3. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 1/23/2018 12:48:45 PM Eastern Standard 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 IB-2-568_PRCA-4-5315_PSO-7-463.zip PRCA_4-5315-TEST-v17.KID Tue Jan 23 16:27:26 2018 UTC
2 IB-2-568_PRCA-4-5315_PSO-7-463.zip PRCA_4-5315-TEST-v17.KID Tue Jan 23 17:42:05 2018 UTC

3.2 Comparison summary

Description Between
Files 1 and 2
Text Blocks Lines
Unchanged 12 52554
Changed 11 22
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   Packman Ma il Message :
  2   ========== ========== =
  3  
  4   $END TXT
  5   $KID PRCA* 4.5*315
  6   **INSTALL  NAME**
  7   PRCA*4.5*3 15
  8   "BLD",1019 1,0)
  9   PRCA*4.5*3 15^ACCOUNT S RECEIVAB LE^0^31801 12^y
  10   "BLD",1019 1,4,0)
  11   ^9.64PA^34 3^3
  12   "BLD",1019 1,4,343,0)
  13   343
  14   "BLD",1019 1,4,343,22 2)
  15   n^n^f^^y^^ y^m^n
  16   "BLD",1019 1,4,430,0)
  17   430
  18   "BLD",1019 1,4,430,2, 0)
  19   ^9.641^430 .0171^2
  20   "BLD",1019 1,4,430,2, 430,0)
  21   ACCOUNTS R ECEIVABLE   (File-top  level)
  22   "BLD",1019 1,4,430,2, 430,1,0)
  23   ^9.6411^15 6^2
  24   "BLD",1019 1,4,430,2, 430,1,156, 0)
  25   ORIGINAL D ATE REFERR ED TO TCSP
  26   "BLD",1019 1,4,430,2, 430,1,301, 0)
  27   RETURNED D ATE
  28   "BLD",1019 1,4,430,2, 430.0171,0 )
  29   CS ADJ TRA NS NUMBER   (sub-file )
  30   "BLD",1019 1,4,430,2, 430.0171,1 ,0)
  31   ^9.6411^.0 1^1
  32   "BLD",1019 1,4,430,2, 430.0171,1 ,.01,0)
  33   CS ADJ TRA NS NUMBER
  34   "BLD",1019 1,4,430,22 2)
  35   y^n^p^^^^n ^^n
  36   "BLD",1019 1,4,430,22 4)
  37  
  38   "BLD",1019 1,4,430.3, 0)
  39   430.3
  40   "BLD",1019 1,4,430.3, 222)
  41   n^n^f^^y^^ y^m^n
  42   "BLD",1019 1,4,"APDD" ,430,430)
  43  
  44   "BLD",1019 1,4,"APDD" ,430,430,1 56)
  45  
  46   "BLD",1019 1,4,"APDD" ,430,430,3 01)
  47  
  48   "BLD",1019 1,4,"APDD" ,430,430.0 171)
  49  
  50   "BLD",1019 1,4,"APDD" ,430,430.0 171,.01)
  51  
  52   "BLD",1019 1,4,"B",34 3,343)
  53  
  54   "BLD",1019 1,4,"B",43 0,430)
  55  
  56   "BLD",1019 1,4,"B",43 0.3,430.3)
  57  
  58   "BLD",1019 1,6.3)
  59   55
  60   "BLD",1019 1,"ABPKG")
  61   n
  62   "BLD",1019 1,"INID")
  63   ^n
  64   "BLD",1019 1,"INIT")
  65   PRCA315P
  66   "BLD",1019 1,"KRN",0)
  67   ^9.67PA^77 9.2^20
  68   "BLD",1019 1,"KRN",.4 ,0)
  69   .4
  70   "BLD",1019 1,"KRN",.4 ,"NM",0)
  71   ^9.68A^^0
  72   "BLD",1019 1,"KRN",.4 01,0)
  73   .401
  74   "BLD",1019 1,"KRN",.4 02,0)
  75   .402
  76   "BLD",1019 1,"KRN",.4 02,"NM",0)
  77   ^9.68A^1^1
  78   "BLD",1019 1,"KRN",.4 02,"NM",1, 0)
  79   PRCAE ADMI N    FILE  #433^433^0
  80   "BLD",1019 1,"KRN",.4 02,"NM","B ","PRCAE A DMIN    FI LE #433",1 )
  81  
  82   "BLD",1019 1,"KRN",.4 03,0)
  83   .403
  84   "BLD",1019 1,"KRN",.5 ,0)
  85   .5
  86   "BLD",1019 1,"KRN",.8 4,0)
  87   .84
  88   "BLD",1019 1,"KRN",3. 6,0)
  89   3.6
  90   "BLD",1019 1,"KRN",3. 8,0)
  91   3.8
  92   "BLD",1019 1,"KRN",9. 2,0)
  93   9.2
  94   "BLD",1019 1,"KRN",9. 8,0)
  95   9.8
  96   "BLD",1019 1,"KRN",9. 8,"NM",0)
  97   ^9.68A^68^ 57
  98   "BLD",1019 1,"KRN",9. 8,"NM",1,0 )
  99   PRCAXP^^0^ B23941725
  100   "BLD",1019 1,"KRN",9. 8,"NM",2,0 )
  101   RCDPRTP^^0 ^B13526370
  102   "BLD",1019 1,"KRN",9. 8,"NM",3,0 )
  103   RCDPRTP0^^ 0^B4734668 8
  104   "BLD",1019 1,"KRN",9. 8,"NM",4,0 )
  105   RCDPRTP2^^ 0^B2078208 7
  106   "BLD",1019 1,"KRN",9. 8,"NM",7,0 )
  107   RCMSITE^^0 ^B10360113
  108   "BLD",1019 1,"KRN",9. 8,"NM",8,0 )
  109   PRCABIL1^^ 0^B5458187 9
  110   "BLD",1019 1,"KRN",9. 8,"NM",9,0 )
  111   PRCABD^^0^ B17322985
  112   "BLD",1019 1,"KRN",9. 8,"NM",10, 0)
  113   RCDPRTEX^^ 0^B5963245 9
  114   "BLD",1019 1,"KRN",9. 8,"NM",11, 0)
  115   PRCAPCL^^0 ^B41751936
  116   "BLD",1019 1,"KRN",9. 8,"NM",12, 0)
  117   RCTCSP1^^0 ^B16928291 6
  118   "BLD",1019 1,"KRN",9. 8,"NM",13, 0)
  119   RCTCSJR^^0 ^B12378887 2
  120   "BLD",1019 1,"KRN",9. 8,"NM",14, 0)
  121   RCTCSP2^^0 ^B13907635 5
  122   "BLD",1019 1,"KRN",9. 8,"NM",15, 0)
  123   RCTCSP4^^0 ^B22343272 5
  124   "BLD",1019 1,"KRN",9. 8,"NM",16, 0)
  125   RCTCSPU^^0 ^B79474233
  126   "BLD",1019 1,"KRN",9. 8,"NM",17, 0)
  127   RCTCSPD^^0 ^B15982560 9
  128   "BLD",1019 1,"KRN",9. 8,"NM",18, 0)
  129   RCTCSPD4^^ 0^B8894296 9
  130   "BLD",1019 1,"KRN",9. 8,"NM",19, 0)
  131   PRCAAPR1^^ 0^B4970733 6
  132   "BLD",1019 1,"KRN",9. 8,"NM",20, 0)
  133   PRCARPM^^0 ^B37026153
  134   "BLD",1019 1,"KRN",9. 8,"NM",21, 0)
  135   RCTCSP5^^0 ^B12274882 2
  136   "BLD",1019 1,"KRN",9. 8,"NM",22, 0)
  137   RCTCSP3^^0 ^B80430487
  138   "BLD",1019 1,"KRN",9. 8,"NM",23, 0)
  139   RCTCSP1A^^ 0^B3836560 2
  140   "BLD",1019 1,"KRN",9. 8,"NM",24, 0)
  141   RCXFMSUF^^ 0^B3876371 7
  142   "BLD",1019 1,"KRN",9. 8,"NM",25, 0)
  143   RCXFMSUR^^ 0^B6350380 9
  144   "BLD",1019 1,"KRN",9. 8,"NM",26, 0)
  145   RCBEADJ^^0 ^B10090241 9
  146   "BLD",1019 1,"KRN",9. 8,"NM",27, 0)
  147   RCTCSWL^^0 ^B15705872 6
  148   "BLD",1019 1,"KRN",9. 8,"NM",28, 0)
  149   RCTCSWL1^^ 0^B5328926 5
  150   "BLD",1019 1,"KRN",9. 8,"NM",29, 0)
  151   RCTCSWL2^^ 0^B2252990 7
  152   "BLD",1019 1,"KRN",9. 8,"NM",31, 0)
  153   RCWROFF^^0 ^B44358365
  154   "BLD",1019 1,"KRN",9. 8,"NM",33, 0)
  155   RCDPBPLI^^ 0^B6000166 9
  156   "BLD",1019 1,"KRN",9. 8,"NM",34, 0)
  157   RCDPBTLM^^ 0^B5228096 7
  158   "BLD",1019 1,"KRN",9. 8,"NM",35, 0)
  159   RCTCSPRS^^ 0^B6092258 2
  160   "BLD",1019 1,"KRN",9. 8,"NM",36, 0)
  161   RCTRAN^^0^ B16424066
  162   "BLD",1019 1,"KRN",9. 8,"NM",37, 0)
  163   PRCAHIS^^0 ^B26002669
  164   "BLD",1019 1,"KRN",9. 8,"NM",38, 0)
  165   RCXFMSUV^^ 0^B1583912 0
  166   "BLD",1019 1,"KRN",9. 8,"NM",42, 0)
  167   PRCACM^^0^ B24617130
  168   "BLD",1019 1,"KRN",9. 8,"NM",43, 0)
  169   RCTOPD^^0^ B71556644
  170   "BLD",1019 1,"KRN",9. 8,"NM",44, 0)
  171   PRCAATR^^0 ^B25086511
  172   "BLD",1019 1,"KRN",9. 8,"NM",45, 0)
  173   RCDPRTP1^^ 0^B4961989 4
  174   "BLD",1019 1,"KRN",9. 8,"NM",46, 0)
  175   PRCARPU^^0 ^B18884689 3
  176   "BLD",1019 1,"KRN",9. 8,"NM",47, 0)
  177   RCDPBPLM^^ 0^B6243697 8
  178   "BLD",1019 1,"KRN",9. 8,"NM",48, 0)
  179   PRCARPS^^0 ^B15642186
  180   "BLD",1019 1,"KRN",9. 8,"NM",49, 0)
  181   RCXFMSPR^^ 0^B3766080 8
  182   "BLD",1019 1,"KRN",9. 8,"NM",50, 0)
  183   RCDPAPL1^^ 0^B9031506 9
  184   "BLD",1019 1,"KRN",9. 8,"NM",51, 0)
  185   PRCABJV^^0 ^B31163592
  186   "BLD",1019 1,"KRN",9. 8,"NM",52, 0)
  187   RCRJRBD^^0 ^B76289018
  188   "BLD",1019 1,"KRN",9. 8,"NM",55, 0)
  189   PRCASVC^^0 ^B11763521
  190   "BLD",1019 1,"KRN",9. 8,"NM",56, 0)
  191   PRCASVC1^^ 0^B1372959
  192   "BLD",1019 1,"KRN",9. 8,"NM",57, 0)
  193   RCBEPAYF^^ 0^B4920689 7
  194   "BLD",1019 1,"KRN",9. 8,"NM",58, 0)
  195   PRCAWO1^^0 ^B20819477
  196   "BLD",1019 1,"KRN",9. 8,"NM",59, 0)
  197   PRCAEXM^^0 ^B13816393
  198   "BLD",1019 1,"KRN",9. 8,"NM",60, 0)
  199   RCTCSPD5^^ 0^B1997104 1
  200   "BLD",1019 1,"KRN",9. 8,"NM",61, 0)
  201   PRCAWREA^^ 0^B2149561 2
  202   "BLD",1019 1,"KRN",9. 8,"NM",62, 0)
  203   PRCAFUT^^0 ^B42447114
  204   "BLD",1019 1,"KRN",9. 8,"NM",63, 0)
  205   PRCACPV^^0 ^B16893124
  206   "BLD",1019 1,"KRN",9. 8,"NM",65, 0)
  207   RCDPAPLI^^ 0^B5395199 8
  208   "BLD",1019 1,"KRN",9. 8,"NM",67, 0)
  209   RCBEUTR1^^ 0^B3777259 3
  210   "BLD",1019 1,"KRN",9. 8,"NM",68, 0)
  211   RCTCSP7^^0 ^B5563240
  212   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCAAPR1 ",19)
  213  
  214   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCAATR" ,44)
  215  
  216   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCABD", 9)
  217  
  218   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCABIL1 ",8)
  219  
  220   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCABJV" ,51)
  221  
  222   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCACM", 42)
  223  
  224   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCACPV" ,63)
  225  
  226   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCAEXM" ,59)
  227  
  228   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCAFUT" ,62)
  229  
  230   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCAHIS" ,37)
  231  
  232   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCAPCL" ,11)
  233  
  234   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCARPM" ,20)
  235  
  236   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCARPS" ,48)
  237  
  238   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCARPU" ,46)
  239  
  240   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCASVC" ,55)
  241  
  242   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCASVC1 ",56)
  243  
  244   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCAWO1" ,58)
  245  
  246   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCAWREA ",61)
  247  
  248   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"PRCAXP", 1)
  249  
  250   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCBEADJ" ,26)
  251  
  252   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCBEPAYF ",57)
  253  
  254   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCBEUTR1 ",67)
  255  
  256   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCDPAPL1 ",50)
  257  
  258   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCDPAPLI ",65)
  259  
  260   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCDPBPLI ",33)
  261  
  262   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCDPBPLM ",47)
  263  
  264   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCDPBTLM ",34)
  265  
  266   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCDPRTEX ",10)
  267  
  268   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCDPRTP" ,2)
  269  
  270   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCDPRTP0 ",3)
  271  
  272   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCDPRTP1 ",45)
  273  
  274   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCDPRTP2 ",4)
  275  
  276   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCMSITE" ,7)
  277  
  278   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCRJRBD" ,52)
  279  
  280   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSJR" ,13)
  281  
  282   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSP1" ,12)
  283  
  284   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSP1A ",23)
  285  
  286   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSP2" ,14)
  287  
  288   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSP3" ,22)
  289  
  290   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSP4" ,15)
  291  
  292   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSP5" ,21)
  293  
  294   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSP7" ,68)
  295  
  296   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSPD" ,17)
  297  
  298   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSPD4 ",18)
  299  
  300   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSPD5 ",60)
  301  
  302   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSPRS ",35)
  303  
  304   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSPU" ,16)
  305  
  306   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSWL" ,27)
  307  
  308   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSWL1 ",28)
  309  
  310   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTCSWL2 ",29)
  311  
  312   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTOPD", 43)
  313  
  314   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCTRAN", 36)
  315  
  316   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCWROFF" ,31)
  317  
  318   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCXFMSPR ",49)
  319  
  320   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCXFMSUF ",24)
  321  
  322   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCXFMSUR ",25)
  323  
  324   "BLD",1019 1,"KRN",9. 8,"NM","B" ,"RCXFMSUV ",38)
  325  
  326   "BLD",1019 1,"KRN",19 ,0)
  327   19
  328   "BLD",1019 1,"KRN",19 ,"NM",0)
  329   ^9.68A^17^ 14
  330   "BLD",1019 1,"KRN",19 ,"NM",4,0)
  331   RCTCSP STO P REACTIVA TE REPORT^ ^0
  332   "BLD",1019 1,"KRN",19 ,"NM",5,0)
  333   RCTCSP REC ALL REPORT ^^0
  334   "BLD",1019 1,"KRN",19 ,"NM",6,0)
  335   RCTCSP MEN U^^0
  336   "BLD",1019 1,"KRN",19 ,"NM",7,0)
  337   RCTCSP BIL L REPORT^^ 0
  338   "BLD",1019 1,"KRN",19 ,"NM",8,0)
  339   RCTCSP REJ ECT REPORT ^^0
  340   "BLD",1019 1,"KRN",19 ,"NM",9,0)
  341   RCTCSP IAI  ERROR COD ES LIST^^0
  342   "BLD",1019 1,"KRN",19 ,"NM",10,0 )
  343   RCTCSP REP ORT^^0
  344   "BLD",1019 1,"KRN",19 ,"NM",11,0 )
  345   RCTCSP REC ONCIL REPO RT^^0
  346   "BLD",1019 1,"KRN",19 ,"NM",12,0 )
  347   RCTCSP REC ALLB^^0
  348   "BLD",1019 1,"KRN",19 ,"NM",13,0 )
  349   RCTCSP REC ALLD^^0
  350   "BLD",1019 1,"KRN",19 ,"NM",14,0 )
  351   RCTCSP STO P^^0
  352   "BLD",1019 1,"KRN",19 ,"NM",15,0 )
  353   PRCAC ENTE R EDIT REP AYMENT^^0
  354   "BLD",1019 1,"KRN",19 ,"NM",16,0 )
  355   RCTCSP REC ONCILIATIO N WORKLIST ^^0
  356   "BLD",1019 1,"KRN",19 ,"NM",17,0 )
  357   RCTCSP IAI  REPORT^^0
  358   "BLD",1019 1,"KRN",19 ,"NM","B", "PRCAC ENT ER EDIT RE PAYMENT",1 5)
  359  
  360   "BLD",1019 1,"KRN",19 ,"NM","B", "RCTCSP BI LL REPORT" ,7)
  361  
  362   "BLD",1019 1,"KRN",19 ,"NM","B", "RCTCSP IA I ERROR CO DES LIST", 9)
  363  
  364   "BLD",1019 1,"KRN",19 ,"NM","B", "RCTCSP IA I REPORT", 17)
  365  
  366   "BLD",1019 1,"KRN",19 ,"NM","B", "RCTCSP ME NU",6)
  367  
  368   "BLD",1019 1,"KRN",19 ,"NM","B", "RCTCSP RE CALL REPOR T",5)
  369  
  370   "BLD",1019 1,"KRN",19 ,"NM","B", "RCTCSP RE CALLB",12)
  371  
  372   "BLD",1019 1,"KRN",19 ,"NM","B", "RCTCSP RE CALLD",13)
  373  
  374   "BLD",1019 1,"KRN",19 ,"NM","B", "RCTCSP RE CONCIL REP ORT",11)
  375  
  376   "BLD",1019 1,"KRN",19 ,"NM","B", "RCTCSP RE CONCILIATI ON WORKLIS T",16)
  377  
  378   "BLD",1019 1,"KRN",19 ,"NM","B", "RCTCSP RE JECT REPOR T",8)
  379  
  380   "BLD",1019 1,"KRN",19 ,"NM","B", "RCTCSP RE PORT",10)
  381  
  382   "BLD",1019 1,"KRN",19 ,"NM","B", "RCTCSP ST OP",14)
  383  
  384   "BLD",1019 1,"KRN",19 ,"NM","B", "RCTCSP ST OP REACTIV ATE REPORT ",4)
  385  
  386   "BLD",1019 1,"KRN",19 .1,0)
  387   19.1
  388   "BLD",1019 1,"KRN",19 .1,"NM",0)
  389   ^9.68A^1^1
  390   "BLD",1019 1,"KRN",19 .1,"NM",1, 0)
  391   PRCAF LATE  CHARGES^^ 0
  392   "BLD",1019 1,"KRN",19 .1,"NM","B ","PRCAF L ATE CHARGE S",1)
  393  
  394   "BLD",1019 1,"KRN",10 1,0)
  395   101
  396   "BLD",1019 1,"KRN",10 1,"NM",0)
  397   ^9.68A^58^ 25
  398   "BLD",1019 1,"KRN",10 1,"NM",19, 0)
  399   PRCA TCSP  WORKLIST A CCOUNT PRO FILE^^0
  400   "BLD",1019 1,"KRN",10 1,"NM",21, 0)
  401   PRCA TCSP  WORKLIST E XPAND^^0
  402   "BLD",1019 1,"KRN",10 1,"NM",23, 0)
  403   PRCA TCSP  WORKLIST I NSURANCE^^ 0
  404   "BLD",1019 1,"KRN",10 1,"NM",24, 0)
  405   PRCA TCSP  WORKLIST M ENU^^0
  406   "BLD",1019 1,"KRN",10 1,"NM",25, 0)
  407   PRCA TCSP  WORKLIST P RINT STATE MENT^^0
  408   "BLD",1019 1,"KRN",10 1,"NM",26, 0)
  409   PRCA TCSP  WORKLIST R EMOVE^^0
  410   "BLD",1019 1,"KRN",10 1,"NM",27, 0)
  411   PRCA TCSP  WORKLIST V IEW PATIEN T^^0
  412   "BLD",1019 1,"KRN",10 1,"NM",31, 0)
  413   PRCA TCSP  ACCOUNT PR OFILE MENU ^^0
  414   "BLD",1019 1,"KRN",10 1,"NM",36, 0)
  415   PRCA TCSP  WORKLIST E XPAND MENU  PROTOCOL^ ^0
  416   "BLD",1019 1,"KRN",10 1,"NM",37, 0)
  417   RCDP ACCOU NT PROFILE  SELECT NE W ACCOUNT^ ^4^
  418   "BLD",1019 1,"KRN",10 1,"NM",38, 0)
  419   RCDP ACCOU NT PROFILE  BILL TRAN SACTIONS^^ 4^
  420   "BLD",1019 1,"KRN",10 1,"NM",39, 0)
  421   RCDP ACCOU NT PROFILE  SELECT ST ATUS^^4^
  422   "BLD",1019 1,"KRN",10 1,"NM",40, 0)
  423   RCDP FAST  EXIT^^4^
  424   "BLD",1019 1,"KRN",10 1,"NM",43, 0)
  425   RCDP ACCOU NT PROFILE  BILL PROF ILE^^4^
  426   "BLD",1019 1,"KRN",10 1,"NM",47, 0)
  427   RCDP ACCT  PROFILE ST OP^^0
  428   "BLD",1019 1,"KRN",10 1,"NM",48, 0)
  429   RCDP ACCT  PROFILE TE RM FISCAL^ ^0
  430   "BLD",1019 1,"KRN",10 1,"NM",49, 0)
  431   RCDP ACCT  PROFILE RE CALL BILL^ ^0
  432   "BLD",1019 1,"KRN",10 1,"NM",50, 0)
  433   RCDP ACCT  PROFILE RE CALL DEBTO R^^0
  434   "BLD",1019 1,"KRN",10 1,"NM",51, 0)
  435   RCDP ACCT  PROFILE DE CREASE TRA NS^^0
  436   "BLD",1019 1,"KRN",10 1,"NM",52, 0)
  437   RCDP ACCT  PROFILE IN CREASE TRA NS^^0
  438   "BLD",1019 1,"KRN",10 1,"NM",53, 0)
  439   RCDP ACCT  PROFILE SU SPEND^^0
  440   "BLD",1019 1,"KRN",10 1,"NM",55, 0)
  441   VALM BLANK  5^^4^
  442   "BLD",1019 1,"KRN",10 1,"NM",56, 0)
  443   VALM BLANK  6^^4^
  444   "BLD",1019 1,"KRN",10 1,"NM",57, 0)
  445   PRCA TCSP  WORKLIST C ANCEL/EDIT /ADD^^0
  446   "BLD",1019 1,"KRN",10 1,"NM",58, 0)
  447   RCDP ACCT  PROFILE RE -ESTABLISH ^^0
  448   "BLD",1019 1,"KRN",10 1,"NM","B" ,"PRCA TCS P ACCOUNT  PROFILE ME NU",31)
  449  
  450   "BLD",1019 1,"KRN",10 1,"NM","B" ,"PRCA TCS P WORKLIST  ACCOUNT P ROFILE",19 )
  451  
  452   "BLD",1019 1,"KRN",10 1,"NM","B" ,"PRCA TCS P WORKLIST  CANCEL/ED IT/ADD",57 )
  453  
  454   "BLD",1019 1,"KRN",10 1,"NM","B" ,"PRCA TCS P WORKLIST  EXPAND",2 1)
  455  
  456   "BLD",1019 1,"KRN",10 1,"NM","B" ,"PRCA TCS P WORKLIST  EXPAND ME NU PROTOCO L",36)
  457  
  458   "BLD",1019 1,"KRN",10 1,"NM","B" ,"PRCA TCS P WORKLIST  INSURANCE ",23)
  459  
  460   "BLD",1019 1,"KRN",10 1,"NM","B" ,"PRCA TCS P WORKLIST  MENU",24)
  461  
  462   "BLD",1019 1,"KRN",10 1,"NM","B" ,"PRCA TCS P WORKLIST  PRINT STA TEMENT",25 )
  463  
  464   "BLD",1019 1,"KRN",10 1,"NM","B" ,"PRCA TCS P WORKLIST  REMOVE",2 6)
  465  
  466   "BLD",1019 1,"KRN",10 1,"NM","B" ,"PRCA TCS P WORKLIST  VIEW PATI ENT",27)
  467  
  468   "BLD",1019 1,"KRN",10 1,"NM","B" ,"RCDP ACC OUNT PROFI LE BILL PR OFILE",43)
  469  
  470   "BLD",1019 1,"KRN",10 1,"NM","B" ,"RCDP ACC OUNT PROFI LE BILL TR ANSACTIONS ",38)
  471  
  472   "BLD",1019 1,"KRN",10 1,"NM","B" ,"RCDP ACC OUNT PROFI LE SELECT  NEW ACCOUN T",37)
  473  
  474   "BLD",1019 1,"KRN",10 1,"NM","B" ,"RCDP ACC OUNT PROFI LE SELECT  STATUS",39 )
  475  
  476   "BLD",1019 1,"KRN",10 1,"NM","B" ,"RCDP ACC T PROFILE  DECREASE T RANS",51)
  477  
  478   "BLD",1019 1,"KRN",10 1,"NM","B" ,"RCDP ACC T PROFILE  INCREASE T RANS",52)
  479  
  480   "BLD",1019 1,"KRN",10 1,"NM","B" ,"RCDP ACC T PROFILE  RE-ESTABLI SH",58)
  481  
  482   "BLD",1019 1,"KRN",10 1,"NM","B" ,"RCDP ACC T PROFILE  RECALL BIL L",49)
  483  
  484   "BLD",1019 1,"KRN",10 1,"NM","B" ,"RCDP ACC T PROFILE  RECALL DEB TOR",50)
  485  
  486   "BLD",1019 1,"KRN",10 1,"NM","B" ,"RCDP ACC T PROFILE  STOP",47)
  487  
  488   "BLD",1019 1,"KRN",10 1,"NM","B" ,"RCDP ACC T PROFILE  SUSPEND",5 3)
  489  
  490   "BLD",1019 1,"KRN",10 1,"NM","B" ,"RCDP ACC T PROFILE  TERM FISCA L",48)
  491  
  492   "BLD",1019 1,"KRN",10 1,"NM","B" ,"RCDP FAS T EXIT",40 )
  493  
  494   "BLD",1019 1,"KRN",10 1,"NM","B" ,"VALM BLA NK 5",55)
  495  
  496   "BLD",1019 1,"KRN",10 1,"NM","B" ,"VALM BLA NK 6",56)
  497  
  498   "BLD",1019 1,"KRN",40 9.61,0)
  499   409.61
  500   "BLD",1019 1,"KRN",40 9.61,"NM", 0)
  501   ^9.68A^6^4
  502   "BLD",1019 1,"KRN",40 9.61,"NM", 1,0)
  503   RCTCSP WOR KLIST^^0
  504   "BLD",1019 1,"KRN",40 9.61,"NM", 2,0)
  505   RCTCSP WOR KLIST EXPA ND^^0
  506   "BLD",1019 1,"KRN",40 9.61,"NM", 5,0)
  507   PRCA TCSP  ACCOUNT PR OFILE^^0
  508   "BLD",1019 1,"KRN",40 9.61,"NM", 6,0)
  509   RCDP ACCOU NT PROFILE ^^0
  510   "BLD",1019 1,"KRN",40 9.61,"NM", "B","PRCA  TCSP ACCOU NT PROFILE ",5)
  511  
  512   "BLD",1019 1,"KRN",40 9.61,"NM", "B","RCDP  ACCOUNT PR OFILE",6)
  513  
  514   "BLD",1019 1,"KRN",40 9.61,"NM", "B","RCTCS P WORKLIST ",1)
  515  
  516   "BLD",1019 1,"KRN",40 9.61,"NM", "B","RCTCS P WORKLIST  EXPAND",2 )
  517  
  518   "BLD",1019 1,"KRN",77 1,0)
  519   771
  520   "BLD",1019 1,"KRN",77 1,"NM",0)
  521   ^9.68A^^
  522   "BLD",1019 1,"KRN",77 9.2,0)
  523   779.2
  524   "BLD",1019 1,"KRN",87 0,0)
  525   870
  526   "BLD",1019 1,"KRN",89 89.51,0)
  527   8989.51
  528   "BLD",1019 1,"KRN",89 89.52,0)
  529   8989.52
  530   "BLD",1019 1,"KRN",89 94,0)
  531   8994
  532   "BLD",1019 1,"KRN","B ",.4,.4)
  533  
  534   "BLD",1019 1,"KRN","B ",.401,.40 1)
  535  
  536   "BLD",1019 1,"KRN","B ",.402,.40 2)
  537  
  538   "BLD",1019 1,"KRN","B ",.403,.40 3)
  539  
  540   "BLD",1019 1,"KRN","B ",.5,.5)
  541  
  542   "BLD",1019 1,"KRN","B ",.84,.84)
  543  
  544   "BLD",1019 1,"KRN","B ",3.6,3.6)
  545  
  546   "BLD",1019 1,"KRN","B ",3.8,3.8)
  547  
  548   "BLD",1019 1,"KRN","B ",9.2,9.2)
  549  
  550   "BLD",1019 1,"KRN","B ",9.8,9.8)
  551  
  552   "BLD",1019 1,"KRN","B ",19,19)
  553  
  554   "BLD",1019 1,"KRN","B ",19.1,19. 1)
  555  
  556   "BLD",1019 1,"KRN","B ",101,101)
  557  
  558   "BLD",1019 1,"KRN","B ",409.61,4 09.61)
  559  
  560   "BLD",1019 1,"KRN","B ",771,771)
  561  
  562   "BLD",1019 1,"KRN","B ",779.2,77 9.2)
  563  
  564   "BLD",1019 1,"KRN","B ",870,870)
  565  
  566   "BLD",1019 1,"KRN","B ",8989.51, 8989.51)
  567  
  568   "BLD",1019 1,"KRN","B ",8989.52, 8989.52)
  569  
  570   "BLD",1019 1,"KRN","B ",8994,899 4)
  571  
  572   "BLD",1019 1,"QDEF")
  573   ^^^^NO^^^^ YES^^NO
  574   "BLD",1019 1,"QUES",0 )
  575   ^9.62^^
  576   "BLD",1019 1,"REQB",0 )
  577   ^9.611^13^ 10
  578   "BLD",1019 1,"REQB",2 ,0)
  579   PRCA*4.5*1 03^2
  580   "BLD",1019 1,"REQB",3 ,0)
  581   PRCA*4.5*1 51^1
  582   "BLD",1019 1,"REQB",4 ,0)
  583   PRCA*4.5*1 86^1
  584   "BLD",1019 1,"REQB",5 ,0)
  585   PRCA*4.5*2 76^1
  586   "BLD",1019 1,"REQB",7 ,0)
  587   PRCA*4.5*2 33^1
  588   "BLD",1019 1,"REQB",9 ,0)
  589   PRCA*4.5*3 20^1
  590   "BLD",1019 1,"REQB",1 0,0)
  591   PRCA*4.5*3 25^1
  592   "BLD",1019 1,"REQB",1 1,0)
  593   PRCA*4.5*3 27^1
  594   "BLD",1019 1,"REQB",1 2,0)
  595   PRCA*4.5*3 18^1
  596   "BLD",1019 1,"REQB",1 3,0)
  597   PRCA*4.5*3 31^1
  598   "BLD",1019 1,"REQB"," B","PRCA*4 .5*103",2)
  599  
  600   "BLD",1019 1,"REQB"," B","PRCA*4 .5*151",3)
  601  
  602   "BLD",1019 1,"REQB"," B","PRCA*4 .5*186",4)
  603  
  604   "BLD",1019 1,"REQB"," B","PRCA*4 .5*233",7)
  605  
  606   "BLD",1019 1,"REQB"," B","PRCA*4 .5*276",5)
  607  
  608   "BLD",1019 1,"REQB"," B","PRCA*4 .5*318",12 )
  609  
  610   "BLD",1019 1,"REQB"," B","PRCA*4 .5*320",9)
  611  
  612   "BLD",1019 1,"REQB"," B","PRCA*4 .5*325",10 )
  613  
  614   "BLD",1019 1,"REQB"," B","PRCA*4 .5*327",11 )
  615  
  616   "BLD",1019 1,"REQB"," B","PRCA*4 .5*331",13 )
  617  
  618   "DATA",343 ,1,0)
  619   FL 4-480
  620   "DATA",343 ,1,1,0)
  621   187^^193^1 93^2931014 ^^^^
  622   "DATA",343 ,1,1,1,0)
  623   NOTICE OF  INDEBTEDNE SS:  Accor ding to ou r records,  you are i ndebted to
  624   "DATA",343 ,1,1,2,0)
  625   the United  States fo r $|PRCA B ALANCE|.   For a comp lete break down of
  626   "DATA",343 ,1,1,3,0)
  627   this amoun t, see the  enclosed  Statement  of Charges  for Medic al Care.
  628   "DATA",343 ,1,1,4,0)
  629   This indeb tedness wa s caused b y |PRCA RE SULTING|.
  630   "DATA",343 ,1,1,5,0)
  631     
  632   "DATA",343 ,1,1,6,0)
  633   You can ap peal this  decision a s explaine d on the e nclosed VA  Form 1-41 07
  634   "DATA",343 ,1,1,7,0)
  635   Notice of  Procedural  and Appel late Right s.
  636   "DATA",343 ,1,1,8,0)
  637   Debts bein g repaid b y installm ents will  be charged  interest  at an annu al
  638   "DATA",343 ,1,1,9,0)
  639   rate of |P RCA INTERE ST|%.  A m onthly col lecting fe e of $|PRC A ADMIN|
  640   "DATA",343 ,1,1,10,0)
  641   (subject t o change a nnually) m ay also be  charged.   If full p ayment of  the
  642   "DATA",343 ,1,1,11,0)
  643   debt is re ceived wit hin 30 day s, no inte rest or ad ministrati ve cost of
  644   "DATA",343 ,1,1,12,0)
  645   collection  fees will  be charge d and any  future ben efit payme nts will n ot
  646   "DATA",343 ,1,1,13,0)
  647   be withhel d.
  648   "DATA",343 ,1,1,14,0)
  649     
  650   "DATA",343 ,1,1,15,0)
  651   NOTICE OF  RIGHTS:  I f you do n ot believe  you owe t his debt o r you thin k
  652   "DATA",343 ,1,1,16,0)
  653   the amount  is incorr ect, you h ave a righ t to dispu te the deb t.  You al so
  654   "DATA",343 ,1,1,17,0)
  655   have the r ight to re quest a wa iver of th e debt and  the right  to an ora l
  656   "DATA",343 ,1,1,18,0)
  657   hearing on  the waive r request.   Waiver m eans that  you will n ot have to
  658   "DATA",343 ,1,1,19,0)
  659   pay the de bt.  A wai ver can on ly be gran ted if you  were not  at
  660   "DATA",343 ,1,1,20,0)
  661   fault in c ausing the  indebtedn ess or if  any fault  on your pa rt is
  662   "DATA",343 ,1,1,21,0)
  663   excusable,  and if pa yment of t he debt wo uld cause  a hardship .
  664   "DATA",343 ,1,1,22,0)
  665   Current or  future be nefit paym ents, if a ny, are su bject to w ithholding
  666   "DATA",343 ,1,1,23,0)
  667   unless you  notify th is office,  in writin g, within  30 days fr om the
  668   "DATA",343 ,1,1,24,0)
  669   date of th is letter  that you w ish to dis pute the e xistence o r amount
  670   "DATA",343 ,1,1,25,0)
  671   of the deb t or reque st a waive r. You may  do both.  You may ha ve an oral
  672   "DATA",343 ,1,1,26,0)
  673   hearing in  connectio n with you r waiver r equest bef ore a waiv er decisio n
  674   "DATA",343 ,1,1,27,0)
  675   is made if  you reque st the hea ring withi n the 30-d ay period.
  676   "DATA",343 ,1,1,28,0)
  677   Additional  informati on concern ing these  rights is  provided o n the encl osed
  678   "DATA",343 ,1,1,29,0)
  679   Notice of  Rights and  Obligatio ns.  Pleas e read it  carefully.
  680   "DATA",343 ,1,1,30,0)
  681     
  682   "DATA",343 ,1,1,31,0)
  683   REPAYMENT  PLAN: Rega rdless of  whether yo u dispute  the debt o r request
  684   "DATA",343 ,1,1,32,0)
  685   waiver, if  you canno t repay th is debt in  full, you  should co ntact us
  686   "DATA",343 ,1,1,33,0)
  687   within 30  days from  the date o f this let ter to wor k out a sa tisfactory
  688   "DATA",343 ,1,1,34,0)
  689   repayment  plan.
  690   "DATA",343 ,1,1,35,0)
  691     
  692   "DATA",343 ,1,1,36,0)
  693   Please mak e your che ck or mone y order pa yable to t he Departm ent of
  694   "DATA",343 ,1,1,37,0)
  695   Veterans A ffairs and  send it t o the addr ess on the  enclosed  VA Form
  696   "DATA",343 ,1,1,38,0)
  697   10-9014 al ong with t he bottom  portion of  this lett er. Please  include
  698   "DATA",343 ,1,1,39,0)
  699   your full  name and f ile number /SSAN on y our check  or money o rder to
  700   "DATA",343 ,1,1,40,0)
  701   insure pro per credit .
  702   "DATA",343 ,1,1,41,0)
  703     
  704   "DATA",343 ,1,1,42,0)
  705   If you hav e any ques tions conc erning thi s letter,  please con tact this
  706   "DATA",343 ,1,1,43,0)
  707   office for  assistanc e.
  708   "DATA",343 ,1,1,44,0)
  709     
  710   "DATA",343 ,1,1,45,0)
  711   Finance Of ficer
  712   "DATA",343 ,1,1,46,0)
  713   |TOP|
  714   "DATA",343 ,1,1,47,0)
  715     
  716   "DATA",343 ,1,1,48,0)
  717                         NOTICE OF  RIGHTS AND  OBLIGATIO NS
  718   "DATA",343 ,1,1,49,0)
  719     
  720   "DATA",343 ,1,1,50,0)
  721   DEBTS OWED  THE UNITE D STATES G OVERNMENT:   The law  requires t he Departm ent of
  722   "DATA",343 ,1,1,51,0)
  723   Veterans A ffairs (VA ) to colle ct debts o wed the go vernment f or medical  care.
  724   "DATA",343 ,1,1,52,0)
  725   When the i ndividual  is entitle d to benef it payment s, the VA  is require d to
  726   "DATA",343 ,1,1,53,0)
  727   collect th e debt by  withholdin g future b enefit pay ments unti l the debt  is
  728   "DATA",343 ,1,1,54,0)
  729   paid, exce pt as expl ained belo w.  Any cu rrent or f uture VA b enefit pay ments,
  730   "DATA",343 ,1,1,55,0)
  731   federal sa lary, lump  sum or re tirement p ayments, i nsurance d ividends o r
  732   "DATA",343 ,1,1,56,0)
  733   other paym ents made  under any  law admini stered by  the VA may  be withhe ld.
  734   "DATA",343 ,1,1,57,0)
  735     
  736   "DATA",343 ,1,1,58,0)
  737   NOTE:  Whe never this  letter st ates that  you have a  period of  time to t ake
  738   "DATA",343 ,1,1,59,0)
  739   some actio n or to no tify us, t he period  of time be gins to ru n from the  date
  740   "DATA",343 ,1,1,60,0)
  741   appearing  on the fro nt of this  letter.
  742   "DATA",343 ,1,1,61,0)
  743     
  744   "DATA",343 ,1,1,62,0)
  745     
  746   "DATA",343 ,1,1,63,0)
  747     
  748   "DATA",343 ,1,1,64,0)
  749     
  750   "DATA",343 ,1,1,65,0)
  751     
  752   "DATA",343 ,1,1,66,0)
  753   RIGHT TO D ISPUTE THE  EXISTENCE  OR AMOUNT  OF THE DE BT:  If yo u tell us  in
  754   "DATA",343 ,1,1,67,0)
  755   writing wi thin 30 da ys that yo u believe  that you d o not owe  this debt  or
  756   "DATA",343 ,1,1,68,0)
  757   that the a mount is i ncorrect,  we will no t withhold  any curre nt or futu re
  758   "DATA",343 ,1,1,69,0)
  759   benefit pa yments unt il we conf irm that y ou do owe  this debt  and the am ount
  760   "DATA",343 ,1,1,70,0)
  761   is correct  or we det ermine tha t the dela y required  to resolv e the disp ute
  762   "DATA",343 ,1,1,71,0)
  763   will jeopa rdize our  ability to  collect t he full am ount of th e debt.  Y ou
  764   "DATA",343 ,1,1,72,0)
  765   should exp lain to th e extent y ou can why  you belie ve you do  not owe th e debt
  766   "DATA",343 ,1,1,73,0)
  767   or why the  amount is  incorrect .  If our  determinat ion of the  dispute i s
  768   "DATA",343 ,1,1,74,0)
  769   unfavorabl e to you,  we will co nsider you r statemen t notifyin g us of th e
  770   "DATA",343 ,1,1,75,0)
  771   dispute to  be a Noti ce of Disa greement w ith the de cision tha t you have  an
  772   "DATA",343 ,1,1,76,0)
  773   indebtedne ss as desc ribed in t he enclose d VA Form  1-4107, No tice of
  774   "DATA",343 ,1,1,77,0)
  775   Procedural  and Appel late Right s.
  776   "DATA",343 ,1,1,78,0)
  777     
  778   "DATA",343 ,1,1,79,0)
  779   RIGHT TO R EQUEST WAI VER OF THE  DEBT:  Un der certai n circumst ances, we  can
  780   "DATA",343 ,1,1,80,0)
  781   waive the  debt.  Thi s means th at you wil l not be r equired to  pay the a mount
  782   "DATA",343 ,1,1,81,0)
  783   owed.  You  are remin ded that a  discharge  of indebt edness, su ch as a wa iver,
  784   "DATA",343 ,1,1,82,0)
  785   is conside red taxabl e income a nd must be  reported  by you to  the Intern al
  786   "DATA",343 ,1,1,83,0)
  787   Revenue Se rvice (IRS ).  A repo rt of this  waiver wi ll be prov ided by th e
  788   "DATA",343 ,1,1,84,0)
  789   Department  of Vetera ns Affairs  to the In ternal Rev enue Servi ce in acco rdance
  790   "DATA",343 ,1,1,85,0)
  791   with IRS r egulations .
  792   "DATA",343 ,1,1,86,0)
  793     
  794   "DATA",343 ,1,1,87,0)
  795   To be cons idered for  waiver, y ou must wr ite to us  and reques t one.  Yo u
  796   "DATA",343 ,1,1,88,0)
  797   should exp lain why t he debt wa s not your  fault or  why any fa ult on you r part
  798   "DATA",343 ,1,1,89,0)
  799   should be  excused.   If you req uest a wai ver, we wi ll ask you  for finan cial
  800   "DATA",343 ,1,1,90,0)
  801   informatio n to deter mine hards hip.  Hard ship is co nsidered o nly if we  find
  802   "DATA",343 ,1,1,91,0)
  803   that you w ere not at  fault or  that your  fault was  excusable.
  804   "DATA",343 ,1,1,92,0)
  805     
  806   "DATA",343 ,1,1,93,0)
  807   If we do n ot receive  your waiv er request  within 30  days, we  will begin  to
  808   "DATA",343 ,1,1,94,0)
  809   withhold a ny current  or future  benefit p ayments as  explained  in the co vering
  810   "DATA",343 ,1,1,95,0)
  811   letter.  I f you do n ot request  a waiver  within 30  days, you  may still  do so
  812   "DATA",343 ,1,1,96,0)
  813   at any tim e within t wo years.   Withholdi ng of your  future be nefit paym ents
  814   "DATA",343 ,1,1,97,0)
  815   will conti nue, howev er, during  our consi deration o f your req uest.  Any
  816   "DATA",343 ,1,1,98,0)
  817   withheld a mount whic h is waive d will be  refunded.
  818   "DATA",343 ,1,1,99,0)
  819     
  820   "DATA",343 ,1,1,100,0 )
  821   NOTE:  You  can both  dispute th e debt and  request w aiver in t he same le tter
  822   "DATA",343 ,1,1,101,0 )
  823   if you wis h.
  824   "DATA",343 ,1,1,102,0 )
  825    
  826   "DATA",343 ,1,1,103,0 )
  827   |TOP|
  828   "DATA",343 ,1,1,104,0 )
  829     
  830   "DATA",343 ,1,1,105,0 )
  831   ORAL HEARI NG ON WAIV ER REQUEST :  You may  request a n oral hea ring to pr esent
  832   "DATA",343 ,1,1,106,0 )
  833   evidence o r argument  on any po int in con nection wi th your wa iver reque st.
  834   "DATA",343 ,1,1,107,0 )
  835   If you des ire a hear ing, you s hould requ est it at  the same t ime that y ou
  836   "DATA",343 ,1,1,108,0 )
  837   submit you r written  request fo r waiver s o that we  can schedu le a heari ng
  838   "DATA",343 ,1,1,109,0 )
  839   before any  decision  is made.   If you do  not reques t an oral  hearing on  your
  840   "DATA",343 ,1,1,110,0 )
  841   waiver req uest withi n 30 days,  we will b egin to wi thhold you r future b enefit
  842   "DATA",343 ,1,1,111,0 )
  843   payments a fter the w aiver deci sion, if u nfavorable , is made.   We will  notify
  844   "DATA",343 ,1,1,112,0 )
  845   you of the  date and  time when  the hearin g will be  held.  You  may bring
  846   "DATA",343 ,1,1,113,0 )
  847   witnesses  to the hea ring.  All  testimony  will be e ntered int o the reco rd.
  848   "DATA",343 ,1,1,114,0 )
  849   The VA wil l furnish  a hearing  room, prov ide hearin g official s, and pre pare a
  850   "DATA",343 ,1,1,115,0 )
  851   written tr anscript o f the proc eedings.   The VA can not bear a ny other e xpense
  852   "DATA",343 ,1,1,116,0 )
  853   of the hea ring.
  854   "DATA",343 ,1,1,117,0 )
  855     
  856   "DATA",343 ,1,1,118,0 )
  857     
  858   "DATA",343 ,1,1,119,0 )
  859     
  860   "DATA",343 ,1,1,120,0 )
  861     
  862   "DATA",343 ,1,1,121,0 )
  863     
  864   "DATA",343 ,1,1,122,0 )
  865     
  866   "DATA",343 ,1,1,123,0 )
  867     
  868   "DATA",343 ,1,1,124,0 )
  869   ADMINISTRA TIVE COST  OF COLLECT ION FEES:  The monthl y administ rative cos t of
  870   "DATA",343 ,1,1,125,0 )
  871   collection  fee will  not be add ed to your  debt if,  within 30  days, full
  872   "DATA",343 ,1,1,126,0 )
  873   payment of  the debt  is receive d or an ac ceptable r epayment p lan is wor ked
  874   "DATA",343 ,1,1,127,0 )
  875   out.  If a n installm ent repaym ent plan i s worked o ut and any  installme nt is
  876   "DATA",343 ,1,1,128,0 )
  877   not receiv ed by the  due date,  the monthl y administ rative cos t of colle ction
  878   "DATA",343 ,1,1,129,0 )
  879   fee will t hereafter  be charged  for the l ife of the  debt.  Ot her costs  of
  880   "DATA",343 ,1,1,130,0 )
  881   collection  may also  be added t o the debt  if additi onal colle ction acti ons
  882   "DATA",343 ,1,1,131,0 )
  883   become nec essary.
  884   "DATA",343 ,1,1,132,0 )
  885     
  886   "DATA",343 ,1,1,133,0 )
  887   REPRESENTA TION:  You  may be re presented,  without c harge, by  an accredi ted
  888   "DATA",343 ,1,1,134,0 )
  889   representa tive of a  veterans'  organizati on or othe r service  organizati on
  890   "DATA",343 ,1,1,135,0 )
  891   recognized  by the Ad ministrato r of Veter ans Affair s.  You ma y employ a n
  892   "DATA",343 ,1,1,136,0 )
  893   attorney t o assist y ou, for ex ample, an  attorney i n private  practice o r a
  894   "DATA",343 ,1,1,137,0 )
  895   legal aid  attorney.   The servi ce of an a ttorney re presenting  you in
  896   "DATA",343 ,1,1,138,0 )
  897   adjudicato ry proceed ings befor e VA are s ubject to  a fee limi tation as  set
  898   "DATA",343 ,1,1,139,0 )
  899   forth in 3 8 U.S.C. 5 904.  If y ou desire  representa tion, and  have not a lready
  900   "DATA",343 ,1,1,140,0 )
  901   designated  a represe ntative, l et us know  and we wi ll send yo u the nece ssary
  902   "DATA",343 ,1,1,141,0 )
  903   forms.
  904   "DATA",343 ,1,1,142,0 )
  905     
  906   "DATA",343 ,1,1,143,0 )
  907                     NOT ICE OF PRO CEDURAL AN D APPELLAT E RIGHTS
  908   "DATA",343 ,1,1,144,0 )
  909     
  910   "DATA",343 ,1,1,145,0 )
  911   We have ba sed our de cision on  the eviden ce of reco rd in your  case and  the
  912   "DATA",343 ,1,1,146,0 )
  913   applicable  law.  Thi s explains  your proc edural and  appellate  rights in
  914   "DATA",343 ,1,1,147,0 )
  915   connection  with this  decision.
  916   "DATA",343 ,1,1,148,0 )
  917     
  918   "DATA",343 ,1,1,149,0 )
  919   REPRESENTA TION.  You  may be re presented,  without c harge, by  an accredi ted
  920   "DATA",343 ,1,1,150,0 )
  921   representa tive of a  veterans o rganizatio n or other  service o rganizatio n
  922   "DATA",343 ,1,1,151,0 )
  923   recognized  by the Ad ministrato r of Veter ans Affair s, or you  may employ  an
  924   "DATA",343 ,1,1,152,0 )
  925   attorney t o assist y ou with yo ur claim.   Typical e xamples of  counsel w ho may
  926   "DATA",343 ,1,1,153,0 )
  927   be availab le include  attorneys  in privat e practice  or legal  aid servic es.
  928   "DATA",343 ,1,1,154,0 )
  929   The servic e of an at torney rep resenting  you in adj udicatory  proceeding s
  930   "DATA",343 ,1,1,155,0 )
  931   before VA  are subjec t to a fee  limitatio n as set f orth in 38  U.S.C. 59 04.
  932   "DATA",343 ,1,1,156,0 )
  933   If you des ire repres entation,  let us kno w and we w ill send y ou the nec essary
  934   "DATA",343 ,1,1,157,0 )
  935   forms.  If  you have  already de signated a  represent ative, no  further ac tion
  936   "DATA",343 ,1,1,158,0 )
  937   on your pa rt is requ ired.
  938   "DATA",343 ,1,1,159,0 )
  939     
  940   "DATA",343 ,1,1,160,0 )
  941   NEW EVIDEN CE.  You m ay submit  additional  evidence  to strengt hen your c laim.
  942   "DATA",343 ,1,1,161,0 )
  943   It is in y our intere st to send  us any ne w evidence  as prompt ly as poss ible.
  944   "DATA",343 ,1,1,162,0 )
  945   We will ca refully co nsider it  and let yo u know whe ther it ch anges our
  946   "DATA",343 ,1,1,163,0 )
  947   decision.
  948   "DATA",343 ,1,1,164,0 )
  949     
  950   "DATA",343 ,1,1,165,0 )
  951   |TOP|
  952   "DATA",343 ,1,1,166,0 )
  953     
  954   "DATA",343 ,1,1,167,0 )
  955   PERSONAL H EARING.  I f you desi re a perso nal hearin g to prese nt evidenc e or
  956   "DATA",343 ,1,1,168,0 )
  957   argument o n any poin t of impor tance in y our claim,  notify th is office  and we
  958   "DATA",343 ,1,1,169,0 )
  959   will arran ge a time  and place  for the he aring.  Yo u may brin g witnesse s if
  960   "DATA",343 ,1,1,170,0 )
  961   you desire  and their  testimony  will be e ntered in  the record .  The VA  will
  962   "DATA",343 ,1,1,171,0 )
  963   furnish th e hearing  room, prov ide hearin g official s, and pre pare the
  964   "DATA",343 ,1,1,172,0 )
  965   transcript  of the pr oceedings.   The VA c annot pay  any other  expenses o f the
  966   "DATA",343 ,1,1,173,0 )
  967   hearing, s ince a per sonal hear ing is not  required.
  968   "DATA",343 ,1,1,174,0 )
  969     
  970   "DATA",343 ,1,1,175,0 )
  971     
  972   "DATA",343 ,1,1,176,0 )
  973     
  974   "DATA",343 ,1,1,177,0 )
  975     
  976   "DATA",343 ,1,1,178,0 )
  977     
  978   "DATA",343 ,1,1,179,0 )
  979     
  980   "DATA",343 ,1,1,180,0 )
  981     
  982   "DATA",343 ,1,1,181,0 )
  983     
  984   "DATA",343 ,1,1,182,0 )
  985     
  986   "DATA",343 ,1,1,183,0 )
  987   APPEAL.  Y ou may app eal our de cision to  the Board  of Veteran s Appeals  at any
  988   "DATA",343 ,1,1,184,0 )
  989   time withi n one year  from the  date of th is letter  if you bel ieve the
  990   "DATA",343 ,1,1,185,0 )
  991   decision i s not in a ccord with  the law a nd the fac ts now of  record.  Y ou can
  992   "DATA",343 ,1,1,186,0 )
  993   start the  appeal pro cess by fi lling a No tice of Di sagreement .  You may  do
  994   "DATA",343 ,1,1,187,0 )
  995   this by wr iting a le tter to th is office  stating th at you wis h to appea l.  If
  996   "DATA",343 ,1,1,188,0 )
  997   more than  one benefi t is invol ved, you s hould iden tify the b enefit or
  998   "DATA",343 ,1,1,189,0 )
  999   benefits f or which y ou are app ealing.  I f you deci de to appe al, we wil l
  1000   "DATA",343 ,1,1,190,0 )
  1001   advise you  further a s to your  procedural  rights as  your clai m progress es
  1002   "DATA",343 ,1,1,191,0 )
  1003   through th e several  stages of  the appeal  process.
  1004   "DATA",343 ,1,1,192,0 )
  1005     
  1006   "DATA",343 ,1,1,193,0 )
  1007   NOTE:  For  further i nformation  about app eals, see  VA Pamphle t 1-1.
  1008   "DATA",343 ,1,2)
  1009   Ineligible  Hospital  (1FU)
  1010   "DATA",343 ,2,0)
  1011   FL 4-481
  1012   "DATA",343 ,2,1,0)
  1013   121^^49^49 ^2931014^^ ^^
  1014   "DATA",343 ,2,1,1,0)
  1015   NOTICE OF  INDEBTEDNE SS:  Accor ding to ou r records,  you are i ndebted to
  1016   "DATA",343 ,2,1,2,0)
  1017   the United  States fo r $|PRCA B ALANCE|.   For a comp lete break down of
  1018   "DATA",343 ,2,1,3,0)
  1019   this amoun t, see the  enclosed  Statement  of Charges  for Medic al Care.
  1020   "DATA",343 ,2,1,4,0)
  1021   This indeb tedness wa s caused b y |PRCA RE SULTING|.
  1022   "DATA",343 ,2,1,5,0)
  1023     
  1024   "DATA",343 ,2,1,6,0)
  1025   Debts bein g repaid b y installm ents will  be charged  interest  at an annu al
  1026   "DATA",343 ,2,1,7,0)
  1027   rate of |P RCA INTERE ST|%.  A m onthly adm inistrativ e cost of  $|PRCA ADM IN|
  1028   "DATA",343 ,2,1,8,0)
  1029   (subject t o change a nnually) m ay also be  charged.   If full p ayment of  the
  1030   "DATA",343 ,2,1,9,0)
  1031   debt is re ceived wit hin 30 day s, no inte rest or ad ministrati ve cost of
  1032   "DATA",343 ,2,1,10,0)
  1033   collection  fees will  be charge d and any  future ben efit payme nts will n ot
  1034   "DATA",343 ,2,1,11,0)
  1035   be withhel d.
  1036   "DATA",343 ,2,1,12,0)
  1037     
  1038   "DATA",343 ,2,1,13,0)
  1039   DEBTS OWED  THE UNITE D STATES G OVERNMENT:  The law r equires th e Departme nt
  1040   "DATA",343 ,2,1,14,0)
  1041   of Veteran s Affairs  (VA) to co llect debt s owed the  governmen t because  of
  1042   "DATA",343 ,2,1,15,0)
  1043   medical ca re.  When  the indivi dual remai ns entitle d to benef its, the V A
  1044   "DATA",343 ,2,1,16,0)
  1045   is require d to colle ct the deb t by withh olding fut ure benefi t payments
  1046   "DATA",343 ,2,1,17,0)
  1047   until the  debt is pa id, except  as explai ned below.   Any curr ent or fut ure
  1048   "DATA",343 ,2,1,18,0)
  1049   VA benefit  payments,  final fed eral salar y, lump su m or retir ement paym ents,
  1050   "DATA",343 ,2,1,19,0)
  1051   insurance  dividends  or other p ayments ma de under a ny law adm inistered  by
  1052   "DATA",343 ,2,1,20,0)
  1053   the VA may  be withhe ld.
  1054   "DATA",343 ,2,1,21,0)
  1055     
  1056   "DATA",343 ,2,1,22,0)
  1057   NOTE: When ever this  letter sta tes that y ou have a  period of  time to ta ke
  1058   "DATA",343 ,2,1,23,0)
  1059   some actio n or to no tify us, t he period  of time be gins to ru n from the
  1060   "DATA",343 ,2,1,24,0)
  1061   date of th is letter.
  1062   "DATA",343 ,2,1,25,0)
  1063     
  1064   "DATA",343 ,2,1,26,0)
  1065   ADMINISTRA TIVE COST  OF COLLECT ION FEES:  The monthl y administ rative cos t of 
  1066   "DATA",343 ,2,1,27,0)
  1067   collection  fee will  not be add ed to your  debt if,  within 30  days, full
  1068   "DATA",343 ,2,1,28,0)
  1069   payment of  the debt  is receive d or an ac ceptable r epayment p lan is wor ked
  1070   "DATA",343 ,2,1,29,0)
  1071   out. If an  installme nt repayme nt plan is  worked ou t and any  installmen t
  1072   "DATA",343 ,2,1,30,0)
  1073   is not rec eived by t he due dat e, the mon thly admin istrative  cost of
  1074   "DATA",343 ,2,1,31,0)
  1075   collection  fee will  thereafter  be charge d for the  life of th e debt.
  1076   "DATA",343 ,2,1,32,0)
  1077    Other cos ts of coll ection may  also be a dded to th e debt if  additional
  1078   "DATA",343 ,2,1,33,0)
  1079   collection  actions b ecome nece ssary.
  1080   "DATA",343 ,2,1,34,0)
  1081     
  1082   "DATA",343 ,2,1,35,0)
  1083   REPAYMENT  PLAN: If y ou cannot  repay this  debt in f ull, you s hould cont act
  1084   "DATA",343 ,2,1,36,0)
  1085   us within  30 days fr om the dat e of this  letter to  work out a  satisfact ory
  1086   "DATA",343 ,2,1,37,0)
  1087   repayment  plan.
  1088   "DATA",343 ,2,1,38,0)
  1089     
  1090   "DATA",343 ,2,1,39,0)
  1091   Please mak e your che ck or mone y order pa yable to t he Departm ent of Vet erans
  1092   "DATA",343 ,2,1,40,0)
  1093   Affairs an d send it  to the abo ve address
  1094   "DATA",343 ,2,1,41,0)
  1095   with the b ottom port ion of thi s letter.   Please in clude
  1096   "DATA",343 ,2,1,42,0)
  1097   your full  name and f ile number /SSAN on y our check  or money o rder to
  1098   "DATA",343 ,2,1,43,0)
  1099   insure pro per credit .
  1100   "DATA",343 ,2,1,44,0)
  1101     
  1102   "DATA",343 ,2,1,45,0)
  1103   If you hav e any ques tions conc erning thi s letter,  please con tact this
  1104   "DATA",343 ,2,1,46,0)
  1105   office for  assistanc e.
  1106   "DATA",343 ,2,1,47,0)
  1107     
  1108   "DATA",343 ,2,1,48,0)
  1109     
  1110   "DATA",343 ,2,1,49,0)
  1111   Finance Of ficer
  1112   "DATA",343 ,2,2)
  1113   Humanitari an (1FU)
  1114   "DATA",343 ,3,0)
  1115   FL 4-482
  1116   "DATA",343 ,3,1,0)
  1117   ^^17^17^29 31014^^^^
  1118   "DATA",343 ,3,1,1,0)
  1119   We recentl y called y our attent ion to you r indebted ness.  The  amount du e is 
  1120   "DATA",343 ,3,1,2,0)
  1121   $|PRCA BAL ANCE| Our  records in dicate tha t we have  not heard  from you
  1122   "DATA",343 ,3,1,3,0)
  1123   regarding  repayment  or other s ettlement  of this de bt.
  1124   "DATA",343 ,3,1,4,0)
  1125     
  1126   "DATA",343 ,3,1,5,0)
  1127   The law re quires us  to follow  certain pr ocedures i n collecti ng amounts
  1128   "DATA",343 ,3,1,6,0)
  1129   due the Go vernment.   Therefore , we must  caution yo u that non -payment o f
  1130   "DATA",343 ,3,1,7,0)
  1131   this debt  will resul t in addit ional expe nse to you  and may a lso result
  1132   "DATA",343 ,3,1,8,0)
  1133   in persona l inconven ience to y ou.
  1134   "DATA",343 ,3,1,9,0)
  1135     
  1136   "DATA",343 ,3,1,10,0)
  1137   The bottom  portion o f this let ter should  be return ed with yo ur
  1138   "DATA",343 ,3,1,11,0)
  1139   remittance .  A self- addressed  envelope i s enclosed  for your  convenienc e.
  1140   "DATA",343 ,3,1,12,0)
  1141     
  1142   "DATA",343 ,3,1,13,0)
  1143   If you hav e recently  paid this  debt or w ritten to  us, thank  you and pl ease
  1144   "DATA",343 ,3,1,14,0)
  1145   disregard  this lette r.
  1146   "DATA",343 ,3,1,15,0)
  1147     
  1148   "DATA",343 ,3,1,16,0)
  1149     
  1150   "DATA",343 ,3,1,17,0)
  1151   Finance Of ficer
  1152   "DATA",343 ,3,2)
  1153   Ineligible  Hospital/ Humanitari an (2FU)
  1154   "DATA",343 ,4,0)
  1155   FL 4-484
  1156   "DATA",343 ,4,1,0)
  1157   ^^46^46^30 01017^
  1158   "DATA",343 ,4,1,1,0)
  1159   We have wr itten to y ou on seve ral occasi ons about  your debt  of
  1160   "DATA",343 ,4,1,2,0)
  1161   $|PRCA BAL ANCE|. Thi s amount c onsists of  $|PRCA PR INCIPAL BA LANCE|
  1162   "DATA",343 ,4,1,3,0)
  1163   principal,  $|PRCA IN TEREST BAL ANCE| inte rest and $ |PRCA ADMI N BALANCE|
  1164   "DATA",343 ,4,1,4,0)
  1165   administra tive cost  of collect ion fees.  It is now  urgent tha t you cont act
  1166   "DATA",343 ,4,1,5,0)
  1167   this offic e immediat ely regard ing settle ment of th e debt.  Y ou may con tact
  1168   "DATA",343 ,4,1,6,0)
  1169   us at |PRC A AR PHONE | between  |PRCA AR H OURS|.
  1170   "DATA",343 ,4,1,7,0)
  1171    
  1172   "DATA",343 ,4,1,8,0)
  1173   INVOLUNTAR Y COLLECTI ON: The De partment o f Veterans  Affairs ( VA) is
  1174   "DATA",343 ,4,1,9,0)
  1175   required u nder 31 U. S.C., chap ter 37, su bchapter I I, to coll ect debts  owed
  1176   "DATA",343 ,4,1,10,0)
  1177   to the gov ernment.   Since your  debt is o ver 60 day s old, unl ess action  is
  1178   "DATA",343 ,4,1,11,0)
  1179   taken to s atisfy thi s debt wit hin 30 day s your deb t may be r eferred fo r
  1180   "DATA",343 ,4,1,12,0)
  1181   involuntar y collecti on action.   This mea ns any cur rent or fu ture feder al
  1182   "DATA",343 ,4,1,13,0)
  1183   salary, lu mp sum or  retirement  payments,  insurance  dividends , or other
  1184   "DATA",343 ,4,1,14,0)
  1185   payments t hat are ma de to you  under any  law admini stered by  VA may be
  1186   "DATA",343 ,4,1,15,0)
  1187   withheld t o pay your  delinquen t debt.  Y our debt m ay be refe rred to th e
  1188   "DATA",343 ,4,1,16,0)
  1189   Department  of Treasu ry for col lection an d/or admin istrative  offset.
  1190   "DATA",343 ,4,1,17,0)
  1191   Please rea d the atta chment for  specific  details re garding th is process  as
  1192   "DATA",343 ,4,1,18,0)
  1193   well as th e rights y ou have un der this p rocess.  A ny of thes e actions  may
  1194   "DATA",343 ,4,1,19,0)
  1195   result in  processing  fees bein g charged  to you.  P ayment che cks that a re
  1196   "DATA",343 ,4,1,20,0)
  1197   canceled b ecause the y have not  been cash ed within  one year m ay be appl ied
  1198   "DATA",343 ,4,1,21,0)
  1199   to offset  the indebt edness and  not be re issued.  O ther invol untary
  1200   "DATA",343 ,4,1,22,0)
  1201   collection  actions m ay include  the repor ting of yo ur delinqu ent accoun t to
  1202   "DATA",343 ,4,1,23,0)
  1203   credit rep orting age ncies 60 d ays from t he date of  this lett er. 
  1204   "DATA",343 ,4,1,24,0)
  1205    
  1206   "DATA",343 ,4,1,25,0)
  1207   Your debt  may be ref erred to o ur VA Regi onal Couns el for app ropriate l egal
  1208   "DATA",343 ,4,1,26,0)
  1209   action wit hin 30 day s from the  date of t his letter .  Unless,  you take
  1210   "DATA",343 ,4,1,27,0)
  1211   action to  pay your d ebt in ful l, make sa tisfactory  arrangeme nts to pay  by
  1212   "DATA",343 ,4,1,28,0)
  1213   installmen ts or subm it a reaso nable comp romise off er, prior  to the
  1214   "DATA",343 ,4,1,29,0)
  1215   expiration  of the 30  days.  Th is referra l will res ult in a o ne-time
  1216   "DATA",343 ,4,1,30,0)
  1217   administra tive charg e to you o f $|PRCA L ITIGATION  FEE|.  Thi s charge i s in
  1218   "DATA",343 ,4,1,31,0)
  1219   addition t o the mont hly admini strative c harge of $ |PRCA ADMI N|.  The V A
  1220   "DATA",343 ,4,1,32,0)
  1221   Regional C ounsel has  the autho rity to in itiate leg al proceed ing agains t
  1222   "DATA",343 ,4,1,33,0)
  1223   you.  Cour t action m ay result  in the add ition of U .S. Marsha l fees and
  1224   "DATA",343 ,4,1,34,0)
  1225   court cost s to your  debt.
  1226   "DATA",343 ,4,1,35,0)
  1227    
  1228   "DATA",343 ,4,1,36,0)
  1229   Please mak e your che ck or mone y order pa yable to t he Departm ent of
  1230   "DATA",343 ,4,1,37,0)
  1231   Veterans A ffairs and  return it  to the ab ove addres s along wi th the bot tom
  1232   "DATA",343 ,4,1,38,0)
  1233   portion of  this lett er.  Pleas e include  your full  name and f ile number  on
  1234   "DATA",343 ,4,1,39,0)
  1235   your check  or money  order to i nsure prop er credit.   In the e vent you a re
  1236   "DATA",343 ,4,1,40,0)
  1237   unable to  pay in ful l immediat ely, you s hould cont act this o ffice,
  1238   "DATA",343 ,4,1,41,0)
  1239   preferably  by teleph one, to in form me of  your inte ntions for  settlemen t.
  1240   "DATA",343 ,4,1,42,0)
  1241   Otherwise,  any or al l of the a bove actio ns may be  taken to c ollect you r
  1242   "DATA",343 ,4,1,43,0)
  1243   debt.
  1244   "DATA",343 ,4,1,44,0)
  1245    
  1246   "DATA",343 ,4,1,45,0)
  1247   Finance Of ficer
  1248   "DATA",343 ,4,1,46,0)
  1249   FL 4-484
  1250   "DATA",343 ,4,2)
  1251   Ineligible  Hospital/ Humanitari an $600.00 -$1199.00  (3FU)
  1252   "DATA",343 ,5,0)
  1253   IRS OFFSET
  1254   "DATA",343 ,5,1,0)
  1255   ^^43^43^29 80812^
  1256   "DATA",343 ,5,1,1,0)
  1257   We have wr itten to y ou on seve ral occasi ons about  your delin quent debt  of
  1258   "DATA",343 ,5,1,2,0)
  1259   $|PRCA IRS  TOTAL|. I t is now u rgent that  you conta ct this of fice
  1260   "DATA",343 ,5,1,3,0)
  1261   immediatel y regardin g settleme nt of the  debt.  You  have 30 d ays from t he
  1262   "DATA",343 ,5,1,4,0)
  1263   date of th is letter  to pay the  debt in f ull, estab lish a sat isfactory
  1264   "DATA",343 ,5,1,5,0)
  1265   repayment  plan, or p resent evi dence that  all or pa rt of this  indebtedn ess
  1266   "DATA",343 ,5,1,6,0)
  1267   is not pas t due or l egally enf orceable.  If we do n ot hear fr om you, we
  1268   "DATA",343 ,5,1,7,0)
  1269   will repor t your deb t to the U .S. Depart ment of th e Treasury  for offse t.
  1270   "DATA",343 ,5,1,8,0)
  1271    
  1272   "DATA",343 ,5,1,9,0)
  1273   The Debt C ollection  Improvemen t Act of 1 996 (Publi c Law 104- 134) requi res
  1274   "DATA",343 ,5,1,10,0)
  1275   the Depart ment of Ve terans Aff airs (VA)  to refer a ny delinqu ent debt o ver
  1276   "DATA",343 ,5,1,11,0)
  1277   180 days o ld to the  Treasury D epartment  for potent ial offset . The Trea sury
  1278   "DATA",343 ,5,1,12,0)
  1279   Departmmen t or other  designate d disbursi ng officia l will off set all or  a
  1280   "DATA",343 ,5,1,13,0)
  1281   portion of  what you  owe VA fro m almost a ny payment  that may  be issued
  1282   "DATA",343 ,5,1,14,0)
  1283   to you by  the Federa l Governme nt. This c ould inclu de, but is  not limit ed
  1284   "DATA",343 ,5,1,15,0)
  1285   to, social  security  benefits,  federal in come tax r efunds and  federal
  1286   "DATA",343 ,5,1,16,0)
  1287   salary or  retirement  benefits.  Referral  of your de bt to Trea sury may
  1288   "DATA",343 ,5,1,17,0)
  1289   result in  processing  fees bein g charged  to you for  the refer ral and fo r
  1290   "DATA",343 ,5,1,18,0)
  1291   each offse t made.
  1292   "DATA",343 ,5,1,19,0)
  1293    
  1294   "DATA",343 ,5,1,20,0)
  1295   If you hav e filed fo r bankrupt cy and the  automatic  stay is i n effect,  you
  1296   "DATA",343 ,5,1,21,0)
  1297   must notif y us withi n 30 days  to prevent  this debt  from bein g reported  to
  1298   "DATA",343 ,5,1,22,0)
  1299   the Treasu ry Departm ent. You s hould send  us proof  of your ba nkruptcy a s
  1300   "DATA",343 ,5,1,23,0)
  1301   soon as po ssible. If  you file  a joint fe deral inco me tax ret urn, you
  1302   "DATA",343 ,5,1,24,0)
  1303   should obt ain IRS Fo rm 8379, I njured Spo use Claim  and Alloca tion, BEFO RE
  1304   "DATA",343 ,5,1,25,0)
  1305   filing you r return.  The instru ctions wil l explain  the steps  your spous e
  1306   "DATA",343 ,5,1,26,0)
  1307   may take t o obtain h is or her  share of y our joint  income tax  refund.
  1308   "DATA",343 ,5,1,27,0)
  1309    
  1310   "DATA",343 ,5,1,28,0)
  1311   Federal em ployees an d annuitan ts, member s of the A rmed Force s (includi ng
  1312   "DATA",343 ,5,1,29,0)
  1313   National G uard and R eserve) an d military  retirees  are entitl ed to a
  1314   "DATA",343 ,5,1,30,0)
  1315   hearing on  the amoun t of feder al salary  or retirem ent benefi ts to be
  1316   "DATA",343 ,5,1,31,0)
  1317   withheld i f they do  not agree  on a repay ment sched ule. Such  a hearing  must
  1318   "DATA",343 ,5,1,32,0)
  1319   be request ed within  15 days of  the date  of this le tter to pr event refe rral
  1320   "DATA",343 ,5,1,33,0)
  1321   of your de bt to the  Treasury D epartment.
  1322   "DATA",343 ,5,1,34,0)
  1323    
  1324   "DATA",343 ,5,1,35,0)
  1325   NOTICE: Th e debt(s)  included o n this bil l may not  be the onl y debt(s)  you
  1326   "DATA",343 ,5,1,36,0)
  1327   are respon sible for  paying. Yo u may have  other act ive bills  with VA, w hich
  1328   "DATA",343 ,5,1,37,0)
  1329   are not el igible for  referral  to the Tre asury Depa rtment and  are not
  1330   "DATA",343 ,5,1,38,0)
  1331   included o n this bil l.
  1332   "DATA",343 ,5,1,39,0)
  1333     
  1334   "DATA",343 ,5,1,40,0)
  1335   If you hav e addition al questio ns, are in  bankruptc y status,  or if you  wish
  1336   "DATA",343 ,5,1,41,0)
  1337   a hearing  on the amo unt of fed eral salar y or retir ement bene fits that
  1338   "DATA",343 ,5,1,42,0)
  1339   might be o ffset, con tact us, i mmediately , at |PRCA  AR PHONE|  between
  1340   "DATA",343 ,5,1,43,0)
  1341   |PRCA AR H OURS|.
  1342   "DATA",343 ,5,2)
  1343   IRS Offset  Notice
  1344   "DATA",343 ,6,0)
  1345   FL 4-521
  1346   "DATA",343 ,6,1,0)
  1347   60^^77^77^ 2931014^^^ ^
  1348   "DATA",343 ,6,1,1,0)
  1349   NOTICE OF  INDEBTEDNE SS:  Accor ding to ou r records,  you are i ndebted to  the
  1350   "DATA",343 ,6,1,2,0)
  1351   United Sta tes for |P RCA BALANC E|.  For c omplete br eakdown of  this amou nt,
  1352   "DATA",343 ,6,1,3,0)
  1353   see the de scription  of charges  below.  T his indebt edness was  caused by
  1354   "DATA",343 ,6,1,4,0)
  1355    |PRCA RES ULTING|.
  1356   "DATA",343 ,6,1,5,0)
  1357     
  1358   "DATA",343 ,6,1,6,0)
  1359   This is a  debt owed  by you to  the United  States Go vernment.  Debts bein g
  1360   "DATA",343 ,6,1,7,0)
  1361   repaid by  installmen ts will be  charged i nterest at  an annual  rate of
  1362   "DATA",343 ,6,1,8,0)
  1363   |PRCA INTE REST|%. A  monthly ad ministrati ve cost of  collectio n fee of
  1364   "DATA",343 ,6,1,9,0)
  1365   $|PRCA ADM IN| (subje ct to chan ge annuall y) may als o be charg ed.
  1366   "DATA",343 ,6,1,10,0)
  1367   Further, a  penalty c harge of | PRCA PENAL TY|% (not  to exceed  6%
  1368   "DATA",343 ,6,1,11,0)
  1369   annually)  will be as sessed on  any accoun t more tha n 90 days  past due.
  1370   "DATA",343 ,6,1,12,0)
  1371   If full pa yment of t he debt is  received  within 30  days, no i nterest,
  1372   "DATA",343 ,6,1,13,0)
  1373   administra tive cost  of collect ion fees o r penalty  charges wi ll be char ged.
  1374   "DATA",343 ,6,1,14,0)
  1375     
  1376   "DATA",343 ,6,1,15,0)
  1377   If you do  not believ e you owe  this debt  or you thi nk the amo unt is
  1378   "DATA",343 ,6,1,16,0)
  1379   incorrect,  you have  a right to  dispute t he debt (s ee attache d Notice o f
  1380   "DATA",343 ,6,1,17,0)
  1381   Rights).  
  1382   "DATA",343 ,6,1,18,0)
  1383     
  1384   "DATA",343 ,6,1,19,0)
  1385   Regardless  of whethe r you disp ute the de bt, if you  can not r epay debt  in
  1386   "DATA",343 ,6,1,20,0)
  1387   full you s hould cont act us wit hin 30 day s from the  date of t his letter  to
  1388   "DATA",343 ,6,1,21,0)
  1389   work out a  satisfact ory repaym ent plan.
  1390   "DATA",343 ,6,1,22,0)
  1391     
  1392   "DATA",343 ,6,1,23,0)
  1393   Please mak e your che ck or mone y order pa yable to t he Departm ent of Vet erans
  1394   "DATA",343 ,6,1,24,0)
  1395   Affairs an d send it  to the add ress on th e receipt  attached.  Please inc lude
  1396   "DATA",343 ,6,1,25,0)
  1397    your full  name and  Bill Numbe r on your  check or m oney order   to insur e
  1398   "DATA",343 ,6,1,26,0)
  1399    proper cr edit.
  1400   "DATA",343 ,6,1,27,0)
  1401     
  1402   "DATA",343 ,6,1,28,0)
  1403   If you hav e any ques tions conc erning thi s letter,  please con tact this  office
  1404   "DATA",343 ,6,1,29,0)
  1405   for assist ance at |P RCA AR PHO NE| betwee n the hour s of |PRCA  AR HOURS| .
  1406   "DATA",343 ,6,1,30,0)
  1407     
  1408   "DATA",343 ,6,1,31,0)
  1409     
  1410   "DATA",343 ,6,1,32,0)
  1411     
  1412   "DATA",343 ,6,1,33,0)
  1413     
  1414   "DATA",343 ,6,1,34,0)
  1415   Finance Of ficer
  1416   "DATA",343 ,6,1,35,0)
  1417   |TOP|
  1418   "DATA",343 ,6,1,36,0)
  1419                          NOTICE OF  RIGHTS AN D OBLIGATI ONS
  1420   "DATA",343 ,6,1,37,0)
  1421     
  1422   "DATA",343 ,6,1,38,0)
  1423     
  1424   "DATA",343 ,6,1,39,0)
  1425   DEBTS OWED  THE UNITE D STATES G OVERNMENT:   The law  requires t he Departm ent
  1426   "DATA",343 ,6,1,40,0)
  1427   of Veteran s Affairs  (VA) to co llect debt  owed the  government .  When th e
  1428   "DATA",343 ,6,1,41,0)
  1429   individual  or corpor ation is e ntitled to  payments,  the VA is  required  to
  1430   "DATA",343 ,6,1,42,0)
  1431   collect de bt by with holding fu ture payme nts until  the debt i s paid, ex cept
  1432   "DATA",343 ,6,1,43,0)
  1433   as explain ed below.   Any curre nt or futu re VA paym ents or ot her paymen ts
  1434   "DATA",343 ,6,1,44,0)
  1435   made under  any law a dministere d by the V A may be w ithheld.
  1436   "DATA",343 ,6,1,45,0)
  1437     
  1438   "DATA",343 ,6,1,46,0)
  1439   NOTE:  Whe never this  letter st ates that  you have a  period of  time to t ake
  1440   "DATA",343 ,6,1,47,0)
  1441   some actio n or to no tify us, t he period  of time be gins to ru n from the  date
  1442   "DATA",343 ,6,1,48,0)
  1443   appearing  on the fro nt of this  letter.
  1444   "DATA",343 ,6,1,49,0)
  1445     
  1446   "DATA",343 ,6,1,50,0)
  1447     
  1448   "DATA",343 ,6,1,51,0)
  1449     
  1450   "DATA",343 ,6,1,52,0)
  1451     
  1452   "DATA",343 ,6,1,53,0)
  1453     
  1454   "DATA",343 ,6,1,54,0)
  1455     
  1456   "DATA",343 ,6,1,55,0)
  1457   RIGHT TO D ISPUTE THE  EXISTENCE  OR AMOUNT  OF THE DE BT:  If yo u tell us  in
  1458   "DATA",343 ,6,1,56,0)
  1459   writing wi thin 30 da ys that yo u believe  that you d o not owe  this debt  or
  1460   "DATA",343 ,6,1,57,0)
  1461   that the a mount of t he debt is  incorrect , we will  not withho ld any cur rent
  1462   "DATA",343 ,6,1,58,0)
  1463   or future  federal sa lary, lump  sum or re tirement p ayments un til we con firm
  1464   "DATA",343 ,6,1,59,0)
  1465   that you a re indebte d and the  amount is  correct or  we determ ine that
  1466   "DATA",343 ,6,1,60,0)
  1467   the delay  required t o resolve  the disput e will jeo pardize ou r ability  to
  1468   "DATA",343 ,6,1,61,0)
  1469   collect th e full amo unt of the  debt.  Yo u should e xplain to  the extent  you
  1470   "DATA",343 ,6,1,62,0)
  1471   can why yo u believe  you do not  owe the d ebt or why  the amoun t is incor rect.
  1472   "DATA",343 ,6,1,63,0)
  1473     
  1474   "DATA",343 ,6,1,64,0)
  1475   ADMINISTRA TIVE COST  OF COLLECT ION FEES:   The month ly adminis trative co st of
  1476   "DATA",343 ,6,1,65,0)
  1477   collection  fee will  not be add ed to your  debt if,  within 30  days, full
  1478   "DATA",343 ,6,1,66,0)
  1479   payment of  the debt  is receive d or an ac ceptable r epayment p lan is wor ked
  1480   "DATA",343 ,6,1,67,0)
  1481   out.  If a n installm ent repaym ent plan i s worked o ut and any  installme nt is
  1482   "DATA",343 ,6,1,68,0)
  1483   not receiv ed by the  due date,  the monthl y administ rative cos t of colle ction
  1484   "DATA",343 ,6,1,69,0)
  1485   fee will t hereafter  be charged  for the l ife of the  debt.  Ot her
  1486   "DATA",343 ,6,1,70,0)
  1487   costs of c ollection  may also b e added to  the debt  if additio nal action s
  1488   "DATA",343 ,6,1,71,0)
  1489   become nec essary.
  1490   "DATA",343 ,6,1,72,0)
  1491     
  1492   "DATA",343 ,6,1,73,0)
  1493   PENALTY CH ARGES:  Th e monthly  penalty ch arge will  not be add ed to your  debt
  1494   "DATA",343 ,6,1,74,0)
  1495   if, within  90 days,  full payme nt of the  debt is re ceived or  an accepta ble
  1496   "DATA",343 ,6,1,75,0)
  1497   repayment  plan is wo rked out.   If an acc eptable re payment pl an is agre ed
  1498   "DATA",343 ,6,1,76,0)
  1499   upon and y ou default  on that a greement,  90 days af ter defaul t we will  begin
  1500   "DATA",343 ,6,1,77,0)
  1501   assessing  a penalty  charge.
  1502   "DATA",343 ,6,2)
  1503   Vendor (1F U)
  1504   "DATA",343 ,7,0)
  1505   FL 4-520b
  1506   "DATA",343 ,7,1,0)
  1507   ^^101^101^ 2931014^^^ ^
  1508   "DATA",343 ,7,1,1,0)
  1509   NOTICE OF  INDEBTEDNE SS:  Accor ding to ou r records,  you are i ndebted to  the
  1510   "DATA",343 ,7,1,2,0)
  1511   United Sta tes for $| PRCA BALAN CE|.  For  complete b reakdown o f this amo unt,
  1512   "DATA",343 ,7,1,3,0)
  1513   see the de scription  of charges  below.  T his indebt edness was  caused
  1514   "DATA",343 ,7,1,4,0)
  1515   by |PRCA R ESULTING|.
  1516   "DATA",343 ,7,1,5,0)
  1517     
  1518   "DATA",343 ,7,1,6,0)
  1519   NOTICE OF  RIGHTS:  I f you do n ot believe  you owe t his debt o r you thin k the
  1520   "DATA",343 ,7,1,7,0)
  1521   amount is  incorrect,  you have  the right  to dispute  this debt .  You als o have
  1522   "DATA",343 ,7,1,8,0)
  1523   the right  to request  a waiver  of the deb t.  Waiver  means tha t you will  not
  1524   "DATA",343 ,7,1,9,0)
  1525   have to pa y the debt .  Additio nal inform ation conc erning the se rights  is
  1526   "DATA",343 ,7,1,10,0)
  1527   attached t o this let ter.  PLEA SE READ IT  CAREFULLY .
  1528   "DATA",343 ,7,1,11,0)
  1529     
  1530   "DATA",343 ,7,1,12,0)
  1531   Debts bein g repaid b y installm ents will  be charged  interest  at an annu al
  1532   "DATA",343 ,7,1,13,0)
  1533   rate of |P RCA INTERE ST|%.  A m onthly adm inistrativ e cost of  collection  fee
  1534   "DATA",343 ,7,1,14,0)
  1535   of $|PRCA  ADMIN| (su bject to c hange annu ally) may  also be ch arged.
  1536   "DATA",343 ,7,1,15,0)
  1537    Further,  a penalty  charge of  |PRCA PENA LTY|% (not  to exceed  6%
  1538   "DATA",343 ,7,1,16,0)
  1539   annually)  will be as sessed on  any accoun t more tha n 90 days  past due.   If
  1540   "DATA",343 ,7,1,17,0)
  1541   full payme nt of the  debt is re ceived wit hin 30 day s, no inte rest,
  1542   "DATA",343 ,7,1,18,0)
  1543   administra tive cost  of collect ion fees o r penalty  charges wi ll be
  1544   "DATA",343 ,7,1,19,0)
  1545   charged.
  1546   "DATA",343 ,7,1,20,0)
  1547     
  1548   "DATA",343 ,7,1,21,0)
  1549   REPAYMENT  PLAN:  If  you are un able to pa y the full  amount in  one payme nt,
  1550   "DATA",343 ,7,1,22,0)
  1551   you should  complete  the enclos ed VA Form  4-5655, F inancial S tatus Repo rt,
  1552   "DATA",343 ,7,1,23,0)
  1553   and return  with a pa rtial paym ent and a  statement  of how you  will pay  the
  1554   "DATA",343 ,7,1,24,0)
  1555   balance. Y our plan s hould indi cate the a mount you  will pay e ach month  and
  1556   "DATA",343 ,7,1,25,0)
  1557   the date p ayment wil l be made.   Any reas onable pla n will rec eive caref ul
  1558   "DATA",343 ,7,1,26,0)
  1559   considerat ion.  
  1560   "DATA",343 ,7,1,27,0)
  1561     
  1562   "DATA",343 ,7,1,28,0)
  1563   Please mak e your che ck or mone y order pa yable to t he VA and  set it to  the
  1564   "DATA",343 ,7,1,29,0)
  1565   above addr ess along  with the b ottom port ion of thi s letter.   Please in dicate
  1566   "DATA",343 ,7,1,30,0)
  1567   your full  name and S ocial Secu rity Numbe r on you c heck or mo ney order  to
  1568   "DATA",343 ,7,1,31,0)
  1569   insure pro per credit .
  1570   "DATA",343 ,7,1,32,0)
  1571     
  1572   "DATA",343 ,7,1,33,0)
  1573   Please dis regard thi s letter i f you have  recently  paid this  debt in fu ll.
  1574   "DATA",343 ,7,1,34,0)
  1575     
  1576   "DATA",343 ,7,1,35,0)
  1577     
  1578   "DATA",343 ,7,1,36,0)
  1579     
  1580   "DATA",343 ,7,1,37,0)
  1581     
  1582   "DATA",343 ,7,1,38,0)
  1583   Finance Of ficer
  1584   "DATA",343 ,7,1,39,0)
  1585     
  1586   "DATA",343 ,7,1,40,0)
  1587   |TOP|
  1588   "DATA",343 ,7,1,41,0)
  1589     
  1590   "DATA",343 ,7,1,42,0)
  1591                          NOTICE OF  RIGHTS AN D OBLIGATI ONS
  1592   "DATA",343 ,7,1,43,0)
  1593     
  1594   "DATA",343 ,7,1,44,0)
  1595   DEBTS OWED  THE UNITE D STATES G OVERNMENT:   The law  requires t he Departm ent
  1596   "DATA",343 ,7,1,45,0)
  1597   of Veteran s Affairs  (VA) to co llect debt  owed the  government .  Any cur rent
  1598   "DATA",343 ,7,1,46,0)
  1599   or future  federal sa lary, lump  sum or re tirement p ayments ma de by the  VA
  1600   "DATA",343 ,7,1,47,0)
  1601   or any oth er federal  agency ma y be withh eld.
  1602   "DATA",343 ,7,1,48,0)
  1603     
  1604   "DATA",343 ,7,1,49,0)
  1605   NOTE:  Whe never this  letter st ates that  you have a  period of  time to t ake
  1606   "DATA",343 ,7,1,50,0)
  1607   some actio n or to no tify us, t he period  of time be gins to ru n from the  date
  1608   "DATA",343 ,7,1,51,0)
  1609   appearing  on the fro nt of this  letter.
  1610   "DATA",343 ,7,1,52,0)
  1611     
  1612   "DATA",343 ,7,1,53,0)
  1613     
  1614   "DATA",343 ,7,1,54,0)
  1615     
  1616   "DATA",343 ,7,1,55,0)
  1617     
  1618   "DATA",343 ,7,1,56,0)
  1619     
  1620   "DATA",343 ,7,1,57,0)
  1621     
  1622   "DATA",343 ,7,1,58,0)
  1623     
  1624   "DATA",343 ,7,1,59,0)
  1625     
  1626   "DATA",343 ,7,1,60,0)
  1627   RIGHT TO D ISPUTE THE  EXISTENCE  OR AMOUNT  OF THE DE BT:  If yo u tell us  in
  1628   "DATA",343 ,7,1,61,0)
  1629   writing wi thin 30 da ys that yo u believe  that you d o not owe  this debt  or
  1630   "DATA",343 ,7,1,62,0)
  1631   that the a mount of t he debt is  incorrect , we will  not withho ld any cur rent
  1632   "DATA",343 ,7,1,63,0)
  1633   or future  federal sa lary, lump  sum or re tirement p ayments un til we con firm
  1634   "DATA",343 ,7,1,64,0)
  1635   that you a re indebte d and the  amount is  correct or  we determ ine that t he
  1636   "DATA",343 ,7,1,65,0)
  1637   delay requ ired to re solve the  dispute wi ll jeopard ize our ab ility to c ollect
  1638   "DATA",343 ,7,1,66,0)
  1639   the full a mount of t he debt.   You should  explain t o the exte nt you can  why
  1640   "DATA",343 ,7,1,67,0)
  1641   you believ e you do n ot owe the  debt or w hy the amo unt is inc orrect.
  1642   "DATA",343 ,7,1,68,0)
  1643     
  1644   "DATA",343 ,7,1,69,0)
  1645   RIGHT TO R EQUEST WAI VER OF THE  DEBT:  Un der certai n circumst ances, we  can
  1646   "DATA",343 ,7,1,70,0)
  1647   waive the  debt.  Thi s means th at you wil l not be r equired to  pay the a mount
  1648   "DATA",343 ,7,1,71,0)
  1649   owed.
  1650   "DATA",343 ,7,1,72,0)
  1651     
  1652   "DATA",343 ,7,1,73,0)
  1653   To be cons idered for  waiver, y ou must wr ite to us  and reques t one.  Yo u
  1654   "DATA",343 ,7,1,74,0)
  1655   should exp lain why y ou believe  that the  erroneous  payment or  overpayme nt
  1656   "DATA",343 ,7,1,75,0)
  1657   which crea ted your i ndebtednes s is not y our fault.
  1658   "DATA",343 ,7,1,76,0)
  1659     
  1660   "DATA",343 ,7,1,77,0)
  1661   If we do n ot receive  your waiv er request  within 30  days, we  will begin  to
  1662   "DATA",343 ,7,1,78,0)
  1663   withhold 1 5% of your  disposabl e pay as e xplained i n the cove ring lette r.  If
  1664   "DATA",343 ,7,1,79,0)
  1665   you do not  request a  waiver wi thin 30 da ys, you ma y still do  so at any  time
  1666   "DATA",343 ,7,1,80,0)
  1667   within 3 y ears of th e date of  discovery  of your in debtedness .  Withhol ding
  1668   "DATA",343 ,7,1,81,0)
  1669   of your pa y will con tinue, how ever, duri ng any con sideration  of a waiv er
  1670   "DATA",343 ,7,1,82,0)
  1671   request re ceived aft er 30 days  of the da te appeari ng on the  front of t his
  1672   "DATA",343 ,7,1,83,0)
  1673   letter.  A ny withhel d amount w hich is wa ived will  be refunde d.
  1674   "DATA",343 ,7,1,84,0)
  1675     
  1676   "DATA",343 ,7,1,85,0)
  1677   ADMINISTRA TIVE COST  OF COLLECT ION FEES:   The month ly adminis trative co st of
  1678   "DATA",343 ,7,1,86,0)
  1679   collection  fee will  not be add ed to your  debt if,  within 30  days, full
  1680   "DATA",343 ,7,1,87,0)
  1681   payment of  the debt  is receive d or an ac ceptable r epayment p lan is wor ked
  1682   "DATA",343 ,7,1,88,0)
  1683   out. If an  installme nt repayme nt plan is  worked ou t and any  installmen t is
  1684   "DATA",343 ,7,1,89,0)
  1685   not receiv ed by the  due date,  the monthl y administ rative cos t of colle ction
  1686   "DATA",343 ,7,1,90,0)
  1687   fee will t hereafter  be charged  for the l ife of the  debt.  Ot her
  1688   "DATA",343 ,7,1,91,0)
  1689   costs of c ollection  may also b e added to  the debt  if additio nal action s
  1690   "DATA",343 ,7,1,92,0)
  1691   become nec essary.
  1692   "DATA",343 ,7,1,93,0)
  1693     
  1694   "DATA",343 ,7,1,94,0)
  1695   PENALTY CH ARGES:  Th e monthly  penalty ch arge will  not be add ed to your  debt
  1696   "DATA",343 ,7,1,95,0)
  1697   if, within  90 days,  full payme nt of the  debt is re ceived or  an accepta ble
  1698   "DATA",343 ,7,1,96,0)
  1699   repayment  plan is wo rked out.   If an acc eptable re payment pl an is agre ed
  1700   "DATA",343 ,7,1,97,0)
  1701   upon and y ou default  on that a greement,  90 days af ter defaul t we will  begin
  1702   "DATA",343 ,7,1,98,0)
  1703   assessing  a penalty  charge.
  1704   "DATA",343 ,7,1,99,0)
  1705     
  1706   "DATA",343 ,7,1,100,0 )
  1707   |TOP|
  1708   "DATA",343 ,7,1,101,0 )
  1709     
  1710   "DATA",343 ,7,2)
  1711   Ex-Employe e (1FU)
  1712   "DATA",343 ,8,0)
  1713   FL 4-520a
  1714   "DATA",343 ,8,1,0)
  1715   "^^127^127 ^2931014^^ ^"^
  1716   "DATA",343 ,8,1,1,0)
  1717   NOTICE OF  INDEBTEDNE SS:  Accor ding to ou r records,  you are i ndebted to  the
  1718   "DATA",343 ,8,1,2,0)
  1719   United Sta tes for $| PRCA BALAN CE|.  This  indebtedn ess was ca used by
  1720   "DATA",343 ,8,1,3,0)
  1721   |PRCA RESU LTING|.
  1722   "DATA",343 ,8,1,4,0)
  1723     
  1724   "DATA",343 ,8,1,5,0)
  1725   You are he reby notif ied that u nless you  make arran gements wi thin 30 da ys
  1726   "DATA",343 ,8,1,6,0)
  1727   from the d ate of thi s letter t o repay th is debt, o r notify t his office ,
  1728   "DATA",343 ,8,1,7,0)
  1729   in writing , that you  wish to d ispute the  existence , amount,  repayment
  1730   "DATA",343 ,8,1,8,0)
  1731   schedule o f the debt , request  a hearing  on such di spute, or  request wa iver
  1732   "DATA",343 ,8,1,9,0)
  1733   (see attac hed NOTICE  OF RIGHTS ), we will  offset yo ur current  pay at a  rate
  1734   "DATA",343 ,8,1,10,0)
  1735   of 15% of  your dispo sable pay  per pay pe riod until  the debt  is liquida ted.
  1736   "DATA",343 ,8,1,11,0)
  1737   If you are  unable to  pay in fu ll and if  offset of  15% would  cause a
  1738   "DATA",343 ,8,1,12,0)
  1739   hardship,  you should  submit a  proposed r epayment p lan for a  lesser
  1740   "DATA",343 ,8,1,13,0)
  1741   withholdin g supporte d by the p roperly co mpleted VA  Form 4-56 55, Financ ial
  1742   "DATA",343 ,8,1,14,0)
  1743   Status Rep ort, which  is enclos ed for you r use.
  1744   "DATA",343 ,8,1,15,0)
  1745     
  1746   "DATA",343 ,8,1,16,0)
  1747   Debts bein g repaid b y installm ents will  be charged  interest  at an annu al
  1748   "DATA",343 ,8,1,17,0)
  1749   rate of |P RCA INTERE ST|%.  A m onthly adm inistrativ e cost of  collection  fee
  1750   "DATA",343 ,8,1,18,0)
  1751   of $|PRCA  ADMIN| (su bject to c hange annu ally) may  also be ch arged.
  1752   "DATA",343 ,8,1,19,0)
  1753   Further, a  penalty c harge of | PRCA PENAL TY|% (not  to exceed  6%
  1754   "DATA",343 ,8,1,20,0)
  1755   annually)  will be as sessed on  any accoun t more tha n 90 days  past due.   If
  1756   "DATA",343 ,8,1,21,0)
  1757   full payme nt of the  debt is re ceived wit hin 30 day s, no inte rest,
  1758   "DATA",343 ,8,1,22,0)
  1759   administra tive cost  of collect ion fees o r penalty  charges wi ll be
  1760   "DATA",343 ,8,1,23,0)
  1761   charged.
  1762   "DATA",343 ,8,1,24,0)
  1763     
  1764   "DATA",343 ,8,1,25,0)
  1765   If we do n ot hear fr om you wit hin 30 day s, we will  automatic ally withh old 15%
  1766   "DATA",343 ,8,1,26,0)
  1767   of you dis posable pa y beginnin g 30 days  past the d ate of thi s letter
  1768   "DATA",343 ,8,1,27,0)
  1769   until the  debt is li quidated.
  1770   "DATA",343 ,8,1,28,0)
  1771   If there i s a balanc e remainin g after yo u terminat e employme nt, we wil l offset
  1772   "DATA",343 ,8,1,29,0)
  1773   the balanc e from you r final sa lary, lump  sum payme nt, CSRS o r FERS.
  1774   "DATA",343 ,8,1,30,0)
  1775     
  1776   "DATA",343 ,8,1,31,0)
  1777   You are ad vised that  any knowi ngly false  or frivol ous statem ents,
  1778   "DATA",343 ,8,1,32,0)
  1779   representa tives, or  evidence m ay subject  you to:   disciplina ry procedu res under
  1780   "DATA",343 ,8,1,33,0)
  1781   5 U.S.C. c h 75, 5 CF R Part 752 , or any o ther appli cable stat utes or
  1782   "DATA",343 ,8,1,34,0)
  1783   regulation s; penalti es under t he False C laims Act  31 U.S.C.  3729-3731,  or any
  1784   "DATA",343 ,8,1,35,0)
  1785   other appl icable sta tutory aut hority; or  criminal  penalties  under 18 U .S.C.
  1786   "DATA",343 ,8,1,36,0)
  1787   286, 287,  1001 or an y other ap plicable s tatutory a uthority.
  1788   "DATA",343 ,8,1,37,0)
  1789     
  1790   "DATA",343 ,8,1,38,0)
  1791   You are al so advised  that any  amounts pa id by you  or deducte d from you r pay
  1792   "DATA",343 ,8,1,39,0)
  1793   which may  be later f ound not t o be owed  will be pr omptly ref unded to y ou.
  1794   "DATA",343 ,8,1,40,0)
  1795   Please dis regard thi s letter i f you have  recently  paid this  debt in fu ll.
  1796   "DATA",343 ,8,1,41,0)
  1797     
  1798   "DATA",343 ,8,1,42,0)
  1799   Finance Of ficer
  1800   "DATA",343 ,8,1,43,0)
  1801     
  1802   "DATA",343 ,8,1,44,0)
  1803   Enclosures
  1804   "DATA",343 ,8,1,45,0)
  1805     
  1806   "DATA",343 ,8,1,46,0)
  1807   |TOP|
  1808   "DATA",343 ,8,1,47,0)
  1809                          NOTICE OF  RIGHTS AN D OBLIGATI ONS
  1810   "DATA",343 ,8,1,48,0)
  1811     
  1812   "DATA",343 ,8,1,49,0)
  1813     
  1814   "DATA",343 ,8,1,50,0)
  1815   DEBTS OWED  THE UNITE D STATES G OVERNMENT:   The law  requires t he Departm ent
  1816   "DATA",343 ,8,1,51,0)
  1817   of Veteran s Affairs  (VA) to co llect debt s owed the  governmen t.  If an
  1818   "DATA",343 ,8,1,52,0)
  1819   individual  is entitl ed to rece ive federa l salary p ayments, t he VA is r equired
  1820   "DATA",343 ,8,1,53,0)
  1821   to collect  the debt  by withhol ding 15% o f disposab le pay unt il the deb t is
  1822   "DATA",343 ,8,1,54,0)
  1823   paid, exce pt as expl ained belo w.  Any cu rrent or f uture fede ral salary , lump
  1824   "DATA",343 ,8,1,55,0)
  1825   sum or ret irement pa yments or  other paym ents made  by the VA  may be wit hheld.
  1826   "DATA",343 ,8,1,56,0)
  1827   You have t he right t o inspect  or to requ est a copy  of any re cord relat ing to
  1828   "DATA",343 ,8,1,57,0)
  1829   the debt.
  1830   "DATA",343 ,8,1,58,0)
  1831     
  1832   "DATA",343 ,8,1,59,0)
  1833   NOTE:  Whe never this  letter st ates that  you have a  period of  time to t ake
  1834   "DATA",343 ,8,1,60,0)
  1835   some actio n or to no tify us, t he period  of time be gins to ru n from the  date
  1836   "DATA",343 ,8,1,61,0)
  1837   appearing  on the fro nt of the  letter.
  1838   "DATA",343 ,8,1,62,0)
  1839     
  1840   "DATA",343 ,8,1,63,0)
  1841     
  1842   "DATA",343 ,8,1,64,0)
  1843     
  1844   "DATA",343 ,8,1,65,0)
  1845     
  1846   "DATA",343 ,8,1,66,0)
  1847     
  1848   "DATA",343 ,8,1,67,0)
  1849   RIGHT TO D ISPUTE THE  EXISTENCE  OR AMOUNT  OF THE DE BT:  If yo u tell us  in
  1850   "DATA",343 ,8,1,68,0)
  1851   writing wi thin 30 da ys that yo u believe  that you d o not owe  this debt  or that
  1852   "DATA",343 ,8,1,69,0)
  1853   the amount  of the de bt is inco rrect, we  will not w ithhold 15 % of your
  1854   "DATA",343 ,8,1,70,0)
  1855   disposable  pay until  we confir m that you  are indeb ted and th e amount i s
  1856   "DATA",343 ,8,1,71,0)
  1857   correct or  we determ ine that t he delay r equired to  resolve t he dispute  will
  1858   "DATA",343 ,8,1,72,0)
  1859   jeopardize  our abili ty to coll ect the fu ll amount  of the deb t.  You sh ould
  1860   "DATA",343 ,8,1,73,0)
  1861   explain to  the exten t you can  why you be lieve you  do not owe  the debt  or why
  1862   "DATA",343 ,8,1,74,0)
  1863   the amount  is incorr ect.
  1864   "DATA",343 ,8,1,75,0)
  1865     
  1866   "DATA",343 ,8,1,76,0)
  1867   RIGHT TO D ISPUTE OFF SET SCHEDU LE:  If of fset of 15 % of your  disposable  pay
  1868   "DATA",343 ,8,1,77,0)
  1869   would caus e a hardsh ip, you ma y request  a review o f the amou nt of offs et.
  1870   "DATA",343 ,8,1,78,0)
  1871   Such reque st for rev iew should  be in wri ting and i nclude a p roposed re payment
  1872   "DATA",343 ,8,1,79,0)
  1873   schedule s upported b y a proper ly complet ed VA Form  4-5655, F inancial S tatus
  1874   "DATA",343 ,8,1,80,0)
  1875   Report, wh ich is enc losed for  your use.   If a requ est for re view of th e issue
  1876   "DATA",343 ,8,1,81,0)
  1877   of the amo unt of sal ary offset  is receiv ed within  30 calenda r days fro m the
  1878   "DATA",343 ,8,1,82,0)
  1879   date of th is letter,  we will t ake no act ion to off set your c urrent pay  until a
  1880   "DATA",343 ,8,1,83,0)
  1881   review has  been held .
  1882   "DATA",343 ,8,1,84,0)
  1883     
  1884   "DATA",343 ,8,1,85,0)
  1885   RIGHT TO R EQUEST A H EARING:  Y ou have th e right to  request a  hearing o n the
  1886   "DATA",343 ,8,1,86,0)
  1887   existence  or amount  of the deb t and/or t he offset  scheduled.   Such a r equest
  1888   "DATA",343 ,8,1,87,0)
  1889   should inc lude reaso ns why you  believe a  hearing i s necessar y.  The he aring
  1890   "DATA",343 ,8,1,88,0)
  1891   officer ha s exclusiv e authorit y to deter mine wheth er a heari ng is to b e
  1892   "DATA",343 ,8,1,89,0)
  1893   conducted  in person,  or by ano ther metho d, such as  a confere nce call,  or on
  1894   "DATA",343 ,8,1,90,0)
  1895   the record , i.e., a  paper revi ew.  You w ill be adv ised as so on as poss ible of
  1896   "DATA",343 ,8,1,91,0)
  1897   the determ ination on  your hear ing reques t.
  1898   "DATA",343 ,8,1,92,0)
  1899     
  1900   "DATA",343 ,8,1,93,0)
  1901   RIGHT TO R EQUEST WAI VER OF THE  DEBT:  Un der certai n circumst ances, we  can
  1902   "DATA",343 ,8,1,94,0)
  1903   waive the  debt.  Thi s means th at you wil l not be r equired to  pay the a mount
  1904   "DATA",343 ,8,1,95,0)
  1905   owed.
  1906   "DATA",343 ,8,1,96,0)
  1907     
  1908   "DATA",343 ,8,1,97,0)
  1909   To be cons idered for  waiver, y ou must wr ite to us  and reques t one.  Yo u should
  1910   "DATA",343 ,8,1,98,0)
  1911   explain wh y you beli eve that t he erroneo us payment  or overpa yment whic h
  1912   "DATA",343 ,8,1,99,0)
  1913   created yo ur indebte dness is n ot your fa ult.
  1914   "DATA",343 ,8,1,100,0 )
  1915     
  1916   "DATA",343 ,8,1,101,0 )
  1917   If we do n ot receive  your waiv er request  within 30  days, we  will begin  to
  1918   "DATA",343 ,8,1,102,0 )
  1919   withhold 1 5% of your  disposabl e pay as e xplained i n the cove ring lette r.  If
  1920   "DATA",343 ,8,1,103,0 )
  1921   you do not  request a  waiver wi thin 30 da ys, you ma y still do  so at any  time
  1922   "DATA",343 ,8,1,104,0 )
  1923   within 3 y ears of th e date of  discovery  of your in debtedness .  Withhol ding of
  1924   "DATA",343 ,8,1,105,0 )
  1925   your pay w ill contin ue, howeve r, during  any consid eration of  a waiver  request
  1926   "DATA",343 ,8,1,106,0 )
  1927   received a fter 30 da ys of the  date appea ring on th e front of  this lett er.  Any
  1928   "DATA",343 ,8,1,107,0 )
  1929   withheld a mount whic h is waive d will be  funded.
  1930   "DATA",343 ,8,1,108,0 )
  1931     
  1932   "DATA",343 ,8,1,109,0 )
  1933   |TOP|
  1934   "DATA",343 ,8,1,110,0 )
  1935     
  1936   "DATA",343 ,8,1,111,0 )
  1937   ADMINISTRA TIVE COST  OF COLLECT ION FEES:   The month ly adminis trative co st of
  1938   "DATA",343 ,8,1,112,0 )
  1939   collection  fee will  not be add ed to your  debt if,  within 30  days, full
  1940   "DATA",343 ,8,1,113,0 )
  1941   payments o f the debt  is receiv ed or an a cceptable  plan is wo rked out.
  1942   "DATA",343 ,8,1,114,0 )
  1943   If an inst allment re payment pl an is work ed out and  any insta llment is
  1944   "DATA",343 ,8,1,115,0 )
  1945   not receiv ed by the  due date,  the monthl y administ rative cos t of colle ction
  1946   "DATA",343 ,8,1,116,0 )
  1947   fee will t hereafter  be charged  for the l ife of the  debt.  Ot her
  1948   "DATA",343 ,8,1,117,0 )
  1949   costs of c ollection  may also b e added to  the debt  if additio nal action s become
  1950   "DATA",343 ,8,1,118,0 )
  1951   necessary.
  1952   "DATA",343 ,8,1,119,0 )
  1953     
  1954   "DATA",343 ,8,1,120,0 )
  1955   PENALTY CH ARGES:  Th e monthly  penalty ch arge will  not be add ed to your
  1956   "DATA",343 ,8,1,121,0 )
  1957   debt if, w ithin 90 d ays, full  payment of  the debt  is receive d or an ac ceptable
  1958   "DATA",343 ,8,1,122,0 )
  1959   repayment  plan is wo rked out.   If an acc eptable re payment pl an is agre ed upon
  1960   "DATA",343 ,8,1,123,0 )
  1961   and you de fault on t hat agreem ent, 90 da ys after d efault we  will begin
  1962   "DATA",343 ,8,1,124,0 )
  1963   assessing  a penalty  charge.
  1964   "DATA",343 ,8,1,125,0 )
  1965     
  1966   "DATA",343 ,8,1,126,0 )
  1967     
  1968   "DATA",343 ,8,1,127,0 )
  1969     
  1970   "DATA",343 ,8,2)
  1971   Current Em ployee (1F U)
  1972   "DATA",343 ,9,0)
  1973   FL 4-513
  1974   "DATA",343 ,9,1,0)
  1975   64^^63^63^ 2941011^^^ ^
  1976   "DATA",343 ,9,1,1,0)
  1977   |CENTER("S pecial Not ice to Acc ompany Pat ient State ment")|
  1978   "DATA",343 ,9,1,2,0)
  1979     
  1980   "DATA",343 ,9,1,3,0)
  1981   Medication  Copayment  Program:   The medic ation copa yment prog ram was fi rst
  1982   "DATA",343 ,9,1,4,0)
  1983   enacted by  Congress  as Public  Law 101-50 8 on Novem ber 5,1990 .  The
  1984   "DATA",343 ,9,1,5,0)
  1985   Congress h as extende d medicati on copayme nt under P ublic Law  102-139.
  1986   "DATA",343 ,9,1,6,0)
  1987     
  1988   "DATA",343 ,9,1,7,0)
  1989   These laws  require t he Departm ent of Vet erans Affa irs (VA) t o collect  a
  1990   "DATA",343 ,9,1,8,0)
  1991   copayment  for each 3 0 day or l ess supply  of medica tions pres cribed for  non
  1992   "DATA",343 ,9,1,9,0)
  1993   service-co nnected co nditions.   While the se funds a re not dir ectly retu rned
  1994   "DATA",343 ,9,1,10,0)
  1995   to your VA  medical c enter, the y offset t he increas ing cost o f providin g
  1996   "DATA",343 ,9,1,11,0)
  1997   VA care.
  1998   "DATA",343 ,9,1,12,0)
  1999     
  2000   "DATA",343 ,9,1,13,0)
  2001   Means Test  Copayment s:  Means  test copay ments and  per diems  are establ ished
  2002   "DATA",343 ,9,1,14,0)
  2003   in section s 1710(f)  and 1712(f ) of Title  38 U.S.C.   These se ctions 
  2004   "DATA",343 ,9,1,15,0)
  2005   authorize  VA to prov ide care t o you on t he basis o f your agr eement to  pay
  2006   "DATA",343 ,9,1,16,0)
  2007   certain fe es for tha t care.
  2008   "DATA",343 ,9,1,17,0)
  2009     
  2010   "DATA",343 ,9,1,18,0)
  2011   Late Charg es:  Secti on 5315 of  Title 38  U.S.C. req uires VA t o assess l ate 
  2012   "DATA",343 ,9,1,19,0)
  2013   charges on  balances  which rema in unpaid.  These cha rges consi st of inte rest
  2014   "DATA",343 ,9,1,20,0)
  2015   and admini strative f ees at rat es that ar e establis hed each y ear.
  2016   "DATA",343 ,9,1,21,0)
  2017   Administra tive fees  apply to y our entire  statement  whenever  any paymen t
  2018   "DATA",343 ,9,1,22,0)
  2019   is late.   Interest f ees are ch arged for  any servic e that rem ains unpai d.
  2020   "DATA",343 ,9,1,23,0)
  2021   Interest c harges are  calculate d from the  date of t he first s tatement o n
  2022   "DATA",343 ,9,1,24,0)
  2023   which the  charge app eared thro ugh the ne xt stateme nt date.   You can av oid
  2024   "DATA",343 ,9,1,25,0)
  2025   these char ges by mai ling your  payment in  time for  it to arri ve by the
  2026   "DATA",343 ,9,1,26,0)
  2027   due date s hown on yo ur stateme nt.
  2028   "DATA",343 ,9,1,27,0)
  2029     
  2030   "DATA",343 ,9,1,28,0)
  2031   Questions  about Char ges:  If y ou sent a  payment to  us in the  past 10 d ays,
  2032   "DATA",343 ,9,1,29,0)
  2033   it may not  have been  applied t o your acc ount by th e time the  statement
  2034   "DATA",343 ,9,1,30,0)
  2035   was prepar ed.  This  payment wi ll be refl ected in y our accoun t on the n ext
  2036   "DATA",343 ,9,1,31,0)
  2037   statement.   Please c all the nu mber shown  on the st atement if  you have  other
  2038   "DATA",343 ,9,1,32,0)
  2039   question a bout your  charges.   We recomme nd you not e the date , name and
  2040   "DATA",343 ,9,1,33,0)
  2041   phone numb er of the  individual  that you  speak to i f the call  results i n
  2042   "DATA",343 ,9,1,34,0)
  2043   a change t o your acc ount.  Ple ase see th e followin g paragrap h relating  to
  2044   "DATA",343 ,9,1,35,0)
  2045   formal dis putes.
  2046   "DATA",343 ,9,1,36,0)
  2047     
  2048   "DATA",343 ,9,1,37,0)
  2049   Formal Dis putes:  Yo u may disp ute the co rrectness  of a charg e applied  to
  2050   "DATA",343 ,9,1,38,0)
  2051   your accou nt.  To do  so, you m ust advise  us of the  dispute i n writing.
  2052   "DATA",343 ,9,1,39,0)
  2053   Your lette r must be  received b y VA withi n 30 days  of the dat e of the 
  2054   "DATA",343 ,9,1,40,0)
  2055   statement  on which t he charge  first appe ared.  We  will suspe nd further  
  2056   "DATA",343 ,9,1,41,0)
  2057   notices co ncerning t he charge  while we r esolve the  question;  however,  we
  2058   "DATA",343 ,9,1,42,0)
  2059   will add i nterest an d, if appl icable, ad ministrati ve charges  to your
  2060   "DATA",343 ,9,1,43,0)
  2061   account.   We will cr edit your  account fo r any late  charges a ssociated
  2062   "DATA",343 ,9,1,44,0)
  2063   with the d isputed am ount, if t he dispute  is resolv ed in your  favor.
  2064   "DATA",343 ,9,1,45,0)
  2065     
  2066   "DATA",343 ,9,1,46,0)
  2067   Repayment  Plans:  If  you are u nable to m ake a full  payment o f the char ges,
  2068   "DATA",343 ,9,1,47,0)
  2069   you may ap ply to hav e the bala nce placed  on a repa yment plan .  To avoi d
  2070   "DATA",343 ,9,1,48,0)
  2071   an adminis trative ch arge, you  must reque st the for ms needed  to establi sh
  2072   "DATA",343 ,9,1,49,0)
  2073   a repaymen t plan in  writing, V A must als o receive  your reque st within
  2074   "DATA",343 ,9,1,50,0)
  2075   30 days of  the date  of the sta tement on  which the  charge fir st appears .
  2076   "DATA",343 ,9,1,51,0)
  2077   The minimu m payment  on a repay ment plan  should be  sufficient  to pay of f
  2078   "DATA",343 ,9,1,52,0)
  2079   the balanc e of your  account wi thin 12 mo nths.  If  your repay ment plan
  2080   "DATA",343 ,9,1,53,0)
  2081   is accepte d, financi ng interes t charges  will be ad ded to you r statemen t
  2082   "DATA",343 ,9,1,54,0)
  2083   on any unp aid balanc e.
  2084   "DATA",343 ,9,1,55,0)
  2085     
  2086   "DATA",343 ,9,1,56,0)
  2087   Overdue Ch arges:  Th e Federal  Claims Col lection St andards (4  CFR 102.2 )
  2088   "DATA",343 ,9,1,57,0)
  2089   requires V A to pursu e certain  options fo r charges  owed the g overnment 
  2090   "DATA",343 ,9,1,58,0)
  2091   for medica l care pro vided to y ou.  If VA  pursues a ny of thes e collecti on 
  2092   "DATA",343 ,9,1,59,0)
  2093   options, w e will adv ise you by  separate  notice.
  2094   "DATA",343 ,9,1,60,0)
  2095     
  2096   "DATA",343 ,9,1,61,0)
  2097   PLEASE NOT E:  WHENEV ER THE ACC OMPANYING  STATEMENT  OR THIS NO TICE STATE S THAT
  2098   "DATA",343 ,9,1,62,0)
  2099   YOU HAVE A  PERIOD OF  TIME TO T AKE SOME A CTION OR T O NOTIFY U S, THE PER IOD
  2100   "DATA",343 ,9,1,63,0)
  2101   OF THAT TI ME BEGINS  TO RUN FRO M THE DATE  OF THE ST ATEMENT.
  2102   "DATA",343 ,9,2)
  2103   Pharmacy a nd Means T est (1/2/3  FU)
  2104   "DATA",343 ,10,0)
  2105   CREDIT
  2106   "DATA",343 ,10,1,0)
  2107   45^^26^26^ 2931022^^^ ^
  2108   "DATA",343 ,10,1,1,0)
  2109     
  2110   "DATA",343 ,10,1,2,0)
  2111     
  2112   "DATA",343 ,10,1,3,0)
  2113   |CENTER("C redit Bala nce Notifi cation")|
  2114   "DATA",343 ,10,1,4,0)
  2115     
  2116   "DATA",343 ,10,1,5,0)
  2117   Our record s show tha t you have  a credit  balance.
  2118   "DATA",343 ,10,1,6,0)
  2119     
  2120   "DATA",343 ,10,1,7,0)
  2121   The Depart ment of Ve terans Aff airs will  accept pre payments a nd overpay ments
  2122   "DATA",343 ,10,1,8,0)
  2123   for copaym ents and p er diems a s a conven ience to y ou.  VA, b y law, doe s not
  2124   "DATA",343 ,10,1,9,0)
  2125   pay intere st on cred it balance s.  Refund s of credi t balances  will be i ssued
  2126   "DATA",343 ,10,1,10,0 )
  2127   upon writt en request .  Otherwi se, refund s will be  issued und er the 
  2128   "DATA",343 ,10,1,11,0 )
  2129   following  conditions :
  2130   "DATA",343 ,10,1,12,0 )
  2131     
  2132   "DATA",343 ,10,1,13,0 )
  2133       If the re has bee n no charg ing activi ty on the  account wi thin the p ast
  2134   "DATA",343 ,10,1,14,0 )
  2135       60 day s, and the  credit ba lance exce eds $25, V A will ref und the
  2136   "DATA",343 ,10,1,15,0 )
  2137       credit  balance.
  2138   "DATA",343 ,10,1,16,0 )
  2139     
  2140   "DATA",343 ,10,1,17,0 )
  2141     
  2142   "DATA",343 ,10,1,18,0 )
  2143     
  2144   "DATA",343 ,10,1,19,0 )
  2145     
  2146   "DATA",343 ,10,1,20,0 )
  2147       If the re has bee n no charg ing activi ty on the  account wi thin the p ast
  2148   "DATA",343 ,10,1,21,0 )
  2149       year,  the credit  balance w ill be ref unded if l ess than o r equal
  2150   "DATA",343 ,10,1,22,0 )
  2151       to $25 .00.  Howe ver, VA wi ll not iss ue refunds  for credi t
  2152   "DATA",343 ,10,1,23,0 )
  2153       amount s of less  than $1.00 .
  2154   "DATA",343 ,10,1,24,0 )
  2155     
  2156   "DATA",343 ,10,1,25,0 )
  2157   If you hav e any ques tions conc erning thi s letter,  please cal l the numb er
  2158   "DATA",343 ,10,1,26,0 )
  2159   shown on t he stateme nt.
  2160   "DATA",343 ,10,2)
  2161   Notice of  Credit Bal ance
  2162   "DATA",343 ,11,0)
  2163   FL 4-483a
  2164   "DATA",343 ,11,1,0)
  2165   ^^7^7^2931 014^^^^
  2166   "DATA",343 ,11,1,1,0)
  2167   We have wr itten to y ou previou sly about  your indeb tedness.   The amount  due
  2168   "DATA",343 ,11,1,2,0)
  2169    is now $| PRCA BALAN CE|. It is  now urgen t that you  contact t his office
  2170   "DATA",343 ,11,1,3,0)
  2171    within fi ve days fr om the dat e of this  letter reg arding set tlement
  2172   "DATA",343 ,11,1,4,0)
  2173   of this de bt.
  2174   "DATA",343 ,11,1,5,0)
  2175     
  2176   "DATA",343 ,11,1,6,0)
  2177     
  2178   "DATA",343 ,11,1,7,0)
  2179   Finance Of ficer
  2180   "DATA",343 ,11,2)
  2181   Current Em ployee/Ex- employee/V endor (2FU )
  2182   "DATA",343 ,12,0)
  2183   FL 4-483
  2184   "DATA",343 ,12,1,0)
  2185   ^^42^42^30 01017^
  2186   "DATA",343 ,12,1,1,0)
  2187   We have wr itten to y ou on seve ral occasi ons about  your debt  of
  2188   "DATA",343 ,12,1,2,0)
  2189   $|PRCA BAL ANCE|. Thi s amount c onsists of  $|PRCA PR INCIPAL BA LANCE|
  2190   "DATA",343 ,12,1,3,0)
  2191   principal,  $|PRCA IN TEREST BAL ANCE| inte rest and $ |PRCA ADMI N BALANCE|
  2192   "DATA",343 ,12,1,4,0)
  2193   administra tive cost  of collect ion fees.  It is now  urgent tha t you cont act
  2194   "DATA",343 ,12,1,5,0)
  2195   this offic e immediat ely regard ing settle ment of th e debt.  Y ou may con tact
  2196   "DATA",343 ,12,1,6,0)
  2197   us at |PRC A AR PHONE | between  |PRCA AR H OURS|.
  2198   "DATA",343 ,12,1,7,0)
  2199    
  2200   "DATA",343 ,12,1,8,0)
  2201   We have au thority to  accept a  lesser amo unt in ful l settleme nt of your
  2202   "DATA",343 ,12,1,9,0)
  2203   debt.  Car eful consi deration w ill be giv en to an o ffer of an y reasonab le
  2204   "DATA",343 ,12,1,10,0 )
  2205   amount in  relation t o your fin ancial sta tus.  A co mpromise o ffer will  not
  2206   "DATA",343 ,12,1,11,0 )
  2207   be conside red unless  accompani ed by a pr operly com pleted VA  Form 4 -56 55,
  2208   "DATA",343 ,12,1,12,0 )
  2209   Financial  Status Rep ort.  VA F orm 4-5655  is enclos ed for thi s purpose
  2210   "DATA",343 ,12,1,13,0 )
  2211   along with  a self-ad dressed en velope.
  2212   "DATA",343 ,12,1,14,0 )
  2213    
  2214   "DATA",343 ,12,1,15,0 )
  2215   INVOLUNTAR Y COLLECTI ON: The De partment o f Veterans  Affairs ( VA) is
  2216   "DATA",343 ,12,1,16,0 )
  2217   required u nder 31 U. S.C., chap ter 37, su bchapter I I, to coll ect debts  owed
  2218   "DATA",343 ,12,1,17,0 )
  2219   to the gov ernment.   Since your  debt is o ver 60 day s old, unl ess action  is
  2220   "DATA",343 ,12,1,18,0 )
  2221   taken to s atisfy thi s debt wit hin 30 day s your deb t may be r eferred fo r
  2222   "DATA",343 ,12,1,19,0 )
  2223   involuntar y collecti on action.   This mea ns any cur rent or fu ture feder al
  2224   "DATA",343 ,12,1,20,0 )
  2225   salary, lu mp sum or  retirement  payments,  insurance  dividends , or other
  2226   "DATA",343 ,12,1,21,0 )
  2227   payments t hat are ma de to you  under any  law admini stered by  VA may be
  2228   "DATA",343 ,12,1,22,0 )
  2229   withheld t o pay your  delinquen t debt. Yo ur debt ma y be refer red to the
  2230   "DATA",343 ,12,1,23,0 )
  2231   Department  of Treasu ry for col lection an d/or admin istrative  offset.
  2232   "DATA",343 ,12,1,24,0 )
  2233   Please rea d the atta chment for  specific  details re garding th is process  as
  2234   "DATA",343 ,12,1,25,0 )
  2235   well as th e rights y ou have un der this p rocess.  A ny of thes e actions  may
  2236   "DATA",343 ,12,1,26,0 )
  2237   result in  processing  fees bein g charged  to you.  P ayment che cks that a re
  2238   "DATA",343 ,12,1,27,0 )
  2239   canceled b ecause the y have not  been cash ed within  one year m ay be appl ied
  2240   "DATA",343 ,12,1,28,0 )
  2241   to offset  the indebt edness and  not be re issued.  O ther invol untary
  2242   "DATA",343 ,12,1,29,0 )
  2243   collection  actions m ay include  the repor ting of yo ur delinqu ent accoun t to
  2244   "DATA",343 ,12,1,30,0 )
  2245   credit rep orting age ncies 60 d ays from t he date of  this lett er. 
  2246   "DATA",343 ,12,1,31,0 )
  2247    
  2248   "DATA",343 ,12,1,32,0 )
  2249   Please mak e your che ck or mone y order pa yable to t he Departm ent of
  2250   "DATA",343 ,12,1,33,0 )
  2251   Veterans A ffairs and  return it  to the ab ove addres s along wi th the bot tom
  2252   "DATA",343 ,12,1,34,0 )
  2253   portion of  this lett er.  Pleas e include  your full  name and f ile number  on
  2254   "DATA",343 ,12,1,35,0 )
  2255   your check  or money  order to i nsure prop er credit.   In the e vent you a re
  2256   "DATA",343 ,12,1,36,0 )
  2257   unable to  pay in ful l immediat ely, you s hould cont act this o ffice,
  2258   "DATA",343 ,12,1,37,0 )
  2259   preferably  by teleph one, to in form me of  your inte ntions for  settlemen t.
  2260   "DATA",343 ,12,1,38,0 )
  2261   Otherwise,  any or al l of the a bove actio ns may be  taken to c ollect you r
  2262   "DATA",343 ,12,1,39,0 )
  2263   debt.
  2264   "DATA",343 ,12,1,40,0 )
  2265    
  2266   "DATA",343 ,12,1,41,0 )
  2267   Finance Of ficer
  2268   "DATA",343 ,12,1,42,0 )
  2269   FL 4-483
  2270   "DATA",343 ,12,2)
  2271   All Debts  $25.00-$59 9.99 (exce pt Pharmac y/Means Te st) (3FU)
  2272   "DATA",343 ,13,0)
  2273   FL 4-485
  2274   "DATA",343 ,13,1,0)
  2275   ^^50^50^30 01017^
  2276   "DATA",343 ,13,1,1,0)
  2277   We have wr itten to y ou on seve ral occasi ons about  your debt  of
  2278   "DATA",343 ,13,1,2,0)
  2279   $|PRCA BAL ANCE|. Thi s amount c onsists of  $|PRCA PR INCIPAL BA LANCE|
  2280   "DATA",343 ,13,1,3,0)
  2281   principal,  $|PRCA IN TEREST BAL ANCE| inte rest and $ |PRCA ADMI N BALANCE|
  2282   "DATA",343 ,13,1,4,0)
  2283   administra tive cost  of collect ion fees.  It is now  urgent tha t you cont act
  2284   "DATA",343 ,13,1,5,0)
  2285   this offic e immediat ely regard ing settle ment of th e debt.  Y ou may con tact
  2286   "DATA",343 ,13,1,6,0)
  2287   us at |PRC A AR PHONE | between  |PRCA AR H OURS|.
  2288   "DATA",343 ,13,1,7,0)
  2289    
  2290   "DATA",343 ,13,1,8,0)
  2291   We have au thority to  accept a  lesser amo unt in ful l settleme nt of your
  2292   "DATA",343 ,13,1,9,0)
  2293   debt.  Car eful consi deration w ill be giv en to an o ffer of an y reasonab le
  2294   "DATA",343 ,13,1,10,0 )
  2295   amount in  relation t o your fin ancial sta tus.  A co mpromise o ffer will  not
  2296   "DATA",343 ,13,1,11,0 )
  2297   be conside red unless  accompani ed by a pr operly com pleted VA  Form 4 -56 55,
  2298   "DATA",343 ,13,1,12,0 )
  2299   Financial  Status Rep ort.  VA F orm 4-5655  is enclos ed for thi s purpose
  2300   "DATA",343 ,13,1,13,0 )
  2301   along with  a self-ad dressed en velope.
  2302   "DATA",343 ,13,1,14,0 )
  2303    
  2304   "DATA",343 ,13,1,15,0 )
  2305   INVOLUNTAR Y COLLECTI ON: The De partment o f Veterans  Affairs ( VA) is
  2306   "DATA",343 ,13,1,16,0 )
  2307   required u nder 31 U. S.C., chap ter 37, su bchapter I I, to coll ect debts  owed
  2308   "DATA",343 ,13,1,17,0 )
  2309   to the gov ernment.   Since your  debt is o ver 60 day s old, unl ess action  is
  2310   "DATA",343 ,13,1,18,0 )
  2311   taken to s atisfy thi s debt wit hin 30 day s your deb t may be r eferred fo r
  2312   "DATA",343 ,13,1,19,0 )
  2313   involuntar y collecti on action.   This mea ns any cur rent or fu ture feder al
  2314   "DATA",343 ,13,1,20,0 )
  2315   salary, lu mp sum or  retirement  payments,  insurance  dividends , or other
  2316   "DATA",343 ,13,1,21,0 )
  2317   payments t hat are ma de to you  under any  law admini stered by  VA may be
  2318   "DATA",343 ,13,1,22,0 )
  2319   withheld t o pay your  delinquen t debt. Yo ur debt ma y be refer red to the
  2320   "DATA",343 ,13,1,23,0 )
  2321   Department  of Treasu ry for col lection an d/or admin istrative  offset.
  2322   "DATA",343 ,13,1,24,0 )
  2323   Please rea d the atta chment for  specific  details re garding th is process  as
  2324   "DATA",343 ,13,1,25,0 )
  2325   well as th e rights y ou have un der this p rocess.  A ny of thes e actions  may
  2326   "DATA",343 ,13,1,26,0 )
  2327   result in  processing  fees bein g charged  to you.  P ayment che cks that a re
  2328   "DATA",343 ,13,1,27,0 )
  2329   canceled b ecause the y have not  been cash ed within  one year m ay be appl ied
  2330   "DATA",343 ,13,1,28,0 )
  2331   to offset  the indebt edness and  not be re issued.  O ther invol untary
  2332   "DATA",343 ,13,1,29,0 )
  2333   collection  actions m ay include  the repor ting of yo ur delinqu ent accoun t to
  2334   "DATA",343 ,13,1,30,0 )
  2335   credit rep orting age ncies 60 d ays from t he date of  this lett er. 
  2336   "DATA",343 ,13,1,31,0 )
  2337    
  2338   "DATA",343 ,13,1,32,0 )
  2339   Your debt  may be ref erred to t he United  States Att orney for  appropriat e
  2340   "DATA",343 ,13,1,33,0 )
  2341   legal acti on within  30 days fr om the dat e of this  letter.  U nless, you
  2342   "DATA",343 ,13,1,34,0 )
  2343   take actio n to pay y our debt i n full, ma ke satisfa ctory arra ngements t o
  2344   "DATA",343 ,13,1,35,0 )
  2345   pay by ins tallments  or submit  a reasonab le comprom ise offer,  prior to  the
  2346   "DATA",343 ,13,1,36,0 )
  2347   expiration  of the 30  days.  Th is referra l will res ult in a o ne-time
  2348   "DATA",343 ,13,1,37,0 )
  2349   administra tive charg e to you o f $|PRCA L ITIGATION  FEE|.  Cou rt action  may
  2350   "DATA",343 ,13,1,38,0 )
  2351   result in  the additi on of U.S.  Marshal f ees and co urt costs  to your de bt.
  2352   "DATA",343 ,13,1,39,0 )
  2353    
  2354   "DATA",343 ,13,1,40,0 )
  2355   Please mak e your che ck or mone y order pa yable to t he Departm ent of
  2356   "DATA",343 ,13,1,41,0 )
  2357   Veterans A ffairs and  return it  to the ab ove addres s along wi th the bot tom
  2358   "DATA",343 ,13,1,42,0 )
  2359   portion of  this lett er.  Pleas e include  your full  name and f ile number  on
  2360   "DATA",343 ,13,1,43,0 )
  2361   your check  or money  order to i nsure prop er credit.   In the e vent you a re
  2362   "DATA",343 ,13,1,44,0 )
  2363   unable to  pay in ful l immediat ely, you s hould cont act this o ffice,
  2364   "DATA",343 ,13,1,45,0 )
  2365   preferably  by teleph one, to in form me of  your inte ntions for  settlemen t.
  2366   "DATA",343 ,13,1,46,0 )
  2367   Otherwise,  any or al l of the a bove actio ns may be  taken to c ollect you r
  2368   "DATA",343 ,13,1,47,0 )
  2369   debt.
  2370   "DATA",343 ,13,1,48,0 )
  2371    
  2372   "DATA",343 ,13,1,49,0 )
  2373   Finance Of ficer
  2374   "DATA",343 ,13,1,50,0 )
  2375   FL 4-485
  2376   "DATA",343 ,13,2)
  2377   Emp/Ex-emp /Vendor >$ 599.99, In el/Hum. >$ 1199.00 (3 FU)
  2378   "DATA",343 ,14,0)
  2379   FL 4-520c
  2380   "DATA",343 ,14,1,0)
  2381   ^^110^110^ 2931014^^^ ^
  2382   "DATA",343 ,14,1,1,0)
  2383   NOTICE  OF  INDEBTEDN ESS:  Acco rding to o ur records , you are  indebted t o the
  2384   "DATA",343 ,14,1,2,0)
  2385   United Sta tes for $| PRCA BALAN CE|.  This  indebtedn ess was ca used
  2386   "DATA",343 ,14,1,3,0)
  2387   by |PRCA R ESULTING|.
  2388   "DATA",343 ,14,1,4,0)
  2389     
  2390   "DATA",343 ,14,1,5,0)
  2391   You are he reby notif ied that u nless you  make arran gements wi thin 30 da ys from
  2392   "DATA",343 ,14,1,6,0)
  2393   the date o f this let ter to rep ay this de bt, or not ify this o ffice, in  writing,
  2394   "DATA",343 ,14,1,7,0)
  2395   that you w ish to dis pute the e xistence o r amount o f the debt , or reque st
  2396   "DATA",343 ,14,1,8,0)
  2397   waiver (se e enclosed  NOTICE OF  RIGHTS),  we will of fset your  current pa y until
  2398   "DATA",343 ,14,1,9,0)
  2399   the debt i s liquidat ed.  If of fset would  cause a h ardship, y ou should  submit a
  2400   "DATA",343 ,14,1,10,0 )
  2401   proposed r epayment p lan for a  lesser wit hholding s upported b y the prop erly
  2402   "DATA",343 ,14,1,11,0 )
  2403   completed  VA Form 4- 5655, Fina ncial Stat us Report,  which is  enclosed f or your
  2404   "DATA",343 ,14,1,12,0 )
  2405   use.
  2406   "DATA",343 ,14,1,13,0 )
  2407     
  2408   "DATA",343 ,14,1,14,0 )
  2409   If full pa yment of t he debt is  received  within 30  days, no i nterest,
  2410   "DATA",343 ,14,1,15,0 )
  2411   administra tive cost  of collect ion fees,  or penalty  charges w ill be cha rged.
  2412   "DATA",343 ,14,1,16,0 )
  2413   If full pa yment of t his debt i s not rece ived withi n 30 days  from the d ate of
  2414   "DATA",343 ,14,1,17,0 )
  2415   this lette r, or the  debt is be ing repaid  by instal lments, yo u will be  charged
  2416   "DATA",343 ,14,1,18,0 )
  2417   interest a t an annua l rate of  |PRCA INTE REST|%.  A  monthly a dministrat ive cost o f
  2418   "DATA",343 ,14,1,19,0 )
  2419   collection  fee of $| PRCA ADMIN | (subject  to change  annually)  may also  be
  2420   "DATA",343 ,14,1,20,0 )
  2421   charged.   Further, a  penalty c harge of | PRCA PENAL TY|% (not  to exceed
  2422   "DATA",343 ,14,1,21,0 )
  2423   6% annuall y) will be  assessed  on any acc ount more  than 90 da ys past du e.
  2424   "DATA",343 ,14,1,22,0 )
  2425   If there i s a balanc e remainin g after yo u terminat e employme nt, we wil l
  2426   "DATA",343 ,14,1,23,0 )
  2427   offset the  balance o f your fin al salary,  lump sum  payment, C SRS or FER S.
  2428   "DATA",343 ,14,1,24,0 )
  2429     
  2430   "DATA",343 ,14,1,25,0 )
  2431   You are ad vised that  any knowi ngly false  or frivol ous statem ents,
  2432   "DATA",343 ,14,1,26,0 )
  2433   representa tions, or  evidence m ay subject  you to:   disciplina ry procedu res
  2434   "DATA",343 ,14,1,27,0 )
  2435   under 5 U. S.C. ch 75 ,5 CFR par t 752, or  any other  applicable  statutes  or
  2436   "DATA",343 ,14,1,28,0 )
  2437   regulation s; penalti es under t he False C laims Act  31 U.S.C.  3729-3731,  or any
  2438   "DATA",343 ,14,1,29,0 )
  2439   other appl icable sta tutory aut hority; or  criminal  penalties  under 18 U .S.C.
  2440   "DATA",343 ,14,1,30,0 )
  2441   286, 287,  1001, and  1002 or an y other st atutory au thority.
  2442   "DATA",343 ,14,1,31,0 )
  2443     
  2444   "DATA",343 ,14,1,32,0 )
  2445   You are al so advised  that any  amount pai d by you o r deducted  from your  pay
  2446   "DATA",343 ,14,1,33,0 )
  2447   which may  be later f ound not t o be owed  will be pr omptly ref unded to y ou.
  2448   "DATA",343 ,14,1,34,0 )
  2449   Please dis regard thi s letter i f you have  recently  paid this  debt in fu ll.
  2450   "DATA",343 ,14,1,35,0 )
  2451     
  2452   "DATA",343 ,14,1,36,0 )
  2453     
  2454   "DATA",343 ,14,1,37,0 )
  2455     
  2456   "DATA",343 ,14,1,38,0 )
  2457   Finance Of ficer
  2458   "DATA",343 ,14,1,39,0 )
  2459     
  2460   "DATA",343 ,14,1,40,0 )
  2461   Enclosure
  2462   "DATA",343 ,14,1,41,0 )
  2463     
  2464   "DATA",343 ,14,1,42,0 )
  2465   |TOP|
  2466   "DATA",343 ,14,1,43,0 )
  2467     
  2468   "DATA",343 ,14,1,44,0 )
  2469                          NOTICE OF  RIGHTS AN D OBLIGATI ONS
  2470   "DATA",343 ,14,1,45,0 )
  2471     
  2472   "DATA",343 ,14,1,46,0 )
  2473     
  2474   "DATA",343 ,14,1,47,0 )
  2475   DEBTS OWED  THE UNITE D STATES G OVERNMENT:   The law  requires t he Departm ent
  2476   "DATA",343 ,14,1,48,0 )
  2477   of Veteran s Affairs  (VA) to co llect debt s owed the  governmen t.  If an
  2478   "DATA",343 ,14,1,49,0 )
  2479   individual  is entitl ed to rece ive federa l salary p ayments.   VA is requ ired to
  2480   "DATA",343 ,14,1,50,0 )
  2481   collect th e debt by  withholdin g current  pay until  the debt i s paid, ex cept as
  2482   "DATA",343 ,14,1,51,0 )
  2483   explained  below.  An y current  or future  federal sa lary, lump  sum or re tirement
  2484   "DATA",343 ,14,1,52,0 )
  2485   payments,  or other p ayments ma de by VA m ay be with held.  You  have the  right to
  2486   "DATA",343 ,14,1,53,0 )
  2487   inspect or  to reques t a copy o f any reco rd relatin g to the d ebt.
  2488   "DATA",343 ,14,1,54,0 )
  2489     
  2490   "DATA",343 ,14,1,55,0 )
  2491   NOTE:  Whe never this  letter st ates that  you have a  period of  time to t ake
  2492   "DATA",343 ,14,1,56,0 )
  2493   some actio n or to no tify us, t he period  of time be gins to ru n from the  date
  2494   "DATA",343 ,14,1,57,0 )
  2495   appearing  on the fro nt of this  letter.
  2496   "DATA",343 ,14,1,58,0 )
  2497     
  2498   "DATA",343 ,14,1,59,0 )
  2499   RIGHT TO D ISPUTE THE  EXISTENCE  OR AMOUNT  OF THIS D EBT:  If y ou tell us  in
  2500   "DATA",343 ,14,1,60,0 )
  2501   writing wi thin 30 da ys that yo u believe  that you d o not owe  this debt  or that
  2502   "DATA",343 ,14,1,61,0 )
  2503   the amount  of this d ebt is inc orrect, we  will not  withhold y our curren t pay
  2504   "DATA",343 ,14,1,62,0 )
  2505   until we c onfirm tha t you are  indebted a nd the amo unt is cor rect or we
  2506   "DATA",343 ,14,1,63,0 )
  2507   determine  that the d elay requi red to res olve the d ispute wil l jeopardi ze our
  2508   "DATA",343 ,14,1,64,0 )
  2509   ability to  collect t he full am ount of th e debt.  Y ou should  explain to  the
  2510   "DATA",343 ,14,1,65,0 )
  2511   extent you  can, why  you believ e you do n ot owe the  debt or w hy the amo unt is
  2512   "DATA",343 ,14,1,66,0 )
  2513   incorrect.
  2514   "DATA",343 ,14,1,67,0 )
  2515     
  2516   "DATA",343 ,14,1,68,0 )
  2517   RIGHT TO D ISPUTE OFF SET SCHEDU LE:  If of fset of yo ur current  pay would
  2518   "DATA",343 ,14,1,69,0 )
  2519   cause hard ship, you  may reques t a review  of the am ount offse t.  Such r equest
  2520   "DATA",343 ,14,1,70,0 )
  2521   for review  should be  in writin g and incl ude a prop osed repay ment sched ule
  2522   "DATA",343 ,14,1,71,0 )
  2523   supported  by a prope rly comple ted VA For m 4-5655,  Financial  Status Rep ort,
  2524   "DATA",343 ,14,1,72,0 )
  2525   which is e nclosed fo r your use .  If a re quest for  review of  the issue  of the
  2526   "DATA",343 ,14,1,73,0 )
  2527   amount of  salary off set is rec eived with in 30 days  calendar  days from  the date
  2528   "DATA",343 ,14,1,74,0 )
  2529   of this le tter, we w ill take n o action t o offset y our curren t pay unti l a
  2530   "DATA",343 ,14,1,75,0 )
  2531   review has  been made .
  2532   "DATA",343 ,14,1,76,0 )
  2533     
  2534   "DATA",343 ,14,1,77,0 )
  2535   RIGHT TO R EQUEST WAI VER OF THE  DEBT:  Un der certai n circumst ances, we  can
  2536   "DATA",343 ,14,1,78,0 )
  2537   waive the  debt.  Thi s means th at you wil l not be r equired to  pay the a mount
  2538   "DATA",343 ,14,1,79,0 )
  2539   owed.  How ever, your  debt may  be conside red for wa iver only  if:  1) th e
  2540   "DATA",343 ,14,1,80,0 )
  2541   advance wa s made to  cover expe nses erron eously aut horized; 2 ) you spen t the
  2542   "DATA",343 ,14,1,81,0 )
  2543   advance in  reliance  on the err oneous tra vel author ization; a nd 3) you  are
  2544   "DATA",343 ,14,1,82,0 )
  2545   indebted f or the rep ayment of  all or par t of the a mount adva nced, afte r the
  2546   "DATA",343 ,14,1,83,0 )
  2547   advance is  applied a gainst any  legitimat e expenses  incurred  by you.
  2548   "DATA",343 ,14,1,84,0 )
  2549     
  2550   "DATA",343 ,14,1,85,0 )
  2551   To be cons idered for  waiver, y ou must wr ite to us  and reques t one.  Yo u should
  2552   "DATA",343 ,14,1,86,0 )
  2553   explain wh y you beli eve that y ou are not  at fault  in the cre ation of t his
  2554   "DATA",343 ,14,1,87,0 )
  2555   debt.
  2556   "DATA",343 ,14,1,88,0 )
  2557     
  2558   "DATA",343 ,14,1,89,0 )
  2559   If we do n ot receive  your requ est within  30 days,  we will be gin to wit hhold
  2560   "DATA",343 ,14,1,90,0 )
  2561   your curre nt pay as  explained  in the cov ering lett er.  If yo u do not r equest a
  2562   "DATA",343 ,14,1,91,0 )
  2563   waiver wit hin 30 day s, you may  still do  so at any  time withi n 3 years  of the
  2564   "DATA",343 ,14,1,92,0 )
  2565   date of di scovery of  your inde btedness.   Withholdi ng of your  pay will
  2566   "DATA",343 ,14,1,93,0 )
  2567   continue,  however, d uring any  considerat ion of a w aiver requ est receiv ed after
  2568   "DATA",343 ,14,1,94,0 )
  2569   30 days of  the date  appearing  on the fro nt of this  letter.   Any withho ld
  2570   "DATA",343 ,14,1,95,0 )
  2571   amount whi ch is waiv ed will be  refunded.
  2572   "DATA",343 ,14,1,96,0 )
  2573     
  2574   "DATA",343 ,14,1,97,0 )
  2575   ADMINISTRA TIVE COST  OF COLLECT ION FEES:   The month ly adminis trative co st of
  2576   "DATA",343 ,14,1,98,0 )
  2577   collection  fee will  not be add ed to your  debt if,  within 30  days, full  payment
  2578   "DATA",343 ,14,1,99,0 )
  2579   of the deb t is recei ved or an  acceptable  repayment  plan is w orked out.
  2580   "DATA",343 ,14,1,100, 0)
  2581   If an inst allment re payment pl an is work ed out and  any insta llment is
  2582   "DATA",343 ,14,1,101, 0)
  2583   not receiv ed by the  due date,  the monthl y administ rative cos t of colle ction
  2584   "DATA",343 ,14,1,102, 0)
  2585   fee will t hereafter  be charged  for the l ife of the  debt.  Ot her
  2586   "DATA",343 ,14,1,103, 0)
  2587   costs of c ollection  may also b e added to  the debt  if additio nal action s
  2588   "DATA",343 ,14,1,104, 0)
  2589   become nec essary.
  2590   "DATA",343 ,14,1,105, 0)
  2591     
  2592   "DATA",343 ,14,1,106, 0)
  2593   PENALTY CH ARGES:  Th e monthly  penalty ch arge will  not be add ed to your
  2594   "DATA",343 ,14,1,107, 0)
  2595   debt, if w ithin 90 d ays, full  payment of  debt is r eceived or  an accept able
  2596   "DATA",343 ,14,1,108, 0)
  2597   repayment  plan is wo rked out.   If an acc eptable pl an is agre ed upon an d you
  2598   "DATA",343 ,14,1,109, 0)
  2599   default on  that agre ement, we  will begin  assessing  a penalty  charge 90  days
  2600   "DATA",343 ,14,1,110, 0)
  2601   after defa ult.
  2602   "DATA",343 ,14,2)
  2603   Current Em ployee - P rior 12/28 /85 (1FU*)
  2604   "DATA",343 ,15,0)
  2605   FL 4-520d
  2606   "DATA",343 ,15,1,0)
  2607   ^^101^101^ 2931014^^^ ^
  2608   "DATA",343 ,15,1,1,0)
  2609   NOTICE OF  INDEBTEDNE SS:  Accor ding to ou r records,  you are i ndebted to  the
  2610   "DATA",343 ,15,1,2,0)
  2611   United Sta tes for $| PRCA BALAN CE|.  This  indebtedn ess was ca used
  2612   "DATA",343 ,15,1,3,0)
  2613   by |PRCA R ESULTING|.
  2614   "DATA",343 ,15,1,4,0)
  2615     
  2616   "DATA",343 ,15,1,5,0)
  2617   This is a  debt owed  by you to  the United  States Go vernment.   Please ma il
  2618   "DATA",343 ,15,1,6,0)
  2619   your check  or money  order paya ble to the  Departmen t of Veter ans Affair s
  2620   "DATA",343 ,15,1,7,0)
  2621   and send i t to the a ddress abo ve along w ith the pa yment remi ttance sli p
  2622   "DATA",343 ,15,1,8,0)
  2623   below.  Pl ease inclu de your fu ll name an d SSAN on  your check  or money  order
  2624   "DATA",343 ,15,1,9,0)
  2625   to insure  proper cre dit.
  2626   "DATA",343 ,15,1,10,0 )
  2627     
  2628   "DATA",343 ,15,1,11,0 )
  2629   NOTICE OF  RIGHTS:  I f you do n ot believe  you owe t his debt o r you thin k the
  2630   "DATA",343 ,15,1,12,0 )
  2631   amount is  incorrect,  you have  a right to  dispute t he debt.   You also h ave
  2632   "DATA",343 ,15,1,13,0 )
  2633   the right  to request  a waiver  of the deb t.  Waiver  means tha t you will  not
  2634   "DATA",343 ,15,1,14,0 )
  2635   have to pa y the debt .  Additio nal inform ation conc erning the se rights  is
  2636   "DATA",343 ,15,1,15,0 )
  2637   attached t o this let ter.  Plea se read it  carefully .
  2638   "DATA",343 ,15,1,16,0 )
  2639     
  2640   "DATA",343 ,15,1,17,0 )
  2641   LATE PAYME NT CHARGES :  If full  payment o f the debt  is receiv ed within  30
  2642   "DATA",343 ,15,1,18,0 )
  2643   days, no i nterest, a dministrat ive cost o f collecti on fees, o r penalty
  2644   "DATA",343 ,15,1,19,0 )
  2645   charges wi ll be char ged.  If f ull paymen t of this  debt is no t received
  2646   "DATA",343 ,15,1,20,0 )
  2647   within 30  days from  the date o f this let ter, you w ill be cha rged inter est
  2648   "DATA",343 ,15,1,21,0 )
  2649   at an annu al rate of  |PRCA INT EREST|%.   A monthly  administra tive cost  of
  2650   "DATA",343 ,15,1,22,0 )
  2651   collection  fee of $| PRCA ADMIN | (subject  to change  annually)  may also
  2652   "DATA",343 ,15,1,23,0 )
  2653   be charged .  Further , a penalt y charge o f |PRCA PE NALTY|% (n ot to
  2654   "DATA",343 ,15,1,24,0 )
  2655   exceed 6%  annually)  will be as sessed on  any accoun t more tha n 90 days  past
  2656   "DATA",343 ,15,1,25,0 )
  2657   due.
  2658   "DATA",343 ,15,1,26,0 )
  2659     
  2660   "DATA",343 ,15,1,27,0 )
  2661   REPAYMENT  PLAN:  If  you are un able to pa y the full  amount in  one payme nt,
  2662   "DATA",343 ,15,1,28,0 )
  2663   you should  complete  the enclos ed VA Form  4-5655, F inancial S tatus Repo rt,
  2664   "DATA",343 ,15,1,29,0 )
  2665   and return  it with a  partial p ayment and  a stateme nt of how  you will p ay the
  2666   "DATA",343 ,15,1,30,0 )
  2667   balance.   Your plan  should ind icate the  amount you  will pay  each month  and
  2668   "DATA",343 ,15,1,31,0 )
  2669   the date p ayment wil l be made.   any reas onable pla n will rec eive caref ul
  2670   "DATA",343 ,15,1,32,0 )
  2671   considerat ion.  Debt s being re paid by in stallments  will be c harged int erest
  2672   "DATA",343 ,15,1,33,0 )
  2673   at an annu al rate of  |PRCA INT EREST|%.
  2674   "DATA",343 ,15,1,34,0 )
  2675     
  2676   "DATA",343 ,15,1,35,0 )
  2677   If you hav e any ques tions conc erning thi s letter,  please con tact this  office
  2678   "DATA",343 ,15,1,36,0 )
  2679   for assist ance.
  2680   "DATA",343 ,15,1,37,0 )
  2681     
  2682   "DATA",343 ,15,1,38,0 )
  2683     
  2684   "DATA",343 ,15,1,39,0 )
  2685     
  2686   "DATA",343 ,15,1,40,0 )
  2687     
  2688   "DATA",343 ,15,1,41,0 )
  2689   Finance Of ficer
  2690   "DATA",343 ,15,1,42,0 )
  2691     
  2692   "DATA",343 ,15,1,43,0 )
  2693   Enclosure
  2694   "DATA",343 ,15,1,44,0 )
  2695     
  2696   "DATA",343 ,15,1,45,0 )
  2697   |TOP|
  2698   "DATA",343 ,15,1,46,0 )
  2699                          NOTICE OF  RIGHTS AN D OBLIGATI ONS
  2700   "DATA",343 ,15,1,47,0 )
  2701     
  2702   "DATA",343 ,15,1,48,0 )
  2703     
  2704   "DATA",343 ,15,1,49,0 )
  2705   DEBTS OWED  THE UNITE D STATES G OVERNMENT:   The law  requires t he Departm ent
  2706   "DATA",343 ,15,1,50,0 )
  2707   of Veteran s Affairs  (VA) to co llect debt s owed the  governmen t.  When t he
  2708   "DATA",343 ,15,1,51,0 )
  2709   individual  or corpor ation is e ntitled to  payments,  the VA is  required  to
  2710   "DATA",343 ,15,1,52,0 )
  2711   collect th e debt by  withholdin g future p ayments un til the de bt is paid ,
  2712   "DATA",343 ,15,1,53,0 )
  2713   except as  explained  below.  An y current  or future  VA payment s or other
  2714   "DATA",343 ,15,1,54,0 )
  2715   payments m ade under  any law ad ministered  by the VA  may be wi thheld.  Y ou
  2716   "DATA",343 ,15,1,55,0 )
  2717   have the r ight to in spect or t o request  a copy of  any record  relating  to the
  2718   "DATA",343 ,15,1,56,0 )
  2719   debt.
  2720   "DATA",343 ,15,1,57,0 )
  2721     
  2722   "DATA",343 ,15,1,58,0 )
  2723   NOTE:  Whe never this  letter st ates that  you have a  period of  time to t ake
  2724   "DATA",343 ,15,1,59,0 )
  2725   some actio n or to no tify us, t he period  of time be gins to ru n from the  date
  2726   "DATA",343 ,15,1,60,0 )
  2727   appearing  on the fro nt of this  letter.
  2728   "DATA",343 ,15,1,61,0 )
  2729     
  2730   "DATA",343 ,15,1,62,0 )
  2731   RIGHT TO D ISPUTE THE  EXISTENCE  OR AMOUNT  OF THIS D EBT:  If y ou tell us  in
  2732   "DATA",343 ,15,1,63,0 )
  2733   writing wi thin 30 da ys that yo u believe  that you d o not owe  this debt  or
  2734   "DATA",343 ,15,1,64,0 )
  2735   that the a mount of t his debt i s incorrec t, we will  not withh old any cu rrent
  2736   "DATA",343 ,15,1,65,0 )
  2737   or future  payments,  lump sum,  or retirem ent until  we confirm  that you  do owe
  2738   "DATA",343 ,15,1,66,0 )
  2739   this debt  and the am ount is co rrect or w e determin e that the  delay req uired
  2740   "DATA",343 ,15,1,67,0 )
  2741   to resolve  the dispu te will je opardize o ur ability  to collec t the full
  2742   "DATA",343 ,15,1,68,0 )
  2743   amount of  the debt.   You shoul d explain  to the ext ent that y ou can, wh y you
  2744   "DATA",343 ,15,1,69,0 )
  2745   believe yo u do not o we the deb t or why t he amount  is incorre ct.
  2746   "DATA",343 ,15,1,70,0 )
  2747     
  2748   "DATA",343 ,15,1,71,0 )
  2749   RIGHT TO R EQUEST WAI VER OF THE  DEBT:  Un der certai n circumst ances, we  can
  2750   "DATA",343 ,15,1,72,0 )
  2751   waive the  debt.  Thi s means th at you wil l not be r equired to  pay the a mount
  2752   "DATA",343 ,15,1,73,0 )
  2753   owed.  How ever, your  debt may  be conside red for wa iver only  if: 1) the
  2754   "DATA",343 ,15,1,74,0 )
  2755   advance wa s made to  cover expe nses erron eously aut horized; 2 ) you spen t the
  2756   "DATA",343 ,15,1,75,0 )
  2757   advance in  reliance  on the err oneous tra vel author ization; a nd 3) you  are
  2758   "DATA",343 ,15,1,76,0 )
  2759   indebted f or the rep ayment of  all or par t of the a mount adva nced, afte r
  2760   "DATA",343 ,15,1,77,0 )
  2761   the advanc e is appli ed against  any legit imate expe nses incur red by you .
  2762   "DATA",343 ,15,1,78,0 )
  2763     
  2764   "DATA",343 ,15,1,79,0 )
  2765   To be cons idered for  waiver, y ou must wr ite to us  and reques t one.  Yo u
  2766   "DATA",343 ,15,1,80,0 )
  2767   should exp lain why y ou believe  that you  are not at  fault in  the creati on
  2768   "DATA",343 ,15,1,81,0 )
  2769   of this de bt.
  2770   "DATA",343 ,15,1,82,0 )
  2771     
  2772   "DATA",343 ,15,1,83,0 )
  2773   You may re quest a wa iver at an y time 3 y ears of th e date of  discovery  of
  2774   "DATA",343 ,15,1,84,0 )
  2775   your indeb tedness.
  2776   "DATA",343 ,15,1,85,0 )
  2777     
  2778   "DATA",343 ,15,1,86,0 )
  2779   ADMINISTRA TIVE COST  OF COLLECT ION FEES:   The month ly adminis trative of
  2780   "DATA",343 ,15,1,87,0 )
  2781   collection  fee will  not be add ed to your  debt if,  within 30  days, full
  2782   "DATA",343 ,15,1,88,0 )
  2783   payment of  the debt  is receive d or an ac ceptable r epayment p lan is wor ked
  2784   "DATA",343 ,15,1,89,0 )
  2785   out and an y installm ent is not  received  by the due  date, the  monthly
  2786   "DATA",343 ,15,1,90,0 )
  2787   administra tion cost  of collect ion fee wi ll thereaf ter by cha rged for t he
  2788   "DATA",343 ,15,1,91,0 )
  2789   life of th e debt.  I f an insta llment rep ayment pla n is worke d out and  any
  2790   "DATA",343 ,15,1,92,0 )
  2791   installmen t is not r eceived by  the due d ate, the m onthly adm inistrativ e cost
  2792   "DATA",343 ,15,1,93,0 )
  2793   of collect ion fee wi ll thereaf ter be cha rged for t he life of  the debt.
  2794   "DATA",343 ,15,1,94,0 )
  2795   Other cost s of colle ction may  also be ad ded to the  debt if a dditional
  2796   "DATA",343 ,15,1,95,0 )
  2797   actions be come neces sary.
  2798   "DATA",343 ,15,1,96,0 )
  2799     
  2800   "DATA",343 ,15,1,97,0 )
  2801   PENALTY CH ARGES:  Th e monthly  penalty ch arge will  not be add ed your de bt,
  2802   "DATA",343 ,15,1,98,0 )
  2803   if within  90 days, f ull paymen t of debt  is receive d or an ac ceptable
  2804   "DATA",343 ,15,1,99,0 )
  2805   repayment  plan is wo rked out.   If an acc eptable re payment pl an is agre ed
  2806   "DATA",343 ,15,1,100, 0)
  2807   upon and y ou default  on that a greement,  we will be gin assess ing a pena lty
  2808   "DATA",343 ,15,1,101, 0)
  2809   charge 90  days after  default.
  2810   "DATA",343 ,15,2)
  2811   Ex-employe e - Prior  12/28/85 ( 1FU*)
  2812   "DATA",343 ,16,0)
  2813   FL 4-534
  2814   "DATA",343 ,16,1,0)
  2815   ^^94^94^29 31014^^^^
  2816   "DATA",343 ,16,1,1,0)
  2817   NOTICE OF  INDEBTEDNE SS:  Accor ding to ou r records,  you are i ndebted to  the
  2818   "DATA",343 ,16,1,2,0)
  2819   United Sta tes for $| PRCA BALAN CE|.  This  indebtedn ess was ca used
  2820   "DATA",343 ,16,1,3,0)
  2821   by |PRCA R ESULTING|.
  2822   "DATA",343 ,16,1,4,0)
  2823     
  2824   "DATA",343 ,16,1,5,0)
  2825   You are he reby notif ied that u nless you  make arran gements wi thin 30 da ys
  2826   "DATA",343 ,16,1,6,0)
  2827   from the d ate of thi s letter t o repay th is debt or  notify th e office i n
  2828   "DATA",343 ,16,1,7,0)
  2829   writing th at you wis h to dispu te the exi stence or  amount of  the debt,  or
  2830   "DATA",343 ,16,1,8,0)
  2831   request a  hearing on  such disp ute (see a ttached No tice of Ri ghts), we  will
  2832   "DATA",343 ,16,1,9,0)
  2833   ask the Of fice of Pe rsonnel Ma nagement ( OPM) to of fset your  retired pa y at
  2834   "DATA",343 ,16,1,10,0 )
  2835   a rate of  50% of you r monthly  annuity.   If you are  unable to  pay in fu ll
  2836   "DATA",343 ,16,1,11,0 )
  2837   and if off set of 50%  would cau se a hards hip, you s hould subm it a
  2838   "DATA",343 ,16,1,12,0 )
  2839   proposed r epayment p lan for le sser withh olding sup ported by  a properly
  2840   "DATA",343 ,16,1,13,0 )
  2841   completed  VA Form 4- 5655, Fina ncial Stat us Report,  which is  enclosed
  2842   "DATA",343 ,16,1,14,0 )
  2843   for your u se.
  2844   "DATA",343 ,16,1,15,0 )
  2845     
  2846   "DATA",343 ,16,1,16,0 )
  2847   Debts bein g repaid b y installm ents will  be charged  interest  at an annu al
  2848   "DATA",343 ,16,1,17,0 )
  2849   rate of |P RCA INTERE ST|%.  A m onthly adm inistrativ e cost of  collection  fee
  2850   "DATA",343 ,16,1,18,0 )
  2851   of $|PRCA  ADMIN| (su bject to c hange annu ally) may  also be ch arged.
  2852   "DATA",343 ,16,1,19,0 )
  2853   Further, a  penalty c harge of | PRCA PENAL TY| (not t o exceed 6 % annually )
  2854   "DATA",343 ,16,1,20,0 )
  2855   will be as sessed  on  any accou nt more th an 90 days  past due.   If full
  2856   "DATA",343 ,16,1,21,0 )
  2857   payment of  the debt  is receive d within 3 0 days, no  interest,  administr ative
  2858   "DATA",343 ,16,1,22,0 )
  2859   cost of co llection f ees or pen alty charg es will be  assessed.
  2860   "DATA",343 ,16,1,23,0 )
  2861     
  2862   "DATA",343 ,16,1,24,0 )
  2863   You are ad vised that  any knowi ngly false  or frivol ous statem ents,
  2864   "DATA",343 ,16,1,25,0 )
  2865   representa tion, or e vidence ma y subject  you to:  p enalties u nder the F alse
  2866   "DATA",343 ,16,1,26,0 )
  2867   Claims Act  31 U.S.C.  3729-3731 , or any o ther appli cable stat utory auth ority;
  2868   "DATA",343 ,16,1,27,0 )
  2869   or crimina l penaltie s under 18  U.S.C. 28 6, 287, 10 01, and 10 02 or any  other
  2870   "DATA",343 ,16,1,28,0 )
  2871   applicable  statutory  authority .
  2872   "DATA",343 ,16,1,29,0 )
  2873     
  2874   "DATA",343 ,16,1,30,0 )
  2875   You are al so advised  that any  amounts pa id by you  are deduct ed from yo ur
  2876   "DATA",343 ,16,1,31,0 )
  2877   retirement  pay which  may be fo und not to  be owed w ill be pro mptly refu nded
  2878   "DATA",343 ,16,1,32,0 )
  2879   to you.
  2880   "DATA",343 ,16,1,33,0 )
  2881     
  2882   "DATA",343 ,16,1,34,0 )
  2883   Please dis regard thi s letter i f you have  recently  written to  us or pai d this
  2884   "DATA",343 ,16,1,35,0 )
  2885   debt in fu ll.
  2886   "DATA",343 ,16,1,36,0 )
  2887     
  2888   "DATA",343 ,16,1,37,0 )
  2889     
  2890   "DATA",343 ,16,1,38,0 )
  2891   Finance Of ficer
  2892   "DATA",343 ,16,1,39,0 )
  2893     
  2894   "DATA",343 ,16,1,40,0 )
  2895   Enclosures
  2896   "DATA",343 ,16,1,41,0 )
  2897     
  2898   "DATA",343 ,16,1,42,0 )
  2899   |TOP|
  2900   "DATA",343 ,16,1,43,0 )
  2901                          NOTICE OF  RIGHTS AN D OBLIGATI ONS
  2902   "DATA",343 ,16,1,44,0 )
  2903     
  2904   "DATA",343 ,16,1,45,0 )
  2905     
  2906   "DATA",343 ,16,1,46,0 )
  2907   DEBTS OWED  THE UNITE D STATES G OVERNMENT:   The law  requires t he Departm ent
  2908   "DATA",343 ,16,1,47,0 )
  2909   of Veteran s Affairs  (VA) to co llect debt  owed the  government . This inc ludes
  2910   "DATA",343 ,16,1,48,0 )
  2911   requesting  that mone ys which a re due and  payable t o a debtor  from the  Civil
  2912   "DATA",343 ,16,1,49,0 )
  2913   Service Re tirement S ystem (CSR S) or Fede ral Employ ees Retire ment Syste m
  2914   "DATA",343 ,16,1,50,0 )
  2915   (FERS) be  administra tively off set in rea sonable am ounts in o rder to co llect
  2916   "DATA",343 ,16,1,51,0 )
  2917   the debt i n one full  payment o r minimal  number of  payments.
  2918   "DATA",343 ,16,1,52,0 )
  2919     
  2920   "DATA",343 ,16,1,53,0 )
  2921   NOTE: When ever this  letter sta tes that y ou have a  period of  time to ta ke
  2922   "DATA",343 ,16,1,54,0 )
  2923   some actio n or to no tify us, t he period  of time be gins to ru n from the  date
  2924   "DATA",343 ,16,1,55,0 )
  2925   appearing  on the fro nt of this  letter.
  2926   "DATA",343 ,16,1,56,0 )
  2927     
  2928   "DATA",343 ,16,1,57,0 )
  2929   RIGHT TO D ISPUTE THE  EXISTENCE  OR AMOUNT  OF THE DE BT:  If yo u tell us  in
  2930   "DATA",343 ,16,1,58,0 )
  2931   writing wi thin 30 da ys that yo u believe  that you d o not owe  this debt  or
  2932   "DATA",343 ,16,1,59,0 )
  2933   that the a mount of t he debt is  incorrect , we will  not reques t OPM to
  2934   "DATA",343 ,16,1,60,0 )
  2935   offset you r retired  pay until  we confirm  that you  are indebt ed and the
  2936   "DATA",343 ,16,1,61,0 )
  2937   amount is  correct. Y ou should  explain to  the exten t you can  why you
  2938   "DATA",343 ,16,1,62,0 )
  2939   believe yo u do not o we the deb t or why t he amount  is incorre ct.
  2940   "DATA",343 ,16,1,63,0 )
  2941     
  2942   "DATA",343 ,16,1,64,0 )
  2943   RIGHT TO R EQUEST LES SER WITHHO LDING FROM  CSRS OR F ERS:  If o ffset of 5 0% of
  2944   "DATA",343 ,16,1,65,0 )
  2945   your month ly annuity  would cau se a hards hip, you m ay request  a review  of the
  2946   "DATA",343 ,16,1,66,0 )
  2947   amount of  offset.  S uch a requ est for re view shoul d be in wr iting and
  2948   "DATA",343 ,16,1,67,0 )
  2949   include a  proposed r epayment s chedule su pported by  a properl y complete d VA
  2950   "DATA",343 ,16,1,68,0 )
  2951   Form 4-565 5, Financi al Status  Report, wh ich is enc losed for  your use.  If a
  2952   "DATA",343 ,16,1,69,0 )
  2953   request fo r review o f the issu e of the a mount of o ffset is r eceived wi thin
  2954   "DATA",343 ,16,1,70,0 )
  2955   30 calenda r days fro m the date  of this l etter, we  will take  no action  to
  2956   "DATA",343 ,16,1,71,0 )
  2957    offset yo ur current  monthly a nnuity unt il a revie w has been  held.
  2958   "DATA",343 ,16,1,72,0 )
  2959     
  2960   "DATA",343 ,16,1,73,0 )
  2961   RIGHT TO R EQUEST A H EARING:  Y ou have th e right to  request a  hearing o n the
  2962   "DATA",343 ,16,1,74,0 )
  2963   existence  or amount  of the deb t and/or t he offset  scheduled.   Such a r equest
  2964   "DATA",343 ,16,1,75,0 )
  2965   should inc lude reaso ns why you  believe a  hearing i s necessar y.  The he aring
  2966   "DATA",343 ,16,1,76,0 )
  2967   officer ha s exclusiv e authorit y to deter mine wheth er a heari ng is to b e
  2968   "DATA",343 ,16,1,77,0 )
  2969   conducted  in person,  or by ano ther metho d, such as  a confere nce call,  or on
  2970   "DATA",343 ,16,1,78,0 )
  2971   the record , i.e., pa per review .  You wil l be advis ed as soon  as possib le of
  2972   "DATA",343 ,16,1,79,0 )
  2973   the determ ination on  your hear ing reques t.
  2974   "DATA",343 ,16,1,80,0 )
  2975     
  2976   "DATA",343 ,16,1,81,0 )
  2977   ADMINISTRA TIVE COST  OF COLLECT ION FEES:   The month ly adminis trative co st of
  2978   "DATA",343 ,16,1,82,0 )
  2979   collection  fee will  not be add ed to your  debt if,  within 30  days, full
  2980   "DATA",343 ,16,1,83,0 )
  2981   payment of f the debt  is receiv ed or an a cceptable  repayment  plan is wo rked
  2982   "DATA",343 ,16,1,84,0 )
  2983   out.  If a n installm ent repaym ent plan i s worked o ut and any  installme nt is
  2984   "DATA",343 ,16,1,85,0 )
  2985   not receiv ed by the  due date,  the monthl y administ rative cos t of colle ction
  2986   "DATA",343 ,16,1,86,0 )
  2987   fee will t hereafter  be charged  for the l ife of the  debt.  Ot her
  2988   "DATA",343 ,16,1,87,0 )
  2989   cost of co llection m ay also be  added to  the debt i f addition al collect ion
  2990   "DATA",343 ,16,1,88,0 )
  2991   actions be come neces sary.
  2992   "DATA",343 ,16,1,89,0 )
  2993     
  2994   "DATA",343 ,16,1,90,0 )
  2995   PENALTY CH ARGES:  Th e monthly  penalty ch arge will  not be add ed to your  debt
  2996   "DATA",343 ,16,1,91,0 )
  2997   if, within  90 days,  full payme nt of the  debt is re ceived or  an accepta ble
  2998   "DATA",343 ,16,1,92,0 )
  2999   repayment  plan is wo rked out.   If an acc eptable re payment pl an is agre ed
  3000   "DATA",343 ,16,1,93,0 )
  3001   upon and y ou default  on that a greement,  90 days af ter defaul t we will  begin
  3002   "DATA",343 ,16,1,94,0 )
  3003   assessing  a penalty  charge.
  3004   "DATA",343 ,16,2)
  3005   Ex-employe e/Post Ret irement (1 FU*)
  3006   "DATA",343 ,17,0)
  3007   FL 4-513w
  3008   "DATA",343 ,17,1,0)
  3009   ^^100^100^ 2941011^^^ ^
  3010   "DATA",343 ,17,1,1,0)
  3011   |CENTER("S pecial Not ice to Acc ompany Pat ient State ment")|
  3012   "DATA",343 ,17,1,2,0)
  3013    
  3014   "DATA",343 ,17,1,3,0)
  3015   Medication  Copayment  Program:   The medic ation copa yment prog ram was fi rst
  3016   "DATA",343 ,17,1,4,0)
  3017   enacted by  Congress  as Public  Law 101-50 8 on Novem ber 5,1990 .  The
  3018   "DATA",343 ,17,1,5,0)
  3019   Congress h as extende d medicati on copayme nt under P ublic Law  102-139.
  3020   "DATA",343 ,17,1,6,0)
  3021    
  3022   "DATA",343 ,17,1,7,0)
  3023   These laws  require t he Departm ent of Vet erans Affa irs (VA) t o collect  a
  3024   "DATA",343 ,17,1,8,0)
  3025   copayment  for each 3 0 day or l ess supply  of medica tions pres cribed for  non
  3026   "DATA",343 ,17,1,9,0)
  3027   service-co nnected co nditions.   While the se funds a re not dir ectly retu rned
  3028   "DATA",343 ,17,1,10,0 )
  3029   to your VA  medical c enter, the y offset t he increas ing cost o f providin g
  3030   "DATA",343 ,17,1,11,0 )
  3031   VA care.
  3032   "DATA",343 ,17,1,12,0 )
  3033    
  3034   "DATA",343 ,17,1,13,0 )
  3035   Means Test  Copayment s:  Means  test copay ments and  per diems  are establ ished
  3036   "DATA",343 ,17,1,14,0 )
  3037   in section s 1710(f)  and 1712(f ) of Title  38 U.S.C.   These se ctions
  3038   "DATA",343 ,17,1,15,0 )
  3039   authorize  VA to prov ide care t o you on t he basis o f your agr eement to  pay
  3040   "DATA",343 ,17,1,16,0 )
  3041   certain fe es for tha t care.
  3042   "DATA",343 ,17,1,17,0 )
  3043    
  3044   "DATA",343 ,17,1,18,0 )
  3045   Late Charg es:  Secti on 5315 of  Title 38  U.S.C. req uires VA t o assess l ate
  3046   "DATA",343 ,17,1,19,0 )
  3047   charges on  balances  which rema in unpaid.  These cha rges consi st of inte rest
  3048   "DATA",343 ,17,1,20,0 )
  3049   and admini strative f ees at rat es that ar e establis hed each y ear.
  3050   "DATA",343 ,17,1,21,0 )
  3051   Administra tive fees  apply to y our entire  statement  whenever  any paymen t
  3052   "DATA",343 ,17,1,22,0 )
  3053   is late.   Interest f ees are ch arged for  any servic e that rem ains unpai d.
  3054   "DATA",343 ,17,1,23,0 )
  3055   Interest c harges are  calculate d from the  date of t he first s tatement o n
  3056   "DATA",343 ,17,1,24,0 )
  3057   which the  charge app eared thro ugh the ne xt stateme nt date.   You can av oid
  3058   "DATA",343 ,17,1,25,0 )
  3059   these char ges by mai ling your  payment in  time for  it to arri ve by the
  3060   "DATA",343 ,17,1,26,0 )
  3061   due date s hown on yo ur stateme nt.
  3062   "DATA",343 ,17,1,27,0 )
  3063    
  3064   "DATA",343 ,17,1,28,0 )
  3065   Questions  about Char ges:  If y ou sent a  payment to  us in the  past 10 d ays,
  3066   "DATA",343 ,17,1,29,0 )
  3067   it may not  have been  applied t o your acc ount by th e time the  statement
  3068   "DATA",343 ,17,1,30,0 )
  3069   was prepar ed.  This  payment wi ll be refl ected in y our accoun t on the n ext
  3070   "DATA",343 ,17,1,31,0 )
  3071   statement.   Please c all the nu mber shown  on the st atement if  you have  other
  3072   "DATA",343 ,17,1,32,0 )
  3073   question a bout your  charges.   We recomme nd you not e the date , name and
  3074   "DATA",343 ,17,1,33,0 )
  3075   phone numb er of the  individual  that you  speak to i f the call  results i n
  3076   "DATA",343 ,17,1,34,0 )
  3077   a change t o your acc ount.  Ple ase see th e followin g paragrap h relating  to
  3078   "DATA",343 ,17,1,35,0 )
  3079   formal dis putes.
  3080   "DATA",343 ,17,1,36,0 )
  3081    
  3082   "DATA",343 ,17,1,37,0 )
  3083   Formal Dis putes:  Yo u may disp ute the co rrectness  of a charg e applied  to
  3084   "DATA",343 ,17,1,38,0 )
  3085   your accou nt.  To do  so, you m ust advise  us of the  dispute i n writing.
  3086   "DATA",343 ,17,1,39,0 )
  3087   Your lette r must be  received b y VA withi n 30 days  of the dat e of the
  3088   "DATA",343 ,17,1,40,0 )
  3089   statement  on which t he charge  first appe ared.  We  will suspe nd further
  3090   "DATA",343 ,17,1,41,0 )
  3091   notices co ncerning t he charge  while we r esolve the  question;  however,  we
  3092   "DATA",343 ,17,1,42,0 )
  3093   will add i nterest an d, if appl icable, ad ministrati ve charges  to your
  3094   "DATA",343 ,17,1,43,0 )
  3095   account.   We will cr edit your  account fo r any late  charges a ssociated
  3096   "DATA",343 ,17,1,44,0 )
  3097   with the d isputed am ount, if t he dispute  is resolv ed in your  favor.
  3098   "DATA",343 ,17,1,45,0 )
  3099    
  3100   "DATA",343 ,17,1,46,0 )
  3101   Repayment  Plans:  If  you are u nable to m ake a full  payment o f the char ges,
  3102   "DATA",343 ,17,1,47,0 )
  3103   you may ap ply to hav e the bala nce placed  on a repa yment plan .  To avoi d
  3104   "DATA",343 ,17,1,48,0 )
  3105   an adminis trative ch arge, you  must reque st the for ms needed  to establi sh
  3106   "DATA",343 ,17,1,49,0 )
  3107   a repaymen t plan in  writing, V A must als o receive  your reque st within
  3108   "DATA",343 ,17,1,50,0 )
  3109   30 days of  the date  of the sta tement on  which the  charge fir st appears .
  3110   "DATA",343 ,17,1,51,0 )
  3111   The minimu m payment  on a repay ment plan  should be  sufficient  to pay of f
  3112   "DATA",343 ,17,1,52,0 )
  3113   the balanc e of your  account wi thin 12 mo nths.  If  your repay ment plan
  3114   "DATA",343 ,17,1,53,0 )
  3115   is accepte d, financi ng interes t charges  will be ad ded to you r statemen t
  3116   "DATA",343 ,17,1,54,0 )
  3117   on any unp aid balanc e.
  3118   "DATA",343 ,17,1,55,0 )
  3119    
  3120   "DATA",343 ,17,1,56,0 )
  3121   Overdue Ch arges:  Th e Federal  Claims Col lection St andards (4  CFR 102.2 )
  3122   "DATA",343 ,17,1,57,0 )
  3123   requires V A to pursu e certain  options fo r charges  owed the g overnment
  3124   "DATA",343 ,17,1,58,0 )
  3125   for medica l care pro vided to y ou.  If VA  pursues a ny of thes e collecti on
  3126   "DATA",343 ,17,1,59,0 )
  3127   options, w e will adv ise you by  separate  notice.
  3128   "DATA",343 ,17,1,60,0 )
  3129    
  3130   "DATA",343 ,17,1,61,0 )
  3131   PLEASE NOT E:  WHENEV ER THE ACC OMPANYING  STATEMENT  OR THIS NO TICE STATE S THAT
  3132   "DATA",343 ,17,1,62,0 )
  3133   YOU HAVE A  PERIOD OF  TIME TO T AKE SOME A CTION OR T O NOTIFY U S, THE PER IOD
  3134   "DATA",343 ,17,1,63,0 )
  3135   OF THAT TI ME BEGINS  TO RUN FRO M THE DATE  OF THE ST ATEMENT.
  3136   "DATA",343 ,17,1,64,0 )
  3137   |TOP|
  3138   "DATA",343 ,17,1,65,0 )
  3139    
  3140   "DATA",343 ,17,1,66,0 )
  3141   Waiver of  Medication  Copayment  Charges:   You may r equest a w aiver of y our
  3142   "DATA",343 ,17,1,67,0 )
  3143   medication  copayment  charges.   You may a lso reques t an oral  hearing on  the
  3144   "DATA",343 ,17,1,68,0 )
  3145   waiver req uest.  How ever, your  right to  request a  waiver doe s not appl y to
  3146   "DATA",343 ,17,1,69,0 )
  3147   the means  test copay ment or th e per diem  charges a pplied to  inpatient  stays.
  3148   "DATA",343 ,17,1,70,0 )
  3149   A waiver m eans that  all or par t of the c harges may  be forgiv en.  Under
  3150   "DATA",343 ,17,1,71,0 )
  3151   certain ci rcumstance s, related  to your i nability t o pay medi cation cop ayment
  3152   "DATA",343 ,17,1,72,0 )
  3153   charges be cause of f inancial h ardship, w e can gran t a reques t to waive  all
  3154   "DATA",343 ,17,1,73,0 )
  3155   or a porti on of thes e charges.   Your rig ht to requ est a waiv er only la sts
  3156   "DATA",343 ,17,1,74,0 )
  3157   for 180 ca lendar day s from the  initial n otificatio n of your  waiver rig hts
  3158   "DATA",343 ,17,1,75,0 )
  3159   associated  with the  specific d ebt in que stion.  Fo r charges  incurred p rior 
  3160   "DATA",343 ,17,1,76,0 )
  3161   to the fir st stateme nt on whic h this not ice appear s, the 180  day limit
  3162   "DATA",343 ,17,1,77,0 )
  3163   applies fr om the dat e of the i nitial not ification  of your ri ght to req uest 
  3164   "DATA",343 ,17,1,78,0 )
  3165   a waiver.  Your waive r request  must be in  writing a nd any req uest for o ral 
  3166   "DATA",343 ,17,1,79,0 )
  3167   hearing mu st be incl uded in th e written  request.   A waiver c annot be
  3168   "DATA",343 ,17,1,80,0 )
  3169   granted if  there is  fraud, mis representa tion or ba d faith on  your part  
  3170   "DATA",343 ,17,1,81,0 )
  3171   in connect ion with y our repres entation o f your fin ancial sta tus.  In 
  3172   "DATA",343 ,17,1,82,0 )
  3173   establishi ng financi al hardshi p, the VA  will apply  the same  rules it u ses 
  3174   "DATA",343 ,17,1,83,0 )
  3175   to establi sh an exem ption to m edication  copayments , except t hat these 
  3176   "DATA",343 ,17,1,84,0 )
  3177   rules can  be applied  to curren t and anti cipated in come rathe r than pri or 
  3178   "DATA",343 ,17,1,85,0 )
  3179   year incom e. By defi nition, wa iver reque sts can on ly be cons idered for  
  3180   "DATA",343 ,17,1,86,0 )
  3181   debts prev iously inc urred and  cannot be  granted pr ospectivel y.
  3182   "DATA",343 ,17,1,87,0 )
  3183    
  3184   "DATA",343 ,17,1,88,0 )
  3185   REPRESENTA TION:  You  may be re presented,  without c harge, by  an accredi ted 
  3186   "DATA",343 ,17,1,89,0 )
  3187   representa tive of a  veterans'  organizati on or othe r service  organizati on
  3188   "DATA",343 ,17,1,90,0 )
  3189   recognized  by the Se cretary of  Veterans  Affairs.   You may em ploy an
  3190   "DATA",343 ,17,1,91,0 )
  3191   attorney t o assist y ou, for ex ample, an   attorney  in private  practice  or a
  3192   "DATA",343 ,17,1,92,0 )
  3193   legal aid  attorney.   The servi ces of an  attorney r epresentin g you in 
  3194   "DATA",343 ,17,1,93,0 )
  3195   adjudicato ry proceed ings befor e VA are s ubject to  a fee limi tation 
  3196   "DATA",343 ,17,1,94,0 )
  3197   as set for th in 38 U .S.C. 5904 .  If you  desire rep resentatio n and have  
  3198   "DATA",343 ,17,1,95,0 )
  3199   not alread y designat ed a repre sentative,  let us kn ow and we  will send 
  3200   "DATA",343 ,17,1,96,0 )
  3201   you the ne cessary fo rms.  If a n attorney  or accred ited agent  represent s
  3202   "DATA",343 ,17,1,97,0 )
  3203   you before  VA, a cop y of any a greement b etween you  and the a ttorney or  
  3204   "DATA",343 ,17,1,98,0 )
  3205   accredited  agtent ab out the pa yment of t he attorne y's or age nt's fees
  3206   "DATA",343 ,17,1,99,0 )
  3207   must be fi led at the  following  address:  Counsel to  the Chair man (01C3)
  3208   "DATA",343 ,17,1,100, 0)
  3209   Board of V eterans Ap peals, 810  Vermont A venue N.W. , Washingt on D.C. 20 420.
  3210   "DATA",343 ,17,2)
  3211   Patient St atement Ri ghts (Waiv er)
  3212   "DATA",343 ,18,0)
  3213   TOP ATTACH MENT LETTE R
  3214   "DATA",343 ,18,1,0)
  3215   ^^49^49^29 90618^
  3216   "DATA",343 ,18,1,1,0)
  3217   This is ad ditional i nformation  for you a bout the p ossible re ferral of
  3218   "DATA",343 ,18,1,2,0)
  3219   debts to t he Departm ent of Tre asury.
  3220   "DATA",343 ,18,1,3,0)
  3221    
  3222   "DATA",343 ,18,1,4,0)
  3223   If we do n ot hear fr om you, we  will repo rt your de bt to the  U.S.
  3224   "DATA",343 ,18,1,5,0)
  3225   Department  of the Tr easury for  cross-ser vicing and /or the Tr easury Off set
  3226   "DATA",343 ,18,1,6,0)
  3227   Program (T OP).  Addi tionally,  you will b e responsi ble for an y and all  fees
  3228   "DATA",343 ,18,1,7,0)
  3229   associated  with cros s servicin g and the  offset pro gram.
  3230   "DATA",343 ,18,1,8,0)
  3231    
  3232   "DATA",343 ,18,1,9,0)
  3233   Once your  debt is su bmitted fo r cross-se rvicing, t he U.S. De partment o f
  3234   "DATA",343 ,18,1,10,0 )
  3235   Treasury m ay refer y our debt t o a privat e collecti on agency  for collec tion
  3236   "DATA",343 ,18,1,11,0 )
  3237   action, re port your  debt to a  credit bur eau and if  the debt  is written
  3238   "DATA",343 ,18,1,12,0 )
  3239   off, repor t it to IR S as poten tial taxab le income.
  3240   "DATA",343 ,18,1,13,0 )
  3241    
  3242   "DATA",343 ,18,1,14,0 )
  3243   If your de bt is subm itted to t he TOP, th e U.S. Dep artment of  Treasury  will
  3244   "DATA",343 ,18,1,15,0 )
  3245   reduce or  withhold a ny of your  eligible  Federal pa yments by  the amount  of
  3246   "DATA",343 ,18,1,16,0 )
  3247   your debt.   The Debt  Collectio n Act of 1 982 and th e Debt Col lection
  3248   "DATA",343 ,18,1,17,0 )
  3249   Improvemen t Act of 1 996 author ize this p rocess, kn own as off set.  Fede ral
  3250   "DATA",343 ,18,1,18,0 )
  3251   payments e ligible fo r offset i nclude:
  3252   "DATA",343 ,18,1,19,0 )
  3253           .   Your inco me tax ref unds
  3254   "DATA",343 ,18,1,20,0 )
  3255           .   Your Fede ral salary  pay, incl uding mili tary pay
  3256   "DATA",343 ,18,1,21,0 )
  3257           .   Your Fede ral retire ment, incl uding mili tary retir ement pay
  3258   "DATA",343 ,18,1,22,0 )
  3259           .   Your cont ractor/ven dor paymen ts
  3260   "DATA",343 ,18,1,23,0 )
  3261           .   Certain F ederal ben efit payme nts, such  as Social  Security
  3262   "DATA",343 ,18,1,24,0 )
  3263               (other th an Supplem ental Secu rity Incom e (SSI)),  Railroad
  3264   "DATA",343 ,18,1,25,0 )
  3265               Retiremen t (other t han tier 2 ), and Bla ck Lung (p art B)
  3266   "DATA",343 ,18,1,26,0 )
  3267               benefits
  3268   "DATA",343 ,18,1,27,0 )
  3269           .   Other Fed eral payme nts, inclu ding certa in loans t o you, tha t
  3270   "DATA",343 ,18,1,28,0 )
  3271               are not e xempt from  offset
  3272   "DATA",343 ,18,1,29,0 )
  3273    
  3274   "DATA",343 ,18,1,30,0 )
  3275   If you hav e filed fo r bankrupt cy and the  automatic  stay is i n effect,  you
  3276   "DATA",343 ,18,1,31,0 )
  3277   must notif y us withi n 30 days  to prevent  this debt  from bein g reported  to
  3278   "DATA",343 ,18,1,32,0 )
  3279   the Treasu ry Departm ent.  You  should sen d us proof  of your b ankruptcy.   If
  3280   "DATA",343 ,18,1,33,0 )
  3281   you file a  joint fed eral incom e tax retu rn, you sh ould obtai n IRS Form
  3282   "DATA",343 ,18,1,34,0 )
  3283   8379, Inju red Spouse  Claim and  Allocatio n, BEFORE  filing you r return.   The
  3284   "DATA",343 ,18,1,35,0 )
  3285   instructio ns will ex plain the  steps your  spouse ma y take to  obtain his /her
  3286   "DATA",343 ,18,1,36,0 )
  3287   share of y our joint  income tax  refund.
  3288   "DATA",343 ,18,1,37,0 )
  3289    
  3290   "DATA",343 ,18,1,38,0 )
  3291   If you are  or become  a Federal  Employee,  your curr ent net di sposable p ay
  3292   "DATA",343 ,18,1,39,0 )
  3293   is subject  to offset  if you do  not pay y our debt o r take oth er action  as
  3294   "DATA",343 ,18,1,40,0 )
  3295   described  on the pre vious page .  Under t he TOP, th e U.S. Tre asury will
  3296   "DATA",343 ,18,1,41,0 )
  3297   deduct up  to 15% of  your dispo sable pay,  beginning  in the pa y period t hat
  3298   "DATA",343 ,18,1,42,0 )
  3299   your debt  is submitt ed to the  TOP.  This  deduction  will cont inue every  pay
  3300   "DATA",343 ,18,1,43,0 )
  3301   period unt il your de bt, includ ing intere st, penalt ies and ot her costs,  is
  3302   "DATA",343 ,18,1,44,0 )
  3303   paid in fu ll.
  3304   "DATA",343 ,18,1,45,0 )
  3305    
  3306   "DATA",343 ,18,1,46,0 )
  3307   You are en titled to  a hearing  to dispute  the amoun t of the p ayroll
  3308   "DATA",343 ,18,1,47,0 )
  3309   deduction.   To reque st a heari ng, you mu st file a  written re quest for  a
  3310   "DATA",343 ,18,1,48,0 )
  3311   hearing no  later tha n 15 days  from the d ate of thi s letter t o prevent
  3312   "DATA",343 ,18,1,49,0 )
  3313   referral o f your deb t to the T reasury De partment.
  3314   "DATA",343 ,18,2)
  3315   Treasury l etter to b e attached  to 3rd de mand lette r
  3316   "DATA",343 ,19,0)
  3317   BENEFICIAR Y TRAVEL N OTICE
  3318   "DATA",343 ,19,1,0)
  3319   S ^343.01^ 135^135^31 61121^S ^S  ^S ^
  3320   "DATA",343 ,19,1,1,0)
  3321   |TOP|NOTIC E OF RIGHT S AND RESP ONSIBILITI ES
  3322   "DATA",343 ,19,1,2,0)
  3323   __________ __________ __________ __________ __________ __________ __________ ____     
  3324   "DATA",343 ,19,1,3,0)
  3325   COLLECTION :  The U.S . Departme nt of Vete rans Affai rs (VA) is  required  to       
  3326   "DATA",343 ,19,1,4,0)
  3327   collect de bts owed t o the gove rnment.  A ction must  be taken  within six ty       
  3328   "DATA",343 ,19,1,5,0)
  3329   (60) days  from the i nitial bil ling state ment to pa y your deb t in full  or       
  3330   "DATA",343 ,19,1,6,0)
  3331   establish  a payment  plan or yo ur account  may be re ferred for  further            
  3332   "DATA",343 ,19,1,7,0)
  3333   collection  action.   You have t he right t o inspect  and copy t he records          
  3334   "DATA",343 ,19,1,8,0)
  3335   related to  the debt.   You also  have the  right to e stablish a  payment p lan.     
  3336   "DATA",343 ,19,1,9,0)
  3337   You have t he right t o submit a  compromis e offer.   You have t he right t o        
  3338   "DATA",343 ,19,1,10,0 )
  3339   request a  waiver and  a hearing  on the wa iver reque st.  Colle ction acti on      
  3340   "DATA",343 ,19,1,11,0 )
  3341   includes r eferring y our delinq uent balan ce to the  Department  of                
  3342   "DATA",343 ,19,1,12,0 )
  3343   Treasury's  Treasury  Offset Pro gram, whic h will inc lude offse t of any           
  3344   "DATA",343 ,19,1,13,0 )
  3345   federal an d state pa yments to  which you  are entitl ed.  This  includes t ax      
  3346   "DATA",343 ,19,1,14,0 )
  3347   refunds, s ocial secu rity benef its and sa lary or re tirement b enefits.           
  3348   "DATA",343 ,19,1,15,0 )
  3349   __________ __________ __________ __________ __________ __________ __________ ___     
  3350   "DATA",343 ,19,1,16,0 )
  3351   PAY YOUR B ILL:  Pay  the debt i n full by  the balanc e due date  on the
  3352   "DATA",343 ,19,1,17,0 )
  3353   initial bi lling stat ement to a void late  charges an d collecti on action:
  3354   "DATA",343 ,19,1,18,0 )
  3355       In Per son: At yo ur local V eteran Aff airs Medic al Center' s Agent
  3356   "DATA",343 ,19,1,19,0 )
  3357                   Cashi er's Offic e
  3358   "DATA",343 ,19,1,20,0 )
  3359       By Pho ne:  (see  below for  local info rmation)
  3360   "DATA",343 ,19,1,21,0 )
  3361       By Mai l:   (see  below for  local info rmation)
  3362   "DATA",343 ,19,1,22,0 )
  3363   __________ __________ __________ __________ __________ __________ __________ ____
  3364   "DATA",343 ,19,1,23,0 )
  3365   LATE CHARG ES:  The V A is requi red to ass ess late c harges on  balances w hich
  3366   "DATA",343 ,19,1,24,0 )
  3367   remain unp aid thirty  (30) days  after the  statement  date.  Th ese charge s
  3368   "DATA",343 ,19,1,25,0 )
  3369   consist of  interest  and admini strative f ees at rat es establi shed each
  3370   "DATA",343 ,19,1,26,0 )
  3371   year.  Int erest will  be charge d from the  date char ges first  appear on  the
  3372   "DATA",343 ,19,1,27,0 )
  3373   statement.  You can a void these  charges b y making t imely paym ents by th e
  3374   "DATA",343 ,19,1,28,0 )
  3375   balance du e date on  the statem ent.  A mo nthly admi nistrative  cost or
  3376   "DATA",343 ,19,1,29,0 )
  3377   collection  fee will  be added t o your deb t if, with in thirty  (30) days  of
  3378   "DATA",343 ,19,1,30,0 )
  3379   the date o f the stat ement on w hich charg es first a ppear, ful l payment  of
  3380   "DATA",343 ,19,1,31,0 )
  3381   the debt i s not rece ived or a  repayment  plan agree ment is no t approved .
  3382   "DATA",343 ,19,1,32,0 )
  3383   If an inst allment re payment pl an is esta blished an d any inst allment is  not
  3384   "DATA",343 ,19,1,33,0 )
  3385   received b y the due  date, the  monthly ad ministrati ve cost or  collectio n
  3386   "DATA",343 ,19,1,34,0 )
  3387   fee will t hereafter  be charged  until the  debt is p aid.  Othe r collecti on
  3388   "DATA",343 ,19,1,35,0 )
  3389   costs may  be added t o the debt  if additi onal colle ction acti ons become  
  3390   "DATA",343 ,19,1,36,0 )
  3391   necessary.
  3392   "DATA",343 ,19,1,37,0 )
  3393   __________ __________ __________ __________ __________ __________ __________ ____
  3394   "DATA",343 ,19,1,38,0 )
  3395   WAIVER:  Y ou have th e right to  request a  waiver of  part or a ll of your
  3396   "DATA",343 ,19,1,39,0 )
  3397   debt.  If  the waiver  is grante d you will  not be re quired to  pay the am ount
  3398   "DATA",343 ,19,1,40,0 )
  3399   waived.  T o do so, s ubmit an e xplanation  and a com pleted Fin ancial Sta tus
  3400   "DATA",343 ,19,1,41,0 )
  3401   Report (VA  Form 5655 ) found at :  www.va. gov/vaform s/va/pdf/V A5655.pdf.
  3402   "DATA",343 ,19,1,42,0 )
  3403   Your expla nation sho uld includ e why you  are not re sponsible  for the de bt
  3404   "DATA",343 ,19,1,43,0 )
  3405   and any un due hardsh ip the pay ment of th e debt wou ld cause y ou.  You h ave
  3406   "DATA",343 ,19,1,44,0 )
  3407   the right  to request  a hearing  in connec tion with  your reque st for a
  3408   "DATA",343 ,19,1,45,0 )
  3409   waiver.  T o do so, s ubmit a wr itten requ est for he aring with  your waiv er
  3410   "DATA",343 ,19,1,46,0 )
  3411   request.   VA will no tify you o f the date , time and  place whe re the hea ring
  3412   "DATA",343 ,19,1,47,0 )
  3413   will be he ld.  Refer  to the "C ustomer Se rvice" and  "Submitti ng Your
  3414   "DATA",343 ,19,1,48,0 )
  3415   Request" s ections be low for mo re informa tion.
  3416   "DATA",343 ,19,1,49,0 )
  3417   __________ __________ __________ __________ __________ __________ __________ ____
  3418   "DATA",343 ,19,1,50,0 )
  3419   COMPROMISE  OFFER:  Y ou have th e right to  request a  compromis e.  A
  3420   "DATA",343 ,19,1,51,0 )
  3421   compromise  means you  may propo se a lesse r amount a s full set tlement of  the
  3422   "DATA",343 ,19,1,52,0 )
  3423   debt.  To  request a  compromise , submit y our reques t in writi ng to VA,
  3424   "DATA",343 ,19,1,53,0 )
  3425   specifying  the dolla r amount y ou are pro posing VA  should acc ept as pay ment
  3426   "DATA",343 ,19,1,54,0 )
  3427   in full, a nd a compl eted Finan cial Statu s Report ( VA Form 56 55) found  at:
  3428   "DATA",343 ,19,1,55,0 )
  3429   www.va.gov /vaforms/v a/pdf/VA56 55.pdf.  R efer to th e "Custome r Service"
  3430   "DATA",343 ,19,1,56,0 )
  3431   and "Submi tting Your  Request"  sections b elow for m ore inform ation.
  3432   "DATA",343 ,19,1,57,0 )
  3433   __________ __________ __________ __________ __________ __________ __________ ____
  3434   "DATA",343 ,19,1,58,0 )
  3435   REPAYMENT  PLAN:  You  have the  right to e stablish a  monthly r epayment p lan
  3436   "DATA",343 ,19,1,59,0 )
  3437   at any tim e during y our enroll ment in VA  health ca re if you  cannot pay
  3438   "DATA",343 ,19,1,60,0 )
  3439   your debt  in full.   To do so,  submit a c ompleted A greement t o Pay
  3440   "DATA",343 ,19,1,61,0 )
  3441   Indebtedne ss (VA For m 1100) fo und at:
  3442   "DATA",343 ,19,1,62,0 )
  3443   www.va.gov /vaforms/v a/pdf/VA11 00.pdf.  I ndicate yo ur propose d monthly
  3444   "DATA",343 ,19,1,63,0 )
  3445   payment am ount in pa ragraph 1A .  Refer t o the "Cus tomer Serv ice" and
  3446   "DATA",343 ,19,1,64,0 )
  3447   "Submittin g Your Req uest" sect ions below  for more  informatio n.
  3448   "DATA",343 ,19,1,65,0 )
  3449   __________ __________ __________ __________ __________ __________ __________ ____
  3450   "DATA",343 ,19,1,66,0 )
  3451   DISPUTE TH E EXISTENC E OR AMOUN T OF THE D EBT:  You  have the r ight to
  3452   "DATA",343 ,19,1,67,0 )
  3453   dispute th e existenc e or amoun t of the d ebt.  To d o so, subm it a lette r
  3454   "DATA",343 ,19,1,68,0 )
  3455   explaining  why you q uestion th e validity  or amount  of the de bt.  To av oid
  3456   "DATA",343 ,19,1,69,0 )
  3457   late charg es, you mu st submit  a dispute  by the bal ance due d ate on the
  3458   "DATA",343 ,19,1,70,0 )
  3459   statement.  VA will n ot initiat e collecti on if your  dispute i s received
  3460   "DATA",343 ,19,1,71,0 )
  3461   within six ty (60) da ys from th e initial  billing st atement.   If VA rece ives
  3462   "DATA",343 ,19,1,72,0 )
  3463   your notic e later th an sixty ( 60) days a nd collect ion has be en initiat ed,
  3464   "DATA",343 ,19,1,73,0 )
  3465   it will co ntinue whi le the dis pute is be ing review ed.  If th e dispute  is
  3466   "DATA",343 ,19,1,74,0 )
  3467   resolved i n your fav or, all la te charges  will be r emoved fro m your
  3468   "DATA",343 ,19,1,75,0 )
  3469   account, a nd any amo unts withh eld from y our VA ben efits, fed eral payme nts,
  3470   "DATA",343 ,19,1,76,0 )
  3471   or wages w ill be ref unded to y ou.  Refer  to the "C ustomer Se rvice" and
  3472   "DATA",343 ,19,1,77,0 )
  3473   "Submittin g Your Req uest" sect ions below  for more  informatio n.
  3474   "DATA",343 ,19,1,78,0 )
  3475   __________ __________ __________ __________ __________ __________ __________ ____
  3476   "DATA",343 ,19,1,79,0 )
  3477   CUSTOMER S ERVICE:  F or additio nal inform ation or a ssistance:
  3478   "DATA",343 ,19,1,80,0 )
  3479       In Per son: At yo ur local V eteran Aff airs Medic al Center' s
  3480   "DATA",343 ,19,1,81,0 )
  3481                   Agent  Cashier's  Office
  3482   "DATA",343 ,19,1,82,0 )
  3483       By Pho ne:  (see  below for  local info rmation)
  3484   "DATA",343 ,19,1,83,0 )
  3485       Online :    Visit   www.va.g ov/vaforms  to retrie ve VA form s
  3486   "DATA",343 ,19,1,84,0 )
  3487   __________ __________ __________ __________ __________ __________ __________ ____
  3488   "DATA",343 ,19,1,85,0 )
  3489   SUBMITTING  YOUR REQU EST:  Subm it the req uired VA f orms or do cuments to
  3490   "DATA",343 ,19,1,86,0 )
  3491   apply for  one of VA' s Financia l Hardship  Programs:
  3492   "DATA",343 ,19,1,87,0 )
  3493       In Per son: At yo ur local V eteran Aff airs Medic al Center' s Agent
  3494   "DATA",343 ,19,1,88,0 )
  3495                   Cashi er's Offic e
  3496   "DATA",343 ,19,1,89,0 )
  3497       By Mai l:   Send  completed  forms and/ or other r equired do cumentatio n
  3498   "DATA",343 ,19,1,90,0 )
  3499                   to th e VA addre ss at the  top right  of your st atement to  the
  3500   "DATA",343 ,19,1,91,0 )
  3501                   atten tion of th e Fiscal O ffice/Bill  of Collec tion Manag er
  3502   "DATA",343 ,19,1,92,0 )
  3503   For additi onal infor mation, to  request n ecessary f orms or as sistance i n
  3504   "DATA",343 ,19,1,93,0 )
  3505   accessing  forms onli ne, contac t VA at 1- 866-400-12 38.
  3506   "DATA",343 ,19,1,94,0 )
  3507   __________ __________ __________ __________ __________ __________ __________ ____
  3508   "DATA",343 ,19,1,95,0 )
  3509   REPRESENTA TION:  An  accredited  represent ative of a  Veteran S ervice
  3510   "DATA",343 ,19,1,96,0 )
  3511   Organizati on or othe r service  organizati on recogni zed by the  Secretary  of
  3512   "DATA",343 ,19,1,97,0 )
  3513   Veterans A ffairs may  represent  you witho ut charge.   You may  employ an
  3514   "DATA",343 ,19,1,98,0 )
  3515   attorney o r VA accre dited agen t to assis t you.  Th e services  of an
  3516   "DATA",343 ,19,1,99,0 )
  3517   attorney o r accredit ed agent r epresentin g you in a djudicativ e proceedi ngs
  3518   "DATA",343 ,19,1,100, 0)
  3519   before VA  are subjec t to a fee  limitatio n as set f orth in 38  U.S.C. 59 04.
  3520   "DATA",343 ,19,1,101, 0)
  3521   If you des ire repres entation a nd have no t already  designated  a
  3522   "DATA",343 ,19,1,102, 0)
  3523   representa tive, cont act VA at  1-866-400- 1238 to re quest the  necessary
  3524   "DATA",343 ,19,1,103, 0)
  3525   forms.  If  an attorn ey or accr edited age nt represe nts you be fore VA, a
  3526   "DATA",343 ,19,1,104, 0)
  3527   copy of an y agreemen t between  you and th e attorney  or accred ited agent
  3528   "DATA",343 ,19,1,105, 0)
  3529   about the  payment of  the attor ney's or a gent's fee s must be  filed at t he
  3530   "DATA",343 ,19,1,106, 0)
  3531   following  address:   Counsel to  the Chair man (01C3) , Board of  Veterans 
  3532   "DATA",343 ,19,1,107, 0)
  3533   Appeals, 8 10 Vermont  Avenue N. W., Washin gton D.C.  20420.
  3534   "DATA",343 ,19,1,108, 0)
  3535   __________ __________ __________ __________ __________ __________ __________ ____
  3536   "DATA",343 ,19,1,109, 0)
  3537   NOTICE TO  CUSTOMERS  MAKING PAY MENT BY CH ECK: When  you provid e a check  as       
  3538   "DATA",343 ,19,1,110, 0)
  3539   payment, y ou authori ze VA to e ither use  informatio n from you r check to
  3540   "DATA",343 ,19,1,111, 0)
  3541   make a one -time elec tronic fun d transfer  from your  account o r to proce ss
  3542   "DATA",343 ,19,1,112, 0)
  3543   the paymen t as a che ck transac tion.  Whe n VA uses  informatio n from you r
  3544   "DATA",343 ,19,1,113, 0)
  3545   check to m ake an ele ctronic fu nd transfe r, funds m ay be with drawn from  
  3546   "DATA",343 ,19,1,114, 0)
  3547   your accou nt as soon  as the da y we proce ss your pa yment, and  you will  not
  3548   "DATA",343 ,19,1,115, 0)
  3549   receive yo ur check b ack from t he financi al institu tion.  A P rivacy Act
  3550   "DATA",343 ,19,1,116, 0)
  3551   Statement  required b y 5 U.S.C.  & 552a(e) (3) statin g our auth ority for
  3552   "DATA",343 ,19,1,117, 0)
  3553   soliciting  and colle cting the  informatio n from you r check, a nd explain ing
  3554   "DATA",343 ,19,1,118, 0)
  3555   the purpos es and rou tine uses  which will  be made o f your che ck
  3556   "DATA",343 ,19,1,119, 0)
  3557   informatio n, VA Noti ce of Priv acy Practi ces, IB 10 -163 is av ailable on line
  3558   "DATA",343 ,19,1,120, 0)
  3559   at www.va. gov/vhapub lications  or call to ll free at  1-866-400 -1238 to
  3560   "DATA",343 ,19,1,121, 0)
  3561   obtain a c opy by mai l.  Furnis hing the c heck infor mation is  voluntary,  but
  3562   "DATA",343 ,19,1,122, 0)
  3563   a decision  not to do  so may re quire you  to make pa yment by s ome other
  3564   "DATA",343 ,19,1,123, 0)
  3565   method.
  3566   "DATA",343 ,19,1,124, 0)
  3567   __________ __________ __________ __________ __________ __________ __________ ____
  3568   "DATA",343 ,19,1,125, 0)
  3569   QUESTIONS  ABOUT PAYM ENTS:  Pay ments made  in the pa st ten (10 ) days may  not
  3570   "DATA",343 ,19,1,126, 0)
  3571   have been  applied to  your acco unt by the  time your  statement  was prepa red.
  3572   "DATA",343 ,19,1,127, 0)
  3573   If so, thi s payment  will be re flected in  your acco unt on the  next
  3574   "DATA",343 ,19,1,128, 0)
  3575   statement.   For assi stance in  understand ing your s tatement a nd assesse d
  3576   "DATA",343 ,19,1,129, 0)
  3577   charges co ntact VA a t (see bel ow for loc al informa tion).
  3578   "DATA",343 ,19,1,130, 0)
  3579   __________ __________ __________ __________ __________ __________ __________ ____
  3580   "DATA",343 ,19,1,131, 0)
  3581   VA PRIVACY :  The VA  Notice of  Privacy Pr actices, I B 10-163,  which outl ines
  3582   "DATA",343 ,19,1,132, 0)
  3583   your priva cy rights,  is availa ble online  at www.va .gov/vhapu blications ,
  3584   "DATA",343 ,19,1,133, 0)
  3585   or you may  obtain a  copy by wr iting the  VHA Privac y Office ( 10P2C1) at  810
  3586   "DATA",343 ,19,1,134, 0)
  3587   Vermont Av enue NW, W ashington,  DC 20420.
  3588   "DATA",343 ,19,1,135, 0)
  3589   __________ __________ __________ __________ __________ __________ __________ ____
  3590   "DATA",430 .3,1,0)
  3591   INCREASE A DJUSTMENT^ AJ^1^1^^1
  3592   "DATA",430 .3,2,0)
  3593   PAYMENT (I N PART)^PP ^2^1^^1
  3594   "DATA",430 .3,3,0)
  3595   REFER TO R C^RC^3^0^^ 1
  3596   "DATA",430 .3,4,0)
  3597   REFER TO D OJ^RJ^4^0^ ^1
  3598   "DATA",430 .3,5,0)
  3599   REESTABLIS H TO RC/DO J^RR^5^0^^ 1
  3600   "DATA",430 .3,6,0)
  3601   RETURNED B Y RC/DOJ^R D^6^0^^1
  3602   "DATA",430 .3,7,0)
  3603   CASH COLLE CTION BY R C/DOJ^CJ^7 ^1^^1
  3604   "DATA",430 .3,8,0)
  3605   TERM.BY FI S.OFFICER^ TO^8^1^^1
  3606   "DATA",430 .3,9,0)
  3607   TERM.BY CO MPROMISE^T C^9^1^^1
  3608   "DATA",430 .3,10,0)
  3609   WAIVED IN  FULL^WF^10 ^1^^1
  3610   "DATA",430 .3,11,0)
  3611   WAIVED IN  PART^WP^11 ^1^^1
  3612   "DATA",430 .3,12,0)
  3613   ADMIN.COST  CHARGE^AC ^12^0^^1
  3614   "DATA",430 .3,13,0)
  3615   INTEREST/A DM. CHARGE ^IC^13^0^^ 1
  3616   "DATA",430 .3,14,0)
  3617   EXEMPT INT /ADM. COST ^E^14^0^^1
  3618   "DATA",430 .3,15,0)
  3619   INCOMPLETE ^IN^101^0^ ^0
  3620   "DATA",430 .3,16,0)
  3621   ACTIVE^A^1 02^0^1^1
  3622   "DATA",430 .3,17,0)
  3623   IN-ACTIVE^ IA^103^0^1 ^
  3624   "DATA",430 .3,18,0)
  3625   NEW BILL^N ^104^0^^1
  3626   "DATA",430 .3,19,0)
  3627   SUSPENSE^S ^105^0^1^1
  3628   "DATA",430 .3,20,0)
  3629   PENDING AP PROVAL^PA^ 205^0^^0
  3630   "DATA",430 .3,21,0)
  3631   PENDING CA LM CODE^PC ^107^0^1^0
  3632   "DATA",430 .3,22,0)
  3633   COLLECTED/ CLOSED^CC^ 108^0^1^1
  3634   "DATA",430 .3,23,0)
  3635   WRITE-OFF^ WO^109^0^1 ^1
  3636   "DATA",430 .3,24,0)
  3637   MARSHAL/CO URT COST^M L^15^0^^1
  3638   "DATA",430 .3,25,0)
  3639   REPAYMENT  PLAN^RP^16 ^0^^0
  3640   "DATA",430 .3,26,0)
  3641   CANCELLED  BILL^CB^21 0^0^^1
  3642   "DATA",430 .3,27,0)
  3643   BILL INCOM PLETE^BI^2 01^0^^0
  3644   "DATA",430 .3,28,0)
  3645   OLD BILL^O B^106^0^^0
  3646   "DATA",430 .3,29,0)
  3647   TERM.BY RC /DOJ^TJ^29 ^1^^1
  3648   "DATA",430 .3,30,0)
  3649   DEBIT VOUC HER (SF 55 15)^DV^30^ 1^^0
  3650   "DATA",430 .3,31,0)
  3651   RETURNED F ROM AR (NE W)^RT^220^ 0^^0
  3652   "DATA",430 .3,32,0)
  3653   RETURNED F OR AMENDME NT^RA^230^ 0^^0
  3654   "DATA",430 .3,33,0)
  3655   AMENDED BI LL^AB^110^ 1^^0
  3656   "DATA",430 .3,34,0)
  3657   PAYMENT (I N FULL)^PF ^20^1^^1
  3658   "DATA",430 .3,35,0)
  3659   DECREASE A DJUSTMENT^ DA^21^1^^1
  3660   "DATA",430 .3,36,0)
  3661   DELETE (AM END)^DL^30 1^0^^0
  3662   "DATA",430 .3,37,0)
  3663   ADD (AMEND )^AD^302^0 ^^0
  3664   "DATA",430 .3,38,0)
  3665   AMEND^AM^3 03^0^^0
  3666   "DATA",430 .3,39,0)
  3667   CANCELLATI ON^CN^111^ 1^0^1
  3668   "DATA",430 .3,40,0)
  3669   SUSPENDED^ SP^240^0^0 ^1
  3670   "DATA",430 .3,41,0)
  3671   REFUNDED^R F^120^1^0^ 1
  3672   "DATA",430 .3,42,0)
  3673   OPEN^OP^11 2^1^0^1
  3674   "DATA",430 .3,43,0)
  3675   RE-ESTABLI SH^RW^250^ ^^1
  3676   "DATA",430 .3,44,0)
  3677   REFUND REV IEW^PR^113 ^0^0^1
  3678   "DATA",430 .3,45,0)
  3679   COMMENT^CM ^17^0^0^0
  3680   "DATA",430 .3,46,0)
  3681   UNSUSPENDE D^US^18^0^ 0^1
  3682   "DATA",430 .3,47,0)
  3683   CHARGE SUS PENDED^CS^ 19^0^0^1
  3684   "DATA",430 .3,48,0)
  3685   PENDING AR CHIVE^X^11 4^0^0^0
  3686   "DATA",430 .3,49,0)
  3687   ARCHIVED^X X^115^0^0^ 0
  3688   "DATA",430 .3,51,0)
  3689   CS STOP PL ACED^CP^33 ^^^0
  3690   "DATA",430 .3,53,0)
  3691   CS BILL RE CALL^CR^34 ^^^0
  3692   "DATA",430 .3,54,0)
  3693   CS STOP DE LETED^CD^3 6^^^0
  3694   "DATA",430 .3,55,0)
  3695   CS DEL BIL L RECALL^C F^37^^^0
  3696   "DATA",430 .3,56,0)
  3697   CS DEBTOR  RECALL^CE^ 35^^^0
  3698   "DATA",430 .3,57,0)
  3699   CS DEL DEB TOR RECALL ^CL^38^^^0
  3700   "DATA",430 .3,60,0)
  3701   CS UPDATE  DEBT^CU^41 ^^^0
  3702   "DATA",430 .3,64,0)
  3703   CS CASE RE CALL^CO^45 ^^^0
  3704   "DATA",430 .3,65,0)
  3705   CS DEL CAS E RECALL^C G^46^^^0
  3706   "DATA",430 .3,66,0)
  3707   CS DECR AD J NOT APP^ CA^40^^^0
  3708   "DATA",430 .3,67,0)
  3709   CS ADD CAS E INFO^CZ^ 47^^^0
  3710   "DATA",430 .3,68,0)
  3711   CS NEW DBT R NEW BILL ^CH^48^^^0
  3712   "DATA",430 .3,70,0)
  3713   CS DECREAS E ADJ^CY^4 9^^^0
  3714   "DATA",430 .3,71,0)
  3715   CS RECON W ORKED^CV^5 0
  3716   "DATA",430 .3,72,0)
  3717   DEL REPAY  PLAN^DP^31 ^0^^0
  3718   "DATA",430 .3,73,0)
  3719   CS INCREAS E ADJ^AI^5 1^1^^1
  3720   "DATA",430 .3,74,0)
  3721   CS ADMIN.C OST CHARGE ^AE^52^0^^ 1
  3722   "DATA",430 .3,75,0)
  3723   CS ADMIN A DJ TR REV? Y^AN^53^^^ 0
  3724   "DATA",430 .3,76,0)
  3725   CS ADMIN A DJ TR REV? N^AO^54^^^ 0
  3726   "DATA",430 .3,79,0)
  3727   CS INC ADJ  TR REV?Y^ AS^57^^^0
  3728   "DATA",430 .3,80,0)
  3729   CS INC ADJ  TR REV?N^ AT^58^^^0
  3730   "DATA",430 .3,83,0)
  3731   CS PEND RE CON^RK^61^ ^^0
  3732   "DATA",430 .3,84,0)
  3733   CS RECALL  PLACED^CQ^ 62
  3734   "DATA",430 .3,85,0)
  3735   CS DEBTOR  NEW BILL^C K^39^^^0
  3736   "FIA",343)
  3737   AR FORM LE TTER
  3738   "FIA",343, 0)
  3739   ^RC(343,
  3740   "FIA",343, 0,0)
  3741   343I
  3742   "FIA",343, 0,1)
  3743   n^n^f^^y^^ y^m^n
  3744   "FIA",343, 0,10)
  3745  
  3746   "FIA",343, 0,11)
  3747  
  3748   "FIA",343, 0,"RLRO")
  3749  
  3750   "FIA",343, 0,"VR")
  3751   4.5^PRCA
  3752   "FIA",343, 343)
  3753   0
  3754   "FIA",343, 343.01)
  3755   0
  3756   "FIA",430)
  3757   ACCOUNTS R ECEIVABLE
  3758   "FIA",430, 0)
  3759   ^PRCA(430,
  3760   "FIA",430, 0,0)
  3761   430I
  3762   "FIA",430, 0,1)
  3763   y^n^p^^^^n ^^n
  3764   "FIA",430, 0,10)
  3765  
  3766   "FIA",430, 0,11)
  3767  
  3768   "FIA",430, 0,"RLRO")
  3769  
  3770   "FIA",430, 0,"VR")
  3771   4.5^PRCA
  3772   "FIA",430, 430)
  3773   1
  3774   "FIA",430, 430,156)
  3775  
  3776   "FIA",430, 430,171)
  3777  
  3778   "FIA",430, 430,301)
  3779  
  3780   "FIA",430, 430.0171)
  3781   1
  3782   "FIA",430, 430.0171,. 01)
  3783  
  3784   "FIA",430. 3)
  3785   ACCOUNTS R ECEIVABLE  TRANS.TYPE
  3786   "FIA",430. 3,0)
  3787   ^PRCA(430. 3,
  3788   "FIA",430. 3,0,0)
  3789   430.3
  3790   "FIA",430. 3,0,1)
  3791   n^n^f^^y^^ y^m^n
  3792   "FIA",430. 3,0,10)
  3793  
  3794   "FIA",430. 3,0,11)
  3795  
  3796   "FIA",430. 3,0,"RLRO" )
  3797  
  3798   "FIA",430. 3,0,"VR")
  3799   4.5^PRCA
  3800   "FIA",430. 3,430.3)
  3801   0
  3802   "INIT")
  3803   PRCA315P
  3804   "KRN",.402 ,807,-1)
  3805   0^1
  3806   "KRN",.402 ,807,0)
  3807   PRCAE ADMI N^3170920. 1912^^433^ ^^3171016
  3808   "KRN",.402 ,807,"%D", 0)
  3809   ^.4021^2^2 ^3170920^^ ^^
  3810   "KRN",.402 ,807,"%D", 1,0)
  3811   This templ ate adds a n administ rative cha rge to an  account.
  3812   "KRN",.402 ,807,"%D", 2,0)
  3813   OPTION: PR CAC TR ADM
  3814   "KRN",.402 ,807,"DIAB ",2,0,433, 3)
  3815   27;"INTERE ST CHARGE"
  3816   "KRN",.402 ,807,"DIAB ",3,0,433, 2)
  3817   28;"MONTHL Y ADMIN. C HARGE"
  3818   "KRN",.402 ,807,"DIAB ",5,0,433, 0)
  3819   11;"ADMIN.  COST CHAR GE DATE"// ^S X=DT
  3820   "KRN",.402 ,807,"DR", 1,433)
  3821   S:'$D(PRCA BN) Y="";S :$D(PRCASU P) ADMINTO T=0;.03/// /^S X=PRCA BN;12///^S  X=$S($D(^ PRCA(430," TCSP",PRCA BN)):74,1: 12);11ADMI N. COST CH ARGE DATE~ ;21;S:$D(P RCASUP) AD MINTOT=X;2 2;S:$D(PRC ASUP) ADMI NTOT=ADMIN TOT+X;23;
  3822   "KRN",.402 ,807,"DR", 1,433,1)
  3823   S:$D(PRCAS UP) ADMINT OT=ADMINTO T+X;24;S:$ D(PRCASUP)  ADMINTOT= ADMINTOT+X ;S PRCA2=0 ;S:$D(PRCA ERR) Y=28; 25;I $D(PR CASUP),X<0 ,-X>$P(PRC AIND,U,4)  W !,*7,"TO O MUCH MAR SHALL FEE  BEING DEDU CTED" S Y= 25;26;
  3824   "KRN",.402 ,807,"DR", 1,433,2)
  3825   I $D(PRCAS UP),X<0,-X >$P(PRCAIN D,U,5) W ! ,*7,"TOO M UCH COURT  COST BEING  DEDUCTED"  S Y=26;S: '$D(PRCASU P) Y="";28 MONTHLY AD MIN. CHARG E~;S ADMIN TOT=ADMINT OT+X;29;S  ADMINTOT=A DMINTOT+X; K PRCAERR;
  3826   "KRN",.402 ,807,"DR", 1,433,3)
  3827   I ADMINTOT <0,-ADMINT OT>$P(PRCA IND,U,3) W  !,*7,"TOO  MUCH ADMI NISTRATIVE  CHARGE DE DUCTED." S  PRCAERR=1 ,ADMINTOT= 0,Y=21;27I NTEREST CH ARGE~;I X< 0,-X>$P(PR CAIND,U,2)  W !,*7,"T OO MUCH IN TEREST DED UCTED" S Y =27;
  3828   "KRN",19,1 1794,-1)
  3829   0^14
  3830   "KRN",19,1 1794,0)
  3831   RCTCSP STO P^Stop/Rea ctivate TC SP Referra l For a Bi ll^^R^^^^^ ^^^
  3832   "KRN",19,1 1794,1,0)
  3833   ^19.06^3^3 ^3150113^^
  3834   "KRN",19,1 1794,1,1,0 )
  3835   This optio n is used  to allow t he user to  stop Cros s-Servicin g referral  for
  3836   "KRN",19,1 1794,1,2,0 )
  3837   a bill.  I t also is  used to re -activate  Cross-Serv icing refe rral for a
  3838   "KRN",19,1 1794,1,3,0 )
  3839   bill that  had been p reviously  stopped.
  3840   "KRN",19,1 1794,25)
  3841   STOP^RCTCS PU
  3842   "KRN",19,1 1794,"U")
  3843   STOP/REACT IVATE TCSP  REFERRAL 
  3844   "KRN",19,1 1795,-1)
  3845   0^12
  3846   "KRN",19,1 1795,0)
  3847   RCTCSP REC ALLB^Bill  Recall/Rea ctivate TC SP Referra l^^R^^^^^^ ^^
  3848   "KRN",19,1 1795,1,0)
  3849   ^19.06^3^3 ^3170308^^
  3850   "KRN",19,1 1795,1,1,0 )
  3851   This optio n is used  to allow t he user to  recall a  bill from  Cross 
  3852   "KRN",19,1 1795,1,2,0 )
  3853   Servicing.   It is al so used to  delete th e recall i f the reca ll has not  
  3854   "KRN",19,1 1795,1,3,0 )
  3855   taken plac e.
  3856   "KRN",19,1 1795,25)
  3857   RCLLSETB^R CTCSPU
  3858   "KRN",19,1 1795,"U")
  3859   BILL RECAL L/REACTIVA TE TCSP RE
  3860   "KRN",19,1 1796,-1)
  3861   0^13
  3862   "KRN",19,1 1796,0)
  3863   RCTCSP REC ALLD^Debto r Recall/R eactivate  TCSP Refer ral^^R^^^^ ^^^^
  3864   "KRN",19,1 1796,1,0)
  3865   ^19.06^3^3 ^3170308^^ ^
  3866   "KRN",19,1 1796,1,1,0 )
  3867   This optio n is used  to allow t he user to  recall a  debtor and  all of 
  3868   "KRN",19,1 1796,1,2,0 )
  3869   the associ ated bills  from Cros s-Servicin g.  It is  also used  to delete  the
  3870   "KRN",19,1 1796,1,3,0 )
  3871   recall if  the recall  has not t aken place .
  3872   "KRN",19,1 1796,25)
  3873   RCLLSETD^R CTCSPU
  3874   "KRN",19,1 1796,"U")
  3875   DEBTOR REC ALL/REACTI VATE TCSP 
  3876   "KRN",19,1 1797,-1)
  3877   0^6
  3878   "KRN",19,1 1797,0)
  3879   RCTCSP MEN U^Cross-Se rvicing Me nu^^M^^^^^ ^^^
  3880   "KRN",19,1 1797,1,0)
  3881   ^19.06^2^2 ^3150113^^ ^^
  3882   "KRN",19,1 1797,1,1,0 )
  3883   This menu  is placed  on the AR  Supervisor 's Menu.   It contain s
  3884   "KRN",19,1 1797,1,2,0 )
  3885    options f or Cross-S ervicing.
  3886   "KRN",19,1 1797,10,0)
  3887   ^19.01IP^3 9^21
  3888   "KRN",19,1 1797,10,1, 0)
  3889   11794
  3890   "KRN",19,1 1797,10,1, "^")
  3891   RCTCSP STO P
  3892   "KRN",19,1 1797,10,2, 0)
  3893   11795
  3894   "KRN",19,1 1797,10,2, "^")
  3895   RCTCSP REC ALLB
  3896   "KRN",19,1 1797,10,3, 0)
  3897   11796
  3898   "KRN",19,1 1797,10,3, "^")
  3899   RCTCSP REC ALLD
  3900   "KRN",19,1 1797,10,4, 0)
  3901   11798
  3902   "KRN",19,1 1797,10,4, "^")
  3903   RCTCSP BIL L REPORT
  3904   "KRN",19,1 1797,10,5, 0)
  3905   11799
  3906   "KRN",19,1 1797,10,5, "^")
  3907   RCTCSP REP ORT
  3908   "KRN",19,1 1797,10,6, 0)
  3909   11800
  3910   "KRN",19,1 1797,10,6, "^")
  3911   RCTCSP REC ALL REPORT
  3912   "KRN",19,1 1797,10,9, 0)
  3913   11803^
  3914   "KRN",19,1 1797,10,9, "^")
  3915   RCTCSP REJ ECT REPORT
  3916   "KRN",19,1 1797,10,10 ,0)
  3917   11804^
  3918   "KRN",19,1 1797,10,10 ,"^")
  3919   RCTCSP IAI  ERROR COD ES LIST
  3920   "KRN",19,1 1797,10,11 ,0)
  3921   11807
  3922   "KRN",19,1 1797,10,11 ,"^")
  3923   RCTCSP STO P REACTIVA TE REPORT
  3924   "KRN",19,1 1797,10,20 ,0)
  3925   11819
  3926   "KRN",19,1 1797,10,20 ,"^")
  3927   RCTCSP IAI  REPORT
  3928   "KRN",19,1 1797,10,38 ,0)
  3929   11816
  3930   "KRN",19,1 1797,10,38 ,"^")
  3931   RCTCSP REC ONCILIATIO N WORKLIST
  3932   "KRN",19,1 1797,10,39 ,0)
  3933   11802
  3934   "KRN",19,1 1797,10,39 ,"^")
  3935   RCTCSP REC ONCIL REPO RT
  3936   "KRN",19,1 1797,99)
  3937   64602,5386 7
  3938   "KRN",19,1 1797,99.1)
  3939   64562,4877 6
  3940   "KRN",19,1 1797,"U")
  3941   CROSS-SERV ICING MENU
  3942   "KRN",19,1 1798,-1)
  3943   0^7
  3944   "KRN",19,1 1798,0)
  3945   RCTCSP BIL L REPORT^C ross-Servi cing Bill  Report^^R^ ^^^^^^^
  3946   "KRN",19,1 1798,1,0)
  3947   ^19.06^5^5 ^3150113^^ ^^
  3948   "KRN",19,1 1798,1,1,0 )
  3949   This repor t lists th e bills fo r the indi vidual deb tor that h ave been
  3950   "KRN",19,1 1798,1,2,0 )
  3951   forwarded  to Cross-S ervicing.   For each  bill, the  report dis plays
  3952   "KRN",19,1 1798,1,3,0 )
  3953   the status  code, the  original  amount of  the bill,  the curren t amount o f
  3954   "KRN",19,1 1798,1,4,0 )
  3955   the bill,  the princi ple, inter est, admin istrative  cost, cour t cost, an d
  3956   "KRN",19,1 1798,1,5,0 )
  3957   the Cross- Servicing  referral d ate.
  3958   "KRN",19,1 1798,25)
  3959   BILLREP^RC TCSP1
  3960   "KRN",19,1 1798,"U")
  3961   CROSS-SERV ICING BILL  REPORT
  3962   "KRN",19,1 1799,-1)
  3963   0^10
  3964   "KRN",19,1 1799,0)
  3965   RCTCSP REP ORT^Print  Cross-Serv icing Repo rt^^R^^^^^ ^^^
  3966   "KRN",19,1 1799,1,0)
  3967   ^19.06^5^5 ^3150113^^ ^
  3968   "KRN",19,1 1799,1,1,0 )
  3969   This optio n is used  to print a  Cross-Ser vicing rep ort.  For  each bill 
  3970   "KRN",19,1 1799,1,2,0 )
  3971   which has  been refer red to Cro ss-Servici ng, the re port will  display th e
  3972   "KRN",19,1 1799,1,3,0 )
  3973   Debtor's n ame, the D ebtor SSN,  the origi nal amount  referred,  and the 
  3974   "KRN",19,1 1799,1,4,0 )
  3975   Cross-Serv icing refe rred date.   The user  will have  the optio n of sorti ng
  3976   "KRN",19,1 1799,1,5,0 )
  3977   by Bill Nu mber, Debt or Name, o r Cross-Se rvicing Re ferred Dat e.
  3978   "KRN",19,1 1799,25)
  3979   CSRPRT^RCT CSP1
  3980   "KRN",19,1 1799,"U")
  3981   PRINT CROS S-SERVICIN G REPORT
  3982   "KRN",19,1 1800,-1)
  3983   0^5
  3984   "KRN",19,1 1800,0)
  3985   RCTCSP REC ALL REPORT ^Cross-Ser vicing Rec all Report ^^R^^^^^^^ ^
  3986   "KRN",19,1 1800,1,0)
  3987   ^19.06^3^3 ^3150113^^ ^^
  3988   "KRN",19,1 1800,1,1,0 )
  3989   The Cross- Servicing  Recall Rep ort lists  the bills  that have  been recal led
  3990   "KRN",19,1 1800,1,2,0 )
  3991   from Cross -Servicing .  The rep ort has tw o sort opt ions, a so rt by Bill  
  3992   "KRN",19,1 1800,1,3,0 )
  3993   Number, an d a sort b y Debtor N ame.
  3994   "KRN",19,1 1800,25)
  3995   CSRCLRT^RC TCSP5
  3996   "KRN",19,1 1800,"U")
  3997   CROSS-SERV ICING RECA LL REPORT
  3998   "KRN",19,1 1802,-1)
  3999   0^11
  4000   "KRN",19,1 1802,0)
  4001   RCTCSP REC ONCIL REPO RT^Reconci liation Re port - Cro ss-Servici ng^^R^^^^^ ^^^
  4002   "KRN",19,1 1802,1,0)
  4003   ^19.06^8^8 ^3170308^^ ^^
  4004   "KRN",19,1 1802,1,1,0 )
  4005   This optio n is used  to print a  Reconcili ation Repo rt.  For
  4006   "KRN",19,1 1802,1,2,0 )
  4007   each bill  which has  been retur ned from T reasury by  reconcili ation,
  4008   "KRN",19,1 1802,1,3,0 )
  4009   the report  will disp lay the De btor's nam e, Bill Nu mber, Retu rned
  4010   "KRN",19,1 1802,1,4,0 )
  4011   Date, and  Closed Dat e.  A seco nd text li ne will di splay 
  4012   "KRN",19,1 1802,1,5,0 )
  4013   the Return ed Code De scription.   If there  is a Date  of Death,
  4014   "KRN",19,1 1802,1,6,0 )
  4015   a Date of  Bankruptcy , or a Dat e of Disso lution, th en this
  4016   "KRN",19,1 1802,1,7,0 )
  4017   date will  appear on  a new line  with a te xt descrip tion and
  4018   "KRN",19,1 1802,1,8,0 )
  4019   the date.
  4020   "KRN",19,1 1802,25)
  4021   RCRPRT^RCT CSP2
  4022   "KRN",19,1 1802,"U")
  4023   RECONCILIA TION REPOR T - CROSS-
  4024   "KRN",19,1 1803,-1)
  4025   0^8
  4026   "KRN",19,1 1803,0)
  4027   RCTCSP REJ ECT REPORT ^Debt Refe rral Rejec t Report^^ R^^^^^^^^
  4028   "KRN",19,1 1803,1,0)
  4029   4^19.06^10 ^10^314120 8^^^^
  4030   "KRN",19,1 1803,1,1,0 )
  4031   This optio n allows t he user to  report id entified D ebt Referr al Rejects .
  4032   "KRN",19,1 1803,1,2,0 )
  4033    
  4034   "KRN",19,1 1803,1,3,0 )
  4035   The report  prints ou t based on  the follo wing user  defined pa rameters: 
  4036   "KRN",19,1 1803,1,4,0 )
  4037    (i.e. -Ra nge of Dat es,   -in  either Bri ef or Deta il mode,
  4038   "KRN",19,1 1803,1,5,0 )
  4039          -so rted by Bi ll Number,  Debtor Na me or CS R eferred Da te,
  4040   "KRN",19,1 1803,1,6,0 )
  4041          -fo r a given  Reject Ori gination S ource (or  All),
  4042   "KRN",19,1 1803,1,7,0 )
  4043          -an d in eithe r Ascendin g or Desce nding prin t order.)
  4044   "KRN",19,1 1803,1,8,0 )
  4045    
  4046   "KRN",19,1 1803,1,9,0 )
  4047   In additio n, output  can be mad e to a dev ice or fil e in eithe r print 
  4048   "KRN",19,1 1803,1,10, 0)
  4049   or in Exce l spreadsh eet format .
  4050   "KRN",19,1 1803,25)
  4051   RJRPT^RCTC SJR
  4052   "KRN",19,1 1803,"U")
  4053   DEBT REFER RAL REJECT  REPORT
  4054   "KRN",19,1 1804,-1)
  4055   0^9
  4056   "KRN",19,1 1804,0)
  4057   RCTCSP IAI  ERROR COD ES LIST^Li st IAI Err or Codes^^ R^^^^^^^^
  4058   "KRN",19,1 1804,1,0)
  4059   ^19.06^3^3 ^3141112^^
  4060   "KRN",19,1 1804,1,1,0 )
  4061   This optio n is a lis ting of th e IAI Erro r Codes, i n error co de order.   Its
  4062   "KRN",19,1 1804,1,2,0 )
  4063   display co ntains a)  Error Code , b) Field  Name, c)  associated  Record Ty pes 
  4064   "KRN",19,1 1804,1,3,0 )
  4065   and d) Des cription.
  4066   "KRN",19,1 1804,25)
  4067   ECLIST^RCT CSJR
  4068   "KRN",19,1 1804,"U")
  4069   LIST IAI E RROR CODES
  4070   "KRN",19,1 1807,-1)
  4071   0^4
  4072   "KRN",19,1 1807,0)
  4073   RCTCSP STO P REACTIVA TE REPORT^ Cross-Serv icing Stop  Reactivat e Report^^ R^^^^^^^^
  4074   "KRN",19,1 1807,1,0)
  4075   ^^4^4^3170 606^
  4076   "KRN",19,1 1807,1,1,0 )
  4077   The Cross- Servicing  Stop React ivate Repo rt lists t he bills t hat have b een
  4078   "KRN",19,1 1807,1,2,0 )
  4079   stopped fr om Cross-S ervicing,  or Reactiv ated, or B oth. The u ser may se lect
  4080   "KRN",19,1 1807,1,3,0 )
  4081   a range of  Debtors o r all Debt ors, and a  range of  dates or a ll dates.
  4082   "KRN",19,1 1807,1,4,0 )
  4083   Excel CSV  output is  also suppo rted.
  4084   "KRN",19,1 1807,25)
  4085   EN^RCTCSP4
  4086   "KRN",19,1 1807,"U")
  4087   CROSS-SERV ICING STOP  REACTIVAT
  4088   "KRN",19,1 1815,-1)
  4089   0^15
  4090   "KRN",19,1 1815,0)
  4091   PRCAC ENTE R EDIT REP AYMENT^Ent er/Edit Re payment Pl an^^A^^^^^ ^^^ACCOUNT S RECEIVAB LE^^1
  4092   "KRN",19,1 1815,1,0)
  4093   ^^1^1^3170 213^
  4094   "KRN",19,1 1815,1,1,0 )
  4095   This optio n sets up  a repaymen t plan for  an AR Deb tor. The p lan can in corporate  multiple b ills.
  4096   "KRN",19,1 1815,20)
  4097   D ^PRCARPM
  4098   "KRN",19,1 1815,"U")
  4099   ENTER/EDIT  REPAYMENT  PLAN
  4100   "KRN",19,1 1816,-1)
  4101   0^16
  4102   "KRN",19,1 1816,0)
  4103   RCTCSP REC ONCILIATIO N WORKLIST ^Reconcili ation List  Manager^^ R^^^^^^^^
  4104   "KRN",19,1 1816,1,0)
  4105   ^19.06^1^1 ^3170329^^ ^
  4106   "KRN",19,1 1816,1,1,0 )
  4107   List Manag er for Vis tA AR Cros s-servicin g
  4108   "KRN",19,1 1816,25)
  4109   EN^RCTCSWL
  4110   "KRN",19,1 1816,"U")
  4111   RECONCILIA TION LIST  MANAGER
  4112   "KRN",19,1 1819,-1)
  4113   0^17
  4114   "KRN",19,1 1819,0)
  4115   RCTCSP IAI  REPORT^Tr easury Cro ss-Servici ng IAI Rep ort^^R^^^^ ^^^^
  4116   "KRN",19,1 1819,1,0)
  4117   ^^4^4^3171 016^
  4118   "KRN",19,1 1819,1,1,0 )
  4119   This repor t displays  a record  of current  VHA bills  at Treasu ry. It is 
  4120   "KRN",19,1 1819,1,2,0 )
  4121   tool that  can be use d to ident ify bills  erroneousl y
  4122   "KRN",19,1 1819,1,3,0 )
  4123   listed in  a referral  status in  VistA whe n reconcil ed with th e Print 
  4124   "KRN",19,1 1819,1,4,0 )
  4125   Cross-Serv icing Repo rt.
  4126   "KRN",19,1 1819,25)
  4127   IAIRPT^RCT CSP5
  4128   "KRN",19,1 1819,"U")
  4129   TREASURY C ROSS-SERVI CING IAI R
  4130   "KRN",19.1 ,617,-1)
  4131   0^1
  4132   "KRN",19.1 ,617,0)
  4133   PRCAF LATE  CHARGES
  4134   "KRN",19.1 ,617,1,0)
  4135   ^^2^2^3161 116^
  4136   "KRN",19.1 ,617,1,1,0 )
  4137   This is a  key for th e AR actio n in PRCAF  U ADMIN.R ATE to all ow edits
  4138   "KRN",19.1 ,617,1,2,0 )
  4139   to the Int erest/Admi n and Pena lty Rates.
  4140   "KRN",101, 460,-1)
  4141   4^55
  4142   "KRN",101, 460,0)
  4143   VALM BLANK  5
  4144   "KRN",101, 461,-1)
  4145   4^56
  4146   "KRN",101, 461,0)
  4147   VALM BLANK  6
  4148   "KRN",101, 2778,-1)
  4149   4^37
  4150   "KRN",101, 2778,0)
  4151   RCDP ACCOU NT PROFILE  SELECT NE W ACCOUNT
  4152   "KRN",101, 2779,-1)
  4153   4^38
  4154   "KRN",101, 2779,0)
  4155   RCDP ACCOU NT PROFILE  BILL TRAN SACTIONS
  4156   "KRN",101, 2780,-1)
  4157   4^39
  4158   "KRN",101, 2780,0)
  4159   RCDP ACCOU NT PROFILE  SELECT ST ATUS
  4160   "KRN",101, 2786,-1)
  4161   4^43
  4162   "KRN",101, 2786,0)
  4163   RCDP ACCOU NT PROFILE  BILL PROF ILE
  4164   "KRN",101, 2816,-1)
  4165   4^40
  4166   "KRN",101, 2816,0)
  4167   RCDP FAST  EXIT
  4168   "KRN",101, 4992,-1)
  4169   0^24
  4170   "KRN",101, 4992,0)
  4171   PRCA TCSP  WORKLIST M ENU^Workli st Menu^^M ^^^^^^^^AC COUNTS REC EIVABLE
  4172   "KRN",101, 4992,1,0)
  4173   ^101.06^1^ 1^3170515^ ^^^
  4174   "KRN",101, 4992,1,1,0 )
  4175   This is th e main cro ss-servici ng worklis t protocol .
  4176   "KRN",101, 4992,4)
  4177   26^3
  4178   "KRN",101, 4992,10,0)
  4179   ^101.01PA^ 9^6
  4180   "KRN",101, 4992,10,1, 0)
  4181   4993^EP^10 ^^^Expand  Pat
  4182   "KRN",101, 4992,10,1, "^")
  4183   PRCA TCSP  WORKLIST E XPAND
  4184   "KRN",101, 4992,10,2, 0)
  4185   4996^VI^20 ^^^View In s
  4186   "KRN",101, 4992,10,2, "^")
  4187   PRCA TCSP  WORKLIST I NSURANCE
  4188   "KRN",101, 4992,10,3, 0)
  4189   4997^AP^30 ^^^Acct Pr ofile
  4190   "KRN",101, 4992,10,3, "^")
  4191   PRCA TCSP  WORKLIST A CCOUNT PRO FILE
  4192   "KRN",101, 4992,10,4, 0)
  4193   4998^PT^40 ^^^Patient  Inq
  4194   "KRN",101, 4992,10,4, "^")
  4195   PRCA TCSP  WORKLIST V IEW PATIEN T
  4196   "KRN",101, 4992,10,8, 0)
  4197   5002^PR^80 ^^^Print S tatement
  4198   "KRN",101, 4992,10,8, "^")
  4199   PRCA TCSP  WORKLIST P RINT STATE MENT
  4200   "KRN",101, 4992,10,9, 0)
  4201   5008^RM^90 ^^^Remove  From Workl ist
  4202   "KRN",101, 4992,10,9, "^")
  4203   PRCA TCSP  WORKLIST R EMOVE
  4204   "KRN",101, 4992,26)
  4205   D SHOW^VAL M
  4206   "KRN",101, 4992,28)
  4207   Select Act ion: 
  4208   "KRN",101, 4992,99)
  4209   64418,5001 7
  4210   "KRN",101, 4993,-1)
  4211   0^21
  4212   "KRN",101, 4993,0)
  4213   PRCA TCSP  WORKLIST E XPAND^Expa nd^^A^^^^^ ^^^ACCOUNT S RECEIVAB LE
  4214   "KRN",101, 4993,2,0)
  4215   ^101.02A^^ 0
  4216   "KRN",101, 4993,10,0)
  4217   ^101.01PA^ 0^0
  4218   "KRN",101, 4993,20)
  4219   D EXPAND^R CTCSWL
  4220   "KRN",101, 4993,99)
  4221   64363,6107 4
  4222   "KRN",101, 4994,-1)
  4223   0^36
  4224   "KRN",101, 4994,0)
  4225   PRCA TCSP  WORKLIST E XPAND MENU  PROTOCOL^ Expand Men u Protocol ^^M^^^^^^^ ^ACCOUNTS  RECEIVABLE
  4226   "KRN",101, 4994,4)
  4227   ^3
  4228   "KRN",101, 4994,26)
  4229   D SHOW^VAL M
  4230   "KRN",101, 4994,28)
  4231  
  4232   "KRN",101, 4994,29)
  4233   Quit
  4234   "KRN",101, 4994,99)
  4235   64363,6107 4
  4236   "KRN",101, 4996,-1)
  4237   0^23
  4238   "KRN",101, 4996,0)
  4239   PRCA TCSP  WORKLIST I NSURANCE^V iew Insura nce^^A^^^^ ^^^^
  4240   "KRN",101, 4996,20)
  4241   D LINKI^RC TCSWL
  4242   "KRN",101, 4996,99)
  4243   64363,6107 4
  4244   "KRN",101, 4997,-1)
  4245   0^19
  4246   "KRN",101, 4997,0)
  4247   PRCA TCSP  WORKLIST A CCOUNT PRO FILE^Acct  Profile^^A ^^^^^^^^
  4248   "KRN",101, 4997,2,0)
  4249   ^101.02A^^ 0
  4250   "KRN",101, 4997,20)
  4251   D ACCTPR^R CTCSWL
  4252   "KRN",101, 4997,99)
  4253   64363,6107 4
  4254   "KRN",101, 4998,-1)
  4255   0^27
  4256   "KRN",101, 4998,0)
  4257   PRCA TCSP  WORKLIST V IEW PATIEN T^Patient  View^^A^^^ ^^^^^
  4258   "KRN",101, 4998,2,0)
  4259   ^101.02A^^ 0
  4260   "KRN",101, 4998,20)
  4261   D PTVW^RCT CSWL
  4262   "KRN",101, 4998,99)
  4263   64418,4964 7
  4264   "KRN",101, 4999,-1)
  4265   0^57
  4266   "KRN",101, 4999,0)
  4267   PRCA TCSP  WORKLIST C ANCEL/EDIT /ADD^Cance l/Edit/Add ^^A^^^^^^^ ^
  4268   "KRN",101, 4999,20)
  4269   D CEA^RCTC SWL
  4270   "KRN",101, 4999,99)
  4271   64425,6863 3
  4272   "KRN",101, 5000,-1)
  4273   0^52
  4274   "KRN",101, 5000,0)
  4275   RCDP ACCT  PROFILE IN CREASE TRA NS^Increas e Adjustme nt^^A^^^^^ ^^^ACCOUNT S RECEIVAB LE
  4276   "KRN",101, 5000,1,0)
  4277   ^^2^2^3170 522^
  4278   "KRN",101, 5000,1,1,0 )
  4279   This is th e action f or Increas e Adjustme nt on the  Account Pr ofile scre en. 
  4280   "KRN",101, 5000,1,2,0 )
  4281   Multiple s election a llowed.
  4282   "KRN",101, 5000,20)
  4283   D INC^RCDP APL1
  4284   "KRN",101, 5000,99)
  4285   64363,6107 4
  4286   "KRN",101, 5001,-1)
  4287   0^51
  4288   "KRN",101, 5001,0)
  4289   RCDP ACCT  PROFILE DE CREASE TRA NS^Decreas e Adjustme nt^^A^^^^^ ^^^ACCOUNT S RECEIVAB LE
  4290   "KRN",101, 5001,1,0)
  4291   ^^2^2^3170 522^
  4292   "KRN",101, 5001,1,1,0 )
  4293   This is th e action f or Decreas e Adjustme nt on the  Account Pr ofile scre en.
  4294   "KRN",101, 5001,1,2,0 )
  4295   Multiple s election a llowed.
  4296   "KRN",101, 5001,20)
  4297   D DEC^RCDP APL1
  4298   "KRN",101, 5001,99)
  4299   64363,6107 4
  4300   "KRN",101, 5002,-1)
  4301   0^25
  4302   "KRN",101, 5002,0)
  4303   PRCA TCSP  WORKLIST P RINT STATE MENT^Print  Statement ^^A^^^^^^^ ^
  4304   "KRN",101, 5002,20)
  4305   D PRTSTAT^ RCTCSWL
  4306   "KRN",101, 5002,99)
  4307   64363,6107 4
  4308   "KRN",101, 5004,-1)
  4309   0^47
  4310   "KRN",101, 5004,0)
  4311   RCDP ACCT  PROFILE ST OP^Stop TC SP^^A^^^^^ ^^^ACCOUNT S RECEIVAB LE
  4312   "KRN",101, 5004,1,0)
  4313   ^^2^2^3170 522^
  4314   "KRN",101, 5004,1,1,0 )
  4315   This is th e action f or Stop TC SP on the  Account Pr ofile scre en. 
  4316   "KRN",101, 5004,1,2,0 )
  4317   Multiple s election a llowed.
  4318   "KRN",101, 5004,20)
  4319   D STOP^RCD PAPL1
  4320   "KRN",101, 5004,99)
  4321   64363,6107 4
  4322   "KRN",101, 5005,-1)
  4323   0^48
  4324   "KRN",101, 5005,0)
  4325   RCDP ACCT  PROFILE TE RM FISCAL^ Term Fisca l^^A^^^^^^ ^^ACCOUNTS  RECEIVABL E
  4326   "KRN",101, 5005,1,0)
  4327   ^^2^2^3170 522^
  4328   "KRN",101, 5005,1,1,0 )
  4329   This is th e action f or Term Fi scal on th e Account  Profile sc reen.
  4330   "KRN",101, 5005,1,2,0 )
  4331   Multiple s election a llowed.
  4332   "KRN",101, 5005,20)
  4333   D TERM^RCD PAPL1
  4334   "KRN",101, 5005,99)
  4335   64363,6107 4
  4336   "KRN",101, 5006,-1)
  4337   0^49
  4338   "KRN",101, 5006,0)
  4339   RCDP ACCT  PROFILE RE CALL BILL^ Recall Bil l^^A^^^^^^ ^^ACCOUNTS  RECEIVABL E
  4340   "KRN",101, 5006,1,0)
  4341   ^^2^2^3170 522^
  4342   "KRN",101, 5006,1,1,0 )
  4343   This is th e action f or Recall  Bill on th e Account  Profile sc reen. 
  4344   "KRN",101, 5006,1,2,0 )
  4345   Multiple s election a llowed.
  4346   "KRN",101, 5006,20)
  4347   D RECALLB^ RCDPAPL1
  4348   "KRN",101, 5006,99)
  4349   64363,6107 4
  4350   "KRN",101, 5007,-1)
  4351   0^50
  4352   "KRN",101, 5007,0)
  4353   RCDP ACCT  PROFILE RE CALL DEBTO R^Recall D ebtor^^A^^ ^^^^^^ACCO UNTS RECEI VABLE
  4354   "KRN",101, 5007,1,0)
  4355   ^^2^2^3170 522^
  4356   "KRN",101, 5007,1,1,0 )
  4357   This is th e action f or Recall  Debtor on  the Accoun t Profile  screen. 
  4358   "KRN",101, 5007,1,2,0 )
  4359   No multipl e selectio n.
  4360   "KRN",101, 5007,20)
  4361   D RECALLD^ RCDPAPL1
  4362   "KRN",101, 5007,99)
  4363   64363,6107 4
  4364   "KRN",101, 5008,-1)
  4365   0^26
  4366   "KRN",101, 5008,0)
  4367   PRCA TCSP  WORKLIST R EMOVE^Remo ve From Wo rklist^^A^ ^^^^^^^
  4368   "KRN",101, 5008,20)
  4369   D REMOVE^R CTCSWL
  4370   "KRN",101, 5008,99)
  4371   64363,6107 4
  4372   "KRN",101, 5009,-1)
  4373   0^53
  4374   "KRN",101, 5009,0)
  4375   RCDP ACCT  PROFILE SU SPEND^Susp end Bill^^ A^^^^^^^^A CCOUNTS RE CEIVABLE
  4376   "KRN",101, 5009,1,0)
  4377   ^^2^2^3170 522^
  4378   "KRN",101, 5009,1,1,0 )
  4379   This is th e action f or Suspend  Bill on t he Account  Profile s creen. 
  4380   "KRN",101, 5009,1,2,0 )
  4381   Multiple s election a llowed.
  4382   "KRN",101, 5009,20)
  4383   D SUSPEND^ RCDPAPL1
  4384   "KRN",101, 5009,99)
  4385   64394,4438 9
  4386   "KRN",101, 5012,-1)
  4387   0^31
  4388   "KRN",101, 5012,0)
  4389   PRCA TCSP  ACCOUNT PR OFILE MENU ^Account P rofile Men u^^M^^^^^^ ^^ACCOUNTS  RECEIVABL E
  4390   "KRN",101, 5012,1,0)
  4391   ^101.06^1^ 1^3170508^ ^^^
  4392   "KRN",101, 5012,1,1,0 )
  4393   This optio n will sho w a profil e of bills  for an ac count.
  4394   "KRN",101, 5012,4)
  4395   20^3^^DP
  4396   "KRN",101, 5012,10,0)
  4397   ^101.01PA^ 19^16
  4398   "KRN",101, 5012,10,1, 0)
  4399   2778^NA^41 ^^^Select  New Acct
  4400   "KRN",101, 5012,10,1, "^")
  4401   RCDP ACCOU NT PROFILE  SELECT NE W ACCOUNT
  4402   "KRN",101, 5012,10,3, 0)
  4403   2780^SS^31 ^
  4404   "KRN",101, 5012,10,3, "^")
  4405   RCDP ACCOU NT PROFILE  SELECT ST ATUS
  4406   "KRN",101, 5012,10,4, 0)
  4407   4999^CN^42 ^
  4408   "KRN",101, 5012,10,4, "^")
  4409   PRCA TCSP  WORKLIST C ANCEL/EDIT /ADD
  4410   "KRN",101, 5012,10,5, 0)
  4411   2816^EA^44 ^
  4412   "KRN",101, 5012,10,5, "^")
  4413   RCDP FAST  EXIT
  4414   "KRN",101, 5012,10,7, 0)
  4415   2779^BT^21 ^^^Bill Tr ans
  4416   "KRN",101, 5012,10,7, "^")
  4417   RCDP ACCOU NT PROFILE  BILL TRAN SACTIONS
  4418   "KRN",101, 5012,10,8, 0)
  4419   5004^ST^12 ^
  4420   "KRN",101, 5012,10,8, "^")
  4421   RCDP ACCT  PROFILE ST OP
  4422   "KRN",101, 5012,10,9, 0)
  4423   5005^TF^23 ^
  4424   "KRN",101, 5012,10,9, "^")
  4425   RCDP ACCT  PROFILE TE RM FISCAL
  4426   "KRN",101, 5012,10,10 ,0)
  4427   5006^RB^22 ^
  4428   "KRN",101, 5012,10,10 ,"^")
  4429   RCDP ACCT  PROFILE RE CALL BILL
  4430   "KRN",101, 5012,10,11 ,0)
  4431   5007^RD^32 ^
  4432   "KRN",101, 5012,10,11 ,"^")
  4433   RCDP ACCT  PROFILE RE CALL DEBTO R
  4434   "KRN",101, 5012,10,12 ,0)
  4435   5001^DA^43 ^^^Decreas e Adj
  4436   "KRN",101, 5012,10,12 ,"^")
  4437   RCDP ACCT  PROFILE DE CREASE TRA NS
  4438   "KRN",101, 5012,10,13 ,0)
  4439   5000^IA^33 ^^^Increas e Adj
  4440   "KRN",101, 5012,10,13 ,"^")
  4441   RCDP ACCT  PROFILE IN CREASE TRA NS
  4442   "KRN",101, 5012,10,14 ,0)
  4443   5009^SU^13 ^
  4444   "KRN",101, 5012,10,14 ,"^")
  4445   RCDP ACCT  PROFILE SU SPEND
  4446   "KRN",101, 5012,10,16 ,0)
  4447   460^^24^
  4448   "KRN",101, 5012,10,16 ,"^")
  4449   VALM BLANK  5
  4450   "KRN",101, 5012,10,17 ,0)
  4451   461^^34^
  4452   "KRN",101, 5012,10,17 ,"^")
  4453   VALM BLANK  6
  4454   "KRN",101, 5012,10,18 ,0)
  4455   2786^BP^11 ^
  4456   "KRN",101, 5012,10,18 ,"^")
  4457   RCDP ACCOU NT PROFILE  BILL PROF ILE
  4458   "KRN",101, 5012,10,19 ,0)
  4459   5022^RE^14 ^^^ReEstab lish Bill
  4460   "KRN",101, 5012,10,19 ,"^")
  4461   RCDP ACCT  PROFILE RE -ESTABLISH
  4462   "KRN",101, 5012,24)
  4463   I 1 X:$D(^ ORD(101,+$ P(^ORD(101 ,DA(1),10, DA,0),"^") ,24)) ^(24 )
  4464   "KRN",101, 5012,26)
  4465   D SHOW^VAL M
  4466   "KRN",101, 5012,28)
  4467   Select Act ion: 
  4468   "KRN",101, 5012,99)
  4469   64454,3410 0
  4470   "KRN",101, 5022,-1)
  4471   0^58
  4472   "KRN",101, 5022,0)
  4473   RCDP ACCT  PROFILE RE -ESTABLISH ^Re-Establ ish Bill^^ A^^^^^^^^A CCOUNTS RE CEIVABLE
  4474   "KRN",101, 5022,1,0)
  4475   ^^2^2^3170 619^
  4476   "KRN",101, 5022,1,1,0 )
  4477   This is th e action p rotocol fo r the Re-E stablish B ill on the  Account 
  4478   "KRN",101, 5022,1,2,0 )
  4479   Profile sc reen.  Mul tiple sele ction is a llowed.
  4480   "KRN",101, 5022,20)
  4481   D REESTAB^ RCDPAPL1
  4482   "KRN",101, 5022,99)
  4483   64453,5314 6
  4484   "KRN",409. 61,399,-1)
  4485   0^6
  4486   "KRN",409. 61,399,0)
  4487   RCDP ACCOU NT PROFILE ^1^^80^7^2 0^1^1^Bill ^RCDP ACCO UNT PROFIL E MENU^Acc ount Profi le^1^^1
  4488   "KRN",409. 61,399,1)
  4489   ^VALM HIDD EN ACTIONS
  4490   "KRN",409. 61,399,"AR RAY")
  4491    ^TMP("RCD PAPLM",$J)
  4492   "KRN",409. 61,399,"CO L",0)
  4493   ^409.621^8 ^7
  4494   "KRN",409. 61,399,"CO L",1,0)
  4495   BILL NUMBE R^8^7^Bill Num
  4496   "KRN",409. 61,399,"CO L",3,0)
  4497   CARE DATE^ 17^8^CareD ate
  4498   "KRN",409. 61,399,"CO L",4,0)
  4499   BILL TYPE^ 33^20^Bill  Type
  4500   "KRN",409. 61,399,"CO L",5,0)
  4501   PRINCIPAL^ 53^9^Princ ipal
  4502   "KRN",409. 61,399,"CO L",6,0)
  4503   INTEREST^6 3^8^Intere st
  4504   "KRN",409. 61,399,"CO L",7,0)
  4505   ADMIN^75^5 ^Admin
  4506   "KRN",409. 61,399,"CO L",8,0)
  4507   STATUS^27^ 4^Stat
  4508   "KRN",409. 61,399,"CO L","B","AD MIN",7)
  4509  
  4510   "KRN",409. 61,399,"CO L","B","BI LL NUMBER" ,1)
  4511  
  4512   "KRN",409. 61,399,"CO L","B","BI LL TYPE",4 )
  4513  
  4514   "KRN",409. 61,399,"CO L","B","CA RE DATE",3 )
  4515  
  4516   "KRN",409. 61,399,"CO L","B","IN TEREST",6)
  4517  
  4518   "KRN",409. 61,399,"CO L","B","PR INCIPAL",5 )
  4519  
  4520   "KRN",409. 61,399,"CO L","B","ST ATUS",8)
  4521  
  4522   "KRN",409. 61,399,"FN L")
  4523   D EXIT^RCD PAPLM
  4524   "KRN",409. 61,399,"HD R")
  4525   D HDR^RCDP APLM
  4526   "KRN",409. 61,399,"IN IT")
  4527   D INIT^RCD PAPLM
  4528   "KRN",409. 61,761,-1)
  4529   0^1
  4530   "KRN",409. 61,761,0)
  4531   RCTCSP WOR KLIST^1^^8 0^5^19^1^1 ^Account^P RCA TCSP W ORKLIST ME NU^TCSP RE CONCILIATI ON WORKLIS T^1^^1
  4532   "KRN",409. 61,761,1)
  4533   ^VALM HIDD EN ACTIONS
  4534   "KRN",409. 61,761,"CO L",0)
  4535   ^409.621^5 ^5
  4536   "KRN",409. 61,761,"CO L",1,0)
  4537   PATIENT^7^ 27^Patient
  4538   "KRN",409. 61,761,"CO L",2,0)
  4539   ID^33^6^Pt  ID
  4540   "KRN",409. 61,761,"CO L",3,0)
  4541   BILLNO^41^ 15^Bill No .
  4542   "KRN",409. 61,761,"CO L",4,0)
  4543   BAL^59^12^ Balance
  4544   "KRN",409. 61,761,"CO L",5,0)
  4545   RSN^68^7^R et Rsn
  4546   "KRN",409. 61,761,"CO L","B","BA L",4)
  4547  
  4548   "KRN",409. 61,761,"CO L","B","BI LLNO",3)
  4549  
  4550   "KRN",409. 61,761,"CO L","B","ID ",2)
  4551  
  4552   "KRN",409. 61,761,"CO L","B","PA TIENT",1)
  4553  
  4554   "KRN",409. 61,761,"CO L","B","RS N",5)
  4555  
  4556   "KRN",409. 61,761,"EX P")
  4557   D EXPAND^R CTCSWL
  4558   "KRN",409. 61,761,"FN L")
  4559   D EXIT^RCT CSWL
  4560   "KRN",409. 61,761,"HD R")
  4561   D HDR^RCTC SWL
  4562   "KRN",409. 61,761,"HL P")
  4563   D HELP^RCT CSWL
  4564   "KRN",409. 61,761,"IN IT")
  4565   D INIT^RCT CSWL
  4566   "KRN",409. 61,762,-1)
  4567   0^2
  4568   "KRN",409. 61,762,0)
  4569   RCTCSP WOR KLIST EXPA ND^1^^80^5 ^20^1^0^^P RCA TCSP W ORKLIST EX PAND MENU  PROTOCOL^E xpanded TC PS Data^1^ ^1
  4570   "KRN",409. 61,762,1)
  4571   ^VALM HIDD EN ACTIONS
  4572   "KRN",409. 61,762,"AR RAY")
  4573    ^TMP("RCT CSWE",$J)
  4574   "KRN",409. 61,762,"CO L",0)
  4575   ^409.621^^ 0
  4576   "KRN",409. 61,762,"FN L")
  4577   D EXIT^RCT CSWL2
  4578   "KRN",409. 61,762,"HD R")
  4579   D HDR^RCTC SWL2
  4580   "KRN",409. 61,762,"HL P")
  4581   D HELP^RCT CSWL2
  4582   "KRN",409. 61,762,"IN IT")
  4583   D INIT^RCT CSWL2
  4584   "KRN",409. 61,764,-1)
  4585   0^5
  4586   "KRN",409. 61,764,0)
  4587   PRCA TCSP  ACCOUNT PR OFILE^1^^8 0^7^18^1^1 ^Bill^PRCA  TCSP ACCO UNT PROFIL E MENU^Acc ount Profi le^1^^1
  4588   "KRN",409. 61,764,1)
  4589   ^VALM HIDD EN ACTIONS
  4590   "KRN",409. 61,764,"AR RAY")
  4591    ^TMP("RCD PAPLM",$J)
  4592   "KRN",409. 61,764,"CO L",0)
  4593   ^409.621^7 ^7
  4594   "KRN",409. 61,764,"CO L",1,0)
  4595   BILL NUMBE R^8^7^Bill Num^^0
  4596   "KRN",409. 61,764,"CO L",2,0)
  4597   CARE DATE^ 17^8^CareD ate^^0
  4598   "KRN",409. 61,764,"CO L",3,0)
  4599   BILL TYPE^ 33^20^Bill  Type^^0
  4600   "KRN",409. 61,764,"CO L",4,0)
  4601   PRINCIPAL^ 53^9^Princ ipal^^0
  4602   "KRN",409. 61,764,"CO L",5,0)
  4603   INTEREST^6 3^8^Intere st^^0
  4604   "KRN",409. 61,764,"CO L",6,0)
  4605   ADMIN^75^5 ^Admin^^0
  4606   "KRN",409. 61,764,"CO L",7,0)
  4607   STATUS^27^ 4^Stat^^0
  4608   "KRN",409. 61,764,"CO L","AIDENT ",0,1)
  4609  
  4610   "KRN",409. 61,764,"CO L","AIDENT ",0,2)
  4611  
  4612   "KRN",409. 61,764,"CO L","AIDENT ",0,3)
  4613  
  4614   "KRN",409. 61,764,"CO L","AIDENT ",0,4)
  4615  
  4616   "KRN",409. 61,764,"CO L","AIDENT ",0,5)
  4617  
  4618   "KRN",409. 61,764,"CO L","AIDENT ",0,6)
  4619  
  4620   "KRN",409. 61,764,"CO L","AIDENT ",0,7)
  4621  
  4622   "KRN",409. 61,764,"CO L","B","AD MIN",6)
  4623  
  4624   "KRN",409. 61,764,"CO L","B","BI LL NUMBER" ,1)
  4625  
  4626   "KRN",409. 61,764,"CO L","B","BI LL TYPE",3 )
  4627  
  4628   "KRN",409. 61,764,"CO L","B","CA RE DATE",2 )
  4629  
  4630   "KRN",409. 61,764,"CO L","B","IN TEREST",5)
  4631  
  4632   "KRN",409. 61,764,"CO L","B","PR INCIPAL",4 )
  4633  
  4634   "KRN",409. 61,764,"CO L","B","ST ATUS",7)
  4635  
  4636   "KRN",409. 61,764,"FN L")
  4637   D EXIT^RCD PAPLM
  4638   "KRN",409. 61,764,"HD R")
  4639   D HDR^RCDP APLM
  4640   "KRN",409. 61,764,"HL P")
  4641  
  4642   "KRN",409. 61,764,"IN IT")
  4643   D INIT^RCD PAPLM
  4644   "MBREQ")
  4645   0
  4646   "ORD",3,19 .1)
  4647   19.1;3;;;K EY^XPDTA1; KEYF1^XPDI A1;KEYE1^X PDIA1;KEYF 2^XPDIA1;; KEYDEL^XPD IA1
  4648   "ORD",3,19 .1,0)
  4649   SECURITY K EY
  4650   "ORD",7,.4 02)
  4651   .402;7;;;E DEOUT^DIFR OMSO(.402, DA,"",XPDA );FPRE^DIF ROMSI(.402 ,"",XPDA); EPRE^DIFRO MSI(.402,D A,$E("N",$ G(XPDNEW)) ,XPDA,"",O LDA);;EPOS T^DIFROMSI (.402,DA," ",XPDA);DE L^DIFROMSK (.402,"",% )
  4652   "ORD",7,.4 02,0)
  4653   INPUT TEMP LATE
  4654   "ORD",15,1 01)
  4655   101;15;;;P RO^XPDTA;P ROF1^XPDIA ;PROE1^XPD IA;PROF2^X PDIA;;PROD EL^XPDIA
  4656   "ORD",15,1 01,0)
  4657   PROTOCOL
  4658   "ORD",17,4 09.61)
  4659   409.61;17; 1;;;;LME1^ XPDIA1;;;L MDEL^XPDIA 1
  4660   "ORD",17,4 09.61,0)
  4661   LIST TEMPL ATE
  4662   "ORD",18,1 9)
  4663   19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
  4664   "ORD",18,1 9,0)
  4665   OPTION
  4666   "PKG",53,- 1)
  4667   1^1
  4668   "PKG",53,0 )
  4669   ACCOUNTS R ECEIVABLE^ PRCA^FMS
  4670   "PKG",53,2 0,0)
  4671   ^9.402P^1^ 1
  4672   "PKG",53,2 0,1,0)
  4673   2^^PRCAMRG
  4674   "PKG",53,2 0,1,1)
  4675  
  4676   "PKG",53,2 0,"B",2,1)
  4677  
  4678   "PKG",53,2 2,0)
  4679   ^9.49I^1^1
  4680   "PKG",53,2 2,1,0)
  4681   4.5^305111 9^2960627
  4682   "PKG",53,2 2,1,"PAH", 1,0)
  4683   315^318011 2
  4684   "PKG",53,2 2,1,"PAH", 1,1,0)
  4685   ^^367^367^ 3171211
  4686   "PKG",53,2 2,1,"PAH", 1,1,1,0)
  4687    
  4688   "PKG",53,2 2,1,"PAH", 1,1,2,0)
  4689   IMPORTANT  INSTALLATI ON NOTE:
  4690   "PKG",53,2 2,1,"PAH", 1,1,3,0)
  4691   ---------- ---------- --------
  4692   "PKG",53,2 2,1,"PAH", 1,1,4,0)
  4693   This patch  is part o f a multi- package bu ild. There  are three  patches 
  4694   "PKG",53,2 2,1,"PAH", 1,1,5,0)
  4695   associated  with the  FY16 HAPE  Revenue En hancement  project -  IB*2.0*568 ,
  4696   "PKG",53,2 2,1,"PAH", 1,1,6,0)
  4697   PRCA*4.5*3 15 and PSO *7.0*463.  All three  patches ar e to be in stalled 
  4698   "PKG",53,2 2,1,"PAH", 1,1,7,0)
  4699   together a s a bundle , IB_2_568 _PRCA_PSO_ BUNDLE_T1. KID
  4700   "PKG",53,2 2,1,"PAH", 1,1,8,0)
  4701    
  4702   "PKG",53,2 2,1,"PAH", 1,1,9,0)
  4703    
  4704   "PKG",53,2 2,1,"PAH", 1,1,10,0)
  4705   Descriptio n
  4706   "PKG",53,2 2,1,"PAH", 1,1,11,0)
  4707   ---------- -
  4708   "PKG",53,2 2,1,"PAH", 1,1,12,0)
  4709   The Chief  Business O ffice (CBO ) is reque sting syst em enhance ments to
  4710   "PKG",53,2 2,1,"PAH", 1,1,13,0)
  4711   The Vetera ns Health  Informatio n Systems  and Techno logy Archi tecture
  4712   "PKG",53,2 2,1,"PAH", 1,1,14,0)
  4713   (VistA) In tegrated B illing (IB ), Account s Receivab le (AR), a nd 
  4714   "PKG",53,2 2,1,"PAH", 1,1,15,0)
  4715   Outpatient  Pharmacy  (PSO) soft ware modul es.  
  4716   "PKG",53,2 2,1,"PAH", 1,1,16,0)
  4717    
  4718   "PKG",53,2 2,1,"PAH", 1,1,17,0)
  4719   The missio n of the D epartment  of Veteran s Affairs  (VA), Offi ce of 
  4720   "PKG",53,2 2,1,"PAH", 1,1,18,0)
  4721   Informatio n & Techno logy (OI&T ), is to p rovide ben efits and  services 
  4722   "PKG",53,2 2,1,"PAH", 1,1,19,0)
  4723   to veteran s of the U nited Stat es Armed F orces. In  meeting th ese goals,  
  4724   "PKG",53,2 2,1,"PAH", 1,1,20,0)
  4725   OIT strive s to provi de high qu ality, eff ective, an d efficien
  4726   "PKG",53,2 2,1,"PAH", 1,1,21,0)
  4727   Informatio n Technolo gy (IT) se rvices to  those resp onsible fo
  4728   "PKG",53,2 2,1,"PAH", 1,1,22,0)
  4729   providing  care to th e veterans  at the po int-of-car e, as well  as 
  4730   "PKG",53,2 2,1,"PAH", 1,1,23,0)
  4731   throughout  all the p oints of t he veteran s' health  care. The  VA depends
  4732   "PKG",53,2 2,1,"PAH", 1,1,24,0)
  4733   on Informa tion Manag ement/Info rmationTec hnology (I M/IT) syst ems to mee t
  4734   "PKG",53,2 2,1,"PAH", 1,1,25,0)
  4735   mission go als.
  4736   "PKG",53,2 2,1,"PAH", 1,1,26,0)
  4737    
  4738   "PKG",53,2 2,1,"PAH", 1,1,27,0)
  4739   The overal l FY16 HAP E Revenue  Enhancemen t project  has been f urther 
  4740   "PKG",53,2 2,1,"PAH", 1,1,28,0)
  4741   divided in to three s ub-project s:
  4742   "PKG",53,2 2,1,"PAH", 1,1,29,0)
  4743    
  4744   "PKG",53,2 2,1,"PAH", 1,1,30,0)
  4745   NSR #20150 506
  4746   "PKG",53,2 2,1,"PAH", 1,1,31,0)
  4747   The Revenu e Eligibil ity Enhanc ements Pro ject effor t for the  Chief 
  4748   "PKG",53,2 2,1,"PAH", 1,1,32,0)
  4749   Business O ffice (CBO ), bundles  several N SRs with s imilar bus iness 
  4750   "PKG",53,2 2,1,"PAH", 1,1,33,0)
  4751   needs into  a single  requiremen ts documen t.  Succes sfully add ressing 
  4752   "PKG",53,2 2,1,"PAH", 1,1,34,0)
  4753   the requir ements con tained wit hin this d ocument wi ll enable  the 
  4754   "PKG",53,2 2,1,"PAH", 1,1,35,0)
  4755   Department  of Vetera ns Affairs  (VA) to a ppropriate ly bill ce rtain 
  4756   "PKG",53,2 2,1,"PAH", 1,1,36,0)
  4757   subsets of  billable  events by  correcting , automati ng, or enh ancing 
  4758   "PKG",53,2 2,1,"PAH", 1,1,37,0)
  4759   current Ve terans Hea lth Inform ation Syst ems and Te chnology A rchitectur e
  4760   "PKG",53,2 2,1,"PAH", 1,1,38,0)
  4761   (VistA) sy stems.
  4762   "PKG",53,2 2,1,"PAH", 1,1,39,0)
  4763    
  4764   "PKG",53,2 2,1,"PAH", 1,1,40,0)
  4765   NSR #20150 507
  4766   "PKG",53,2 2,1,"PAH", 1,1,41,0)
  4767   The Revenu e Operatio ns Enhance ments Proj ect combin es servera l NSRs, 
  4768   "PKG",53,2 2,1,"PAH", 1,1,42,0)
  4769   as well. T his effort  enables t he Departm ent of Vet erans Affa irs (VA) 
  4770   "PKG",53,2 2,1,"PAH", 1,1,43,0)
  4771   to improve  revenue o peration f unctionali ty related  to repaym ent plans,  
  4772   "PKG",53,2 2,1,"PAH", 1,1,44,0)
  4773   late charg e capture,  bill susp ension rea sons, the  billing of  
  4774   "PKG",53,2 2,1,"PAH", 1,1,45,0)
  4775   deactivate d provider s, and the  display o f appeal r ights and 
  4776   "PKG",53,2 2,1,"PAH", 1,1,46,0)
  4777   responsibi lities on  the Vetera ns Benefic iary trave l Bill of  Collection s
  4778   "PKG",53,2 2,1,"PAH", 1,1,47,0)
  4779   form.  Imp lementatio n of the p roposed en hancements  will make  a 
  4780   "PKG",53,2 2,1,"PAH", 1,1,48,0)
  4781   significan t positive  impact on  stakehold ers and ta rget users .
  4782   "PKG",53,2 2,1,"PAH", 1,1,49,0)
  4783    
  4784   "PKG",53,2 2,1,"PAH", 1,1,50,0)
  4785   NSR #20150 505
  4786   "PKG",53,2 2,1,"PAH", 1,1,51,0)
  4787   The Revenu e Reportin g Enhancem ents Proje ct will en able the V A to 
  4788   "PKG",53,2 2,1,"PAH", 1,1,52,0)
  4789   improve tr acking and  reporting  of revenu e, and wil l support  revenue 
  4790   "PKG",53,2 2,1,"PAH", 1,1,53,0)
  4791   reporting  business r ules and g uidelines.
  4792   "PKG",53,2 2,1,"PAH", 1,1,54,0)
  4793    
  4794   "PKG",53,2 2,1,"PAH", 1,1,55,0)
  4795    
  4796   "PKG",53,2 2,1,"PAH", 1,1,56,0)
  4797   PRCA*4.5*3 15 patch e nhancement s, pertine nt to the  above NSRs , include:
  4798   "PKG",53,2 2,1,"PAH", 1,1,57,0)
  4799    
  4800   "PKG",53,2 2,1,"PAH", 1,1,58,0)
  4801   1.) By mea ns of the  new Enter  / Edit Rep ayment Pla n option,  the user 
  4802   "PKG",53,2 2,1,"PAH", 1,1,59,0)
  4803   will creat e the Repa yment Plan  by debtor . Note: Th e 'Enter /  Edit 
  4804   "PKG",53,2 2,1,"PAH", 1,1,60,0)
  4805   Repayment  Plan' menu  option na me will re place the  'Set up Re payment 
  4806   "PKG",53,2 2,1,"PAH", 1,1,61,0)
  4807   Plan' menu  option na me.
  4808   "PKG",53,2 2,1,"PAH", 1,1,62,0)
  4809    
  4810   "PKG",53,2 2,1,"PAH", 1,1,63,0)
  4811   2.) On the  Enter / E dit Repaym ent Plan o ption, if  the AR Deb tor has 
  4812   "PKG",53,2 2,1,"PAH", 1,1,64,0)
  4813   Active bil ls, the sy stem will  now displa y a select able list  of bills 
  4814   "PKG",53,2 2,1,"PAH", 1,1,65,0)
  4815   for the de btor.
  4816   "PKG",53,2 2,1,"PAH", 1,1,66,0)
  4817    
  4818   "PKG",53,2 2,1,"PAH", 1,1,67,0)
  4819   3.) On the  Enter / E dit Repaym ent Plan o ption, whe n displayi ng a list 
  4820   "PKG",53,2 2,1,"PAH", 1,1,68,0)
  4821   of Active  bills for  the Debtor , the syst em will di splay step s to the 
  4822   "PKG",53,2 2,1,"PAH", 1,1,69,0)
  4823   user to se t up the R epayment P lan.
  4824   "PKG",53,2 2,1,"PAH", 1,1,70,0)
  4825    
  4826   "PKG",53,2 2,1,"PAH", 1,1,71,0)
  4827   4.) On the  Enter /Ed it Repayme nt Plan op tion, once  a Repayme nt Plan 
  4828   "PKG",53,2 2,1,"PAH", 1,1,72,0)
  4829   has been c reated or  modified,  the summar y of the R epayment P lan is 
  4830   "PKG",53,2 2,1,"PAH", 1,1,73,0)
  4831   displayed.
  4832   "PKG",53,2 2,1,"PAH", 1,1,74,0)
  4833    
  4834   "PKG",53,2 2,1,"PAH", 1,1,75,0)
  4835   5.) On the  Enter / E dit Repaym ent Plan o ption, the  system ch ecks to 
  4836   "PKG",53,2 2,1,"PAH", 1,1,76,0)
  4837   see if a R epayment P lan has al ready been  created f or the Vet eran.  
  4838   "PKG",53,2 2,1,"PAH", 1,1,77,0)
  4839    
  4840   "PKG",53,2 2,1,"PAH", 1,1,78,0)
  4841   6.) On the  Enter / E dit Repaym ent Plan o ption, whe n choosing  to Edit 
  4842   "PKG",53,2 2,1,"PAH", 1,1,79,0)
  4843   the Repaym ent Plan,  all Active  bills for  the debto r will be  displayed
  4844   "PKG",53,2 2,1,"PAH", 1,1,80,0)
  4845   allowing t he user to  add new A ctive bill s to the R epayment P lan as wel l
  4846   "PKG",53,2 2,1,"PAH", 1,1,81,0)
  4847   as change  the due da te of firs t payment  and/or the  repayment  amount du
  4848   "PKG",53,2 2,1,"PAH", 1,1,82,0)
  4849   on the Rep ayment Pla n. 
  4850   "PKG",53,2 2,1,"PAH", 1,1,83,0)
  4851    
  4852   "PKG",53,2 2,1,"PAH", 1,1,84,0)
  4853   7.) On the  Enter / E dit Repaym ent Plan o ption, if  the Debtor  does not 
  4854   "PKG",53,2 2,1,"PAH", 1,1,85,0)
  4855   have new A ctive bill s that can  be added  to the Rep ayment Pla n, the use
  4856   "PKG",53,2 2,1,"PAH", 1,1,86,0)
  4857   will proce ed to iden tify the r epayment a mount due  and/or rep ayment 
  4858   "PKG",53,2 2,1,"PAH", 1,1,87,0)
  4859   amount due  date on t he Repayme nt Plan.
  4860   "PKG",53,2 2,1,"PAH", 1,1,88,0)
  4861    
  4862   "PKG",53,2 2,1,"PAH", 1,1,89,0)
  4863   8.) On the  Enter / E dit Repaym ent Plan o ption, a d esignated  identifier  
  4864   "PKG",53,2 2,1,"PAH", 1,1,90,0)
  4865   will signi fy when an  Active bi ll is part  of a Repa yment Plan
  4866   "PKG",53,2 2,1,"PAH", 1,1,91,0)
  4867    
  4868   "PKG",53,2 2,1,"PAH", 1,1,92,0)
  4869   9.) On the  Enter / E dit Repaym ent Plan o ption, the  system wi ll display  
  4870   "PKG",53,2 2,1,"PAH", 1,1,93,0)
  4871   previously  made paym ents to th e Repaymen t Plan.
  4872   "PKG",53,2 2,1,"PAH", 1,1,94,0)
  4873    
  4874   "PKG",53,2 2,1,"PAH", 1,1,95,0)
  4875   10.) On th e Enter /  Edit Repay ment Plan  option, th e User has  the optio
  4876   "PKG",53,2 2,1,"PAH", 1,1,96,0)
  4877   to enter D ebtor Comm ents durin g the setu p process.  
  4878   "PKG",53,2 2,1,"PAH", 1,1,97,0)
  4879    
  4880   "PKG",53,2 2,1,"PAH", 1,1,98,0)
  4881   11.) The A R Clerk wi ll be able  to select  Suspended  Type from  the menu 
  4882   "PKG",53,2 2,1,"PAH", 1,1,99,0)
  4883   to display  in the St atus Listi ng For Bil ls [PRCAL  STATUS LIS T] report.
  4884   "PKG",53,2 2,1,"PAH", 1,1,100,0)
  4885    
  4886   "PKG",53,2 2,1,"PAH", 1,1,101,0)
  4887   12.) Statu s Listing  For Bills  [PRCAL STA TUS LIST]  report sha ll be 
  4888   "PKG",53,2 2,1,"PAH", 1,1,102,0)
  4889   modified t o incorpor ate reason  for suspe nsion.
  4890   "PKG",53,2 2,1,"PAH", 1,1,103,0)
  4891    
  4892   "PKG",53,2 2,1,"PAH", 1,1,104,0)
  4893   13.) Provi de the abi lity to lo ck the opt ion to upd ate late p ayment 
  4894   "PKG",53,2 2,1,"PAH", 1,1,105,0)
  4895   charges (I nterest/Ad min/Penalt y Rates [P RCAF U ADM IN.RATE])  with a new
  4896   "PKG",53,2 2,1,"PAH", 1,1,106,0)
  4897   security k ey. 
  4898   "PKG",53,2 2,1,"PAH", 1,1,107,0)
  4899    
  4900   "PKG",53,2 2,1,"PAH", 1,1,108,0)
  4901   14.) The s ystem will  allow the  user to i dentify if  the Bill  of 
  4902   "PKG",53,2 2,1,"PAH", 1,1,109,0)
  4903   Collection s letter a pplies to  Veterans B eneficiary  Travel (F orm 1114).
  4904   "PKG",53,2 2,1,"PAH", 1,1,110,0)
  4905    
  4906   "PKG",53,2 2,1,"PAH", 1,1,111,0)
  4907   15.) The s ystem will  print the  Notice of  Rights an d Responsi bilities 
  4908   "PKG",53,2 2,1,"PAH", 1,1,112,0)
  4909   when the B ill of Col lections p ertains to  Veterans  Beneficiar y Travel.
  4910   "PKG",53,2 2,1,"PAH", 1,1,113,0)
  4911    
  4912   "PKG",53,2 2,1,"PAH", 1,1,114,0)
  4913   16.) VistA  AR Softwa re Package  shall dis continue g eneration  of the 
  4914   "PKG",53,2 2,1,"PAH", 1,1,115,0)
  4915   Mailman me ssage/bull etin, "ARD C Detail R eport for  MON/ YYYY" , without 
  4916   "PKG",53,2 2,1,"PAH", 1,1,116,0)
  4917   interrupti ng any oth er transfe r data wit hin ARDC.
  4918   "PKG",53,2 2,1,"PAH", 1,1,117,0)
  4919    
  4920   "PKG",53,2 2,1,"PAH", 1,1,118,0)
  4921   17.) The V istA AR So ftware Pac kage shall  allow the  generatio n of a 
  4922   "PKG",53,2 2,1,"PAH", 1,1,119,0)
  4923   report of  bills cont aining the  same info rmation as  the disco ntinued 
  4924   "PKG",53,2 2,1,"PAH", 1,1,120,0)
  4925   "ARDC Deta il Report  for MON/YY YY" with t he followi ng excepti ons/ 
  4926   "PKG",53,2 2,1,"PAH", 1,1,121,0)
  4927   additions:
  4928   "PKG",53,2 2,1,"PAH", 1,1,122,0)
  4929           Th e report s hall inclu de current  status bi lls (New B ill, Activ e, 
  4930   "PKG",53,2 2,1,"PAH", 1,1,123,0)
  4931           Re turned for  Amendment , Amended  Bill, Open , and Susp ended bill s) 
  4932   "PKG",53,2 2,1,"PAH", 1,1,124,0)
  4933           on ly;
  4934   "PKG",53,2 2,1,"PAH", 1,1,125,0)
  4935    
  4936   "PKG",53,2 2,1,"PAH", 1,1,126,0)
  4937           Th e report s hall inclu de a colum n for the  Fund numbe r associat ed 
  4938   "PKG",53,2 2,1,"PAH", 1,1,127,0)
  4939           wi th each li ne item on  the repor t; and 
  4940   "PKG",53,2 2,1,"PAH", 1,1,128,0)
  4941    
  4942   "PKG",53,2 2,1,"PAH", 1,1,129,0)
  4943           Th e report s hall inclu de a colum n for the  RSC associ ated with 
  4944   "PKG",53,2 2,1,"PAH", 1,1,130,0)
  4945           ea ch line it em on the  report.
  4946   "PKG",53,2 2,1,"PAH", 1,1,131,0)
  4947    
  4948   "PKG",53,2 2,1,"PAH", 1,1,132,0)
  4949   18.) Curre ntly, when  non-healt hcare debt  of $25 or  greater i s in a 
  4950   "PKG",53,2 2,1,"PAH", 1,1,133,0)
  4951   delinquent  status fo r 180 days , VistA tr ansmits th is debt to  TOP 
  4952   "PKG",53,2 2,1,"PAH", 1,1,134,0)
  4953   (via AITC  and DMC) f or initiat ion of the  standard  collection  process.
  4954   "PKG",53,2 2,1,"PAH", 1,1,135,0)
  4955   To maintai n complian ce with Th e DATA Act  of 2014,  the 180-da y date 
  4956   "PKG",53,2 2,1,"PAH", 1,1,136,0)
  4957   parameter  shall be c hanged to  120 days.
  4958   "PKG",53,2 2,1,"PAH", 1,1,137,0)
  4959    
  4960   "PKG",53,2 2,1,"PAH", 1,1,138,0)
  4961   19.)  A ne w audit tr ail is nee ded for de tailing ev ents or tr ansactions  
  4962   "PKG",53,2 2,1,"PAH", 1,1,139,0)
  4963   that have  occurred o n healthca re debts r eferred fo r debt col lection, t
  4964   "PKG",53,2 2,1,"PAH", 1,1,140,0)
  4965   effectivel y support  Veterans a nd reconci le account s.
  4966   "PKG",53,2 2,1,"PAH", 1,1,141,0)
  4967    
  4968   "PKG",53,2 2,1,"PAH", 1,1,142,0)
  4969   20.)  Vist A shall pr ovide enha nced repor ting capab ility, usa bility 
  4970   "PKG",53,2 2,1,"PAH", 1,1,143,0)
  4971   features,  and additi onal data  elements f or managin g healthca re debts 
  4972   "PKG",53,2 2,1,"PAH", 1,1,144,0)
  4973   referred f or debt co llection t o improve  VHA's abil ity to pro vide suppo rt 
  4974   "PKG",53,2 2,1,"PAH", 1,1,145,0)
  4975   to Veteran s and mana ge account s.
  4976   "PKG",53,2 2,1,"PAH", 1,1,146,0)
  4977    
  4978   "PKG",53,2 2,1,"PAH", 1,1,147,0)
  4979   21.)  Crea te report  to track s top/reacti vate debts . VistA sh all provid
  4980   "PKG",53,2 2,1,"PAH", 1,1,148,0)
  4981   a Stop/Rea ctivate re port to id entify hea lthcare de bts that a re placed 
  4982   "PKG",53,2 2,1,"PAH", 1,1,149,0)
  4983   in the cor responding  status.
  4984   "PKG",53,2 2,1,"PAH", 1,1,150,0)
  4985    
  4986   "PKG",53,2 2,1,"PAH", 1,1,151,0)
  4987   22.)  Impr ove automa tion in ma nagement o f debt col lection. V istA shall  
  4988   "PKG",53,2 2,1,"PAH", 1,1,152,0)
  4989   utilize ex isting fun ctionality , such as  List Manag er, and ot her 
  4990   "PKG",53,2 2,1,"PAH", 1,1,153,0)
  4991   automation  capabilit ies to imp rove debt  collection  managemen t"
  4992   "PKG",53,2 2,1,"PAH", 1,1,154,0)
  4993    
  4994   "PKG",53,2 2,1,"PAH", 1,1,155,0)
  4995   23.)  The  existing M edication  Co-Pay Exe mption Rep ort [PRCAX  CO-PAY 
  4996   "PKG",53,2 2,1,"PAH", 1,1,156,0)
  4997   EXEMPTION  REPORT] sh all be mod ified with  the follo wing field  changes:
  4998   "PKG",53,2 2,1,"PAH", 1,1,157,0)
  4999           Ch ange PT ID  from full  Social Se curity Num ber (SSN)  to LastN +  
  5000   "PKG",53,2 2,1,"PAH", 1,1,158,0)
  5001                 4SSN
  5002   "PKG",53,2 2,1,"PAH", 1,1,159,0)
  5003           Ad d Rx#
  5004   "PKG",53,2 2,1,"PAH", 1,1,160,0)
  5005           Ad d Drug Nam e (first 1 0 to 12 ch aracters)
  5006   "PKG",53,2 2,1,"PAH", 1,1,161,0)
  5007           Ad d Fill/Ref ill Date
  5008   "PKG",53,2 2,1,"PAH", 1,1,162,0)
  5009           Ad d Effectiv e Date of  Exemption
  5010   "PKG",53,2 2,1,"PAH", 1,1,163,0)
  5011    
  5012   "PKG",53,2 2,1,"PAH", 1,1,164,0)
  5013   24.)  A ne w Third Pa rty Accoun ts Receiva ble catego ry called 
  5014   "PKG",53,2 2,1,"PAH", 1,1,165,0)
  5015   'EMERGENCY /HUMANITAR IAN REIMB. ' shall be  created i n Accounts  Receivabl es 
  5016   "PKG",53,2 2,1,"PAH", 1,1,166,0)
  5017   with the i nsurer as  the respon sible part y. 
  5018   "PKG",53,2 2,1,"PAH", 1,1,167,0)
  5019    
  5020   "PKG",53,2 2,1,"PAH", 1,1,168,0)
  5021   25.) A new  Third Par ty Account s Receivab le categor y called ' INELIGIBLE  
  5022   "PKG",53,2 2,1,"PAH", 1,1,169,0)
  5023   HOSP. REIM B' shall b e created  in Account s Receivab les with t he insurer  
  5024   "PKG",53,2 2,1,"PAH", 1,1,170,0)
  5025   as the res ponsible p arty. 
  5026   "PKG",53,2 2,1,"PAH", 1,1,171,0)
  5027    
  5028   "PKG",53,2 2,1,"PAH", 1,1,172,0)
  5029   26.) A one -character  "Type" fi eld shall  be added t o the Clai ms Matchin
  5030   "PKG",53,2 2,1,"PAH", 1,1,173,0)
  5031   Report tha t will ind icate the  third-part y claim ca re-type (" I" for 
  5032   "PKG",53,2 2,1,"PAH", 1,1,174,0)
  5033   Inpatient,  "O" for O utpatient,  "P" for P rosthetics , and "R"  for 
  5034   "PKG",53,2 2,1,"PAH", 1,1,175,0)
  5035   Prescripti on
  5036   "PKG",53,2 2,1,"PAH", 1,1,176,0)
  5037   [Rx]) on t he report  of third-p arty bills .
  5038   "PKG",53,2 2,1,"PAH", 1,1,177,0)
  5039    
  5040   "PKG",53,2 2,1,"PAH", 1,1,178,0)
  5041   27.) When  a user gen erates a C laims Matc hing Repor t for a pa tient, all  
  5042   "PKG",53,2 2,1,"PAH", 1,1,179,0)
  5043   records fo r that pat ient are c urrently p roduced on  the repor t. At 
  5044   "PKG",53,2 2,1,"PAH", 1,1,180,0)
  5045   times, use rs need to  generate  informatio n regardin g only cer tain types  
  5046   "PKG",53,2 2,1,"PAH", 1,1,181,0)
  5047   of care fo r a patien t.  The sy stem shall  allow the  user to c hoose 
  5048   "PKG",53,2 2,1,"PAH", 1,1,182,0)
  5049   between pr oducing a  Claims Mat ching Repo rt contain ing (1) al l records 
  5050   "PKG",53,2 2,1,"PAH", 1,1,183,0)
  5051   for a pati ent, or (2 ) only rec ords of a  certain ca re type (" I" for 
  5052   "PKG",53,2 2,1,"PAH", 1,1,184,0)
  5053   Inpatient,  "O" for O utpatient,  "P" for P rosthetics , or "R" f or 
  5054   "PKG",53,2 2,1,"PAH", 1,1,185,0)
  5055   Prescripti on [Rx]).
  5056   "PKG",53,2 2,1,"PAH", 1,1,186,0)
  5057    
  5058   "PKG",53,2 2,1,"PAH", 1,1,187,0)
  5059   28.) The C laims Matc hing Repor t, when ex ported, sh all be in  a line 
  5060   "PKG",53,2 2,1,"PAH", 1,1,188,0)
  5061   format so  that infor mation on  the report  may be ea sily expor ted to 
  5062   "PKG",53,2 2,1,"PAH", 1,1,189,0)
  5063   Microsoft  Excel.
  5064   "PKG",53,2 2,1,"PAH", 1,1,190,0)
  5065    
  5066   "PKG",53,2 2,1,"PAH", 1,1,191,0)
  5067    
  5068   "PKG",53,2 2,1,"PAH", 1,1,192,0)
  5069    
  5070   "PKG",53,2 2,1,"PAH", 1,1,193,0)
  5071   Concurrent  Developme nt / Depen dencies:
  5072   "PKG",53,2 2,1,"PAH", 1,1,194,0)
  5073   ---------- ---------- ---------- --------
  5074   "PKG",53,2 2,1,"PAH", 1,1,195,0)
  5075   N/A
  5076   "PKG",53,2 2,1,"PAH", 1,1,196,0)
  5077    
  5078   "PKG",53,2 2,1,"PAH", 1,1,197,0)
  5079    
  5080   "PKG",53,2 2,1,"PAH", 1,1,198,0)
  5081   Patch Comp onents:
  5082   "PKG",53,2 2,1,"PAH", 1,1,199,0)
  5083   ---------- -------
  5084   "PKG",53,2 2,1,"PAH", 1,1,200,0)
  5085    
  5086   "PKG",53,2 2,1,"PAH", 1,1,201,0)
  5087   Files & Fi elds Assoc iated:
  5088   "PKG",53,2 2,1,"PAH", 1,1,202,0)
  5089    
  5090   "PKG",53,2 2,1,"PAH", 1,1,203,0)
  5091   File Name  (Number)     Field Na me (Number )     New/ Modified/D eleted
  5092   "PKG",53,2 2,1,"PAH", 1,1,204,0)
  5093   ---------- --------     -------- ---------- -     ---- ---------- ------
  5094   "PKG",53,2 2,1,"PAH", 1,1,205,0)
  5095   N/A
  5096   "PKG",53,2 2,1,"PAH", 1,1,206,0)
  5097    
  5098   "PKG",53,2 2,1,"PAH", 1,1,207,0)
  5099   Options As sociated:
  5100   "PKG",53,2 2,1,"PAH", 1,1,208,0)
  5101    
  5102   "PKG",53,2 2,1,"PAH", 1,1,209,0)
  5103   Option Nam e                       Type           New/ Modified/D eleted
  5104   "PKG",53,2 2,1,"PAH", 1,1,210,0)
  5105   ---------- -                       ----           ---- ---------- ------
  5106   "PKG",53,2 2,1,"PAH", 1,1,211,0)
  5107   PRCA ARDC  REPORT                  ROUTINE        NEW
  5108   "PKG",53,2 2,1,"PAH", 1,1,212,0)
  5109    
  5110   "PKG",53,2 2,1,"PAH", 1,1,213,0)
  5111   Protocols  Associated :
  5112   "PKG",53,2 2,1,"PAH", 1,1,214,0)
  5113    
  5114   "PKG",53,2 2,1,"PAH", 1,1,215,0)
  5115   Protocol N ame                                     New /Modified/ Deleted
  5116   "PKG",53,2 2,1,"PAH", 1,1,216,0)
  5117   ---------- ---                                     --- ---------- -------
  5118   "PKG",53,2 2,1,"PAH", 1,1,217,0)
  5119   N/A
  5120   "PKG",53,2 2,1,"PAH", 1,1,218,0)
  5121    
  5122   "PKG",53,2 2,1,"PAH", 1,1,219,0)
  5123   Templates  Associated :
  5124   "PKG",53,2 2,1,"PAH", 1,1,220,0)
  5125    
  5126   "PKG",53,2 2,1,"PAH", 1,1,221,0)
  5127   Template N ame                 T ype   File  Name (Num ber)       New/Mod/De l
  5128   "PKG",53,2 2,1,"PAH", 1,1,222,0)
  5129   ---------- ---                 - ---   ---- ---------- ----       ---------- -
  5130   "PKG",53,2 2,1,"PAH", 1,1,223,0)
  5131   N/A
  5132   "PKG",53,2 2,1,"PAH", 1,1,224,0)
  5133    
  5134   "PKG",53,2 2,1,"PAH", 1,1,225,0)
  5135   New Servic e Requests  (NSRs):
  5136   "PKG",53,2 2,1,"PAH", 1,1,226,0)
  5137   ---------- ---------- --------
  5138   "PKG",53,2 2,1,"PAH", 1,1,227,0)
  5139   20150505 -  Revenue R eporting E nhancement s
  5140   "PKG",53,2 2,1,"PAH", 1,1,228,0)
  5141   20150506 -  Revenue E ligibility  Enhanceme nts
  5142   "PKG",53,2 2,1,"PAH", 1,1,229,0)
  5143   20150507 -  Revenue O perations  Enhancemen ts
  5144   "PKG",53,2 2,1,"PAH", 1,1,230,0)
  5145    
  5146   "PKG",53,2 2,1,"PAH", 1,1,231,0)
  5147    
  5148   "PKG",53,2 2,1,"PAH", 1,1,232,0)
  5149   Patient Sa fety Issue s (PSIs):
  5150   "PKG",53,2 2,1,"PAH", 1,1,233,0)
  5151   ---------- ---------- ----------
  5152   "PKG",53,2 2,1,"PAH", 1,1,234,0)
  5153   N/A
  5154   "PKG",53,2 2,1,"PAH", 1,1,235,0)
  5155    
  5156   "PKG",53,2 2,1,"PAH", 1,1,236,0)
  5157    
  5158   "PKG",53,2 2,1,"PAH", 1,1,237,0)
  5159   Remedy Tic ket(s) & O verviews:
  5160   "PKG",53,2 2,1,"PAH", 1,1,238,0)
  5161   ---------- ---------- ---------
  5162   "PKG",53,2 2,1,"PAH", 1,1,239,0)
  5163   N/A 
  5164   "PKG",53,2 2,1,"PAH", 1,1,240,0)
  5165    
  5166   "PKG",53,2 2,1,"PAH", 1,1,241,0)
  5167   Test Sites :
  5168   "PKG",53,2 2,1,"PAH", 1,1,242,0)
  5169   ----------
  5170   "PKG",53,2 2,1,"PAH", 1,1,243,0)
  5171   Durham VAM C
  5172   "PKG",53,2 2,1,"PAH", 1,1,244,0)
  5173    
  5174   "PKG",53,2 2,1,"PAH", 1,1,245,0)
  5175    
  5176   "PKG",53,2 2,1,"PAH", 1,1,246,0)
  5177   Software a nd Documen tation Ret rieval Ins tructions:
  5178   "PKG",53,2 2,1,"PAH", 1,1,247,0)
  5179   ---------- ---------- ---------- ---------- ---------- --
  5180   "PKG",53,2 2,1,"PAH", 1,1,248,0)
  5181   Patches fo r this ins tallation  are combin ed in host  file 
  5182   "PKG",53,2 2,1,"PAH", 1,1,249,0)
  5183   IB_2_568_P RCA_PSO_BU NDLE_T1.KI D
  5184   "PKG",53,2 2,1,"PAH", 1,1,250,0)
  5185    
  5186   "PKG",53,2 2,1,"PAH", 1,1,251,0)
  5187   Installati on of this  host file  should be  coordinat ed among t he package
  5188   "PKG",53,2 2,1,"PAH", 1,1,252,0)
  5189   affected s ince only  one instal lation is  necessary.
  5190   "PKG",53,2 2,1,"PAH", 1,1,253,0)
  5191    
  5192   "PKG",53,2 2,1,"PAH", 1,1,254,0)
  5193   The patche s are:
  5194   "PKG",53,2 2,1,"PAH", 1,1,255,0)
  5195    
  5196   "PKG",53,2 2,1,"PAH", 1,1,256,0)
  5197        IB*2. 0*568
  5198   "PKG",53,2 2,1,"PAH", 1,1,257,0)
  5199        PRCA* 4.5*315
  5200   "PKG",53,2 2,1,"PAH", 1,1,258,0)
  5201        PSO*7 .0*463
  5202   "PKG",53,2 2,1,"PAH", 1,1,259,0)
  5203        
  5204   "PKG",53,2 2,1,"PAH", 1,1,260,0)
  5205    
  5206   "PKG",53,2 2,1,"PAH", 1,1,261,0)
  5207   Sites may  retrieve t he KIDS bu ild in one  of the fo llowing wa ys:
  5208   "PKG",53,2 2,1,"PAH", 1,1,262,0)
  5209    
  5210   "PKG",53,2 2,1,"PAH", 1,1,263,0)
  5211   (1) The pr eferred me thod is to  FTP the f iles from 
  5212   "PKG",53,2 2,1,"PAH", 1,1,264,0)
  5213   URL
  5214   "PKG",53,2 2,1,"PAH", 1,1,265,0)
  5215   which will  transmit  the files  from the f irst avail able FTP s erver.
  5216   "PKG",53,2 2,1,"PAH", 1,1,266,0)
  5217    
  5218   "PKG",53,2 2,1,"PAH", 1,1,267,0)
  5219   (2) Sites  may also e lect to re trieve the  patch dir ectly from  a specifi c
  5220   "PKG",53,2 2,1,"PAH", 1,1,268,0)
  5221   server as  follows:
  5222   "PKG",53,2 2,1,"PAH", 1,1,269,0)
  5223    
  5224   "PKG",53,2 2,1,"PAH", 1,1,270,0)
  5225     OIFO                 FTP ADDRE SS                    DIRECTORY
  5226   "PKG",53,2 2,1,"PAH", 1,1,271,0)
  5227     -------- ------      --------- ---------- -----      ---------- --------
  5228   "PKG",53,2 2,1,"PAH", 1,1,272,0)
  5229       Albany                URL                anonymous. software
  5230   "PKG",53,2 2,1,"PAH", 1,1,273,0)
  5231       Hines                 URL                 anonymous. software
  5232   "PKG",53,2 2,1,"PAH", 1,1,274,0)
  5233       Salt Lake  City       URL                   anonymous. software
  5234   "PKG",53,2 2,1,"PAH", 1,1,275,0)
  5235    
  5236   "PKG",53,2 2,1,"PAH", 1,1,276,0)
  5237    
  5238   "PKG",53,2 2,1,"PAH", 1,1,277,0)
  5239   Sites may  retrieve d ocumentati on directl y using Se cure File  Transfer 
  5240   "PKG",53,2 2,1,"PAH", 1,1,278,0)
  5241   Protocol ( SFTP) from  the ANONY MOUS.SOFTW ARE direct ory at the  following
  5242   "PKG",53,2 2,1,"PAH", 1,1,279,0)
  5243   OI Field O ffices:
  5244   "PKG",53,2 2,1,"PAH", 1,1,280,0)
  5245    
  5246   "PKG",53,2 2,1,"PAH", 1,1,281,0)
  5247   Albany:            URL        
  5248   "PKG",53,2 2,1,"PAH", 1,1,282,0)
  5249   Hines:             URL        
  5250   "PKG",53,2 2,1,"PAH", 1,1,283,0)
  5251   Salt Lake  City:    URL        
  5252   "PKG",53,2 2,1,"PAH", 1,1,284,0)
  5253    
  5254   "PKG",53,2 2,1,"PAH", 1,1,285,0)
  5255   Documentat ion can al so be foun d on the V A Software  Documenta tion 
  5256   "PKG",53,2 2,1,"PAH", 1,1,286,0)
  5257   Library at :
  5258   "PKG",53,2 2,1,"PAH", 1,1,287,0)
  5259   http:// URL              /
  5260   "PKG",53,2 2,1,"PAH", 1,1,288,0)
  5261    
  5262   "PKG",53,2 2,1,"PAH", 1,1,289,0)
  5263   Title                                          File Na me            FTP Mod e
  5264   "PKG",53,2 2,1,"PAH", 1,1,290,0)
  5265   ---------- ---------- ---------- ---------- ---------- ---------- ---------- -
  5266   "PKG",53,2 2,1,"PAH", 1,1,291,0)
  5267   Accounts R eceivable  Technical  Manual/Sec urity Guid
  5268   "PKG",53,2 2,1,"PAH", 1,1,292,0)
  5269                                                  prca_4_ 5_tm+r0515 .doc Binar y
  5270   "PKG",53,2 2,1,"PAH", 1,1,293,0)
  5271   Accounts R eceivable  Deployment , Installa tion, 
  5272   "PKG",53,2 2,1,"PAH", 1,1,294,0)
  5273        Back- Out, and R ollback Gu ide   
  5274   "PKG",53,2 2,1,"PAH", 1,1,295,0)
  5275                  FY16Re venueARVIP _Deploymen t_Installa tion_Guide .doc Binar
  5276   "PKG",53,2 2,1,"PAH", 1,1,296,0)
  5277    
  5278   "PKG",53,2 2,1,"PAH", 1,1,297,0)
  5279    
  5280   "PKG",53,2 2,1,"PAH", 1,1,298,0)
  5281    
  5282   "PKG",53,2 2,1,"PAH", 1,1,299,0)
  5283   Patch Inst allation:
  5284   "PKG",53,2 2,1,"PAH", 1,1,300,0)
  5285    
  5286   "PKG",53,2 2,1,"PAH", 1,1,301,0)
  5287   Pre/Post I nstallatio n Overview :
  5288   "PKG",53,2 2,1,"PAH", 1,1,302,0)
  5289   ---------- ---------- ---------- -
  5290   "PKG",53,2 2,1,"PAH", 1,1,303,0)
  5291   The post i nstallatio n routine,  PRCA315P,  is not au tomaticall y deleted
  5292   "PKG",53,2 2,1,"PAH", 1,1,304,0)
  5293   as part of  the insta llation pr ocess. You  may delet e it after
  5294   "PKG",53,2 2,1,"PAH", 1,1,305,0)
  5295   installati on if you  desire.
  5296   "PKG",53,2 2,1,"PAH", 1,1,306,0)
  5297    
  5298   "PKG",53,2 2,1,"PAH", 1,1,307,0)
  5299   Pre-Instal lation Ins tructions:
  5300   "PKG",53,2 2,1,"PAH", 1,1,308,0)
  5301   ---------- ---------- ----------
  5302   "PKG",53,2 2,1,"PAH", 1,1,309,0)
  5303   N/A
  5304   "PKG",53,2 2,1,"PAH", 1,1,310,0)
  5305    
  5306   "PKG",53,2 2,1,"PAH", 1,1,311,0)
  5307   Installati on Instruc tions:
  5308   "PKG",53,2 2,1,"PAH", 1,1,312,0)
  5309   ---------- ---------- ------
  5310   "PKG",53,2 2,1,"PAH", 1,1,313,0)
  5311   This proce ss will in stall new  and update d routines  and other  
  5312   "PKG",53,2 2,1,"PAH", 1,1,314,0)
  5313   components  listed ab ove. There  is a post -install r outine tha t will add  
  5314   "PKG",53,2 2,1,"PAH", 1,1,315,0)
  5315   entries to  a number  of files.
  5316   "PKG",53,2 2,1,"PAH", 1,1,316,0)
  5317    
  5318   "PKG",53,2 2,1,"PAH", 1,1,317,0)
  5319   The patch  will be re leased in  conjunctio n with an  Integrated  Billing
  5320   "PKG",53,2 2,1,"PAH", 1,1,318,0)
  5321   patch, IB* 4.5*568, a nd an Outp atient Pha rmacy patc h, PSO*7.0 *463.
  5322   "PKG",53,2 2,1,"PAH", 1,1,319,0)
  5323    
  5324   "PKG",53,2 2,1,"PAH", 1,1,320,0)
  5325     ******** ********** ****** NOT E ******** ********** ******
  5326   "PKG",53,2 2,1,"PAH", 1,1,321,0)
  5327     IF A USE R IS ON TH E SYSTEM A ND USING T HESE PROGR AMS 
  5328   "PKG",53,2 2,1,"PAH", 1,1,322,0)
  5329     AN EDITE D ERROR WI LL OCCUR.   
  5330   "PKG",53,2 2,1,"PAH", 1,1,323,0)
  5331     The patc h should b e installe d when NO  Outpatient  
  5332   "PKG",53,2 2,1,"PAH", 1,1,324,0)
  5333     Pharmacy  users are  on the sy stem.
  5334   "PKG",53,2 2,1,"PAH", 1,1,325,0)
  5335     ******** ********** ********** ********** ********** ******
  5336   "PKG",53,2 2,1,"PAH", 1,1,326,0)
  5337    
  5338   "PKG",53,2 2,1,"PAH", 1,1,327,0)
  5339    Installat ion will t ake less t han 1 minu te.
  5340   "PKG",53,2 2,1,"PAH", 1,1,328,0)
  5341    
  5342   "PKG",53,2 2,1,"PAH", 1,1,329,0)
  5343    Suggested  time to i nstall: no n-peak req uirement h ours.
  5344   "PKG",53,2 2,1,"PAH", 1,1,330,0)
  5345    
  5346   "PKG",53,2 2,1,"PAH", 1,1,331,0)
  5347    
  5348   "PKG",53,2 2,1,"PAH", 1,1,332,0)
  5349     1. Obtai n the file  IB_2_568_ PRCA_PSO_B UNDLE_T1.K ID
  5350   "PKG",53,2 2,1,"PAH", 1,1,333,0)
  5351       
  5352   "PKG",53,2 2,1,"PAH", 1,1,334,0)
  5353     2. From  the Kernel  Installat ion & Dist ribution S ystem menu , select
  5354   "PKG",53,2 2,1,"PAH", 1,1,335,0)
  5355        the I nstallatio n menu.
  5356   "PKG",53,2 2,1,"PAH", 1,1,336,0)
  5357     
  5358   "PKG",53,2 2,1,"PAH", 1,1,337,0)
  5359     3. Use L oad a Dist ribution u sing IB_2_ 568_PRCA_P SO_BUNDLE_ T1.KID whe n
  5360   "PKG",53,2 2,1,"PAH", 1,1,338,0)
  5361        promp ted to Ent er a Host  File name.   You may  need to ap pend a
  5362   "PKG",53,2 2,1,"PAH", 1,1,339,0)
  5363        direc tory name.
  5364   "PKG",53,2 2,1,"PAH", 1,1,340,0)
  5365     
  5366   "PKG",53,2 2,1,"PAH", 1,1,341,0)
  5367     4. From  this menu,  you may s elect to u se the fol lowing opt ions
  5368   "PKG",53,2 2,1,"PAH", 1,1,342,0)
  5369        (when  prompted  for INSTAL L NAME, en ter IB*2.0 *568):
  5370   "PKG",53,2 2,1,"PAH", 1,1,343,0)
  5371            a .  Verify  Checksums  in Transpo rt Global  - This opt ion will 
  5372   "PKG",53,2 2,1,"PAH", 1,1,344,0)
  5373                 allow y ou to ensu re the int egrity of  the routin es that ar
  5374   "PKG",53,2 2,1,"PAH", 1,1,345,0)
  5375                 in the  transport  global.
  5376   "PKG",53,2 2,1,"PAH", 1,1,346,0)
  5377            b .  Print T ransport G lobal - Th is option  will allow  you to 
  5378   "PKG",53,2 2,1,"PAH", 1,1,347,0)
  5379                 view th e componen ts of the  KIDS build .
  5380   "PKG",53,2 2,1,"PAH", 1,1,348,0)
  5381            c .  Compare  Transport  Global to  Current S ystem - Th is option 
  5382   "PKG",53,2 2,1,"PAH", 1,1,349,0)
  5383                 will al low you to  view all  changes th at will be  made when  
  5384   "PKG",53,2 2,1,"PAH", 1,1,350,0)
  5385                 this pa tch is ins talled.  I t compares  all compo nents of 
  5386   "PKG",53,2 2,1,"PAH", 1,1,351,0)
  5387                 this pa tch (routi nes, DD's,  templates , etc.).
  5388   "PKG",53,2 2,1,"PAH", 1,1,352,0)
  5389            d .  Backup  a Transpor t Global -  This opti on will cr eate a 
  5390   "PKG",53,2 2,1,"PAH", 1,1,353,0)
  5391                 backup  message of  any routi nes export ed with th is patch. 
  5392   "PKG",53,2 2,1,"PAH", 1,1,354,0)
  5393                 It will  not backu p any othe r changes  such as DD 's or 
  5394   "PKG",53,2 2,1,"PAH", 1,1,355,0)
  5395                 templat es.
  5396   "PKG",53,2 2,1,"PAH", 1,1,356,0)
  5397      
  5398   "PKG",53,2 2,1,"PAH", 1,1,357,0)
  5399     5. When  prompted " Want KIDS  to INHIBIT  LOGONs du ring the i nstall? 
  5400   "PKG",53,2 2,1,"PAH", 1,1,358,0)
  5401        NO//"  respond N O.
  5402   "PKG",53,2 2,1,"PAH", 1,1,359,0)
  5403      
  5404   "PKG",53,2 2,1,"PAH", 1,1,360,0)
  5405     6. When  prompted " Want to DI SABLE Sche duled Opti ons, Menu  Options, 
  5406   "PKG",53,2 2,1,"PAH", 1,1,361,0)
  5407        and P rotocols?  NO//" resp ond NO. 
  5408   "PKG",53,2 2,1,"PAH", 1,1,362,0)
  5409    
  5410   "PKG",53,2 2,1,"PAH", 1,1,363,0)
  5411    
  5412   "PKG",53,2 2,1,"PAH", 1,1,364,0)
  5413    
  5414   "PKG",53,2 2,1,"PAH", 1,1,365,0)
  5415   Post-Insta llation In structions :
  5416   "PKG",53,2 2,1,"PAH", 1,1,366,0)
  5417   ---------- ---------- ---------- -
  5418   "PKG",53,2 2,1,"PAH", 1,1,367,0)
  5419   There are  no special  tasks to  perform af ter this p atch insta llation.
  5420   "QUES","XP F1",0)
  5421   Y
  5422   "QUES","XP F1","??")
  5423   ^D REP^XPD H
  5424   "QUES","XP F1","A")
  5425   Shall I wr ite over y our |FLAG|  File
  5426   "QUES","XP F1","B")
  5427   YES
  5428   "QUES","XP F1","M")
  5429   D XPF1^XPD IQ
  5430   "QUES","XP F2",0)
  5431   Y
  5432   "QUES","XP F2","??")
  5433   ^D DTA^XPD H
  5434   "QUES","XP F2","A")
  5435   Want my da ta |FLAG|  yours
  5436   "QUES","XP F2","B")
  5437   YES
  5438   "QUES","XP F2","M")
  5439   D XPF2^XPD IQ
  5440   "QUES","XP I1",0)
  5441   YO
  5442   "QUES","XP I1","??")
  5443   ^D INHIBIT ^XPDH
  5444   "QUES","XP I1","A")
  5445   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  5446   "QUES","XP I1","B")
  5447   NO
  5448   "QUES","XP I1","M")
  5449   D XPI1^XPD IQ
  5450   "QUES","XP M1",0)
  5451   PO^VA(200, :EM
  5452   "QUES","XP M1","??")
  5453   ^D MG^XPDH
  5454   "QUES","XP M1","A")
  5455   Enter the  Coordinato r for Mail  Group '|F LAG|'
  5456   "QUES","XP M1","B")
  5457  
  5458   "QUES","XP M1","M")
  5459   D XPM1^XPD IQ
  5460   "QUES","XP O1",0)
  5461   Y
  5462   "QUES","XP O1","??")
  5463   ^D MENU^XP DH
  5464   "QUES","XP O1","A")
  5465   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  5466   "QUES","XP O1","B")
  5467   YES
  5468   "QUES","XP O1","M")
  5469   D XPO1^XPD IQ
  5470   "QUES","XP Z1",0)
  5471   Y
  5472   "QUES","XP Z1","??")
  5473   ^D OPT^XPD H
  5474   "QUES","XP Z1","A")
  5475   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  5476   "QUES","XP Z1","B")
  5477   NO
  5478   "QUES","XP Z1","M")
  5479   D XPZ1^XPD IQ
  5480   "QUES","XP Z2",0)
  5481   Y
  5482   "QUES","XP Z2","??")
  5483   ^D RTN^XPD H
  5484   "QUES","XP Z2","A")
  5485   Want to MO VE routine s to other  CPUs
  5486   "QUES","XP Z2","B")
  5487   NO
  5488   "QUES","XP Z2","M")
  5489   D XPZ2^XPD IQ
  5490   "RTN")
  5491   58
  5492   "RTN","PRC A315P")
  5493   0^^B499457 80^n/a
  5494   "RTN","PRC A315P",1,0 )
  5495   PRCA315P ; SLT/BAA-PR CA*4.5*315  POST INST ALL ;1 Mar  97
  5496   "RTN","PRC A315P",2,0 )
  5497    ;;4.5;Acc ounts Rece ivable;**3 15**;Mar 2 0, 1995;Bu ild 55
  5498   "RTN","PRC A315P",3,0 )
  5499    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  5500   "RTN","PRC A315P",4,0 )
  5501   POSTINIT ;
  5502   "RTN","PRC A315P",5,0 )
  5503    ;
  5504   "RTN","PRC A315P",6,0 )
  5505    D BMES^XP DUTL(" >>   Starting  the Post-I nitializat ion routin e ...")
  5506   "RTN","PRC A315P",7,0 )
  5507    D MES^XPD UTL(" ")
  5508   "RTN","PRC A315P",8,0 )
  5509    ; AR CATE GORIES
  5510   "RTN","PRC A315P",9,0 )
  5511    D ARCAT
  5512   "RTN","PRC A315P",10, 0)
  5513    D REVSC
  5514   "RTN","PRC A315P",11, 0)
  5515    D DELOPT
  5516   "RTN","PRC A315P",12, 0)
  5517    D CRSSVC
  5518   "RTN","PRC A315P",13, 0)
  5519    D CSJOB
  5520   "RTN","PRC A315P",14, 0)
  5521    D MES^XPD UTL(" >>   End of the  Post-Init ialization  routine . ..")
  5522   "RTN","PRC A315P",15, 0)
  5523    Q
  5524   "RTN","PRC A315P",16, 0)
  5525    ;
  5526   "RTN","PRC A315P",17, 0)
  5527    ;
  5528   "RTN","PRC A315P",18, 0)
  5529   ARCAT ;AR  CATEGORY E NTRIES (43 0.2)
  5530   "RTN","PRC A315P",19, 0)
  5531    N %,ARNAM E,D,D0,DA, DI,DIC,DIE ,DIK,DINUM ,DLAYGO,DQ ,DR,RCDATA ,RCDINUM,X ,Y,FLG,RCS
  5532   "RTN","PRC A315P",20, 0)
  5533    D MES^XPD UTL("      -> Adding  new AR Cat egory entr ies to fil e 430.2 .. .")
  5534   "RTN","PRC A315P",21, 0)
  5535    ;
  5536   "RTN","PRC A315P",22, 0)
  5537    ;  instal l entries  in file 43 0.2
  5538   "RTN","PRC A315P",23, 0)
  5539    S FLG=0
  5540   "RTN","PRC A315P",24, 0)
  5541    F RCDINUM =46,47 D
  5542   "RTN","PRC A315P",25, 0)
  5543    . S RCS=" CT"_RCDINU M
  5544   "RTN","PRC A315P",26, 0)
  5545    . S RCDAT A=$P($T(@R CS),";",3, 99)
  5546   "RTN","PRC A315P",27, 0)
  5547    . S (DIC, DIE)="^PRC A(430.2,", DIC(0)="L" ,DLAYGO=43 0.2
  5548   "RTN","PRC A315P",28, 0)
  5549    . ;
  5550   "RTN","PRC A315P",29, 0)
  5551    . S ARNAM E=$P(RCDAT A,";")
  5552   "RTN","PRC A315P",30, 0)
  5553    . ;
  5554   "RTN","PRC A315P",31, 0)
  5555    . I $D(^P RCA(430.2, RCDINUM,0) ) S DIK="^ PRCA(430.2 ,",DA=RCDI NUM D ^DIK
  5556   "RTN","PRC A315P",32, 0)
  5557    . ;
  5558   "RTN","PRC A315P",33, 0)
  5559    . S (DIC, DIE)="^PRC A(430.2,", DIC(0)="L" ,DLAYGO=43 0.2
  5560   "RTN","PRC A315P",34, 0)
  5561    . ;
  5562   "RTN","PRC A315P",35, 0)
  5563    . ;  set  the fields
  5564   "RTN","PRC A315P",36, 0)
  5565    . S (DINU M,DA)=RCDI NUM,X=ARNA ME
  5566   "RTN","PRC A315P",37, 0)
  5567    . S DIC(" DR")="1/// "_$P(RCDAT A,";",2)_" ;2///"_$P( RCDATA,";" ,3)_";3/// "_$P(RCDAT A,";",6)_" ;5///"_$P( RCDATA,";" ,5)_";6/// "_$P(RCDAT A,";",4)
  5568   "RTN","PRC A315P",38, 0)
  5569    . S DIC(" DR")=DIC(" DR")_";7// /2;9///0;1 0///0;11// /0;12///"_ $P(RCDATA, ";",7)_";1 3///2;"
  5570   "RTN","PRC A315P",39, 0)
  5571    . ;  add  entry
  5572   "RTN","PRC A315P",40, 0)
  5573    . S X=ARN AME D FILE ^DICN K DI C I Y<1 K  X,Y Q
  5574   "RTN","PRC A315P",41, 0)
  5575    . D MES^X PDUTL("         New a ccounts Re ceivable c ategory "_ ARNAME_" a dded") S F LG=1
  5576   "RTN","PRC A315P",42, 0)
  5577    ;
  5578   "RTN","PRC A315P",43, 0)
  5579    I FLG D M ES^XPDUTL( "        N ew account s Receivab le categor ies added" )
  5580   "RTN","PRC A315P",44, 0)
  5581    D MES^XPD UTL("  ")
  5582   "RTN","PRC A315P",45, 0)
  5583    Q
  5584   "RTN","PRC A315P",46, 0)
  5585    ;
  5586   "RTN","PRC A315P",47, 0)
  5587    ;
  5588   "RTN","PRC A315P",48, 0)
  5589   REVSC ;REV ENUE SOURC E CODE ent ries in fi le #347.3
  5590   "RTN","PRC A315P",49, 0)
  5591    N I,RSCDA TA,DIC,Y,G BL,DA,X,DI E,DR
  5592   "RTN","PRC A315P",50, 0)
  5593    D MES^XPD UTL("      -> Adding  new REVENU E SOURCE C ODE entrie s to file  347.3 ..." )
  5594   "RTN","PRC A315P",51, 0)
  5595    S GBL="^R C(347.3,"
  5596   "RTN","PRC A315P",52, 0)
  5597    F I=1:1 D   Q:RSCDAT A="END"
  5598   "RTN","PRC A315P",53, 0)
  5599    . S RSCDA TA=$P($T(N EWRSC+I)," ;",3,99)
  5600   "RTN","PRC A315P",54, 0)
  5601    . Q:RSCDA TA="END"
  5602   "RTN","PRC A315P",55, 0)
  5603    . ; do a  lookup and  continue  if exists.
  5604   "RTN","PRC A315P",56, 0)
  5605    . S DIC=G BL,X=$P(RS CDATA,";")  D ^DIC
  5606   "RTN","PRC A315P",57, 0)
  5607    . I +Y>0  S DIK=GBL, DA=+Y D ^D IK
  5608   "RTN","PRC A315P",58, 0)
  5609    . ; add e ntry
  5610   "RTN","PRC A315P",59, 0)
  5611    . S X=$P( RSCDATA,"; ")
  5612   "RTN","PRC A315P",60, 0)
  5613    . S DIC(" DR")=".02/ //"_$P(RSC DATA,";",2 )_";",DIC( 0)="L"
  5614   "RTN","PRC A315P",61, 0)
  5615    . S DIC(" DR")=DIC(" DR")_".03/ //0;"
  5616   "RTN","PRC A315P",62, 0)
  5617    . D FILE^ DICN
  5618   "RTN","PRC A315P",63, 0)
  5619    . I +Y=-1  D
  5620   "RTN","PRC A315P",64, 0)
  5621    . . D MES ^XPDUTL("         "_$ P(RSCDATA, ";")_" fai led to add !")
  5622   "RTN","PRC A315P",65, 0)
  5623    D MES^XPD UTL("         REVENUE  SOURCE CO DES comple ted.")
  5624   "RTN","PRC A315P",66, 0)
  5625    Q
  5626   "RTN","PRC A315P",67, 0)
  5627    ;
  5628   "RTN","PRC A315P",68, 0)
  5629    ;
  5630   "RTN","PRC A315P",69, 0)
  5631   DELOPT ; r emove PRCA C SET REPA YMENT opti on
  5632   "RTN","PRC A315P",70, 0)
  5633    N DA,DIK, MEN,OPT,RE T
  5634   "RTN","PRC A315P",71, 0)
  5635    ; RET - v alue retur ned from
  5636   "RTN","PRC A315P",72, 0)
  5637    S MEN="PR CAC REPAYM ENT MENU"
  5638   "RTN","PRC A315P",73, 0)
  5639    S DA(1)=+ $$LKOPT^XP DMENU(MEN)
  5640   "RTN","PRC A315P",74, 0)
  5641    S OPT="PR CAC SET RE PAYMENT"
  5642   "RTN","PRC A315P",75, 0)
  5643    D BMES^XP DUTL("      -> Updati ng ["_MEN_ "]")
  5644   "RTN","PRC A315P",76, 0)
  5645    S RET=$$D ELETE^XPDM ENU(MEN,OP T)  ; dele te option  from menu
  5646   "RTN","PRC A315P",77, 0)
  5647    S DA=+$$L KOPT^XPDME NU(OPT)  ;  get optio n IEN
  5648   "RTN","PRC A315P",78, 0)
  5649    I DA>0 S  DIK="^DIC( 19," D ^DI K  ; code  can be re- run if alr eady delet ed
  5650   "RTN","PRC A315P",79, 0)
  5651    D MES^XPD UTL("         Menu up date "_$S( RET:"compl eted.",1:" not needed ."))
  5652   "RTN","PRC A315P",80, 0)
  5653    S OPT="PR CAC ENTER  EDIT REPAY MENT"
  5654   "RTN","PRC A315P",81, 0)
  5655    S DA=+$$L KOPT^XPDME NU(OPT)  ;  get optio n IEN
  5656   "RTN","PRC A315P",82, 0)
  5657    I $D(^DIC (19,DA(1), 10,"B",DA) ) Q  ; Opt ion alread y added
  5658   "RTN","PRC A315P",83, 0)
  5659    D ADD^XPD MENU(MEN,O PT,"",1) ;  Set Enter /Edit Repa yment as t he first i tem in Rep ayment Men u
  5660   "RTN","PRC A315P",84, 0)
  5661    Q
  5662   "RTN","PRC A315P",85, 0)
  5663    ;
  5664   "RTN","PRC A315P",86, 0)
  5665   CRSSVC ;Cr oss-servic ing - Repl ace (renam ed) menu o ptions - R CTCSP RECO NCILIATION  WORKLIST,  RCTCSP RE CONCIL REP ORT option s to menu  - Cross-Se rvicing Me nu [RCTCSP  MENU]
  5666   "RTN","PRC A315P",87, 0)
  5667    N DA,DIK, MEN,OPT,RE T
  5668   "RTN","PRC A315P",88, 0)
  5669    ; RET - v alue retur ned from
  5670   "RTN","PRC A315P",89, 0)
  5671    S MEN="RC TCSP MENU"
  5672   "RTN","PRC A315P",90, 0)
  5673    S DA(1)=+ $$LKOPT^XP DMENU(MEN)
  5674   "RTN","PRC A315P",91, 0)
  5675    D BMES^XP DUTL("      -> Updati ng ["_MEN_ "]")
  5676   "RTN","PRC A315P",92, 0)
  5677    F OPT="RC TCSP RECON CILIATION  WORKLIST", "RCTCSP RE CONCIL REP ORT" D
  5678   "RTN","PRC A315P",93, 0)
  5679    . K RET S  RET=$$DEL ETE^XPDMEN U(MEN,OPT)   ; delete  option fr om menu
  5680   "RTN","PRC A315P",94, 0)
  5681    . S DA=+$ $LKOPT^XPD MENU(OPT)   ; get opt ion IEN
  5682   "RTN","PRC A315P",95, 0)
  5683    . D MES^X PDUTL("         Menu  update to  option:  " _OPT_"  "_ $S(RET:"co mpleted.", 1:"not nee ded."))
  5684   "RTN","PRC A315P",96, 0)
  5685    . I $D(^D IC(19,DA(1 ),10,"B",D A)) Q  ; O ption alre ady added
  5686   "RTN","PRC A315P",97, 0)
  5687    . D ADD^X PDMENU(MEN ,OPT,"")
  5688   "RTN","PRC A315P",98, 0)
  5689    Q
  5690   "RTN","PRC A315P",99, 0)
  5691    ;
  5692   "RTN","PRC A315P",100 ,0)
  5693   CSJOB ;Job  the proce ss to buil d the new  Cross-Serv icing data  fields.
  5694   "RTN","PRC A315P",101 ,0)
  5695    N ZTDESC, ZTDTH,ZTIO ,ZTRTN,ZTS K
  5696   "RTN","PRC A315P",102 ,0)
  5697    ;
  5698   "RTN","PRC A315P",103 ,0)
  5699    D BMES^XP DUTL("      -> Queuin g backgrou nd job to  do the fol lowing:")
  5700   "RTN","PRC A315P",104 ,0)
  5701    D MES^XPD UTL("         1. Popu late new C ross-Servi cing indic es in #430 .")
  5702   "RTN","PRC A315P",105 ,0)
  5703    D MES^XPD UTL("         2. Sear ching file  #430, ACC OUNTS RECE IVABLE FIL E for CS S tops place d")
  5704   "RTN","PRC A315P",106 ,0)
  5705    D MES^XPD UTL("            prio r to this  patch in f ield #157  (STOP TCSP  REFERRAL  FLAG).")
  5706   "RTN","PRC A315P",107 ,0)
  5707    D MES^XPD UTL("         3. Popu late new C ross-Servi cing field  156 in #4 30.")
  5708   "RTN","PRC A315P",108 ,0)
  5709    D MES^XPD UTL(" ")
  5710   "RTN","PRC A315P",109 ,0)
  5711    ;
  5712   "RTN","PRC A315P",110 ,0)
  5713    ; Setup r equired va riables
  5714   "RTN","PRC A315P",111 ,0)
  5715    S ZTRTN=" CSJOB1^PRC A315P",ZTI O="",ZTDTH =$H
  5716   "RTN","PRC A315P",112 ,0)
  5717    S ZTDESC= "Backgroun d job to b uild CS in dices for  PRCA*4.5*3 15"
  5718   "RTN","PRC A315P",113 ,0)
  5719    ;
  5720   "RTN","PRC A315P",114 ,0)
  5721    ; Task th e job
  5722   "RTN","PRC A315P",115 ,0)
  5723    D ^%ZTLOA D
  5724   "RTN","PRC A315P",116 ,0)
  5725    ;
  5726   "RTN","PRC A315P",117 ,0)
  5727    ; Check i f task was  created
  5728   "RTN","PRC A315P",118 ,0)
  5729    I $D(ZTSK ) D MES^XP DUTL("         Task # "_ZTSK_" q ueued.")
  5730   "RTN","PRC A315P",119 ,0)
  5731    I '$D(ZTS K) D MES^X PDUTL("         Task  not queued .  Please  create a s upport tic ket.")
  5732   "RTN","PRC A315P",120 ,0)
  5733    D MES^XPD UTL("  ")
  5734   "RTN","PRC A315P",121 ,0)
  5735    Q
  5736   "RTN","PRC A315P",122 ,0)
  5737    ;
  5738   "RTN","PRC A315P",123 ,0)
  5739   CSJOB1 ;Po pulate new  indices i n #430
  5740   "RTN","PRC A315P",124 ,0)
  5741    K ^TMP($J )
  5742   "RTN","PRC A315P",125 ,0)
  5743    S DIK="^P RCA(430,", DIK(1)="17 2" D ENALL ^DIK
  5744   "RTN","PRC A315P",126 ,0)
  5745    S ^TMP($J ,"PRCA315P ",1)="FILE  #430 FIEL D #172 IND EX POPULAT ED"
  5746   "RTN","PRC A315P",127 ,0)
  5747    S DIK="^P RCA(430,", DIK(1)="30 1" D ENALL ^DIK
  5748   "RTN","PRC A315P",128 ,0)
  5749    S ^TMP($J ,"PRCA315P ",2)="FILE  #430 FIEL D #301 IND EX POPULAT ED"
  5750   "RTN","PRC A315P",129 ,0)
  5751    ;
  5752   "RTN","PRC A315P",130 ,0)
  5753   CSSTOP ;de termine CS  stops pla ced in 430  prior to  Patch 315
  5754   "RTN","PRC A315P",131 ,0)
  5755    N RCIEN,D EBTOR,BILL ,CSDATE,LI ST,MSG,GLO
  5756   "RTN","PRC A315P",132 ,0)
  5757    N DIFROM, XMDUN,XMY, XMZ ;  nee d to be ne wed or mai lman will  not delive r the mess age
  5758   "RTN","PRC A315P",133 ,0)
  5759    S GLO=$NA (^TMP($J," RCRJRCORMM "))
  5760   "RTN","PRC A315P",134 ,0)
  5761    ;
  5762   "RTN","PRC A315P",135 ,0)
  5763    S @GLO@(1 )="Bills c urrently f lagged to  stop TCSP  referral a ctivity pr ior"
  5764   "RTN","PRC A315P",136 ,0)
  5765    S @GLO@(2 )="to PRCA *4.5*315.  These bill s will not  show on t he new rep ort:"
  5766   "RTN","PRC A315P",137 ,0)
  5767    S @GLO@(3 )="'Cross- Servicing  Stop React ivate Repo rt'."
  5768   "RTN","PRC A315P",138 ,0)
  5769    S @GLO@(4 )="  "
  5770   "RTN","PRC A315P",139 ,0)
  5771    S RCIEN=0  F  S RCIE N=$O(^PRCA (430,RCIEN )) Q:'RCIE N  D
  5772   "RTN","PRC A315P",140 ,0)
  5773    . K LIST
  5774   "RTN","PRC A315P",141 ,0)
  5775    . I $P($G (^PRCA(430 ,RCIEN,15) ),U,7) D
  5776   "RTN","PRC A315P",142 ,0)
  5777    .. D GETS ^DIQ(430,R CIEN_","," .01;9;158" ,"IE","LIS T","MSG")
  5778   "RTN","PRC A315P",143 ,0)
  5779    .. S BILL =$G(LIST(4 30,RCIEN_" ,",.01,"E" )),DEBTOR= $G(LIST(43 0,RCIEN_", ",9,"E")), CSDATE=$G( LIST(430,R CIEN_",",1 58,"E"))
  5780   "RTN","PRC A315P",144 ,0)
  5781    .. S @GLO @(RCIEN)=B ILL_U_DEBT OR_U_CSDAT E
  5782   "RTN","PRC A315P",145 ,0)
  5783    . ;Load d ate into f ield #156,  ORIGINAL  DATE REFER RED TO TCS P
  5784   "RTN","PRC A315P",146 ,0)
  5785    . I $G(^P RCA(439,RC IEN,21)) Q
  5786   "RTN","PRC A315P",147 ,0)
  5787    . D GETS^ DIQ(430,RC IEN_",","1 51;153;158 ","I","LIS T","MSG")
  5788   "RTN","PRC A315P",148 ,0)
  5789    . F I=151 ,153,158 I  LIST(430, RCIEN_",", I,"I")?7N  S ^PRCA(43 0,RCIEN,21 )=LIST(430 ,RCIEN_"," ,I,"I") Q
  5790   "RTN","PRC A315P",149 ,0)
  5791    S ^TMP($J ,"PRCA315P ",3)="BILL S CURRENTL Y FLAGGED  TO STOP TC SP REPORT  CREATED"
  5792   "RTN","PRC A315P",150 ,0)
  5793    S ^TMP($J ,"PRCA315P ",4)="FILE  #430 FIEL D #156 VAL UES POPULA TED"
  5794   "RTN","PRC A315P",151 ,0)
  5795    S XMDUZ=. 5,XMY(.5)= "",XMY(DUZ )="",XMY(" G.TCSP")=" "
  5796   "RTN","PRC A315P",152 ,0)
  5797    S XMZ=$$S ENDMSG^RCR JRCOR("STO P TCSP REF ERRAL's ex isting bef ore PRCA*4 .5*315",.X MY)
  5798   "RTN","PRC A315P",153 ,0)
  5799    K ^TMP($J ,"RCRJRCOR MM")
  5800   "RTN","PRC A315P",154 ,0)
  5801    S ^TMP($J ,"PRCA315P ",5)="BILL S CURRENTL Y FLAGGED  TO STOP TC SP REPORT  MAIL SENT"
  5802   "RTN","PRC A315P",155 ,0)
  5803    ;
  5804   "RTN","PRC A315P",156 ,0)
  5805    N CNT,MSG ,XMY,XMDUZ ,DIFROM,XM SUB,XMTEXT
  5806   "RTN","PRC A315P",157 ,0)
  5807    S XMY(DUZ )=""
  5808   "RTN","PRC A315P",158 ,0)
  5809    S XMSUB=" PRCA*4.5*3 15 Post in stall rout ine has co mpleted",X MDUZ="Patc h PRCA*4.5 *315"
  5810   "RTN","PRC A315P",159 ,0)
  5811    S XMTEXT= "^TMP($J," "PRCA315P" ","
  5812   "RTN","PRC A315P",160 ,0)
  5813    D ^XMD
  5814   "RTN","PRC A315P",161 ,0)
  5815    Q
  5816   "RTN","PRC A315P",162 ,0)
  5817    ;
  5818   "RTN","PRC A315P",163 ,0)
  5819    ;Revenue  Source Cod es (RSC#)/ /
  5820   "RTN","PRC A315P",164 ,0)
  5821   NEWRSC ;SO URCE CODE; NAME
  5822   "RTN","PRC A315P",165 ,0)
  5823    ;;8VZZ;HU MAN 3RD-PR TY OUTPATI ENT
  5824   "RTN","PRC A315P",166 ,0)
  5825    ;;8UZZ;HU MAN 3RD-PR TY INPATIE NT
  5826   "RTN","PRC A315P",167 ,0)
  5827    ;;841Z;IN ELI 3RD-PA RTY INPATI ENT
  5828   "RTN","PRC A315P",168 ,0)
  5829    ;;842Z;IN ELI 3RD-PA RTY OUTPAT IENT 
  5830   "RTN","PRC A315P",169 ,0)
  5831    ;;END
  5832   "RTN","PRC A315P",170 ,0)
  5833    ;
  5834   "RTN","PRC A315P",171 ,0)
  5835    ;
  5836   "RTN","PRC A315P",172 ,0)
  5837    ;;ACCOUNT S RECEIVAB LE CATEGOR Y FILE (#4 30.2)
  5838   "RTN","PRC A315P",173 ,0)
  5839    ;;.01 CAT EGORY;1 AB BREVIATION ;6 CATEGOR Y NUMBER;7  ACCRUED
  5840   "RTN","PRC A315P",174 ,0)
  5841   CT46 ;;EME RGENCY/HUM ANITARIAN  REIMB.;HR; 252;48;T;1 213;1
  5842   "RTN","PRC A315P",175 ,0)
  5843   CT47 ;;INE LIGIBLE HO SP. REIMB. ;IR;251;49 ;T;1213;0
  5844   "RTN","PRC AAPR1")
  5845   0^19^B4970 7336^B4582 7636
  5846   "RTN","PRC AAPR1",1,0 )
  5847   PRCAAPR1 ; WASH-ISC@A LTOONA,PA/ RGY - PATI ENT ACCOUN T PROFILE  ;2/12/97   11:48 AM
  5848   "RTN","PRC AAPR1",2,0 )
  5849    ;;4.5;Acc ounts Rece ivable;**3 4,45,108,1 43,141,206 ,192,218,2 76,275,284 ,303,301,3 15**;Mar 2 0, 1995;Bu ild 55
  5850   "RTN","PRC AAPR1",3,0 )
  5851    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  5852   "RTN","PRC AAPR1",4,0 )
  5853    ;
  5854   "RTN","PRC AAPR1",5,0 )
  5855   HDR ;Head  for Accoun t profile
  5856   "RTN","PRC AAPR1",6,0 )
  5857    S X="",$P (X,"=",23) ="" W @IOF ,!,X,"   A  c c o u n  t   P r o  f i l e    ",X
  5858   "RTN","PRC AAPR1",7,0 )
  5859   HDR1 N DMC ,IBRX,RSN, TOP4,TOP6, DPTFLG,ACC TNUM,RCCV
  5860   "RTN","PRC AAPR1",8,0 )
  5861    S IBRX=0, DPTFLG=0
  5862   "RTN","PRC AAPR1",9,0 )
  5863    ;
  5864   "RTN","PRC AAPR1",10, 0)
  5865    ; PRCAAPR  cleans up  BILL, COU NT, DEBT,  DTOUT, DIC , OUT, PRC ADB, SEL,  X
  5866   "RTN","PRC AAPR1",11, 0)
  5867    ;Display  new 'State ment Accou nt Number"  (Patch 20 6)
  5868   "RTN","PRC AAPR1",12, 0)
  5869    I PRCADB[ "DPT(" S D PTFLG=1,AC CTNUM=$$AC CT(PRCADB)
  5870   "RTN","PRC AAPR1",13, 0)
  5871    ;
  5872   "RTN","PRC AAPR1",14, 0)
  5873    W !,$P(DE BT,"^",2)  I DPTFLG!( PRCADB["VA (200,") S  X=$S(PRCAD B["DPT(":$ P(^DPT(+PR CADB,0),"^ ",9),1:$P( $G(^VA(200 ,+PRCADB,1 )),"^",9))  W " (",$E (X,1,3),"- ",$E(X,4,5 ),"-",$E(X ,6,9),")"
  5874   "RTN","PRC AAPR1",15, 0)
  5875    W ?53,"St atement Da y: ",$S($$ PST^RCAMFN 01(+DEBT)> 0:$$PST^RC AMFN01(+DE BT),1:"N/A ")
  5876   "RTN","PRC AAPR1",16, 0)
  5877    K Y S X(" ADD")=$$DA DD^RCAMADD (PRCADB)
  5878   "RTN","PRC AAPR1",17, 0)
  5879    ;
  5880   "RTN","PRC AAPR1",18, 0)
  5881    ;Display  new 'State ment Accou nt Number"  (Patch 20 6)
  5882   "RTN","PRC AAPR1",19, 0)
  5883    I DPTFLG  W !,"State ment Accou nt #: ",AC CTNUM,?52, "Last Stat ement: "
  5884   "RTN","PRC AAPR1",20, 0)
  5885    E  W !?52 ,"Last Sta tement: "
  5886   "RTN","PRC AAPR1",21, 0)
  5887    ;
  5888   "RTN","PRC AAPR1",22, 0)
  5889    S Y=+$$LS T^RCFN01(P RCADB,2)
  5890   "RTN","PRC AAPR1",23, 0)
  5891    I Y>0 S Y ("CCPC")=$ $FPS^RCCPC FN(+DEBT)  S:Y("CCPC" ) Y=+$P(Y( "CCPC"),"^ ")
  5892   "RTN","PRC AAPR1",24, 0)
  5893    W $S(Y=-1 :"N/A",1:$ $SLH^RCFN0 1(Y))
  5894   "RTN","PRC AAPR1",25, 0)
  5895    W !,$P(X( "ADD"),"^" )
  5896   "RTN","PRC AAPR1",26, 0)
  5897    W:+$G(Y(" CCPC")) ?5 2,"Activit y as of: " ,$$SLH^RCF N01($$ASOF ^RCCPCFN($ P(Y("CCPC" ),"^",2)))
  5898   "RTN","PRC AAPR1",27, 0)
  5899    W:$P(X("A DD"),"^",2 )]"" !,$P( X("ADD")," ^",2) W:$P (X("ADD"), "^",3)]""  !,$P(X("AD D"),"^",3)
  5900   "RTN","PRC AAPR1",28, 0)
  5901    W ! W:$P( X("ADD")," ^",4)]"" $ P(X("ADD") ,"^",4),",  ",$P(X("A DD"),"^",5 ),"  ",$S( $P(X("ADD" ),"^",6):$ P(X("ADD") ,"^",6),1: $P(X("ADD" ),"^",8))
  5902   "RTN","PRC AAPR1",29, 0)
  5903    W ?55,"Am ount Owed:  ",?69,$J( +$G(^TMP(" PRCAAPR",$ J,"C")),9, 2)
  5904   "RTN","PRC AAPR1",30, 0)
  5905    W !,"Phon e #: ",$S( $P(X("ADD" ),"^",7)]" ":$P(X("AD D"),"^",7) ,1:"N/A")
  5906   "RTN","PRC AAPR1",31, 0)
  5907    I PRCADB[ "DPT(" W ? 51,"RX Cop ay Exempt:  " S IBRX= $$RXST^IBA RXEU(+PRCA DB,DT) W $ S($P(IBRX, U)=1:"YES" ,$P(IBRX,U )=0:"NO",1 :"N/A")
  5908   "RTN","PRC AAPR1",32, 0)
  5909    I PRCADB[ "DPT(" W ! ?57,"CV St atus: " S  RCCV=$$CVE DT^DGCV(+P RCADB,DT)  W $S($P(RC CV,U,3)>0: "YES",1:"N O") I $P(R CCV,U,2) W  !?52,"CV  Status End s: ",$$SLH ^RCFN01($P (RCCV,U,2) )
  5910   "RTN","PRC AAPR1",33, 0)
  5911    ; *108 ad d exemptio n reason/d mc info
  5912   "RTN","PRC AAPR1",34, 0)
  5913    I IBRX>0, ($P(IBRX,U )=1) S DIC ="^IBE(354 .2,",DIC(0 )="M",X=+$ P(IBRX,"^" ,3) D ^DIC  I Y>0 W ! ,?54,"(",$ P(Y,"^",2) ,")"
  5914   "RTN","PRC AAPR1",35, 0)
  5915    I $D(^RCD (340,"DMC" ,1,+DEBT))  S DMC=$G( ^RCD(340,+ DEBT,3)) D
  5916   "RTN","PRC AAPR1",36, 0)
  5917    .I $P(DMC ,"^",2) W  !,"** Acco unt forwar ded to DMC : ",$$SLH^ RCFN01($P( DMC,"^",2) ),?50,"Tot al DMC Amo unt: ",?69 ,$J($P(DMC ,"^",5),9, 2)
  5918   "RTN","PRC AAPR1",37, 0)
  5919    .I $P(DMC ,"^",9)'=" " W !,?49, "Lesser Am t to DMC:  ",?69,$J($ P(DMC,"^", 9),9,2)
  5920   "RTN","PRC AAPR1",38, 0)
  5921    .Q
  5922   "RTN","PRC AAPR1",39, 0)
  5923    I $D(^RCD (340,"TOP" ,+DEBT)) S  TOP4=$G(^ RCD(340,+D EBT,4)),TO P6=$G(^(6) ) D
  5924   "RTN","PRC AAPR1",40, 0)
  5925    .I +TOP6  W !,"** Ac count forw arded to T OP: ",$$SL H^RCFN01($ P(TOP6,"^" )),?45,"To tal TOP Am ount: ",?6 5,$J($P(TO P4,"^",3), 13,2)
  5926   "RTN","PRC AAPR1",41, 0)
  5927    .I $P(TOP 6,"^",6) W  !,?45,"TO P HOLD DAT E: ",$$SLH ^RCFN01($P (TOP6,"^", 6))
  5928   "RTN","PRC AAPR1",42, 0)
  5929    .Q
  5930   "RTN","PRC AAPR1",43, 0)
  5931    I $D(^RCD (340,"TCSP ",+DEBT))  D
  5932   "RTN","PRC AAPR1",44, 0)
  5933    .W !,"x D ebt Referr ed to Cros s-Servicin g",?45,"To tal CS Deb t: ",?65,$ J($$TOTALB ^RCTCSPU(+ DEBT),13,2 )
  5934   "RTN","PRC AAPR1",45, 0)
  5935    .Q
  5936   "RTN","PRC AAPR1",46, 0)
  5937    I $O(^RCD (340,+DEBT ,2,0)) D
  5938   "RTN","PRC AAPR1",47, 0)
  5939    .S Y=0 F  X=0:0 S X= $O(^RCD(34 0,+DEBT,2, X)) Q:'X   W:'Y ! W ! ,$G(^(X,0) ) S Y=Y+1  W:Y=3&$O(^ RCD(340,+D EBT,2,X))  "..." Q:Y= 3
  5940   "RTN","PRC AAPR1",48, 0)
  5941    .Q
  5942   "RTN","PRC AAPR1",49, 0)
  5943    Q
  5944   "RTN","PRC AAPR1",50, 0)
  5945    ; PRCA*4. 5*276 - mo ved header s right to  add EOB i ndicator t o bill #,  adjusted a t tag BLN  accordingl y
  5946   "RTN","PRC AAPR1",51, 0)
  5947    ; PRCA*4. 5*275 - mo ved header s to line  up with co lumn chang es
  5948   "RTN","PRC AAPR1",52, 0)
  5949   HDR2 W !!, "#",?7,"Bi ll #",?20, "Est",?31, "Type",?43 ,"Paid",?5 2,"Prin",? 58,"Int",? 64,"Adm",? 72,"Balanc e"
  5950   "RTN","PRC AAPR1",53, 0)
  5951    Q
  5952   "RTN","PRC AAPR1",54, 0)
  5953   DIS ;Displ ay bill li ne items
  5954   "RTN","PRC AAPR1",55, 0)
  5955    NEW STAT1
  5956   "RTN","PRC AAPR1",56, 0)
  5957    I '$O(^TM P("PRCAAPR ",$J,"C",0 )) S X="", $P(X,"*",2 2)="" W !! ,X,"  NO A CCOUNT INF ORMATION A VAILABLE   ",X G Q1
  5958   "RTN","PRC AAPR1",57, 0)
  5959    F STAT1=0 :0 S STAT1 =$O(^TMP(" PRCAAPR",$ J,"C",STAT 1)) Q:'STA T1!$D(OUT)   D BHDR S  BILL=0 F   S BILL=$O (^TMP("PRC AAPR",$J," C",STAT1,B ILL)) Q:BI LL=""!$D(O UT)  D BLN
  5960   "RTN","PRC AAPR1",58, 0)
  5961    I '$D(OUT ) D READ
  5962   "RTN","PRC AAPR1",59, 0)
  5963   Q1 Q
  5964   "RTN","PRC AAPR1",60, 0)
  5965   BHDR ;Disp lay status  line
  5966   "RTN","PRC AAPR1",61, 0)
  5967    S X=$S(+$ P(^TMP("PR CAAPR",$J, "C",STAT1) ,"^",2)=99 :"PAYMENTS ",1:$P($G( ^PRCA(430. 3,+$O(^PRC A(430.3,"A C",+$P(^TM P("PRCAAPR ",$J,"C",S TAT1),"^", 2),0)),0)) ,"^"))
  5968   "RTN","PRC AAPR1",62, 0)
  5969    S Y=" "_X _" ("_$J(+ ^TMP("PRCA APR",$J,"C ",STAT1),0 ,2)_") " W  ! F X=1:1 :80-$L(Y)/ 2 W "-"
  5970   "RTN","PRC AAPR1",63, 0)
  5971    W Y F X=1 :1:IOM-$X- 1 W "-"
  5972   "RTN","PRC AAPR1",64, 0)
  5973    Q
  5974   "RTN","PRC AAPR1",65, 0)
  5975   BLN ;
  5976   "RTN","PRC AAPR1",66, 0)
  5977    N PRCOUT, REJFLAG,CS CSTAT,DEBT OR,CSDATE1 ,CSDATE2,R CIND
  5978   "RTN","PRC AAPR1",67, 0)
  5979    I $Y+5>IO SL,COUNT D  READ G:$D (OUT) Q2 D  HDR,HDR2, BHDR
  5980   "RTN","PRC AAPR1",68, 0)
  5981    ; PRCA*4. 5*276, att ach EOB in dicator '% ' to bill  # when app licable
  5982   "RTN","PRC AAPR1",69, 0)
  5983    S PRCOUT= $$COMP3^PR CAAPR(BILL )
  5984   "RTN","PRC AAPR1",70, 0)
  5985    I STAT1'= 99,PRCOUT' ="%" S PRC OUT=$$IBEE OBCK(BILL)
  5986   "RTN","PRC AAPR1",71, 0)
  5987    ; PRCA*4. 5*303 - ad d reject i ndicator t o kbill if  applicabl e ; #IA 60 60
  5988   "RTN","PRC AAPR1",72, 0)
  5989    S REJFLAG =0 S:STAT1 '=99 REJFL AG=$$BILLR EJ^IBJTU6( $P($P($G(^ PRCA(430,B ILL,0)),"^ "),"-",2))
  5990   "RTN","PRC AAPR1",73, 0)
  5991    S:STAT1'= 99 COUNT=C OUNT+1,^TM P("PRCAAPR ",$J,"O",C OUNT)=BILL  S X=$S(ST AT1=99:BIL L,1:$G(PRC OUT)_$S(RE JFLAG:"c", 1:"")_$G(^ PRCA(430,B ILL,0)))
  5992   "RTN","PRC AAPR1",74, 0)
  5993    ; PRCA*4. 5*303 - En d
  5994   "RTN","PRC AAPR1",75, 0)
  5995    ;
  5996   "RTN","PRC AAPR1",76, 0)
  5997    ; PRCA*4. 5*315: AR  File #430  - set hist orical ind icator set  to "y" if  an entry  exists in  the 
  5998   "RTN","PRC AAPR1",77, 0)
  5999    ;     ORI GINAL DATE  REFERRED  TO TCSP (f ield #156)  to CS bil l number.   If an ent ry in the 
  6000   "RTN","PRC AAPR1",78, 0)
  6001    ;     DAT E REFERRED  TO TCSP ( field #151 ), then an  "x" indic ator displ ays on the  bill,           
  6002   "RTN","PRC AAPR1",79, 0)
  6003    ;     oth erwise nei ther indic ator.
  6004   "RTN","PRC AAPR1",80, 0)
  6005    ;
  6006   "RTN","PRC AAPR1",81, 0)
  6007    S CSDATE1 =$$GET1^DI Q(430,BILL ,"DATE BIL L REFERRED  TO TCSP", "I")
  6008   "RTN","PRC AAPR1",82, 0)
  6009    S CSDATE2 =$$GET1^DI Q(430,BILL ,"ORIGINAL  DATE REFE RRED TO TC SP","I")
  6010   "RTN","PRC AAPR1",83, 0)
  6011    S RCIND=$ S(CSDATE1' ="":"x",CS DATE2'="": "y",1:"")
  6012   "RTN","PRC AAPR1",84, 0)
  6013    ;W !,$S(S TAT1'=99:C OUNT,1:"*" ),?4,$P(X, "^") W:STA T1'=99 ?20 ,$$SLH^RCF N01($P(X," ^",10))
  6014   "RTN","PRC AAPR1",85, 0)
  6015    I RCIND]" " W !,$S(S TAT1'=99:C OUNT,1:"*" ),?5,$P(RC IND_X,"^")  W:STAT1'= 99 ?20,$$S LH^RCFN01( $P(X,"^",1 0))
  6016   "RTN","PRC AAPR1",86, 0)
  6017    I RCIND=" " W !,$S(S TAT1'=99:C OUNT,1:"*" ),?6,$P(X, "^") W:STA T1'=99 ?20 ,$$SLH^RCF N01($P(X," ^",10))
  6018   "RTN","PRC AAPR1",87, 0)
  6019    W:STAT1'= 99 ?31,$S( $P(X,"^",2 )=31:"TRIC  PT",1:$E( $P($G(^PRC A(430.2,$S ($O(^PRCA( 430.2,"AC" ,24,0))=$P (X,"^",2): +$P(X,"^", 16),1:+$P( X,"^",2)), 0)),"^"),1 ,7))  ; PR CA*4.5*192  changed C HMP PT to  TRIC PT
  6020   "RTN","PRC AAPR1",88, 0)
  6021    W:STAT1=9 9 ?31,"PAY MENT"
  6022   "RTN","PRC AAPR1",89, 0)
  6023    S X=$S(ST AT1=99:"^^ ^^^^"_^TMP ("PRCAAPR" ,$J,"C",ST AT1,BILL), 1:$G(^PRCA (430,BILL, 7))) W ?39  W:STAT1=9 9 "-" W $J ($P(X,"^", 7)+$P(X,"^ ",8)+$P(X, "^",9)+$P( X,"^",10)+ $P(X,"^",1 1),8,2)
  6024   "RTN","PRC AAPR1",90, 0)
  6025    W ?48 W:S TAT1=99 "  " W:STAT1' =99 $S($P( ^PRCA(430, BILL,0),"^ ",2)=$O(^P RCA(430.2, "AC",33,0) ):"-",1:"  ")
  6026   "RTN","PRC AAPR1",91, 0)
  6027    W $J($P(X ,"^"),7,2) ,?57,$J($P (X,"^",2), 5,2),?63,$ J($P(X,"^" ,3),5,2),? 69,$S(STAT 1=99:"-",$ P(^PRCA(43 0,BILL,0), "^",2)=$O( ^PRCA(430. 2,"AC",33, 0)):"-",1: " ")
  6028   "RTN","PRC AAPR1",92, 0)
  6029    W $S(STAT 1=99:$J(^T MP("PRCAAP R",$J,"C", STAT1,BILL ),9,2),1:$ J($P(X,"^" )+$P(X,"^" ,2)+$P(X," ^",3)+$P(X ,"^",4)+$P (X,"^",5), 9,2))
  6030   "RTN","PRC AAPR1",93, 0)
  6031    K ^TMP("P RCAAPR",$J ,"C",STAT1 ,BILL) K:$ O(^TMP("PR CAAPR",$J, "C",STAT1, ""))="" ^T MP("PRCAAP R",$J,"C", STAT1)
  6032   "RTN","PRC AAPR1",94, 0)
  6033   Q2 Q
  6034   "RTN","PRC AAPR1",95, 0)
  6035   READ ;Read  bill numb er
  6036   "RTN","PRC AAPR1",96, 0)
  6037    W !!,"Sel ect 1-",CO UNT W:$O(^ TMP("PRCAA PR",$J,"C" ,"")) " or  return to  continue"  R ": ",X: DTIME I X[ "^"!'$T S: '$T DTOUT= 1 S OUT=1  G Q3
  6038   "RTN","PRC AAPR1",97, 0)
  6039    I X["?" W  !!,"To se e detailed  informati on for a b ill number , enter th e correspo nding '#'" ,!,"next t o the bill .  (Ex: 1  or 1,3)" G  READ
  6040   "RTN","PRC AAPR1",98, 0)
  6041    I X="",'$ O(^TMP("PR CAAPR",$J, "C","")) S  OUT=1 G Q 3
  6042   "RTN","PRC AAPR1",99, 0)
  6043    G:X="" Q3  S SEL=X
  6044   "RTN","PRC AAPR1",100 ,0)
  6045    F X=1:1:$ L(SEL,",")  S Y=$P(SE L,",",X) I  Y'?1N.N!' $D(^TMP("P RCAAPR",$J ,"O",+Y))  W *7," ??"  G READ
  6046   "RTN","PRC AAPR1",101 ,0)
  6047    S OUT=1 F  X=1:1:$L( SEL,",") S  Y=$P(SEL, ",",X) D E N1^PRCAATR ($G(^TMP(" PRCAAPR",$ J,"O",+Y)) )
  6048   "RTN","PRC AAPR1",102 ,0)
  6049   Q3 Q
  6050   "RTN","PRC AAPR1",103 ,0)
  6051    ;
  6052   "RTN","PRC AAPR1",104 ,0)
  6053   ACCT(DFN)  ;Get accou nt number.  Join stat ion with D FN (Patch  206)
  6054   "RTN","PRC AAPR1",105 ,0)
  6055    N SITE,AC CT,ACCT1,L EN
  6056   "RTN","PRC AAPR1",106 ,0)
  6057    S DFN=+DF N
  6058   "RTN","PRC AAPR1",107 ,0)
  6059    S LEN=$L( DFN)-1
  6060   "RTN","PRC AAPR1",108 ,0)
  6061    S SITE=$$ SITE^RCMSI TE                            ;s tation num ber
  6062   "RTN","PRC AAPR1",109 ,0)
  6063    S ACCT=$$ RJ^XLFSTR( DFN,13,0)                     ;a dd leading  zeroes
  6064   "RTN","PRC AAPR1",110 ,0)
  6065    S ACCT1=S ITE_"-"_$E (ACCT,1,$L (ACCT)-$L( DFN))   ;a dd hyphen
  6066   "RTN","PRC AAPR1",111 ,0)
  6067    S ACCT1=A CCT1_"-"_$ E(ACCT,$L( ACCT)-LEN, 99)     ;a dd hyphen
  6068   "RTN","PRC AAPR1",112 ,0)
  6069    S ACCT1=A CCT1_"-"_$ E($P($P(DE BT,U,2),", "),1,5) ;a dd last na me
  6070   "RTN","PRC AAPR1",113 ,0)
  6071    Q ACCT1
  6072   "RTN","PRC AAPR1",114 ,0)
  6073    ;
  6074   "RTN","PRC AAPR1",115 ,0)
  6075    ; PRCA*4. 5*276 -  U se Event D ate to fin d an assoc iated 3rd  Party bill  with an a ssociated  EEOB
  6076   "RTN","PRC AAPR1",116 ,0)
  6077   IBEEOBCK(P RCAAR) ; P assed AR B ill
  6078   "RTN","PRC AAPR1",117 ,0)
  6079    ; Functio n will qui t as soon  as a 3rd p arty bill  is located  that has  an associa ted EEOB
  6080   "RTN","PRC AAPR1",118 ,0)
  6081    ;
  6082   "RTN","PRC AAPR1",119 ,0)
  6083    ; Find 3r d Party Bi lls with a n Event Da te
  6084   "RTN","PRC AAPR1",120 ,0)
  6085    N PRCAREF ,PRCAEEOB, PRCADT,DFN ,DBTR,X1
  6086   "RTN","PRC AAPR1",121 ,0)
  6087    ; Get DFN
  6088   "RTN","PRC AAPR1",122 ,0)
  6089    S DBTR=+$ P($G(^PRCA (430,PRCAA R,0)),U,9)
  6090   "RTN","PRC AAPR1",123 ,0)
  6091    S X1=$P($ G(^RCD(340 ,DBTR,0)), U) I X1'[" DPT" Q ""
  6092   "RTN","PRC AAPR1",124 ,0)
  6093    S DFN=+X1
  6094   "RTN","PRC AAPR1",125 ,0)
  6095    S PRCAEEO B=""
  6096   "RTN","PRC AAPR1",126 ,0)
  6097    ; Loop th rough Xref  of ARbill  (#430) to  Action fi le (#350)
  6098   "RTN","PRC AAPR1",127 ,0)
  6099    I +$G(PRC AAR) S PRC AREF=0 F   S PRCAREF= $O(^IB("AB IL",$P($G( ^PRCA(430, PRCAAR,0)) ,"^"),PRCA REF)) Q:'P RCAREF  D   Q:PRCAEEO B="%"
  6100   "RTN","PRC AAPR1",128 ,0)
  6101    . S PRCAD T=$P($G(^I B(PRCAREF, 0)),"^",17 ) ;Get eve nt Date
  6102   "RTN","PRC AAPR1",129 ,0)
  6103    . I PRCAD T S PRCAEE OB=$$TPEVD T(DFN,PRCA DT) Q:PRCA EEOB="%"
  6104   "RTN","PRC AAPR1",130 ,0)
  6105    . I PRCAD T S PRCAEE OB=$$TPOPV (DFN,PRCAD T)
  6106   "RTN","PRC AAPR1",131 ,0)
  6107    ;
  6108   "RTN","PRC AAPR1",132 ,0)
  6109    Q PRCAEEO B
  6110   "RTN","PRC AAPR1",133 ,0)
  6111    ;
  6112   "RTN","PRC AAPR1",134 ,0)
  6113    ; PRCA*4. 5*276 - Tr averse all  THIRD PAR TY bills f or a patie nt with a  specific E vent Date  (399,.03)
  6114   "RTN","PRC AAPR1",135 ,0)
  6115   TPEVDT(DFN ,EVDT) ;
  6116   "RTN","PRC AAPR1",136 ,0)
  6117    ; Functio n will qui t as soon  as a 3rd p arty bill  is located  that has  an associa ted EEOB
  6118   "RTN","PRC AAPR1",137 ,0)
  6119    ; PRCA*4. 5*284 - Us e the 399, "APDT" (by  patient)  index inst ead of the  399,"D" i ndex for e fficiency
  6120   "RTN","PRC AAPR1",138 ,0)
  6121    I '$G(DFN )!'$G(EVDT ) Q ""
  6122   "RTN","PRC AAPR1",139 ,0)
  6123    N PRCAIFN ,PRCAEEOB
  6124   "RTN","PRC AAPR1",140 ,0)
  6125    S PRCAEEO B="",PRCAI FN=""
  6126   "RTN","PRC AAPR1",141 ,0)
  6127    F  S PRCA IFN=$O(^DG CR(399,"AP DT",DFN,PR CAIFN),-1)  Q:'PRCAIF N  D  Q:PR CAEEOB="%"
  6128   "RTN","PRC AAPR1",142 ,0)
  6129    . I $D(^D GCR(399,"A PDT",DFN,P RCAIFN,999 9999-EVDT) ) S PRCAEE OB=$$COMP3 ^PRCAAPR(P RCAIFN)
  6130   "RTN","PRC AAPR1",143 ,0)
  6131    Q PRCAEEO B
  6132   "RTN","PRC AAPR1",144 ,0)
  6133    ;
  6134   "RTN","PRC AAPR1",145 ,0)
  6135    ; PRCA*4. 5*276 - Tr averse all  THIRD PAR TY bills f or a patie nt with an y Opt Visi t Dates sa me as Even t Date (39 9,43)
  6136   "RTN","PRC AAPR1",146 ,0)
  6137   TPOPV(DFN, EVDT) ;
  6138   "RTN","PRC AAPR1",147 ,0)
  6139    ; Functio n will qui t as soon  as a 3rd p arty bill  is located  that has  an associa ted EEOB
  6140   "RTN","PRC AAPR1",148 ,0)
  6141    N PRCAIFN ,PRCAEEOB
  6142   "RTN","PRC AAPR1",149 ,0)
  6143    S PRCAEEO B=""
  6144   "RTN","PRC AAPR1",150 ,0)
  6145    I +$G(DFN ),+$G(EVDT ) S PRCAIF N=0 F  S P RCAIFN=$O( ^DGCR(399, "AOPV",DFN ,EVDT,PRCA IFN)) Q:'P RCAIFN  D   Q:PRCAEEO B="%"
  6146   "RTN","PRC AAPR1",151 ,0)
  6147    . ; attac h EOB indi cator '%'  to bill #  when appli cable
  6148   "RTN","PRC AAPR1",152 ,0)
  6149    . S PRCAE EOB=$$COMP 3^PRCAAPR( PRCAIFN)
  6150   "RTN","PRC AAPR1",153 ,0)
  6151    Q PRCAEEO B
  6152   "RTN","PRC AATR")
  6153   0^44^B2508 6511^B2277 1269
  6154   "RTN","PRC AATR",1,0)
  6155   PRCAATR ;W ASH-ISC@AL TOONA,PA/R GY - VIEW  TRANSACTIO N FOR BILL S ;2/14/96   2:46 PM
  6156   "RTN","PRC AATR",2,0)
  6157   V ;;4.5;Ac counts Rec eivable;** 36,104,172 ,138,233,2 76,303,301 ,315**;Mar  20, 1995; Build 55
  6158   "RTN","PRC AATR",3,0)
  6159    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  6160   "RTN","PRC AATR",4,0)
  6161    ;
  6162   "RTN","PRC AATR",5,0)
  6163    ; PRCAAPR  cleans up  DEBT, DTO UT
  6164   "RTN","PRC AATR",6,0)
  6165   EN1(BILL)  ;ENTRY POI NT FROM PR CAAPR
  6166   "RTN","PRC AATR",7,0)
  6167    NEW X,Y,C OUNT,OUT,T RAN,SEL,PR CAATRX,PRC AIO,PRCAIO S,D0,PRCAQ UE,POP,PRC APRT,Y,ZTS K,PRCOUT,P RCA15,REJF LG
  6168   "RTN","PRC AATR",8,0)
  6169    NEW CSDAT E1,CSDATE2 ,CSFLG
  6170   "RTN","PRC AATR",9,0)
  6171    I '$D(BIL L) G Q
  6172   "RTN","PRC AATR",10,0 )
  6173    I BILL'?1 N.N!'$D(^P RCA(430,+B ILL,0)) G  Q
  6174   "RTN","PRC AATR",11,0 )
  6175    ; PRCA*4. 5*276
  6176   "RTN","PRC AATR",12,0 )
  6177    S PRCOUT= $$COMP3^PR CAAPR(BILL ) ; check  for 1st an d 3rd part y payments
  6178   "RTN","PRC AATR",13,0 )
  6179    I PRCOUT' ="%" S PRC OUT=$$IBEE OBCK^PRCAA PR1(BILL)
  6180   "RTN","PRC AATR",14,0 )
  6181    S PRCAPRT =1,PRCAIO= IO(0),PRCA IO(0)=IO(0 ),COUNT=0  K ^TMP("PR CAATR",$J)
  6182   "RTN","PRC AATR",15,0 )
  6183    D HDR,DIS ,^%ZISC
  6184   "RTN","PRC AATR",16,0 )
  6185   Q K ^TMP(" PRCAATR",$ J),IO("Q")  Q
  6186   "RTN","PRC AATR",17,0 )
  6187   HDR ;Heade r
  6188   "RTN","PRC AATR",18,0 )
  6189    D HDR^PRC AAPR1
  6190   "RTN","PRC AATR",19,0 )
  6191    I $P($G(^ PRCA(430,B ILL,13))," ^") W !,"M EDICARE CO NTRACTUAL  ADJUSTMENT : ",$J($P( $G(^PRCA(4 30,BILL,13 )),"^"),0, 2)
  6192   "RTN","PRC AATR",20,0 )
  6193    I $P($G(^ PRCA(430,B ILL,13))," ^",2) W !, "UNREIMBUR SED MEDICA RE EXPENSE : ",$J($P( $G(^PRCA(4 30,BILL,13 )),"^",2), 0,2)
  6194   "RTN","PRC AATR",21,0 )
  6195    ; PRCA*4. 5*303 - Ad ding rejec t indicato r, 'x' to  bill numbe r when app licable
  6196   "RTN","PRC AATR",22,0 )
  6197    S REJFLG= $$BILLREJ^ IBJTU6($P( $P($G(^PRC A(430,BILL ,0)),"^"), "-",2)) ;  IA# 6060
  6198   "RTN","PRC AATR",23,0 )
  6199    ; PRCA*4. 5*315
  6200   "RTN","PRC AATR",24,0 )
  6201    S CSDATE1 =$$GET1^DI Q(430,BILL ,"DATE BIL L REFERRED  TO TCSP", "I")
  6202   "RTN","PRC AATR",25,0 )
  6203    S CSDATE2 =$$GET1^DI Q(430,BILL ,"ORIGINAL  DATE REFE RRED TO TC SP","I")
  6204   "RTN","PRC AATR",26,0 )
  6205    S CSFLG=$ S(CSDATE1' ="":"x",CS DATE2'="": "y",1:"")
  6206   "RTN","PRC AATR",27,0 )
  6207    ; PRCA*4. 5*276 - at tach EEOB  indicator  to bill nu mber
  6208   "RTN","PRC AATR",28,0 )
  6209    I +$G(^PR CA(430,BIL L,15)) S P RCA15=^(15 ) I $P(PRC A15,U)]""  W !,"CS Re ferred Dat e: " S Y=$ P(PRCA15,U ) D DD^%DT  W Y  ;prc a*4.5*301
  6210   "RTN","PRC AATR",29,0 )
  6211    S PRCA15= $G(^PRCA(4 30,BILL,15 )) D
  6212   "RTN","PRC AATR",30,0 )
  6213    .I $P(PRC A15,U,2)]" " W !,"CS  Recall Rea son: ",$E( $$GET1^DIQ (430,BILL, 154),1,31)  W ?51,"CS  Recall Da te: " S Y= $P(PRCA15, U,3) D DD^ %DT W Y Q   ;prca*4.5 *301
  6214   "RTN","PRC AATR",31,0 )
  6215    .I $P(PRC A15,U,4)]" ",$P(PRCA1 5,U,2)=""  W !,"CS Re call Reaso n: ",$E($$ GET1^DIQ(4 30,BILL,15 4),1,31) W  ?51,"CS R ecall Date : "
  6216   "RTN","PRC AATR",32,0 )
  6217    W ! D PRO FRJ^RCTCSJ S1(BILL) ;  Reject hi story  ;pr ca*4.5*301
  6218   "RTN","PRC AATR",33,0 )
  6219    W !,"Bill  #: ",$G(P RCOUT)_CSF LG_$P(^PRC A(430,BILL ,0),"^") D :$P(^(0)," ^",9)'=+DE BT DEB ; p rca*4.5*31 5
  6220   "RTN","PRC AATR",34,0 )
  6221    I REJFLG  W !,"Bill  #: ",$G(PR COUT)_$S(R EJFLG:"c", 1:"")_$P(^ PRCA(430,B ILL,0),"^" ) D:$P(^(0 ),"^",9)'= +DEBT DEB
  6222   "RTN","PRC AATR",35,0 )
  6223    W !!,"Bil l #",?8,"T r #",?17," Type",?52, "Date",?70 ,"Amount"
  6224   "RTN","PRC AATR",36,0 )
  6225    S X="",$P (X,"-",IOM )="" W !,X
  6226   "RTN","PRC AATR",37,0 )
  6227    Q
  6228   "RTN","PRC AATR",38,0 )
  6229   DIS ;Displ ay transac tions
  6230   "RTN","PRC AATR",39,0 )
  6231    W !,?17," Original A mount",?52 ,$$SLH^RCF N01($P(^PR CA(430,BIL L,0),"^",1 0)),?65,$J ($P(^(0)," ^",3),11,2 )
  6232   "RTN","PRC AATR",40,0 )
  6233    I '$O(^PR CA(433,"C" ,BILL,0))  D
  6234   "RTN","PRC AATR",41,0 )
  6235    . S X="", $P(X,"*",2 0)="" W !! ,X,"  NO T RANSACTION  INFORMATI ON AVAILAB LE  ",X
  6236   "RTN","PRC AATR",42,0 )
  6237   RD . R !!, "Press ret urn to con tinue: ",X :DTIME S:' $T DTOUT=1  S OUT=1
  6238   "RTN","PRC AATR",43,0 )
  6239    . I X["?"  W !!,"Pre ss the ret urn key to  return to  menu." G  RD
  6240   "RTN","PRC AATR",44,0 )
  6241    . Q
  6242   "RTN","PRC AATR",45,0 )
  6243    F TRAN=0: 0 S TRAN=$ O(^PRCA(43 3,"C",BILL ,TRAN)) Q: 'TRAN!$D(O UT)  D TLN
  6244   "RTN","PRC AATR",46,0 )
  6245    S X=$G(^P RCA(430,BI LL,7))
  6246   "RTN","PRC AATR",47,0 )
  6247    I '$D(OUT ) W !?65," ---------- -",!,?64," $",$J($P(X ,"^")+$P(X ,"^",2)+$P (X,"^",3)+ $P(X,"^",4 )+$P(X,"^" ,5),11,2)  D READ
  6248   "RTN","PRC AATR",48,0 )
  6249    Q
  6250   "RTN","PRC AATR",49,0 )
  6251   TLN ;Displ ay a trans action
  6252   "RTN","PRC AATR",50,0 )
  6253    N YR
  6254   "RTN","PRC AATR",51,0 )
  6255    I $Y+5>IO SL,COUNT D  READ G:$D (DTOUT)!$D (OUT) Q1 D  HDR
  6256   "RTN","PRC AATR",52,0 )
  6257    S COUNT=C OUNT+1,X=$ G(^PRCA(43 3,TRAN,1)) ,^TMP("PRC AATR",$J,C OUNT)=TRAN
  6258   "RTN","PRC AATR",53,0 )
  6259    W !,COUNT ,$S($P(^PR CA(433,TRA N,0),"^",4 )=1!$P(^(0 ),"^",10): "(I)",1:"" ),?8,TRAN, ?17
  6260   "RTN","PRC AATR",54,0 )
  6261    ;W $S($P( $G(^PRCA(4 30.3,+$P(X ,"^",2),0) ),"^",3)'= 17:$P($G(^ PRCA(433,T RAN,5)),"^ ",2),1:$P( $G(^(0))," ^"))
  6262   "RTN","PRC AATR",55,0 )
  6263    W $$GET1^ DIQ(433,"" _TRAN_",", 12) ; prca  4.5*315
  6264   "RTN","PRC AATR",56,0 )
  6265    ;  show d ecrease ad justments  as negativ e (patch 4 .5*172)
  6266   "RTN","PRC AATR",57,0 )
  6267    I $P(X,"^ ",2)=35 S: $P(X,"^",5 )>0 $P(X," ^",5)=-$P( X,"^",5)
  6268   "RTN","PRC AATR",58,0 )
  6269    W ?52,$S( +X:$$SLH^R CFN01(+X), 1:""),?65, $J($P(X,"^ ",5),11,2)
  6270   "RTN","PRC AATR",59,0 )
  6271    ;
  6272   "RTN","PRC AATR",60,0 )
  6273   Q1 Q
  6274   "RTN","PRC AATR",61,0 )
  6275   READ ;Read  a trans n umber
  6276   "RTN","PRC AATR",62,0 )
  6277    I IO'=IO( 0) G Q2
  6278   "RTN","PRC AATR",63,0 )
  6279   ASK W !!," Select 1-" ,COUNT,$S( PRCAPRT:"  or 'P' to  Print",1:"  to print" ) W:TRAN "  or return  to contin ue" R ": " ,X:DTIME I  X["^"!'$T  S:'$T DTO UT=1 S OUT =1 G Q2
  6280   "RTN","PRC AATR",64,0 )
  6281    I PRCAPRT ,X="P" S % ZIS="MQ" D  ^%ZIS D   S PRCAPRT= 0,PRCAIO=I O,PRCAIO(0 )=IO(0) G: 'POP ASK K  POP S OUT =1 G Q2
  6282   "RTN","PRC AATR",65,0 )
  6283    . I $D(IO ("S")) S P RCAIOS=ION  D ^%ZISC
  6284   "RTN","PRC AATR",66,0 )
  6285    . Q
  6286   "RTN","PRC AATR",67,0 )
  6287    I X["?" W  !!,"To se e detailed  informati on for a t ransaction  number, e nter the c orrespondi ng '#'",!, "next to t he transac tion.  (Ex : 1 or 1,3 )" G ASK
  6288   "RTN","PRC AATR",68,0 )
  6289    I X="" S: TRAN="" OU T=1 G Q2
  6290   "RTN","PRC AATR",69,0 )
  6291    S SEL=X
  6292   "RTN","PRC AATR",70,0 )
  6293    F X=1:1:$ L(SEL,",")  S Y=$P(SE L,",",X) I  Y'?1N.N!' $D(^TMP("P RCAATR",$J ,+Y)) W *7 ," ??" G R EAD
  6294   "RTN","PRC AATR",71,0 )
  6295    F PRCAATR X=1:1:$L(S EL,",") S  Y=$P(SEL," ,",PRCAATR X) D VT Q: $D(OUT)
  6296   "RTN","PRC AATR",72,0 )
  6297    S OUT=1
  6298   "RTN","PRC AATR",73,0 )
  6299   Q2 Q
  6300   "RTN","PRC AATR",74,0 )
  6301   VT ;View a  transacti on
  6302   "RTN","PRC AATR",75,0 )
  6303    N IOP,%ZI S,ZTRTN,ZT DESC,ZTSAV E,ZTDTH
  6304   "RTN","PRC AATR",76,0 )
  6305    S D0=$G(^ TMP("PRCAA TR",$J,+Y) ) G:'D0 Q3
  6306   "RTN","PRC AATR",77,0 )
  6307    I $D(IO(" Q")) S ZTS AVE("D0")= "",ZTSAVE( "PRCAIO")= IO,ZTSAVE( "PRCAIO(0) ")=IO(0),Z TRTN="DQ^P RCAATR",ZT DESC="AR T RANS PROFI LE",ZTDTH= $H D ^%ZTL OAD W !,"* ** Trans #  ",D0," RE QUEST QUEU ED ***" G  Q3
  6308   "RTN","PRC AATR",78,0 )
  6309    I IO'=IO( 0) W !,"OK , Printing  Transacti on # ",D0, " ..."
  6310   "RTN","PRC AATR",79,0 )
  6311    I $D(PRCA IOS) S IOP =PRCAIOS D  ^%ZIS
  6312   "RTN","PRC AATR",80,0 )
  6313    U IO D DQ  U IO(0)
  6314   "RTN","PRC AATR",81,0 )
  6315   Q3 Q
  6316   "RTN","PRC AATR",82,0 )
  6317   DQ ;
  6318   "RTN","PRC AATR",83,0 )
  6319    W @IOF S  X="",$P(X, "=",30)=""  W !,X," T RANSACTION  PROFILE " ,X,!!
  6320   "RTN","PRC AATR",84,0 )
  6321    K DXS D ^ PRCATR3 K  DXS S X=D0  D ENF^IBO LK
  6322   "RTN","PRC AATR",85,0 )
  6323   RD1 I $E(I OST)="C" R  !!,"PRESS  <RETURN>  TO CONTINU E: ",X:DTI ME S:'$T D TOUT=1,OUT =1 I X["?"  W !!,"Pre ss return  to view ne xt transac tion or to  continue"  G RD1
  6324   "RTN","PRC AATR",86,0 )
  6325    Q
  6326   "RTN","PRC AATR",87,0 )
  6327   DEB ;View  debtor
  6328   "RTN","PRC AATR",88,0 )
  6329    NEW PRCA
  6330   "RTN","PRC AATR",89,0 )
  6331    S PRCA=$P (^PRCA(430 ,BILL,0)," ^",9) I PR CA S PRCA= $P(^RCD(34 0,PRCA,0), "^") W "    ",$P($G(@ ("^"_$P(PR CA,";",2)_ +PRCA_",0) ")),"^")
  6332   "RTN","PRC AATR",90,0 )
  6333    Q
  6334   "RTN","PRC ABD")
  6335   0^9^B17322 985^B16869 095
  6336   "RTN","PRC ABD",1,0)
  6337   PRCABD ;SF -ISC/RSD-D ISPLAY/PRI NT BILL ;1 2/15/95  1 0:54
  6338   "RTN","PRC ABD",2,0)
  6339   V ;;4.5;Ac counts Rec eivable;** 29,57,104, 109,154,23 3,315**;20 -MAR-95;Bu ild 55
  6340   "RTN","PRC ABD",3,0)
  6341    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  6342   "RTN","PRC ABD",4,0)
  6343    ;
  6344   "RTN","PRC ABD",5,0)
  6345   DEV Q:'$D( PRCABT)  K  ZTSAVE S  %ZIS="QM"  D ^%ZIS Q: POP  G EN: IO=IO(0)
  6346   "RTN","PRC ABD",6,0)
  6347    I $D(IO(" Q")) S ZTR TN=$S(PRCA BT=3:"EN^P RCABD",1:" ^PRCABP"_P RCABT),ZTD TH=$H,ZTSA VE("D0")=" ",ZTSAVE(" PRCABT")=" ",ZTSAVE(" PRCADFM")= "" D ^%ZTL OAD G Q
  6348   "RTN","PRC ABD",7,0)
  6349    U IO
  6350   "RTN","PRC ABD",8,0)
  6351   EN Q:'$D(D 0)  S PRCA D0=$G(^PRC A(430,D0,0 )),PRCAD10 =$G(^(100) ),PRCAD14= $G(^(104))  G Q:PRCAD 0=""!(PRCA D10="")
  6352   "RTN","PRC ABD",9,0)
  6353    S $P(PRCA DUL,"-",80 )="-" W @I OF,"BILL # : ",$P(PRC AD0,U,1),? 30,"DATE:  " S Y=$P(P RCAD0,U,10 ) D DT W ? 60,"TYPE:  ",$P("1081 ^1080^1114 ","^",PRCA BT),!,"DEB TOR: ",?40 ,"BILLING  AGENCY: ", !
  6354   "RTN","PRC ABD",10,0)
  6355    S Y=+$P(P RCAD0,U,9) ,X=$S($D(^ RCD(340,Y, 0)):$P(^(0 ),U,1),1:" "),X(1)=""  S:X]"" X( 1)=$S($D(@ ("^"_$P(X, ";",2)_+X_ ",0)")):$P (^(0),U,1) ,1:"")
  6356   "RTN","PRC ABD",11,0)
  6357    S PRCADB= $S($D(^RCD (340,+$P(P RCAD0,"^", 9),0)):$P( ^(0),"^"), 1:"") S X= $$DADD^RCA MADD(PRCAD B) K PRCAD B S J=2 D  ADD
  6358   "RTN","PRC ABD",12,0)
  6359    S Y=+$P(P RCAD10,U,7 ),X(6)=$P( $G(^RC(342 .1,+Y,0)), "^"),X=$$S ADD^RCFN01 (+Y_";RC(3 42.1,"),J= 7 D ADD F  I=1:1:5 I  $D(X(I))!( $D(X(I+5)) ) W !?1 W: $D(X(I)) X (I) W ?41  W:$D(X(I+5 )) X(I+5)
  6360   "RTN","PRC ABD",13,0)
  6361    ;*****  P ROBABLY WA NT TO ENTE R ACCT LIN E INFO HER E   *****
  6362   "RTN","PRC ABD",14,0)
  6363    W !!,"CON TROL POINT  :"
  6364   "RTN","PRC ABD",15,0)
  6365    W ?17,$P( $G(^PRCA(4 30,D0,11)) ,U)
  6366   "RTN","PRC ABD",16,0)
  6367    W ! W:PRC ABT=1 !?40 ,"AGENCY L OCATION CO DE: ",$P(P RCAD10,U,3 ) W !,"APP ROVING OFF ICIAL: "
  6368   "RTN","PRC ABD",17,0)
  6369    I $P(PRCA D14,U,2)]" " S X=$P(P RCAD14,U,2 ),P=+PRCAD 14,DA=D0 D  DE^PRCASI G(.X,P,DA_ +$P(PRCAD0 ,U,3)) W " /ES/ ",X,"    DATE: "  S Y=$P(PR CAD14,U,3)  D DT
  6370   "RTN","PRC ABD",18,0)
  6371    W ! F I=0 :0 S I=$O( ^PRCA(430, D0,2,I)) Q :'I  I $D( ^(I,0)) S  X=^(0) W ! ,"FY: ",$P (X,U,1),?1 2,"APPR. S YMBOL: ",$ P($G(^PRCA (430,D0,11 )),U,17),? 50,"AMOUNT : ",$J($P( X,U,2),10, 2)
  6372   "RTN","PRC ABD",19,0)
  6373    D DES(D0, PRCABT)
  6374   "RTN","PRC ABD",20,0)
  6375    ;PRCA*4.5 *315 Print  Beneficia ry Travel  Notice
  6376   "RTN","PRC ABD",21,0)
  6377    D BENEPRT ^PRCABIL1
  6378   "RTN","PRC ABD",22,0)
  6379   Q D ^%ZISC  K DA,DIWL ,DIWR,DIWF ,FLN,I,J,P ,PRCAD,PRC AD0,PRCAD1 0,PRCAD14, PRCADFM,PR CADI,PRCAD I0,PRCADQ, PRCADUL,X, Y,Z,ZTDTH, ZTRTN,ZTSA VE,%ZIS Q
  6380   "RTN","PRC ABD",23,0)
  6381   DES(D0,PRC ABT) ;also  entry fro m letter r outine
  6382   "RTN","PRC ABD",24,0)
  6383    NEW DIWF, DIWL,DIWR, FLN,PRCAD, PRCADI,PRC ADI0,PRCAD Q
  6384   "RTN","PRC ABD",25,0)
  6385    W !! D HD R S (PRCAD Q,PRCADI)= 0
  6386   "RTN","PRC ABD",26,0)
  6387   DESL S PRC ADI=$O(^PR CA(430,D0, 101,PRCADI )) G:'PRCA DI DESQ S  PRCADI0=^( PRCADI,0), PRCAD=0,DI WL=1,DIWR= 50,DIWF=""  K ^UTILIT Y($J,"W"), FLN
  6388   "RTN","PRC ABD",27,0)
  6389    F  S PRCA D=$O(^PRCA (430,D0,10 1,PRCADI,1 ,PRCAD)) Q :'PRCAD  S  X=$S($D(^ (PRCAD,0)) :^(0),1:"" ) D ^DIWP
  6390   "RTN","PRC ABD",28,0)
  6391    I $D(^UTI LITY($J,"W ",DIWL)) F  I=0:0 S I =$O(^UTILI TY($J,"W", DIWL,I)) Q :'I  S DIW F=^(I,0) D :'$D(FLN)  FLN Q:PRCA DQ  I $D(F LN),DIWF'= "" W !,?11 ,DIWF
  6392   "RTN","PRC ABD",29,0)
  6393    I '$D(FLN ) D FLN
  6394   "RTN","PRC ABD",30,0)
  6395    K ^UTILIT Y($J,"W")  W !! G:'PR CADQ DESL
  6396   "RTN","PRC ABD",31,0)
  6397   DESQ Q
  6398   "RTN","PRC ABD",32,0)
  6399   FLN ;first  line of d etail afte r descript ion
  6400   "RTN","PRC ABD",33,0)
  6401    Q:$D(FLN)   D ASK Q: PRCADQ  S  FLN=1
  6402   "RTN","PRC ABD",34,0)
  6403    W:PRCABT= 2 $P(PRCAD I0,U,7),?1 1 S Y=$P(P RCADI0,U,1 ) D DT
  6404   "RTN","PRC ABD",35,0)
  6405    W ?11 I $ L($G(DIWF) )<25 W DIW F S DIWF=" "
  6406   "RTN","PRC ABD",36,0)
  6407    W:$P(PRCA DI0,U,3)]" " ?37,$J($ S($P(PRCAD I0,U,3)?1" .".N:"0"_$ P(PRCADI0, U,3),1:$P( PRCADI0,U, 3)),8)
  6408   "RTN","PRC ABD",37,0)
  6409    W:$P(PRCA DI0,U,4)]" " ?47,$J($ P(PRCADI0, U,4),12,4)  W ?62,$S( $D(^PRCD(4 20.5,+$P(P RCADI0,U,5 ),0)):$P(^ (0),U,1),1 :"")
  6410   "RTN","PRC ABD",38,0)
  6411    W ?65,$J( $P(PRCADI0 ,U,6),15,2 )
  6412   "RTN","PRC ABD",39,0)
  6413    Q
  6414   "RTN","PRC ABD",40,0)
  6415   ASK I $E(I OST,1,2)=" C-",($Y+4) >IOSL W !? 8,"ENTER ' ^' TO HALT : " R X:DT IME S:X["^ "!'$T PRCA DQ=1 Q:PRC ADQ  W @IO F D HDR Q
  6416   "RTN","PRC ABD",41,0)
  6417    I $E(IOST ,1,2)'="C- ",($Y+4)>I OSL W @IOF  D HDR
  6418   "RTN","PRC ABD",42,0)
  6419    Q
  6420   "RTN","PRC ABD",43,0)
  6421   HDR I PRCA BT=2 W !," ORDER NO." ,?11,"DATE ",?37,"QUA NTITY",?55 ,"COST",?6 1,"PER",?7 4,"AMOUNT"
  6422   "RTN","PRC ABD",44,0)
  6423    E  W !,"  DATE",?11, "DESCRIPTI ON",?37,"Q UANTITY",? 55,"COST", ?61,"PER", ?74,"AMOUN T"
  6424   "RTN","PRC ABD",45,0)
  6425    I '$D(PRC ADUL) S PR CADUL="",$ P(PRCADUL, "_",80)="_ "
  6426   "RTN","PRC ABD",46,0)
  6427    W !,PRCAD UL,! Q
  6428   "RTN","PRC ABD",47,0)
  6429   ADD F I=1: 1:4 S:I<4& ($P(X,U,I) ]"") X(J)= $P(X,U,I), J=J+1 I I= 4 S X(J)=$ P(X,U,4) S :$P(X,U,5) '="" X(J)= X(J)_", "_ $P(X,U,5)_ " "_$P(X,U ,6)
  6430   "RTN","PRC ABD",48,0)
  6431    Q
  6432   "RTN","PRC ABD",49,0)
  6433   DT Q:Y=""   W $$SLH^R CFN01(Y,"/ ")_" " Q
  6434   "RTN","PRC ABD",50,0)
  6435   EN1 ;PRINT /DISPLAY B ILL
  6436   "RTN","PRC ABD",51,0)
  6437   EN10 D SVC ^PRCABIL G  EN1Q:'$D( PRCAP("S") ) S DIC("S ")="S Z0=$ S($D(^PRCA (430.3,+$P (^(0),U,8) ,0)):$P(^( 0),U,3),1: 0) I Z0=20 5,$D(^PRCA (430,Y,100 )),+$P(^(1 00),U,2)=" _PRCAP("S" )
  6438   "RTN","PRC ABD",52,0)
  6439    D BILLN^P RCAUTL G E N1Q:'$D(PR CABN) S PR CABT=+^PRC A(430,PRCA BN,100) G  EN1Q:'PRCA BT S D0=PR CABN,PRCAD FM=1 D DEV ,EN1Q G EN 10
  6440   "RTN","PRC ABD",53,0)
  6441   EN1Q K D0, DIC,PRCA,P RCABN,PRCA DFM,PRCAP, PRCABT,PRC ATY,Z0,ZTS K Q
  6442   "RTN","PRC ABIL1")
  6443   0^8^B54581 879^B25296 320
  6444   "RTN","PRC ABIL1",1,0 )
  6445   PRCABIL1 ; SF-ISC/RSD  - ENTER B ILL INFO ; 10/16/96   7:04 PM
  6446   "RTN","PRC ABIL1",2,0 )
  6447   V ;;4.5;Ac counts Rec eivable;** 57,64,109, 147,220,27 6,315**;Ma r 20, 1995 ;Build 55
  6448   "RTN","PRC ABIL1",3,0 )
  6449    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  6450   "RTN","PRC ABIL1",4,0 )
  6451    ;
  6452   "RTN","PRC ABIL1",5,0 )
  6453   EN1 ;ENTER  NEW BILL
  6454   "RTN","PRC ABIL1",6,0 )
  6455    D ST Q:'%   N CP
  6456   "RTN","PRC ABIL1",7,0 )
  6457   EN10 D EN^ PRCABIL2 G  Q:'$D(PRC ABN) S $P( ^PRCA(430, PRCABN,0), "^",8)=$O( ^PRCA(430. 3,"AC",201 ,0)) D EN  G EN10
  6458   "RTN","PRC ABIL1",8,0 )
  6459   EN2 ;EDIT  BILL
  6460   "RTN","PRC ABIL1",9,0 )
  6461   EN20 D SVC ^PRCABIL Q :'$D(PRCAP ("S"))  S  DIC("S")=" S Z0=$S($D (^PRCA(430 .3,+$P(^(0 ),U,8),0)) :$P(^(0),U ,3),1:0) I  Z0>199,Z0 <210,'$P($ G(^PRCA(43 0,Y,3)),U, 3),+$P($G( ^(100)),U, 2)="_PRCAP ("S")
  6462   "RTN","PRC ABIL1",10, 0)
  6463    D BILLN^P RCAUTL G Q :'$D(PRCAB N) D EN G  EN20
  6464   "RTN","PRC ABIL1",11, 0)
  6465   EN4 ;CANCE L BILL
  6466   "RTN","PRC ABIL1",12, 0)
  6467   EN40 D SVC ^PRCABIL Q :'$D(PRCAP ("S"))  S  DIC("S")=" S Z0=$S($D (^PRCA(430 .3,+$P(^(0 ),U,8),0)) :$P(^(0),U ,3),1:0) I  Z0>199,Z0 <210,$D(^P RCA(430,Y, 100)),+$P( ^(100),U,2 )="_PRCAP( "S")
  6468   "RTN","PRC ABIL1",13, 0)
  6469    D BILLN^P RCAUTL G Q :'$D(PRCAB N)
  6470   "RTN","PRC ABIL1",14, 0)
  6471   YN S %=2 W  !,"  Sure  you want  to cancel  this Bill"  D YN^DICN
  6472   "RTN","PRC ABIL1",15, 0)
  6473    I %=0 W ! ,*7,"Answe r 'Yes' or  'No' " G  YN
  6474   "RTN","PRC ABIL1",16, 0)
  6475    I %'=1 D  Q G EN40
  6476   "RTN","PRC ABIL1",17, 0)
  6477    S $P(^PRC A(430,PRCA BN,0),"^", 14)=DT,$P( ^(0),"^",1 7)=DUZ,$P( ^(9),"^",6 )=$P(^(0), "^",8),PRC A("STATUS" )=$O(^PRCA (430.3,"AC ",210,0))  D UPSTATS^ PRCAUT2 K  PRCA("STAT US") D Q G  EN40
  6478   "RTN","PRC ABIL1",18, 0)
  6479   EN K PRCAD FM S DA=PR CABN D LCK  G Q:'$D(D A)
  6480   "RTN","PRC ABIL1",19, 0)
  6481    S DIE="^P RCA(430,"
  6482   "RTN","PRC ABIL1",20, 0)
  6483    I $D(RCAM END) S X=+ ^PRCA(430, DA,100) I  X?1N,X<4,X >0 G FORM
  6484   "RTN","PRC ABIL1",21, 0)
  6485    S DR="100 " D ^DIE G :X'?1N Q
  6486   "RTN","PRC ABIL1",22, 0)
  6487   FORM N PRC ACAT,PRCAF UND,PRCABE NE,PRCACA, PRCATYP,PR CAADD,PRCA NAD,PRCAAD 1D,PRCAAD2 D,PRCACD,P RCASTD
  6488   "RTN","PRC ABIL1",23, 0)
  6489    N PRCAZPD ,PRCAPHD,P RCANM,PRCA PH,PRCAADD 1,PRCAADD2 ,PRCACSZ,P RCACSZD,PR END
  6490   "RTN","PRC ABIL1",24, 0)
  6491    S PRCABEN E=0
  6492   "RTN","PRC ABIL1",25, 0)
  6493    S DR="[PR CA BILL "_ $P("1081^1 080^1114", "^",X)_"]" ,PRCABT=X  D ^DIE
  6494   "RTN","PRC ABIL1",26, 0)
  6495    S:$D(DUZ)  $P(^PRCA( 430,PRCABN ,9),U,8)=D UZ
  6496   "RTN","PRC ABIL1",27, 0)
  6497    S PRCACAT =$P(^PRCA( 430,PRCABN ,0),U,2)
  6498   "RTN","PRC ABIL1",28, 0)
  6499    ;PRCA*4.5 *315 New P rompt for  Beneficiar y Travel i f Category  is VENDOR
  6500   "RTN","PRC ABIL1",29, 0)
  6501    I PRCACAT =17 D  I $ G(PREND)=1  Q
  6502   "RTN","PRC ABIL1",30, 0)
  6503    .W !!
  6504   "RTN","PRC ABIL1",31, 0)
  6505    .S DIR("A ")="IS THI S FOR VETE RANS BENEF ICIARY TRA VEL? "
  6506   "RTN","PRC ABIL1",32, 0)
  6507    .S DIR("? ")="Please  answer Ye s or No."
  6508   "RTN","PRC ABIL1",33, 0)
  6509    .S DIR("B ")="NO",DI R(0)="YA^^ "
  6510   "RTN","PRC ABIL1",34, 0)
  6511    .D ^DIR K  DIR
  6512   "RTN","PRC ABIL1",35, 0)
  6513    .I '$D(Y( 0)) S PREN D=1 Q
  6514   "RTN","PRC ABIL1",36, 0)
  6515    .I Y(0)=" YES" D
  6516   "RTN","PRC ABIL1",37, 0)
  6517    ..S PRCAB ENE=1
  6518   "RTN","PRC ABIL1",38, 0)
  6519    ..S PRCAC A=$O(^RC(3 42.1,"B"," AGENT CASH IER",0))
  6520   "RTN","PRC ABIL1",39, 0)
  6521    ..S PRCAT YP=$P(^RC( 342.1,PRCA CA,0),U,2)
  6522   "RTN","PRC ABIL1",40, 0)
  6523    ..S PRCAA DD=$$SADD^ RCFN01(PRC ATYP)
  6524   "RTN","PRC ABIL1",41, 0)
  6525    ..I $G(PR CAADD)'=""  D
  6526   "RTN","PRC ABIL1",42, 0)
  6527    ...S PRCA NAD=$P(PRC AADD,U),PR CAAD1D=$P( PRCAADD,U, 2),PRCAAD2 D=$P(PRCAA DD,U,3),PR CACD=$P(PR CAADD,U,4)
  6528   "RTN","PRC ABIL1",43, 0)
  6529    ...S PRCA STD=$P(PRC AADD,U,5), PRCAZPD=$P (PRCAADD,U ,6),PRCAPH D=$P(PRCAA DD,U,7)
  6530   "RTN","PRC ABIL1",44, 0)
  6531    ...S PRCA CSZD=PRCAC D_", "_PRC ASTD_"  "_ PRCAZPD
  6532   "RTN","PRC ABIL1",45, 0)
  6533    ..S DIR(" A")="Enter  Agent Cas hier Name:  "
  6534   "RTN","PRC ABIL1",46, 0)
  6535    ..I $G(PR CANAD)'=""  S DIR("B" )=PRCANAD
  6536   "RTN","PRC ABIL1",47, 0)
  6537    ..S DIR(" ?")="Pleas e enter Ag ent Cashie r Name."
  6538   "RTN","PRC ABIL1",48, 0)
  6539    ..S DIR(0 )="FA^^"
  6540   "RTN","PRC ABIL1",49, 0)
  6541    ..D ^DIR  K DIR
  6542   "RTN","PRC ABIL1",50, 0)
  6543    ..I $G(Y) ["^" S PRE ND=1 Q
  6544   "RTN","PRC ABIL1",51, 0)
  6545    ..S PRCAN M=Y
  6546   "RTN","PRC ABIL1",52, 0)
  6547    ..S DIR(" A")="Enter  Agent Cas hier Phone  Number: "
  6548   "RTN","PRC ABIL1",53, 0)
  6549    ..I $G(PR CAPHD)'=""  S DIR("B" )=PRCAPHD
  6550   "RTN","PRC ABIL1",54, 0)
  6551    ..S DIR(" ?")="Pleas e enter a  phone numb er."
  6552   "RTN","PRC ABIL1",55, 0)
  6553    ..S DIR(0 )="FA^^"
  6554   "RTN","PRC ABIL1",56, 0)
  6555    ..D ^DIR  K DIR
  6556   "RTN","PRC ABIL1",57, 0)
  6557    ..I $G(Y) ["^" S PRE ND=1 Q
  6558   "RTN","PRC ABIL1",58, 0)
  6559    ..S PRCAP H=Y
  6560   "RTN","PRC ABIL1",59, 0)
  6561    ..S DIR(" A")="Enter  Agent Cas hier Addre ss Line 1:  "
  6562   "RTN","PRC ABIL1",60, 0)
  6563    ..I $G(PR CAAD1D)'=" " S DIR("B ")=PRCAAD1 D
  6564   "RTN","PRC ABIL1",61, 0)
  6565    ..S DIR(" ?")="Pleas e enter Ad dress Line  1."
  6566   "RTN","PRC ABIL1",62, 0)
  6567    ..S DIR(0 )="FA^^"
  6568   "RTN","PRC ABIL1",63, 0)
  6569    ..D ^DIR  K DIR
  6570   "RTN","PRC ABIL1",64, 0)
  6571    ..I $G(Y) ["^" S PRE ND=1 Q
  6572   "RTN","PRC ABIL1",65, 0)
  6573    ..S PRCAA DD1=Y
  6574   "RTN","PRC ABIL1",66, 0)
  6575    ..S DIR(" A")="Enter  Agent Cas hier Addre ss Line 2:  "
  6576   "RTN","PRC ABIL1",67, 0)
  6577    ..I $G(PR CAAD2D)'=" " S DIR("B ")=PRCAAD2 D
  6578   "RTN","PRC ABIL1",68, 0)
  6579    ..S DIR(" ?")="Pleas e enter Ad dress Line  2."
  6580   "RTN","PRC ABIL1",69, 0)
  6581    ..S DIR(0 )="FAO^^"
  6582   "RTN","PRC ABIL1",70, 0)
  6583    ..D ^DIR  K DIR
  6584   "RTN","PRC ABIL1",71, 0)
  6585    ..I $G(Y) ["^" S PRE ND=1 Q
  6586   "RTN","PRC ABIL1",72, 0)
  6587    ..S PRCAA DD2=Y
  6588   "RTN","PRC ABIL1",73, 0)
  6589    ..S DIR(" A")="Enter  Agent Cas hier City,  State  ZI P: "
  6590   "RTN","PRC ABIL1",74, 0)
  6591    ..I $G(PR CACSZD)'=" " S DIR("B ")=PRCACSZ D
  6592   "RTN","PRC ABIL1",75, 0)
  6593    ..S DIR(" ?")="Pleas e enter Ci ty, State   ZIP."
  6594   "RTN","PRC ABIL1",76, 0)
  6595    ..S DIR(0 )="FA^^"
  6596   "RTN","PRC ABIL1",77, 0)
  6597    ..D ^DIR  K DIR
  6598   "RTN","PRC ABIL1",78, 0)
  6599    ..I $G(Y) ["^" S PRE ND=1 Q
  6600   "RTN","PRC ABIL1",79, 0)
  6601    ..S PRCAC SZ=Y
  6602   "RTN","PRC ABIL1",80, 0)
  6603    I PRCACAT >39,PRCACA T<45 D
  6604   "RTN","PRC ABIL1",81, 0)
  6605    .S X=PRCA CAT,PRCAFU ND=$S(X=40 :"05",X=41 :"06",X=42 :"07",X=43 :"08",1:"1 0"),PRCAFU ND=5287_PR CAFUND
  6606   "RTN","PRC ABIL1",82, 0)
  6607    .S DR="25 9////"_"09 ;203////^S  X=PRCAFUN D"
  6608   "RTN","PRC ABIL1",83, 0)
  6609    .D ^DIE
  6610   "RTN","PRC ABIL1",84, 0)
  6611    .K Y,X
  6612   "RTN","PRC ABIL1",85, 0)
  6613    .Q
  6614   "RTN","PRC ABIL1",86, 0)
  6615    I PRCACAT =47 D  ;31 5
  6616   "RTN","PRC ABIL1",87, 0)
  6617    .N FUND
  6618   "RTN","PRC ABIL1",88, 0)
  6619    .S FUND=" 0160A1"
  6620   "RTN","PRC ABIL1",89, 0)
  6621    .S DR="25 9////"_"02 ;203////^S  X=FUND"
  6622   "RTN","PRC ABIL1",90, 0)
  6623    .D ^DIE
  6624   "RTN","PRC ABIL1",91, 0)
  6625    .K Y,X
  6626   "RTN","PRC ABIL1",92, 0)
  6627    .Q
  6628   "RTN","PRC ABIL1",93, 0)
  6629    I $P(^PRC A(430,PRCA BN,0),U,9) =""!('$D(^ (100))!('$ D(^(101))) ) D MESG W  !,"Bill i s incomple te and mus t be re-ed ited !",*7  G Q
  6630   "RTN","PRC ABIL1",94, 0)
  6631    D EN4^PRC ABIL S PRC AMT1=0,PRC AMTY=0,DIK ="^PRCA(43 0,PRCABN,2 ,"
  6632   "RTN","PRC ABIL1",95, 0)
  6633    F PRCAI=0 :0 S PRCAI =$O(^PRCA( 430,PRCABN ,2,PRCAI))  Q:'PRCAI   I $D(^(PR CAI,0)) S  X=^(0) I $ P(X,"^",8) ]"" S PRCA MT1=PRCAMT 1+$P(X,"^" ,8),PRCAMT Y=PRCAMTY+ 1
  6634   "RTN","PRC ABIL1",96, 0)
  6635    I 'PRCAMT 1 W !!,"Fi scal Year  Amount was  not enter ed !  Bill  is incomp lete",*7 G  Q
  6636   "RTN","PRC ABIL1",97, 0)
  6637    I PRCAMTY >1 W !!,"M ultiple Fi scal Years  are not a llowed at  this time  !",!,"Bill  is incomp lete and m ust be re- edited.",* 7 G Q
  6638   "RTN","PRC ABIL1",98, 0)
  6639    I PRCAMT1 '=PRCAMT,P RCABT'=1 W  !!,"Fisca l Year Amo unts do no t equal th e total bi ll amount  !",!,"Bill  is incomp lete and m ust be re- edited !", *7 G Q
  6640   "RTN","PRC ABIL1",99, 0)
  6641    I PRCAMT1 '=PRCAMT,P RCABT=1 D   ;
  6642   "RTN","PRC ABIL1",100 ,0)
  6643    . N DIE,D A,DR
  6644   "RTN","PRC ABIL1",101 ,0)
  6645    . S PRCAM T1=PRCAMT
  6646   "RTN","PRC ABIL1",102 ,0)
  6647    . S DIE=" ^PRCA(430, PRCABN,2,"
  6648   "RTN","PRC ABIL1",103 ,0)
  6649    . S DA(1) =PRCABN
  6650   "RTN","PRC ABIL1",104 ,0)
  6651    . S DA=+$ O(^PRCA(43 0,PRCABN,2 ,0))
  6652   "RTN","PRC ABIL1",105 ,0)
  6653    . S DR="1 ///"_PRCAM T1
  6654   "RTN","PRC ABIL1",106 ,0)
  6655    . QUIT:'D A
  6656   "RTN","PRC ABIL1",107 ,0)
  6657    . ; 
  6658   "RTN","PRC ABIL1",108 ,0)
  6659    . DO ^DIE
  6660   "RTN","PRC ABIL1",109 ,0)
  6661    ;
  6662   "RTN","PRC ABIL1",110 ,0)
  6663    S Y=$P(^P RCA(430,PR CABN,0),"^ ",9),Y=Y_" ^"_$P(^RCD (340,Y,0), "^",1)
  6664   "RTN","PRC ABIL1",111 ,0)
  6665    G:$P(Y,"; ",2)="DPT( "!($P(Y,"; ",2)="DIC( 36,") CONT
  6666   "RTN","PRC ABIL1",112 ,0)
  6667    S PRCANOD E=.11 S:$P (Y,";",2)= "DIC(4," P RCANODE=1  S PRCANODE ="^"_$P(Y, ";",2)_+$P (Y,"^",2)_ ","_PRCANO DE_")",PRC ANODE=$G(@ PRCANODE)
  6668   "RTN","PRC ABIL1",113 ,0)
  6669    I $P(PRCA NODE,"^",1 )="" S DR= $P(Y,"^",2 ),%=1 W !, " (No Stre et Address )  Edit De btor Addre ss: " D YN ^DICN,EN1^ RCAM(DR):% =1 K DIE,D R,DA
  6670   "RTN","PRC ABIL1",114 ,0)
  6671   CONT S Y=^ PRCA(430,P RCABN,0),$ P(Y,"^",3) =PRCAMT,PR CA("STATUS ")=$O(^PRC A(430.3,"A C",205,0)) ,^PRCA(430 ,PRCABN,0) =Y,$P(^PRC A(430,PRCA BN,7),"^") =PRCAMT
  6672   "RTN","PRC ABIL1",115 ,0)
  6673    I '$D(RCA MEND) S DI E="^PRCA(4 30,",DA=PR CABN,DR="8 ////"_PRCA ("STATUS") _"" D ^DIE  K DIE,DR, DA
  6674   "RTN","PRC ABIL1",116 ,0)
  6675   DISP S %=1 ,PRCADFM=1  W !,"   D isplay/Pri nt Bill:"
  6676   "RTN","PRC ABIL1",117 ,0)
  6677    K IOP D Y N^DICN
  6678   "RTN","PRC ABIL1",118 ,0)
  6679    I %=0 W ! ,*7,"Answe r 'Yes' or  'No' " G  DISP
  6680   "RTN","PRC ABIL1",119 ,0)
  6681    D ^PRCABD :%=1
  6682   "RTN","PRC ABIL1",120 ,0)
  6683   Q L -^PRCA (430,+$G(P RCABN),0)
  6684   "RTN","PRC ABIL1",121 ,0)
  6685    K %,%Y,A, B,C,D0,DA, DIC,DIE,DI K,DR,I,PRC A,PRCABC,P RCABN,PRCA BT,PRCADFM ,PRCAI,PRC AKCT,PRCAN M,PRCARN,P RCATIME,PR CAMT,PRCAM TY,PRCANM, PRCANODE,P RCAMT1,PRC AMT2,PRCAQ ,PRCAP,PRC AT,PRCATY, PRCAX,X,Y, Z0,ZRTN,ZT SK Q
  6686   "RTN","PRC ABIL1",122 ,0)
  6687   LCK L +^PR CA(430,DA, 0):0 I  Q
  6688   "RTN","PRC ABIL1",123 ,0)
  6689    W !,"ANOT HER USER I S EDITING  THIS ENTRY  !" K DA Q
  6690   "RTN","PRC ABIL1",124 ,0)
  6691   CP ;CONTRO L POINT LO OK-UP
  6692   "RTN","PRC ABIL1",125 ,0)
  6693    N DIC,PRC ,DIE,DA,DR ,X,Y,PRCSI P,PRCSI
  6694   "RTN","PRC ABIL1",126 ,0)
  6695    S PRC("SI TE")=$S($G (PRCA("SIT E")):PRCA( "SITE"),1: $$SITE^RCM SITE)
  6696   "RTN","PRC ABIL1",127 ,0)
  6697    S DIC("B" )=$P($G(^P RCA(430,PR CABN,11)), U)
  6698   "RTN","PRC ABIL1",128 ,0)
  6699    D CP^PRCS UT I '$G(P RC("CP"))  Q
  6700   "RTN","PRC ABIL1",129 ,0)
  6701    I PRC("CP ")<0 Q
  6702   "RTN","PRC ABIL1",130 ,0)
  6703    S $P(^PRC A(430,PRCA BN,11),U)= PRC("CP")
  6704   "RTN","PRC ABIL1",131 ,0)
  6705    Q
  6706   "RTN","PRC ABIL1",132 ,0)
  6707   BENEPRT ;P RCA*4.5*31 5 Benefici ary Travel  Notice of  Rights an d Responsi bilities
  6708   "RTN","PRC ABIL1",133 ,0)
  6709    I $G(PRCA BENE) D
  6710   "RTN","PRC ABIL1",134 ,0)
  6711    .N LINE,B ENELTR,DIW F,DIWL,DIW R,IOSLSAVE ,PRNT
  6712   "RTN","PRC ABIL1",135 ,0)
  6713    .S BENELT R=$O(^RC(3 43,"B","BE NEFICIARY  TRAVEL NOT ICE",0))
  6714   "RTN","PRC ABIL1",136 ,0)
  6715    .K ^UTILI TY($J) ;pr int main b ody text f rom 343
  6716   "RTN","PRC ABIL1",137 ,0)
  6717    .S ^UTILI TY($J,1)=" W "_IOF
  6718   "RTN","PRC ABIL1",138 ,0)
  6719    .S IOSLSA VE=IOSL,IO SL=140
  6720   "RTN","PRC ABIL1",139 ,0)
  6721    .U IO
  6722   "RTN","PRC ABIL1",140 ,0)
  6723    .W #
  6724   "RTN","PRC ABIL1",141 ,0)
  6725    .F LINE=0 :0 S LINE= $O(^RC(343 ,BENELTR,1 ,LINE)) Q: 'LINE  S X =$G(^(LINE ,0)) I X]" " W:($Y+2) >IOSL @IOF  S DIWL=1, DIWR=80,DI WF="N" D ^ DIWP
  6726   "RTN","PRC ABIL1",142 ,0)
  6727    .D ^DIWW  S:$G(PRNT) ="FL" PRNT =1 K ^UTIL ITY($J)
  6728   "RTN","PRC ABIL1",143 ,0)
  6729    .S IOSL=I OSLSAVE
  6730   "RTN","PRC ABIL1",144 ,0)
  6731    .W !,"Loc al Agent C ashier Con tact Infor mation"
  6732   "RTN","PRC ABIL1",145 ,0)
  6733    .W !,"  A gent Cashi er: ",$G(P RCANM)
  6734   "RTN","PRC ABIL1",146 ,0)
  6735    .W !,"    Office Pho ne: ",$G(P RCAPH)
  6736   "RTN","PRC ABIL1",147 ,0)
  6737    .W !,"Mai ling Addre ss: ",$G(P RCAADD1)
  6738   "RTN","PRC ABIL1",148 ,0)
  6739    .I $G(PRC AADD2)'=""  W !,"                   ",$G(PR CAADD2)
  6740   "RTN","PRC ABIL1",149 ,0)
  6741    .W !,"                   ",$G(P RCACSZ)
  6742   "RTN","PRC ABIL1",150 ,0)
  6743    Q
  6744   "RTN","PRC ABIL1",151 ,0)
  6745    ;
  6746   "RTN","PRC ABIL1",152 ,0)
  6747   ST D CKSIT E^PRCAUDT  S %=$D(PRC A("CKSITE" )) Q
  6748   "RTN","PRC ABIL1",153 ,0)
  6749   ST1 D SVC^ PRCABIL S  %=$S($D(PR CAP("S")): 1,1:0) Q:%
  6750   "RTN","PRC ABIL1",154 ,0)
  6751    K PRCAP Q
  6752   "RTN","PRC ABIL1",155 ,0)
  6753   DIP D SVC^ PRCABIL Q: '$D(PRCAP( "S"))
  6754   "RTN","PRC ABIL1",156 ,0)
  6755    ; PRCA*4. 5*276 - ad d '@' to B ILL NO. in  the 'BY'  paramter s o that pri ntout does  not show  it as a so rting fiel d.
  6756   "RTN","PRC ABIL1",157 ,0)
  6757    S FR=PRCA P("S")_",? ,@",TO=PRC AP("S")_", ?",L=0,DIC ="^PRCA(43 0,",FLDS=" [PRCA BILL  LIST]",BY ="@INTERNA L(SERVICE) ,@BILL NO. ,FORM TYPE " D EN1^DI P K BY,DHD ,DIC,FLDS, FR,L,PRCAP ,TO Q
  6758   "RTN","PRC ABIL1",158 ,0)
  6759   MESG I $P( ^PRCA(430, PRCABN,0), U,9)="" W  !,?3,"Debt or (or Pay er) data i s missing. "
  6760   "RTN","PRC ABIL1",159 ,0)
  6761    I '$D(^PR CA(430,PRC ABN,100))  W !,?3,"Se rvice (or  Section) ,  Form type  or Vouche r number d ata is mis sing."
  6762   "RTN","PRC ABIL1",160 ,0)
  6763    I '$D(^PR CA(430,PRC ABN,101))  W !,?3,"Da te of Char ge data do es not exi st."
  6764   "RTN","PRC ABIL1",161 ,0)
  6765    W ! Q
  6766   "RTN","PRC ABJV")
  6767   0^51^B3116 3592^B3034 3584
  6768   "RTN","PRC ABJV",1,0)
  6769   PRCABJV ;W ASH-ISC@AL TOONA,PA/T JK-FILE VE RIFICATION  FOR BACKG ROUND JOB  ;4/6/95  1 0:13 AM
  6770   "RTN","PRC ABJV",2,0)
  6771   V ;;4.5;Ac counts Rec eivable;** 1,48,63,11 4,141,170, 176,173,19 2,220,296, 310,315**; Mar 20, 19 95;Build 5 5
  6772   "RTN","PRC ABJV",3,0)
  6773    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  6774   "RTN","PRC ABJV",4,0)
  6775    ;;patch 1 92 changes  all occur rences of  CHAMPUS to  TRICARE
  6776   "RTN","PRC ABJV",5,0)
  6777   EN1(FILE,X 1,X2,ERROR ) ;
  6778   "RTN","PRC ABJV",6,0)
  6779    ;FILE IS  THE FILE N UMBER
  6780   "RTN","PRC ABJV",7,0)
  6781    ;X1 AND X 2 ARE 3 PA RT VARIABL ES SEPARAT ED BY SEMI -COLONS WI TH
  6782   "RTN","PRC ABJV",8,0)
  6783    ;THE FORM AT (X-REF  INDEX;NODE ;PIECE)
  6784   "RTN","PRC ABJV",9,0)
  6785    ;AN ERROR  ARRAY IS  SET IF VAL IDATION FA ILS
  6786   "RTN","PRC ABJV",10,0 )
  6787    NEW LT,CN T,I,I1,I2, I3,REC,IND ,ND,PC,DAT A,J,LN,FIL ENT
  6788   "RTN","PRC ABJV",11,0 )
  6789    S LT=$S(F ILE[430.3: "TRANST",F ILE[430.2: "CAT",1:"E VENT"),CNT =0
  6790   "RTN","PRC ABJV",12,0 )
  6791    F I=1,2 S  J=@("X"_I ),IND(I)=$ P(J,";"),N D(I)=$P(J, ";",2),PC( I)=$P(J,"; ",3)
  6792   "RTN","PRC ABJV",13,0 )
  6793    F I1=1:1  D  Q:(DATA (0)="EOF") !(ERROR)
  6794   "RTN","PRC ABJV",14,0 )
  6795       .S LN= $T(@LT+I1)  F I=3:1:6  S DATA(I- 3)=$P(LN," ;",I)
  6796   "RTN","PRC ABJV",15,0 )
  6797       .Q:DAT A(0)="EOF"
  6798   "RTN","PRC ABJV",16,0 )
  6799       .G RC: FILE<430
  6800   "RTN","PRC ABJV",17,0 )
  6801       .I '$D (^PRCA(FIL E,"B",DATA (0))) S ER ROR=1 Q
  6802   "RTN","PRC ABJV",18,0 )
  6803       .S REC =$O(^PRCA( FILE,"B",D ATA(0),0))  I 'REC S  ERROR=1 Q
  6804   "RTN","PRC ABJV",19,0 )
  6805       .I DAT A(3)'=REC  S ERROR=1  Q
  6806   "RTN","PRC ABJV",20,0 )
  6807       .I $P( ^PRCA(FILE ,REC,0),U) '=DATA(0)  S ERROR=1  Q
  6808   "RTN","PRC ABJV",21,0 )
  6809       .G CNT :X1=""
  6810   "RTN","PRC ABJV",22,0 )
  6811       .F I2= 1,2 D  Q:E RROR  I I2 =1,X2="" Q
  6812   "RTN","PRC ABJV",23,0 )
  6813          ..I  '$D(^PRCA (FILE,IND( I2),DATA(I 2))) S ERR OR=1 G Q2
  6814   "RTN","PRC ABJV",24,0 )
  6815          ..;   do not c heck if ca tegory num ber is a z ero
  6816   "RTN","PRC ABJV",25,0 )
  6817          ..I  I2=1,DATA (1)'=0,$O( ^PRCA(FILE ,IND(I2),D ATA(I2),0) )'=REC S E RROR=1 G Q 2
  6818   "RTN","PRC ABJV",26,0 )
  6819          ..I  $P(^PRCA( FILE,REC,N D(I2)),U,P C(I2))'=DA TA(I2) S E RROR=1
  6820   "RTN","PRC ABJV",27,0 )
  6821   Q2 ..Q
  6822   "RTN","PRC ABJV",28,0 )
  6823   CNT .Q:ERR OR
  6824   "RTN","PRC ABJV",29,0 )
  6825       .S CNT =CNT+1
  6826   "RTN","PRC ABJV",30,0 )
  6827   Q1 .Q
  6828   "RTN","PRC ABJV",31,0 )
  6829   RC .I '$D( ^RC(FILE," B",DATA(0) )) S ERROR =1 Q
  6830   "RTN","PRC ABJV",32,0 )
  6831       .S REC =$O(^RC(FI LE,"B",DAT A(0),0)) I  'REC S ER ROR=1 Q
  6832   "RTN","PRC ABJV",33,0 )
  6833       .I DAT A(3)'=REC  S ERROR=1  Q
  6834   "RTN","PRC ABJV",34,0 )
  6835       .I $P( ^RC(FILE,R EC,0),U)'= DATA(0) S  ERROR=1 Q
  6836   "RTN","PRC ABJV",35,0 )
  6837       .G CNT :X1=""
  6838   "RTN","PRC ABJV",36,0 )
  6839       .F I3= 1,2 D  Q:E RROR  I I3 =1,X2="" Q
  6840   "RTN","PRC ABJV",37,0 )
  6841          ..I  '$D(^RC(F ILE,IND(I3 ),DATA(I3) )) S ERROR =1 G Q3
  6842   "RTN","PRC ABJV",38,0 )
  6843          ..I  $O(^RC(FI LE,IND(I3) ,DATA(I3), 0))'=REC S  ERROR=1 G  Q3
  6844   "RTN","PRC ABJV",39,0 )
  6845          ..I  $P(^RC(FI LE,REC,ND( I3)),U,PC( I3))'=DATA (I3) S ERR OR=1
  6846   "RTN","PRC ABJV",40,0 )
  6847   Q3 ..Q
  6848   "RTN","PRC ABJV",41,0 )
  6849       .G CNT
  6850   "RTN","PRC ABJV",42,0 )
  6851    I FILE>42 9.99,$P(^P RCA(FILE,0 ),U,4)'=CN T S ERROR= 1 G EXIT
  6852   "RTN","PRC ABJV",43,0 )
  6853    G EXIT:FI LE>429.99
  6854   "RTN","PRC ABJV",44,0 )
  6855    I $P(^RC( FILE,0),U, 4)'=CNT S  ERROR=1
  6856   "RTN","PRC ABJV",45,0 )
  6857   EXIT Q:'ER ROR
  6858   "RTN","PRC ABJV",46,0 )
  6859    S FILENT= $S(FILE>42 9.99:$P(^P RCA(FILE,0 ),U,4),1:$ P(^RC(FILE ,0),U,4))
  6860   "RTN","PRC ABJV",47,0 )
  6861    S ERROR(1 )="An erro r has been  detected  in the "_$ P(^DIC(FIL E,0),U)_"  File."
  6862   "RTN","PRC ABJV",48,0 )
  6863    I DATA(0) ="EOF" S E RROR(2)="T here are t oo many en tries in y our file."
  6864   "RTN","PRC ABJV",49,0 )
  6865    I DATA(0) '="EOF" S  ERROR(2)=" The "_DATA (0)_" Entr y in your  file is mi ssing or c orrupted."
  6866   "RTN","PRC ABJV",50,0 )
  6867    Q
  6868   "RTN","PRC ABJV",51,0 )
  6869   TRANST ;
  6870   "RTN","PRC ABJV",52,0 )
  6871    ;;ACTIVE; 102;A;16
  6872   "RTN","PRC ABJV",53,0 )
  6873    ;;ADD (AM END);302;A D;37
  6874   "RTN","PRC ABJV",54,0 )
  6875    ;;ADMIN.C OST CHARGE ;12;AC;12
  6876   "RTN","PRC ABJV",55,0 )
  6877    ;;AMEND;3 03;AM;38
  6878   "RTN","PRC ABJV",56,0 )
  6879    ;;AMENDED  BILL;110; AB;33
  6880   "RTN","PRC ABJV",57,0 )
  6881    ;;ARCHIVE D;115;XX;4 9
  6882   "RTN","PRC ABJV",58,0 )
  6883    ;;BILL IN COMPLETE;2 01;BI;27
  6884   "RTN","PRC ABJV",59,0 )
  6885    ;;CANCELL ATION;111; CN;39
  6886   "RTN","PRC ABJV",60,0 )
  6887    ;;CANCELL ED BILL;21 0;CB;26
  6888   "RTN","PRC ABJV",61,0 )
  6889    ;;CASH CO LLECTION B Y RC/DOJ;7 ;CJ;7
  6890   "RTN","PRC ABJV",62,0 )
  6891    ;;CHARGE  SUSPENDED; 19;CS;47
  6892   "RTN","PRC ABJV",63,0 )
  6893    ;;COLLECT ED/CLOSED; 108;CC;22
  6894   "RTN","PRC ABJV",64,0 )
  6895    ;;COMMENT ;17;CM;45
  6896   "RTN","PRC ABJV",65,0 )
  6897    ;;DEBIT V OUCHER (SF  5515);30; DV;30
  6898   "RTN","PRC ABJV",66,0 )
  6899    ;;DECREAS E ADJUSTME NT;21;DA;3 5
  6900   "RTN","PRC ABJV",67,0 )
  6901    ;;DELETE  (AMEND);30 1;DL;36
  6902   "RTN","PRC ABJV",68,0 )
  6903    ;;EXEMPT  INT/ADM. C OST;14;E;1 4
  6904   "RTN","PRC ABJV",69,0 )
  6905    ;;IN-ACTI VE;103;IA; 17
  6906   "RTN","PRC ABJV",70,0 )
  6907    ;;INCOMPL ETE;101;IN ;15
  6908   "RTN","PRC ABJV",71,0 )
  6909    ;;INCREAS E ADJUSTME NT;1;AJ;1
  6910   "RTN","PRC ABJV",72,0 )
  6911    ;;INTERES T/ADM. CHA RGE;13;IC; 13
  6912   "RTN","PRC ABJV",73,0 )
  6913    ;;MARSHAL /COURT COS T;15;ML;24
  6914   "RTN","PRC ABJV",74,0 )
  6915    ;;NEW BIL L;104;N;18
  6916   "RTN","PRC ABJV",75,0 )
  6917    ;;OLD BIL L;106;OB;2 8
  6918   "RTN","PRC ABJV",76,0 )
  6919    ;;OPEN;11 2;OP;42
  6920   "RTN","PRC ABJV",77,0 )
  6921    ;;PAYMENT  (IN FULL) ;20;PF;34
  6922   "RTN","PRC ABJV",78,0 )
  6923    ;;PAYMENT  (IN PART) ;2;PP;2
  6924   "RTN","PRC ABJV",79,0 )
  6925    ;;PENDING  APPROVAL; 205;PA;20
  6926   "RTN","PRC ABJV",80,0 )
  6927    ;;PENDING  ARCHIVE;1 14;X;48
  6928   "RTN","PRC ABJV",81,0 )
  6929    ;;PENDING  CALM CODE ;107;PC;21
  6930   "RTN","PRC ABJV",82,0 )
  6931    ;;RE-ESTA BLISH;250; RW;43
  6932   "RTN","PRC ABJV",83,0 )
  6933    ;;REESTAB LISH TO RC /DOJ;5;RR; 5
  6934   "RTN","PRC ABJV",84,0 )
  6935    ;;REFER T O RC;3;RC; 3
  6936   "RTN","PRC ABJV",85,0 )
  6937    ;;REFER T O DOJ;4;RJ ;4
  6938   "RTN","PRC ABJV",86,0 )
  6939    ;;REFUND  REVIEW;113 ;PR;44
  6940   "RTN","PRC ABJV",87,0 )
  6941    ;;REFUNDE D;120;RF;4 1
  6942   "RTN","PRC ABJV",88,0 )
  6943    ;;REPAYME NT PLAN;16 ;RP;25
  6944   "RTN","PRC ABJV",89,0 )
  6945    ;;RETURNE D BY RC/DO J;6;RD;6
  6946   "RTN","PRC ABJV",90,0 )
  6947    ;;RETURNE D FOR AMEN DMENT;230; RA;32
  6948   "RTN","PRC ABJV",91,0 )
  6949    ;;RETURNE D FROM AR  (NEW);220; RT;31
  6950   "RTN","PRC ABJV",92,0 )
  6951    ;;SUSPEND ED;240;SP; 40
  6952   "RTN","PRC ABJV",93,0 )
  6953    ;;SUSPENS E;105;S;19
  6954   "RTN","PRC ABJV",94,0 )
  6955    ;;TERM.BY  COMPROMIS E;9;TC;9
  6956   "RTN","PRC ABJV",95,0 )
  6957    ;;TERM.BY  RC/DOJ;29 ;TJ;29
  6958   "RTN","PRC ABJV",96,0 )
  6959    ;;TERM.BY  FIS.OFFIC ER;8;TO;8
  6960   "RTN","PRC ABJV",97,0 )
  6961    ;;UNSUSPE NDED;18;US ;46
  6962   "RTN","PRC ABJV",98,0 )
  6963    ;;WAIVED  IN FULL;10 ;WF;10
  6964   "RTN","PRC ABJV",99,0 )
  6965    ;;WAIVED  IN PART;11 ;WP;11
  6966   "RTN","PRC ABJV",100, 0)
  6967    ;;WRITE-O FF;109;WO; 23
  6968   "RTN","PRC ABJV",101, 0)
  6969    ;;EOF
  6970   "RTN","PRC ABJV",102, 0)
  6971   CAT ;patch  192 - ISC -0502-N280 3 change C hampus to  Tricare
  6972   "RTN","PRC ABJV",103, 0)
  6973    ;;ADULT D AY HEALTH  CARE;40;AD ;33
  6974   "RTN","PRC ABJV",104, 0)
  6975    ;;C (MEAN S TEST);24 ;C;18
  6976   "RTN","PRC ABJV",105, 0)
  6977    ;;TRICARE ;37;T1;30
  6978   "RTN","PRC ABJV",106, 0)
  6979    ;;TRICARE  PATIENT;3 8;T2;31
  6980   "RTN","PRC ABJV",107, 0)
  6981    ;;TRICARE  THIRD PAR TY;39;T3;3 2
  6982   "RTN","PRC ABJV",108, 0)
  6983    ;;CHAMPVA ;36;CV;29
  6984   "RTN","PRC ABJV",109, 0)
  6985    ;;CHAMPVA  SUBSISTEN CE;34;CS;2 7
  6986   "RTN","PRC ABJV",110, 0)
  6987    ;;CHAMPVA  THIRD PAR TY;35;CT;2 8
  6988   "RTN","PRC ABJV",111, 0)
  6989    ;;COMP &  PEN PROCEE DS;8;CM;43
  6990   "RTN","PRC ABJV",112, 0)
  6991    ;;CRIME O F PER.VIO. ;27;CP;8
  6992   "RTN","PRC ABJV",113, 0)
  6993    ;;CURRENT  EMP.;14;C E;16
  6994   "RTN","PRC ABJV",114, 0)
  6995    ;;CWT PRO CEEDS;7;CW ;42
  6996   "RTN","PRC ABJV",115, 0)
  6997    ;;DOMICIL IARY;41;DO ;34
  6998   "RTN","PRC ABJV",116, 0)
  6999    ;;EMERGEN CY/HUMANIT ARIAN;25;H ;2
  7000   "RTN","PRC ABJV",117, 0)
  7001    ;;EMERGEN CY/HUMANIT ARIAN REIM B.;48;HR;4 6
  7002   "RTN","PRC ABJV",118, 0)
  7003    ;;ENHANCE D USE LEAS E PROCEEDS ;10;EP;44
  7004   "RTN","PRC ABJV",119, 0)
  7005    ;;EX-EMPL OYEE;13;E; 15
  7006   "RTN","PRC ABJV",120, 0)
  7007    ;;FEDERAL  AGENCIES- REFUND;15; F2;13
  7008   "RTN","PRC ABJV",121, 0)
  7009    ;;FEDERAL  AGENCIES- REIMB.;16; F1;14
  7010   "RTN","PRC ABJV",122, 0)
  7011    ;;FEE REI MB INS;47; FR;45
  7012   "RTN","PRC ABJV",123, 0)
  7013    ;;GERIATR IC EVAL-IN STITUTIONA L;44;GE;37
  7014   "RTN","PRC ABJV",124, 0)
  7015    ;;GERIATR IC EVAL-NO N-INSTITUT ION;45;GN; 38
  7016   "RTN","PRC ABJV",125, 0)
  7017    ;;HOSPITA L CARE (NS C);1;HC;5
  7018   "RTN","PRC ABJV",126, 0)
  7019    ;;HOSPITA L CARE PER  DIEM;32;H P;25
  7020   "RTN","PRC ABJV",127, 0)
  7021    ;;INELIGI BLE HOSP.; 20;I;1
  7022   "RTN","PRC ABJV",128, 0)
  7023    ;;INELIGI BLE HOSP.  REIMB.;49; IR;47
  7024   "RTN","PRC ABJV",129, 0)
  7025    ;;INTERAG ENCY;19;IA ;20
  7026   "RTN","PRC ABJV",130, 0)
  7027    ;;MEDICAR E;28;MC;21
  7028   "RTN","PRC ABJV",131, 0)
  7029    ;;MILITAR Y;17;M;12
  7030   "RTN","PRC ABJV",132, 0)
  7031    ;;NO-FAUL T AUTO ACC .;26;NA;7
  7032   "RTN","PRC ABJV",133, 0)
  7033    ;;NURSING  HOME CARE  PER DIEM; 31;NP;24
  7034   "RTN","PRC ABJV",134, 0)
  7035    ;;NURSING  HOME CARE (NSC);3;NC ;3
  7036   "RTN","PRC ABJV",135, 0)
  7037    ;;NURSING  HOME CARE -LTC;46;NL ;39
  7038   "RTN","PRC ABJV",136, 0)
  7039    ;;NURSING  HOME PROC EEDS;5;NH; 40
  7040   "RTN","PRC ABJV",137, 0)
  7041    ;;OUTPATI ENT CARE(N SC);2;OC;4
  7042   "RTN","PRC ABJV",138, 0)
  7043    ;;PARKING  FEES;6;PF ;41
  7044   "RTN","PRC ABJV",139, 0)
  7045    ;;PREPAYM ENT;33;PP; 26
  7046   "RTN","PRC ABJV",140, 0)
  7047    ;;REIMBUR S.HEALTH I NS.;21;RI; 9
  7048   "RTN","PRC ABJV",141, 0)
  7049    ;;RESPITE  CARE-INST ITUTIONAL; 42;RC;35
  7050   "RTN","PRC ABJV",142, 0)
  7051    ;;RESPITE  CARE-NON- INSTITUTIO NAL;43;RN; 36
  7052   "RTN","PRC ABJV",143, 0)
  7053    ;;RX CO-P AYMENT/NSC  VET;30;PN ;23
  7054   "RTN","PRC ABJV",144, 0)
  7055    ;;RX CO-P AYMENT/SC  VET;29;PS; 22
  7056   "RTN","PRC ABJV",145, 0)
  7057    ;;SHARING  AGREEMENT S;18;SA;19
  7058   "RTN","PRC ABJV",146, 0)
  7059    ;;TORT FE ASOR;22;TF ;10
  7060   "RTN","PRC ABJV",147, 0)
  7061    ;;VENDOR; 11;V;17
  7062   "RTN","PRC ABJV",148, 0)
  7063    ;;WORKMAN 'S COMP.;2 3;WC;6
  7064   "RTN","PRC ABJV",149, 0)
  7065    ;;EOF
  7066   "RTN","PRC ABJV",150, 0)
  7067   EVENT ;
  7068   "RTN","PRC ABJV",151, 0)
  7069    ;;CASH PA YMENT;6;;6
  7070   "RTN","PRC ABJV",152, 0)
  7071    ;;CHECK/M O PAYMENT; 4;;4
  7072   "RTN","PRC ABJV",153, 0)
  7073    ;;COMMENT ;1;;1
  7074   "RTN","PRC ABJV",154, 0)
  7075    ;;CREDIT  CARD PAYME NT;7;;7
  7076   "RTN","PRC ABJV",155, 0)
  7077    ;;DEPT OF  JUSTICE P AYMENT;5;; 5
  7078   "RTN","PRC ABJV",156, 0)
  7079    ;;REGIONA L COUNSEL  PAYMENT;3; ;3
  7080   "RTN","PRC ABJV",157, 0)
  7081    ;;FOLLOW- UP LETTER; 10;;10
  7082   "RTN","PRC ABJV",158, 0)
  7083    ;;IRS PAY MENT;11;;1 1
  7084   "RTN","PRC ABJV",159, 0)
  7085    ;;PATIENT  STATEMENT ;2;;2
  7086   "RTN","PRC ABJV",160, 0)
  7087    ;;TDA PAY MENT;8;;8
  7088   "RTN","PRC ABJV",161, 0)
  7089    ;;UB PRIN TED;9;;9
  7090   "RTN","PRC ABJV",162, 0)
  7091    ;;LOCKBOX ;12;;12
  7092   "RTN","PRC ABJV",163, 0)
  7093    ;;TOP PAY MENT;13;;1 3
  7094   "RTN","PRC ABJV",164, 0)
  7095    ;;EDI LOC KBOX;14;;1 4
  7096   "RTN","PRC ABJV",165, 0)
  7097    ;;ADMINIS TRATIVE OF FSET;15;;1 5
  7098   "RTN","PRC ABJV",166, 0)
  7099    ;;PRIVATE  COLLECTIO N AGENCY;1 6;;16
  7100   "RTN","PRC ABJV",167, 0)
  7101    ;;EOF
  7102   "RTN","PRC ACM")
  7103   0^42^B2461 7130^B2324 1294
  7104   "RTN","PRC ACM",1,0)
  7105   PRCACM ;WA SH-ISC@ALT OONA,PA/RG Y-COMMENT  ADJUSTMENT  TRANSACTI ON ;6/2/95   2:41 PM
  7106   "RTN","PRC ACM",2,0)
  7107    ;;4.5;Acc ounts Rece ivable;**8 ,67,125,16 9,254,315* *;Mar 20,  1995;Build  55
  7108   "RTN","PRC ACM",3,0)
  7109    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  7110   "RTN","PRC ACM",4,0)
  7111    ;DBIA 382 0-A used f or direct  global rea d into fil e 399.
  7112   "RTN","PRC ACM",5,0)
  7113    ;
  7114   "RTN","PRC ACM",6,0)
  7115    ;This is  a routine  for adjust ment trans action.
  7116   "RTN","PRC ACM",7,0)
  7117    NEW PRCAE N,PRCAA1,D R,DIE,DA,D 0,PRCAD,RC ASK,PRCAA2 ,DIROUT,DI RUT,DIR,DU OUT,PRCA,P RCATY
  7118   "RTN","PRC ACM",8,0)
  7119    I '$G(GOT BILL) N PR CABN
  7120   "RTN","PRC ACM",9,0)
  7121   ADJUST D B EGIN G:('$ D(PRCABN)) !('$D(PRCA EN)) Q
  7122   "RTN","PRC ACM",10,0)
  7123    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0) G  Q:PRCAA1'> 0 S PRCAA2 =$P(^(0),U ,3) W !
  7124   "RTN","PRC ACM",11,0)
  7125   DIE S DR=" [PRCA COMM ENT]",DIE= "^PRCA(433 ,",DA=PRCA EN D ^DIE  K DIE,DR,D A
  7126   "RTN","PRC ACM",12,0)
  7127    I $P($G(^ PRCA(433,P RCAEN,5)), "^",2)=""! '$P(^PRCA( 433,PRCAEN ,1),"^") S  PRCACOMM= "TRANSACTI ON INCOMPL ETE" D DEL ETE^PRCAWO 1 K PRCACO MM G:$D(DT OUT)!($G(G OTBILL)) Q  G ADJUST
  7128   "RTN","PRC ACM",13,0)
  7129    W ! W:$D( IOF) @IOF  S D0=PRCAE N K DXS D  ^PRCATO4 K  DXS
  7130   "RTN","PRC ACM",14,0)
  7131    I $P($G(^ PRCA(433,P RCAEN,1)), "^")>$P($G (^(5)),"^" ,3),$P($G( ^(5)),"^", 3) W !!,*7 ,"You ente red a date  of follow -up before  the date  of contact !" S PRCAC OMM="INVAL ID FOLLOW- UP DATE" D  DELETE^PR CAWO1 K PR CACOMM G A DJUST
  7132   "RTN","PRC ACM",15,0)
  7133   ASK S %=2  W !!,"Is t his correc t" D YN^DI CN I %=0 W  !,"Answer  'Y' or 'Y ES' if thi s data is  correct, a nswer 'N'  or 'NO' if  not",! G  ASK
  7134   "RTN","PRC ACM",16,0)
  7135    I (%<0)!( %=2) S PRC ACOMM="USE R CANCELED " D DELETE ^PRCAWO1 K  PRCACOMM  G ADJUST
  7136   "RTN","PRC ACM",17,0)
  7137   DONE I '$D (PRCAD("DE LETE")) S  RCASK=1 D  TRANUP^PRC AUTL,UPPRI N^PRCADJ
  7138   "RTN","PRC ACM",18,0)
  7139    I $P($G(^ RCD(340,+$ P(^PRCA(43 0,PRCABN,0 ),"^",9),0 )),"^")["; DPT(" D
  7140   "RTN","PRC ACM",19,0)
  7141    .S $P(^PR CA(433,PRC AEN,0),"^" ,10)=1
  7142   "RTN","PRC ACM",20,0)
  7143    .S DIR(0) ="Y",DIR(" A")="Shoul d the BRIE F COMMENT  print on t he patient  statement ",DIR("B") ="NO" D ^D IR K DIR
  7144   "RTN","PRC ACM",21,0)
  7145    .I Y=1 S  DIR(0)="Y" ,DIR("A")= "Are you S URE this B RIEF COMME NT should  appear on  the patien t statemen t",DIR("B" )="NO" D ^ DIR K DIR  I Y=1 D
  7146   "RTN","PRC ACM",22,0)
  7147    ..W !!,*7 ,"*** OK,  This comme nt will ap pear on th e patient' s statemen t! ***",!, "(If you c hange your  mind, use  the optio n Remove/A dd Comment  From Pati ent Statem ent)",!
  7148   "RTN","PRC ACM",23,0)
  7149    ..S $P(^P RCA(433,PR CAEN,0),"^ ",10)=""
  7150   "RTN","PRC ACM",24,0)
  7151    ..Q
  7152   "RTN","PRC ACM",25,0)
  7153    .Q
  7154   "RTN","PRC ACM",26,0)
  7155    I $G(GOTB ILL) G Q     ; PRCA*4 .5*315
  7156   "RTN","PRC ACM",27,0)
  7157    G ADJUST
  7158   "RTN","PRC ACM",28,0)
  7159   Q Q
  7160   "RTN","PRC ACM",29,0)
  7161   EN1 Q:'$D( PRCABN)
  7162   "RTN","PRC ACM",30,0)
  7163    NEW X
  7164   "RTN","PRC ACM",31,0)
  7165    F X=0:0 S  X=$O(^PRC A(433,"C", PRCABN,X))  Q:'X  I $ P($G(^PRCA (433,X,1)) ,"^",4) I  $P(^(1),"^ ",2)=1!($P (^(1),"^", 2)=35) S P RCAQNM=$P( ^(1),"^",4 )+1
  7166   "RTN","PRC ACM",32,0)
  7167    Q
  7168   "RTN","PRC ACM",33,0)
  7169   ASK1 ;ASK  FOR STATUS
  7170   "RTN","PRC ACM",34,0)
  7171    NEW DTOUT ,DUOUT,DIR UT,DIR,DIR OUT
  7172   "RTN","PRC ACM",35,0)
  7173    S DIR("A" )="Change  'BILL' sta tus to?",D IR("B")="C ANCELLED", DIR(0)="SB ^1:CANCELL ED;2:COLLE CTED/CLOSE D;" D ^DIR  K DIR
  7174   "RTN","PRC ACM",36,0)
  7175    I Y=2 S P RCA("STATU S")=$O(^PR CA(430.3," AC",108,0) )
  7176   "RTN","PRC ACM",37,0)
  7177    Q
  7178   "RTN","PRC ACM",38,0)
  7179   RPT ;
  7180   "RTN","PRC ACM",39,0)
  7181    NEW %DT,B EG,END,DIC ,L,FR,TO,F LDS,PRCACM ,POP,PRCAD EV
  7182   "RTN","PRC ACM",40,0)
  7183   ST W !! S  %DT="AEX", %DT("A")=" Follow-up  Date(s) Fr om: " D ^% DT G:Y<0 R EPQ S BEG= Y
  7184   "RTN","PRC ACM",41,0)
  7185    S %DT="AE X",%DT("A" )="Follow- up Date(s)    To: " D  ^%DT G:Y< 0 REPQ S E ND=Y
  7186   "RTN","PRC ACM",42,0)
  7187    I BEG>END  W !!,*7,"   (Ending  date must  be greater  than Star t date.)"  G ST
  7188   "RTN","PRC ACM",43,0)
  7189    S %ZIS="M Q" D ^%ZIS  G:POP REP Q S PRCADE V=ION_";"_ IOST_";"_I OM_";"_IOS L_";"_$G(I O("DOC"))
  7190   "RTN","PRC ACM",44,0)
  7191    I $D(IO(" Q")) S Y=$ $TI() G:Y< 0 REPQ F P RCACM=1,2  S ZTDTH=$H ,ZTRTN="DQ "_PRCACM_" ^PRCACM",Z TSAVE("BEG ")="",ZTSA VE("PRCADE V")="",ZTS AVE("END") ="",ZTDESC ="Comment  Follow-up  List" D ^% ZTLOAD G R EPQ:PRCACM =2
  7192   "RTN","PRC ACM",45,0)
  7193    D DQ1,DQ2 :'$D(DTOUT )
  7194   "RTN","PRC ACM",46,0)
  7195   REPQ Q
  7196   "RTN","PRC ACM",47,0)
  7197   DQ1 ;
  7198   "RTN","PRC ACM",48,0)
  7199    S IOP=PRC ADEV,DIC=" ^PRCA(433, ",L=0,BY=" [PRCA FOLL OW-UP]",FL DS="[PRCA  FOLLOW-UP] ",FR=BEG,T O=END D EN 1^DIP
  7200   "RTN","PRC ACM",49,0)
  7201    D ^%ZISC  K IOP
  7202   "RTN","PRC ACM",50,0)
  7203    I $E(IOST )="C" W !, *7,"OK, fi rst part o f report c omplete... ",!,"press  return to  continue:  " R X:DTI ME W @IOF  S:X["^"!'$ T DTOUT=1
  7204   "RTN","PRC ACM",51,0)
  7205    Q
  7206   "RTN","PRC ACM",52,0)
  7207   DQ2 ;
  7208   "RTN","PRC ACM",53,0)
  7209    S IOP=PRC ADEV D ^%Z IS
  7210   "RTN","PRC ACM",54,0)
  7211    I 'POP S  IOP=PRCADE V,DIC="^RC (341,",L=0 ,BY="[RCAM  COMMENT]" ,FLDS="[RC AM COMMENT ]",FR=BEG, TO=END D E N1^DIP
  7212   "RTN","PRC ACM",55,0)
  7213    D ^%ZISC  K IOP
  7214   "RTN","PRC ACM",56,0)
  7215    Q
  7216   "RTN","PRC ACM",57,0)
  7217   TI() ;
  7218   "RTN","PRC ACM",58,0)
  7219    N %DT D N OW^%DTC S  %DT("A")=" Request Ti me to Queu e? ",%DT(" B")="NOW"
  7220   "RTN","PRC ACM",59,0)
  7221    S %DT="AE RX",%DT(0) =% D ^%DT
  7222   "RTN","PRC ACM",60,0)
  7223    Q Y
  7224   "RTN","PRC ACM",61,0)
  7225   BEGIN ;
  7226   "RTN","PRC ACM",62,0)
  7227    K PRCATER M,PRCAEN,P RCA("CKSIT E"),PRCAIB S
  7228   "RTN","PRC ACM",63,0)
  7229    I '$G(GOT BILL) D BI LL^PRCAUTL  Q:('$D(PR CABN))      ;PRCA*4.5 *315
  7230   "RTN","PRC ACM",64,0)
  7231    S PRCAIBS =$P($G(^DG CR(399,PRC ABN,0)),U, 13)         ; IB clai m status -  DBIA3820- A
  7232   "RTN","PRC ACM",65,0)
  7233    I PRCAIBS =1 W !!,"* *  You can not add AR  Comments  to an Ente red/Not Re viewed cla im.  **",! ,*7 Q:$G(G OTBILL)  G  BEGIN
  7234   "RTN","PRC ACM",66,0)
  7235    I PRCAIBS =2 W !!,"* *  You can not add AR  Comments  to an MRA  Request cl aim.  **", !,*7 Q:$G( GOTBILL)   G BEGIN
  7236   "RTN","PRC ACM",67,0)
  7237    I '$D(^PR CA(430,PRC ABN,2,0)), PRCAIBS=7  W !!,"**   You cannot  add AR Co mments to  a claim Ca ncelled/no t passed t o AR.  **" ,!,*7 Q:$G (GOTBILL)   G BEGIN
  7238   "RTN","PRC ACM",68,0)
  7239    I $P($G(^ PRCA(430,P RCABN,0)), "^",8)=49  W !!,"**   Comments C ANNOT be e ntered on  an ARCHIVE D bill.  * *",!,*7 Q: $G(GOTBILL )  G BEGIN
  7240   "RTN","PRC ACM",69,0)
  7241    D SETTR^P RCAUTL,PAT TR^PRCAUTL  S DIC="^P RCA(433,"  K PRCAMT,P RCAD("DELE TE") Q
  7242   "RTN","PRC ACPV")
  7243   0^63^B1689 3124^B1449 4379
  7244   "RTN","PRC ACPV",1,0)
  7245   PRCACPV ;W ASH-ISC@AL TOONA,PA/L DB- CHAMPV A FMS DOCU MENTS ;5/1 /95  3:06  PM
  7246   "RTN","PRC ACPV",2,0)
  7247   V ;;4.5;Ac counts Rec eivable;** 1,48,90,11 9,204,192, 235,295,31 5**;Mar 20 , 1995;Bui ld 55
  7248   "RTN","PRC ACPV",3,0)
  7249    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  7250   "RTN","PRC ACPV",4,0)
  7251    ;
  7252   "RTN","PRC ACPV",5,0)
  7253    ;Add CAT= 47:"INELIG IBLE REIMB . ins. cod e for PRCA *4.5*315
  7254   "RTN","PRC ACPV",6,0)
  7255   EN(BILL,ER R) ;Send C HAMPVA SUB SISTENCE b ill to FMS
  7256   "RTN","PRC ACPV",7,0)
  7257    N ADD,ADD R,AMT,BILL 0,BNUM,CAT ,DA,DIE,DO C,DR,ERROR ,ENT,FY,GE CSFMS,I,P, PAT,SITE,T XT,VA,VAER R,VADM,X,X MDUZ,XMTEX T,XMY,XMSU B,Y
  7258   "RTN","PRC ACPV",8,0)
  7259    S ERR=-1
  7260   "RTN","PRC ACPV",9,0)
  7261    I '$G(BIL L) S ERR=" NO BILL NU MBER TO PR OCESS" D E RR Q
  7262   "RTN","PRC ACPV",10,0 )
  7263    S BILL0=$ G(^PRCA(43 0,+BILL,0) ) I BILL0' ]"" S ERR= "BILL INFO  CORRUPTED  FOR BILL  '"_BILL D  ERR Q
  7264   "RTN","PRC ACPV",11,0 )
  7265    ;Allow al l TRICARE  categories  to transm it to FMS  - PRCA*4.5 *295
  7266   "RTN","PRC ACPV",12,0 )
  7267    ;Add inel igible rei mb ins *31 5
  7268   "RTN","PRC ACPV",13,0 )
  7269    I "^27^28 ^30^31^32^ 47^"'[("^" _$P(BILL0, "^",2)_"^" )  Q
  7270   "RTN","PRC ACPV",14,0 )
  7271    S SITE=$P ($P(BILL0, "^"),"-")  I SITE']""  S ERR="BI LL NUMBER  CORRUPTED"  D ERR Q
  7272   "RTN","PRC ACPV",15,0 )
  7273    S BNUM=$P (BILL0,"^" )
  7274   "RTN","PRC ACPV",16,0 )
  7275    S AMT=$J( $P(BILL0," ^",3),0,2)
  7276   "RTN","PRC ACPV",17,0 )
  7277    S CAT=$P( BILL0,"^", 2)
  7278   "RTN","PRC ACPV",18,0 )
  7279    I "^27^31 ^"[("^"_CA T_"^") S P AT=$P($G(^ PRCA(430,+ BILL,0))," ^",9),PAT= $P($G(^RCD (340,+PAT, 0)),"^"),P AT=$$NAM^R CFN01(PAT) ,PAT=$P(PA T,",",2)_"  "_$P(PAT, ",")
  7280   "RTN","PRC ACPV",19,0 )
  7281    S FY=$$FY ^RCFN01(DT )
  7282   "RTN","PRC ACPV",20,0 )
  7283    S ADD=$$S ADD^RCFN01 (5)
  7284   "RTN","PRC ACPV",21,0 )
  7285    ;Add inel igible rei mb ins *31 5
  7286   "RTN","PRC ACPV",22,0 )
  7287    S DESC=$S (CAT=27:"C HAMPVA Sub sistence", CAT=30:"TR ICARE",CAT =31:"TRICA RE PATIENT ",CAT=32:" TRICARE Th ird Party" ,CAT=47:"I NELIGIBLE  HOSP. REIM B.",1:"CHA MPVA Third  Party")
  7288   "RTN","PRC ACPV",23,0 )
  7289    F I=1:1:6  S ADDR(I) =$P(ADD,"^ ",I) I (I' =3),(ADDR( I)']"") S  ERR="NO HO SPITAL ADD RESS FOUND  FOR SITE  GROUP" D E RR Q
  7290   "RTN","PRC ACPV",24,0 )
  7291    I ERR>0 Q
  7292   "RTN","PRC ACPV",25,0 )
  7293    ;CALL TO  GET VENDOR ID BELOW -  CHECK NOT  NECESSARY  SINCE GEN ERIC
  7294   "RTN","PRC ACPV",26,0 )
  7295    ;VENDOR C ODE ALWAYS  RETURNED  FOR THESE  BILL TYPES
  7296   "RTN","PRC ACPV",27,0 )
  7297    S VENDORI D=$$VENDOR ID^RCXFMSU V(BILL)
  7298   "RTN","PRC ACPV",28,0 )
  7299    I ADDR(6) ["-" S ADD R(7)=$P(AD DR(6),"-", 2),ADDR(6) =$P(ADDR(6 ),"-")
  7300   "RTN","PRC ACPV",29,0 )
  7301    N FMSDT S  FMSDT=$$F MSDATE^RCB EUTRA(DT)
  7302   "RTN","PRC ACPV",30,0 )
  7303    S ^TMP("P RCACPV",$J ,1)="BD2^" _$E(FMSDT, 4,5)_"^"_$ E(FMSDT,6, 7)_"^"_$E( FMSDT,2,3)
  7304   "RTN","PRC ACPV",31,0 )
  7305    S ^TMP("P RCACPV",$J ,1)=^TMP(" PRCACPV",$ J,1)_"^^^^ ^^E^"_VEND ORID_"^^"_ AMT_"^^^^" _$E(ADDR(1 ),1,30)_"^ "_$E(ADDR( 2),1,30)_" ^"_$E(ADDR (3),1,30)_ "^"_$E(ADD R(4),1,19) _"^"_ADDR( 5)_"^"_ADD R(6)_"^"_$ G(ADDR(7)) _"^"_"N^^^ ^^^W^~"
  7306   "RTN","PRC ACPV",32,0 )
  7307    ;Add inel igible rei mb ins *31 5
  7308   "RTN","PRC ACPV",33,0 )
  7309    S ^TMP("P RCACPV",$J ,2)="LIN^~ BDA^"_$$LI NE^RCXFMSC 1(BILL)_"^ "_FY_"^^"_ $S(CAT=28: "0160A1",C AT<30:"322 0",CAT=47: "0160A1",1 :"0160A1") _"^"_SITE_ "^^^"
  7310   "RTN","PRC ACPV",34,0 )
  7311    S:CAT<30  CAT("R")=1 000
  7312   "RTN","PRC ACPV",35,0 )
  7313    I CAT'<30  S CAT("R" )=$P($G(^P RCA(430,+B ILL,11)),U ,6)
  7314   "RTN","PRC ACPV",36,0 )
  7315    ;Add inel igible rei mb ins *31 5
  7316   "RTN","PRC ACPV",37,0 )
  7317    S ^TMP("P RCACPV",$J ,2)=^TMP(" PRCACPV",$ J,2)_CAT(" R")_"^^^^^ ^^"_AMT_"^ I^AR_INTER FACE^^^^"_ $S(CAT<30: "09",CAT=4 7:"02",1:" 02")_"^~"
  7318   "RTN","PRC ACPV",38,0 )
  7319    D CONTROL ^GECSUFMS( "A",SITE,B NUM,"BD",1 0,0,"",DES C)
  7320   "RTN","PRC ACPV",39,0 )
  7321    I '$D(GEC SFMS("DA") ) S ERR="C OULD NOT A CCESS STAC K FILE" D  ERR Q
  7322   "RTN","PRC ACPV",40,0 )
  7323    S DOC=$S( $G(GECSFMS ("DOC"))]" ":$P(GECSF MS("DOC"), "^",3)_"-" _$P(GECSFM S("DOC")," ^",4),1:BN UM)
  7324   "RTN","PRC ACPV",41,0 )
  7325    S DA=0 F   S DA=$O(^ TMP("PRCAC PV",$J,DA) ) Q:'DA  D
  7326   "RTN","PRC ACPV",42,0 )
  7327    . D SETCS ^GECSSTAA( GECSFMS("D A"),^TMP(" PRCACPV",$ J,DA))
  7328   "RTN","PRC ACPV",43,0 )
  7329    D OPEN^RC FMDRV1(DOC ,6,"B"_+BI LL,.ENT,.E RROR,+BILL )
  7330   "RTN","PRC ACPV",44,0 )
  7331    I ERROR]" " S ERR="A R DOCUMENT  MISSING -  "_ERROR Q
  7332   "RTN","PRC ACPV",45,0 )
  7333    D SETCODE ^GECSSDCT( GECSFMS("D A"),"D RET N^RCFMFN02 ")
  7334   "RTN","PRC ACPV",46,0 )
  7335    D SETSTAT ^GECSSTAA( GECSFMS("D A"),"Q")
  7336   "RTN","PRC ACPV",47,0 )
  7337    D SSTAT^R CFMFN02("B "_+BILL,1)
  7338   "RTN","PRC ACPV",48,0 )
  7339    K ^TMP("P RCACPV",$J )
  7340   "RTN","PRC ACPV",49,0 )
  7341    ;
  7342   "RTN","PRC ACPV",50,0 )
  7343   ERR ;Add i neligible  reimb ins  *315
  7344   "RTN","PRC ACPV",51,0 )
  7345    I ERR'<0  S ERR="1^" _ERR D
  7346   "RTN","PRC ACPV",52,0 )
  7347    .S TXT(1) ="The foll owing erro r has occu rred while  processin g a "_$S(C AT=31:"TRI CARE PATIE NT ",CAT=4 7:"INELIGI BLE REIMB.  INS. PATI ENT",1:"CH AMPVA")
  7348   "RTN","PRC ACPV",53,0 )
  7349    .S TXT(2) ="bill: (" _$S($G(BNU M):BNUM,1: "BILL IFN  - "_+BILL) _")"
  7350   "RTN","PRC ACPV",54,0 )
  7351    .S TXT(3) =" "
  7352   "RTN","PRC ACPV",55,0 )
  7353    .S TXT(4) =$P(ERR,"^ ",2)
  7354   "RTN","PRC ACPV",56,0 )
  7355    .S TXT(5) =""
  7356   "RTN","PRC ACPV",57,0 )
  7357    .S TXT(6) ="You will  need to u se the BIL LING DOCUM ENT REGENE RATION opt ion to cre ate the FM S document ."
  7358   "RTN","PRC ACPV",58,0 )
  7359    .S XMTEXT ="TXT(",XM Y("G.PRCA  ERROR")=""
  7360   "RTN","PRC ACPV",59,0 )
  7361    .S XMSUB= $S(CAT=31: "TRICARE P ATIENT",CA T=30:"TRIC ARE",CAT=3 2:"TRICARE  Third Par ty",CAT=47 :"INELIGIB LE REIMB.  INS. PATIE NT",1:"CHA MPVA")_" F MS DOC err or",XMDUZ= "ACCOUNTS  RECEIVABLE  PACKAGE"
  7362   "RTN","PRC ACPV",60,0 )
  7363    .D ^XMD
  7364   "RTN","PRC ACPV",61,0 )
  7365    Q
  7366   "RTN","PRC AEXM")
  7367   0^59^B1381 6393^B1498 8614
  7368   "RTN","PRC AEXM",1,0)
  7369   PRCAEXM ;S F-ISC/YJK- ADMIN.COST  CHARGE TR ANSACTION  ;3/30/94   11:19 AM
  7370   "RTN","PRC AEXM",2,0)
  7371    ;;4.5;Acc ounts Rece ivable;**6 7,103,196, 301,318,31 5**;Mar 20 , 1995;Bui ld 55
  7372   "RTN","PRC AEXM",3,0)
  7373    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  7374   "RTN","PRC AEXM",4,0)
  7375    ;Update I nt/adm.bal ance and A dministrat ive cost c harge tran saction, i s called b y ^PRCAWO.
  7376   "RTN","PRC AEXM",5,0)
  7377    ;
  7378   "RTN","PRC AEXM",6,0)
  7379   EN1 ;Adjus tment Inte rest/admin .cost from  an AR - t his makes  the int/ad m.balance
  7380   "RTN","PRC AEXM",7,0)
  7381    ;  ,marsh al fee and  court cos t zero,0.
  7382   "RTN","PRC AEXM",8,0)
  7383    N PRCAIND ,ADMINTOT, PRCAERR,PR CABN0
  7384   "RTN","PRC AEXM",9,0)
  7385    I '$D(^XU SEC("RCDPE AR",DUZ))  D  Q  ; PR CA*4.5*318  Added sec urity key  check
  7386   "RTN","PRC AEXM",10,0 )
  7387    . W !!,"T his action  can only  be taken b y users th at have th e RCDPEAR  security k ey.",!
  7388   "RTN","PRC AEXM",11,0 )
  7389    . S VALMB CK="R"
  7390   "RTN","PRC AEXM",12,0 )
  7391    . D PAUSE ^VALM1
  7392   "RTN","PRC AEXM",13,0 )
  7393    D BEGIN^P RCAWO G:(' $D(PRCABN) )!('$D(PRC AEN)) END  G:'$D(^PRC A(430,PRCA BN,7)) END
  7394   "RTN","PRC AEXM",14,0 )
  7395    L +^PRCA( 430,PRCABN ):1 I '$T  W !!,*7,"A NOTHER USE R IS EDITI NG THIS BI LL" G EN1
  7396   "RTN","PRC AEXM",15,0 )
  7397    S PRCABN0 =PRCABN
  7398   "RTN","PRC AEXM",16,0 )
  7399    S PRCAIND =$G(^PRCA( 430,PRCABN ,7))
  7400   "RTN","PRC AEXM",17,0 )
  7401    S PRCAMT= $P(PRCAIND ,U,2)+$P(P RCAIND,U,3 )+$P(PRCAI ND,U,4)+$P (PRCAIND,U ,5)
  7402   "RTN","PRC AEXM",18,0 )
  7403    S %=$P(^P RCA(430,PR CABN,0),U, 2) I "PC"' [$P(^PRCA( 430.2,%,0) ,U,6) W *7 ,!,"This A R may not  be appropr iate to ch arge Inter est/Admini strative c ost.",!,"P lease chec k the cate gory of th is AR.",!  H 3
  7404   "RTN","PRC AEXM",19,0 )
  7405    K % W !!, "You may e xempt the  account fr om all the  interest  and admini strative c ost balanc es - makin g those ba lances zer o (0),",!, "or adjust  them."
  7406   "RTN","PRC AEXM",20,0 )
  7407   EN011 S %= 2 W !!,"Do  you want  to exempt  the accoun t from all  the Int/A dm. costs"  D YN^DICN  I %<0 S P RCACOMM="U ser Cancel ed" D DELE TE^PRCAWO1  K PRCACOM M G EN1
  7408   "RTN","PRC AEXM",21,0 )
  7409    I %=1 D E N11,END G  EN1
  7410   "RTN","PRC AEXM",22,0 )
  7411    I %=0 W ! ,"ANSWER ' YES' OR 'N O' " G EN0 11
  7412   "RTN","PRC AEXM",23,0 )
  7413    W !,"Adju sting the  administra tive/Inter est charge  ...",!
  7414   "RTN","PRC AEXM",24,0 )
  7415    D DIEEN^P RCAWO1,END  G EN1
  7416   "RTN","PRC AEXM",25,0 )
  7417    ;
  7418   "RTN","PRC AEXM",26,0 )
  7419    ;  exempt  interest  and admin  charges
  7420   "RTN","PRC AEXM",27,0 )
  7421   EN11 S PRC ATYPE=14,D IE="^PRCA( 433,",DA=P RCAEN
  7422   "RTN","PRC AEXM",28,0 )
  7423    S DR=".03 ////^S X=" _PRCABN_"; 11////^S X ="_DT_";12 ////^S X=" _PRCATYPE_ ";15////^S  X="_PRCAM T_";"
  7424   "RTN","PRC AEXM",29,0 )
  7425    S DR=DR_" 27////^S X ="_+$P(PRC AIND,U,2)_ ";"  ;inte rest
  7426   "RTN","PRC AEXM",30,0 )
  7427    S DR=DR_" 28////^S X ="_+$P(PRC AIND,U,3)_ ";"  ;admi n charge
  7428   "RTN","PRC AEXM",31,0 )
  7429    S DR=DR_" 25////^S X ="_+$P(PRC AIND,U,4)_ ";"  ;mars hal fee
  7430   "RTN","PRC AEXM",32,0 )
  7431    S DR=DR_" 26////^S X ="_+$P(PRC AIND,U,5)_ ";"  ;cour t cost
  7432   "RTN","PRC AEXM",33,0 )
  7433    S DIC=DIE ,PRCA("LOC K")=0 D LO CKF^PRCAWO 1 Q:PRCA(" LOCK")=1   D ^DIE
  7434   "RTN","PRC AEXM",34,0 )
  7435    I PRCAEN, $D(^PRCA(4 30,"TCSP", PRCABN)) D  DECADJ^RC TCSPU(PRCA BN,PRCAEN)  ;prca*4.5 *301 add c s 5B flag
  7436   "RTN","PRC AEXM",35,0 )
  7437    S $P(^PRC A(430,PRCA BN,7),U,2, 5)="0^0^0^ 0" D TRANS T^PRCAWO1  Q
  7438   "RTN","PRC AEXM",36,0 )
  7439    ;
  7440   "RTN","PRC AEXM",37,0 )
  7441    ;
  7442   "RTN","PRC AEXM",38,0 )
  7443   EN2 Q:'$D( PRCAEN)  Q :($P(^PRCA (433,PRCAE N,2),U,8)= "")&($P(^P RCA(433,PR CAEN,2),U, 7)="")
  7444   "RTN","PRC AEXM",39,0 )
  7445    W !,"MONT HLY ADMIN.  CHARGE: " ,?25,+$P(^ PRCA(433,P RCAEN,2),U ,8),?40,"I NTEREST CH ARGE: ",+$ P(^PRCA(43 3,PRCAEN,2 ),U,7) Q
  7446   "RTN","PRC AEXM",40,0 )
  7447    ;
  7448   "RTN","PRC AEXM",41,0 )
  7449   END L -^PR CA(433,+$G (PRCAEN)), -^PRCA(430 ,+$G(PRCAB N))
  7450   "RTN","PRC AEXM",42,0 )
  7451    S X(1)=0, X=$G(^PRCA (430,+$G(P RCABN0),7) ),X(1)=+X, X(1)=$P(X, "^",2)+X(1 ),X(1)=$P( X,"^",3)+X (1),X(1)=$ P(X,"^",4) +X(1),X(1) =$P(X,"^", 5)+X(1)
  7452   "RTN","PRC AEXM",43,0 )
  7453    K PRCA("S TATUS")
  7454   "RTN","PRC AEXM",44,0 )
  7455    I X(1)=0, $G(PRCABN0 ) D
  7456   "RTN","PRC AEXM",45,0 )
  7457    .;Check f or payment  transacti ons
  7458   "RTN","PRC AEXM",46,0 )
  7459    .F X=0:0  S X=$O(^PR CA(433,"C" ,PRCABN0,X )) Q:'X  I  ",2,7,20, "[(","_$P( $G(^PRCA(4 30.3,+$P($ G(^PRCA(43 3,X,1)),"^ ",2),0))," ^",3)_",")  S PRCA("S TATUS")=$O (^PRCA(430 .3,"AC",10 8,0))
  7460   "RTN","PRC AEXM",47,0 )
  7461    .S:'$D(PR CA("STATUS ")) PRCA(" STATUS")=$ O(^PRCA(43 0.3,"AC",1 11,0))
  7462   "RTN","PRC AEXM",48,0 )
  7463    .S DA=PRC ABN0,DIE=" ^PRCA(430, ",DR="8/// /"_PRCA("S TATUS") D  ^DIE
  7464   "RTN","PRC AEXM",49,0 )
  7465    K PRCATY, PRCA,PRCA2 ,PRCAD,PRC ABN,PRCAEN ,PRCATYPE, DA,DIE,DIC ,PRCAMT,DR ,X,% Q
  7466   "RTN","PRC AFUT")
  7467   0^62^B4244 7114^B4034 9439
  7468   "RTN","PRC AFUT",1,0)
  7469   PRCAFUT ;W ASH-ISC@AL TOONA/CLH- FMS Utilit ies ;10/8/ 96  10:50  AM
  7470   "RTN","PRC AFUT",2,0)
  7471   V ;;4.5;Ac counts Rec eivable;** 5,39,64,92 ,104,169,1 88,194,220 ,231,315** ;Mar 20, 1 995;Build  55
  7472   "RTN","PRC AFUT",3,0)
  7473    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  7474   "RTN","PRC AFUT",4,0)
  7475   CPLK(PRCAB N) ;get co ntrol poin t from fil e 430 and  set DR str ing to edi t CP data
  7476   "RTN","PRC AFUT",5,0)
  7477    N DR,X,Y, QUIT,FUND, FTBL,CAT,C ATTYP,CATT YPE,CP,BBF Y,EBFY,DIC ,BGFY,CPTB L,CC,SCC,E XIT,FYERRO R
  7478   "RTN","PRC AFUT",6,0)
  7479    K PRCA("E XIT")
  7480   "RTN","PRC AFUT",7,0)
  7481    S PRCA("S ITE")=$S($ G(PRCABN): $P($P($G(^ PRCA(430,P RCABN,0)), "^"),"-"), 1:$$SITE^R CMSITE)
  7482   "RTN","PRC AFUT",8,0)
  7483    S CP=$P($ G(^PRCA(43 0,PRCABN,1 1)),U)
  7484   "RTN","PRC AFUT",9,0)
  7485    S CAT=+$P ($G(^PRCA( 430,PRCABN ,0)),U,2), CATTYP=$P( $G(^PRCA(4 30.2,CAT,0 )),U,13)
  7486   "RTN","PRC AFUT",10,0 )
  7487    I CAT>39, CAT<45 D   G END
  7488   "RTN","PRC AFUT",11,0 )
  7489       .S TYP E="09" D C HKELEM,REV  Q:$G(PRCA ("EXIT"))
  7490   "RTN","PRC AFUT",12,0 )
  7491       .S DR= "257///^S  X=$G(PRCA( ""SITE"")) "
  7492   "RTN","PRC AFUT",13,0 )
  7493       .;I CA T'=42 S DR =DR_";258/ ///1"
  7494   "RTN","PRC AFUT",14,0 )
  7495       .D DIE
  7496   "RTN","PRC AFUT",15,0 )
  7497       .Q
  7498   "RTN","PRC AFUT",16,0 )
  7499    I CAT=47  D  G END ; 315
  7500   "RTN","PRC AFUT",17,0 )
  7501    .S TYPE=" 02",FUND=" 0160A1"
  7502   "RTN","PRC AFUT",18,0 )
  7503    .S DR="25 9///"_TYPE _";203///^ S X=FUND"
  7504   "RTN","PRC AFUT",19,0 )
  7505    .D DIE
  7506   "RTN","PRC AFUT",20,0 )
  7507    .Q
  7508   "RTN","PRC AFUT",21,0 )
  7509    D TYPE Q: $D(PRCA("E XIT"))
  7510   "RTN","PRC AFUT",22,0 )
  7511    I CATTYP= 2 K PRCA(" EXIT") D   G END
  7512   "RTN","PRC AFUT",23,0 )
  7513     . ;reibu rsement lo gic (if th ere is suc h a thing)
  7514   "RTN","PRC AFUT",24,0 )
  7515     . S DR=" 203" D DIE  K DR I $D (Y) Q
  7516   "RTN","PRC AFUT",25,0 )
  7517     . I '$D( FUND) S FU ND=$P($G(^ PRCA(430,P RCABN,11)) ,U,17) D   I FUND=-1  S PRCA("EX IT")="" Q
  7518   "RTN","PRC AFUT",26,0 )
  7519     .. N X,Y ,DIC
  7520   "RTN","PRC AFUT",27,0 )
  7521     .. S X=F UND,DIC="^ PRCD(420.1 4,",DIC(0) ="XMNZ",DI C("B")=FUN D D ^DIC
  7522   "RTN","PRC AFUT",28,0 )
  7523     .. I +Y< 0 D FUND^P RCAFBDU D   Q:FUND=-1
  7524   "RTN","PRC AFUT",29,0 )
  7525     ... S DI C="^PRCD(4 20.14,",DI C(0)="AEMN QZ",DIC("A ")="FUND:  ",DIC("B") =FUND
  7526   "RTN","PRC AFUT",30,0 )
  7527     ... D ^D IC
  7528   "RTN","PRC AFUT",31,0 )
  7529     ... S:+Y <0 FUND=-1  Q
  7530   "RTN","PRC AFUT",32,0 )
  7531     .. S FUN D=Y
  7532   "RTN","PRC AFUT",33,0 )
  7533     .. S BBF Y=$E($P(Y( 0),U,3),3, 4),EBFY=$E ($P(Y(0),U ,4),3,4)
  7534   "RTN","PRC AFUT",34,0 )
  7535     ..Q
  7536   "RTN","PRC AFUT",35,0 )
  7537     .S PRCAB N(1)=$O(^P RCA(430,+P RCABN,2,0) )
  7538   "RTN","PRC AFUT",36,0 )
  7539     .S PRCAB N(2)=$G(^P RCA(430,+P RCABN,2,PR CABN(1),0) )
  7540   "RTN","PRC AFUT",37,0 )
  7541     .S PRCAB N(4)=+$G(P RCABN(2))
  7542   "RTN","PRC AFUT",38,0 )
  7543     .S X=BBF Y D ^%DT S  PRCABN(3) =$E(Y,1,3)
  7544   "RTN","PRC AFUT",39,0 )
  7545     .K ^PRCA (430,PRCAB N,2,PRCABN (1),0)
  7546   "RTN","PRC AFUT",40,0 )
  7547     .K ^PRCA (430,PRCAB N,2,"B",PR CABN(4),PR CABN(1))
  7548   "RTN","PRC AFUT",41,0 )
  7549     .S ^PRCA (430,PRCAB N,2,PRCABN (3),0)=PRC ABN(2)
  7550   "RTN","PRC AFUT",42,0 )
  7551     .S $P(^P RCA(430,PR CABN,2,PRC ABN(3),0), "^")=BBFY
  7552   "RTN","PRC AFUT",43,0 )
  7553     .S ^PRCA (430,PRCAB N,2,"B",BB FY,PRCABN( 3))=""
  7554   "RTN","PRC AFUT",44,0 )
  7555     .D DOCRE Q^PRC0C(+F UND,"REV", "FTBL")
  7556   "RTN","PRC AFUT",45,0 )
  7557     . I '$D( FTBL) S PR CA("EXIT") =1 D  Q
  7558   "RTN","PRC AFUT",46,0 )
  7559     .. W !,* 7,"FMS REQ UIRED FIEL DS missing .  Edit th e IFCAP RE QUIRED FIE LDS table" ,!,"for FU ND/FY comb ination."
  7560   "RTN","PRC AFUT",47,0 )
  7561     .. Q
  7562   "RTN","PRC AFUT",48,0 )
  7563     . S DR=" 259////^S  X=CAT;257/ ///^S X=$G (PRCA(""SI TE""));201 ////^S X=B BFY;202/// /^S X=$S($ G(EBFY)'=B BFY:EBFY,1 :"""")"
  7564   "RTN","PRC AFUT",49,0 )
  7565     . D DR
  7566   "RTN","PRC AFUT",50,0 )
  7567     . Q
  7568   "RTN","PRC AFUT",51,0 )
  7569    ;Ask Begi nning/end  budget fis cal year
  7570   "RTN","PRC AFUT",52,0 )
  7571    D FY^PRCA FUT1
  7572   "RTN","PRC AFUT",53,0 )
  7573    I $D(FYER ROR) S PRC A("EXIT")= 1 Q
  7574   "RTN","PRC AFUT",54,0 )
  7575    ;S BGFY=$ P(^PRCA(43 0,PRCABN,0 ),U,10),BG FY=$$FY^RC FN01(BGFY)
  7576   "RTN","PRC AFUT",55,0 )
  7577    S DR="250 ;I '$D(CPT BL) D CPTB L^PRCAFUT; 259////^S  X=CAT;204/ ///^S X=$P (CPTBL,U); 206////^S  X=$P(CPTBL ,U,3)"
  7578   "RTN","PRC AFUT",56,0 )
  7579    S DR=DR_" ;203////^S  X=$P(CPTB L,U,5);201 ////^S X=$ E($P(CPTBL ,U,6),3,4) "
  7580   "RTN","PRC AFUT",57,0 )
  7581    S DR(1,43 0,1)="202/ ///^S X=$S ($P(CPTBL, U,7)'=$P(C PTBL,U,6): $E($P(CPTB L,U,7),3,4 ),1:"""")"
  7582   "RTN","PRC AFUT",58,0 )
  7583    S DR(1,43 0,2)="261/ ///^S X=$P (CPTBL,U,1 0)"
  7584   "RTN","PRC AFUT",59,0 )
  7585    S DA=PRCA BN D ^DIE  K DR
  7586   "RTN","PRC AFUT",60,0 )
  7587    I $D(Y) S  PRCA("EXI T")=1 Q
  7588   "RTN","PRC AFUT",61,0 )
  7589    K DR
  7590   "RTN","PRC AFUT",62,0 )
  7591    D FTBL Q: '$D(FTBL)
  7592   "RTN","PRC AFUT",63,0 )
  7593    S (X,PRCA BN(1))=$E( $P(CPTBL,U ,6),3,4)
  7594   "RTN","PRC AFUT",64,0 )
  7595    D ^%DT S  PRCABN(2)= $E(Y,1,3)
  7596   "RTN","PRC AFUT",65,0 )
  7597    S PRCABN( 3)=$O(^PRC A(430,+PRC ABN,2,0))
  7598   "RTN","PRC AFUT",66,0 )
  7599    S PRCABN( 4)=$G(^PRC A(430,+PRC ABN,2,PRCA BN(3),0))
  7600   "RTN","PRC AFUT",67,0 )
  7601    S PRCABN( 5)=$E(PRCA BN(4),1,2)
  7602   "RTN","PRC AFUT",68,0 )
  7603    K ^PRCA(4 30,PRCABN, 2,PRCABN(3 ),0)
  7604   "RTN","PRC AFUT",69,0 )
  7605    K ^PRCA(4 30,PRCABN, 2,"B",PRCA BN(5),PRCA BN(3))
  7606   "RTN","PRC AFUT",70,0 )
  7607    S ^PRCA(4 30,PRCABN, 2,PRCABN(2 ),0)=PRCAB N(4)
  7608   "RTN","PRC AFUT",71,0 )
  7609    S $P(^PRC A(430,PRCA BN,2,PRCAB N(2),0),"^ ")=PRCABN( 1)
  7610   "RTN","PRC AFUT",72,0 )
  7611    S ^PRCA(4 30,PRCABN, 2,"B",PRCA BN(1),PRCA BN(2))=""
  7612   "RTN","PRC AFUT",73,0 )
  7613    S $P(^PRC A(430,PRCA BN,2,0),"^ ",3)=PRCAB N(2)
  7614   "RTN","PRC AFUT",74,0 )
  7615    Q
  7616   "RTN","PRC AFUT",75,0 )
  7617   FTBL S FUN D=$$FUND^P RC0C($P(CP TBL,U,5),$ P(CPTBL,U, 6))
  7618   "RTN","PRC AFUT",76,0 )
  7619    D DOCREQ^ PRC0C(+FUN D,"SPE","F TBL")
  7620   "RTN","PRC AFUT",77,0 )
  7621    I '$D(FTB L) W !!,*7 ,"UNABLE T O GET FMS- LINE FUND  ACCOUNTING  INFORMATI ON.  CHECK  CONTROL P OINT." H 5  S PRCA("E XIT")=1 Q
  7622   "RTN","PRC AFUT",78,0 )
  7623    S DR="257 ////^S X=$ G(PRCA(""S ITE""))"
  7624   "RTN","PRC AFUT",79,0 )
  7625   DR I $$INT EG^RCFN01( $G(PRCA("S ITE"))) S  DR=DR_";26 0"
  7626   "RTN","PRC AFUT",80,0 )
  7627    I $G(FTBL ("AO"))="Y " S DR=DR_ ";204"
  7628   "RTN","PRC AFUT",81,0 )
  7629    I $G(FTBL ("FCPRJ")) ="Y" S DR= DR_";I '$D (CPTBL) D  CPTBL^PRCA FUT;206/// /^S X=$P(C PTBL,U,3)"
  7630   "RTN","PRC AFUT",82,0 )
  7631    I $G(FTBL ("CC"))="Y "             S DR=DR _";251;252 ////^S X=$ G(SCC)"
  7632   "RTN","PRC AFUT",83,0 )
  7633    I $G(FTBL ("BOC"))=" Y"            S DR=DR _";253"
  7634   "RTN","PRC AFUT",84,0 )
  7635    I $G(FTBL ("SBOC"))= "Y"!(CAT=2 0) S DR=DR _";254"
  7636   "RTN","PRC AFUT",85,0 )
  7637    I $G(FTBL ("JOB"))=" Y"            S DR=DR _";261"
  7638   "RTN","PRC AFUT",86,0 )
  7639    I $G(FTBL ("RC"))="Y "             S DR=DR _";263"
  7640   "RTN","PRC AFUT",87,0 )
  7641    I $G(FTBL ("REV"))=" Y"            D DIE Q :$G(PRCA(" EXIT"))  D  REV Q:$G( PRCA("EXIT "))
  7642   "RTN","PRC AFUT",88,0 )
  7643    I $G(FTBL ("SREV"))= "Y"           S DR=$S (DR="":"25 6",1:DR_"; 256")
  7644   "RTN","PRC AFUT",89,0 )
  7645    I $G(FTBL ("OC"))="Y "             S DR=$S (DR="":"20 5",1:DR_"; 205")
  7646   "RTN","PRC AFUT",90,0 )
  7647    I DR'=""  D DIE
  7648   "RTN","PRC AFUT",91,0 )
  7649    Q
  7650   "RTN","PRC AFUT",92,0 )
  7651   DIE S DA=P RCABN,DIE= "^PRCA(430 ," D ^DIE
  7652   "RTN","PRC AFUT",93,0 )
  7653   END I $D(Y ) S PRCA(" EXIT")=1
  7654   "RTN","PRC AFUT",94,0 )
  7655    K DR Q
  7656   "RTN","PRC AFUT",95,0 )
  7657    ;
  7658   "RTN","PRC AFUT",96,0 )
  7659   RECTYP(BN)  ;Refund o r reimburs ement
  7660   "RTN","PRC AFUT",97,0 )
  7661    I '$D(BN) ,'$D(^PRCA (430,BN,0) ) Q -1
  7662   "RTN","PRC AFUT",98,0 )
  7663    Q $P($G(^ PRCA(430,B N,11)),U,1 0)
  7664   "RTN","PRC AFUT",99,0 )
  7665    ;
  7666   "RTN","PRC AFUT",100, 0)
  7667   REV ;looku p revenue  by calling  "C" xref
  7668   "RTN","PRC AFUT",101, 0)
  7669    N DS,DIC, DIBTDH,HEL P,I,IAT,OU T,RV,X,Y
  7670   "RTN","PRC AFUT",102, 0)
  7671    S OUT=0,R V=$P($G(^P RCA(430,PR CABN,11)), U,6)
  7672   "RTN","PRC AFUT",103, 0)
  7673    F  D  Q:O UT
  7674   "RTN","PRC AFUT",104, 0)
  7675    .W !,"REV ENUE SOURC E: "_$S(RV '="":RV_"/ / ",1:"")  R X:DTIME
  7676   "RTN","PRC AFUT",105, 0)
  7677    .I $E(X)= "?",X?."?"  D @($S($L (X)=1:"REV H1",1:"REV H2")) S DI C=347.3,DI C(0)="QE"  D ^DIC Q:Y <1  Q
  7678   "RTN","PRC AFUT",106, 0)
  7679    .I $E(X)= "^",X?."^"  S OUT=1,P RCA("EXIT" )=1 Q
  7680   "RTN","PRC AFUT",107, 0)
  7681    .I X="@"  W "??  Req uired" Q
  7682   "RTN","PRC AFUT",108, 0)
  7683    .I X="",R V'="" S OU T=1 Q
  7684   "RTN","PRC AFUT",109, 0)
  7685    .I X="",R V="" W "?? " D REVH1  Q
  7686   "RTN","PRC AFUT",110, 0)
  7687    .I $D(^RC (347.3,"B" ,X)) D  Q
  7688   "RTN","PRC AFUT",111, 0)
  7689    ..S DS=$P ($G(^RC(34 7.3,+$O(^R C(347.3,"B ",X,0)),0) ),U,2),IAT =$P(^(0),U ,3)
  7690   "RTN","PRC AFUT",112, 0)
  7691    ..W "        "_DS W: IAT "          INACTI VE" D REVD IE
  7692   "RTN","PRC AFUT",113, 0)
  7693    .S DIC="^ RC(347.3," ,DIC(0)="Q E",D="C" D  IX^DIC I  Y<1 D REVH 1 Q
  7694   "RTN","PRC AFUT",114, 0)
  7695    .S X=$P(Y ,U,2) D RE VDIE
  7696   "RTN","PRC AFUT",115, 0)
  7697    S DR=""
  7698   "RTN","PRC AFUT",116, 0)
  7699    Q
  7700   "RTN","PRC AFUT",117, 0)
  7701   REVDIE S D A=PRCABN,D IE="^PRCA( 430,",DR=" 255///"_X  D ^DIE I $ G(X)'="" S  OUT=1 Q
  7702   "RTN","PRC AFUT",118, 0)
  7703    D REVH1 Q
  7704   "RTN","PRC AFUT",119, 0)
  7705   REVH1 S HE LP("DIHELP ",1)=$G(^D D(430,255, 3)) D MSG^ DIALOG("WH ","",70,5, "HELP") Q
  7706   "RTN","PRC AFUT",120, 0)
  7707   REVH2 D HE LP^DIE(430 ,"",255,"D ","HELP"), MSG^DIALOG ("WH","",7 0,8,"HELP" ) Q
  7708   "RTN","PRC AFUT",121, 0)
  7709    ;
  7710   "RTN","PRC AFUT",122, 0)
  7711   FUND ;get  fund
  7712   "RTN","PRC AFUT",123, 0)
  7713    N DIC,Y
  7714   "RTN","PRC AFUT",124, 0)
  7715    S DIC="^P RCD(420.14 ,",DIC(0)= "EMNQZ"
  7716   "RTN","PRC AFUT",125, 0)
  7717    D ^DIC
  7718   "RTN","PRC AFUT",126, 0)
  7719    I $D(DUOU T)!$D(DTOU T) S PRCA( "EXIT")=1  Q
  7720   "RTN","PRC AFUT",127, 0)
  7721    Q:+Y<0
  7722   "RTN","PRC AFUT",128, 0)
  7723    S FUND=Y
  7724   "RTN","PRC AFUT",129, 0)
  7725    S BBFY=$E ($P(Y(0),U ,3),3,4),E BFY=$E($P( Y(0),U,4), 3,4)
  7726   "RTN","PRC AFUT",130, 0)
  7727    Q
  7728   "RTN","PRC AFUT",131, 0)
  7729    ;
  7730   "RTN","PRC AFUT",132, 0)
  7731   DISPLACC ; display ac count info rmation
  7732   "RTN","PRC AFUT",133, 0)
  7733    Q:'$D(PRC ABN)  NEW  DIC,L,FR,T O,FLDS,IOP ,X
  7734   "RTN","PRC AFUT",134, 0)
  7735    R !!,"Pre ss <RETURN > to conti nue: ",X:6 0
  7736   "RTN","PRC AFUT",135, 0)
  7737    I X["^" S  PRCA("EXI T")="" Q
  7738   "RTN","PRC AFUT",136, 0)
  7739    S IOP=IO( 0),DIC="^P RCA(430,", FLDS="[PRC A DISP AUD IT2]",(FR, TO)=PRCABN ,L=0,BY="@ NUMBER" D  EN1^DIP
  7740   "RTN","PRC AFUT",137, 0)
  7741    Q
  7742   "RTN","PRC AFUT",138, 0)
  7743    ;
  7744   "RTN","PRC AFUT",139, 0)
  7745   CP ;lookup  control p oint
  7746   "RTN","PRC AFUT",140, 0)
  7747    N DIC
  7748   "RTN","PRC AFUT",141, 0)
  7749    S DIC="^P RC(420,"_$ S($D(PRCA( "SITE")):P RCA("SITE" ),1:$$SITE ^RCMSITE)_ ",1,",DIC( 0)="EMNQ", X=CP
  7750   "RTN","PRC AFUT",142, 0)
  7751    D ^DIC
  7752   "RTN","PRC AFUT",143, 0)
  7753    I +Y<0 K  X,CP Q
  7754   "RTN","PRC AFUT",144, 0)
  7755    S CP=+Y
  7756   "RTN","PRC AFUT",145, 0)
  7757    Q
  7758   "RTN","PRC AFUT",146, 0)
  7759    ;
  7760   "RTN","PRC AFUT",147, 0)
  7761   CC ;cost c enter
  7762   "RTN","PRC AFUT",148, 0)
  7763    G CC^PRCA FBDU
  7764   "RTN","PRC AFUT",149, 0)
  7765    ;
  7766   "RTN","PRC AFUT",150, 0)
  7767   BOC ;budge t object c ode
  7768   "RTN","PRC AFUT",151, 0)
  7769    G BOC^PRC AFBDU
  7770   "RTN","PRC AFUT",152, 0)
  7771    ;
  7772   "RTN","PRC AFUT",153, 0)
  7773   TYPE ;ask  if bill is  a refund  or reimbur sement
  7774   "RTN","PRC AFUT",154, 0)
  7775    W !!,"Bui lding FMS  Accounting  Elements. ..",!
  7776   "RTN","PRC AFUT",155, 0)
  7777    N DIR,Y,T YPE
  7778   "RTN","PRC AFUT",156, 0)
  7779    I +$G(CAT )=1 S CAT= "02",CATTY PE=2 D CHK ELEM Q
  7780   "RTN","PRC AFUT",157, 0)
  7781    I +$G(CAT )=10 S CAT =50,CATTYP E=2 D CHKE LEM Q
  7782   "RTN","PRC AFUT",158, 0)
  7783    I +$G(CAT )=47 S CAT ="02" Q
  7784   "RTN","PRC AFUT",159, 0)
  7785    D BDTRANS ^PRCAFBDU
  7786   "RTN","PRC AFUT",160, 0)
  7787    Q:$D(PRCA ("EXIT"))
  7788   "RTN","PRC AFUT",161, 0)
  7789    S CATTYP= $S(TYPE="0 1":"1",TYP E="20":"1" ,1:"2")
  7790   "RTN","PRC AFUT",162, 0)
  7791    S CAT=TYP E ; I CAT> 2 S CAT=$S (CAT=4:"20 ",1:"9")
  7792   "RTN","PRC AFUT",163, 0)
  7793    D CHKELEM
  7794   "RTN","PRC AFUT",164, 0)
  7795    Q
  7796   "RTN","PRC AFUT",165, 0)
  7797    ;
  7798   "RTN","PRC AFUT",166, 0)
  7799   CHKELEM ;c heck for c orrect acc ounting li ne data
  7800   "RTN","PRC AFUT",167, 0)
  7801    N I
  7802   "RTN","PRC AFUT",168, 0)
  7803    Q:'$D(^PR CA(430,PRC ABN,11))
  7804   "RTN","PRC AFUT",169, 0)
  7805    I $G(CATT YP)=1 D  Q
  7806   "RTN","PRC AFUT",170, 0)
  7807     . F I=6, 7 S $P(^PR CA(430,PRC ABN,11),U, I)=""
  7808   "RTN","PRC AFUT",171, 0)
  7809     . Q
  7810   "RTN","PRC AFUT",172, 0)
  7811    Q:$G(TYPE )=10
  7812   "RTN","PRC AFUT",173, 0)
  7813    F I=1:1:5 ,11:1:16,1 8:1:21 S $ P(^PRCA(43 0,PRCABN,1 1),U,I)=""
  7814   "RTN","PRC AFUT",174, 0)
  7815    S $P(^PRC A(430,PRCA BN,11),U,1 5)="05"
  7816   "RTN","PRC AFUT",175, 0)
  7817    Q
  7818   "RTN","PRC AFUT",176, 0)
  7819   CPTBL ;bui ld CP tabl e
  7820   "RTN","PRC AFUT",177, 0)
  7821    S:'$D(BGF Y) BGFY=$$ FY^RCFN01( DT)
  7822   "RTN","PRC AFUT",178, 0)
  7823    S BGFY(1) =$S(BGFY>5 0:19,1:20)
  7824   "RTN","PRC AFUT",179, 0)
  7825    S CPTBL=$ $ACC^PRC0C ($G(PRCA(" SITE")),+C P_U_BGFY_U _BGFY(1)_B GFY)
  7826   "RTN","PRC AFUT",180, 0)
  7827    I '$D(CPT BL) S CPTB L=""
  7828   "RTN","PRC AFUT",181, 0)
  7829    Q
  7830   "RTN","PRC AFUT",182, 0)
  7831    ;
  7832   "RTN","PRC AFUT",183, 0)
  7833   CPHLP ;exe cutable he lp for cp  prompt
  7834   "RTN","PRC AFUT",184, 0)
  7835    N DIC,X,Y
  7836   "RTN","PRC AFUT",185, 0)
  7837    S DIC="^P RC(420,"_$ S($D(PRCA( "SITE")):P RCA("SITE" ),1:$$SITE ^RCMSITE)_ ",1,",DIC( 0)="EMQ",X ="?" D ^DI C
  7838   "RTN","PRC AFUT",186, 0)
  7839    Q
  7840   "RTN","PRC AFUT",187, 0)
  7841    ;
  7842   "RTN","PRC AFUT",188, 0)
  7843   FND(BILL)  ;Get fund  for a bill
  7844   "RTN","PRC AFUT",189, 0)
  7845    I '$D(^PR CA(430,BIL L,0)) Q -1
  7846   "RTN","PRC AFUT",190, 0)
  7847    I $D(^PRC A(430,BILL ,11)),$P(^ (11),"^",1 7)'="" Q $ P(^(11),"^ ",17)
  7848   "RTN","PRC AFUT",191, 0)
  7849    I $P(^PRC A(430,BILL ,0),"^",18 )'="" Q $E ($P(^(0)," ^",18),4,9 )
  7850   "RTN","PRC AFUT",192, 0)
  7851    Q -1
  7852   "RTN","PRC AFUT",193, 0)
  7853    ;
  7854   "RTN","PRC AHIS")
  7855   0^37^B2600 2669^B2557 0251
  7856   "RTN","PRC AHIS",1,0)
  7857   PRCAHIS ;W ASH-ISC@AL TOONA,PA/L DB-Transac tion Histo ry Report  ;9/27/93   4:32 PM
  7858   "RTN","PRC AHIS",2,0)
  7859   V ;;4.5;Ac counts Rec eivable;** 110,198,23 3,315**;Ma r 20, 1995 ;Build 55
  7860   "RTN","PRC AHIS",3,0)
  7861    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  7862   "RTN","PRC AHIS",4,0)
  7863    ;
  7864   "RTN","PRC AHIS",5,0)
  7865   EN ;Ask de btor and d ate range  for transa ction hist ory
  7866   "RTN","PRC AHIS",6,0)
  7867    K DIR S P OP=0
  7868   "RTN","PRC AHIS",7,0)
  7869    N DPTNOFZ Y,DPTNOFZK  S (DPTNOF ZY,DPTNOFZ K)=1
  7870   "RTN","PRC AHIS",8,0)
  7871    S DIR(0)= "PO^340:QE AMZ",DIR(" A")="Selec t Patient  ",DIR("?") ="Enter a  Patient na me" D ^DIR
  7872   "RTN","PRC AHIS",9,0)
  7873    I $D(DIRU T)!(Y="")  G EXIT1
  7874   "RTN","PRC AHIS",10,0 )
  7875    I $P($G(^ RCD(340,+Y ,0)),U)'[" DPT" W *7  G EN
  7876   "RTN","PRC AHIS",11,0 )
  7877    S DEB=+Y  K DIR
  7878   "RTN","PRC AHIS",12,0 )
  7879    I '$D(^PR CA(433,"AT D",DEB)),' $D(^PRCA(4 30,"ATD",D EB)),'$D(^ RC(341,"AD ",DEB)) W  !,"This pa tient has  no activit y." Q
  7880   "RTN","PRC AHIS",13,0 )
  7881    S BDATE=$ O(^PRCA(43 3,"ATD",+D EB,0)),DIR (0)="DO" S :'BDATE BD ATE=291010 1
  7882   "RTN","PRC AHIS",14,0 )
  7883    S DIR("A" )="History  beginning ",DIR("B") =$$FMTE^XL FDT(BDATE, "1D")
  7884   "RTN","PRC AHIS",15,0 )
  7885    S DIR("?" )="The def ault date  is either  the last s tatement d ay or T-30 , but any  date may b e entered. "
  7886   "RTN","PRC AHIS",16,0 )
  7887    D ^DIR
  7888   "RTN","PRC AHIS",17,0 )
  7889    S:Y'="" B DATE=Y I $ D(DIRUT)&' Y G EXIT1  Q
  7890   "RTN","PRC AHIS",18,0 )
  7891    K DIR,X,Y
  7892   "RTN","PRC AHIS",19,0 )
  7893    S DIR(0)= "DO^"_BDAT E_":DT"
  7894   "RTN","PRC AHIS",20,0 )
  7895    S DIR("A" )="History  ending",D IR("B")=$$ FMTE^XLFDT (DT,"1D")
  7896   "RTN","PRC AHIS",21,0 )
  7897    D ^DIR S: Y="" Y=DT  I $D(DIRUT )&'Y G EXI T1 Q
  7898   "RTN","PRC AHIS",22,0 )
  7899    S EDATE=Y
  7900   "RTN","PRC AHIS",23,0 )
  7901    K DIR
  7902   "RTN","PRC AHIS",24,0 )
  7903   TYPE S DIC ="^PRCA(43 0.3,",DIC( 0)="QEMZ", DIC("S")=" I +Y,(+Y<1 5!(""25^29 ^34^35^40^ 41^43^45^4 7^50^51^53 ^54^55^56^ 57^58^59^6 0^61^62^63 ^64^65""[( ""^""_+Y_" "^"")))"
  7904   "RTN","PRC AHIS",25,0 )
  7905    S Y=0 R ! ,"TRANSACT ION TYPE:  ALL//",X:D TIME I '$T !(X="^") Q
  7906   "RTN","PRC AHIS",26,0 )
  7907    I X]"",X' ="ALL" D ^ DIC
  7908   "RTN","PRC AHIS",27,0 )
  7909    I X["?" W  !!,"Enter  'ALL' for  all types  of transa ctions in  the AR TRA NSACTION T YPE FILE", !,"includi ng COMMENT S and STAT EMENT DATE S.",! G TY PE
  7910   "RTN","PRC AHIS",28,0 )
  7911    G:Y<0 EXI T1  S TYP= $S(+Y:+Y,1 :X)
  7912   "RTN","PRC AHIS",29,0 )
  7913    I $P($G(^ PRCA(430.3 ,+Y,0)),"^ ",3)>100 W  !!,"This  is STATUS.  Enter a t ransaction  type only ." G TYPE
  7914   "RTN","PRC AHIS",30,0 )
  7915    S %ZIS="A EQ" D ^%ZI S G:POP EX IT1
  7916   "RTN","PRC AHIS",31,0 )
  7917    I $D(IO(" Q")) D  Q
  7918   "RTN","PRC AHIS",32,0 )
  7919    .S ZTSAVE ("DEB")="" ,ZTSAVE("B DATE")="", ZTSAVE("ED ATE")="",Z TSAVE("TYP ")="",ZTRT N="DQ^PRCA HIS",ZTDES C="Patient  Transacti on History  Report"
  7920   "RTN","PRC AHIS",33,0 )
  7921    .D ^%ZTLO AD,^%ZISC, EXIT1 K ZT SAVE,ZTRTN  Q
  7922   "RTN","PRC AHIS",34,0 )
  7923    ;
  7924   "RTN","PRC AHIS",35,0 )
  7925   DQ ;Call t o build ar ray of pay ment trans actions
  7926   "RTN","PRC AHIS",36,0 )
  7927    ;
  7928   "RTN","PRC AHIS",37,0 )
  7929    U IO
  7930   "RTN","PRC AHIS",38,0 )
  7931    D TRANS^P RCAHIS1
  7932   "RTN","PRC AHIS",39,0 )
  7933    I '$D(^TM P("PRCAGT" ,$J)) W !! ,"This pat ient has n o activity  during th is time pe riod."
  7934   "RTN","PRC AHIS",40,0 )
  7935    I $D(^TMP ("PRCAGT", $J)) D HDR ,PRINT
  7936   "RTN","PRC AHIS",41,0 )
  7937    ;
  7938   "RTN","PRC AHIS",42,0 )
  7939   EXIT1 K AM T,BDATE,BN ,BN0,CAT,C ATCARE,EDA TE,EVNTT,D AT1,DAT2,D ATE,DEB,DI C,DIR,DIWL ,DIWF,DIWR ,DIWT,DUOU T,DX,DY,EV NT,EVNTT,L INE,PG,PNO DE,TBAL,TO TPRIN,TOTT RAN,TTYP,T YP,TN,TN0, X,Y,Z,ZTSK ,^TMP("PRC AGT",$J),^ UTILITY($J )
  7940   "RTN","PRC AHIS",43,0 )
  7941    I $D(DIRU T)!POP K D IRUT,POP Q
  7942   "RTN","PRC AHIS",44,0 )
  7943    ;end of r outine
  7944   "RTN","PRC AHIS",45,0 )
  7945   EXIT2 I $E (IOST,1,2) '="C-" W @ IOF D ^%ZI SC Q
  7946   "RTN","PRC AHIS",46,0 )
  7947    I $E(IOST ,1,2)="C-"  W ! D ENS ^%ZISS S D Y=IOM-1,DX =0 X IOXY  D KILL^%ZI SS K DIR,X ,Y,^UTILIT Y($J) S DI R(0)="E" D  ^DIR
  7948   "RTN","PRC AHIS",47,0 )
  7949    I $D(DIRU T) K DIRUT  Q
  7950   "RTN","PRC AHIS",48,0 )
  7951    D ^%ZISC
  7952   "RTN","PRC AHIS",49,0 )
  7953    G EN
  7954   "RTN","PRC AHIS",50,0 )
  7955    ;
  7956   "RTN","PRC AHIS",51,0 )
  7957    ;
  7958   "RTN","PRC AHIS",52,0 )
  7959   PRINT ;Pri nt transac tions
  7960   "RTN","PRC AHIS",53,0 )
  7961    K DIRUT
  7962   "RTN","PRC AHIS",54,0 )
  7963    S DATE=0  F  S DATE= $O(^TMP("P RCAGT",$J, DEB,DATE))  Q:'DATE   Q:$D(DIRUT )  D
  7964   "RTN","PRC AHIS",55,0 )
  7965    .S BN=""  F  S BN=$O (^TMP("PRC AGT",$J,DE B,DATE,BN) ) Q:BN=""! ($D(DIRUT) )  D SCRN  D
  7966   "RTN","PRC AHIS",56,0 )
  7967    ..I $D(^T MP("PRCAGT ",$J,DEB,D ATE,0)) S  (BN0,PNODE )=^(0) D
  7968   "RTN","PRC AHIS",57,0 )
  7969    ...W !,$$ FMTE^XLFDT ($P(DATE," .")),?16
  7970   "RTN","PRC AHIS",58,0 )
  7971    ...S TYP= $P(BN0,"^" ,2) W $S(T YP=1:"COMM ENT",1:"PA TIENT STAT EMENT PRIN TED") I TY P=1 S EVNT =$P(BN0,"^ ",3) D
  7972   "RTN","PRC AHIS",59,0 )
  7973    ....W:$D( ^RC(341,+E VNT,4)) !, ?16,$P(^(4 ),"^")
  7974   "RTN","PRC AHIS",60,0 )
  7975    ....I $O( ^RC(341,+E VNT,2,0))  S EVNTT=0  F  S EVNTT =$O(^RC(34 1,+EVNT,2, EVNTT)) Q: 'EVNTT  I  $D(^(EVNTT ,0)) S X=^ (0) D  Q:$ D(DIRUT)   D ^DIWW
  7976   "RTN","PRC AHIS",61,0 )
  7977    .....S DI WL=17,DIWF ="WC63" D  ^DIWP
  7978   "RTN","PRC AHIS",62,0 )
  7979    .....D SC RN
  7980   "RTN","PRC AHIS",63,0 )
  7981    ..Q:(BN=0 )  S TN=""  F  S TN=$ O(^TMP("PR CAGT",$J,D EB,DATE,BN ,TN)) Q:TN =""  Q:$D( DIRUT)  D  SCRN D
  7982   "RTN","PRC AHIS",64,0 )
  7983    ...I 'TN, $D(^TMP("P RCAGT",$J, DEB,DATE,B N,0)) S PN ODE=^(0),B N0=$G(^PRC A(430,+BN, 0)) W !!,$ $FMTE^XLFD T($P(DATE, ".")) D
  7984   "RTN","PRC AHIS",65,0 )
  7985    ....S CAT =$P(BN0,"^ ",2),CAT=$ S(CAT=24&$ P(BN0,"^", 16):$P(^PR CA(430.2,$ P(BN0,"^", 16),0),"^" ),1:$P($G( ^PRCA(430. 2,+CAT,0)) ,"^"))
  7986   "RTN","PRC AHIS",66,0 )
  7987    ....W ?16 ,CAT," BIL L",?56,$P( $G(^PRCA(4 30,+BN,0)) ,"^"),?69, $J(+PNODE, 10,2)
  7988   "RTN","PRC AHIS",67,0 )
  7989    ....W !,? 16,$P($G(^ PRCA(430.3 ,+$P(BN0," ^",8),0)), "^")
  7990   "RTN","PRC AHIS",68,0 )
  7991    ...I TN S  PNODE=^TM P("PRCAGT" ,$J,DEB,DA TE,BN,TN)  W !!,$$FMT E^XLFDT(DA TE,"1D"),? 16 S TYP=$ P($G(^PRCA (433,+TN,1 )),"^",2), TTYP=$P($G (^PRCA(430 .3,+TYP,0) ),U) W TTY P D
  7992   "RTN","PRC AHIS",69,0 )
  7993    ....S CAT =$P($G(^PR CA(430,+BN ,0)),"^",2 ),CAT=$P($ G(^PRCA(43 0.2,+CAT,0 )),"^")
  7994   "RTN","PRC AHIS",70,0 )
  7995    ....S CAT CARE=$P($G (^PRCA(430 ,+BN,0))," ^",16),CAT CARE=$P($G (^PRCA(430 .2,+$P(^(0 ),"^",16), 0)),"^")
  7996   "RTN","PRC AHIS",71,0 )
  7997    ...I TN W  ?56,$P($G (^PRCA(430 ,+BN,0))," ^") W:+TYP '=45 ?69,$ J(+PNODE,1 0,2)
  7998   "RTN","PRC AHIS",72,0 )
  7999    ...I TN W  !?16,CAT  W:CATCARE] "" !,?16,C ATCARE
  8000   "RTN","PRC AHIS",73,0 )
  8001    ...I TN,( +TYP=45) D
  8002   "RTN","PRC AHIS",74,0 )
  8003    ....I $D( ^PRCA(433, +TN,5)) W  !?16,$P(^( 5),"^",2)
  8004   "RTN","PRC AHIS",75,0 )
  8005    ....I $O( ^PRCA(433, +TN,7,0))  S TN0=0 F   S TN0=$O( ^PRCA(433, +TN,7,TN0) ) Q:'TN0   I $D(^(TN0 ,0)) S X=^ (0) D  Q:$ D(DIRUT)   D ^DIWW
  8006   "RTN","PRC AHIS",76,0 )
  8007    .....S DI WL=17,DIWF ="C63W" D  ^DIWP
  8008   "RTN","PRC AHIS",77,0 )
  8009    ...D SCRN
  8010   "RTN","PRC AHIS",78,0 )
  8011    ..Q
  8012   "RTN","PRC AHIS",79,0 )
  8013    .Q
  8014   "RTN","PRC AHIS",80,0 )
  8015    Q
  8016   "RTN","PRC AHIS",81,0 )
  8017    ;
  8018   "RTN","PRC AHIS",82,0 )
  8019   SCRN ;Chec k for scre en
  8020   "RTN","PRC AHIS",83,0 )
  8021    N X,Y K D IR I ($Y+5 )>IOSL D
  8022   "RTN","PRC AHIS",84,0 )
  8023    .I $E(IOS T,1,2)="C- " S DIR(0) ="E" D ^DI R Q:$D(DIR UT)
  8024   "RTN","PRC AHIS",85,0 )
  8025    .D HDR
  8026   "RTN","PRC AHIS",86,0 )
  8027    Q
  8028   "RTN","PRC AHIS",87,0 )
  8029    ;
  8030   "RTN","PRC AHIS",88,0 )
  8031   HDR ;Headi ng for rep ort
  8032   "RTN","PRC AHIS",89,0 )
  8033    S PG=PG+1
  8034   "RTN","PRC AHIS",90,0 )
  8035    W @IOF,!, ?20,"Patie nt Transac tion Histo ry Report" ,?70,"Page  ",PG
  8036   "RTN","PRC AHIS",91,0 )
  8037    W !,?20," ---------- ---------- ---------- -------"
  8038   "RTN","PRC AHIS",92,0 )
  8039    W !!,?18, "For Patie nt: ",$$NA M^RCFN01(D EB),!,?25, "SSN : ",$ $SSN^RCFN0 1(DEB)
  8040   "RTN","PRC AHIS",93,0 )
  8041    W !,?20," For dates:  ",$$FMTE^ XLFDT(BDAT E,"1D"),"- ",$$FMTE^X LFDT(EDATE ,"1D")
  8042   "RTN","PRC AHIS",94,0 )
  8043    W !!," DA TE",?16,"A CTIVITY",? 56,"BILL # ",?73,"AMO UNT",!,LIN E
  8044   "RTN","PRC APCL")
  8045   0^11^B4175 1936^B2537 8502
  8046   "RTN","PRC APCL",1,0)
  8047   PRCAPCL ;W ASH-ISC@AL TOONA,PA/N YB-Print B ill Status  Report ;8 /19/94  10 :21 AM
  8048   "RTN","PRC APCL",2,0)
  8049   V ;;4.5;Ac counts Rec eivable;** 72,63,143, 154,315**; Mar 20, 19 95;Build 5 5
  8050   "RTN","PRC APCL",3,0)
  8051    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  8052   "RTN","PRC APCL",4,0)
  8053    N BAL,BN, CAT,DEAD,D EBT,DIR,DI ROUT,DUOUT ,DP,DP2,HD R,IOP,N430
  8054   "RTN","PRC APCL",5,0)
  8055    N PAGE,PO P,PRCAE,PR CATOT,PRCA TOT2,PRCAT ,PRCAT2,PR CY,RCDOJ,T DT,ST,STT
  8056   "RTN","PRC APCL",6,0)
  8057    S (PAGE,P RCAT,PRCAT 2,PRCATOT, PRCATOT2,H DR)=0
  8058   "RTN","PRC APCL",7,0)
  8059    D NOW^%DT C S Y=% X  ^DD("DD")  S TDT=Y
  8060   "RTN","PRC APCL",8,0)
  8061    I $G(STAT )="ALL" S  STT=0 F  S  STT=($O(^ PRCA(430.3 ,"AC",STT) )) Q:STT=" "  D
  8062   "RTN","PRC APCL",9,0)
  8063    . I STT<1 00!(STT=10 7) Q
  8064   "RTN","PRC APCL",10,0 )
  8065    . S STAT( $O(^PRCA(4 30.3,"AC", STT,0)))=" "
  8066   "RTN","PRC APCL",11,0 )
  8067    . Q
  8068   "RTN","PRC APCL",12,0 )
  8069    S STAT=0  F  S STAT= $O(STAT(ST AT)) Q:STA T=""!($D(D IROUT))!($ D(DUOUT))   D
  8070   "RTN","PRC APCL",13,0 )
  8071    . N NDE
  8072   "RTN","PRC APCL",14,0 )
  8073    . D HDR
  8074   "RTN","PRC APCL",15,0 )
  8075    . F PRCAE =0:0 S PRC AE=$O(^PRC A(430,"AC" ,STAT,PRCA E)),X="" Q :'PRCAE!($ D(DIROUT)! ($D(DUOUT) ))  I $P($ G(^PRCA(43 0,PRCAE,10 0)),"^",2) [$G(SER),$ S($G(SER): +$G(^PRCA( 430,PRCAE, 100)),1:1)  D  Q:$D(D IROUT)!($D (DUOUT))   D PRNTL
  8076   "RTN","PRC APCL",16,0 )
  8077    .. I $Y+4 >IOSL D TO P,HDR
  8078   "RTN","PRC APCL",17,0 )
  8079    . I $Y+4> IOSL D TOP ,HDR Q:$D( DIROUT)!($ D(DUOUT))
  8080   "RTN","PRC APCL",18,0 )
  8081    . S DP1=$ S(+DAT>0:+ DAT,1:0)
  8082   "RTN","PRC APCL",19,0 )
  8083    . S DP2=$ S(+$P($G(D AT),"^",2) =0:"",1:+$ P($G(DAT), "^",2))
  8084   "RTN","PRC APCL",20,0 )
  8085    . S ST=""  F  S ST=$ O(^TMP($J, "PRCAE",ST )) Q:ST="" !($D(DIROU T)!($D(DUO UT)))  D
  8086   "RTN","PRC APCL",21,0 )
  8087    .. I STAT =40 D STHD R
  8088   "RTN","PRC APCL",22,0 )
  8089    .. S DP=0  F  S DP=$ O(^TMP($J, "PRCAE",ST ,DP)) Q:'D P!($D(DIRO UT)!($D(DU OUT)))  D
  8090   "RTN","PRC APCL",23,0 )
  8091    ... S BN= "" F  S BN =$O(^TMP($ J,"PRCAE", ST,DP,BN))  Q:BN=""!( $D(DIROUT) !($D(DUOUT )))  D
  8092   "RTN","PRC APCL",24,0 )
  8093    .... S ND E=^TMP($J, "PRCAE",ST ,DP,BN)
  8094   "RTN","PRC APCL",25,0 )
  8095    .... S Y= DP X ^DD(" DD") S DP2 =Y K Y
  8096   "RTN","PRC APCL",26,0 )
  8097    .... S RC DOJ=$$REFS T^RCRCUTL( +$O(^PRCA( 430,"B",BN ,0)))
  8098   "RTN","PRC APCL",27,0 )
  8099    .... W $G (DP2),?15, $S(RCDOJ&$ G(BN):$G(B N)_"r",1:$ G(BN)),?30 ,$P(NDE,U, 2),?45,$P( NDE,U,3)
  8100   "RTN","PRC APCL",28,0 )
  8101    .... W ?6 5,$J($P(ND E,U,4),9,2 ),!
  8102   "RTN","PRC APCL",29,0 )
  8103    .... S PR CATOT2=PRC ATOT2+$P(N DE,U,4),PR CAT2=PRCAT 2+1
  8104   "RTN","PRC APCL",30,0 )
  8105    .... S PR CATOT=PRCA TOT+$P(NDE ,U,4),PRCA T=PRCAT+1
  8106   "RTN","PRC APCL",31,0 )
  8107    .... I $Y +4>IOSL D  TOP,HDR Q: $D(DIROUT) !($D(DUOUT ))  I STAT =40 D STHD R
  8108   "RTN","PRC APCL",32,0 )
  8109    .... K ^T MP($J,"PRC AE",ST,DP, BN)
  8110   "RTN","PRC APCL",33,0 )
  8111    . I X'="^ " W !!!,"S UBTOTAL: " ,$J(PRCATO T2,10,2),! ,"SUBCOUNT : ",$J(PRC AT2,10),?3 0 Q:$D(DIR OUT)!($D(D UOUT))
  8112   "RTN","PRC APCL",34,0 )
  8113    . S (PRCA TOT2,PRCAT 2)=0
  8114   "RTN","PRC APCL",35,0 )
  8115    . Q:$D(DI ROUT)!($D( DUOUT))
  8116   "RTN","PRC APCL",36,0 )
  8117    . I $O(ST AT(STAT))= "" Q
  8118   "RTN","PRC APCL",37,0 )
  8119    . I $O(ST AT(STAT))' ="" W !! D  TOP
  8120   "RTN","PRC APCL",38,0 )
  8121    I X'="^"  W !!!,"TOT AL: ",$J(P RCATOT,10, 2),!,"COUN T: ",$J(PR CAT,10),!, " MEAN: ", $J($S('PRC AT:0,1:PRC ATOT/PRCAT ),10,2),?3 0,"* -indi cates that  patient i s deceased ",!,?30,"r  -indicate s that bil l is refer red"
  8122   "RTN","PRC APCL",39,0 )
  8123    W:$E(IOST )="P" @IOF  Q
  8124   "RTN","PRC APCL",40,0 )
  8125   TOP ;
  8126   "RTN","PRC APCL",41,0 )
  8127    I $E(IOST )="C" S X= "" S DIR(0 )="E" D ^D IR Q:$D(DI ROUT)!($D( DUOUT))
  8128   "RTN","PRC APCL",42,0 )
  8129   Q2 Q
  8130   "RTN","PRC APCL",43,0 )
  8131   PRNTL ;
  8132   "RTN","PRC APCL",44,0 )
  8133    N BAL,DEA D,DEBT,ST
  8134   "RTN","PRC APCL",45,0 )
  8135    S X=$S($D (^PRCA(430 ,PRCAE,0)) :^(0),1:"" ) G:X="" P Q
  8136   "RTN","PRC APCL",46,0 )
  8137    S BN=$P($ G(X),U),DP =$P($G(X), U,14),PRCY =$P($G(X), U,2) G:BN= "" PQ
  8138   "RTN","PRC APCL",47,0 )
  8139    S BEG=+DA T-1,END=+$ P(DAT,U,2)
  8140   "RTN","PRC APCL",48,0 )
  8141    S ST=999  I STAT=40  D SUST ;PR CA*4.5*315 /DRF Find  suspended  type
  8142   "RTN","PRC APCL",49,0 )
  8143    I BEG,DP' >BEG Q
  8144   "RTN","PRC APCL",50,0 )
  8145    I END,DP> END Q
  8146   "RTN","PRC APCL",51,0 )
  8147    I STAT=40 ,$G(PRSELS T)'="",PRS ELST'[("," _ST_",") Q   ;PRCA*4. 5*315/DRF  Quit if su spended ty pe is not  selected
  8148   "RTN","PRC APCL",52,0 )
  8149    S (CAT,PR CY)=$S(PRC Y="":PRCY, $D(^PRCA(4 30.2,PRCY, 0))#2:$P(^ (0),U),1:P RCY)
  8150   "RTN","PRC APCL",53,0 )
  8151    S PRCY=$S ($D(^RCD(3 40,+$P(X,U ,9),0)):$P (^(0),U),1 :"")
  8152   "RTN","PRC APCL",54,0 )
  8153    I PRCY["D PT" S DFN= +PRCY D DE M^VADPT S: +VADM(6) D EAD="*" D  KVAR^VADPT  K VA,VADM
  8154   "RTN","PRC APCL",55,0 )
  8155    I PRCY]""  S (DEBT,P RCY)=$S($D (@("^"_$P( PRCY,";",2 )_+PRCY_", 0)")):^(0) ,1:"")
  8156   "RTN","PRC APCL",56,0 )
  8157    S PRCY=$S ($D(^PRCA( 430,PRCAE, 7)):^(7),1 :"")
  8158   "RTN","PRC APCL",57,0 )
  8159    I 'PRCY,( STAT=$O(^P RCA(430.3, "AC",104,0 ))!((STAT= 20)&($G(^P RCA(430,PR CAE,100))) ))
  8160   "RTN","PRC APCL",58,0 )
  8161    S (BAL,PR CY)=$P(PRC Y,U)+$P(PR CY,U,2)+$P (PRCY,U,3) +$P(PRCY,U ,4)+$P(PRC Y,U,5)
  8162   "RTN","PRC APCL",59,0 )
  8163    I DP'=""  S ^TMP($J, "PRCAE",ST ,DP,BN)=U_ $E(CAT,1,1 3)_U_$G(DE AD)_$E($P( $G(DEBT),U ),1,15)_U_ $G(BAL)_U_ $G(PRCATOT 2)_U_$G(PR CAT2)
  8164   "RTN","PRC APCL",60,0 )
  8165    I $G(SER) ,(STAT=31! (STAT=32))  S Y=$G(^P RCA(430,PR CAE,3)) D
  8166   "RTN","PRC APCL",61,0 )
  8167    . W:$P(Y, U)]"" !,"D ate: ",$E( $P(Y,U),4, 5),"/",$E( $P(Y,U),6, 7),"/",$E( $P(Y,U),2, 3)
  8168   "RTN","PRC APCL",62,0 )
  8169    . W:$P(Y, U,2)]"" "   By: ",$P( $G(^VA(200 ,+$P(Y,U,2 ),0)),U)
  8170   "RTN","PRC APCL",63,0 )
  8171    . W:$P(Y, U,6)]"" "   Reason: " ,$P(Y,U,6)
  8172   "RTN","PRC APCL",64,0 )
  8173    . Q
  8174   "RTN","PRC APCL",65,0 )
  8175    I $E(IOST )="",$Y+4> IOSL D TOP
  8176   "RTN","PRC APCL",66,0 )
  8177   PQ Q
  8178   "RTN","PRC APCL",67,0 )
  8179   HDR ;
  8180   "RTN","PRC APCL",68,0 )
  8181    I $E(IOST )="C"!PAGE  W @IOF
  8182   "RTN","PRC APCL",69,0 )
  8183    S PAGE=PA GE+1
  8184   "RTN","PRC APCL",70,0 )
  8185    W !,"BILL  STATUS LI STING REPO RT"
  8186   "RTN","PRC APCL",71,0 )
  8187    W ?40,$G( TDT),?72,$ G(PAGE)
  8188   "RTN","PRC APCL",72,0 )
  8189    W !,"Sort  Criteria  for Date L ast Update d Range: " _SC1_" to  "_SC2
  8190   "RTN","PRC APCL",73,0 )
  8191    W !,"Date  Last",!,"  Updated", ?15,"Bill  no.",?30," Category"
  8192   "RTN","PRC APCL",74,0 )
  8193    W ?50,"De btor",?68, "Balance", !
  8194   "RTN","PRC APCL",75,0 )
  8195    S X="",$P (X,"-",IOM -1)="" W X ,!
  8196   "RTN","PRC APCL",76,0 )
  8197    W !,?5,"S tatus: ",$ P($S($D(^P RCA(430.3, STAT,0)):^ (0),1:""), U)
  8198   "RTN","PRC APCL",77,0 )
  8199    S HDR=1
  8200   "RTN","PRC APCL",78,0 )
  8201    W !!
  8202   "RTN","PRC APCL",79,0 )
  8203    Q
  8204   "RTN","PRC APCL",80,0 )
  8205   DT I Y X ^ DD("DD") S  DP2=Y
  8206   "RTN","PRC APCL",81,0 )
  8207    Q
  8208   "RTN","PRC APCL",82,0 )
  8209   STAT(SER)  W ! ;Bill  Status Lis ting
  8210   "RTN","PRC APCL",83,0 )
  8211    N BEG,CH, DAT,END,I, PRSELST,PR SUS,SC1,SC 2,STAT,STT ,XX
  8212   "RTN","PRC APCL",84,0 )
  8213    K ^TMP($J )
  8214   "RTN","PRC APCL",85,0 )
  8215    S DAT=$$D ATE^RCEVUT L1("")
  8216   "RTN","PRC APCL",86,0 )
  8217    Q:$G(DAT) =-1
  8218   "RTN","PRC APCL",87,0 )
  8219    S BEG=+DA T,END=+$P( DAT,U,2)
  8220   "RTN","PRC APCL",88,0 )
  8221    S SC1=$S( BEG=0:"Fir st",1:BEG- 1) I +$G(S C1) S Y=SC 1+1 X ^DD( "DD") S SC 1=Y
  8222   "RTN","PRC APCL",89,0 )
  8223    S SC2=$S( END=0:"Las t",1:END)  I +$G(SC2)  S Y=SC2 X  ^DD("DD")  S SC2=Y
  8224   "RTN","PRC APCL",90,0 )
  8225    S XX=^DD( 433,90,0), XX=$P(XX," ^",3) F I= 1:1 S CH=$ P(XX,";",I ) Q:CH=""   S PRSUS($ P(CH,":",1 ))=$P(CH," :",2)
  8226   "RTN","PRC APCL",91,0 )
  8227    D ST
  8228   "RTN","PRC APCL",92,0 )
  8229    Q:STAT="^ "
  8230   "RTN","PRC APCL",93,0 )
  8231    D TSK,Q1
  8232   "RTN","PRC APCL",94,0 )
  8233    Q
  8234   "RTN","PRC APCL",95,0 )
  8235   ST N DIC,X ,Y
  8236   "RTN","PRC APCL",96,0 )
  8237    S DIC="^P RCA(430.3, ",DIC(0)=" QEMZ"
  8238   "RTN","PRC APCL",97,0 )
  8239    S DIC("S" )="I $P(^( 0),""^"",3 )>100,($P( ^(0),""^"" ,3)'=107)"
  8240   "RTN","PRC APCL",98,0 )
  8241    S Y=0 W ! ,"STATUS:  "_$S('$O(S TAT("")):" ALL// ",1: "")
  8242   "RTN","PRC APCL",99,0 )
  8243    R X:DTIME  I '$T!(X= "^") S STA T="^" Q
  8244   "RTN","PRC APCL",100, 0)
  8245    I ((X="") !(X="ALL") ),'$O(STAT ("")) S (S TAT,X)="AL L" Q
  8246   "RTN","PRC APCL",101, 0)
  8247    I X="" Q
  8248   "RTN","PRC APCL",102, 0)
  8249    D ^DIC S  STAT=+Y,SE R=$G(SER)
  8250   "RTN","PRC APCL",103, 0)
  8251    I X["?" W  !!,"Enter  'ALL' for  all statu s types.", ! G ST
  8252   "RTN","PRC APCL",104, 0)
  8253    I STAT'=" ALL",(+STA T>0) S STA T(+STAT)=" " D:STAT=4 0 SUSTYP G  ST
  8254   "RTN","PRC APCL",105, 0)
  8255    G:+STAT<0  ST
  8256   "RTN","PRC APCL",106, 0)
  8257    Q
  8258   "RTN","PRC APCL",107, 0)
  8259   SUSTYP ;If  SUSPENDED  is chosen , prompt f or which s uspended b ills to di splay PRCA *4.5*315/D RF
  8260   "RTN","PRC APCL",108, 0)
  8261    N X,CH,LA ST,PRPRT
  8262   "RTN","PRC APCL",109, 0)
  8263    S LAST=$O (PRSUS("") ,-1),PRSUS (LAST+1)=" NONE"
  8264   "RTN","PRC APCL",110, 0)
  8265    S PRSUS(L AST+2)="AL L OF THE A BOVE"
  8266   "RTN","PRC APCL",111, 0)
  8267    S PRPRT=" Choose fro m SUSPENDE D TYPE:"
  8268   "RTN","PRC APCL",112, 0)
  8269    S PRSELST =$$MLTP0(P RPRT,.PRSU S,1)
  8270   "RTN","PRC APCL",113, 0)
  8271    Q
  8272   "RTN","PRC APCL",114, 0)
  8273   SUST ;Look  for suspe nded type  for a susp ended bill  PRCA*4.5* 315/DRF
  8274   "RTN","PRC APCL",115, 0)
  8275    N TRANS
  8276   "RTN","PRC APCL",116, 0)
  8277    S TRANS=$ O(^PRCA(43 3,"C",PRCA E,""),-1)
  8278   "RTN","PRC APCL",117, 0)
  8279    S ST=$P($ G(^PRCA(43 3,TRANS,1) ),U,11)
  8280   "RTN","PRC APCL",118, 0)
  8281    I ST="" S  ST=12
  8282   "RTN","PRC APCL",119, 0)
  8283    Q
  8284   "RTN","PRC APCL",120, 0)
  8285   STHDR ;Dis play Suspe nded Type  PRCA*4.5*3 15/DRF
  8286   "RTN","PRC APCL",121, 0)
  8287    I 'HDR W  !
  8288   "RTN","PRC APCL",122, 0)
  8289    W ?30,"Su spend Type : ",PRSUS( ST),!!
  8290   "RTN","PRC APCL",123, 0)
  8291    S HDR=0
  8292   "RTN","PRC APCL",124, 0)
  8293    Q
  8294   "RTN","PRC APCL",125, 0)
  8295   TSK ;
  8296   "RTN","PRC APCL",126, 0)
  8297    N POP,ZTS K
  8298   "RTN","PRC APCL",127, 0)
  8299    W *7,!,"R eport shou ld be QUEU ED it coul d take som e time to  run!"
  8300   "RTN","PRC APCL",128, 0)
  8301    S POP=0,% ZIS="MQ" D  ^%ZIS G:P OP Q1
  8302   "RTN","PRC APCL",129, 0)
  8303    I '$D(IO( "Q")) U IO  D PRCAPCL  U IO(0) G  Q1
  8304   "RTN","PRC APCL",130, 0)
  8305    S ZTRTN=" ^PRCAPCL"
  8306   "RTN","PRC APCL",131, 0)
  8307    S (ZTSAVE ("BEG"),ZT SAVE("DAT" ),ZTSAVE(" END"),ZTSA VE("SER")) =""
  8308   "RTN","PRC APCL",132, 0)
  8309    S (ZTSAVE ("STAT"),Z TSAVE("STA T("),ZTSAV E("SC1"),Z TSAVE("SC2 "))=""
  8310   "RTN","PRC APCL",133, 0)
  8311    S (ZTSAVE ("PRSELST" ),ZTSAVE(" PRSUS("))= ""
  8312   "RTN","PRC APCL",134, 0)
  8313    S ZTDESC= "Bill Stat us Listing " D ^%ZTLO AD
  8314   "RTN","PRC APCL",135, 0)
  8315   Q1 D ^%ZIS C Q
  8316   "RTN","PRC APCL",136, 0)
  8317    ;
  8318   "RTN","PRC APCL",137, 0)
  8319    ;Choose m ultiple it ems from a  list incl uding valu e 0 - PRCA *4.5*315/D RF
  8320   "RTN","PRC APCL",138, 0)
  8321   MLTP0(PRPT ,OPT,ALL)  ; Function  for multi ple value  selection
  8322   "RTN","PRC APCL",139, 0)
  8323    ; Input:  PRPT - Str ing to be  prompted t o the user , before l isting opt ions
  8324   "RTN","PRC APCL",140, 0)
  8325    ;         OPT  - Arr ay contain ing the po ssible ent ries (inde xed by cod e)
  8326   "RTN","PRC APCL",141, 0)
  8327    ;                Obs : Code mus t be seque ntial star ting with  0
  8328   "RTN","PRC APCL",142, 0)
  8329    ;         ALL  - Fla g indicati ng if the  last optio n is ALL O F THE ABOV E
  8330   "RTN","PRC APCL",143, 0)
  8331    ;
  8332   "RTN","PRC APCL",144, 0)
  8333    ; Output:  MLTP - Us er selecti on, i.e. " 1,2,3," or  "1," or N ULL (nothi ng
  8334   "RTN","PRC APCL",145, 0)
  8335    ;                  w as selecte d)
  8336   "RTN","PRC APCL",146, 0)
  8337    ;
  8338   "RTN","PRC APCL",147, 0)
  8339    N A,DIR,D IRUT,DTOUT ,DUOUT,DIR OUT,I,IX,L ST,MLTP
  8340   "RTN","PRC APCL",148, 0)
  8341    ;
  8342   "RTN","PRC APCL",149, 0)
  8343   PRPT S MLT P="",ALL=+ $G(ALL)
  8344   "RTN","PRC APCL",150, 0)
  8345    S LST=$O( OPT(""),-1 )
  8346   "RTN","PRC APCL",151, 0)
  8347    S DIR(0)= "LO^0:"_LS T_"^K:+$P( X,""-"",2) >"_LST_" X "
  8348   "RTN","PRC APCL",152, 0)
  8349    S DIR("A" ,1)=$G(PRP T),DIR("A" ,2)=""
  8350   "RTN","PRC APCL",153, 0)
  8351    S A="",IX =3
  8352   "RTN","PRC APCL",154, 0)
  8353    F  S A=$O (OPT(A))   Q:A=""  D
  8354   "RTN","PRC APCL",155, 0)
  8355    . S DIR(" A",IX)="    "_A_" - " _$G(OPT(A) ),IX=IX+1
  8356   "RTN","PRC APCL",156, 0)
  8357    S DIR("A" ,IX)="",DI R("A")="Se lect",DIR( "B")=LST,D IR("T")=DT IME W !
  8358   "RTN","PRC APCL",157, 0)
  8359    D ^DIR K  DIR I $D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) S M LTP="" G Q T
  8360   "RTN","PRC APCL",158, 0)
  8361    S MLTP=Y  K DIROUT,D TOUT,DUOUT ,DIRUT
  8362   "RTN","PRC APCL",159, 0)
  8363    S DIR(0)= "Y",DIR("A ",1)="You  have selec ted",DIR(" A",2)=""
  8364   "RTN","PRC APCL",160, 0)
  8365    S A="",IX =3
  8366   "RTN","PRC APCL",161, 0)
  8367    F I=1:1:( $L(MLTP,", ")-1) D
  8368   "RTN","PRC APCL",162, 0)
  8369    . S DIR(" A",IX)="     "_$P(MLT P,",",I)_"  - "_$G(OP T($P(MLTP, ",",I)))
  8370   "RTN","PRC APCL",163, 0)
  8371    . S IX=IX +1
  8372   "RTN","PRC APCL",164, 0)
  8373    S DIR("A" ,IX)=""
  8374   "RTN","PRC APCL",165, 0)
  8375    S DIR("A" )="Are you  sure",DIR ("B")="NO" ,DIR("T")= DTIME W !
  8376   "RTN","PRC APCL",166, 0)
  8377    D ^DIR K  DIR I $D(D IRUT)!$D(D TOUT)!$D(D UOUT)!$D(D IROUT) S M LTP="" G Q T
  8378   "RTN","PRC APCL",167, 0)
  8379    K DIROUT, DTOUT,DUOU T,DIRUT I  'Y K DIR G  PRPT
  8380   "RTN","PRC APCL",168, 0)
  8381    I ALL,MLT P[LST S ML TP="" G QT
  8382   "RTN","PRC APCL",169, 0)
  8383    S MLTP=", "_MLTP
  8384   "RTN","PRC APCL",170, 0)
  8385    ;
  8386   "RTN","PRC APCL",171, 0)
  8387   QT Q MLTP
  8388   "RTN","PRC ARPM")
  8389   0^20^B3702 6153^n/a
  8390   "RTN","PRC ARPM",1,0)
  8391   PRCARPM ;A LB/DRF-CRE ATE MULTIP LE ACCOUNT  REPAYMENT  DATE SCHE DULE ;08/0 9/2016  4: 40 PM
  8392   "RTN","PRC ARPM",2,0)
  8393    ;;4.5;Acc ounts Rece ivable;**3 15**;Mar 2 0, 1995;Bu ild 55
  8394   "RTN","PRC ARPM",3,0)
  8395    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  8396   "RTN","PRC ARPM",4,0)
  8397    ;
  8398   "RTN","PRC ARPM",5,0)
  8399   BEGIN ;Sta rt here
  8400   "RTN","PRC ARPM",6,0)
  8401    N ACT,ADD ,ALL,D0,DE L,DIC,DIR, LIST,LSTDA TE,MULTI,N ON,PAYDATE ,PLN,PLNAM T,PLNDAY,P LNDT
  8402   "RTN","PRC ARPM",7,0)
  8403    N PLNFRST ,PLNLST,PL NNXT,PLNRM N,PLNTDUE, PRCA,PRCAD AY,PRCADT, PRCAFP,PRC AFPD,PRCAM T
  8404   "RTN","PRC ARPM",8,0)
  8405    N PRCANPA Y,PRCAPB,P RCAREM,SUC CESS,SURE, TOTAL,TOTD UE,X,Y
  8406   "RTN","PRC ARPM",9,0)
  8407    I $G(DEBT OR)]"" L - ^RCD(340,+ DEBTOR) ;R elease pre vious debt or lock
  8408   "RTN","PRC ARPM",10,0 )
  8409    S DEBTOR= $$DEBTOR^P RCARPU()
  8410   "RTN","PRC ARPM",11,0 )
  8411    I $G(DEBT OR)="" K D EBTOR Q
  8412   "RTN","PRC ARPM",12,0 )
  8413    W "  ",$$ NAM^RCFN01 (+DEBTOR)
  8414   "RTN","PRC ARPM",13,0 )
  8415    L +^RCD(3 40,+DEBTOR ):1 I '$T  W !,"Anoth er user is  editing t his record ",!! G BEG IN
  8416   "RTN","PRC ARPM",14,0 )
  8417    D ACCOUNT S^PRCARPU( +DEBTOR,.A LL,.PLN,.N ON,.ACT)
  8418   "RTN","PRC ARPM",15,0 )
  8419    I ACT=0 W  !,"No act ive bills  for this d ebtor",!!  G BEGIN
  8420   "RTN","PRC ARPM",16,0 )
  8421    I PLN=0 G  NOPLAN ;N o current  plan
  8422   "RTN","PRC ARPM",17,0 )
  8423    S MULTI=$ $MULTI^PRC ARPU(.PLN)  I MULTI G  MULTPLN ; Multiple e xisting pl ans
  8424   "RTN","PRC ARPM",18,0 )
  8425    I PLN G P LAN ;Singl e existing  plan
  8426   "RTN","PRC ARPM",19,0 )
  8427    G BEGIN
  8428   "RTN","PRC ARPM",20,0 )
  8429    ;
  8430   "RTN","PRC ARPM",21,0 )
  8431   PLAN ;Ther e is an ex isting Rep ayment Pla n
  8432   "RTN","PRC ARPM",22,0 )
  8433    S DIR(0)= "SA^E:EDIT ;D:DELETE; V:VIEW^",D IR("B")="V "
  8434   "RTN","PRC ARPM",23,0 )
  8435    S DIR("A" )="This Ve teran has  a Repaymen t Plan - ( D)elete, ( E)dit or ( V)iew it?  "
  8436   "RTN","PRC ARPM",24,0 )
  8437    D ^DIR
  8438   "RTN","PRC ARPM",25,0 )
  8439    I Y="V" G  VIEW
  8440   "RTN","PRC ARPM",26,0 )
  8441    I Y="D" G  DELETE
  8442   "RTN","PRC ARPM",27,0 )
  8443    I Y="E",N ON G EDITA DD
  8444   "RTN","PRC ARPM",28,0 )
  8445    I Y="E",N ON=0 G EDI T
  8446   "RTN","PRC ARPM",29,0 )
  8447    G BEGIN
  8448   "RTN","PRC ARPM",30,0 )
  8449    ;
  8450   "RTN","PRC ARPM",31,0 )
  8451   MULTPLN ;T here is mo re than on e existing  Repayment  Plan
  8452   "RTN","PRC ARPM",32,0 )
  8453    S DIR(0)= "Y"
  8454   "RTN","PRC ARPM",33,0 )
  8455    S DIR("A" )="This De btor has m ultiple pl ans - view  them"
  8456   "RTN","PRC ARPM",34,0 )
  8457    S DIR("?" )="Enter Y  to view m ultiple Re payment Pl ans"
  8458   "RTN","PRC ARPM",35,0 )
  8459    D ^DIR
  8460   "RTN","PRC ARPM",36,0 )
  8461    I 'Y G BE GIN
  8462   "RTN","PRC ARPM",37,0 )
  8463    D DSMPLNS ^PRCARPU(D EBTOR,.PLN )
  8464   "RTN","PRC ARPM",38,0 )
  8465    S DIR(0)= "Y"
  8466   "RTN","PRC ARPM",39,0 )
  8467    S DIR("A" )="This De btor has m ultiple pl ans - cons olidate th em"
  8468   "RTN","PRC ARPM",40,0 )
  8469    S DIR("?" )="Enter Y  to consol idate mult iple Repay ment Plans  into one"
  8470   "RTN","PRC ARPM",41,0 )
  8471    D ^DIR
  8472   "RTN","PRC ARPM",42,0 )
  8473    I 'Y G ML TDEL
  8474   "RTN","PRC ARPM",43,0 )
  8475    S TOTDUE= $$DUEARR^P RCARPU(.PL N) ;New to tal amount  due
  8476   "RTN","PRC ARPM",44,0 )
  8477    S SUCCESS =$$INQPLAN ^PRCARPU(T OTDUE,PLND T)
  8478   "RTN","PRC ARPM",45,0 )
  8479    I 'SUCCES S W !! G B EGIN
  8480   "RTN","PRC ARPM",46,0 )
  8481    D RPDEL^P RCARPU(.PL N)
  8482   "RTN","PRC ARPM",47,0 )
  8483    D ADDPLAN ^PRCARPU(. PLN,PRCAMT ,PRCADAY,P RCAFPD,PRC ADT)
  8484   "RTN","PRC ARPM",48,0 )
  8485    W !,"The  Repayment  Plan has b een consol idated.",!  D PAUSE^P RCARPU
  8486   "RTN","PRC ARPM",49,0 )
  8487    I 'Y G BE GIN
  8488   "RTN","PRC ARPM",50,0 )
  8489    D ACCOUNT S^PRCARPU( +DEBTOR,.A LL,.PLN,.N ON,.ACT) ; Reload acc ounts afte r change i s filed
  8490   "RTN","PRC ARPM",51,0 )
  8491    I NON G E DITADD
  8492   "RTN","PRC ARPM",52,0 )
  8493    D RPDIS^P RCARPU(DEB TOR,.PLN)
  8494   "RTN","PRC ARPM",53,0 )
  8495    D DISPLAY ^PRCARPU(. PLN,0)
  8496   "RTN","PRC ARPM",54,0 )
  8497    D PAUSE^P RCARPU
  8498   "RTN","PRC ARPM",55,0 )
  8499    I 'Y G BE GIN
  8500   "RTN","PRC ARPM",56,0 )
  8501    D PAYDISP ^PRCARPU(+ DEBTOR,PLN DT)
  8502   "RTN","PRC ARPM",57,0 )
  8503    D CMTENTR ^PRCARPU(+ DEBTOR)
  8504   "RTN","PRC ARPM",58,0 )
  8505    G BEGIN
  8506   "RTN","PRC ARPM",59,0 )
  8507    ;
  8508   "RTN","PRC ARPM",60,0 )
  8509   DELETE ;De lete a Rep ayment Pla n
  8510   "RTN","PRC ARPM",61,0 )
  8511    D RPDIS^P RCARPU(DEB TOR,.PLN)
  8512   "RTN","PRC ARPM",62,0 )
  8513    D DISPLAY ^PRCARPU(. PLN,0)
  8514   "RTN","PRC ARPM",63,0 )
  8515    S SURE=$$ CORRECT^PR CARPU()
  8516   "RTN","PRC ARPM",64,0 )
  8517    I '+SURE  G BEGIN
  8518   "RTN","PRC ARPM",65,0 )
  8519    D RPDEL^P RCARPU(.PL N,1)
  8520   "RTN","PRC ARPM",66,0 )
  8521    W !!,"The  Repayment  Plan for  "_$P(DEBTO R,U,2)_" h as been De leted.",!  D PAUSE^PR CARPU
  8522   "RTN","PRC ARPM",67,0 )
  8523    I 'Y G BE GIN
  8524   "RTN","PRC ARPM",68,0 )
  8525    D CMTENTR ^PRCARPU(+ DEBTOR)
  8526   "RTN","PRC ARPM",69,0 )
  8527    G BEGIN
  8528   "RTN","PRC ARPM",70,0 )
  8529    ;
  8530   "RTN","PRC ARPM",71,0 )
  8531   EDITADD ;E dit a Repa yment Plan  with new  bills
  8532   "RTN","PRC ARPM",72,0 )
  8533    D RPDIS^P RCARPU(DEB TOR,.PLN)
  8534   "RTN","PRC ARPM",73,0 )
  8535    D DISPLAY ^PRCARPU(. PLN,0)
  8536   "RTN","PRC ARPM",74,0 )
  8537    D PAUSE^P RCARPU
  8538   "RTN","PRC ARPM",75,0 )
  8539    I 'Y G BE GIN
  8540   "RTN","PRC ARPM",76,0 )
  8541    D PAYDISP ^PRCARPU(+ DEBTOR,PLN DT)
  8542   "RTN","PRC ARPM",77,0 )
  8543    W !,"Bill s not in R epayment P lan:",!
  8544   "RTN","PRC ARPM",78,0 )
  8545    S TOTAL=$ $DISPLAY^P RCARPU(.NO N,1)
  8546   "RTN","PRC ARPM",79,0 )
  8547    I TOTAL=0  G NOBILLS
  8548   "RTN","PRC ARPM",80,0 )
  8549    K ADD
  8550   "RTN","PRC ARPM",81,0 )
  8551    S LIST=$$ SELECT^PRC ARPU(.NON)
  8552   "RTN","PRC ARPM",82,0 )
  8553    I LIST=""  W !,"  No  Bills sel ected",! D  PAUSE^PRC ARPU G:'Y  BEGIN G NO BILLS
  8554   "RTN","PRC ARPM",83,0 )
  8555    D SUMM^PR CARPU(.NON ,LIST,.ADD )
  8556   "RTN","PRC ARPM",84,0 )
  8557    S TOTDUE= $$DUEARR^P RCARPU(.AD D) ;Amount  being add ed
  8558   "RTN","PRC ARPM",85,0 )
  8559    W !!,"Tot al amount  chosen is  $",$J(TOTD UE,8,2),!
  8560   "RTN","PRC ARPM",86,0 )
  8561    S SURE=$$ CORRECT^PR CARPU()
  8562   "RTN","PRC ARPM",87,0 )
  8563    I 'SURE W  !! G BEGI N
  8564   "RTN","PRC ARPM",88,0 )
  8565    M DEL=PLN
  8566   "RTN","PRC ARPM",89,0 )
  8567    D MERGE^P RCARPU(.PL N,.ADD)
  8568   "RTN","PRC ARPM",90,0 )
  8569   NOBILLS ;N o new bill  were chos en
  8570   "RTN","PRC ARPM",91,0 )
  8571    S TOTDUE= $$DUEARR^P RCARPU(.PL N) ;New to tal amount  due
  8572   "RTN","PRC ARPM",92,0 )
  8573    S SUCCESS =$$INQPLAN ^PRCARPU(T OTDUE,PLND T)
  8574   "RTN","PRC ARPM",93,0 )
  8575    I 'SUCCES S W !! G B EGIN
  8576   "RTN","PRC ARPM",94,0 )
  8577    I $G(DEL) >0 D RPDEL ^PRCARPU(. DEL,1)
  8578   "RTN","PRC ARPM",95,0 )
  8579    K DEL
  8580   "RTN","PRC ARPM",96,0 )
  8581    D ADDPLAN ^PRCARPU(. PLN,PRCAMT ,PRCADAY,P RCAFPD,PRC ADT,1)
  8582   "RTN","PRC ARPM",97,0 )
  8583    W !!,"The  Repayment  Plan has  been updat ed.",! D P AUSE^PRCAR PU
  8584   "RTN","PRC ARPM",98,0 )
  8585    I 'Y G BE GIN
  8586   "RTN","PRC ARPM",99,0 )
  8587    K ADD
  8588   "RTN","PRC ARPM",100, 0)
  8589    D ACCOUNT S^PRCARPU( +DEBTOR,.A LL,.PLN,.N ON,.ACT) ; Reload acc ounts afte r change i s filed 
  8590   "RTN","PRC ARPM",101, 0)
  8591    D RPDIS^P RCARPU(DEB TOR,.PLN)
  8592   "RTN","PRC ARPM",102, 0)
  8593    D DISPLAY ^PRCARPU(. PLN,0)
  8594   "RTN","PRC ARPM",103, 0)
  8595    D CMTENTR ^PRCARPU(+ DEBTOR)
  8596   "RTN","PRC ARPM",104, 0)
  8597    G BEGIN
  8598   "RTN","PRC ARPM",105, 0)
  8599    ;
  8600   "RTN","PRC ARPM",106, 0)
  8601   EDIT ;Edit  a Repayme nt Plan, n o new bill s
  8602   "RTN","PRC ARPM",107, 0)
  8603    D RPDIS^P RCARPU(DEB TOR,.PLN)
  8604   "RTN","PRC ARPM",108, 0)
  8605    D DISPLAY ^PRCARPU(. PLN,0)
  8606   "RTN","PRC ARPM",109, 0)
  8607    W !,"Ther e are no n ew bills t o be added .",!!
  8608   "RTN","PRC ARPM",110, 0)
  8609    D PAUSE^P RCARPU
  8610   "RTN","PRC ARPM",111, 0)
  8611    I 'Y G BE GIN
  8612   "RTN","PRC ARPM",112, 0)
  8613    D PAYDISP ^PRCARPU(+ DEBTOR,PLN DT)
  8614   "RTN","PRC ARPM",113, 0)
  8615    S SUCCESS =$$INQPLAN ^PRCARPU(P LNTDUE,PLN DT)
  8616   "RTN","PRC ARPM",114, 0)
  8617    I 'SUCCES S W !! G B EGIN
  8618   "RTN","PRC ARPM",115, 0)
  8619    D RPDEL^P RCARPU(.PL N,1)
  8620   "RTN","PRC ARPM",116, 0)
  8621    D ADDPLAN ^PRCARPU(. PLN,PRCAMT ,PRCADAY,P RCAFPD,PRC ADT,1)
  8622   "RTN","PRC ARPM",117, 0)
  8623    W !,"The  Repayment  Plan has b een update d.",! D PA USE^PRCARP U
  8624   "RTN","PRC ARPM",118, 0)
  8625    I 'Y G BE GIN
  8626   "RTN","PRC ARPM",119, 0)
  8627    D ACCOUNT S^PRCARPU( +DEBTOR,.A LL,.PLN,.N ON,.ACT) ; Reload acc ounts afte r change i s filed 
  8628   "RTN","PRC ARPM",120, 0)
  8629    D RPDIS^P RCARPU(DEB TOR,.PLN)
  8630   "RTN","PRC ARPM",121, 0)
  8631    D DISPLAY ^PRCARPU(. PLN,0)
  8632   "RTN","PRC ARPM",122, 0)
  8633    D CMTENTR ^PRCARPU(+ DEBTOR)
  8634   "RTN","PRC ARPM",123, 0)
  8635    G BEGIN
  8636   "RTN","PRC ARPM",124, 0)
  8637    ;
  8638   "RTN","PRC ARPM",125, 0)
  8639   NOPLAN ;De btor has n o Repaymen t Plan
  8640   "RTN","PRC ARPM",126, 0)
  8641    W !,"This  Veteran d oes not ha ve a Repay ment Plan" ,!!,"List  of Active  Bills:",!!
  8642   "RTN","PRC ARPM",127, 0)
  8643    S TOTAL=$ $DISPLAY^P RCARPU(.NO N,1)
  8644   "RTN","PRC ARPM",128, 0)
  8645    S LIST=$$ SELECT^PRC ARPU(.NON)
  8646   "RTN","PRC ARPM",129, 0)
  8647    I LIST=""  W !! G BE GIN
  8648   "RTN","PRC ARPM",130, 0)
  8649    D SUMM^PR CARPU(.NON ,LIST,.ADD )
  8650   "RTN","PRC ARPM",131, 0)
  8651    S TOTDUE= $$DUEARR^P RCARPU(.AD D)
  8652   "RTN","PRC ARPM",132, 0)
  8653    W !!,"Tot al amount  chosen is  $",$J(TOTD UE,8,2),!
  8654   "RTN","PRC ARPM",133, 0)
  8655    S SURE=$$ CORRECT^PR CARPU()
  8656   "RTN","PRC ARPM",134, 0)
  8657    I 'SURE W  !! G BEGI N
  8658   "RTN","PRC ARPM",135, 0)
  8659    S SUCCESS =$$INQPLAN ^PRCARPU(T OTDUE)
  8660   "RTN","PRC ARPM",136, 0)
  8661    I 'SUCCES S W !! G B EGIN
  8662   "RTN","PRC ARPM",137, 0)
  8663    D ADDPLAN ^PRCARPU(. ADD,PRCAMT ,PRCADAY,P RCAFPD,PRC ADT)
  8664   "RTN","PRC ARPM",138, 0)
  8665    W !,"The  Repayment  Plan has b een establ ished.",!  D PAUSE^PR CARPU
  8666   "RTN","PRC ARPM",139, 0)
  8667    I 'Y G BE GIN
  8668   "RTN","PRC ARPM",140, 0)
  8669    D ACCOUNT S^PRCARPU( +DEBTOR,.A LL,.PLN,.N ON,.ACT) ; Reload acc ounts afte r change i s filed
  8670   "RTN","PRC ARPM",141, 0)
  8671    D RPDIS^P RCARPU(DEB TOR,.PLN)
  8672   "RTN","PRC ARPM",142, 0)
  8673    D DISPLAY ^PRCARPU(. PLN,0)
  8674   "RTN","PRC ARPM",143, 0)
  8675    D CMTENTR ^PRCARPU(+ DEBTOR)
  8676   "RTN","PRC ARPM",144, 0)
  8677    G BEGIN
  8678   "RTN","PRC ARPM",145, 0)
  8679    ;
  8680   "RTN","PRC ARPM",146, 0)
  8681   MLTDEL ;De lete all m ultiple pl ans
  8682   "RTN","PRC ARPM",147, 0)
  8683    S DIR(0)= "Y"
  8684   "RTN","PRC ARPM",148, 0)
  8685    S DIR("A" )="Delete  ALL curren t Repaymen t Plans fo r this Deb tor"
  8686   "RTN","PRC ARPM",149, 0)
  8687    S DIR("?" )="Enter Y  to delete  ALL curre nt Repayme nt Plans"
  8688   "RTN","PRC ARPM",150, 0)
  8689    D ^DIR
  8690   "RTN","PRC ARPM",151, 0)
  8691    I 'Y G BE GIN
  8692   "RTN","PRC ARPM",152, 0)
  8693    D RPDEL^P RCARPU(.PL N)
  8694   "RTN","PRC ARPM",153, 0)
  8695    W !,"All  Repayment  Plans have  been dele ted.",! D  PAUSE^PRCA RPU
  8696   "RTN","PRC ARPM",154, 0)
  8697    G BEGIN
  8698   "RTN","PRC ARPM",155, 0)
  8699    ;
  8700   "RTN","PRC ARPM",156, 0)
  8701   VIEW ;View  a Repayme nt Plan
  8702   "RTN","PRC ARPM",157, 0)
  8703    D RPDIS^P RCARPU(DEB TOR,.PLN)
  8704   "RTN","PRC ARPM",158, 0)
  8705    D DISPLAY ^PRCARPU(. PLN,0)
  8706   "RTN","PRC ARPM",159, 0)
  8707    D PAUSE^P RCARPU
  8708   "RTN","PRC ARPM",160, 0)
  8709    I 'Y G BE GIN
  8710   "RTN","PRC ARPM",161, 0)
  8711    D PAYDISP ^PRCARPU(+ DEBTOR,PLN DT)
  8712   "RTN","PRC ARPM",162, 0)
  8713    W !,"Bill s not in R epayment P lan:",!
  8714   "RTN","PRC ARPM",163, 0)
  8715    S TOTAL=$ $DISPLAY^P RCARPU(.NO N,1)
  8716   "RTN","PRC ARPM",164, 0)
  8717    G BEGIN
  8718   "RTN","PRC ARPS")
  8719   0^48^B1564 2186^B1466 5305
  8720   "RTN","PRC ARPS",1,0)
  8721   PRCARPS ;S F-ISC/YJK- REPAYMENT  PAYMENT ST ATEMENT ;1 0/23/93  9 :50 AM
  8722   "RTN","PRC ARPS",2,0)
  8723    ;;4.5;Acc ounts Rece ivable;**1 04,315**;M ar 20, 199 5;Build 55
  8724   "RTN","PRC ARPS",3,0)
  8725    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  8726   "RTN","PRC ARPS",4,0)
  8727    ;
  8728   "RTN","PRC ARPS",5,0)
  8729    ;PRINT TH E PAYMENT  STATEMENT  FOR REPAYM ENT PLAN
  8730   "RTN","PRC ARPS",6,0)
  8731    N PRCALL
  8732   "RTN","PRC ARPS",7,0)
  8733   BEGIN ;PRC A*4.5*315  Allow GOTB ILL (PRCAB N) to be p assed in
  8734   "RTN","PRC ARPS",8,0)
  8735    I $G(GOTB ILL)="" D  BILL^PRCAU TL Q:'$D(P RCABN)
  8736   "RTN","PRC ARPS",9,0)
  8737    S PRCA("B ILLN")=$P( ^PRCA(430, PRCABN,0), U,1),PRCA( "DEBTOR")= $P(^(0),U, 9)
  8738   "RTN","PRC ARPS",10,0 )
  8739    I $G(GOTB ILL)="" I  '$D(^PRCA( 430,PRCABN ,5)) W !,* 7,"NO REPA YMENT PLAN  FOR THIS  ACCOUNT.", ! Q
  8740   "RTN","PRC ARPS",11,0 )
  8741    I $G(GOTB ILL)=1 I ' $D(^PRCA(4 30,PRCABN, 5)) W !,*7 ,"NO REPAY MENT PLAN  FOR THIS A CCOUNT.",!  H 5 Q
  8742   "RTN","PRC ARPS",12,0 )
  8743    S PRCAREP =1 Q
  8744   "RTN","PRC ARPS",13,0 )
  8745   PRINTST S  PRCAREP=0  D BEGIN G: PRCAREP=0  END D EN,K ILLV G PRI NTST
  8746   "RTN","PRC ARPS",14,0 )
  8747   EN S PRCAP T=0 D GETP T I PRCAPT =0 W !,"NO  PAYMENT D ATA!",! Q
  8748   "RTN","PRC ARPS",15,0 )
  8749    I '$D(DT)  S %DT="", X="T" D ^% DT S DT=+Y  K %DT
  8750   "RTN","PRC ARPS",16,0 )
  8751    S %ZIS="Q " D ^%ZIS  Q:POP  I I O=IO(0) D  PRT Q
  8752   "RTN","PRC ARPS",17,0 )
  8753    I $D(IO(" Q")) K IO( "Q") D QUE  D:IO'=IO( 0) CLOSEDV  Q
  8754   "RTN","PRC ARPS",18,0 )
  8755    U IO D PR T Q
  8756   "RTN","PRC ARPS",19,0 )
  8757   PRT K PRCA PP D GETPA Y Q:'$D(PR CAPP)  D S ETLINE,GET PB,WRST^PR CARPS1
  8758   "RTN","PRC ARPS",20,0 )
  8759    I '$D(DT)  S %DT="", X="T" D ^% DT S DT=+Y  K %DT
  8760   "RTN","PRC ARPS",21,0 )
  8761    I PRCANOD >0 S $P(^P RCA(430,PR CABN,5,PRC ANOD,0),U, 3)=1,$P(^P RCA(430,PR CABN,5,PRC ANOD,0),U, 5)=DT
  8762   "RTN","PRC ARPS",22,0 )
  8763    D CLOSEDV  Q
  8764   "RTN","PRC ARPS",23,0 )
  8765   QUE K ZTSK ,ZTSAVE S  ZTSAVE("PR CAPT")=PRC APT,ZTSAVE ("PRCADUE" )=PRCADUE, ZTSAVE("PR CABN")=PRC ABN,ZTSAVE ("PRCA(""B ILLN"")")= PRCA("BILL N"),ZTSAVE ("PRCA(""D EBTOR"")") =PRCA("DEB TOR"),ZTSA VE("PRCANO D")=PRCANO D
  8766   "RTN","PRC ARPS",24,0 )
  8767    S ZTRTN=" PRT^PRCARP S",ZTDESC= "Repayment  Plan Stat ement" D ^ %ZTLOAD K  ZTRTN,ZTSA VE Q
  8768   "RTN","PRC ARPS",25,0 )
  8769   CLOSEDV D  ^%ZISC Q
  8770   "RTN","PRC ARPS",26,0 )
  8771   KILLV ;
  8772   "RTN","PRC ARPS",27,0 )
  8773   END K PRCA REP,PRCABN ,PRCA,PRCA PP,PRCAPB, PRCALN,PRC AST1,PRCAC ITY,PRCA(" DEBTNAM"), PRCA("DEBT OR"),I,PRC ADT,PRCADU E,PRCAMT,P RCANOD,PRC APT,PRCASS AN,PRCAKIP ,PRCABN1,P RCA1,PRCAT Y,PRCARDT, PRCANO D K VAR^VADPT  Q
  8774   "RTN","PRC ARPS",28,0 )
  8775    ;
  8776   "RTN","PRC ARPS",29,0 )
  8777   GETPT S PR CAKEN=+$P( ^PRCA(430, PRCABN,5,0 ),U,4),(PR CADUE,PRCA NOD)=0
  8778   "RTN","PRC ARPS",30,0 )
  8779    F Z=1:1:P RCAKEN I + $P(^PRCA(4 30,PRCABN, 5,Z,0),U,4 )>0,+$P(^( 0),U,3)'>0  S PRCAPT= $P(^(0),U, 4),PRCANOD =Z Q
  8780   "RTN","PRC ARPS",31,0 )
  8781    F Z=1:1:P RCAKEN I + $P(^PRCA(4 30,PRCABN, 5,Z,0),U,2 )<1 S PRCA DUE=+$P(^( 0),U,1) Q
  8782   "RTN","PRC ARPS",32,0 )
  8783    K Z,PRCAK EN Q
  8784   "RTN","PRC ARPS",33,0 )
  8785   GETPAY S P RCADT=$P(^ PRCA(433,P RCAPT,1),U ,1) Q:PRCA DT=""
  8786   "RTN","PRC ARPS",34,0 )
  8787    S Y=PRCAD T D DD^%DT
  8788   "RTN","PRC ARPS",35,0 )
  8789    S PRCADT= $E(PRCADT, 4,5)_"/"_$ E(PRCADT,6 ,7)_"/"_$P (Y,", ",2)
  8790   "RTN","PRC ARPS",36,0 )
  8791    S PRCAMT= +$P(^PRCA( 433,PRCAPT ,1),U,5) Q :PRCAMT'>0
  8792   "RTN","PRC ARPS",37,0 )
  8793    S Z3=$S($ D(^PRCA(43 3,PRCAPT,3 )):^(3),1: "") Q:Z3=" "
  8794   "RTN","PRC ARPS",38,0 )
  8795    F Z=1:1:5  S PRCAPP( Z)=+$P(Z3, U,Z)
  8796   "RTN","PRC ARPS",39,0 )
  8797    K Z,Z3 Q
  8798   "RTN","PRC ARPS",40,0 )
  8799   GETPB S Z4 =^PRCA(430 ,PRCABN,7)
  8800   "RTN","PRC ARPS",41,0 )
  8801    F Z=1:1:5  S PRCAPB( Z)=+$P(Z4, U,Z)
  8802   "RTN","PRC ARPS",42,0 )
  8803    K Z,Z4 Q
  8804   "RTN","PRC ARPS",43,0 )
  8805   SETLINE S  PRCALN=0 S :IOM>87 PR CALN=7 S P RCALN(0)=2 5+PRCALN,P RCALN(1)=5 0+PRCALN,P RCALN(2)=5 2+PRCALN,P RCALN(3)=6 2+PRCALN,P RCALN(4)=6 4+PRCALN,P RCALN(5)=1 0+PRCALN,P RCALN(6)=3 0+PRCALN
  8806   "RTN","PRC ARPS",44,0 )
  8807    S PRCALL( 1)=18+PRCA LN,PRCALL( 2)=20+PRCA LN,PRCALL( 3)=30+PRCA LN,PRCALL( 4)=32+PRCA LN,PRCALL( 5)=42+PRCA LN,PRCALL( 6)=44+PRCA LN,PRCALL( 7)=54+PRCA LN,PRCALL( 8)=56+PRCA LN,PRCALL( 9)=66+PRCA LN,PRCALL( 10)=68+PRC ALN,PRCALL (11)=78+PR CALN Q
  8808   "RTN","PRC ARPS",45,0 )
  8809    ;======== ========== == REPRINT  STATEMENT  ========= ========== =========
  8810   "RTN","PRC ARPS",46,0 )
  8811   EN1 ;Repri nt the pay ment state ment.
  8812   "RTN","PRC ARPS",47,0 )
  8813    S PRCAREP =0 D BEGIN  G:+PRCARE P=0 END
  8814   "RTN","PRC ARPS",48,0 )
  8815    K PRCARDT  D DATE G: '$D(PRCARD T) END
  8816   "RTN","PRC ARPS",49,0 )
  8817    S PRCA1=0  D LOOK I  PRCA1=0 W  !,*7,"THE  DATE DOES  NOT MATCH  !, PLEASE  CHECK REPA YMENT PROF ILE.",!! G  END
  8818   "RTN","PRC ARPS",50,0 )
  8819    D CLDATE  D EN,KILLV  G EN1
  8820   "RTN","PRC ARPS",51,0 )
  8821   LOOK S Z1= 0
  8822   "RTN","PRC ARPS",52,0 )
  8823    F Z0=0:0  S Z1=$O(^P RCA(430,PR CABN,5,Z1) ) Q:+Z1'>0   I $P(^(Z 1,0),U,5)= PRCARDT S  PRCA1=1,PR CABN1=Z1 K  Z1 Q
  8824   "RTN","PRC ARPS",53,0 )
  8825    K Z0 Q
  8826   "RTN","PRC ARPS",54,0 )
  8827   DATE S %DT ="AE",%DT( "A")="Ente r the date  the state ment was p rinted: "  D ^%DT Q:Y <0  S PRCA RDT=+Y Q
  8828   "RTN","PRC ARPS",55,0 )
  8829   CLDATE Q:' $D(^PRCA(4 30,PRCABN, 5,PRCABN1, 0))  S $P( ^(0),U,3)= 0,$P(^(0), U,5)="" Q
  8830   "RTN","PRC ARPU")
  8831   0^46^B1888 46893^n/a
  8832   "RTN","PRC ARPU",1,0)
  8833   PRCARPU ;A LB/DRF-CRE ATE MULTIP LE ACCOUNT  REPAYMENT  DATE SCHE DULE FUNCT IONS;08/09 /2016  4:4 0 PM
  8834   "RTN","PRC ARPU",2,0)
  8835    ;;4.5;Acc ounts Rece ivable;**3 15**;Mar 2 0, 1995;Bu ild 55
  8836   "RTN","PRC ARPU",3,0)
  8837    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  8838   "RTN","PRC ARPU",4,0)
  8839    ;
  8840   "RTN","PRC ARPU",5,0)
  8841    Q
  8842   "RTN","PRC ARPU",6,0)
  8843    ;
  8844   "RTN","PRC ARPU",7,0)
  8845   DEBTOR() ; Look up de btor by na me or bill  #
  8846   "RTN","PRC ARPU",8,0)
  8847    N DIC,X,Y ,DEBT,DEBT OR,DIC,PRC ADB,DTOUT, DUOUT
  8848   "RTN","PRC ARPU",9,0)
  8849    R !!,"Sel ect DEBTOR  NAME or B ILL NUMBER : ",X:DTIM E
  8850   "RTN","PRC ARPU",10,0 )
  8851    I X["^"!( X="") Q ""
  8852   "RTN","PRC ARPU",11,0 )
  8853    S X=$$UPP ER^VALM1(X )
  8854   "RTN","PRC ARPU",12,0 )
  8855    S Y=$S($O (^PRCA(430 ,"B",X,0)) :$O(^(0)), $O(^PRCA(4 30,"D",X,0 )):$O(^(0) ),1:-1)
  8856   "RTN","PRC ARPU",13,0 )
  8857    I Y>0 S D EBT=$P($G( ^PRCA(430, Y,0)),"^", 9) I DEBT  D  Q DEBT   ;If found  by bill n umber
  8858   "RTN","PRC ARPU",14,0 )
  8859    . S PRCAD B=$P($G(^R CD(340,DEB T,0)),"^")
  8860   "RTN","PRC ARPU",15,0 )
  8861    . S ^DISV (DUZ,"^RCD (340,")=DE BT
  8862   "RTN","PRC ARPU",16,0 )
  8863    . S $P(DE BT,"^",2)= $$NAM^RCFN 01(DEBT)
  8864   "RTN","PRC ARPU",17,0 )
  8865    I $D(DTOU T) Q 0
  8866   "RTN","PRC ARPU",18,0 )
  8867    S DIC="^R CD(340,",D IC(0)="EX"  D ^DIC W  ! I Y<0 Q  0
  8868   "RTN","PRC ARPU",19,0 )
  8869    I $G(DTOU T)!($G(DUO UT)) Q ""   ;TIMEOUT/ UP ARROW
  8870   "RTN","PRC ARPU",20,0 )
  8871    S ^DISV(D UZ,"^RCD(3 40,")=+Y,P RCADB=$P(Y ,"^",2),DE BTOR=+Y_"^ "_$P(@("^" _$P(PRCADB ,";",2)_+P RCADB_",0) "),"^")
  8872   "RTN","PRC ARPU",21,0 )
  8873    Q DEBTOR   ;If looke d up by de btor name
  8874   "RTN","PRC ARPU",22,0 )
  8875    ;
  8876   "RTN","PRC ARPU",23,0 )
  8877   ACCOUNTS(D EBTOR,ARRA LL,ARRPLN, ARRNON,ACT ) ;Find al l active a ccounts fo r a debtor
  8878   "RTN","PRC ARPU",24,0 )
  8879    ; DEBTOR   - Pointer  to #340
  8880   "RTN","PRC ARPU",25,0 )
  8881    ; ARRALL   - Name of  array (pa ssed by re ference) t hat holds  all the ac counts for  this debt or
  8882   "RTN","PRC ARPU",26,0 )
  8883    ;            Ordered  by date i n the form at ARRAY(1 ,xxxxxxx)= "",ARRAY(2 ,xxxxxx)=" "...
  8884   "RTN","PRC ARPU",27,0 )
  8885    ; ARRPLN   - Name of  array (pa ssed by re ference) t hat holds  the accoun ts for thi s debtor
  8886   "RTN","PRC ARPU",28,0 )
  8887    ;            that ar e part of  a current  payment pl an
  8888   "RTN","PRC ARPU",29,0 )
  8889    ;            Ordered  by date i n the form at ARRAY(1 ,xxxxxxx)= "",ARRAY(2 ,xxxxxx)=" "...
  8890   "RTN","PRC ARPU",30,0 )
  8891    ;            Check f or ARRPLN> 0 to see i f there is  an existi ng plan fo r this deb tor
  8892   "RTN","PRC ARPU",31,0 )
  8893    ; ARRNON   - Name of  array (pa ssed by re ference) t hat holds  the accoun ts for thi s debtor
  8894   "RTN","PRC ARPU",32,0 )
  8895    ;            that ar e NOT part  of a curr ent paymen t plan
  8896   "RTN","PRC ARPU",33,0 )
  8897    ;            Ordered  by date i n the form at ARRAY(1 ,xxxxxxx)= "",ARRAY(2 ,xxxxxx)=" "...
  8898   "RTN","PRC ARPU",34,0 )
  8899    ; ACT      - Variabl e that tra cks the nu mber of ac tive accou nts for th e debtor.  ARRALL dis plays
  8900   "RTN","PRC ARPU",35,0 )
  8901    ;            Cross-S erviced ac counts, bu t they are  not activ e for the  purposes o f repaymen t plans
  8902   "RTN","PRC ARPU",36,0 )
  8903    ;
  8904   "RTN","PRC ARPU",37,0 )
  8905    ; Returns : ARRAY(CO UNTER,PRCA BN)=BILL#^ PART OF A  PAYMENT PL AN=1^IN CR OSS SERVIC ING=1^BALA NCE DUE^DO S^STATUS^C ATEGORY^PL AN DATE
  8906   "RTN","PRC ARPU",38,0 )
  8907    ;
  8908   "RTN","PRC ARPU",39,0 )
  8909    N AMT,BIL L,CS,D0,D4 ,D7,DOS,DT ,PLNDT,PP, PRCABN,PRC AT,PRCS15, STAT
  8910   "RTN","PRC ARPU",40,0 )
  8911    K ARRALL, ARRPLN,ARR NON,ACT
  8912   "RTN","PRC ARPU",41,0 )
  8913    S (ARRALL ,ARRPLN,AR RNON,ACT)= 0
  8914   "RTN","PRC ARPU",42,0 )
  8915    S DT="" F   S DT=$O( ^PRCA(430, "ATD",DEBT OR,DT)) Q: 'DT  S PRC ABN=0 F  S  PRCABN=$O (^PRCA(430 ,"ATD",DEB TOR,DT,PRC ABN)) Q:'P RCABN  D
  8916   "RTN","PRC ARPU",43,0 )
  8917    . S D0=^P RCA(430,PR CABN,0),ST AT=$P(D0,U ,8)
  8918   "RTN","PRC ARPU",44,0 )
  8919    . I +STAT >0,$P(^PRC A(430.3,ST AT,0),U,3) '=102 Q  ; Not an act ive accoun t
  8920   "RTN","PRC ARPU",45,0 )
  8921    . S D4=$G (^PRCA(430 ,PRCABN,4) ),D7=$G(^P RCA(430,PR CABN,7))
  8922   "RTN","PRC ARPU",46,0 )
  8923    . S AMT=$ S(+D7:$P(D 7,U,1)+$P( D7,U,2)+$P (D7,U,3)+$ P(D7,U,4)+ $P(D7,U,5) ,1:$P(D0,U ,3)),DOS=$ P(D0,U,10)
  8924   "RTN","PRC ARPU",47,0 )
  8925    . S BILL= $P(D0,U,1) ,PRCAT=$P( D0,U,2),PL NDT=$P(D4, U,1)
  8926   "RTN","PRC ARPU",48,0 )
  8927    . S PP=0  I PLNDT]""  S PP=1 ;P art of a p ayment pla n?
  8928   "RTN","PRC ARPU",49,0 )
  8929    . S CS=0  I $D(^PRCA (430,"TCSP ",PRCABN))  S CS=1 ;B ill is in  cross-serv icing
  8930   "RTN","PRC ARPU",50,0 )
  8931    . I 'CS S  ACT=ACT+1
  8932   "RTN","PRC ARPU",51,0 )
  8933    . I ARRAL L]"" S ARR ALL=ARRALL +1,ARRALL( ARRALL,PRC ABN)=BILL_ U_PP_U_CS_ U_AMT_U_DO S_U_STAT_U _PRCAT_U_P LNDT
  8934   "RTN","PRC ARPU",52,0 )
  8935    . I PP,AR RPLN]"" S  ARRPLN=ARR PLN+1,ARRP LN(ARRPLN, PRCABN)=BI LL_U_PP_U_ CS_U_AMT_U _DOS_U_STA T_U_PRCAT_ U_PLNDT Q
  8936   "RTN","PRC ARPU",53,0 )
  8937    . I 'PP,A RRNON]"" S  ARRNON=AR RNON+1,ARR NON(ARRNON ,PRCABN)=B ILL_U_PP_U _CS_U_AMT_ U_DOS_U_ST AT_U_PRCAT  Q
  8938   "RTN","PRC ARPU",54,0 )
  8939    Q
  8940   "RTN","PRC ARPU",55,0 )
  8941    ;
  8942   "RTN","PRC ARPU",56,0 )
  8943   DISPLAY(AR R,NUM) ;Di splay acco unts in AR R
  8944   "RTN","PRC ARPU",57,0 )
  8945    ; ARR - A n array of  bills
  8946   "RTN","PRC ARPU",58,0 )
  8947    ; NUM - D isplay sel ection num bers in le ft column  (defaults  to no (0))
  8948   "RTN","PRC ARPU",59,0 )
  8949    ;
  8950   "RTN","PRC ARPU",60,0 )
  8951    N AMT,BIL L,CS,CSMSG ,DOS,I,PLN ,PLNMSG,PR CABN,PRCAT ,PRCATN,ST AT,STATN,T AMT,Y
  8952   "RTN","PRC ARPU",61,0 )
  8953    S NUM=+$G (NUM)
  8954   "RTN","PRC ARPU",62,0 )
  8955    S TAMT=0, PLNMSG=0,C SMSG=0
  8956   "RTN","PRC ARPU",63,0 )
  8957    F I=1:1:A RR D
  8958   "RTN","PRC ARPU",64,0 )
  8959    . S PRCAB N=$O(ARR(I ,0)),BILL= $P(ARR(I,P RCABN),U,1 ),PLN=$P(A RR(I,PRCAB N),U,2),CS =$P(ARR(I, PRCABN),U, 3)
  8960   "RTN","PRC ARPU",65,0 )
  8961    . S AMT=$ P(ARR(I,PR CABN),U,4) ,DOS=$P(AR R(I,PRCABN ),U,5),STA T=$P(ARR(I ,PRCABN),U ,6),PRCAT= $P(ARR(I,P RCABN),U,7 )
  8962   "RTN","PRC ARPU",66,0 )
  8963    . I $G(CS )=0 S TAMT =TAMT+AMT
  8964   "RTN","PRC ARPU",67,0 )
  8965    . I PLN,' PLNMSG S P LNMSG=1
  8966   "RTN","PRC ARPU",68,0 )
  8967    . I CS,'C SMSG S CSM SG=1
  8968   "RTN","PRC ARPU",69,0 )
  8969    . S PRCAT N=$P($G(^P RCA(430.2, PRCAT,0)), U,1),STATN =$P($G(^PR CA(430.3,S TAT,0)),U, 1)
  8970   "RTN","PRC ARPU",70,0 )
  8971    . I I#22= 0 D PAUSE
  8972   "RTN","PRC ARPU",71,0 )
  8973    . W $S(NU M:I,1:""), ?5,BILL,$S (PLN:"**", CS:"#",1:" "),?24,PRC ATN,?50,$$ MDY(DOS,"- "),?61,STA TN,?70,"$" ,$J(AMT,8, 2),!
  8974   "RTN","PRC ARPU",72,0 )
  8975    W !
  8976   "RTN","PRC ARPU",73,0 )
  8977    I PLNMSG  W "** Bill  is curren tly in Rep ayment Pla n",!
  8978   "RTN","PRC ARPU",74,0 )
  8979    I CSMSG W  "# Bill i s currentl y in Cross  Servicing ",!
  8980   "RTN","PRC ARPU",75,0 )
  8981    Q TAMT
  8982   "RTN","PRC ARPU",76,0 )
  8983    ;
  8984   "RTN","PRC ARPU",77,0 )
  8985   MDY(DT,DEL ) ;Return  date forma t of mm-dd -yy
  8986   "RTN","PRC ARPU",78,0 )
  8987    ; DT - Da te in File Man format
  8988   "RTN","PRC ARPU",79,0 )
  8989    ; DEL - D elimiter u sed to sep erate mont h, day, ye ar
  8990   "RTN","PRC ARPU",80,0 )
  8991    ;
  8992   "RTN","PRC ARPU",81,0 )
  8993    ; Returns : Date in  mmddyy fom at delimit ed by DEL
  8994   "RTN","PRC ARPU",82,0 )
  8995    N %DT,X,Y
  8996   "RTN","PRC ARPU",83,0 )
  8997    S X=$G(DT ),DEL=$S($ G(DEL)="": "-",1:DEL) ,%DT="T"
  8998   "RTN","PRC ARPU",84,0 )
  8999    D ^%DT S  DT=Y S:Y<0  DT="00000 00"
  9000   "RTN","PRC ARPU",85,0 )
  9001    Q $E(DT,4 ,5)_DEL_$E (DT,6,7)_D EL_$E(DT,2 ,3)
  9002   "RTN","PRC ARPU",86,0 )
  9003    ;
  9004   "RTN","PRC ARPU",87,0 )
  9005   SELECT(ARR ) ;Select  items up t o number A RR
  9006   "RTN","PRC ARPU",88,0 )
  9007    ; ARR - T he upper l imit that  can be cho sen
  9008   "RTN","PRC ARPU",89,0 )
  9009    ; This fu nction wil l eliminat e duplicat es and ret urn choice s in numer ical error
  9010   "RTN","PRC ARPU",90,0 )
  9011    ; regardl ess of inp ut order.
  9012   "RTN","PRC ARPU",91,0 )
  9013    ; Returns : comma de limited li st of poin ters to fi le #430 in  ascending  date orde r
  9014   "RTN","PRC ARPU",92,0 )
  9015    ;
  9016   "RTN","PRC ARPU",93,0 )
  9017    N CNT,DIR ,ERR,FIRST ,I,J,LAST, LIST,OK,PC ,PRCABN,ST R,X,Y
  9018   "RTN","PRC ARPU",94,0 )
  9019    S OK=0 F  CNT=1:1 I  'OK D  Q:O K
  9020   "RTN","PRC ARPU",95,0 )
  9021    . I CNT>1  W "   Sel ect bills  using the  following  formats:(A )ll or (N) one or 1,2 ,3 and/or  1-3",!
  9022   "RTN","PRC ARPU",96,0 )
  9023    . S DIR(0 )="FO^^"
  9024   "RTN","PRC ARPU",97,0 )
  9025    . S DIR(" A")="Choos e Bills to  Add to Re payment Pl an: "
  9026   "RTN","PRC ARPU",98,0 )
  9027    . S DIR(" B")="ALL"
  9028   "RTN","PRC ARPU",99,0 )
  9029    . S DIR(" ?")="Selec t bills us ing the fo llowing fo rmats:(A)l l or (N)on e or 1,2,3  and/or 1- 3"
  9030   "RTN","PRC ARPU",100, 0)
  9031    . D ^DIR
  9032   "RTN","PRC ARPU",101, 0)
  9033    . I $G(DT OUT)!$G(DU OUT) S LIS T="",OK=1  Q
  9034   "RTN","PRC ARPU",102, 0)
  9035    . S X=$$U PPER^VALM1 (X)
  9036   "RTN","PRC ARPU",103, 0)
  9037    . I $E("N ONE",1,$L( X))=X S LI ST="",OK=1  Q
  9038   "RTN","PRC ARPU",104, 0)
  9039    . K STR S  ERR=""
  9040   "RTN","PRC ARPU",105, 0)
  9041    . I $E("A LL",1,$L(X ))=X D  Q: OK
  9042   "RTN","PRC ARPU",106, 0)
  9043    .. F I=1: 1:ARR S ST R(I)=""
  9044   "RTN","PRC ARPU",107, 0)
  9045    .. S OK=1
  9046   "RTN","PRC ARPU",108, 0)
  9047    . F I=1:1 :$L(X,",")  S PC=$P(X ,",",I) D   Q:ERR]""
  9048   "RTN","PRC ARPU",109, 0)
  9049    .. I PC'? 1.N,PC'?1. N1"-"1.N S  ERR="Inva lid respon se" Q
  9050   "RTN","PRC ARPU",110, 0)
  9051    .. I PC'> 0!(PC>ARR)  S ERR="Nu mber out o f range" Q
  9052   "RTN","PRC ARPU",111, 0)
  9053    .. I PC?1 .N,PC>0,PC '>ARR S ST R(PC)="" Q
  9054   "RTN","PRC ARPU",112, 0)
  9055    .. I PC?1 .N1"-"1.N  D  Q:ERR]" "
  9056   "RTN","PRC ARPU",113, 0)
  9057    ... S FIR ST=$P(PC," -",1),LAST =$P(PC,"-" ,2)
  9058   "RTN","PRC ARPU",114, 0)
  9059    ... I FIR ST'>0!(FIR ST>ARR)!(L AST'>0)!(L AST>ARR) S  ERR="Numb er out of  range" Q
  9060   "RTN","PRC ARPU",115, 0)
  9061    ... I FIR ST>0,FIRST '>ARR,LAST >0,LAST'>A RR F J=FIR ST:1:LAST  S STR(J)=" "
  9062   "RTN","PRC ARPU",116, 0)
  9063    . I ERR=" " S OK=1 Q
  9064   "RTN","PRC ARPU",117, 0)
  9065    . S OK=0  W "  "_ERR ,!
  9066   "RTN","PRC ARPU",118, 0)
  9067    S I=0,LIS T="" F  S  I=$O(STR(I )) Q:I=""   D
  9068   "RTN","PRC ARPU",119, 0)
  9069    . S PRCAB N=$O(ARR(I ,0))
  9070   "RTN","PRC ARPU",120, 0)
  9071    . I $P(AR R(I,PRCABN ),U,3) W ! ,I_". "_$P (ARR(I,PRC ABN),U,1)_ " is in Cr oss Servic ing" Q
  9072   "RTN","PRC ARPU",121, 0)
  9073    . I $P(AR R(I,PRCABN ),U,2) W ! ,I_". "_$P (ARR(I,PRC ABN),U,1)_ " is in a  Payment Pl an" Q
  9074   "RTN","PRC ARPU",122, 0)
  9075    . S LIST= LIST_$S(LI ST="":"",1 :",")_I
  9076   "RTN","PRC ARPU",123, 0)
  9077    Q LIST
  9078   "RTN","PRC ARPU",124, 0)
  9079    ;
  9080   "RTN","PRC ARPU",125, 0)
  9081   RPDIS(DEBT OR,PLN) ;D isplay Rep ayment Pla n
  9082   "RTN","PRC ARPU",126, 0)
  9083    ; DEBTOR   - Pointer  to #340
  9084   "RTN","PRC ARPU",127, 0)
  9085    ; PLN - A n array of  bills
  9086   "RTN","PRC ARPU",128, 0)
  9087    ;
  9088   "RTN","PRC ARPU",129, 0)
  9089    D PLNDTL( .PLN)
  9090   "RTN","PRC ARPU",130, 0)
  9091    W #
  9092   "RTN","PRC ARPU",131, 0)
  9093    W !,"Summ ary of Cur rent Repay ment Plan  for AR Deb tor: ",$P( DEBTOR,U,2 ),!
  9094   "RTN","PRC ARPU",132, 0)
  9095    W "------ ---------- ---------- ---------- ---------- ---------- ---------- ",!
  9096   "RTN","PRC ARPU",133, 0)
  9097    W "Monthl y Repaymen t Amount:" ,?32,"$",$ J(PLNAMT,0 ,2)
  9098   "RTN","PRC ARPU",134, 0)
  9099    W ?45,"Da y of Month  Payment D ue:",?72,P LNDAY,!
  9100   "RTN","PRC ARPU",135, 0)
  9101    W "Number  of Paymen ts Remaini ng:",?32,P LNRMN
  9102   "RTN","PRC ARPU",136, 0)
  9103    W ?45,"Du e Date of  First Paym ent:",?72, PLNFRST,!
  9104   "RTN","PRC ARPU",137, 0)
  9105    W "Curren t Total Du e:",?32,"$ ",$J(PLNTD UE,0,2)
  9106   "RTN","PRC ARPU",138, 0)
  9107    W ?45,"La st Payment  Due:",?72 ,PLNLST,!
  9108   "RTN","PRC ARPU",139, 0)
  9109    W "Plan D ate:",?32, $$MDY(PLND T)
  9110   "RTN","PRC ARPU",140, 0)
  9111    W ?45,"Ne xt Payment  Due:",?72 ,$S(PLNNXT ="00/00/00 ":"DEFAULT ",1:PLNNXT ),!!
  9112   "RTN","PRC ARPU",141, 0)
  9113    W "Bills  in Repayme nt Plan:", !
  9114   "RTN","PRC ARPU",142, 0)
  9115    Q
  9116   "RTN","PRC ARPU",143, 0)
  9117    ;
  9118   "RTN","PRC ARPU",144, 0)
  9119   RPDEL(PLN, TRAN) ;Del ete repaym ent plan
  9120   "RTN","PRC ARPU",145, 0)
  9121    ; PLN - A n array of  bills
  9122   "RTN","PRC ARPU",146, 0)
  9123    ;
  9124   "RTN","PRC ARPU",147, 0)
  9125    N I,PRCAB N,PRCAPB,X
  9126   "RTN","PRC ARPU",148, 0)
  9127    I $G(TRAN )="" S TRA N=1 ; The  default is  to file a  transacti on
  9128   "RTN","PRC ARPU",149, 0)
  9129    F I=1:1:P LN D
  9130   "RTN","PRC ARPU",150, 0)
  9131    . S PRCAB N=$O(PLN(I ,0))
  9132   "RTN","PRC ARPU",151, 0)
  9133    . S X=PLN (I,PRCABN)
  9134   "RTN","PRC ARPU",152, 0)
  9135    . K ^PRCA (430,PRCAB N,4),^PRCA (430,PRCAB N,5)
  9136   "RTN","PRC ARPU",153, 0)
  9137    . I TRAN  D TRANDEL
  9138   "RTN","PRC ARPU",154, 0)
  9139    Q
  9140   "RTN","PRC ARPU",155, 0)
  9141    ;
  9142   "RTN","PRC ARPU",156, 0)
  9143   DBTCOM(DEB TOR,TEXT)  ;Add DEBTO R comments
  9144   "RTN","PRC ARPU",157, 0)
  9145    ; DEBTOR   - Pointer  to #340
  9146   "RTN","PRC ARPU",158, 0)
  9147    ; TEXT -  Comment te xt
  9148   "RTN","PRC ARPU",159, 0)
  9149    ;
  9150   "RTN","PRC ARPU",160, 0)
  9151    N DIC,X,Y
  9152   "RTN","PRC ARPU",161, 0)
  9153    I $G(TEXT )="" Q
  9154   "RTN","PRC ARPU",162, 0)
  9155    S DIC="^R CD(340,"_D EBTOR_",2, ",DIC(0)=" L",X=TEXT
  9156   "RTN","PRC ARPU",163, 0)
  9157    D FILE^DI CN
  9158   "RTN","PRC ARPU",164, 0)
  9159    Q
  9160   "RTN","PRC ARPU",165, 0)
  9161    ;
  9162   "RTN","PRC ARPU",166, 0)
  9163   PLNDTL(ARR ) ;Gather  existing p lan detail s
  9164   "RTN","PRC ARPU",167, 0)
  9165    ; ARR - A n array of  bills
  9166   "RTN","PRC ARPU",168, 0)
  9167    ;
  9168   "RTN","PRC ARPU",169, 0)
  9169    N BILL,PL AN,DA,D0,D 1,D4,D7,I, PRCABN,DT, PYMT,TODAY
  9170   "RTN","PRC ARPU",170, 0)
  9171    S PLNRMN= 0,PLNTDUE= 0,PLNNXT=0 ,LSTDATE=0
  9172   "RTN","PRC ARPU",171, 0)
  9173    D DT^DILF ("","T",.T ODAY)
  9174   "RTN","PRC ARPU",172, 0)
  9175    F I=1:1:A RR D
  9176   "RTN","PRC ARPU",173, 0)
  9177    . S PRCAB N=$O(ARR(I ,0)),X=ARR (I,PRCABN)
  9178   "RTN","PRC ARPU",174, 0)
  9179    . S D4=$G (^PRCA(430 ,PRCABN,4) )
  9180   "RTN","PRC ARPU",175, 0)
  9181    . S BILL= $P(X,U,1)
  9182   "RTN","PRC ARPU",176, 0)
  9183    . S PLNTD UE=PLNTDUE +$P(X,U,4)
  9184   "RTN","PRC ARPU",177, 0)
  9185    . I I=1 S  PLNDT=$P( D4,U,1),PL NDAY=$P(D4 ,U,2),PLNA MT=$P(D4,U ,3)
  9186   "RTN","PRC ARPU",178, 0)
  9187    . S PYMT= 0 F  S PYM T=$O(^PRCA (430,PRCAB N,5,PYMT))  Q:'PYMT   D
  9188   "RTN","PRC ARPU",179, 0)
  9189    .. S D1=^ PRCA(430,P RCABN,5,PY MT,0)
  9190   "RTN","PRC ARPU",180, 0)
  9191    .. I I=1, PYMT=1 S P LNFRST=$P( D1,U,1)
  9192   "RTN","PRC ARPU",181, 0)
  9193    .. I $P(D 1,U,1)>TOD AY,$P(D1,U ,1)>LSTDAT E S PLNRMN =PLNRMN+1, LSTDATE=$P (D1,U,1)
  9194   "RTN","PRC ARPU",182, 0)
  9195    .. I 'PLN NXT,($P(D1 ,U,1)>TODA Y) S PLNNX T=$P(D1,U, 1)
  9196   "RTN","PRC ARPU",183, 0)
  9197    .. S PLNL ST=$P(D1,U ,1)
  9198   "RTN","PRC ARPU",184, 0)
  9199    S PLNFRST =$$MDY(PLN FRST,"/")
  9200   "RTN","PRC ARPU",185, 0)
  9201    S PLNNXT= $$MDY(PLNN XT,"/")
  9202   "RTN","PRC ARPU",186, 0)
  9203    S PLNLST= $$MDY(PLNL ST,"/")
  9204   "RTN","PRC ARPU",187, 0)
  9205    ;S PLNDT= $$MDY(PLND T,"/")
  9206   "RTN","PRC ARPU",188, 0)
  9207    Q
  9208   "RTN","PRC ARPU",189, 0)
  9209    ;
  9210   "RTN","PRC ARPU",190, 0)
  9211   SUMM(ARR,L IST,ADD) ; List bills  from ARR  to plan, n ew or exis ting
  9212   "RTN","PRC ARPU",191, 0)
  9213    ; ARR - A n array of  bills
  9214   "RTN","PRC ARPU",192, 0)
  9215    ; LIST -  A comma de limited li st of bill s to be ad ded
  9216   "RTN","PRC ARPU",193, 0)
  9217    ; ADD - A n array of  bills
  9218   "RTN","PRC ARPU",194, 0)
  9219    ;
  9220   "RTN","PRC ARPU",195, 0)
  9221    N I,J,PRC ABN
  9222   "RTN","PRC ARPU",196, 0)
  9223    F J=1:1 S  I=$P(LIST ,",",J) Q: I=""  D  S  ADD=J
  9224   "RTN","PRC ARPU",197, 0)
  9225    . S PRCAB N=$O(ARR(I ,""))
  9226   "RTN","PRC ARPU",198, 0)
  9227    . S ADD(J ,PRCABN)=A RR(I,PRCAB N)
  9228   "RTN","PRC ARPU",199, 0)
  9229    Q
  9230   "RTN","PRC ARPU",200, 0)
  9231    ;
  9232   "RTN","PRC ARPU",201, 0)
  9233   CORRECT()  ;Are you s ure this i s correct?
  9234   "RTN","PRC ARPU",202, 0)
  9235    ; Return:  1 for Yes
  9236   "RTN","PRC ARPU",203, 0)
  9237    ;          0 for No
  9238   "RTN","PRC ARPU",204, 0)
  9239    ;
  9240   "RTN","PRC ARPU",205, 0)
  9241    N DIR,X,Y
  9242   "RTN","PRC ARPU",206, 0)
  9243    S DIR(0)= "Y",DIR("B ")="YES",D IR("A")="A re you sur e this is  correct"
  9244   "RTN","PRC ARPU",207, 0)
  9245    D ^DIR
  9246   "RTN","PRC ARPU",208, 0)
  9247    Q $S($E(X )="Y":1,$E (X)="y":1, 1:0)
  9248   "RTN","PRC ARPU",209, 0)
  9249    ;
  9250   "RTN","PRC ARPU",210, 0)
  9251   INQPLAN(DU E,PLNDT) ; Prompt for  plan deta ils
  9252   "RTN","PRC ARPU",211, 0)
  9253    ; DUE - T otal amoun t due for  the curren t plan
  9254   "RTN","PRC ARPU",212, 0)
  9255    ; Returns : 1 if com pleted
  9256   "RTN","PRC ARPU",213, 0)
  9257    ;
  9258   "RTN","PRC ARPU",214, 0)
  9259    N DIR,OK, X,Y,NPAY
  9260   "RTN","PRC ARPU",215, 0)
  9261    ;Repaymen t amount
  9262   "RTN","PRC ARPU",216, 0)
  9263    S DIR(0)= "N"
  9264   "RTN","PRC ARPU",217, 0)
  9265    S DIR("A" )="Repayme nt Amount  Due"
  9266   "RTN","PRC ARPU",218, 0)
  9267    S DIR("?" )="This is  the amoun t the debt or will pa y each mon th"
  9268   "RTN","PRC ARPU",219, 0)
  9269    D ^DIR
  9270   "RTN","PRC ARPU",220, 0)
  9271    I $G(DTOU T)!$G(DUOU T)!$G(DIRU T) Q 0
  9272   "RTN","PRC ARPU",221, 0)
  9273    S PRCAMT= Y
  9274   "RTN","PRC ARPU",222, 0)
  9275    S NPAY=DU E\PRCAMT I  DUE#PRCAM T>0 S NPAY =NPAY+1
  9276   "RTN","PRC ARPU",223, 0)
  9277    W !!,"Num ber of Pay ments will  be ",NPAY ,!
  9278   "RTN","PRC ARPU",224, 0)
  9279    I NPAY>36  D
  9280   "RTN","PRC ARPU",225, 0)
  9281    . W "The  number of  payments e xceeds 36  payments.  Ensure you  have Supe rvisor App roval",!
  9282   "RTN","PRC ARPU",226, 0)
  9283    . W "and  enter Supe rvisor app roval in t he Expande d Comment. ",!!
  9284   "RTN","PRC ARPU",227, 0)
  9285    . D PAUSE
  9286   "RTN","PRC ARPU",228, 0)
  9287    ;
  9288   "RTN","PRC ARPU",229, 0)
  9289    ;Repaymen t plan dat e
  9290   "RTN","PRC ARPU",230, 0)
  9291    S PLNDT=$ G(PLNDT)
  9292   "RTN","PRC ARPU",231, 0)
  9293    I PLNDT=" " S %DT="A EFX",%DT(" A")="Repay ment Plan  Date:  ",% DT("B")="T " D ^%DT K  %DT I Y=- 1!($G(DTOU T)) Q 0
  9294   "RTN","PRC ARPU",232, 0)
  9295    S PRCADT= $S(PLNDT]" ":PLNDT,1: Y) ;Plan D ate
  9296   "RTN","PRC ARPU",233, 0)
  9297    ;
  9298   "RTN","PRC ARPU",234, 0)
  9299    ;Day of m onth
  9300   "RTN","PRC ARPU",235, 0)
  9301    S DIR(0)= "N"
  9302   "RTN","PRC ARPU",236, 0)
  9303    S DIR("A" )="Day of  Month Paym ent Due"
  9304   "RTN","PRC ARPU",237, 0)
  9305    S DIR("?" )="Enter t he day of  the month  (1-28) tha t the paym ent will b e due."
  9306   "RTN","PRC ARPU",238, 0)
  9307    S OK=0 F   D  Q:OK
  9308   "RTN","PRC ARPU",239, 0)
  9309    . D ^DIR
  9310   "RTN","PRC ARPU",240, 0)
  9311    . I $G(DT OUT)!$G(DU OUT)!$G(DI RUT) S OK= 1 Q
  9312   "RTN","PRC ARPU",241, 0)
  9313    . I Y>0,Y <29 S OK=1  Q
  9314   "RTN","PRC ARPU",242, 0)
  9315    . W "  En ter the da y of the m onth (1-28 ) that the  payment w ill be due .",!
  9316   "RTN","PRC ARPU",243, 0)
  9317    I $G(DTOU T)!$G(DUOU T)!$G(DIRU T) Q 0
  9318   "RTN","PRC ARPU",244, 0)
  9319    S PRCADAY =Y
  9320   "RTN","PRC ARPU",245, 0)
  9321    ;
  9322   "RTN","PRC ARPU",246, 0)
  9323    ;Date of  first paym ent
  9324   "RTN","PRC ARPU",247, 0)
  9325    ;S DIR(0) ="DA^:DT:E X",DIR("B" )="T",DIR( "A")="Due  Date of Fi rst Paymen t:  " D ^D IR  K DIR   (Default  to today)
  9326   "RTN","PRC ARPU",248, 0)
  9327    S %DT="AE FX",%DT(0) ="NOW",%DT ("A")="Due  Date of F irst Payme nt:  " D ^ %DT K %DT
  9328   "RTN","PRC ARPU",249, 0)
  9329    I Y=-1!($ G(DTOUT))  Q 0
  9330   "RTN","PRC ARPU",250, 0)
  9331    S PRCAFPD =Y ;First  payment da te
  9332   "RTN","PRC ARPU",251, 0)
  9333    Q 1
  9334   "RTN","PRC ARPU",252, 0)
  9335    ;
  9336   "RTN","PRC ARPU",253, 0)
  9337   COMMENTS ; File DEBTO R comments
  9338   "RTN","PRC ARPU",254, 0)
  9339    S DIR(0)= "Y"
  9340   "RTN","PRC ARPU",255, 0)
  9341    S DIR("A" )="Do you  wish to en ter Debtor  Comments"
  9342   "RTN","PRC ARPU",256, 0)
  9343    S DIR("?" )="Enter Y  or N to e nter Debto r Comments "
  9344   "RTN","PRC ARPU",257, 0)
  9345    D ^DIR
  9346   "RTN","PRC ARPU",258, 0)
  9347    Q
  9348   "RTN","PRC ARPU",259, 0)
  9349    ;
  9350   "RTN","PRC ARPU",260, 0)
  9351   DUEARR(ARR ) ;Total o utstanding  balance f or array A RR returne d in PLNTD UE
  9352   "RTN","PRC ARPU",261, 0)
  9353    ; ARR - A n array of  bills
  9354   "RTN","PRC ARPU",262, 0)
  9355    ;
  9356   "RTN","PRC ARPU",263, 0)
  9357    ; Returns : Outstand ing balanc e of Bills  in ARR
  9358   "RTN","PRC ARPU",264, 0)
  9359    N PLNTDUE ,I,PRCABN
  9360   "RTN","PRC ARPU",265, 0)
  9361    S PLNTDUE =0
  9362   "RTN","PRC ARPU",266, 0)
  9363    F I=1:1:A RR S PRCAB N=$O(ARR(I ,0)),PLNTD UE=PLNTDUE +$P(ARR(I, PRCABN),U, 4)
  9364   "RTN","PRC ARPU",267, 0)
  9365    Q PLNTDUE
  9366   "RTN","PRC ARPU",268, 0)
  9367    ;
  9368   "RTN","PRC ARPU",269, 0)
  9369   ADDPLAN(AD D,PRCAMT,P RCADAY,PRC AFPD,PRCAD T,TRAN) ;R ecord plan  on bills
  9370   "RTN","PRC ARPU",270, 0)
  9371    ; ADD - A n array of  bills to  add to the  repayment  plan
  9372   "RTN","PRC ARPU",271, 0)
  9373    ; PRCAMT  - Monthly  amount the  debtor wi ll pay
  9374   "RTN","PRC ARPU",272, 0)
  9375    ; PRCADAY  - Day of  the month  payment wi ll be made
  9376   "RTN","PRC ARPU",273, 0)
  9377    ; PRCAFPD  - Date of  first pay ment
  9378   "RTN","PRC ARPU",274, 0)
  9379    ; PRCADT  - Date pla n s establ ished
  9380   "RTN","PRC ARPU",275, 0)
  9381    ; TRAN -  Flag to fi le a trans action for  new plan
  9382   "RTN","PRC ARPU",276, 0)
  9383    ;
  9384   "RTN","PRC ARPU",277, 0)
  9385    N BILL,FP ,PAYDATE,P RCAPB,PRCA BN,X,XX,PR CANPAY,PRC AFP,PRCARE M,PRCA,PAY
  9386   "RTN","PRC ARPU",278, 0)
  9387    I $G(TRAN )="" S TRA N=1 ; the  default ac tion is to  file a tr ansaction
  9388   "RTN","PRC ARPU",279, 0)
  9389    S FP=PRCA MT,PAYDATE =PRCAFPD
  9390   "RTN","PRC ARPU",280, 0)
  9391    F BILL=1: 1:ADD D
  9392   "RTN","PRC ARPU",281, 0)
  9393    . S PRCAB N=$O(ADD(B ILL,0))
  9394   "RTN","PRC ARPU",282, 0)
  9395    . S X=ADD (BILL,PRCA BN)
  9396   "RTN","PRC ARPU",283, 0)
  9397    . S PRCAP B=$P(X,U,4 )
  9398   "RTN","PRC ARPU",284, 0)
  9399    . S XX=$$ PAYMENTS(P RCAPB,FP,P RCAMT),PRC ANPAY=$P(X X,U,1),PRC AFP=$P(XX, U,2),PRCAR EM=$P(XX,U ,3)
  9400   "RTN","PRC ARPU",285, 0)
  9401    . F PAY=1 :1:PRCANPA Y D
  9402   "RTN","PRC ARPU",286, 0)
  9403    .. S PAYD ATE=$S(PAY =1&(PRCARE M):PAYDATE ,1:$$INCDA TE(PAYDATE ,PRCADAY))  ;If remai nder from  previous b ill, file  on same da te
  9404   "RTN","PRC ARPU",287, 0)
  9405    .. S ^PRC A(430,PRCA BN,5,PAY,0 )=PAYDATE_ U_"0"
  9406   "RTN","PRC ARPU",288, 0)
  9407    . S ^PRCA (430,PRCAB N,5,0)="^4 30.051DA^" _PRCANPAY_ "^"_PRCANP AY
  9408   "RTN","PRC ARPU",289, 0)
  9409    . S (DIC, DIE)="^PRC A(430,",DA =PRCABN,DR ="41///"_P RCADT_";42 ///"_PRCAD AY_";43/// "_PRCAMT_" ;44///"_PR CANPAY
  9410   "RTN","PRC ARPU",290, 0)
  9411    . S PRCA( "LOCK")=0  D LOCKF^PR CAWO1 D:PR CA("LOCK") =0 ^DIE
  9412   "RTN","PRC ARPU",291, 0)
  9413    . K DA,DI C,DIE,DR
  9414   "RTN","PRC ARPU",292, 0)
  9415    . I TRAN  D TRAN
  9416   "RTN","PRC ARPU",293, 0)
  9417    . D IXDIK
  9418   "RTN","PRC ARPU",294, 0)
  9419    . L -^PRC A(430,+$G( PRCABN))
  9420   "RTN","PRC ARPU",295, 0)
  9421    . S FP=$S (PRCAREM:P RCAREM,1:P RCAMT)
  9422   "RTN","PRC ARPU",296, 0)
  9423    Q
  9424   "RTN","PRC ARPU",297, 0)
  9425    ;
  9426   "RTN","PRC ARPU",298, 0)
  9427   IXDIK ;Rei ndex 5 nod e in 430
  9428   "RTN","PRC ARPU",299, 0)
  9429    N DA,DIK
  9430   "RTN","PRC ARPU",300, 0)
  9431    S DIK="^P RCA(430,"_ PRCABN_",5 ,",DA(1)=P RCABN
  9432   "RTN","PRC ARPU",301, 0)
  9433    D IXALL^D IK
  9434   "RTN","PRC ARPU",302, 0)
  9435    K DIK
  9436   "RTN","PRC ARPU",303, 0)
  9437    Q
  9438   "RTN","PRC ARPU",304, 0)
  9439    ;
  9440   "RTN","PRC ARPU",305, 0)
  9441   TRAN ;File  plan add  transactio n in 433
  9442   "RTN","PRC ARPU",306, 0)
  9443    N DIE,DA, DR,PRCAEN, PRCAKTY
  9444   "RTN","PRC ARPU",307, 0)
  9445    S PRCAKTY =$O(^PRCA( 430.3,"AC" ,16,""))
  9446   "RTN","PRC ARPU",308, 0)
  9447    S PRCAEN= -1 D SETTR ^PRCAUTL Q :PRCAEN<0   S DA=PRCA EN
  9448   "RTN","PRC ARPU",309, 0)
  9449    S DIE="^P RCA(433,", DR=".03/// /"_PRCABN_ ";11///"_D T_";12///" _PRCAKTY_" ;15///"_PR CAPB_"" D  ^DIE
  9450   "RTN","PRC ARPU",310, 0)
  9451    S $P(^PRC A(433,PRCA EN,0),U,4) =2
  9452   "RTN","PRC ARPU",311, 0)
  9453    Q
  9454   "RTN","PRC ARPU",312, 0)
  9455    ;
  9456   "RTN","PRC ARPU",313, 0)
  9457   TRANDEL ;F ile plan d elete tran saction in  433
  9458   "RTN","PRC ARPU",314, 0)
  9459    N DIE,DA, DR,PRCAEN, PRCAKTY
  9460   "RTN","PRC ARPU",315, 0)
  9461    S PRCAKTY =$O(^PRCA( 430.3,"AC" ,31,""))
  9462   "RTN","PRC ARPU",316, 0)
  9463    S PRCAEN= -1 D SETTR ^PRCAUTL Q :PRCAEN<0   S DA=PRCA EN
  9464   "RTN","PRC ARPU",317, 0)
  9465    S DIE="^P RCA(433,", DR=".03/// /"_PRCABN_ ";11///"_D T_";12///" _PRCAKTY_" ;15///"_0_ "" D ^DIE
  9466   "RTN","PRC ARPU",318, 0)
  9467    S $P(^PRC A(433,PRCA EN,0),U,4) =2
  9468   "RTN","PRC ARPU",319, 0)
  9469    Q
  9470   "RTN","PRC ARPU",320, 0)
  9471    ;
  9472   "RTN","PRC ARPU",321, 0)
  9473   PAYMENTS(A MT,FP,PAY)  ;How many  payments?
  9474   "RTN","PRC ARPU",322, 0)
  9475    ; AMT - T OTAL DUE O N BILL
  9476   "RTN","PRC ARPU",323, 0)
  9477    ; FP - FI RST PAYMEN T AMOUNT
  9478   "RTN","PRC ARPU",324, 0)
  9479    ; PAY - A MOUNT DEBT OR AGREES  TO MONTHLY
  9480   "RTN","PRC ARPU",325, 0)
  9481    ;
  9482   "RTN","PRC ARPU",326, 0)
  9483    ; Returns :
  9484   "RTN","PRC ARPU",327, 0)
  9485    ;  NP - N umber of p ayments
  9486   "RTN","PRC ARPU",328, 0)
  9487    ;  FP - F irst payme nt
  9488   "RTN","PRC ARPU",329, 0)
  9489    ;  REM -  Remainder
  9490   "RTN","PRC ARPU",330, 0)
  9491    ;
  9492   "RTN","PRC ARPU",331, 0)
  9493    N NP,RAMT ,REM
  9494   "RTN","PRC ARPU",332, 0)
  9495    I FP'<AMT  S NP=1,RE M=FP-AMT,F P=AMT Q NP _U_FP_U_RE M
  9496   "RTN","PRC ARPU",333, 0)
  9497    I AMT>FP  S RAMT=AMT -FP
  9498   "RTN","PRC ARPU",334, 0)
  9499    S NP=RAMT \PAY+1
  9500   "RTN","PRC ARPU",335, 0)
  9501    S REM=$S( PAY>RAMT:P AY-RAMT,1: PAY-(RAMT# PAY))
  9502   "RTN","PRC ARPU",336, 0)
  9503    I REM S N P=NP+1
  9504   "RTN","PRC ARPU",337, 0)
  9505    Q NP_U_FP _U_REM
  9506   "RTN","PRC ARPU",338, 0)
  9507    ;
  9508   "RTN","PRC ARPU",339, 0)
  9509   INCDATE(DA TE,PRCADAY ) ;Increme nt payment  date
  9510   "RTN","PRC ARPU",340, 0)
  9511    ; DATE -  Today's da te in File Man format
  9512   "RTN","PRC ARPU",341, 0)
  9513    ; PRCADAY  - Day of  the month  payment is  due
  9514   "RTN","PRC ARPU",342, 0)
  9515    ;
  9516   "RTN","PRC ARPU",343, 0)
  9517    ; Returns : Next pay ment date
  9518   "RTN","PRC ARPU",344, 0)
  9519    ;
  9520   "RTN","PRC ARPU",345, 0)
  9521    N PRCAYR, PRCAMON
  9522   "RTN","PRC ARPU",346, 0)
  9523    S PRCAYR= $E(DATE,1, 3),PRCAMON =$E(DATE,4 ,5)
  9524   "RTN","PRC ARPU",347, 0)
  9525    I $L(PRCA DAY)=1 S P RCADAY="0" _PRCADAY
  9526   "RTN","PRC ARPU",348, 0)
  9527    S PRCAMON =PRCAMON+1
  9528   "RTN","PRC ARPU",349, 0)
  9529    I PRCAMON =13 S PRCA MON=1,PRCA YR=PRCAYR+ 1
  9530   "RTN","PRC ARPU",350, 0)
  9531    Q PRCAYR_ $S((PRCAMO N<10&($E(P RCAMON,1)' =0)):0_PRC AMON,1:PRC AMON)_PRCA DAY
  9532   "RTN","PRC ARPU",351, 0)
  9533    ;
  9534   "RTN","PRC ARPU",352, 0)
  9535   PAYDISP(DE BTOR,PLNDT ) ;Display  all payme nt for Deb tor since  Repayment  Plan effec tive date
  9536   "RTN","PRC ARPU",353, 0)
  9537    ; DEBTOR   - Pointer  to #340
  9538   "RTN","PRC ARPU",354, 0)
  9539    ; PLNDT -  Effective  date of r epayment p lan
  9540   "RTN","PRC ARPU",355, 0)
  9541    ;
  9542   "RTN","PRC ARPU",356, 0)
  9543    N PAY,DT, TN
  9544   "RTN","PRC ARPU",357, 0)
  9545    S PAY=0
  9546   "RTN","PRC ARPU",358, 0)
  9547    W "Paymen ts Since P lan Date", !
  9548   "RTN","PRC ARPU",359, 0)
  9549    I '$D(^PR CA(433,"AT D",DEBTOR) ) W "None" ,!! Q
  9550   "RTN","PRC ARPU",360, 0)
  9551    S DT=$G(P LNDT) I DT ="" W "Non e",!! Q
  9552   "RTN","PRC ARPU",361, 0)
  9553    F  S DT=$ O(^PRCA(43 3,"ATD",DE BTOR,DT))  Q:'DT  D
  9554   "RTN","PRC ARPU",362, 0)
  9555    . S TN=""  F  S TN=$ O(^PRCA(43 3,"ATD",DE BTOR,DT,TN )) Q:'TN   D
  9556   "RTN","PRC ARPU",363, 0)
  9557    .. I $D(^ PRCA(433,T N,0)),$D(^ (1)),"^2^3 4^41^"[("^ "_$P(^(1), "^",2)_"^" ) D
  9558   "RTN","PRC ARPU",364, 0)
  9559    ... I $P( ^PRCA(433, TN,0),"^", 4)'=2 Q  ; if transac tion is no t complete  (2), do n ot display  it
  9560   "RTN","PRC ARPU",365, 0)
  9561    ... W $$M DY($P(DT," .",1),"/") ,"  ",$P(^ PRCA(430,$ P(^PRCA(43 3,TN,0),U, 2),0),U,1) ,"  ",$J($ P(^PRCA(43 3,TN,1),U, 5),10,2),!
  9562   "RTN","PRC ARPU",366, 0)
  9563    ... S PAY =1
  9564   "RTN","PRC ARPU",367, 0)
  9565    I 'PAY W  "None",!
  9566   "RTN","PRC ARPU",368, 0)
  9567    Q
  9568   "RTN","PRC ARPU",369, 0)
  9569    ;
  9570   "RTN","PRC ARPU",370, 0)
  9571   MERGE(PLN, ADD) ;Add  ADD to PLN
  9572   "RTN","PRC ARPU",371, 0)
  9573    ; PLN - A n array of  bills
  9574   "RTN","PRC ARPU",372, 0)
  9575    ; ADD - A n array of  bills
  9576   "RTN","PRC ARPU",373, 0)
  9577    ;
  9578   "RTN","PRC ARPU",374, 0)
  9579    N TMP,OLD ,X,CNT,I,P RCABN
  9580   "RTN","PRC ARPU",375, 0)
  9581    M OLD=PLN  K PLN
  9582   "RTN","PRC ARPU",376, 0)
  9583    F CNT=1:1 :OLD D
  9584   "RTN","PRC ARPU",377, 0)
  9585    . S PRCAB N=$O(OLD(C NT,0))
  9586   "RTN","PRC ARPU",378, 0)
  9587    . S X=OLD (CNT,PRCAB N),TMP(PRC ABN)=X
  9588   "RTN","PRC ARPU",379, 0)
  9589    F CNT=1:1 :ADD D
  9590   "RTN","PRC ARPU",380, 0)
  9591    . S PRCAB N=$O(ADD(C NT,0))
  9592   "RTN","PRC ARPU",381, 0)
  9593    . S X=ADD (CNT,PRCAB N),TMP(PRC ABN)=X
  9594   "RTN","PRC ARPU",382, 0)
  9595    S PRCABN= 0 F I=1:1  S PRCABN=$ O(TMP(PRCA BN)) Q:'PR CABN  D
  9596   "RTN","PRC ARPU",383, 0)
  9597    . S PLN(I ,PRCABN)=T MP(PRCABN) ,PLN=I
  9598   "RTN","PRC ARPU",384, 0)
  9599    Q
  9600   "RTN","PRC ARPU",385, 0)
  9601    ;
  9602   "RTN","PRC ARPU",386, 0)
  9603   MULTI(PLN)  ;Multiple  Repayment  Plans?
  9604   "RTN","PRC ARPU",387, 0)
  9605    ; PLN - A n array of  bills
  9606   "RTN","PRC ARPU",388, 0)
  9607    ;
  9608   "RTN","PRC ARPU",389, 0)
  9609    ; Returns : 1 if mul tiple Repa yment Plan s, 0 if si ngle plan
  9610   "RTN","PRC ARPU",390, 0)
  9611    N I,FIRDT ,MULT,PRCA BN,X
  9612   "RTN","PRC ARPU",391, 0)
  9613    S FIRDT=0 ,MULT=0
  9614   "RTN","PRC ARPU",392, 0)
  9615    F I=1:1:P LN D  Q:MU LT
  9616   "RTN","PRC ARPU",393, 0)
  9617    . S PRCAB N=$O(PLN(I ,0))
  9618   "RTN","PRC ARPU",394, 0)
  9619    . S X=PLN (I,PRCABN) ,PLNDT=$P( X,U,8)
  9620   "RTN","PRC ARPU",395, 0)
  9621    . I 'FIRD T S FIRDT= PLNDT
  9622   "RTN","PRC ARPU",396, 0)
  9623    . I PLNDT '=FIRDT S  MULT=1
  9624   "RTN","PRC ARPU",397, 0)
  9625    Q MULT
  9626   "RTN","PRC ARPU",398, 0)
  9627    ;
  9628   "RTN","PRC ARPU",399, 0)
  9629   PAUSE ;Pre ss Return  to Continu e
  9630   "RTN","PRC ARPU",400, 0)
  9631    N DIR
  9632   "RTN","PRC ARPU",401, 0)
  9633    S DIR(0)= "E" D ^DIR
  9634   "RTN","PRC ARPU",402, 0)
  9635    W !
  9636   "RTN","PRC ARPU",403, 0)
  9637    Q
  9638   "RTN","PRC ARPU",404, 0)
  9639    ;
  9640   "RTN","PRC ARPU",405, 0)
  9641   CMTMULT(DE BTOR) ;Ent er multipl e line com ment
  9642   "RTN","PRC ARPU",406, 0)
  9643    ; DEBTOR   - Pointer  to #340
  9644   "RTN","PRC ARPU",407, 0)
  9645    ;
  9646   "RTN","PRC ARPU",408, 0)
  9647    N TYPE
  9648   "RTN","PRC ARPU",409, 0)
  9649    S TYPE=1
  9650   "RTN","PRC ARPU",410, 0)
  9651    D ADJ(DEB TOR,TYPE)
  9652   "RTN","PRC ARPU",411, 0)
  9653    Q
  9654   "RTN","PRC ARPU",412, 0)
  9655    ;
  9656   "RTN","PRC ARPU",413, 0)
  9657   CMTENTR(DE BTOR) ;Ent er comment s question
  9658   "RTN","PRC ARPU",414, 0)
  9659    ; DEBTOR   - Pointer  to #340
  9660   "RTN","PRC ARPU",415, 0)
  9661    ;
  9662   "RTN","PRC ARPU",416, 0)
  9663    N DIR,ANS
  9664   "RTN","PRC ARPU",417, 0)
  9665    S DIR(0)= "Y",DIR("B ")="YES",D IR("A")="D o you wish  to enter  Debtor com ments"
  9666   "RTN","PRC ARPU",418, 0)
  9667    D ^DIR
  9668   "RTN","PRC ARPU",419, 0)
  9669    S ANS=$S( $E(X)="Y": 1,$E(X)="y ":1,$E(X)= "N":0,1:0)
  9670   "RTN","PRC ARPU",420, 0)
  9671    I ANS W ! ! D CMTMUL T(DEBTOR)
  9672   "RTN","PRC ARPU",421, 0)
  9673    Q
  9674   "RTN","PRC ARPU",422, 0)
  9675    ;
  9676   "RTN","PRC ARPU",423, 0)
  9677   ADJ(DEBT,T YPE) ;Adju st an acco unt for DE BT (340 en try)
  9678   "RTN","PRC ARPU",424, 0)
  9679    N DA,DIC, DIE,DR,ERR ,EVN,SITE, X,Y
  9680   "RTN","PRC ARPU",425, 0)
  9681    S SITE=$$ SITE^RCMSI TE() G:SIT E'>0 Q2
  9682   "RTN","PRC ARPU",426, 0)
  9683    S DEBT=$P ($G(^RCD(3 40,+$G(DEB T),0)),"^" ) G:'DEBT  Q2
  9684   "RTN","PRC ARPU",427, 0)
  9685    D OPEN^RC EVDRV1(TYP E,DEBT,DT, DUZ,SITE,. ERR,.EVN)
  9686   "RTN","PRC ARPU",428, 0)
  9687    I ERR]""! (EVN<0) W  !,"Error ( ",ERR,") t rying to o pen a new  event",! G  Q2
  9688   "RTN","PRC ARPU",429, 0)
  9689    W !,"Refe rence numb er assigne d: ",$P(^R C(341,EVN, 0),"^"),!
  9690   "RTN","PRC ARPU",430, 0)
  9691   EDT S DR=$ P($G(^RC(3 41.1,$O(^R C(341.1,"A C",TYPE,0) ),1)),"^") ,DIE="^RC( 341,",DA=E VN D:DR]""  ^DIE
  9692   "RTN","PRC ARPU",431, 0)
  9693    S X=$$OK( EVN) G:X=0  EDT I X<0 !(X["^") D  DEL^RCEVD RV1(EVN) W  " ... Del eted",! G  Q2
  9694   "RTN","PRC ARPU",432, 0)
  9695    D CLOSE^R CEVDRV1(EV N,.ERR)
  9696   "RTN","PRC ARPU",433, 0)
  9697    I ERR]""  W !,"Error  ("_ERR_") ",!,"...   trying to  close this  event"
  9698   "RTN","PRC ARPU",434, 0)
  9699   Q2 Q
  9700   "RTN","PRC ARPU",435, 0)
  9701   OK(EVN) ;O K an event  or delete  it
  9702   "RTN","PRC ARPU",436, 0)
  9703    NEW L,FLD S,BY,TO,DI C,IOP,DIR, DIRUT,DIRO UT,DUOUT
  9704   "RTN","PRC ARPU",437, 0)
  9705    W ! S DIR (0)="YA",D IR("B")="Y ES",DIR("A ")="Is thi s OK? " D  ^DIR K DIR
  9706   "RTN","PRC ARPU",438, 0)
  9707    S:$D(DTOU T) Y=-1
  9708   "RTN","PRC ARPU",439, 0)
  9709    Q Y
  9710   "RTN","PRC ARPU",440, 0)
  9711    ;
  9712   "RTN","PRC ARPU",441, 0)
  9713   DSMPLNS(DE BTOR,PLN)  ;Display m ultiple pl ans
  9714   "RTN","PRC ARPU",442, 0)
  9715    ; DEBTOR   - Pointer  to #340
  9716   "RTN","PRC ARPU",443, 0)
  9717    ; PLN - A n array of  bills
  9718   "RTN","PRC ARPU",444, 0)
  9719    ;
  9720   "RTN","PRC ARPU",445, 0)
  9721    N CNT,J,O LDPLN,PLAN DAT,PRCABN ,TMP,X
  9722   "RTN","PRC ARPU",446, 0)
  9723    F CNT=1:1 :PLN D
  9724   "RTN","PRC ARPU",447, 0)
  9725    . S PRCAB N=$O(PLN(C NT,0))
  9726   "RTN","PRC ARPU",448, 0)
  9727    . S X=PLN (CNT,PRCAB N),PLANDAT =$P(X,U,8)
  9728   "RTN","PRC ARPU",449, 0)
  9729    . S TMP(P LANDAT,CNT ,PRCABN)=X
  9730   "RTN","PRC ARPU",450, 0)
  9731    S PLANDAT ="" F  S P LANDAT=$O( TMP(PLANDA T)) Q:PLAN DAT=""  D
  9732   "RTN","PRC ARPU",451, 0)
  9733    . K OLDPL N
  9734   "RTN","PRC ARPU",452, 0)
  9735    . S J=0
  9736   "RTN","PRC ARPU",453, 0)
  9737    . S CNT=0  F  S CNT= $O(TMP(PLA NDAT,CNT))  Q:CNT=""   D
  9738   "RTN","PRC ARPU",454, 0)
  9739    .. S PRCA BN="" F  S  PRCABN=$O (TMP(PLAND AT,CNT,PRC ABN)) Q:PR CABN=""  D
  9740   "RTN","PRC ARPU",455, 0)
  9741    ... S J=J +1
  9742   "RTN","PRC ARPU",456, 0)
  9743    ... S X=T MP(PLANDAT ,CNT,PRCAB N),OLDPLN( J,PRCABN)= X
  9744   "RTN","PRC ARPU",457, 0)
  9745    . S OLDPL N=J
  9746   "RTN","PRC ARPU",458, 0)
  9747    . D RPDIS (DEBTOR,.O LDPLN)
  9748   "RTN","PRC ARPU",459, 0)
  9749    . D DISPL AY(.OLDPLN ,0)
  9750   "RTN","PRC ARPU",460, 0)
  9751    . D PAUSE
  9752   "RTN","PRC ARPU",461, 0)
  9753    Q
  9754   "RTN","PRC ASVC")
  9755   0^55^B1176 3521^B9776 542
  9756   "RTN","PRC ASVC",1,0)
  9757   PRCASVC ;S F-ISC/YJK- ACCEPT, AM MEND AND C ANCEL AR B ILL ;9/6/9 5  2:09 PM
  9758   "RTN","PRC ASVC",2,0)
  9759   V ;;4.5;Ac counts Rec eivable;** 1,21,48,90 ,136,138,2 49,274,315 **;Mar 20,  1995;Buil d 55
  9760   "RTN","PRC ASVC",3,0)
  9761    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  9762   "RTN","PRC ASVC",4,0)
  9763   REL ;Accep t bill int o AR
  9764   "RTN","PRC ASVC",5,0)
  9765    N X,Y
  9766   "RTN","PRC ASVC",6,0)
  9767    D ^PRCASV C6 G:$D(PR CAERR) Q3  S PRCADEBT =$O(^RCD(3 40,"B",PRC ASV("DEBTO R"),0)) I  'PRCADEBT  K DD,DO S  DIC="^RCD( 340,",DIC( 0)="QL",X= PRCASV("DE BTOR"),DLA YGO=340 D  FILE^DICN  K DIC,DLAY GO,DO Q:Y< 0  S PRCAD EBT=+Y
  9768   "RTN","PRC ASVC",7,0)
  9769    D FY S PR CAT=$P(^PR CA(430.2,P RCASV("CAT "),0),"^", 6) F Y="ID NO^4","GPN O^6","GPNM ^5","INPA^ 1" S:$D(PR CASV($P(Y, "^"))) $P( ^PRCA(430, PRCASV("AR REC"),202) ,"^",$P(Y, "^",2))=PR CASV($P(Y, "^"))
  9770   "RTN","PRC ASVC",8,0)
  9771    S DIE="^P RCA(430,", DR="[PRCAS V REL]",DA =PRCASV("A RREC") D ^ DIE
  9772   "RTN","PRC ASVC",9,0)
  9773   Q3 K PRCAT ,PRCAORA,P RCADEBT,DI E,DR,%
  9774   "RTN","PRC ASVC",10,0 )
  9775    ;  set th e fund for  the bill  (set in ro utine rcxf msuf)
  9776   "RTN","PRC ASVC",11,0 )
  9777    S:'$G(DA)  DA=PRCASV ("ARREC")  S %=$$GETF UNDB^RCXFM SUF(DA)
  9778   "RTN","PRC ASVC",12,0 )
  9779    I "^27^28 ^"[("^"_PR CASV("CAT" )_"^") D
  9780   "RTN","PRC ASVC",13,0 )
  9781    .N P
  9782   "RTN","PRC ASVC",14,0 )
  9783    .F P=6,8, 10,15 S $P (^PRCA(430 ,DA,11),"^ ",P)=$S(P= 6:1000,P=8 :$G(PRCASV ("SITE")), P=10:9,1:$ P($G(PRCAS V("FY"))," ^"))
  9784   "RTN","PRC ASVC",15,0 )
  9785    .S $P(^PR CA(430,DA, 11),"^",18 ,999)=""
  9786   "RTN","PRC ASVC",16,0 )
  9787    I PRCASV( "CAT")=27  S $P(^PRCA (430,+PRCA SV("ARREC" ),0),"^",5 )=$O(^PRCA (430.6,"B" ,"CHMPV",0 ))
  9788   "RTN","PRC ASVC",17,0 )
  9789    I PRCASV( "CAT")=29  S $P(^PRCA (430,DA,11 ),"^",18,9 99)=""
  9790   "RTN","PRC ASVC",18,0 )
  9791    ;
  9792   "RTN","PRC ASVC",19,0 )
  9793    ; prca*4. 5*274 - fo r TRICARE  claims, se t the stat ion# (fiel d# 257) fr om the PRC ASV("SITE" ) value
  9794   "RTN","PRC ASVC",20,0 )
  9795    I "^30^31 ^32^"[("^" _PRCASV("C AT")_"^")  D
  9796   "RTN","PRC ASVC",21,0 )
  9797    .N RCCARE ,P
  9798   "RTN","PRC ASVC",22,0 )
  9799    .S:'$G(PR CASV("SITE ")) PRCASV ("SITE")=$ P($$SITE^V ASITE,"^", 3)
  9800   "RTN","PRC ASVC",23,0 )
  9801    .F P=8,9, 10,15 S $P (^PRCA(430 ,DA,11),"^ ",P)=$S(P= 8:$G(PRCAS V("SITE")) ,P=9:1,P=1 0:"02",1:$ P($G(PRCAS V("FY"))," ^"))
  9802   "RTN","PRC ASVC",24,0 )
  9803    .S $P(^PR CA(430,DA, 11),"^",18 )=""
  9804   "RTN","PRC ASVC",25,0 )
  9805    .S RCCARE =$$TYP^IBR FN(DA),RCC ARE(1)=$S( RCCARE="I" :8028,RCCA RE="O":802 9,1:8030), $P(^PRCA(4 30,DA,11), "^",6)=RCC ARE(1)
  9806   "RTN","PRC ASVC",26,0 )
  9807    ;
  9808   "RTN","PRC ASVC",27,0 )
  9809    I PRCASV( "CAT")=47  D  ;PRCA*4 .5*315/BAA
  9810   "RTN","PRC ASVC",28,0 )
  9811    .N RCCARE ,P
  9812   "RTN","PRC ASVC",29,0 )
  9813    .S:'$G(PR CASV("SITE ")) PRCASV ("SITE")=$ P($$SITE^V ASITE,"^", 3)
  9814   "RTN","PRC ASVC",30,0 )
  9815    .F P=8,9, 10,15 S $P (^PRCA(430 ,DA,11),"^ ",P)=$S(P= 8:$G(PRCAS V("SITE")) ,P=9:1,P=1 0:"02",1:$ P($G(PRCAS V("FY"))," ^"))
  9816   "RTN","PRC ASVC",31,0 )
  9817    .S $P(^PR CA(430,DA, 11),"^",18 )=""
  9818   "RTN","PRC ASVC",32,0 )
  9819    .S RCCARE =$$TYP^IBR FN(DA),RCC ARE(1)=$S( RCCARE="I" :"841Z",RC CARE="O":" 842Z",1:"8 42Z"),$P(^ PRCA(430,D A,11),"^", 6)=RCCARE( 1)
  9820   "RTN","PRC ASVC",33,0 )
  9821    ; 
  9822   "RTN","PRC ASVC",34,0 )
  9823    I $G(PRCA SV("MEDCA" ))!$G(PRCA SV("MEDURE ")) D MEDI CARE
  9824   "RTN","PRC ASVC",35,0 )
  9825    K DA
  9826   "RTN","PRC ASVC",36,0 )
  9827    Q
  9828   "RTN","PRC ASVC",37,0 )
  9829    ;
  9830   "RTN","PRC ASVC",38,0 )
  9831    ;
  9832   "RTN","PRC ASVC",39,0 )
  9833   FY K:$D(^P RCA(430,PR CASV("ARRE C"),2)) ^( 2) S PRCAK 1=1,PRCAOR A=0,^PRCA( 430,PRCASV ("ARREC"), 2,0)="^430 .01IA^^"
  9834   "RTN","PRC ASVC",40,0 )
  9835    F J=1:1 S  X=$P(PRCA SV("FY"),U ,PRCAK1),P RCAMT=+$P( PRCASV("FY "),U,PRCAK 1+1) D FY1  S PRCAK1= PRCAK1+2 Q :$P(PRCASV ("FY"),U,P RCAK1)=""
  9836   "RTN","PRC ASVC",41,0 )
  9837   EXITFY K P RCAK1,J,PR CAMT Q
  9838   "RTN","PRC ASVC",42,0 )
  9839   FY1 S DA(1 )=PRCASV(" ARREC"),DI C="^PRCA(4 30,"_DA(1) _",2,",DIC (0)="QL",D LAYGO=430  D ^DIC K D IC,DLAYGO  Q:Y<0  S D A=+Y
  9840   "RTN","PRC ASVC",43,0 )
  9841    S PRCAORA =PRCAORA+P RCAMT,$P(^ PRCA(430,P RCASV("ARR EC"),0),"^ ",3)=PRCAO RA,$P(^(7) ,"^")=PRCA ORA,$P(^(2 ,DA,0),U,2 )=PRCAMT,$ P(^(0),"^" ,8)=PRCAMT
  9842   "RTN","PRC ASVC",44,0 )
  9843    K DA Q
  9844   "RTN","PRC ASVC",45,0 )
  9845    ;
  9846   "RTN","PRC ASVC",46,0 )
  9847   MEDICARE ; Setup Medi care Suppl emental am ounts
  9848   "RTN","PRC ASVC",47,0 )
  9849    N DR,DIE
  9850   "RTN","PRC ASVC",48,0 )
  9851    I $G(PRCA SV("MEDCA" )) S DIE=" ^PRCA(430, ",DR="131/ ///"_PRCAS V("MEDCA")  D ^DIE
  9852   "RTN","PRC ASVC",49,0 )
  9853    I $G(PRCA SV("MEDURE ")) S DIE= "^PRCA(430 ,",DR="132 ////"_PRCA SV("MEDURE ") D ^DIE
  9854   "RTN","PRC ASVC",50,0 )
  9855    K PRCASV( "MEDCA"),P RCASV("MED URE")
  9856   "RTN","PRC ASVC",51,0 )
  9857    Q  ;MEDIC ARE
  9858   "RTN","PRC ASVC",52,0 )
  9859    ;
  9860   "RTN","PRC ASVC1")
  9861   0^56^B1372 959^B13727 64
  9862   "RTN","PRC ASVC1",1,0 )
  9863   PRCASVC1 ; SF-ISC/YJK -ACCEPT, A MMEND AND  CANCEL AR  BILL ;5/1/ 95  3:05 P M
  9864   "RTN","PRC ASVC1",2,0 )
  9865    ;;4.5;Acc ounts Rece ivable;**1 ,68,48,84, 157,295,31 5**;Mar 20 , 1995;Bui ld 55
  9866   "RTN","PRC ASVC1",3,0 )
  9867    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  9868   "RTN","PRC ASVC1",4,0 )
  9869    Q
  9870   "RTN","PRC ASVC1",5,0 )
  9871    ;
  9872   "RTN","PRC ASVC1",6,0 )
  9873    ;
  9874   "RTN","PRC ASVC1",7,0 )
  9875   AMEND ;  a mend the b ill in AR
  9876   "RTN","PRC ASVC1",8,0 )
  9877    D CANCEL
  9878   "RTN","PRC ASVC1",9,0 )
  9879    Q
  9880   "RTN","PRC ASVC1",10, 0)
  9881    ;
  9882   "RTN","PRC ASVC1",11, 0)
  9883    ;
  9884   "RTN","PRC ASVC1",12, 0)
  9885   CANCEL ;   cancel the  bill in A R
  9886   "RTN","PRC ASVC1",13, 0)
  9887    N X
  9888   "RTN","PRC ASVC1",14, 0)
  9889    S X=$$CAN CEL^RCBEIB ($G(PRCASV ("ARREC")) ,$G(PRCASV ("DATE")), $G(PRCASV( "BY")),$G( PRCASV("AM T")),$G(PR CASV("COMM ENT")))
  9890   "RTN","PRC ASVC1",15, 0)
  9891    Q
  9892   "RTN","PRC ASVC1",16, 0)
  9893    ;
  9894   "RTN","PRC ASVC1",17, 0)
  9895    ;
  9896   "RTN","PRC ASVC1",18, 0)
  9897   STATUS ;Ch ange the c urrent sta tus of a b ill
  9898   "RTN","PRC ASVC1",19, 0)
  9899    S DIE="^P RCA(430,", DA=PRCASV( "ARREC"),D R="[PRCASV  STATUS]"  D ^DIE K D R,DIE
  9900   "RTN","PRC ASVC1",20, 0)
  9901    ;Allow TR ICARE cate gories to  transmit t o FMS auto matically  - PRCA*4.5 *295
  9902   "RTN","PRC ASVC1",21, 0)
  9903    ;Add INEL IGIBLE HOS P. REIMB.  - PRCA*4.5 *315
  9904   "RTN","PRC ASVC1",22, 0)
  9905    I $D(^PRC A(430,+DA, 0)),("^27^ 30^31^32^4 7^"[("^"_$ P(^(0),"^" ,2)_"^"))  D EN^PRCAC PV(+DA)
  9906   "RTN","PRC ASVC1",23, 0)
  9907    K DA
  9908   "RTN","PRC ASVC1",24, 0)
  9909    Q
  9910   "RTN","PRC AWO1")
  9911   0^58^B2081 9477^B1651 8505
  9912   "RTN","PRC AWO1",1,0)
  9913   PRCAWO1 ;S F-ISC/YJK- ADMIN.COST  CHARGE,TR ANSACTION  SUBROUTINE S ;7/9/93   12:18 PM
  9914   "RTN","PRC AWO1",2,0)
  9915   V ;;4.5;Ac counts Rec eivable;** 67,68,153, 315**;Mar  20, 1995;B uild 55
  9916   "RTN","PRC AWO1",3,0)
  9917    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  9918   "RTN","PRC AWO1",4,0)
  9919    ;Administ rative cos t charge t ransaction
  9920   "RTN","PRC AWO1",5,0)
  9921    ; and sub routines c alled by ^ PRCAWO.
  9922   "RTN","PRC AWO1",6,0)
  9923    ;
  9924   "RTN","PRC AWO1",7,0)
  9925   EN1 ;Admin istrative  cost charg e
  9926   "RTN","PRC AWO1",8,0)
  9927    D BEGIN^P RCAWO G:(' $D(PRCAEN) )!('$D(PRC ABN)) END1  D DIEEN,K ILLV G EN1
  9928   "RTN","PRC AWO1",9,0)
  9929   DIEEN ;Loo p through  edit
  9930   "RTN","PRC AWO1",10,0 )
  9931    I $D(^PRC A(430,"TCS P",PRCABN) ) S RCTRRE V=$$ASKREV () W !  ;3 15/DRF
  9932   "RTN","PRC AWO1",11,0 )
  9933    S DIC="^P RCA(433,", DIE=DIC,DR ="[PRCAE A DMIN]",DA= PRCAEN
  9934   "RTN","PRC AWO1",12,0 )
  9935    S DIC=DIE ,PRCA("LOC K")=0 D LO CKF Q:PRCA ("LOCK")=1   D ^DIE
  9936   "RTN","PRC AWO1",13,0 )
  9937    I '$D(^PR CA(433,PRC AEN,2)) D  DELETE Q
  9938   "RTN","PRC AWO1",14,0 )
  9939    S PRCADM= +$P(^PRCA( 433,PRCAEN ,2),U,1)+$ P(^(2),U,2 )+$P(^(2), U,3)+$P(^( 2),U,4)+$P (^(2),U,8) +$P(^(2),U ,9),$P(^PR CA(433,PRC AEN,1),U,5 )=PRCADM+$ P(^(2),U,5 )+$P(^(2), U,6)+$P(^( 2),U,7)
  9940   "RTN","PRC AWO1",15,0 )
  9941    D DIP S P RCAOK=0 D  ASK1 I $D( PRCA("EXIT ")) D DELE TE Q
  9942   "RTN","PRC AWO1",16,0 )
  9943    I $D(PRCA SUP),PRCAO K=1,$G(^PR CA(433,PRC AEN,2))["- " D  I $D( PRCA("EXIT ")) D DELE TE Q
  9944   "RTN","PRC AWO1",17,0 )
  9945       .N ND2 ,ND7,I,J,K
  9946   "RTN","PRC AWO1",18,0 )
  9947       .S ND2 =$G(^PRCA( 433,PRCAEN ,2)),ND7=$ G(^PRCA(43 0,PRCABN,7 ))
  9948   "RTN","PRC AWO1",19,0 )
  9949       .I PRC ADM<0,-PRC ADM>$P(ND7 ,U,3) D MS G Q
  9950   "RTN","PRC AWO1",20,0 )
  9951       .F I=5 :1:7 I $P( ND2,U,I)<0  D  I $D(P RCA("EXIT" )) Q
  9952   "RTN","PRC AWO1",21,0 )
  9953          ..S  J=$P(ND2, U,I)
  9954   "RTN","PRC AWO1",22,0 )
  9955          ..S  K=$S(I=5: 4,I=6:5,1: 2)
  9956   "RTN","PRC AWO1",23,0 )
  9957          ..I  -J>$P(ND7 ,U,K) D MS G
  9958   "RTN","PRC AWO1",24,0 )
  9959          ..Q
  9960   "RTN","PRC AWO1",25,0 )
  9961       .Q
  9962   "RTN","PRC AWO1",26,0 )
  9963    I PRCAOK= 1 D UPD W  ?40,"*** D ONE***",!  Q
  9964   "RTN","PRC AWO1",27,0 )
  9965    D ASK2 G: PRCAOK=1 D IEEN D DEL ETE Q
  9966   "RTN","PRC AWO1",28,0 )
  9967   UPD S PRCA MF=$S($P(^ PRCA(433,P RCAEN,2),U ,5)]"":+$P (^(2),U,5) ,1:0),$P(^ PRCA(430,P RCABN,7),U ,4)=PRCAMF +$P(^PRCA( 430,PRCABN ,7),U,4)
  9968   "RTN","PRC AWO1",29,0 )
  9969    S PRCACC= $S(+$P(^PR CA(433,PRC AEN,2),U,6 )]"":+$P(^ (2),U,6),1 :0),$P(^PR CA(430,PRC ABN,7),U,5 )=PRCACC+$ P(^PRCA(43 0,PRCABN,7 ),U,5)
  9970   "RTN","PRC AWO1",30,0 )
  9971    S $P(^PRC A(430,PRCA BN,7),U,3) =+PRCADM+$ P(^PRCA(43 0,PRCABN,7 ),U,3)
  9972   "RTN","PRC AWO1",31,0 )
  9973    S $P(^PRC A(430,PRCA BN,7),U,2) =+$P(^PRCA (433,PRCAE N,2),U,7)+ $P(^PRCA(4 30,PRCABN, 7),U,2)
  9974   "RTN","PRC AWO1",32,0 )
  9975    D TRANST
  9976   "RTN","PRC AWO1",33,0 )
  9977    ;
  9978   "RTN","PRC AWO1",34,0 )
  9979    I $D(^PRC A(430,"TCS P",PRCABN) ),PRCAEN D   ;PRCA*4. 5*315/DRF  add cs inc rease adju stment
  9980   "RTN","PRC AWO1",35,0 )
  9981    . I $G(RC TRREV)=0 D  CSATRN^RC TCSPD5
  9982   "RTN","PRC AWO1",36,0 )
  9983    . I $G(RC TRREV)=0 D  INCADJ^RC TCSPU(PRCA BN,PRCAEN)
  9984   "RTN","PRC AWO1",37,0 )
  9985    . I $G(RC TRREV)=1 D  CSATRY^RC TCSPD5
  9986   "RTN","PRC AWO1",38,0 )
  9987    ;
  9988   "RTN","PRC AWO1",39,0 )
  9989   KILLV ;
  9990   "RTN","PRC AWO1",40,0 )
  9991   END1 K PRC A,PRCADM,P RCAOK,%,PR CACC,PRCAM F,PRCA1,PR CA2,PRCAEN ,PRCABN,PR CATYPE,PRC ATY,RCTRRE V Q
  9992   "RTN","PRC AWO1",41,0 )
  9993    ;
  9994   "RTN","PRC AWO1",42,0 )
  9995   MSG W !!,* 7,"INVALID  AMOUNTS E NTERED."
  9996   "RTN","PRC AWO1",43,0 )
  9997    S PRCA("E XIT")="" Q
  9998   "RTN","PRC AWO1",44,0 )
  9999   DIP K DXS  S D0=PRCAE N D ^PRCAT O3 K DXS Q
  10000   "RTN","PRC AWO1",45,0 )
  10001   ASK1 S %=2  W !!,"Is  this corre ct" D YN^D ICN I %<0  S PRCA("EX IT")="" Q
  10002   "RTN","PRC AWO1",46,0 )
  10003    I %=0 W ! ,"Answer ' Y' or 'YES ' if the d ata is cor rect, answ er 'N' or  'NO' if no t",! G ASK 1
  10004   "RTN","PRC AWO1",47,0 )
  10005    S:%=1 PRC AOK=1 Q
  10006   "RTN","PRC AWO1",48,0 )
  10007   ASK2 S %=2  W !!,"Do  you want t o edit" D  YN^DICN I  %<0 S PRCA ("EXIT")=" " Q
  10008   "RTN","PRC AWO1",49,0 )
  10009    I %=0 W ! ,"Answer ' Y' or 'YES ' if you w ant to edi t the data , answer ' N' or 'NO'  if you do  not want  to edit th e data",!  G ASK2
  10010   "RTN","PRC AWO1",50,0 )
  10011    S:%=1 PRC AOK=1 Q
  10012   "RTN","PRC AWO1",51,0 )
  10013    ;======== ========== ====SUBROU TINE DIE== ========== ========== =======
  10014   "RTN","PRC AWO1",52,0 )
  10015    ;this is  called by  ^PRCAWO.
  10016   "RTN","PRC AWO1",53,0 )
  10017   DIE1 ;upda te the cur rent statu s in the f ile 430.
  10018   "RTN","PRC AWO1",54,0 )
  10019    S DIE="^P RCA(430,", DA=PRCABN, DR="8///"_ PRCA("STAT US")_";" D  ^DIE
  10020   "RTN","PRC AWO1",55,0 )
  10021    K DIC,DA, DR Q  ;end  of DIE1
  10022   "RTN","PRC AWO1",56,0 )
  10023    ;
  10024   "RTN","PRC AWO1",57,0 )
  10025   TRANST Q:' $D(PRCAEN)   S $P(^PR CA(433,PRC AEN,0),U,4 )=2 Q
  10026   "RTN","PRC AWO1",58,0 )
  10027    ;======== ========== ======SUBR OUTINE DEL ETE======= ========== ========== =
  10028   "RTN","PRC AWO1",59,0 )
  10029   DELETE ;De letes an e ntry but l eaves an a udit trail
  10030   "RTN","PRC AWO1",60,0 )
  10031    ; Require s PRCABN=B ill #
  10032   "RTN","PRC AWO1",61,0 )
  10033    ;           PRCAEN=T ransaction  to Delete
  10034   "RTN","PRC AWO1",62,0 )
  10035    ;           PRCAARC= True if ar chiving th is trans
  10036   "RTN","PRC AWO1",63,0 )
  10037    ;           PRCANOPR =True if n o message  should be  printed to  screen
  10038   "RTN","PRC AWO1",64,0 )
  10039    ;           PRCACOMM =Reason wh y this tra nsaction i s being de leted
  10040   "RTN","PRC AWO1",65,0 )
  10041    ;           PRCAMAN= True if IR M is manua lly callin g this API  
  10042   "RTN","PRC AWO1",66,0 )
  10043    NEW X,DIN UM,DD,DIC, DLAYGO,DO, DIK,DIE,DA ,T0,T5,FLA G
  10044   "RTN","PRC AWO1",67,0 )
  10045    S FLAG=0
  10046   "RTN","PRC AWO1",68,0 )
  10047    ;Check fo r previous  audit tra il
  10048   "RTN","PRC AWO1",69,0 )
  10049    S T0=$G(^ PRCA(433,P RCAEN,0)), T5=$G(^PRC A(433,PRCA EN,5)) I ' T0 Q
  10050   "RTN","PRC AWO1",70,0 )
  10051    I $P(T0,U ,4)=1,$P(T 0,U,10)=1, ($P(T5,U,2 )["SYSTEM  INACTIVATE D"!($P(T5, U,2)["SYST EM ARCHIVE D")) S FLA G=1 D
  10052   "RTN","PRC AWO1",71,0 )
  10053      .I $G(P RCAMAN) W  !,"You are  attemptin g to delet e a record  that alre ady appear s to have  been delet ed and con tains an a udit trail . Delete f ailed!"
  10054   "RTN","PRC AWO1",72,0 )
  10055    I FLAG Q
  10056   "RTN","PRC AWO1",73,0 )
  10057    S PRCATYP E=$P($G(^P RCA(433,PR CAEN,1)),U ,2)
  10058   "RTN","PRC AWO1",74,0 )
  10059    S:'$D(PRC ACOMM) PRC ACOMM="USE R CANCELED "
  10060   "RTN","PRC AWO1",75,0 )
  10061    S:'$D(PRC ABN) PRCAB N=$P($G(^P RCA(433,PR CAEN,0)),U ,2)
  10062   "RTN","PRC AWO1",76,0 )
  10063    S DIK="^P RCA(433,", DA=PRCAEN  D ^DIK K D IK
  10064   "RTN","PRC AWO1",77,0 )
  10065    ;
  10066   "RTN","PRC AWO1",78,0 )
  10067    ; Now Cre ate the st ub full of  audit tra ils...
  10068   "RTN","PRC AWO1",79,0 )
  10069    ; Trans#( .01), Tran s Status(4 ), Brief C omment(5.0 2), Commen ts(41), 
  10070   "RTN","PRC AWO1",80,0 )
  10071    ; Inc. Tr ans Flag(1 0), Trans  Date(11),  Trans Type (12), Proc . By(42)
  10072   "RTN","PRC AWO1",81,0 )
  10073    S (X,DINU M)=PRCAEN, DIC="^PRCA (433,",DIC (0)="L",DL AYGO=433
  10074   "RTN","PRC AWO1",82,0 )
  10075    K DD,DO D  FILE^DICN  K DIC,DLA YGO,DO
  10076   "RTN","PRC AWO1",83,0 )
  10077    ;
  10078   "RTN","PRC AWO1",84,0 )
  10079    ; Ensure  the 'last  transactio n' counter  is accura te
  10080   "RTN","PRC AWO1",85,0 )
  10081    S $P(^PRC A(433,0),U ,3)=$O(^PR CA(433,"A" ),-1)
  10082   "RTN","PRC AWO1",86,0 )
  10083    ;
  10084   "RTN","PRC AWO1",87,0 )
  10085    S DIE="^P RCA(433,", DR="[PRCA  CREATE TRA NS STUB]", DA=PRCAEN  D ^DIE
  10086   "RTN","PRC AWO1",88,0 )
  10087    W:'$G(PRC ANOPR) !,* 7," NOTHIN G CHANGED  !",!!
  10088   "RTN","PRC AWO1",89,0 )
  10089    S PRCAD(" DELETE")=" " K PRCANO PR,%,%DT,% X,%Y
  10090   "RTN","PRC AWO1",90,0 )
  10091    Q
  10092   "RTN","PRC AWO1",91,0 )
  10093    ;======== ========== ====SUBROU TINE LOCKF ========== ========== ========== ==
  10094   "RTN","PRC AWO1",92,0 )
  10095   LOCKF L @( "+"_DIC_DA _"):1") I  '$T W !,*7 ,"ANOTHER  USER IS ED ITING THIS  ENTRY , T RY LATER." ,! S PRCA( "LOCK")=1
  10096   "RTN","PRC AWO1",93,0 )
  10097    Q  ;end o f LOCKF
  10098   "RTN","PRC AWO1",94,0 )
  10099   END K PRCA ,PRCABN,PR CAEN,PRCAP REV,PRCATY PE,DIE,DIC ,PRCAMF,PR CACC,A Q
  10100   "RTN","PRC AWO1",95,0 )
  10101    ;
  10102   "RTN","PRC AWO1",96,0 )
  10103   ASKREV() ;  Ask if Tr easury rev ersal 315/ DRF
  10104   "RTN","PRC AWO1",97,0 )
  10105    N DIR,DIR UT,DTOUT,D UOUT,X,Y
  10106   "RTN","PRC AWO1",98,0 )
  10107    S DIR(0)= "YO",DIR(" B")="NO"
  10108   "RTN","PRC AWO1",99,0 )
  10109    S DIR("A" )="  Is th is a TREAS URY revers al "
  10110   "RTN","PRC AWO1",100, 0)
  10111    W ! D ^DI R
  10112   "RTN","PRC AWO1",101, 0)
  10113    I $G(DTOU T)!($G(DUO UT)) S Y=- 1 I $G(GOT BILL) S RC DPGQ=1     ; account  profile li stman quit  flag  *31 5
  10114   "RTN","PRC AWO1",102, 0)
  10115    Q Y
  10116   "RTN","PRC AWREA")
  10117   0^61^B2149 5612^B1093 3866
  10118   "RTN","PRC AWREA",1,0 )
  10119   PRCAWREA ; WASH-ISC@A LTOONA,PA/ TJK-RE-EST ABLISH BIL L ;7/24/96   2:35 PM
  10120   "RTN","PRC AWREA",2,0 )
  10121   V ;;4.5;Ac counts Rec eivable;** 16,49,153, 315**;Mar  20, 1995;B uild 55
  10122   "RTN","PRC AWREA",3,0 )
  10123    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  10124   "RTN","PRC AWREA",4,0 )
  10125    ;;Select  bill to ma ke active,  cancellat ion, suspe nded, coll /clos or w rite-off
  10126   "RTN","PRC AWREA",5,0 )
  10127    N DA,DIC, DIE,I,PRCA BN,PRCATAM T,PRCAEN,P RCA,PRCAWO ,PRCAPB,PR CATYPE,PRC ATY,X,Y,FM SNUM,FMSAM T,PRCASTAT
  10128   "RTN","PRC AWREA",6,0 )
  10129    D CKSITE^ PRCAUDT I  '$D(PRCA(" CKSITE"))  W !,"Your  site is no t defined. " G EXIT
  10130   "RTN","PRC AWREA",7,0 )
  10131    K DIC,DA  S PRCAWO=" ," F I=109 ,240,111,1 08 S PRCAW O=$G(PRCAW O)_$O(^PRC A(430.3,"A C",I,0))_" ,"
  10132   "RTN","PRC AWREA",8,0 )
  10133    I $G(PRCA WO)']"" W  !,"Transac tion Types  not defin ed, please  contact I RM." G EXI T
  10134   "RTN","PRC AWREA",9,0 )
  10135    S DIC("S" )="I $P(^( 0),U,2)'=2 6,"""_PRCA WO_"""[("" ,""_$P(^(0 ),U,8)_"", "")" D BIL LN^PRCAUTL  G:$G(PRCA BN)="" EXI T
  10136   "RTN","PRC AWREA",10, 0)
  10137    ;
  10138   "RTN","PRC AWREA",11, 0)
  10139   APJ ; Entr y point fr om the ENA P entry po int (below ) for the  Account Pr ofile scre en  *315
  10140   "RTN","PRC AWREA",12, 0)
  10141    ;
  10142   "RTN","PRC AWREA",13, 0)
  10143    L +^PRCA( 430,PRCABN ):1 I '$T  W !!,*7,"A NOTHER USE R IS EDITI NG THIS BI LL" G EXIT
  10144   "RTN","PRC AWREA",14, 0)
  10145    S PRCAPB= $G(^PRCA(4 30,PRCABN, 7)),PRCAST AT=$P(^PRC A(430,PRCA BN,0),U,8)
  10146   "RTN","PRC AWREA",15, 0)
  10147    S PRCATAM T=0 F I=1: 1:5 S PRCA TAMT=PRCAT AMT+$P(PRC APB,U,I)
  10148   "RTN","PRC AWREA",16, 0)
  10149    I PRCATAM T=0&('$$AC CK^PRCAACC (PRCABN))  D  G EXIT
  10150   "RTN","PRC AWREA",17, 0)
  10151     .W !!,*7 ,"A bill w ith ZERO d ollars CAN NOT BE RE- ESTABLISHE D."
  10152   "RTN","PRC AWREA",18, 0)
  10153     .W !!,"C reate a ne w bill."
  10154   "RTN","PRC AWREA",19, 0)
  10155     .L -^PRC A(430,PRCA BN)        ; *315 bug  fix - unl ock the bi ll before  exit
  10156   "RTN","PRC AWREA",20, 0)
  10157     .Q
  10158   "RTN","PRC AWREA",21, 0)
  10159    S FMSAMT= PRCATAMT
  10160   "RTN","PRC AWREA",22, 0)
  10161    I PRCATAM T=0 D AMT  I PRCATAMT '>0 W !!," Sorry, no  bill amoun t entered! " L -^PRCA (430,PRCAB N) G EXIT     ; *315  unlock bil l
  10162   "RTN","PRC AWREA",23, 0)
  10163    D SETTR^P RCAUTL,UPC ALM^PRCAWO ,PATTR^PRC AUTL
  10164   "RTN","PRC AWREA",24, 0)
  10165    S PRCATYP E=$S($P(^P RCA(430,PR CABN,0),"^ ",8)=$O(^P RCA(430.3, "AC",240,0 )):$O(^PRC A(430.3,"A C",18,0)), 1:$O(^PRCA (430.3,"AC ",250,0)))
  10166   "RTN","PRC AWREA",25, 0)
  10167    K DIC,DIE ,DR,DA S ( DIC,DIE)=" ^PRCA(433, ",DA=PRCAE N,DR="[PRC A RE-ESTAB LISH WRITE -OFF]" D ^ DIE K DIC, DA,DIE,DR
  10168   "RTN","PRC AWREA",26, 0)
  10169    S PRCA("S DT")=DT,PR CA("STATUS ")=$O(^PRC A(430.3,"A C",102,0))  D UPSTATS ^PRCAUT2
  10170   "RTN","PRC AWREA",27, 0)
  10171    S $P(^PRC A(433,PRCA EN,4,$O(^P RCA(433,PR CAEN,4,0)) ,0),U,5)=P RCATAMT
  10172   "RTN","PRC AWREA",28, 0)
  10173    S $P(^PRC A(433,PRCA EN,0),U,4) =2 L -^PRC A(430,PRCA BN)
  10174   "RTN","PRC AWREA",29, 0)
  10175    W !!,*7,? 5,$P(^PRCA (430,PRCAB N,0),U,1), " is in th e ",$P(^PR CA(430.3,$ P(^PRCA(43 0,PRCABN,0 ),U,8),0), U,1)," sta tus for $" ,$P(^PRCA( 433,PRCAEN ,1),U,5)
  10176   "RTN","PRC AWREA",30, 0)
  10177    I $P(^PRC A(430,PRCA BN,0),U,8) =$O(^PRCA( 430.3,"AC" ,102,""))  D PREPAY^R CBEPAYP(PR CABN)
  10178   "RTN","PRC AWREA",31, 0)
  10179    I FMSAMT> 0,PRCASTAT '=40,'$$AC CK^PRCAACC (PRCABN) D
  10180   "RTN","PRC AWREA",32, 0)
  10181     .S FMSNU M=$P($G(^P RCA(430,PR CABN,11)), U,22),MOD= 1
  10182   "RTN","PRC AWREA",33, 0)
  10183     .I FMSNU M="" S FMS NUM=$$ENUM ^RCMSNUM,M OD=0
  10184   "RTN","PRC AWREA",34, 0)
  10185     .D MODWR ^PRCAFWO(P RCABN,FMSA MT,FMSNUM, PRCAEN,MOD )
  10186   "RTN","PRC AWREA",35, 0)
  10187     .Q
  10188   "RTN","PRC AWREA",36, 0)
  10189   EXIT Q
  10190   "RTN","PRC AWREA",37, 0)
  10191   AMT ;
  10192   "RTN","PRC AWREA",38, 0)
  10193    ;;Ask for  amount to  be re-est ablished
  10194   "RTN","PRC AWREA",39, 0)
  10195    N Y
  10196   "RTN","PRC AWREA",40, 0)
  10197   AMTE R !!, "Enter Re- Establish  Amount: ", Y:DTIME I  '$T!(Y["^" ) S Y=0 G  AMTQ
  10198   "RTN","PRC AWREA",41, 0)
  10199    I Y="" W  !,*7,"The  amount is  required.   Enter ""^ "" to exit !",!
  10200   "RTN","PRC AWREA",42, 0)
  10201    I Y["?"!( Y'?.N.1"." .2N)!(Y>99 9999.99)!( Y<.01) D A MTH G AMTE
  10202   "RTN","PRC AWREA",43, 0)
  10203   AMTQ S PRC ATAMT=+Y I  Y>0 S PRC APB=PRCATA MT_"^^^^^" ,$P(^PRCA( 430,PRCABN ,7),U,1)=Y ,$P(^PRCA( 430,PRCABN ,2,$O(^PRC A(430,PRCA BN,2,0)),0 ),U,2)=PRC ATAMT
  10204   "RTN","PRC AWREA",44, 0)
  10205    Q
  10206   "RTN","PRC AWREA",45, 0)
  10207   AMTH W !," Enter in a n amount f rom .01 to  999999.99 , 2 decima l digits"
  10208   "RTN","PRC AWREA",46, 0)
  10209    W !!,"The  bill must  have an a mount inor der to be  re-establi shed."
  10210   "RTN","PRC AWREA",47, 0)
  10211    W !,"This  amount wi ll be the  principal  balance of  the bill. "
  10212   "RTN","PRC AWREA",48, 0)
  10213    Q
  10214   "RTN","PRC AWREA",49, 0)
  10215    ;
  10216   "RTN","PRC AWREA",50, 0)
  10217   ENAP(PRCAB N) ; Entry  point for  Re-Establ ish bill f rom the Ac count Prof ile screen  - *315
  10218   "RTN","PRC AWREA",51, 0)
  10219    ; origina lly called  from REES TAB^RCDPAP L1.  PRCAB N is the i nternal bi ll# and is  required.
  10220   "RTN","PRC AWREA",52, 0)
  10221    ;
  10222   "RTN","PRC AWREA",53, 0)
  10223    N PG,PRS, I,PRCAWO,P RCATY,PRCA ,PRCATAMT, PRCAEN,PRC APB,PRCATY PE,PRCASTA T,FMSNUM,F MSAMT,MOD
  10224   "RTN","PRC AWREA",54, 0)
  10225    N DA,DIC, DIE,DR,X,Y
  10226   "RTN","PRC AWREA",55, 0)
  10227    ;
  10228   "RTN","PRC AWREA",56, 0)
  10229    ; set oth er variabl es related  to the bi ll
  10230   "RTN","PRC AWREA",57, 0)
  10231    S PG=$G(^ PRCA(430,P RCABN,0))
  10232   "RTN","PRC AWREA",58, 0)
  10233    S PRCATY= $P(PG,U,2)                                        ; ar  category  ien
  10234   "RTN","PRC AWREA",59, 0)
  10235    S PRCA("S EG")=$S(+$ P(PG,U,21) >240:$P(PG ,U,21),1:" ")    ; se gment - us ed in the  input temp late
  10236   "RTN","PRC AWREA",60, 0)
  10237    S PRCA("S TATUS")=$P (PG,U,8)                               ; cu rrent stat us of the  bill
  10238   "RTN","PRC AWREA",61, 0)
  10239    S PRCA("A PPR")=$P(P G,U,18)                                ; ap propriatio n symbol
  10240   "RTN","PRC AWREA",62, 0)
  10241    ;
  10242   "RTN","PRC AWREA",63, 0)
  10243    ; get sit e stuff
  10244   "RTN","PRC AWREA",64, 0)
  10245    S PRS=+$P ($G(^RC(34 2,1,0)),U, 1)       ;  main AR s ite
  10246   "RTN","PRC AWREA",65, 0)
  10247    S PRCA("S ITE")=+$$G ET1^DIQ(4, PRS,99)  ;  station#
  10248   "RTN","PRC AWREA",66, 0)
  10249    I PRCA("S ITE") S PR CA("CKSITE ")=""    ;  station#  check flag
  10250   "RTN","PRC AWREA",67, 0)
  10251    ;
  10252   "RTN","PRC AWREA",68, 0)
  10253    ; build a  string of  valid int ernal stat us ien's ( WRITE-OFF,  SUSPENDED , CANCELLA TION, COLL ECTED/CLOS ED)
  10254   "RTN","PRC AWREA",69, 0)
  10255    S PRCAWO= "," F I=10 9,240,111, 108 S PRCA WO=PRCAWO_ $O(^PRCA(4 30.3,"AC", I,0))_","
  10256   "RTN","PRC AWREA",70, 0)
  10257    I '$F(PRC AWO,","_PR CA("STATUS ")_",") D   G ENAPX
  10258   "RTN","PRC AWREA",71, 0)
  10259    . W !,"Th e Re-Estab lish actio n is not a vailable f or this bi ll because  the curre nt"
  10260   "RTN","PRC AWREA",72, 0)
  10261    . W !,"AR  status of  this bill  is "_$$GE T1^DIQ(430 ,PRCABN,8) _"."
  10262   "RTN","PRC AWREA",73, 0)
  10263    . W !,"Va lid status es are WRI TE-OFF, SU SPENDED, C ANCELLATIO N, or COLL ECTED/CLOS ED."
  10264   "RTN","PRC AWREA",74, 0)
  10265    . Q
  10266   "RTN","PRC AWREA",75, 0)
  10267    ;
  10268   "RTN","PRC AWREA",76, 0)
  10269    I PRCATY= 26 D  G EN APX
  10270   "RTN","PRC AWREA",77, 0)
  10271    . W !,"Th e Re-Estab lish actio n is not a vailable f or this bi ll because  the curre nt"
  10272   "RTN","PRC AWREA",78, 0)
  10273    . W !,"AR  category  of this bi ll is "_$$ GET1^DIQ(4 30,PRCABN, 2)_".  Thi s is the o nly one no t allowed. "
  10274   "RTN","PRC AWREA",79, 0)
  10275    . Q
  10276   "RTN","PRC AWREA",80, 0)
  10277    ;
  10278   "RTN","PRC AWREA",81, 0)
  10279    G APJ        ; jump  into the r outine at  the proper  point
  10280   "RTN","PRC AWREA",82, 0)
  10281    ;
  10282   "RTN","PRC AWREA",83, 0)
  10283   ENAPX ;
  10284   "RTN","PRC AWREA",84, 0)
  10285    Q
  10286   "RTN","PRC AWREA",85, 0)
  10287    ;
  10288   "RTN","PRC AXP")
  10289   0^1^B23941 725^B12869 783
  10290   "RTN","PRC AXP",1,0)
  10291   PRCAXP ;WA SH-ISC@ALT OONA,PA/TJ K-PRINT RX -COPAY EXE MPTION REP ORT ;10/23 /93  10:01  AM
  10292   "RTN","PRC AXP",2,0)
  10293   V ;;4.5;Ac counts Rec eivable;** 315**;Mar  20, 1995;B uild 55
  10294   "RTN","PRC AXP",3,0)
  10295    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  10296   "RTN","PRC AXP",4,0)
  10297    NEW BEG,E ND,%DT,%ZI S,IOP,POP, Y,%
  10298   "RTN","PRC AXP",5,0)
  10299   BEG W ! D  NOW^%DTC S  %DT(0)=-% ,%DT="AEXP ",%DT("A") ="Start Da te: " D ^% DT G:Y<0 Q  S BEG=Y
  10300   "RTN","PRC AXP",6,0)
  10301    S %DT="AE X",%DT("A" )="     En d Date: ", %DT("B")=" T" D ^%DT  G:Y<0 Q S  END=Y
  10302   "RTN","PRC AXP",7,0)
  10303    W !!,"You  will need  a 132 col umn printe r for this  report!", !
  10304   "RTN","PRC AXP",8,0)
  10305    W ! K IO( "Q") S %ZI S="MQ" D ^ %ZIS G:POP  Q
  10306   "RTN","PRC AXP",9,0)
  10307    I $D(IO(" Q")) S ZTR TN="DQ^PRC AXP",ZTSAV E("BEG")=" ",ZTSAVE(" END")="" D  ^%ZTLOAD  G Q
  10308   "RTN","PRC AXP",10,0)
  10309    U IO
  10310   "RTN","PRC AXP",11,0)
  10311   DQ ;ENTRY  POINT FROM  TASK MANA GER FOR PR INTING REP ORT
  10312   "RTN","PRC AXP",12,0)
  10313    NEW Y,TOD AY,PG,I,PR CA,PRCAHDR ,BEGPR,END PR,TRDATE, TRNO,T0,T1 ,BILL,TRAM T,OUT,PTNM ,DFN,CONTI NUE
  10314   "RTN","PRC AXP",13,0)
  10315    NEW ID,RE C,TTYPE,VA ,PTOT,PGTO T,TOT,LAST ,BLNO,EFDT ,DTH
  10316   "RTN","PRC AXP",14,0)
  10317   COMPUTE ;S ETS TEMPOR ARY GLOBAL  FOR PRINT ING
  10318   "RTN","PRC AXP",15,0)
  10319    K ^TMP($J ) S TRDATE =BEG-1,(TO T("D"),TOT ("E"),TOT( "I"))=0,U= "^"
  10320   "RTN","PRC AXP",16,0)
  10321    F  S TRDA TE=$O(^PRC A(433,"ACE ",TRDATE))  G PRINT:' TRDATE!($P (TRDATE,". ")>END) S  TRNO=0 D
  10322   "RTN","PRC AXP",17,0)
  10323    .F  S TRN O=$O(^PRCA (433,"ACE" ,TRDATE,TR NO)) Q:'TR NO  D
  10324   "RTN","PRC AXP",18,0)
  10325    ..S T0=$G (^PRCA(433 ,TRNO,0)), T1=$G(^(1) ) Q:T0=""
  10326   "RTN","PRC AXP",19,0)
  10327    ..S BLNO= $P(T0,U,2) ,TRAMT=$P( T1,U,5),TT YPE=$S($P( T1,U,2)=35 :"D",$P(T1 ,U,2)=1:"I ",1:"E"),E FDT=$P(T1, U,1)  ;*31 5 START
  10328   "RTN","PRC AXP",20,0)
  10329    ..;S DFN= $P(^PRCA(4 30,BLNO,0) ,U,9),BILL =$P(^(0),U )
  10330   "RTN","PRC AXP",21,0)
  10331    ..S P0=$G (^PRCA(430 ,BLNO,0)), DFN=$P(P0, U,9),BILL= $P(P0,U),I BN=0
  10332   "RTN","PRC AXP",22,0)
  10333    ..S DFN=$ P(^RCD(340 ,+DFN,0),U ) Q:'DFN!( DFN'["DPT( ")  S DFN= +DFN
  10334   "RTN","PRC AXP",23,0)
  10335    ..D DEM^V ADPT S PTN M=VADM(1), ID=$E(PTNM ,1)_VA("BI D") S DTH= $S(+VADM(6 ):"*",1:"" ) D KVAR^V ADPT
  10336   "RTN","PRC AXP",24,0)
  10337    ..D FNDBI L(TRNO,TTY PE)
  10338   "RTN","PRC AXP",25,0)
  10339   PRINT ;PRI NT REPORT
  10340   "RTN","PRC AXP",26,0)
  10341    S LAST=""
  10342   "RTN","PRC AXP",27,0)
  10343    S Y=BEG X  ^DD("DD")  S BEGPR=Y
  10344   "RTN","PRC AXP",28,0)
  10345    S Y=END X  ^DD("DD")  S ENDPR=Y
  10346   "RTN","PRC AXP",29,0)
  10347    S Y=DT X  ^DD("DD")  S TODAY=Y, PG=0 D HEA D
  10348   "RTN","PRC AXP",30,0)
  10349    I '$D(^TM P($J)) W ! !,"NO EXEM PTIONS FOR  THIS TIME  PERIOD" G  Q
  10350   "RTN","PRC AXP",31,0)
  10351    S PTNM=""  F  S PTNM =$O(^TMP($ J,PTNM)) Q :PTNM=""!( $D(OUT))   D
  10352   "RTN","PRC AXP",32,0)
  10353    .S DFN=0  F  S DFN=$ O(^TMP($J, PTNM,DFN))  Q:'DFN!($ D(OUT))  S  CONTINUE= "",PTOT=0  D  I PTOT  W !,?115," ---------- ---",!,?11 5,$J(+PTOT ,13,2),!
  10354   "RTN","PRC AXP",33,0)
  10355    ..S BILL= "" F  S BI LL=$O(^TMP ($J,PTNM,D FN,BILL))  Q:BILL=""! ($D(OUT))   D
  10356   "RTN","PRC AXP",34,0)
  10357    ...S TRNO =0 F  S TR NO=$O(^TMP ($J,PTNM,D FN,BILL,TR NO)) Q:TRN O=""!($D(O UT))  D    ;*315 STAR T
  10358   "RTN","PRC AXP",35,0)
  10359    ....S CON TINUE=""
  10360   "RTN","PRC AXP",36,0)
  10361    ....S RX= 0 F  S RX= $O(^TMP($J ,PTNM,DFN, BILL,TRNO, RX)) Q:'RX !($D(OUT))   D
  10362   "RTN","PRC AXP",37,0)
  10363    .....S RE C=^TMP($J, PTNM,DFN,B ILL,TRNO,R X),TRAMT=$ P(REC,U,1)  W ! W:$D( CONTINUE)  $P(REC,"^" ,4),$E(PTN M,1,25),"  ",?28,$P(R EC,U,2),?3 5,BILL,?48 ,TRNO,?56, $P(REC,U,3 )
  10364   "RTN","PRC AXP",38,0)
  10365    .....W ?6 0,$S(RX=1: "",1:$P(RE C,U,5)) W  ?70,$E($P( REC,U,6),1 ,17),?90,$ P(REC,U,7) ,?100,$P(R EC,U,8) I  $D(CONTINU E),TRNO'=L AST W ?115 ,$J(TRAMT, 13,2)
  10366   "RTN","PRC AXP",39,0)
  10367    .....I $D (CONTINUE) ,TRNO'=LAS T S PTOT=P TOT+TRAMT, PGTOT=+$G( PGTOT)+TRA MT,TOT($S( $P(REC,U,3 )]"":$P(RE C,U,3),1:" UNK"))=$G( TOT($S($P( REC,U,3)]" ":$P(REC,U ,3),1:"UNK ")))+REC   ;*315 END
  10368   "RTN","PRC AXP",40,0)
  10369    .....K CO NTINUE S L AST=TRNO D  HEAD:($Y+ 4)>IOSL
  10370   "RTN","PRC AXP",41,0)
  10371    G:$D(OUT)  Q
  10372   "RTN","PRC AXP",42,0)
  10373    W !,"* -i ndicates p atient is  deceased"
  10374   "RTN","PRC AXP",43,0)
  10375    D HEAD:($ Y+7)>IOSL
  10376   "RTN","PRC AXP",44,0)
  10377    W !!,"EXE MPTION TYP ES AND TOT ALS"
  10378   "RTN","PRC AXP",45,0)
  10379    W !!,"D=D ECREASE AD JUSTMENT " ,?35,$J(TO T("D"),13, 2),!,"E=IN TEREST/ADM IN EXEMPTI ON ",?35,$ J(TOT("E") ,13,2),!," I=INCREASE  ADJUSTMEN T FOR REFU ND ",?35,$ J(TOT("I") ,13,2)
  10380   "RTN","PRC AXP",46,0)
  10381    I $D(TOT( "UNK")) W  !,"UNK=EXE MPTION TYP E UNKNOWN" ,?35,$J(TO T("UNK"),1 3,2)
  10382   "RTN","PRC AXP",47,0)
  10383    W !,?35," ---------- ---",!,?35 ,$J(PGTOT, 13,2)
  10384   "RTN","PRC AXP",48,0)
  10385    K BEG,END ,IO("Q") ; K ^TMP($J)  
  10386   "RTN","PRC AXP",49,0)
  10387   Q D ^%ZISC  Q
  10388   "RTN","PRC AXP",50,0)
  10389    ;
  10390   "RTN","PRC AXP",51,0)
  10391   FNDBIL(TRN O,TTYPE) ;
  10392   "RTN","PRC AXP",52,0)
  10393    N FOUND,C NT,IBN,IB0 ,RR,RX,DRU G,FLDT,EDT ,EFFDT,IBA MT,IBAS,AR TRN
  10394   "RTN","PRC AXP",53,0)
  10395    S (IBN,FO UND,CNT,RX )=0,EDT=""
  10396   "RTN","PRC AXP",54,0)
  10397    F  S IBN= $O(^IB("AB IL",BILL,I BN)) Q:IBN =""  D
  10398   "RTN","PRC AXP",55,0)
  10399    .S IB0=^I B(IBN,0),R R=$P(IB0,U ,4),EDT=$P (IB0,U,17) ,IBAMT=$P( IB0,U,7),A RTRN=$P(IB 0,U,12)
  10400   "RTN","PRC AXP",56,0)
  10401    .I EDT=""  S EDT=EFD T
  10402   "RTN","PRC AXP",57,0)
  10403    .I EDT=""  S EDT=TRD ATE
  10404   "RTN","PRC AXP",58,0)
  10405    .I ARTRN= TRNO S FOU ND=1 D DAT A Q
  10406   "RTN","PRC AXP",59,0)
  10407    .I 'FOUND ,ARTRN=""  D DATA
  10408   "RTN","PRC AXP",60,0)
  10409    I CNT=0,R X=0 D
  10410   "RTN","PRC AXP",61,0)
  10411    .I EDT=""  S EDT=EFD T
  10412   "RTN","PRC AXP",62,0)
  10413    .I EDT=""  S EDT=TRD ATE
  10414   "RTN","PRC AXP",63,0)
  10415    .S EFFDT= $$FMTE^XLF DT(EDT,"2D Z")
  10416   "RTN","PRC AXP",64,0)
  10417    .D SET(1)
  10418   "RTN","PRC AXP",65,0)
  10419    Q
  10420   "RTN","PRC AXP",66,0)
  10421    ;
  10422   "RTN","PRC AXP",67,0)
  10423   DATA ; SET  UP DATA
  10424   "RTN","PRC AXP",68,0)
  10425    N RIEN,RF L
  10426   "RTN","PRC AXP",69,0)
  10427    S CNT=CNT +1
  10428   "RTN","PRC AXP",70,0)
  10429    S RIEN=+$ P(RR,"52:" ,2),RFL=+$ P(RR,":",3 )
  10430   "RTN","PRC AXP",71,0)
  10431    S DRUG=$P ($$GET1^PS ODI(52,RIE N,6,"E"),U ,2)
  10432   "RTN","PRC AXP",72,0)
  10433    S RX=$P($ $GET1^PSOD I(52,RIEN, .01,"E"),U ,2)
  10434   "RTN","PRC AXP",73,0)
  10435    I RFL>0 S  FLDT=$P($ $GET1^PSOD I(52.1,RFL _","_RIEN, .01,"I"),U ,2)
  10436   "RTN","PRC AXP",74,0)
  10437    I RFL=0 S  FLDT=$P($ $GET1^PSOD I(52,RIEN, 22,"I"),U, 2)
  10438   "RTN","PRC AXP",75,0)
  10439    S EFFDT=$ $FMTE^XLFD T(EDT,"2DZ "),FLDT=$$ FMTE^XLFDT (FLDT,"2DZ ")
  10440   "RTN","PRC AXP",76,0)
  10441    I $D(^TMP ($J,PTNM,D FN,BILL,TR NO,RX)) Q
  10442   "RTN","PRC AXP",77,0)
  10443    D SET(RX)
  10444   "RTN","PRC AXP",78,0)
  10445    Q
  10446   "RTN","PRC AXP",79,0)
  10447    ;
  10448   "RTN","PRC AXP",80,0)
  10449   SET(RX) ;
  10450   "RTN","PRC AXP",81,0)
  10451    S ^TMP($J ,PTNM,DFN, BILL,TRNO, RX)=TRAMT_ U_ID_U_TTY PE_U_DTH_U _$G(RX)_U_ $G(DRUG)_U _$G(FLDT)_ U_$G(EFFDT )_U_$G(ART RN)_U_$G(I BAS)_U_$G( IBN)  ;*31 5 END
  10452   "RTN","PRC AXP",82,0)
  10453    Q
  10454   "RTN","PRC AXP",83,0)
  10455    ;
  10456   "RTN","PRC AXP",84,0)
  10457   HEAD ;PRIN TS HEADING
  10458   "RTN","PRC AXP",85,0)
  10459    I PG,$E(I OST,1,2)[" C-" D SCR  Q:$D(OUT)
  10460   "RTN","PRC AXP",86,0)
  10461    W @IOF S  PG=PG+1
  10462   "RTN","PRC AXP",87,0)
  10463    W !!,"Pg.  "_PG,?130 -$L(TODAY) ,TODAY
  10464   "RTN","PRC AXP",88,0)
  10465    S PRCAHDR ="MEDICATI ON CO-PAY  EXEMPTION  REPORT",PR CA="",$P(P RCA,"*",(1 30-$L(PRCA HDR))\2)=" *",PRCAHDR =PRCA_" "_ PRCAHDR_"  "_PRCA
  10466   "RTN","PRC AXP",89,0)
  10467    W !,PRCAH DR,!,?53,B EGPR,"-",E NDPR
  10468   "RTN","PRC AXP",90,0)
  10469    W !,?35," BILL",?48, "TRAN.",?5 6,"EXP",?9 0,"FILL/", ?100,"EFFE CTIVE"  ;* 315 START
  10470   "RTN","PRC AXP",91,0)
  10471    W !,"PATI ENT",?28," ID",?35,"N UMBER",?48 ,"NUMBER", ?56,"TYP", ?60,"RX",? 70,"DRUG N AME",?90," REFL DT",? 102,"DATE" ,?120,"AMO UNT"  ;*31 5 END
  10472   "RTN","PRC AXP",92,0)
  10473    S PRCA="" ,$P(PRCA," -",132)=""  W !,PRCA
  10474   "RTN","PRC AXP",93,0)
  10475    S CONTINU E=""
  10476   "RTN","PRC AXP",94,0)
  10477    Q
  10478   "RTN","PRC AXP",95,0)
  10479    ;
  10480   "RTN","PRC AXP",96,0)
  10481   SCR ;
  10482   "RTN","PRC AXP",97,0)
  10483    Q:$E(IOST ,1,2)'["C- "
  10484   "RTN","PRC AXP",98,0)
  10485    N DIR,YY, DIRUT,DUOU T,DTOUT,DI ROUT,X,Y
  10486   "RTN","PRC AXP",99,0)
  10487    F YY=$Y:1 :(IOSL-2)  W !
  10488   "RTN","PRC AXP",100,0 )
  10489    S DIR(0)= "E" D ^DIR  I $D(DIRU T)!($D(DTO UT)) S OUT =1
  10490   "RTN","PRC AXP",101,0 )
  10491    Q
  10492   "RTN","RCB EADJ")
  10493   0^26^B1009 02419^B771 25147
  10494   "RTN","RCB EADJ",1,0)
  10495   RCBEADJ ;W ISC/RFJ-ad justment ; Jun 06, 20 14@19:11:1 9
  10496   "RTN","RCB EADJ",2,0)
  10497    ;;4.5;Acc ounts Rece ivable;**1 69,172,204 ,173,208,2 33,298,301 ,315**;Mar  20, 1995; Build 55
  10498   "RTN","RCB EADJ",3,0)
  10499    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  10500   "RTN","RCB EADJ",4,0)
  10501    Q
  10502   "RTN","RCB EADJ",5,0)
  10503    ;
  10504   "RTN","RCB EADJ",6,0)
  10505    ;
  10506   "RTN","RCB EADJ",7,0)
  10507   DECREASE ;   menu opt ion: creat e a decrea se adjustm ent
  10508   "RTN","RCB EADJ",8,0)
  10509    D ADJUST( "DECREASE" )
  10510   "RTN","RCB EADJ",9,0)
  10511    Q
  10512   "RTN","RCB EADJ",10,0 )
  10513    ;
  10514   "RTN","RCB EADJ",11,0 )
  10515    ;
  10516   "RTN","RCB EADJ",12,0 )
  10517   INCREASE ;   menu opt ion: creat e an incre ase adjust ment
  10518   "RTN","RCB EADJ",13,0 )
  10519    D ADJUST( "INCREASE" )
  10520   "RTN","RCB EADJ",14,0 )
  10521    Q
  10522   "RTN","RCB EADJ",15,0 )
  10523    ;
  10524   "RTN","RCB EADJ",16,0 )
  10525   ADJUST(RCB ETYPE,RCED I) ;  crea te an adju stment
  10526   "RTN","RCB EADJ",17,0 )
  10527    ;  rcbety pe = INCRE ASE for in crease or  DECREASE f or decreas e
  10528   "RTN","RCB EADJ",18,0 )
  10529    ;  rcedi  = the ien  of the bil l selected  via the E DI Worklis t;ien of 
  10530   "RTN","RCB EADJ",19,0 )
  10531    ;    XX       the ER A entry or  null/unde fined if b ill should  be select ed
  10532   "RTN","RCB EADJ",20,0 )
  10533    I '$G(GOT BILL) N RC BILLDA  ;P RCA*4.5*31 5 If enter ing from w orklist
  10534   "RTN","RCB EADJ",21,0 )
  10535    F  D  Q:R CBILLDA<0! $G(RCEDI)! $G(GOTBILL )
  10536   "RTN","RCB EADJ",22,0 )
  10537    .   K RCT RANDA,RCLI ST,RCTRREV
  10538   "RTN","RCB EADJ",23,0 )
  10539    .   ;
  10540   "RTN","RCB EADJ",24,0 )
  10541    .   ;  se lect a bil l
  10542   "RTN","RCB EADJ",25,0 )
  10543    .   I '$G (GOTBILL)  S RCBILLDA =$S('$G(RC EDI):$$GET ABILL^RCBE UBIL,1:+RC EDI)  ;PRC A*4.5*315
  10544   "RTN","RCB EADJ",26,0 )
  10545    .   I RCB ILLDA<1 Q
  10546   "RTN","RCB EADJ",27,0 )
  10547    .   I $D( ^PRCA(430, "TCSP",RCB ILLDA)),(R CBETYPE="I NCREASE")  D  ;PRCA*4 .5*315/DRF
  10548   "RTN","RCB EADJ",28,0 )
  10549    ..    S R CTRREV=$$A SKREV()
  10550   "RTN","RCB EADJ",29,0 )
  10551    ..    W !
  10552   "RTN","RCB EADJ",30,0 )
  10553    .   I $D( ^PRCA(430, "TCSP",RCB ILLDA)),(R CBETYPE="D ECREASE")  S %=$$ASKC M Q:(%'=1)      ; prc a*4.5*301  & *315
  10554   "RTN","RCB EADJ",31,0 )
  10555    .   ;
  10556   "RTN","RCB EADJ",32,0 )
  10557    .   ;  ad just the b ill
  10558   "RTN","RCB EADJ",33,0 )
  10559    .   D ADJ BILL(RCBET YPE,RCBILL DA,$P($G(R CEDI),";", 2))
  10560   "RTN","RCB EADJ",34,0 )
  10561    Q
  10562   "RTN","RCB EADJ",35,0 )
  10563    ;
  10564   "RTN","RCB EADJ",36,0 )
  10565   ADJBILL(RC BETYPE,RCB ILLDA,RCED IWL) ;  ad just a bil l
  10566   "RTN","RCB EADJ",37,0 )
  10567    ; RCEDIWL  = ien of  ERA entry  if called  from workl ist
  10568   "RTN","RCB EADJ",38,0 )
  10569    N RCAMOUN T,RCBALANC ,RCDATA7,R CLIST,RCON TADJ,RCTRA NDA,TOTALC AL,TOTALST O,I,X,Y
  10570   "RTN","RCB EADJ",39,0 )
  10571    ;  lock t he bill
  10572   "RTN","RCB EADJ",40,0 )
  10573    L +^PRCA( 430,RCBILL DA):5 E  W  !,"ANOTHE R USER IS  CURRENTLY  WORKING WI TH THIS BI LL." Q
  10574   "RTN","RCB EADJ",41,0 )
  10575    ;
  10576   "RTN","RCB EADJ",42,0 )
  10577    ;  show d ata for th e bill
  10578   "RTN","RCB EADJ",43,0 )
  10579    D SHOWBIL L^RCWROFF1 (RCBILLDA)
  10580   "RTN","RCB EADJ",44,0 )
  10581    ;
  10582   "RTN","RCB EADJ",45,0 )
  10583    ;  check  the balanc e of the b ill
  10584   "RTN","RCB EADJ",46,0 )
  10585    W !!,"Che cking the  bill's bal ance ..."
  10586   "RTN","RCB EADJ",47,0 )
  10587    S RCBALAN C=$$OUTOFB AL^RCBDBBA L(RCBILLDA )
  10588   "RTN","RCB EADJ",48,0 )
  10589    I RCBALAN C="" W " I N Balance! "
  10590   "RTN","RCB EADJ",49,0 )
  10591    ;
  10592   "RTN","RCB EADJ",50,0 )
  10593    ;  out of  balance,  ask to fix  it
  10594   "RTN","RCB EADJ",51,0 )
  10595    I RCBALAN C'="" D  I  RCBILLDA< 1 D UNLOCK  Q
  10596   "RTN","RCB EADJ",52,0 )
  10597    .   S TOT ALCAL=$P(R CBALANC,"^ ")+$P(RCBA LANC,"^",2 )+$P(RCBAL ANC,"^",3) +$P(RCBALA NC,"^",4)+ $P(RCBALAN C,"^",5)
  10598   "RTN","RCB EADJ",53,0 )
  10599    .   S RCD ATA7=$G(^P RCA(430,RC BILLDA,7))
  10600   "RTN","RCB EADJ",54,0 )
  10601    .   S TOT ALSTO=$P(R CDATA7,"^" )+$P(RCDAT A7,"^",2)+ $P(RCDATA7 ,"^",3)+$P (RCDATA7," ^",4)+$P(R CDATA7,"^" ,5)
  10602   "RTN","RCB EADJ",55,0 )
  10603    .   W " O UT of Bala nce!"
  10604   "RTN","RCB EADJ",56,0 )
  10605    .   W !!, "                   B ALANCE:",$ J("Calcula ted",12),$ J("Stored" ,12)
  10606   "RTN","RCB EADJ",57,0 )
  10607    .   W !,"                    -- ----- ",$J ("-------- ----",12), $J("------ ------",12 )
  10608   "RTN","RCB EADJ",58,0 )
  10609    .   W !,"         Pr incipal Ba lance:",$J ($P(RCBALA NC,"^",1), 12,2),$J($ P(RCDATA7, "^",1),12, 2)
  10610   "RTN","RCB EADJ",59,0 )
  10611    .   I +$P (RCBALANC, "^",1)'=+$ P(RCDATA7, "^",1) W "   <<-- OUT  OF BALANC E"
  10612   "RTN","RCB EADJ",60,0 )
  10613    .   W !,"          I nterest Ba lance:",$J ($P(RCBALA NC,"^",2), 12,2),$J($ P(RCDATA7, "^",2),12, 2)
  10614   "RTN","RCB EADJ",61,0 )
  10615    .   I +$P (RCBALANC, "^",2)'=+$ P(RCDATA7, "^",2) W "   <<-- OUT  OF BALANC E"
  10616   "RTN","RCB EADJ",62,0 )
  10617    .   W !,"              Admin Ba lance:",$J ($P(RCBALA NC,"^",3), 12,2),$J($ P(RCDATA7, "^",3),12, 2)
  10618   "RTN","RCB EADJ",63,0 )
  10619    .   I +$P (RCBALANC, "^",3)'=+$ P(RCDATA7, "^",3) W "   <<-- OUT  OF BALANC E"
  10620   "RTN","RCB EADJ",64,0 )
  10621    .   W !,"                 MF Ba lance:",$J ($P(RCBALA NC,"^",4), 12,2),$J($ P(RCDATA7, "^",4),12, 2)
  10622   "RTN","RCB EADJ",65,0 )
  10623    .   I +$P (RCBALANC, "^",4)'=+$ P(RCDATA7, "^",4) W "   <<-- OUT  OF BALANC E"
  10624   "RTN","RCB EADJ",66,0 )
  10625    .   W !,"                 CC Ba lance:",$J ($P(RCBALA NC,"^",5), 12,2),$J($ P(RCDATA7, "^",5),12, 2)
  10626   "RTN","RCB EADJ",67,0 )
  10627    .   I +$P (RCBALANC, "^",5)'=+$ P(RCDATA7, "^",5) W "   <<-- OUT  OF BALANC E"
  10628   "RTN","RCB EADJ",68,0 )
  10629    .   W !,"                    -- ----- ",$J ("-------- -----",12) ,$J("----- --------", 12)
  10630   "RTN","RCB EADJ",69,0 )
  10631    .   W !,"                       TOTAL:",$J (TOTALCAL, 12,2),$J(T OTALSTO,12 ,2)
  10632   "RTN","RCB EADJ",70,0 )
  10633    .   I +TO TALCAL'=+T OTALSTO W  "  <<-- OU T OF BALAN CE"
  10634   "RTN","RCB EADJ",71,0 )
  10635    .   ;
  10636   "RTN","RCB EADJ",72,0 )
  10637    .   ;  as k to fix t he balance s
  10638   "RTN","RCB EADJ",73,0 )
  10639    .   S Y=$ $ASKFIX I  Y'=1 W !,"   NOTE: Yo u must fix  the Balan ce Discrep ancy befor e processi ng an adju stment!" S  RCBILLDA= 0 Q
  10640   "RTN","RCB EADJ",74,0 )
  10641    .   ;
  10642   "RTN","RCB EADJ",75,0 )
  10643    .   ;  fi x it
  10644   "RTN","RCB EADJ",76,0 )
  10645    .   S $P( RCDATA7,"^ ",1)=+$P(R CBALANC,"^ ",1) ; pri ncipal
  10646   "RTN","RCB EADJ",77,0 )
  10647    .   S $P( RCDATA7,"^ ",2)=+$P(R CBALANC,"^ ",2) ; int erest
  10648   "RTN","RCB EADJ",78,0 )
  10649    .   S $P( RCDATA7,"^ ",3)=+$P(R CBALANC,"^ ",3) ; adm in
  10650   "RTN","RCB EADJ",79,0 )
  10651    .   S $P( RCDATA7,"^ ",4)=+$P(R CBALANC,"^ ",4) ; mar shal fee
  10652   "RTN","RCB EADJ",80,0 )
  10653    .   S $P( RCDATA7,"^ ",5)=+$P(R CBALANC,"^ ",5) ; cou rt cost
  10654   "RTN","RCB EADJ",81,0 )
  10655    .   S $P( ^PRCA(430, RCBILLDA,7 ),"^",1,5) =$P(RCDATA 7,"^",1,5)
  10656   "RTN","RCB EADJ",82,0 )
  10657    .   ;
  10658   "RTN","RCB EADJ",83,0 )
  10659    .   W !,"   Balance  Discrepanc y FIXED!"
  10660   "RTN","RCB EADJ",84,0 )
  10661    ;
  10662   "RTN","RCB EADJ",85,0 )
  10663    ;  if the  principal  balance i s zero, do  not allow  it to be  adjusted
  10664   "RTN","RCB EADJ",86,0 )
  10665    ;  ask to  close/can cel it
  10666   "RTN","RCB EADJ",87,0 )
  10667    I RCBETYP E="DECREAS E",'$G(^PR CA(430,RCB ILLDA,7))  W !!,"Note : This bil l has NO P RINCIPAL B ALANCE to  decrease ! " D INTADM IN(RCBILLD A),UNLOCK  Q
  10668   "RTN","RCB EADJ",88,0 )
  10669    ;
  10670   "RTN","RCB EADJ",89,0 )
  10671    ; If entr y is from  EDI Lockbo x worklist , display  total adju stments in  ERA
  10672   "RTN","RCB EADJ",90,0 )
  10673    N AP D
  10674   "RTN","RCB EADJ",91,0 )
  10675    .N BILL,E OB,ERA,SEQ  S ERA="", AP=0
  10676   "RTN","RCB EADJ",92,0 )
  10677    .F  S ERA =$O(^RCY(3 44.4,"AP", 1,ERA)) Q: 'ERA  D  Q :AP
  10678   "RTN","RCB EADJ",93,0 )
  10679    ..S SEQ=0
  10680   "RTN","RCB EADJ",94,0 )
  10681    ..F  S SE Q=$O(^RCY( 344.4,"AP" ,1,ERA,SEQ )) Q:'SEQ   D  Q:AP
  10682   "RTN","RCB EADJ",95,0 )
  10683    ...S EOB= $P($G(^RCY (344.4,ERA ,1,SEQ,0)) ,U,2) Q:'E OB
  10684   "RTN","RCB EADJ",96,0 )
  10685    ...S:$P($ G(^IBM(361 .1,EOB,0)) ,U)=RCBILL DA AP=1 ;I A #4051
  10686   "RTN","RCB EADJ",97,0 )
  10687    ;
  10688   "RTN","RCB EADJ",98,0 )
  10689    ;  Ask to  enter tra nsaction e ven though  it is mar ked for au topost PRC A*4.5*298
  10690   "RTN","RCB EADJ",99,0 )
  10691    I RCBETYP E="DECREAS E",AP S Y= $$ASKAUPO( ) I Y'=1 W  !,"Exitin g bill adj ustment."  D UNLOCK Q
  10692   "RTN","RCB EADJ",100, 0)
  10693    ;
  10694   "RTN","RCB EADJ",101, 0)
  10695    ;  ask to  enter adj ustment am ount
  10696   "RTN","RCB EADJ",102, 0)
  10697    S RCAMOUN T=$$AMOUNT (RCBILLDA, RCBETYPE)
  10698   "RTN","RCB EADJ",103, 0)
  10699    I RCAMOUN T<0 D UNLO CK Q
  10700   "RTN","RCB EADJ",104, 0)
  10701    ;
  10702   "RTN","RCB EADJ",105, 0)
  10703    ;  if dec rease, mak e negative
  10704   "RTN","RCB EADJ",106, 0)
  10705    I RCBETYP E="DECREAS E" S RCAMO UNT=-RCAMO UNT
  10706   "RTN","RCB EADJ",107, 0)
  10707    ;
  10708   "RTN","RCB EADJ",108, 0)
  10709    ;  ask if  it is a c ontract ad justment ( 45,46,47 a dded PRCA* 4.5*315)/D RF)
  10710   "RTN","RCB EADJ",109, 0)
  10711    I RCBETYP E="DECREAS E","^9^28^ 29^30^32^4 5^46^47^"[ ("^"_$P($G (^PRCA(430 ,RCBILLDA, 0)),"^",2) _"^") S RC ONTADJ=$$A SKCONT I R CONTADJ<0  D UNLOCK Q
  10712   "RTN","RCB EADJ",110, 0)
  10713    ;
  10714   "RTN","RCB EADJ",111, 0)
  10715    ;  show w hat the ne w transact ion will l ook like
  10716   "RTN","RCB EADJ",112, 0)
  10717    S RCDATA7 =$G(^PRCA( 430,RCBILL DA,7))
  10718   "RTN","RCB EADJ",113, 0)
  10719    W !!,"If  you proces s the tran saction, t he bill wi ll look li ke:"
  10720   "RTN","RCB EADJ",114, 0)
  10721    W !,"Curr ent Princi pal Balanc e: ",$J($P (RCDATA7," ^"),11,2)
  10722   "RTN","RCB EADJ",115, 0)
  10723    W !,"  NE W ",RCBETY PE," Adjus tment: ",$ J(RCAMOUNT ,11,2)
  10724   "RTN","RCB EADJ",116, 0)
  10725    W !,"                              ------- ----"
  10726   "RTN","RCB EADJ",117, 0)
  10727    W !,"     NEW Princi pal Balanc e: ",$J($P (RCDATA7," ^")+RCAMOU NT,11,2)
  10728   "RTN","RCB EADJ",118, 0)
  10729    ;
  10730   "RTN","RCB EADJ",119, 0)
  10731    ;  ask to  enter tra nsaction
  10732   "RTN","RCB EADJ",120, 0)
  10733    S Y=$$ASK OK(RCBETYP E) I Y'=1  D UNLOCK Q
  10734   "RTN","RCB EADJ",121, 0)
  10735    ;
  10736   "RTN","RCB EADJ",122, 0)
  10737   ADDADJ ;   add adjust ment
  10738   "RTN","RCB EADJ",123, 0)
  10739    S RCTRAND A=$$INCDEC ^RCBEUTR1( RCBILLDA,R CAMOUNT,"" ,"","",$G( RCONTADJ))
  10740   "RTN","RCB EADJ",124, 0)
  10741    I 'RCTRAN DA W !,"   *** W A R  N I N G: A djustment  NOT Proces sed! ***"  D UNLOCK Q
  10742   "RTN","RCB EADJ",125, 0)
  10743    I RCTRAND A W !,"  A djustment  Transactio n: ",RCTRA NDA," has  been added ."
  10744   "RTN","RCB EADJ",126, 0)
  10745    I RCTRAND A,'$G(RCED IWL),(RCBE TYPE="DECR EASE"),$D( ^PRCA(430, "TCSP",RCB ILLDA)) D  DECADJ^RCT CSPU(RCBIL LDA,RCTRAN DA) ;prca* 4.5*301 ad d cs decre ase adjust ment
  10746   "RTN","RCB EADJ",127, 0)
  10747    I RCTRAND A,$G(RCTRR EV)=0 S PR CABN=RCBIL LDA D CSIT RN^RCTCSPD 5
  10748   "RTN","RCB EADJ",128, 0)
  10749    I RCTRAND A,$G(RCTRR EV)=0,'$G( RCEDIWL),( RCBETYPE=" INCREASE") ,$D(^PRCA( 430,"TCSP" ,RCBILLDA) ) S PRCABN =RCBILLDA  D INCADJ^R CTCSPU(RCB ILLDA,RCTR ANDA) ;PRC A*4.5*315/ DRF add cs  increase  adjustment
  10750   "RTN","RCB EADJ",129, 0)
  10751    I $G(RCTR REV)=1 S P RCABN=RCBI LLDA D CSI TRY^RCTCSP D5
  10752   "RTN","RCB EADJ",130, 0)
  10753    I '$G(REF MS)&(DT>$$ LDATE^RCRJ R(DT)) S Y =$E($$FPS^ RCAMFN01(D T,1),1,5)_ "01" D DD^ %DT W !!,"    * * * *  Transmiss ion will b e held unt il "_Y_" *  * * *"
  10754   "RTN","RCB EADJ",131, 0)
  10755    ;
  10756   "RTN","RCB EADJ",132, 0)
  10757    ;  ask to  enter a c omment
  10758   "RTN","RCB EADJ",133, 0)
  10759    W !!,"Ent er a comme nt for the  ",RCBETYP E," Adjust ment:"
  10760   "RTN","RCB EADJ",134, 0)
  10761    S Y=$$EDI T433^RCBEU TRA(RCTRAN DA,"41;")
  10762   "RTN","RCB EADJ",135, 0)
  10763    ;
  10764   "RTN","RCB EADJ",136, 0)
  10765    ;  ask to  exempt in terest and  admin cha rges
  10766   "RTN","RCB EADJ",137, 0)
  10767    I RCBETYP E="DECREAS E" D INTAD MIN(RCBILL DA)
  10768   "RTN","RCB EADJ",138, 0)
  10769    ;
  10770   "RTN","RCB EADJ",139, 0)
  10771    ;  notifi cation of  subsequent  payer bul letin
  10772   "RTN","RCB EADJ",140, 0)
  10773    S RCDATA7 =$G(^PRCA( 430,RCBILL DA,7)),X=0
  10774   "RTN","RCB EADJ",141, 0)
  10775    F I=1:1:5  S X=X+$P( RCDATA7,"^ ",I)
  10776   "RTN","RCB EADJ",142, 0)
  10777    I RCDATA7 '="",'X D
  10778   "RTN","RCB EADJ",143, 0)
  10779    .   N PRC ABN,PRCAEN ,PRCAMT
  10780   "RTN","RCB EADJ",144, 0)
  10781    .   S PRC ABN=RCBILL DA,PRCAEN= RCTRANDA,P RCAMT=+$P( $G(^PRCA(4 33,RCTRAND A,1)),"^", 5)
  10782   "RTN","RCB EADJ",145, 0)
  10783    .   D EOB ^PRCADJ
  10784   "RTN","RCB EADJ",146, 0)
  10785    ;
  10786   "RTN","RCB EADJ",147, 0)
  10787    ;  unlock  and ask t he next bi ll to adju st
  10788   "RTN","RCB EADJ",148, 0)
  10789    D UNLOCK
  10790   "RTN","RCB EADJ",149, 0)
  10791    Q
  10792   "RTN","RCB EADJ",150, 0)
  10793    ;
  10794   "RTN","RCB EADJ",151, 0)
  10795    ;
  10796   "RTN","RCB EADJ",152, 0)
  10797   UNLOCK ;   unlock bil l and tran saction
  10798   "RTN","RCB EADJ",153, 0)
  10799    L -^PRCA( 430,RCBILL DA)
  10800   "RTN","RCB EADJ",154, 0)
  10801    I $G(RCTR ANDA) L -^ PRCA(433,R CTRANDA)
  10802   "RTN","RCB EADJ",155, 0)
  10803    Q
  10804   "RTN","RCB EADJ",156, 0)
  10805    ;
  10806   "RTN","RCB EADJ",157, 0)
  10807    ;
  10808   "RTN","RCB EADJ",158, 0)
  10809   INTADMIN(R CBILLDA) ;   ask and  adjust the  interest  and admin
  10810   "RTN","RCB EADJ",159, 0)
  10811    N RCAMOUN T,RCTRANDA ,Y
  10812   "RTN","RCB EADJ",160, 0)
  10813    ;
  10814   "RTN","RCB EADJ",161, 0)
  10815    ;  check  to see if  there is i nterest an d admin ch arges
  10816   "RTN","RCB EADJ",162, 0)
  10817    S RCAMOUN T=$G(^PRCA (430,RCBIL LDA,7))
  10818   "RTN","RCB EADJ",163, 0)
  10819    I '$P(RCA MOUNT,"^", 2),'$P(RCA MOUNT,"^", 3),'$P(RCA MOUNT,"^", 4),'$P(RCA MOUNT,"^", 5) Q
  10820   "RTN","RCB EADJ",164, 0)
  10821    ;
  10822   "RTN","RCB EADJ",165, 0)
  10823    ;  only a sk if ther e is no pr incipal
  10824   "RTN","RCB EADJ",166, 0)
  10825    I RCAMOUN T Q
  10826   "RTN","RCB EADJ",167, 0)
  10827    ;
  10828   "RTN","RCB EADJ",168, 0)
  10829    W !!,"You  have the  option to  automatica lly EXEMPT  the inter est"
  10830   "RTN","RCB EADJ",169, 0)
  10831    W !,"and  administra tive charg es.  This  will close  the bill. "
  10832   "RTN","RCB EADJ",170, 0)
  10833    S Y=$$ASK EXEMP I Y' =1 Q
  10834   "RTN","RCB EADJ",171, 0)
  10835    ;
  10836   "RTN","RCB EADJ",172, 0)
  10837    W !!,"Cre ating an E XEMPT tran saction .. ."
  10838   "RTN","RCB EADJ",173, 0)
  10839    S RCTRAND A=$$EXEMPT ^RCBEUTR2( RCBILLDA,$ P(RCAMOUNT ,"^",2)_"^ "_$P(RCAMO UNT,"^",3) _"^^"_$P(R CAMOUNT,"^ ",4)_"^"_$ P(RCAMOUNT ,"^",5))
  10840   "RTN","RCB EADJ",174, 0)
  10841    I 'RCTRAN DA W !,"   *** W A R  N I N G: E XEMPTION N OT Process ed! ***" Q
  10842   "RTN","RCB EADJ",175, 0)
  10843    I RCTRAND A W !,"    Exempt Tra nsaction:  ",RCTRANDA ," has bee n added."
  10844   "RTN","RCB EADJ",176, 0)
  10845   INTC35B ;C heck if CS 5B entry n eeded for  exempt tra nsaction
  10846   "RTN","RCB EADJ",177, 0)
  10847    I RCTRAND A,'$G(RCED IWL),(RCBE TYPE="DECR EASE"),$D( ^PRCA(430, "TCSP",RCB ILLDA)) D  DECADJ^RCT CSPU(RCBIL LDA,RCTRAN DA) ;prca* 4.5*301 ad d cs exemp t
  10848   "RTN","RCB EADJ",178, 0)
  10849    I '$G(REF MS)&(DT>$$ LDATE^RCRJ R(DT)) S Y =$E($$FPS^ RCAMFN01(D T,1),1,5)_ "01" D DD^ %DT W !!,"    * * * *  Transmiss ion will b e held unt il "_Y_" *  * * *"
  10850   "RTN","RCB EADJ",179, 0)
  10851    ;
  10852   "RTN","RCB EADJ",180, 0)
  10853    W !,"  Cu rrent Bill  Status: " ,$P($G(^PR CA(430.3,+ $P($G(^PRC A(430,RCBI LLDA,0))," ^",8),0)), "^")
  10854   "RTN","RCB EADJ",181, 0)
  10855    Q
  10856   "RTN","RCB EADJ",182, 0)
  10857    ;
  10858   "RTN","RCB EADJ",183, 0)
  10859   ASKOK(RCBE TYPE) ;  a sk record  decrease o r increase  transacti on
  10860   "RTN","RCB EADJ",184, 0)
  10861    N DIR,DIQ 2,DIRUT,DT OUT,DUOUT, X,Y
  10862   "RTN","RCB EADJ",185, 0)
  10863    S DIR(0)= "YO",DIR(" B")="YES"
  10864   "RTN","RCB EADJ",186, 0)
  10865    S DIR("A" )="Are you  sure you  want to en ter this " _RCBETYPE_ " adjustme nt "
  10866   "RTN","RCB EADJ",187, 0)
  10867    W ! D ^DI R
  10868   "RTN","RCB EADJ",188, 0)
  10869    I $G(DTOU T)!($G(DUO UT)) S Y=- 1 I $G(GOT BILL) S RC DPGQ=1     ; account  profile li stman quit  flag  *31 5
  10870   "RTN","RCB EADJ",189, 0)
  10871    Q Y
  10872   "RTN","RCB EADJ",190, 0)
  10873    ;
  10874   "RTN","RCB EADJ",191, 0)
  10875   ASKAUPO()  ;  ask rec ord even t hough mark ed for aut o post PRC A*4.5*298
  10876   "RTN","RCB EADJ",192, 0)
  10877    N DIR,DIQ 2,DIRUT,DT OUT,DUOUT, X,Y
  10878   "RTN","RCB EADJ",193, 0)
  10879    S DIR(0)= "YOA",DIR( "B")="NO"
  10880   "RTN","RCB EADJ",194, 0)
  10881    S DIR("A" )="Marked  for Auto-P ost. Are y ou sure? ( Y/N) "
  10882   "RTN","RCB EADJ",195, 0)
  10883    W ! D ^DI R
  10884   "RTN","RCB EADJ",196, 0)
  10885    I $G(DTOU T)!($G(DUO UT)) S Y=- 1 I $G(GOT BILL) S RC DPGQ=1     ; account  profile li stman quit  flag  *31 5
  10886   "RTN","RCB EADJ",197, 0)
  10887    Q Y
  10888   "RTN","RCB EADJ",198, 0)
  10889    ;
  10890   "RTN","RCB EADJ",199, 0)
  10891   ASKFIX() ;   ask to f ix bill's  balance
  10892   "RTN","RCB EADJ",200, 0)
  10893    N DIR,DIQ 2,DIRUT,DT OUT,DUOUT, X,Y
  10894   "RTN","RCB EADJ",201, 0)
  10895    S DIR(0)= "YO",DIR(" B")="YES"
  10896   "RTN","RCB EADJ",202, 0)
  10897    S DIR("A" )="  Do yo u want to  FIX the ba lance disc repancy "
  10898   "RTN","RCB EADJ",203, 0)
  10899    W ! D ^DI R
  10900   "RTN","RCB EADJ",204, 0)
  10901    I $G(DTOU T)!($G(DUO UT)) S Y=- 1 I $G(GOT BILL) S RC DPGQ=1     ; account  profile li stman quit  flag  *31 5
  10902   "RTN","RCB EADJ",205, 0)
  10903    Q Y
  10904   "RTN","RCB EADJ",206, 0)
  10905    ;
  10906   "RTN","RCB EADJ",207, 0)
  10907    ;
  10908   "RTN","RCB EADJ",208, 0)
  10909   ASKEXEMP()  ;  ask to  record an  exempt tr ansaction
  10910   "RTN","RCB EADJ",209, 0)
  10911    N DIR,DIQ 2,DIRUT,DT OUT,DUOUT, X,Y
  10912   "RTN","RCB EADJ",210, 0)
  10913    S DIR(0)= "YO",DIR(" B")="NO"
  10914   "RTN","RCB EADJ",211, 0)
  10915    S DIR("A" )="  Would  you like  to EXEMPT  the intere st and adm in charges  "
  10916   "RTN","RCB EADJ",212, 0)
  10917    D ^DIR
  10918   "RTN","RCB EADJ",213, 0)
  10919    I $G(DTOU T)!($G(DUO UT)) S Y=- 1 I $G(GOT BILL) S RC DPGQ=1     ; account  profile li stman quit  flag  *31 5
  10920   "RTN","RCB EADJ",214, 0)
  10921    Q Y
  10922   "RTN","RCB EADJ",215, 0)
  10923    ;
  10924   "RTN","RCB EADJ",216, 0)
  10925    ;
  10926   "RTN","RCB EADJ",217, 0)
  10927   ASKCONT()  ;  ask if  contract a djustment
  10928   "RTN","RCB EADJ",218, 0)
  10929    N DIR,DIQ 2,DIRUT,DT OUT,DUOUT, X,Y
  10930   "RTN","RCB EADJ",219, 0)
  10931    S DIR(0)= "YO",DIR(" B")="YES"
  10932   "RTN","RCB EADJ",220, 0)
  10933    S DIR("A" )="  Is th is a CONTR ACT adjust ment "
  10934   "RTN","RCB EADJ",221, 0)
  10935    W ! D ^DI R
  10936   "RTN","RCB EADJ",222, 0)
  10937    I $G(DTOU T)!($G(DUO UT)) S Y=- 1 I $G(GOT BILL) S RC DPGQ=1     ; account  profile li stman quit  flag  *31 5
  10938   "RTN","RCB EADJ",223, 0)
  10939    Q Y
  10940   "RTN","RCB EADJ",224, 0)
  10941    ;
  10942   "RTN","RCB EADJ",225, 0)
  10943    ;
  10944   "RTN","RCB EADJ",226, 0)
  10945   ASKREV() ;  Ask if Tr easury rev ersal *315 /DRF
  10946   "RTN","RCB EADJ",227, 0)
  10947    N DIR,DIQ 2,DIRUT,DT OUT,DUOUT, X,Y
  10948   "RTN","RCB EADJ",228, 0)
  10949    S DIR(0)= "YO",DIR(" B")="NO"
  10950   "RTN","RCB EADJ",229, 0)
  10951    S DIR("A" )="  Is th is a TREAS URY revers al "
  10952   "RTN","RCB EADJ",230, 0)
  10953    W ! D ^DI R
  10954   "RTN","RCB EADJ",231, 0)
  10955    I $G(DTOU T)!($G(DUO UT)) S Y=- 1 I $G(GOT BILL) S RC DPGQ=1     ; account  profile li stman quit  flag  *31 5
  10956   "RTN","RCB EADJ",232, 0)
  10957    Q Y
  10958   "RTN","RCB EADJ",233, 0)
  10959    ;
  10960   "RTN","RCB EADJ",234, 0)
  10961    ;
  10962   "RTN","RCB EADJ",235, 0)
  10963   ADJNUM(RCB ILLDA) ;   get next a djustment  number for  a bill
  10964   "RTN","RCB EADJ",236, 0)
  10965    N %,ADJUS T,DATA1,RC TRANDA
  10966   "RTN","RCB EADJ",237, 0)
  10967    S RCTRAND A=0
  10968   "RTN","RCB EADJ",238, 0)
  10969    F  S RCTR ANDA=$O(^P RCA(433,"C ",RCBILLDA ,RCTRANDA) ) Q:'RCTRA NDA  S DAT A1=$G(^PRC A(433,RCTR ANDA,1)) I  $P(DATA1, "^",4),$P( DATA1,"^", 2)=1!($P(D ATA1,"^",2 )=35) S AD JUST=$P(DA TA1,"^",4) +1
  10970   "RTN","RCB EADJ",239, 0)
  10971    Q ADJUST
  10972   "RTN","RCB EADJ",240, 0)
  10973    ;
  10974   "RTN","RCB EADJ",241, 0)
  10975    ;
  10976   "RTN","RCB EADJ",242, 0)
  10977   AMOUNT(RCB ILLDA,RCBE TYPE) ;  e nter the a djustment  amount for  a bill
  10978   "RTN","RCB EADJ",243, 0)
  10979    N DIR,DIR UT,DTOUT,D UOUT,PRINB AL,X,Y
  10980   "RTN","RCB EADJ",244, 0)
  10981    S PRINBAL =+$P($G(^P RCA(430,RC BILLDA,7)) ,"^")
  10982   "RTN","RCB EADJ",245, 0)
  10983    I RCBETYP E="INCREAS E" S PRINB AL=9999999 .99
  10984   "RTN","RCB EADJ",246, 0)
  10985    W !!,"Ent er the ",R CBETYPE,"  Adjustment  AMOUNT, f rom .01 to  ",$J(PRIN BAL,0,2)," ."
  10986   "RTN","RCB EADJ",247, 0)
  10987    S DIR(0)= "NAO^.01:" _PRINBAL_" :2"
  10988   "RTN","RCB EADJ",248, 0)
  10989    S DIR("A" )="  "_RCB ETYPE_" PR INCIPAL BA LANCE BY:  "
  10990   "RTN","RCB EADJ",249, 0)
  10991    D ^DIR
  10992   "RTN","RCB EADJ",250, 0)
  10993    I $G(DTOU T)!($G(DUO UT)) S Y=- 1 I $G(GOT BILL) S RC DPGQ=1     ; account  profile li stman quit  flag  *31 5
  10994   "RTN","RCB EADJ",251, 0)
  10995    Q $S(Y'=" ":Y,1:-1)
  10996   "RTN","RCB EADJ",252, 0)
  10997    ;
  10998   "RTN","RCB EADJ",253, 0)
  10999   ASKCM() ;   ask if th e action i s being pe rformed du e to the c laims matc hing proce ss  *315
  11000   "RTN","RCB EADJ",254, 0)
  11001    N DIR,DIQ 2,DIRUT,DT OUT,DUOUT, X,Y
  11002   "RTN","RCB EADJ",255, 0)
  11003    S DIR(0)= "YO",DIR(" B")="NO"
  11004   "RTN","RCB EADJ",256, 0)
  11005    S DIR("A" )="Is this  action be ing perfor med due to  the CLAIM S MATCHING  process "
  11006   "RTN","RCB EADJ",257, 0)
  11007    D ^DIR
  11008   "RTN","RCB EADJ",258, 0)
  11009    I $G(DTOU T)!($G(DUO UT)) S Y=- 1 I $G(GOT BILL) S RC DPGQ=1     ; account  profile li stman quit  flag  *31 5
  11010   "RTN","RCB EADJ",259, 0)
  11011    Q Y
  11012   "RTN","RCB EADJ",260, 0)
  11013    ;
  11014   "RTN","RCB EPAYF")
  11015   0^57^B4920 6897^B4914 2931
  11016   "RTN","RCB EPAYF",1,0 )
  11017   RCBEPAYF ; WISC/RFJ-f irst party  payment p rocessing( called by  rcbepay) ; 1 Jun 00
  11018   "RTN","RCB EPAYF",2,0 )
  11019    ;;4.5;Acc ounts Rece ivable;**1 53,301,322 ,315**;Mar  20, 1995; Build 55
  11020   "RTN","RCB EPAYF",3,0 )
  11021    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  11022   "RTN","RCB EPAYF",4,0 )
  11023    Q
  11024   "RTN","RCB EPAYF",5,0 )
  11025    ;
  11026   "RTN","RCB EPAYF",6,0 )
  11027    ;PRCA*4.5 *322 Awake n commente d line to  post payem nt to
  11028   "RTN","RCB EPAYF",7,0 )
  11029    ;              impli ed bill# f or receipt  payment
  11030   "RTN","RCB EPAYF",8,0 )
  11031    ;
  11032   "RTN","RCB EPAYF",9,0 )
  11033   FIRSTPTY()  ;  apply  payment to  first par ty account
  11034   "RTN","RCB EPAYF",10, 0)
  11035    ;  called  by rcbepa y
  11036   "RTN","RCB EPAYF",11, 0)
  11037    N PAYMENT ,RCBILBAL, RCBILLDA,R CDATE,RCDE BTDA,RCERR OR,RCREPAM T,RCSTATUS ,RCTRANDA, X,CSBILL,C SBILLDA,CS DEP,IDX,PR EV
  11038   "RTN","RCB EPAYF",12, 0)
  11039    K ^TMP("R CBEPAY",$J )
  11040   "RTN","RCB EPAYF",13, 0)
  11041    ; acc't l ookup info   BB prca* 4.5*301
  11042   "RTN","RCB EPAYF",14, 0)
  11043    S CSBILLD A=+$E($P(R CDATA,"^", 7),22,99), CSDEP=$P(R CDATA,"^", 19),CSBILL =$E($P(RCD ATA,"^",7) ,1,3)_"-"_ $E($P(RCDA TA,"^",7), 4,10)
  11044   "RTN","RCB EPAYF",15, 0)
  11045    I 'CSDEP  S CSDEP=16 9     ;Def ault for m issing pay  type
  11046   "RTN","RCB EPAYF",16, 0)
  11047    I $E($G(C SDEP),1,3) =170 S CSB ILLDA=$O(^ PRCA(430," B",CSBILL, 0))
  11048   "RTN","RCB EPAYF",17, 0)
  11049    I RCDATA[ "PRCA(430, " S CSBILL DA=+$P(RCD ATA,"^",3)
  11050   "RTN","RCB EPAYF",18, 0)
  11051    I CSDEP>1 67,CSDEP<1 71 S RCBET YPE=CSDEP
  11052   "RTN","RCB EPAYF",19, 0)
  11053    ;end PRCA *4.5*301
  11054   "RTN","RCB EPAYF",20, 0)
  11055    ;
  11056   "RTN","RCB EPAYF",21, 0)
  11057    ;  look u p account  in debtor  file
  11058   "RTN","RCB EPAYF",22, 0)
  11059    S RCDEBTD A=$$DEBT^R CEVUTL(RCA CCT)
  11060   "RTN","RCB EPAYF",23, 0)
  11061    I RCDEBTD A<0 Q "1^C ould not a dd Patient  ("_RCACCT _") to deb tor file"
  11062   "RTN","RCB EPAYF",24, 0)
  11063    ;
  11064   "RTN","RCB EPAYF",25, 0)
  11065    ;  lock t he debtor  account
  11066   "RTN","RCB EPAYF",26, 0)
  11067    L +^RCD(3 40,RCDEBTD A):20 I '$ T Q "1^Ano ther user  is working  with this  patient a ccount"
  11068   "RTN","RCB EPAYF",27, 0)
  11069    ;
  11070   "RTN","RCB EPAYF",28, 0)
  11071    ;  build  list of ac tive(16) a nd open(42 ) bills fo r patient
  11072   "RTN","RCB EPAYF",29, 0)
  11073    ;  sorted  by date b ill prepar ed
  11074   "RTN","RCB EPAYF",30, 0)
  11075    F RCSTATU S=16,42 S  RCBILLDA=0  F  S RCBI LLDA=$O(^P RCA(430,"A S",RCDEBTD A,RCSTATUS ,RCBILLDA) ) Q:'RCBIL LDA  D
  11076   "RTN","RCB EPAYF",31, 0)
  11077    .   ;  ch eck bill f or prepaym ent
  11078   "RTN","RCB EPAYF",32, 0)
  11079    .   I $P( ^PRCA(430, RCBILLDA,0 ),"^",2)=2 6 Q  ; ACC OUNTS RECE IVABLE CAT EGORY (PRE PAYMENT=26 )
  11080   "RTN","RCB EPAYF",33, 0)
  11081    .   ;
  11082   "RTN","RCB EPAYF",34, 0)
  11083    .   ;  ch ecks if pa yment was  via a "170 " CS Treas ury lockbo x transact ion ; prca *4.5*301
  11084   "RTN","RCB EPAYF",35, 0)
  11085    .   ;     Ignores bi ll if bill  is NOT a  "TCSP" CS  bill
  11086   "RTN","RCB EPAYF",36, 0)
  11087    .   ;     else sets  as FIRST i f designat ed as bill  to be app lied, or s ubsequent  in oldest  date order
  11088   "RTN","RCB EPAYF",37, 0)
  11089    .   I CSD EP=170 D   Q  ; prca* 4.5*301
  11090   "RTN","RCB EPAYF",38, 0)
  11091    .   .  I  $D(^PRCA(4 30,"TCSP", RCBILLDA))  D  Q  ;
  11092   "RTN","RCB EPAYF",39, 0)
  11093    .   .  .  I CSBILLDA =RCBILLDA  S ^TMP("RC BEPAY",$J, 0,RCBILLDA )="" Q
  11094   "RTN","RCB EPAYF",40, 0)
  11095    .   .  .  S ^TMP("RC BEPAY",$J, 880000000+ $P($G(^PRC A(430,RCBI LLDA,0))," ^",10),RCB ILLDA)=""
  11096   "RTN","RCB EPAYF",41, 0)
  11097    .   .  S  ^TMP("RCBE PAY",$J,99 0000000+$P ($G(^PRCA( 430,RCBILL DA,0)),"^" ,10),RCBIL LDA)=""
  11098   "RTN","RCB EPAYF",42, 0)
  11099    .   I $E( $G(CSDEP), 1,3)'=168, $D(^PRCA(4 30,"TCSP", RCBILLDA))  Q   ;BB p rca*4.5*30 1
  11100   "RTN","RCB EPAYF",43, 0)
  11101    .   I CSB ILLDA=RCBI LLDA S ^TM P("RCBEPAY ",$J,0,RCB ILLDA)=""  Q   ;PRCA* 4.5*322
  11102   "RTN","RCB EPAYF",44, 0)
  11103    .   S ^TM P("RCBEPAY ",$J,+$P($ G(^PRCA(43 0,RCBILLDA ,0)),"^",1 0),RCBILLD A)=""
  11104   "RTN","RCB EPAYF",45, 0)
  11105   PROC ;
  11106   "RTN","RCB EPAYF",46, 0)
  11107    ;  loop a ll the bil ls for a p atients ac count and  keep loopi ng them
  11108   "RTN","RCB EPAYF",47, 0)
  11109    ;  until  either the re is no m ore bills  or the mon ey paid is  zero.
  11110   "RTN","RCB EPAYF",48, 0)
  11111    ;  the bi lls are lo oped in ca se of repa yments.  i f there is  money
  11112   "RTN","RCB EPAYF",49, 0)
  11113    ;  left o ver, this  will apply  more mone y to the r epayment b ills
  11114   "RTN","RCB EPAYF",50, 0)
  11115    ;  instea d of creat ing a prep ayment.  a  prepaymen t should o nly be
  11116   "RTN","RCB EPAYF",51, 0)
  11117    ;  create d if all b ills for t he account  is collec ted/closed .
  11118   "RTN","RCB EPAYF",52, 0)
  11119    S RCERROR =0
  11120   "RTN","RCB EPAYF",53, 0)
  11121    ;  quit t he loop if  no money  left to ap ply OR an  error occu rred OR
  11122   "RTN","RCB EPAYF",54, 0)
  11123    ;  no mor e bills le ft to appl y payment  to
  11124   "RTN","RCB EPAYF",55, 0)
  11125    F  D  I ' RCPAYAMT!( RCERROR)!( $O(^TMP("R CBEPAY",$J ,""))="")  Q
  11126   "RTN","RCB EPAYF",56, 0)
  11127    .   ;  lo op the bil ls by date  prepared  and apply  the paymen t
  11128   "RTN","RCB EPAYF",57, 0)
  11129    .   ;  qu it if no m oney left  to apply O R and erro r occurred
  11130   "RTN","RCB EPAYF",58, 0)
  11131    .   S RCD ATE="" F   S RCDATE=$ O(^TMP("RC BEPAY",$J, RCDATE)) Q :RCDATE=""   D  I 'RC PAYAMT!(RC ERROR) Q
  11132   "RTN","RCB EPAYF",59, 0)
  11133    .   .   S  RCBILLDA= 0 F  S RCB ILLDA=$O(^ TMP("RCBEP AY",$J,RCD ATE,RCBILL DA)) Q:'RC BILLDA  D   I 'RCPAYA MT!(RCERRO R) Q
  11134   "RTN","RCB EPAYF",60, 0)
  11135    .   .   .    L +^PRC A(430,RCBI LLDA):10
  11136   "RTN","RCB EPAYF",61, 0)
  11137    .   .   .    I '$T S  RCERROR=" 1^Another  user is wo rking with  bill "_$P (^PRCA(430 ,RCBILLDA, 0),"^") Q
  11138   "RTN","RCB EPAYF",62, 0)
  11139    .   .   .    ;
  11140   "RTN","RCB EPAYF",63, 0)
  11141    .   .   .    ;  exem pt any int erest/admi n/penalty  charges ad ded on or  after
  11142   "RTN","RCB EPAYF",64, 0)
  11143    .   .   .    ;  the  payment da te
  11144   "RTN","RCB EPAYF",65, 0)
  11145    .   .   .    D EXEMP T^RCBECHGE (RCBILLDA, RCPAYDAT)
  11146   "RTN","RCB EPAYF",66, 0)
  11147    .   .   .    ;
  11148   "RTN","RCB EPAYF",67, 0)
  11149    .   .   .    ;  get  the repaym ent amount  (if any)
  11150   "RTN","RCB EPAYF",68, 0)
  11151    .   .   .    S RCREP AMT=$P($G( ^PRCA(430, RCBILLDA,4 )),"^",3)  I CSDEP=16 8!(CSDEP=1 70) S RCRE PAMT=0   ; PRCA*4.5*3 01
  11152   "RTN","RCB EPAYF",69, 0)
  11153    .   .   .    ;
  11154   "RTN","RCB EPAYF",70, 0)
  11155    .   .   .    ;  get  the balanc e of the b ill
  11156   "RTN","RCB EPAYF",71, 0)
  11157    .   .   .    S X=$G( ^PRCA(430, RCBILLDA,7 ))
  11158   "RTN","RCB EPAYF",72, 0)
  11159    .   .   .    S RCBIL BAL=$P(X," ^")+$P(X," ^",2)+$P(X ,"^",3)+$P (X,"^",4)+ $P(X,"^",5 )
  11160   "RTN","RCB EPAYF",73, 0)
  11161    .   .   .    ;  if b ill has no  balance,  chg status  = collect ed/closed
  11162   "RTN","RCB EPAYF",74, 0)
  11163    .   .   .    I 'RCBI LBAL D  Q     ;PRCA*4 .5*301
  11164   "RTN","RCB EPAYF",75, 0)
  11165    .   .   .    . D CHG STAT^RCBEU BIL(RCBILL DA,22)
  11166   "RTN","RCB EPAYF",76, 0)
  11167    .   .   .    . L -^P RCA(430,RC BILLDA)
  11168   "RTN","RCB EPAYF",77, 0)
  11169    .   .   .    . K ^TM P("RCBEPAY ",$J,RCDAT E,RCBILLDA )
  11170   "RTN","RCB EPAYF",78, 0)
  11171    .   .   .    ;
  11172   "RTN","RCB EPAYF",79, 0)
  11173    .   .   .    ;  dete rmine amou nt to pay
  11174   "RTN","RCB EPAYF",80, 0)
  11175    .   .   .    ;  if t he payment  is greate r than bil led amount , pay bill ed amount
  11176   "RTN","RCB EPAYF",81, 0)
  11177    .   .   .    ;  if t here is a  repayment  amount, pa y the repa yment amou nt
  11178   "RTN","RCB EPAYF",82, 0)
  11179    .   .   .    ;  do n ot allow p ayment to  exceed amo unt paid
  11180   "RTN","RCB EPAYF",83, 0)
  11181    .   .   .    S PAYME NT=RCPAYAM T
  11182   "RTN","RCB EPAYF",84, 0)
  11183    .   .   .    I PAYME NT>RCBILBA L S PAYMEN T=RCBILBAL
  11184   "RTN","RCB EPAYF",85, 0)
  11185    .   .   .    I RCREP AMT S PAYM ENT=RCREPA MT I PAYME NT>RCBILBA L S PAYMEN T=RCBILBAL
  11186   "RTN","RCB EPAYF",86, 0)
  11187    .   .   .    I PAYME NT>RCPAYAM T S PAYMEN T=RCPAYAMT
  11188   "RTN","RCB EPAYF",87, 0)
  11189    .   .   .    ;
  11190   "RTN","RCB EPAYF",88, 0)
  11191    .   .   .    ;  appl y payment  to bill
  11192   "RTN","RCB EPAYF",89, 0)
  11193    .   .   .    ;  retu rn error i f problem  adding pay ment trans action
  11194   "RTN","RCB EPAYF",90, 0)
  11195    .   .   .    S RCTRA NDA=$$PAYT RAN^RCBEPA Y1(RCBILLD A,PAYMENT, RCRECTDA,R CPAYDA,RCP AYDAT)
  11196   "RTN","RCB EPAYF",91, 0)
  11197    .   .   .    I 'RCTR ANDA L -^P RCA(430,RC BILLDA) S  RCERROR="1 ^"_$P(RCTR ANDA,"^",2 ) Q
  11198   "RTN","RCB EPAYF",92, 0)
  11199    .   .   .    ;
  11200   "RTN","RCB EPAYF",93, 0)
  11201    .   .   .    ;  paym ent applie d to bill,  subtract  off the pa yment amou nt
  11202   "RTN","RCB EPAYF",94, 0)
  11203    .   .   .    S RCPAY AMT=RCPAYA MT-$P($G(^ PRCA(433,R CTRANDA,1) ),"^",5)
  11204   "RTN","RCB EPAYF",95, 0)
  11205    .   .   .    ;
  11206   "RTN","RCB EPAYF",96, 0)
  11207    .   .   .    ;  set  the amount  processed  on the re ceipt paym ent
  11208   "RTN","RCB EPAYF",97, 0)
  11209    .   .   .    D SETAM T^RCBEPAY( RCRECTDA,R CPAYDA,$P( $G(^PRCA(4 33,RCTRAND A,1)),"^", 5))
  11210   "RTN","RCB EPAYF",98, 0)
  11211    .   .   .    ;
  11212   "RTN","RCB EPAYF",99, 0)
  11213    .   .   .    ;  if B ill is Cro ss-Service d, then cr eate DECRE ASED ADJUS TMENT for  5B reporti ng
  11214   "RTN","RCB EPAYF",100 ,0)
  11215    .   .   .    I $E($G (CSDEP),1, 3)=168,$D( ^PRCA(430, "TCSP",RCB ILLDA)) D  CS5B(RCBIL LDA) ; BB  prca*4.5*3 01
  11216   "RTN","RCB EPAYF",101 ,0)
  11217    .   .   .    I $E($G (CSDEP),1, 3)=170,RCB ILLDA'=CSB ILLDA,$D(^ PRCA(430," TCSP",RCBI LLDA)) D C S5B(RCBILL DA) ; BB p rca*4.5*30 1
  11218   "RTN","RCB EPAYF",102 ,0)
  11219    .   .   .    ;
  11220   "RTN","RCB EPAYF",103 ,0)
  11221    .   .   .    ;  get  the new ba lance of t he bill.   if it is z ero
  11222   "RTN","RCB EPAYF",104 ,0)
  11223    .   .   .    ;  remo ve it from  the tmp g lobal (thi s will sto p the
  11224   "RTN","RCB EPAYF",105 ,0)
  11225    .   .   .    ;  loop  if dollar s are left  and no bi lls are ac tive)
  11226   "RTN","RCB EPAYF",106 ,0)
  11227    .   .   .    S X=$G( ^PRCA(430, RCBILLDA,7 ))
  11228   "RTN","RCB EPAYF",107 ,0)
  11229    .   .   .    S RCBIL BAL=$P(X," ^")+$P(X," ^",2)+$P(X ,"^",3)+$P (X,"^",4)+ $P(X,"^",5 )
  11230   "RTN","RCB EPAYF",108 ,0)
  11231    .   .   .    I 'RCBI LBAL D       ;PRCA*4. 5*301
  11232   "RTN","RCB EPAYF",109 ,0)
  11233    .   .   .    . D CHG STAT^RCBEU BIL(RCBILL DA,22)
  11234   "RTN","RCB EPAYF",110 ,0)
  11235    .   .   .    . K ^TM P("RCBEPAY ",$J,RCDAT E,RCBILLDA )
  11236   "RTN","RCB EPAYF",111 ,0)
  11237    .   .   .    . I $D( ^PRCA(430, "TCSP",RCB ILLDA)),RC BILLDA=CSB ILLDA S $P (^PRCA(430 ,RCBILLDA, 15),"^")=" " K ^PRCA( 430,"TCSP" ,RCBILLDA)      ;S DA =RCBILLDA, DIE="^PRCA (430,",DR= "151////@"  D ^DIE K  DIE,DA,DR
  11238   "RTN","RCB EPAYF",112 ,0)
  11239    .   .   .    ;
  11240   "RTN","RCB EPAYF",113 ,0)
  11241    .   .   .    L -^PRC A(430,RCBI LLDA)
  11242   "RTN","RCB EPAYF",114 ,0)
  11243    ;
  11244   "RTN","RCB EPAYF",115 ,0)
  11245    K ^TMP("R CBEPAY",$J )
  11246   "RTN","RCB EPAYF",116 ,0)
  11247    ;
  11248   "RTN","RCB EPAYF",117 ,0)
  11249    ;  if an  error occu rred, quit
  11250   "RTN","RCB EPAYF",118 ,0)
  11251    I RCERROR  L -^RCD(3 40,RCDEBTD A) Q RCERR OR
  11252   "RTN","RCB EPAYF",119 ,0)
  11253    ;
  11254   "RTN","RCB EPAYF",120 ,0)
  11255    ;  if no  money left , quit
  11256   "RTN","RCB EPAYF",121 ,0)
  11257    I 'RCPAYA MT L -^RCD (340,RCDEB TDA) Q 0
  11258   "RTN","RCB EPAYF",122 ,0)
  11259    ;
  11260   "RTN","RCB EPAYF",123 ,0)
  11261    ;  dollar s remainin g, create  a prepayme nt
  11262   "RTN","RCB EPAYF",124 ,0)
  11263    N %,%H,%I ,%X,D,D0,D FN,DI,DIC, DICR,DIG,D IH,DIU,DIV ,DIW,DQ,I, PRCA,RCREF ,VA,VADM
  11264   "RTN","RCB EPAYF",125 ,0)
  11265    D EN^PRCA PAY3(RCACC T,RCPAYAMT ,RCPAYDAT, DUZ,$P(^RC Y(344,RCRE CTDA,0),"^ "),"","",. RCERROR,"" )
  11266   "RTN","RCB EPAYF",126 ,0)
  11267    ;  no err ors
  11268   "RTN","RCB EPAYF",127 ,0)
  11269    I RCERROR =""!(RCERR OR=0) D
  11270   "RTN","RCB EPAYF",128 ,0)
  11271    .   S RCE RROR=0
  11272   "RTN","RCB EPAYF",129 ,0)
  11273    .   ;  se t the amou nt process ed on the  receipt
  11274   "RTN","RCB EPAYF",130 ,0)
  11275    .   D SET AMT^RCBEPA Y(RCRECTDA ,RCPAYDA,R CPAYAMT)
  11276   "RTN","RCB EPAYF",131 ,0)
  11277    ;  error  creating p repayment
  11278   "RTN","RCB EPAYF",132 ,0)
  11279    I RCERROR '=0 S RCER ROR="1^"_R CERROR
  11280   "RTN","RCB EPAYF",133 ,0)
  11281    ;
  11282   "RTN","RCB EPAYF",134 ,0)
  11283    L -^RCD(3 40,RCDEBTD A)
  11284   "RTN","RCB EPAYF",135 ,0)
  11285    Q RCERROR
  11286   "RTN","RCB EPAYF",136 ,0)
  11287    ;
  11288   "RTN","RCB EPAYF",137 ,0)
  11289   CS5B(RCBIL LDA) ; log s ADJ for  5B CS repo rting if C ross-Servi ced bill ;  prca*4.5* 301 ; LEG
  11290   "RTN","RCB EPAYF",138 ,0)
  11291    ; Changed  descripti on from DE C ADJ to A DJ since i ncrease ad justments  will also  use this c ode 315/DR F
  11292   "RTN","RCB EPAYF",139 ,0)
  11293    ; note: c an use eit her I +$G( ^PRCA(430, RCBILLDA,1 5)) D  ; b ill is Cro ss-Service d
  11294   "RTN","RCB EPAYF",140 ,0)
  11295    I $D(^PRC A(430,"TCS P",RCBILLD A)) D  ; b ill is Cro ss-Service d
  11296   "RTN","RCB EPAYF",141 ,0)
  11297    . ;  chec ks for val id bill
  11298   "RTN","RCB EPAYF",142 ,0)
  11299    . S DIC=" ^PRCA(430, ",DIC(0)=" KMNZ",X=RC BILLDA D ^ DIC
  11300   "RTN","RCB EPAYF",143 ,0)
  11301    . ; check s if DEC A DJ record  was previo usly logge d
  11302   "RTN","RCB EPAYF",144 ,0)
  11303    . S IDX=0 ,PREV=0
  11304   "RTN","RCB EPAYF",145 ,0)
  11305    . F  S ID X=$O(^PRCA (430,RCBIL LDA,17,IDX )) Q:'IDX   D  ;
  11306   "RTN","RCB EPAYF",146 ,0)
  11307    . . I +$G (^PRCA(430 ,RCBILLDA, 17,IDX,0)) =RCTRANDA  S PREV=1
  11308   "RTN","RCB EPAYF",147 ,0)
  11309    . I PREV  Q  ; trans action was  already l ogged
  11310   "RTN","RCB EPAYF",148 ,0)
  11311    . ;
  11312   "RTN","RCB EPAYF",149 ,0)
  11313    . ;  gets  next ADJ  subfile en try number  or create s 1st
  11314   "RTN","RCB EPAYF",150 ,0)
  11315    . K DR,DA ,DD,DO,DIC ,DIE
  11316   "RTN","RCB EPAYF",151 ,0)
  11317    . S X=RCT RANDA        ; CS ADJ  TRANS NUM BER
  11318   "RTN","RCB EPAYF",152 ,0)
  11319    . S DA(1) =RCBILLDA
  11320   "RTN","RCB EPAYF",153 ,0)
  11321    . S DIC=" ^PRCA(430, "_DA(1)_", 17,"
  11322   "RTN","RCB EPAYF",154 ,0)
  11323    . S DIC(0 )="KLMNZ"
  11324   "RTN","RCB EPAYF",155 ,0)
  11325    . S DIC(" P")=$P(^DD (430,171,0 ),"^",2)
  11326   "RTN","RCB EPAYF",156 ,0)
  11327    . D ^DIC
  11328   "RTN","RCB EPAYF",157 ,0)
  11329    . ;  set  ADJ Fields
  11330   "RTN","RCB EPAYF",158 ,0)
  11331    . S DIE=D IC K DIC
  11332   "RTN","RCB EPAYF",159 ,0)
  11333    . S DA=+Y
  11334   "RTN","RCB EPAYF",160 ,0)
  11335    . S DR="1 ////1" ; S END TCSP R ECORD 5B
  11336   "RTN","RCB EPAYF",161 ,0)
  11337    . S DIC(" DR")=DR
  11338   "RTN","RCB EPAYF",162 ,0)
  11339    . D ^DIE
  11340   "RTN","RCB EPAYF",163 ,0)
  11341    Q
  11342   "RTN","RCB EUTR1")
  11343   0^67^B3777 2593^B3626 8452
  11344   "RTN","RCB EUTR1",1,0 )
  11345   RCBEUTR1 ; WISC/RFJ-a dd int,adm in chg or  increase,d ecrease pr incipal  ; 1 Jun 00
  11346   "RTN","RCB EUTR1",2,0 )
  11347    ;;4.5;Acc ounts Rece ivable;**1 53,169,192 ,226,270,2 76,301,315 **;Mar 20,  1995;Buil d 55
  11348   "RTN","RCB EUTR1",3,0 )
  11349    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  11350   "RTN","RCB EUTR1",4,0 )
  11351    Q
  11352   "RTN","RCB EUTR1",5,0 )
  11353    ;
  11354   "RTN","RCB EUTR1",6,0 )
  11355    ;
  11356   "RTN","RCB EUTR1",7,0 )
  11357   INTADM(RCB ILLDA,RCVA LUE,RCCOMM NT,RCDATE)  ;  add an  intererst /admin cha rge (trans action typ e=13)
  11358   "RTN","RCB EUTR1",8,0 )
  11359    ;  for a  bill.  rcv alue = int erest ^ ad min ^ pena lty ^ mars hal fee ^  court cost
  11360   "RTN","RCB EUTR1",9,0 )
  11361    ;  for th e transact ion.  rcda te = proce ss date (o ptional)
  11362   "RTN","RCB EUTR1",10, 0)
  11363    ;  return s transact ion number  if succes sful
  11364   "RTN","RCB EUTR1",11, 0)
  11365    ;
  11366   "RTN","RCB EUTR1",12, 0)
  11367    N RCDRSTR G,RCTRANDA ,Y
  11368   "RTN","RCB EUTR1",13, 0)
  11369    ;  add th e transact ion (if ad ded to 433 , transact ion is loc ked)
  11370   "RTN","RCB EUTR1",14, 0)
  11371    S RCTRAND A=$$ADD433 ^RCBEUTRA( RCBILLDA,1 3) I 'RCTR ANDA Q 0
  11372   "RTN","RCB EUTR1",15, 0)
  11373    ;
  11374   "RTN","RCB EUTR1",16, 0)
  11375    ;  build  dr string
  11376   "RTN","RCB EUTR1",17, 0)
  11377    ;  transa ction date  (strip of f time)
  11378   "RTN","RCB EUTR1",18, 0)
  11379    S RCDRSTR G="11////" _$S($G(RCD ATE):$P(RC DATE,"."), 1:DT)_";"
  11380   "RTN","RCB EUTR1",19, 0)
  11381    ;
  11382   "RTN","RCB EUTR1",20, 0)
  11383    ;  transa ction valu es
  11384   "RTN","RCB EUTR1",21, 0)
  11385    S RCDRSTR G=RCDRSTRG _"15////"_ ($P(RCVALU E,"^")+$P( RCVALUE,"^ ",2)+$P(RC VALUE,"^", 3)+$P(RCVA LUE,"^",4) +$P(RCVALU E,"^",5))_ ";"
  11386   "RTN","RCB EUTR1",22, 0)
  11387    I $P(RCVA LUE,"^",4)  S RCDRSTR G=RCDRSTRG _"25////"_ $P(RCVALUE ,"^",4)_"; "  ;marsha l fee
  11388   "RTN","RCB EUTR1",23, 0)
  11389    I $P(RCVA LUE,"^",5)  S RCDRSTR G=RCDRSTRG _"26////"_ $P(RCVALUE ,"^",5)_"; "  ;court  cost
  11390   "RTN","RCB EUTR1",24, 0)
  11391    I $P(RCVA LUE,"^",1)  S RCDRSTR G=RCDRSTRG _"27////"_ $P(RCVALUE ,"^",1)_"; "  ;intere st
  11392   "RTN","RCB EUTR1",25, 0)
  11393    I $P(RCVA LUE,"^",2)  S RCDRSTR G=RCDRSTRG _"28////"_ $P(RCVALUE ,"^",2)_"; "  ;admin
  11394   "RTN","RCB EUTR1",26, 0)
  11395    I $P(RCVA LUE,"^",3)  S RCDRSTR G=RCDRSTRG _"29////"_ $P(RCVALUE ,"^",3)_"; "  ;penalt y
  11396   "RTN","RCB EUTR1",27, 0)
  11397    I $G(RCDA TE) S RCDR STRG=RCDRS TRG_"19/// /"_RCDATE_ ";"  ;date  entered
  11398   "RTN","RCB EUTR1",28, 0)
  11399    ;
  11400   "RTN","RCB EUTR1",29, 0)
  11401    ;  input  the fields  for the t ransaction
  11402   "RTN","RCB EUTR1",30, 0)
  11403    S Y=$$EDI T433^RCBEU TRA(RCTRAN DA,RCDRSTR G) I 'Y L  -^PRCA(433 ,RCTRANDA)  Q 0
  11404   "RTN","RCB EUTR1",31, 0)
  11405    ;
  11406   "RTN","RCB EUTR1",32, 0)
  11407    ;  set th e comment
  11408   "RTN","RCB EUTR1",33, 0)
  11409    I $D(RCCO MMNT(1)) D  ADDCOMM^R CBEUTRA(RC TRANDA,.RC COMMNT)
  11410   "RTN","RCB EUTR1",34, 0)
  11411    ;
  11412   "RTN","RCB EUTR1",35, 0)
  11413    ;  move o ver 433 fr om 430 (no  principal , just mov e it)
  11414   "RTN","RCB EUTR1",36, 0)
  11415    D FY433^R CBEUTRA(RC TRANDA)
  11416   "RTN","RCB EUTR1",37, 0)
  11417    ;
  11418   "RTN","RCB EUTR1",38, 0)
  11419    ;  mark t ransaction  as proces sed
  11420   "RTN","RCB EUTR1",39, 0)
  11421    D PROCESS ^RCBEUTRA( RCTRANDA)
  11422   "RTN","RCB EUTR1",40, 0)
  11423    ;
  11424   "RTN","RCB EUTR1",41, 0)
  11425    ;  update  the bill  file with  the balanc e of the t ransaction
  11426   "RTN","RCB EUTR1",42, 0)
  11427    D SETBAL^ RCBEUBIL(R CTRANDA)
  11428   "RTN","RCB EUTR1",43, 0)
  11429    ;
  11430   "RTN","RCB EUTR1",44, 0)
  11431    ;  if the  bill has  no balance , close or  cancel it
  11432   "RTN","RCB EUTR1",45, 0)
  11433    D CLOSEIT (RCBILLDA)
  11434   "RTN","RCB EUTR1",46, 0)
  11435    ;
  11436   "RTN","RCB EUTR1",47, 0)
  11437    ;  clear  the lock a nd return  the transa ction adde d
  11438   "RTN","RCB EUTR1",48, 0)
  11439    L -^PRCA( 433,RCTRAN DA)
  11440   "RTN","RCB EUTR1",49, 0)
  11441    Q RCTRAND A
  11442   "RTN","RCB EUTR1",50, 0)
  11443    ;
  11444   "RTN","RCB EUTR1",51, 0)
  11445    ; PRCA*4. 5*270 add  CRD flag s o FMS know s this is  a correcte d record
  11446   "RTN","RCB EUTR1",52, 0)
  11447    ; INCDEC( RCBILLDA,R CVALUE,RCC OMMNT,RCDA TE,RCPREPA Y,RCONTADJ ) ;  autom atically
  11448   "RTN","RCB EUTR1",53, 0)
  11449   INCDEC(RCB ILLDA,RCVA LUE,RCCOMM NT,RCDATE, RCPREPAY,R CONTADJ,RC CRD) ;
  11450   "RTN","RCB EUTR1",54, 0)
  11451    ;  automa tically cr eate an in crease or  decrease a djustment  for a bill
  11452   "RTN","RCB EUTR1",55, 0)
  11453    ;  pass v ariables:
  11454   "RTN","RCB EUTR1",56, 0)
  11455    ;      rc value  = p rincipal v alue for t he transac tion.
  11456   "RTN","RCB EUTR1",57, 0)
  11457    ;                  i f rcvalue  is less th an zero, i t will cre ate a
  11458   "RTN","RCB EUTR1",58, 0)
  11459    ;                  d ecrease ad justment.   if rcvalu e is great er than
  11460   "RTN","RCB EUTR1",59, 0)
  11461    ;                  z ero, it wi ll create  an increas e adjustme nt.
  11462   "RTN","RCB EUTR1",60, 0)
  11463    ;      rc commnt = t he comment s for the  word proce ssing fiel d.
  11464   "RTN","RCB EUTR1",61, 0)
  11465    ;      rc date   = o ptional pr ocessing d ate and ti me.  if no t
  11466   "RTN","RCB EUTR1",62, 0)
  11467    ;                  p assed, the  current d ate and ti me will be  used
  11468   "RTN","RCB EUTR1",63, 0)
  11469    ;      rc prepay = o ptional pr epayment t ransaction .  this is  the
  11470   "RTN","RCB EUTR1",64, 0)
  11471    ;                  p ayment tra nsaction a pplied to  the bill t o
  11472   "RTN","RCB EUTR1",65, 0)
  11473    ;                  c reate the  decrease a djustment.   this get s
  11474   "RTN","RCB EUTR1",66, 0)
  11475    ;                  s tored in f ield 20 (f ile 433).
  11476   "RTN","RCB EUTR1",67, 0)
  11477    ;      rc ontadj = o ptional co ntract adj ustment.   if 1 then  this
  11478   "RTN","RCB EUTR1",68, 0)
  11479    ;                  g ets stored  in field  88 (file 4 33).
  11480   "RTN","RCB EUTR1",69, 0)
  11481    ;      rc crd    = o ptional co rrected fl ag.  If 1,  then FMS  must 1st c ancel or d elete the
  11482   "RTN","RCB EUTR1",70, 0)
  11483    ;                  o riginal bi lling docu ment befor e creating  the new o ne.
  11484   "RTN","RCB EUTR1",71, 0)
  11485    ;
  11486   "RTN","RCB EUTR1",72, 0)
  11487    ;  return s transact ion number  added to  433 if suc cessful.
  11488   "RTN","RCB EUTR1",73, 0)
  11489    ;
  11490   "RTN","RCB EUTR1",74, 0)
  11491    N ADJNUMB ,RCDRSTRG, RCTRANDA,X ,Y,RCNEG,T RNTYP
  11492   "RTN","RCB EUTR1",75, 0)
  11493    ;
  11494   "RTN","RCB EUTR1",76, 0)
  11495    ;  determ ine transa ction type
  11496   "RTN","RCB EUTR1",77, 0)
  11497    I RCVALUE >0 S TRNTY P=1 I $D(^ PRCA(430," TCSP",RCBI LLDA)) S T RNTYP=73 ; PRCA*4.5*3 15/DRF
  11498   "RTN","RCB EUTR1",78, 0)
  11499    I RCVALUE <0 S TRNTY P=35
  11500   "RTN","RCB EUTR1",79, 0)
  11501    ;
  11502   "RTN","RCB EUTR1",80, 0)
  11503    ;  add th e transact ion (if ad ded to 433 , transact ion is loc ked)
  11504   "RTN","RCB EUTR1",81, 0)
  11505    S RCTRAND A=$$ADD433 ^RCBEUTRA( RCBILLDA,T RNTYP) I ' RCTRANDA Q  0
  11506   "RTN","RCB EUTR1",82, 0)
  11507    ;
  11508   "RTN","RCB EUTR1",83, 0)
  11509    ;  build  dr string
  11510   "RTN","RCB EUTR1",84, 0)
  11511    ;  11=tra nsaction d ate (strip  off time)
  11512   "RTN","RCB EUTR1",85, 0)
  11513    S RCDRSTR G="11////" _$S($G(RCD ATE):$P(RC DATE,"."), 1:DT)_";"
  11514   "RTN","RCB EUTR1",86, 0)
  11515    ;  transa ction valu e (make su re it is n ot negativ e)
  11516   "RTN","RCB EUTR1",87, 0)
  11517    I RCVALUE <0 S RCVAL UE=-RCVALU E
  11518   "RTN","RCB EUTR1",88, 0)
  11519    S RCDRSTR G=RCDRSTRG _"15////"_ RCVALUE_"; "
  11520   "RTN","RCB EUTR1",89, 0)
  11521    S RCDRSTR G=RCDRSTRG _"81////"_ RCVALUE_"; "
  11522   "RTN","RCB EUTR1",90, 0)
  11523    I $G(RCBE TYPE)="DEC REASE" S R CDRSTRG=RC DRSTRG_"31 ////"_RCVA LUE_";"     ;PRCA*4.5 *301
  11524   "RTN","RCB EUTR1",91, 0)
  11525    ;
  11526   "RTN","RCB EUTR1",92, 0)
  11527    ;  get th e next adj ustment nu mber if in crease(1)  or decreas e(35)
  11528   "RTN","RCB EUTR1",93, 0)
  11529    ;  start  with the l ast transa ction and  work backw ards
  11530   "RTN","RCB EUTR1",94, 0)
  11531    S X=99999 9999999,AD JNUMB=1
  11532   "RTN","RCB EUTR1",95, 0)
  11533    F  S X=$O (^PRCA(433 ,"C",RCBIL LDA,X),-1)  Q:'X  I $ P($G(^PRCA (433,X,1)) ,"^",4) I  $P(^(1),"^ ",2)=1!($P (^(1),"^", 2)=35) S A DJNUMB=$P( ^(1),"^",4 )+1 Q
  11534   "RTN","RCB EUTR1",96, 0)
  11535    S RCDRSTR G=RCDRSTRG _"14////"_ ADJNUMB_"; "
  11536   "RTN","RCB EUTR1",97, 0)
  11537    ;
  11538   "RTN","RCB EUTR1",98, 0)
  11539    ;  date e ntered
  11540   "RTN","RCB EUTR1",99, 0)
  11541    I $G(RCDA TE) S RCDR STRG=RCDRS TRG_"19/// /"_RCDATE_ ";"
  11542   "RTN","RCB EUTR1",100 ,0)
  11543    ;
  11544   "RTN","RCB EUTR1",101 ,0)
  11545    ;  store  the prepay ment trans action
  11546   "RTN","RCB EUTR1",102 ,0)
  11547    I $G(RCPR EPAY) D
  11548   "RTN","RCB EUTR1",103 ,0)
  11549    .   S RCD RSTRG=RCDR STRG_"20// //"_RCPREP AY_";"
  11550   "RTN","RCB EUTR1",104 ,0)
  11551    .   ;  fo r prepayme nts, set t he incompl ete transa ction flag
  11552   "RTN","RCB EUTR1",105 ,0)
  11553    .   ;  th is will no  longer be  used afte r patch 14 6 and can
  11554   "RTN","RCB EUTR1",106 ,0)
  11555    .   ;  be  removed
  11556   "RTN","RCB EUTR1",107 ,0)
  11557    .   S RCD RSTRG=RCDR STRG_"10// //1;"
  11558   "RTN","RCB EUTR1",108 ,0)
  11559    ;
  11560   "RTN","RCB EUTR1",109 ,0)
  11561    ;  contra ct adjustm ent
  11562   "RTN","RCB EUTR1",110 ,0)
  11563    I $G(RCON TADJ) S RC DRSTRG=RCD RSTRG_"88/ //1;"
  11564   "RTN","RCB EUTR1",111 ,0)
  11565    ;
  11566   "RTN","RCB EUTR1",112 ,0)
  11567    ;  input  the fields  for the t ransaction
  11568   "RTN","RCB EUTR1",113 ,0)
  11569    S Y=$$EDI T433^RCBEU TRA(RCTRAN DA,RCDRSTR G) I 'Y L  -^PRCA(433 ,RCTRANDA)  Q 0
  11570   "RTN","RCB EUTR1",114 ,0)
  11571    ;
  11572   "RTN","RCB EUTR1",115 ,0)
  11573    ;  set th e comment
  11574   "RTN","RCB EUTR1",116 ,0)
  11575    I $D(RCCO MMNT(1)) D  ADDCOMM^R CBEUTRA(RC TRANDA,.RC COMMNT)
  11576   "RTN","RCB EUTR1",117 ,0)
  11577    ;
  11578   "RTN","RCB EUTR1",118 ,0)
  11579    ;  mark t he transac tion proce ssed
  11580   "RTN","RCB EUTR1",119 ,0)
  11581    D PROCESS ^RCBEUTRA( RCTRANDA)
  11582   "RTN","RCB EUTR1",120 ,0)
  11583    ;
  11584   "RTN","RCB EUTR1",121 ,0)
  11585    ;  update  the fisca l year mul tiple (mus t be done  after mark ed as
  11586   "RTN","RCB EUTR1",122 ,0)
  11587    ;  proces sed so the  value is  defined)
  11588   "RTN","RCB EUTR1",123 ,0)
  11589    D FYMULT^ RCBEUTRA(R CTRANDA)
  11590   "RTN","RCB EUTR1",124 ,0)
  11591    ;
  11592   "RTN","RCB EUTR1",125 ,0)
  11593    ;  update  the bill  file with  the balanc e of the t ransaction
  11594   "RTN","RCB EUTR1",126 ,0)
  11595    ; PRCA276  - add exc eption con dition - n eeds to qu it receipt  processin g when neg ative clai m balance  could resu lt
  11596   "RTN","RCB EUTR1",127 ,0)
  11597    S RCNEG=0  D SETBAL^ RCBEUBIL(R CTRANDA,.R CNEG) I RC NEG D DEL4 33^RCBEUTR A(RCTRANDA ,"CANCELLE D WORKLIST  DEC ADJ T O PREVENT  NEG PRIN B AL",1) L - ^PRCA(433, RCTRANDA)  Q "0^1"
  11598   "RTN","RCB EUTR1",128 ,0)
  11599    ;
  11600   "RTN","RCB EUTR1",129 ,0)
  11601    ;  if the  bill has  no balance , close or  cancel it
  11602   "RTN","RCB EUTR1",130 ,0)
  11603    D CLOSEIT (RCBILLDA)
  11604   "RTN","RCB EUTR1",131 ,0)
  11605    ;
  11606   "RTN","RCB EUTR1",132 ,0)
  11607    ;  send F MS documen t if non-a ccrued (re do this la ter on)
  11608   "RTN","RCB EUTR1",133 ,0)
  11609    I '$$ACCK ^PRCAACC(R CBILLDA) D
  11610   "RTN","RCB EUTR1",134 ,0)
  11611    .   N D0, DA,DI,DIC, DIE,DIQ2,D Q,DR,ENT,F MSNUM,GECS DATA
  11612   "RTN","RCB EUTR1",135 ,0)
  11613    .   N CAT EG,DATA1,E RR
  11614   "RTN","RCB EUTR1",136 ,0)
  11615    .   S CAT EG=$P($G(^ PRCA(430,R CBILLDA,0) ),"^",2)
  11616   "RTN","RCB EUTR1",137 ,0)
  11617    .   ;
  11618   "RTN","RCB EUTR1",138 ,0)
  11619    .   ;  ca tegory=29  champva, d o not send  to fms, q uit
  11620   "RTN","RCB EUTR1",139 ,0)
  11621    .   I CAT EG=29 Q
  11622   "RTN","RCB EUTR1",140 ,0)
  11623    .   ;
  11624   "RTN","RCB EUTR1",141 ,0)
  11625    .   ;  ca tegory=30  tricare or  32 tricar e third pa rty, and c ontract ad j
  11626   "RTN","RCB EUTR1",142 ,0)
  11627    .   I (CA TEG=30!(CA TEG=32)),$ P($G(^PRCA (433,RCTRA NDA,8)),"^ ",8) D  Q
  11628   "RTN","RCB EUTR1",143 ,0)
  11629    .   .   S  DATA1=$G( ^PRCA(433, RCTRANDA,1 ))
  11630   "RTN","RCB EUTR1",144 ,0)
  11631    .   .   D  EN^PRCAFW O(RCBILLDA ,$P(DATA1, "^",1),$P( DATA1,"^", 5),$$SITE^ RCMSITE,RC TRANDA)
  11632   "RTN","RCB EUTR1",145 ,0)
  11633    .   ;
  11634   "RTN","RCB EUTR1",146 ,0)
  11635    .   ;  al l other ca tegories
  11636   "RTN","RCB EUTR1",147 ,0)
  11637    .   ;  pa ss trans a mount(1;5) ,trans typ e(1;2),tra ns date(1; 1)
  11638   "RTN","RCB EUTR1",148 ,0)
  11639    .   S DAT A1=$G(^PRC A(433,RCTR ANDA,1))
  11640   "RTN","RCB EUTR1",149 ,0)
  11641    .   ;
  11642   "RTN","RCB EUTR1",150 ,0)
  11643    .   ; PRC A*4.5*270  - pass CRD  flag to F MS
  11644   "RTN","RCB EUTR1",151 ,0)
  11645    .   D EN^ PRCAFBDM(R CBILLDA,$P (DATA1,"^" ,5),$P(DAT A1,"^",2), $P(DATA1," ^",1),RCTR ANDA,.ERR, $G(RCCRD))
  11646   "RTN","RCB EUTR1",152 ,0)
  11647    ;
  11648   "RTN","RCB EUTR1",153 ,0)
  11649    ;  clear  the lock a nd return  the transa ction adde d
  11650   "RTN","RCB EUTR1",154 ,0)
  11651    L -^PRCA( 433,RCTRAN DA)
  11652   "RTN","RCB EUTR1",155 ,0)
  11653    Q RCTRAND A
  11654   "RTN","RCB EUTR1",156 ,0)
  11655    ;
  11656   "RTN","RCB EUTR1",157 ,0)
  11657    ;
  11658   "RTN","RCB EUTR1",158 ,0)
  11659   CLOSEIT(RC BILLDA) ;   check to  cancel or  close bill  with no b alance
  11660   "RTN","RCB EUTR1",159 ,0)
  11661    N AMTPAID ,BILLBAL,D ATA7,TRAND A
  11662   "RTN","RCB EUTR1",160 ,0)
  11663    ;  if the  bill has  no balance , close or  cancel it
  11664   "RTN","RCB EUTR1",161 ,0)
  11665    S DATA7=$ G(^PRCA(43 0,RCBILLDA ,7))
  11666   "RTN","RCB EUTR1",162 ,0)
  11667    S BILLBAL =$P(DATA7, "^")+$P(DA TA7,"^",2) +$P(DATA7, "^",3)+$P( DATA7,"^", 4)+$P(DATA 7,"^",5)
  11668   "RTN","RCB EUTR1",163 ,0)
  11669    I 'BILLBA L D
  11670   "RTN","RCB EUTR1",164 ,0)
  11671    .   ;  ge t payments  recorded  against th e bill.  i f payments  have been
  11672   "RTN","RCB EUTR1",165 ,0)
  11673    .   ;  ma de, then t he status  of the bil l should b e collecte d/closed.
  11674   "RTN","RCB EUTR1",166 ,0)
  11675    .   S AMT PAID=$P(DA TA7,"^",7) +$P(DATA7, "^",8)+$P( DATA7,"^", 9)+$P(DATA 7,"^",10)+ $P(DATA7," ^",11)
  11676   "RTN","RCB EUTR1",167 ,0)
  11677    .   I AMT PAID D CHG STAT^RCBEU BIL(RCBILL DA,22) Q
  11678   "RTN","RCB EUTR1",168 ,0)
  11679    .   ;  if  the last  transactio n was a de crease con tract adju stment,
  11680   "RTN","RCB EUTR1",169 ,0)
  11681    .   ;  th en the sta tus will b e collecte d/closed
  11682   "RTN","RCB EUTR1",170 ,0)
  11683    .   S TRA NDA=+$O(^P RCA(433,"C ",RCBILLDA ,999999999 999),-1)
  11684   "RTN","RCB EUTR1",171 ,0)
  11685    .   I $P( $G(^PRCA(4 33,TRANDA, 8)),"^",8)  D CHGSTAT ^RCBEUBIL( RCBILLDA,2 2) Q
  11686   "RTN","RCB EUTR1",172 ,0)
  11687    .   ;  ot herwise it  should be  cancellat ion
  11688   "RTN","RCB EUTR1",173 ,0)
  11689    .   D CHG STAT^RCBEU BIL(RCBILL DA,39)
  11690   "RTN","RCB EUTR1",174 ,0)
  11691    Q
  11692   "RTN","RCD PAPL1")
  11693   0^50^B9031 5069^B3375 537
  11694   "RTN","RCD PAPL1",1,0 )
  11695   RCDPAPL1 ; WISC/RFJ-a ccount pro file listm anager opt ions ;1 Ju n 99
  11696   "RTN","RCD PAPL1",2,0 )
  11697    ;;4.5;Acc ounts Rece ivable;**1 14,315**;M ar 20, 199 5;Build 55
  11698   "RTN","RCD PAPL1",3,0 )
  11699    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  11700   "RTN","RCD PAPL1",4,0 )
  11701    Q
  11702   "RTN","RCD PAPL1",5,0 )
  11703    ;
  11704   "RTN","RCD PAPL1",6,0 )
  11705   ACCOUNT ;   select a  new accoun t
  11706   "RTN","RCD PAPL1",7,0 )
  11707    D FULL^VA LM1
  11708   "RTN","RCD PAPL1",8,0 )
  11709    S VALMBCK ="R"
  11710   "RTN","RCD PAPL1",9,0 )
  11711    ;
  11712   "RTN","RCD PAPL1",10, 0)
  11713    W !!,"Thi s option w ill allow  you to sel ect a new  account."
  11714   "RTN","RCD PAPL1",11, 0)
  11715    W ! S %=$ $SELACCT^R CDPAPLM
  11716   "RTN","RCD PAPL1",12, 0)
  11717    I %<1 Q
  11718   "RTN","RCD PAPL1",13, 0)
  11719    S RCDEBTD A=%
  11720   "RTN","RCD PAPL1",14, 0)
  11721    ;
  11722   "RTN","RCD PAPL1",15, 0)
  11723    D INIT^RC DPAPLM
  11724   "RTN","RCD PAPL1",16, 0)
  11725    Q
  11726   "RTN","RCD PAPL1",17, 0)
  11727    ;
  11728   "RTN","RCD PAPL1",18, 0)
  11729   BILLTRAN ;   show tra nsactions  for a bill
  11730   "RTN","RCD PAPL1",19, 0)
  11731    N RCBILLD A
  11732   "RTN","RCD PAPL1",20, 0)
  11733    S VALMBCK ="R"
  11734   "RTN","RCD PAPL1",21, 0)
  11735    ;
  11736   "RTN","RCD PAPL1",22, 0)
  11737    S RCBILLD A=$$SELBIL L I 'RCBIL LDA Q
  11738   "RTN","RCD PAPL1",23, 0)
  11739    D EN^VALM ("RCDP TRA NSACTIONS  LIST")
  11740   "RTN","RCD PAPL1",24, 0)
  11741    ;
  11742   "RTN","RCD PAPL1",25, 0)
  11743    D INIT^RC DPAPLM
  11744   "RTN","RCD PAPL1",26, 0)
  11745    S VALMBCK ="R"
  11746   "RTN","RCD PAPL1",27, 0)
  11747    ;  fast e xit
  11748   "RTN","RCD PAPL1",28, 0)
  11749    I $G(RCDP FXIT) S VA LMBCK="Q"
  11750   "RTN","RCD PAPL1",29, 0)
  11751    Q
  11752   "RTN","RCD PAPL1",30, 0)
  11753    ;
  11754   "RTN","RCD PAPL1",31, 0)
  11755   BILLPROF ;   bill pro file
  11756   "RTN","RCD PAPL1",32, 0)
  11757    N RCBILLD A
  11758   "RTN","RCD PAPL1",33, 0)
  11759    S VALMBCK ="R"
  11760   "RTN","RCD PAPL1",34, 0)
  11761    ;
  11762   "RTN","RCD PAPL1",35, 0)
  11763    S RCBILLD A=$$SELBIL L I 'RCBIL LDA Q
  11764   "RTN","RCD PAPL1",36, 0)
  11765    D EN^VALM ("RCDP BIL L PROFILE" )
  11766   "RTN","RCD PAPL1",37, 0)
  11767    ;
  11768   "RTN","RCD PAPL1",38, 0)
  11769    D INIT^RC DPAPLM
  11770   "RTN","RCD PAPL1",39, 0)
  11771    S VALMBCK ="R"
  11772   "RTN","RCD PAPL1",40, 0)
  11773    ;  fast e xit
  11774   "RTN","RCD PAPL1",41, 0)
  11775    I $G(RCDP FXIT) S VA LMBCK="Q"
  11776   "RTN","RCD PAPL1",42, 0)
  11777    Q
  11778   "RTN","RCD PAPL1",43, 0)
  11779    ;
  11780   "RTN","RCD PAPL1",44, 0)
  11781   SELBILL()  ;  select  bill from  list
  11782   "RTN","RCD PAPL1",45, 0)
  11783    N VALMBG, VALMLST,VA LMY
  11784   "RTN","RCD PAPL1",46, 0)
  11785    ;  if no  bills, qui t
  11786   "RTN","RCD PAPL1",47, 0)
  11787    I '$O(^TM P("RCDPAPL M",$J,"IDX ",0)) S VA LMSG="Ther e are NO b ills to pr ofile." Q  0
  11788   "RTN","RCD PAPL1",48, 0)
  11789    ;
  11790   "RTN","RCD PAPL1",49, 0)
  11791    ;  if onl y one bill , select t hat one au tomaticall y
  11792   "RTN","RCD PAPL1",50, 0)
  11793    I '$O(^TM P("RCDPAPL M",$J,"IDX ",1)) Q +$ G(^TMP("RC DPAPLM",$J ,"IDX",1,1 ))
  11794   "RTN","RCD PAPL1",51, 0)
  11795    ;
  11796   "RTN","RCD PAPL1",52, 0)
  11797    ;  select  the entry  from the  list
  11798   "RTN","RCD PAPL1",53, 0)
  11799    ;  if not  on first  screen, ma ke sure se lection be gins with  1
  11800   "RTN","RCD PAPL1",54, 0)
  11801    S VALMBG= 1
  11802   "RTN","RCD PAPL1",55, 0)
  11803    ;  if not  on last s creen, mak e sure sel ection end s with las t
  11804   "RTN","RCD PAPL1",56, 0)
  11805    S VALMLST =$O(^TMP(" RCDPAPLM", $J,"IDX",9 99999999), -1)
  11806   "RTN","RCD PAPL1",57, 0)
  11807    D EN^VALM 2($G(XQORN OD(0)),"OS ")
  11808   "RTN","RCD PAPL1",58, 0)
  11809    Q +$G(^TM P("RCDPAPL M",$J,"IDX ",+$O(VALM Y(0)),+$O( VALMY(0))) )
  11810   "RTN","RCD PAPL1",59, 0)
  11811    ;
  11812   "RTN","RCD PAPL1",60, 0)
  11813   SELMULT(VA LMY) ; sel ect 0, 1,  or more bi lls from t he list
  11814   "RTN","RCD PAPL1",61, 0)
  11815    ; Output  VALMY arra y, pass by  reference .  Return  format is  VALMY(#)=" "
  11816   "RTN","RCD PAPL1",62, 0)
  11817    ; The cal ling routi ne must th en process  any of th e entries  found in t he VALMY a rray, one  at a time.
  11818   "RTN","RCD PAPL1",63, 0)
  11819    ;
  11820   "RTN","RCD PAPL1",64, 0)
  11821    N VALMBG, VALMLST
  11822   "RTN","RCD PAPL1",65, 0)
  11823    K VALMY
  11824   "RTN","RCD PAPL1",66, 0)
  11825    ;
  11826   "RTN","RCD PAPL1",67, 0)
  11827    ; if no b ills in li st, then u pdate scre en message  and exit
  11828   "RTN","RCD PAPL1",68, 0)
  11829    I '$O(@VA LMAR@("IDX ",0)) S VA LMSG="Ther e are no b ills to se lect." G S ELMX
  11830   "RTN","RCD PAPL1",69, 0)
  11831    ;
  11832   "RTN","RCD PAPL1",70, 0)
  11833    ; if ther e is only  1 bill in  list then  add that o ne into th e VALMY ar ray and qu it
  11834   "RTN","RCD PAPL1",71, 0)
  11835    I '$O(@VA LMAR@("IDX ",1)) S VA LMY(1)=""  G SELMX
  11836   "RTN","RCD PAPL1",72, 0)
  11837    ;
  11838   "RTN","RCD PAPL1",73, 0)
  11839    ; Multipl e bills in  list. Ask  user to s elect 1 or  more of t hem
  11840   "RTN","RCD PAPL1",74, 0)
  11841    S VALMBG= 1                                       ; f irst possi ble entry
  11842   "RTN","RCD PAPL1",75, 0)
  11843    S VALMLST =$O(@VALMA R@("IDX",9 99999999), -1)    ; l ast possib le entry
  11844   "RTN","RCD PAPL1",76, 0)
  11845    ;
  11846   "RTN","RCD PAPL1",77, 0)
  11847    ; call th e selector  API
  11848   "RTN","RCD PAPL1",78, 0)
  11849    D EN^VALM 2($G(XQORN OD(0)),"O" )
  11850   "RTN","RCD PAPL1",79, 0)
  11851    ;
  11852   "RTN","RCD PAPL1",80, 0)
  11853   SELMX ;
  11854   "RTN","RCD PAPL1",81, 0)
  11855    Q
  11856   "RTN","RCD PAPL1",82, 0)
  11857    ;
  11858   "RTN","RCD PAPL1",83, 0)
  11859   SUSPEND ;S uspend a B ill PRCA*4 .5*315
  11860   "RTN","RCD PAPL1",84, 0)
  11861    N GOTBILL ,VALMY,RCB ILLDA,RCDP GN,RCDPGC, RCDPGT,RCD PGQ
  11862   "RTN","RCD PAPL1",85, 0)
  11863    D FULL^VA LM1
  11864   "RTN","RCD PAPL1",86, 0)
  11865    D SELMULT (.VALMY) I  '$O(VALMY (0)) G SUS PX
  11866   "RTN","RCD PAPL1",87, 0)
  11867    ;
  11868   "RTN","RCD PAPL1",88, 0)
  11869    ; count t he number  of selecte d entries  and put in to RCDPGT
  11870   "RTN","RCD PAPL1",89, 0)
  11871    S RCDPGN= 0 F RCDPGT =0:1 S RCD PGN=$O(VAL MY(RCDPGN) ) Q:'RCDPG N
  11872   "RTN","RCD PAPL1",90, 0)
  11873    ;
  11874   "RTN","RCD PAPL1",91, 0)
  11875    W !
  11876   "RTN","RCD PAPL1",92, 0)
  11877    S (RCDPGN ,RCDPGC)=0  F  S RCDP GN=$O(VALM Y(RCDPGN))  Q:'RCDPGN   D  Q:$G( RCDPFXIT)! $G(RCDPGQ)
  11878   "RTN","RCD PAPL1",93, 0)
  11879    . S RCBIL LDA=$G(@VA LMAR@("IDX ",RCDPGN,R CDPGN)) Q: 'RCBILLDA
  11880   "RTN","RCD PAPL1",94, 0)
  11881    . S RCDPG C=RCDPGC+1
  11882   "RTN","RCD PAPL1",95, 0)
  11883    . W !,"   ======== B ill# ",$P( $P($G(^PRC A(430,RCBI LLDA,0)),U ,1),"-",2) ," (",RCDP GC," of ", RCDPGT," s elected) = =======",!
  11884   "RTN","RCD PAPL1",96, 0)
  11885    . S GOTBI LL=1
  11886   "RTN","RCD PAPL1",97, 0)
  11887    . D 47^RC WROFF    ;  Call into  existing  write-off  routine fo r each bil l selected
  11888   "RTN","RCD PAPL1",98, 0)
  11889    . Q
  11890   "RTN","RCD PAPL1",99, 0)
  11891    ;
  11892   "RTN","RCD PAPL1",100 ,0)
  11893    D INIT^RC DPAPLM   ;  refresh t he account  profile l ist of bil ls
  11894   "RTN","RCD PAPL1",101 ,0)
  11895    ;
  11896   "RTN","RCD PAPL1",102 ,0)
  11897   SUSPX ;
  11898   "RTN","RCD PAPL1",103 ,0)
  11899    S VALMBCK ="R"
  11900   "RTN","RCD PAPL1",104 ,0)
  11901    I $G(RCDP FXIT) S VA LMBCK="Q"
  11902   "RTN","RCD PAPL1",105 ,0)
  11903    Q
  11904   "RTN","RCD PAPL1",106 ,0)
  11905    ;
  11906   "RTN","RCD PAPL1",107 ,0)
  11907   REESTAB ;  Re-Establi sh a Bill  - PRCA*4.5 *315
  11908   "RTN","RCD PAPL1",108 ,0)
  11909    N GOTBILL ,VALMY,RCB ILLDA,RCDP GN,RCDPGC, RCDPGT,RCD PGQ,DIR,X, Y,DIRUT,DU OUT,DTOUT, DIROUT
  11910   "RTN","RCD PAPL1",109 ,0)
  11911    D FULL^VA LM1
  11912   "RTN","RCD PAPL1",110 ,0)
  11913    D SELMULT (.VALMY) I  '$O(VALMY (0)) G REE STX
  11914   "RTN","RCD PAPL1",111 ,0)
  11915    ;
  11916   "RTN","RCD PAPL1",112 ,0)
  11917    ; count t he number  of selecte d entries  and put in to RCDPGT
  11918   "RTN","RCD PAPL1",113 ,0)
  11919    S RCDPGN= 0 F RCDPGT =0:1 S RCD PGN=$O(VAL MY(RCDPGN) ) Q:'RCDPG N
  11920   "RTN","RCD PAPL1",114 ,0)
  11921    ;
  11922   "RTN","RCD PAPL1",115 ,0)
  11923    W !
  11924   "RTN","RCD PAPL1",116 ,0)
  11925    S (RCDPGN ,RCDPGC)=0  F  S RCDP GN=$O(VALM Y(RCDPGN))  Q:'RCDPGN   D  Q:$G( RCDPFXIT)! $G(RCDPGQ)
  11926   "RTN","RCD PAPL1",117 ,0)
  11927    . S RCBIL LDA=$G(@VA LMAR@("IDX ",RCDPGN,R CDPGN)) Q: 'RCBILLDA
  11928   "RTN","RCD PAPL1",118 ,0)
  11929    . S RCDPG C=RCDPGC+1
  11930   "RTN","RCD PAPL1",119 ,0)
  11931    . W !,"   ======== B ill# ",$P( $P($G(^PRC A(430,RCBI LLDA,0)),U ,1),"-",2) ," (",RCDP GC," of ", RCDPGT," s elected) = =======",!
  11932   "RTN","RCD PAPL1",120 ,0)
  11933    . S GOTBI LL=1
  11934   "RTN","RCD PAPL1",121 ,0)
  11935    . D ENAP^ PRCAWREA(R CBILLDA)      ; Call  into exist ing Re-Est ablish bil l routine  for each b ill select ed
  11936   "RTN","RCD PAPL1",122 ,0)
  11937    . ;
  11938   "RTN","RCD PAPL1",123 ,0)
  11939    . ; do a  special br eak in bet ween each  one - copi ed from WA IT^VALM1 a nd modifie d to captu re DIRUT
  11940   "RTN","RCD PAPL1",124 ,0)
  11941    . W ! S D IR(0)="E"  S DIR("A") ="Enter RE TURN to co ntinue"
  11942   "RTN","RCD PAPL1",125 ,0)
  11943    . I (RCDP GT-RCDPGC) >0 S DIR(" A")=DIR("A ")_" or '^ ' to exit  this Bill#  loop"     ; if there  are still  more bill s in loop
  11944   "RTN","RCD PAPL1",126 ,0)
  11945    . D ^DIR  K DIR W !
  11946   "RTN","RCD PAPL1",127 ,0)
  11947    . I $D(DI RUT) S RCD PGQ=1
  11948   "RTN","RCD PAPL1",128 ,0)
  11949    . Q
  11950   "RTN","RCD PAPL1",129 ,0)
  11951    ;
  11952   "RTN","RCD PAPL1",130 ,0)
  11953    D INIT^RC DPAPLM   ;  refresh t he account  profile l ist of bil ls
  11954   "RTN","RCD PAPL1",131 ,0)
  11955    ;
  11956   "RTN","RCD PAPL1",132 ,0)
  11957   REESTX ;
  11958   "RTN","RCD PAPL1",133 ,0)
  11959    S VALMBCK ="R"
  11960   "RTN","RCD PAPL1",134 ,0)
  11961    I $G(RCDP FXIT) S VA LMBCK="Q"
  11962   "RTN","RCD PAPL1",135 ,0)
  11963    Q
  11964   "RTN","RCD PAPL1",136 ,0)
  11965    ;
  11966   "RTN","RCD PAPL1",137 ,0)
  11967   STOP ;Stop  a Bill in  Cross-ser vicing (De btor) PRCA *4.5*315
  11968   "RTN","RCD PAPL1",138 ,0)
  11969    N GOTBILL ,VALMY,RCB ILLDA,RCDP GN,RCDPGC, RCDPGT,RCD PGQ
  11970   "RTN","RCD PAPL1",139 ,0)
  11971    D FULL^VA LM1
  11972   "RTN","RCD PAPL1",140 ,0)
  11973    D SELMULT (.VALMY) I  '$O(VALMY (0)) G STO PX
  11974   "RTN","RCD PAPL1",141 ,0)
  11975    ;
  11976   "RTN","RCD PAPL1",142 ,0)
  11977    ; count t he number  of selecte d entries  and put in to RCDPGT
  11978   "RTN","RCD PAPL1",143 ,0)
  11979    S RCDPGN= 0 F RCDPGT =0:1 S RCD PGN=$O(VAL MY(RCDPGN) ) Q:'RCDPG N
  11980   "RTN","RCD PAPL1",144 ,0)
  11981    ;
  11982   "RTN","RCD PAPL1",145 ,0)
  11983    W !
  11984   "RTN","RCD PAPL1",146 ,0)
  11985    S (RCDPGN ,RCDPGC)=0  F  S RCDP GN=$O(VALM Y(RCDPGN))  Q:'RCDPGN   D  Q:$G( RCDPFXIT)! $G(RCDPGQ)
  11986   "RTN","RCD PAPL1",147 ,0)
  11987    . S RCBIL LDA=$G(@VA LMAR@("IDX ",RCDPGN,R CDPGN)) Q: 'RCBILLDA
  11988   "RTN","RCD PAPL1",148 ,0)
  11989    . S RCDPG C=RCDPGC+1
  11990   "RTN","RCD PAPL1",149 ,0)
  11991    . W !,"   ======== B ill# ",$P( $P($G(^PRC A(430,RCBI LLDA,0)),U ,1),"-",2) ," (",RCDP GC," of ", RCDPGT," s elected) = =======",!
  11992   "RTN","RCD PAPL1",150 ,0)
  11993    . S GOTBI LL=1
  11994   "RTN","RCD PAPL1",151 ,0)
  11995    . D STOP^ RCTCSPU  ; Call into  existing T OP routine  for each  bill selec ted
  11996   "RTN","RCD PAPL1",152 ,0)
  11997    . D WAIT^ VALM1
  11998   "RTN","RCD PAPL1",153 ,0)
  11999    . Q
  12000   "RTN","RCD PAPL1",154 ,0)
  12001    ;
  12002   "RTN","RCD PAPL1",155 ,0)
  12003    D INIT^RC DPAPLM   ;  refresh t he account  profile l ist of bil ls
  12004   "RTN","RCD PAPL1",156 ,0)
  12005    ;
  12006   "RTN","RCD PAPL1",157 ,0)
  12007   STOPX ;
  12008   "RTN","RCD PAPL1",158 ,0)
  12009    S VALMBCK ="R"
  12010   "RTN","RCD PAPL1",159 ,0)
  12011    I $G(RCDP FXIT) S VA LMBCK="Q"
  12012   "RTN","RCD PAPL1",160 ,0)
  12013    Q
  12014   "RTN","RCD PAPL1",161 ,0)
  12015    ;
  12016   "RTN","RCD PAPL1",162 ,0)
  12017   TERM ;Fisc al Officer  Terminate d PRCA*4.5 *315
  12018   "RTN","RCD PAPL1",163 ,0)
  12019    N GOTBILL ,VALMY,RCB ILLDA,RCDP GN,RCDPGC, RCDPGT,RCD PGQ
  12020   "RTN","RCD PAPL1",164 ,0)
  12021    D FULL^VA LM1
  12022   "RTN","RCD PAPL1",165 ,0)
  12023    D SELMULT (.VALMY) I  '$O(VALMY (0)) G TER MX
  12024   "RTN","RCD PAPL1",166 ,0)
  12025    ;
  12026   "RTN","RCD PAPL1",167 ,0)
  12027    ; count t he number  of selecte d entries  and put in to RCDPGT
  12028   "RTN","RCD PAPL1",168 ,0)
  12029    S RCDPGN= 0 F RCDPGT =0:1 S RCD PGN=$O(VAL MY(RCDPGN) ) Q:'RCDPG N
  12030   "RTN","RCD PAPL1",169 ,0)
  12031    ;
  12032   "RTN","RCD PAPL1",170 ,0)
  12033    W !
  12034   "RTN","RCD PAPL1",171 ,0)
  12035    S (RCDPGN ,RCDPGC)=0  F  S RCDP GN=$O(VALM Y(RCDPGN))  Q:'RCDPGN   D  Q:$G( RCDPFXIT)! $G(RCDPGQ)
  12036   "RTN","RCD PAPL1",172 ,0)
  12037    . S RCBIL LDA=$G(@VA LMAR@("IDX ",RCDPGN,R CDPGN)) Q: 'RCBILLDA
  12038   "RTN","RCD PAPL1",173 ,0)
  12039    . S RCDPG C=RCDPGC+1
  12040   "RTN","RCD PAPL1",174 ,0)
  12041    . W !,"   ======== B ill# ",$P( $P($G(^PRC A(430,RCBI LLDA,0)),U ,1),"-",2) ," (",RCDP GC," of ", RCDPGT," s elected) = =======",!
  12042   "RTN","RCD PAPL1",175 ,0)
  12043    . S GOTBI LL=1
  12044   "RTN","RCD PAPL1",176 ,0)
  12045    . D 8^RCW ROFF     ;  Call into  existing  write-off  routine fo r each bil l selected
  12046   "RTN","RCD PAPL1",177 ,0)
  12047    . Q
  12048   "RTN","RCD PAPL1",178 ,0)
  12049    ;
  12050   "RTN","RCD PAPL1",179 ,0)
  12051    D INIT^RC DPAPLM   ;  refresh t he account  profile l ist of bil ls
  12052   "RTN","RCD PAPL1",180 ,0)
  12053    ;
  12054   "RTN","RCD PAPL1",181 ,0)
  12055   TERMX ;
  12056   "RTN","RCD PAPL1",182 ,0)
  12057    S VALMBCK ="R"
  12058   "RTN","RCD PAPL1",183 ,0)
  12059    I $G(RCDP FXIT) S VA LMBCK="Q"
  12060   "RTN","RCD PAPL1",184 ,0)
  12061    Q
  12062   "RTN","RCD PAPL1",185 ,0)
  12063    ;
  12064   "RTN","RCD PAPL1",186 ,0)
  12065   RECALLB ;R ecall a Bi ll PRCA*4. 5*315
  12066   "RTN","RCD PAPL1",187 ,0)
  12067    N GOTBILL ,VALMY,RCB ILLDA,RCDP GN,RCDPGC, RCDPGT,RCD PGQ
  12068   "RTN","RCD PAPL1",188 ,0)
  12069    D FULL^VA LM1
  12070   "RTN","RCD PAPL1",189 ,0)
  12071    D SELMULT (.VALMY) I  '$O(VALMY (0)) G REC ALBX
  12072   "RTN","RCD PAPL1",190 ,0)
  12073    ;
  12074   "RTN","RCD PAPL1",191 ,0)
  12075    ; count t he number  of selecte d entries  and put in to RCDPGT
  12076   "RTN","RCD PAPL1",192 ,0)
  12077    S RCDPGN= 0 F RCDPGT =0:1 S RCD PGN=$O(VAL MY(RCDPGN) ) Q:'RCDPG N
  12078   "RTN","RCD PAPL1",193 ,0)
  12079    ;
  12080   "RTN","RCD PAPL1",194 ,0)
  12081    W !
  12082   "RTN","RCD PAPL1",195 ,0)
  12083    S (RCDPGN ,RCDPGC)=0  F  S RCDP GN=$O(VALM Y(RCDPGN))  Q:'RCDPGN   D  Q:$G( RCDPFXIT)! $G(RCDPGQ)
  12084   "RTN","RCD PAPL1",196 ,0)
  12085    . S RCBIL LDA=$G(@VA LMAR@("IDX ",RCDPGN,R CDPGN)) Q: 'RCBILLDA
  12086   "RTN","RCD PAPL1",197 ,0)
  12087    . S RCDPG C=RCDPGC+1
  12088   "RTN","RCD PAPL1",198 ,0)
  12089    . W !,"   ======== B ill# ",$P( $P($G(^PRC A(430,RCBI LLDA,0)),U ,1),"-",2) ," (",RCDP GC," of ", RCDPGT," s elected) = =======",!
  12090   "RTN","RCD PAPL1",199 ,0)
  12091    . S GOTBI LL=1
  12092   "RTN","RCD PAPL1",200 ,0)
  12093    . D RCLLS ETB^RCTCSP U    ; Cal l into exi sting reca ll code
  12094   "RTN","RCD PAPL1",201 ,0)
  12095    . D WAIT^ VALM1
  12096   "RTN","RCD PAPL1",202 ,0)
  12097    . Q
  12098   "RTN","RCD PAPL1",203 ,0)
  12099    ;
  12100   "RTN","RCD PAPL1",204 ,0)
  12101    D INIT^RC DPAPLM   ;  refresh t he account  profile l ist of bil ls
  12102   "RTN","RCD PAPL1",205 ,0)
  12103    ;
  12104   "RTN","RCD PAPL1",206 ,0)
  12105   RECALBX ;
  12106   "RTN","RCD PAPL1",207 ,0)
  12107    S VALMBCK ="R"
  12108   "RTN","RCD PAPL1",208 ,0)
  12109    I $G(RCDP FXIT) S VA LMBCK="Q"
  12110   "RTN","RCD PAPL1",209 ,0)
  12111    Q
  12112   "RTN","RCD PAPL1",210 ,0)
  12113    ;
  12114   "RTN","RCD PAPL1",211 ,0)
  12115   RECALLD ;R ecall a De btor PRCA* 4.5*315
  12116   "RTN","RCD PAPL1",212 ,0)
  12117    N GOTDEBT
  12118   "RTN","RCD PAPL1",213 ,0)
  12119    D FULL^VA LM1
  12120   "RTN","RCD PAPL1",214 ,0)
  12121    S RCDEBTD A=+$G(RCDE BTDA)      ; RCDEBTDA  is set by  the ACCTP R^RCTCSWL  - Account  Profile ac tion proto col
  12122   "RTN","RCD PAPL1",215 ,0)
  12123    I 'RCDEBT DA G RECAL DX
  12124   "RTN","RCD PAPL1",216 ,0)
  12125    ;
  12126   "RTN","RCD PAPL1",217 ,0)
  12127    S GOTDEBT =1
  12128   "RTN","RCD PAPL1",218 ,0)
  12129    D RCLLSET D^RCTCSPU      ; Call  into exis ting recal l code for  debtors
  12130   "RTN","RCD PAPL1",219 ,0)
  12131    D WAIT^VA LM1
  12132   "RTN","RCD PAPL1",220 ,0)
  12133    D INIT^RC DPAPLM         ; refr esh the ac count prof ile list o f bills
  12134   "RTN","RCD PAPL1",221 ,0)
  12135   RECALDX ;
  12136   "RTN","RCD PAPL1",222 ,0)
  12137    S VALMBCK ="R"
  12138   "RTN","RCD PAPL1",223 ,0)
  12139    I $G(RCDP FXIT) S VA LMBCK="Q"
  12140   "RTN","RCD PAPL1",224 ,0)
  12141    Q
  12142   "RTN","RCD PAPL1",225 ,0)
  12143    ;
  12144   "RTN","RCD PAPL1",226 ,0)
  12145   INC ;Incre ase Transa ction PRCA *4.5*315
  12146   "RTN","RCD PAPL1",227 ,0)
  12147    N GOTBILL ,VALMY,RCB ILLDA,RCDP GN,RCDPGC, RCDPGT,RCD PGQ
  12148   "RTN","RCD PAPL1",228 ,0)
  12149    D FULL^VA LM1
  12150   "RTN","RCD PAPL1",229 ,0)
  12151    ;
  12152   "RTN","RCD PAPL1",230 ,0)
  12153    ; check o n security  key - sam e one used  in the me nu system  for AR opt ion PRCAC  TR ADJUSTM ENT
  12154   "RTN","RCD PAPL1",231 ,0)
  12155    I '$D(^XU SEC("PRCAD J",DUZ)) D   G INCX
  12156   "RTN","RCD PAPL1",232 ,0)
  12157    . W *7,!! ?3,"You mu st hold th e PRCADJ s ecurity ke y in order  to access  this opti on.",!
  12158   "RTN","RCD PAPL1",233 ,0)
  12159    . D WAIT^ VALM1
  12160   "RTN","RCD PAPL1",234 ,0)
  12161    . Q
  12162   "RTN","RCD PAPL1",235 ,0)
  12163    ;
  12164   "RTN","RCD PAPL1",236 ,0)
  12165    D SELMULT (.VALMY) I  '$O(VALMY (0)) G INC X
  12166   "RTN","RCD PAPL1",237 ,0)
  12167    ;
  12168   "RTN","RCD PAPL1",238 ,0)
  12169    ; count t he number  of selecte d entries  and put in to RCDPGT
  12170   "RTN","RCD PAPL1",239 ,0)
  12171    S RCDPGN= 0 F RCDPGT =0:1 S RCD PGN=$O(VAL MY(RCDPGN) ) Q:'RCDPG N
  12172   "RTN","RCD PAPL1",240 ,0)
  12173    ;
  12174   "RTN","RCD PAPL1",241 ,0)
  12175    W !
  12176   "RTN","RCD PAPL1",242 ,0)
  12177    S (RCDPGN ,RCDPGC)=0  F  S RCDP GN=$O(VALM Y(RCDPGN))  Q:'RCDPGN   D  Q:$G( RCDPFXIT)! $G(RCDPGQ)
  12178   "RTN","RCD PAPL1",243 ,0)
  12179    . S RCBIL LDA=$G(@VA LMAR@("IDX ",RCDPGN,R CDPGN)) Q: 'RCBILLDA
  12180   "RTN","RCD PAPL1",244 ,0)
  12181    . S RCDPG C=RCDPGC+1
  12182   "RTN","RCD PAPL1",245 ,0)
  12183    . W !,"   ======== B ill# ",$P( $P($G(^PRC A(430,RCBI LLDA,0)),U ,1),"-",2) ," (",RCDP GC," of ", RCDPGT," s elected) = =======",!
  12184   "RTN","RCD PAPL1",246 ,0)
  12185    . S GOTBI LL=1
  12186   "RTN","RCD PAPL1",247 ,0)
  12187    . D INCRE ASE^RCBEAD J    ; Cal l into exi sting incr ease code
  12188   "RTN","RCD PAPL1",248 ,0)
  12189    . D WAIT^ VALM1
  12190   "RTN","RCD PAPL1",249 ,0)
  12191    . Q
  12192   "RTN","RCD PAPL1",250 ,0)
  12193    ;
  12194   "RTN","RCD PAPL1",251 ,0)
  12195    D INIT^RC DPAPLM   ;  refresh t he account  profile l ist of bil ls
  12196   "RTN","RCD PAPL1",252 ,0)
  12197    ;
  12198   "RTN","RCD PAPL1",253 ,0)
  12199   INCX ;
  12200   "RTN","RCD PAPL1",254 ,0)
  12201    S VALMBCK ="R"
  12202   "RTN","RCD PAPL1",255 ,0)
  12203    I $G(RCDP FXIT) S VA LMBCK="Q"
  12204   "RTN","RCD PAPL1",256 ,0)
  12205    Q
  12206   "RTN","RCD PAPL1",257 ,0)
  12207    ;
  12208   "RTN","RCD PAPL1",258 ,0)
  12209   DEC ;Decre ase Transa ction PRCA *4.5*315
  12210   "RTN","RCD PAPL1",259 ,0)
  12211    N GOTBILL ,VALMY,RCB ILLDA,RCDP GN,RCDPGC, RCDPGT,RCD PGQ
  12212   "RTN","RCD PAPL1",260 ,0)
  12213    D FULL^VA LM1
  12214   "RTN","RCD PAPL1",261 ,0)
  12215    ;
  12216   "RTN","RCD PAPL1",262 ,0)
  12217    ; check o n security  key - sam e one used  in the me nu system  for AR opt ion PRCAC  TR ADJUSTM ENT
  12218   "RTN","RCD PAPL1",263 ,0)
  12219    I '$D(^XU SEC("PRCAD J",DUZ)) D   G DECX
  12220   "RTN","RCD PAPL1",264 ,0)
  12221    . W *7,!! ?3,"You mu st hold th e PRCADJ s ecurity ke y in order  to access  this opti on.",!
  12222   "RTN","RCD PAPL1",265 ,0)
  12223    . D WAIT^ VALM1
  12224   "RTN","RCD PAPL1",266 ,0)
  12225    . Q
  12226   "RTN","RCD PAPL1",267 ,0)
  12227    ;
  12228   "RTN","RCD PAPL1",268 ,0)
  12229    D SELMULT (.VALMY) I  '$O(VALMY (0)) G DEC X
  12230   "RTN","RCD PAPL1",269 ,0)
  12231    ;
  12232   "RTN","RCD PAPL1",270 ,0)
  12233    ; count t he number  of selecte d entries  and put in to RCDPGT
  12234   "RTN","RCD PAPL1",271 ,0)
  12235    S RCDPGN= 0 F RCDPGT =0:1 S RCD PGN=$O(VAL MY(RCDPGN) ) Q:'RCDPG N
  12236   "RTN","RCD PAPL1",272 ,0)
  12237    ;
  12238   "RTN","RCD PAPL1",273 ,0)
  12239    W !
  12240   "RTN","RCD PAPL1",274 ,0)
  12241    S (RCDPGN ,RCDPGC)=0  F  S RCDP GN=$O(VALM Y(RCDPGN))  Q:'RCDPGN   D  Q:$G( RCDPFXIT)! $G(RCDPGQ)
  12242   "RTN","RCD PAPL1",275 ,0)
  12243    . S RCBIL LDA=$G(@VA LMAR@("IDX ",RCDPGN,R CDPGN)) Q: 'RCBILLDA
  12244   "RTN","RCD PAPL1",276 ,0)
  12245    . S RCDPG C=RCDPGC+1
  12246   "RTN","RCD PAPL1",277 ,0)
  12247    . W !,"   ======== B ill# ",$P( $P($G(^PRC A(430,RCBI LLDA,0)),U ,1),"-",2) ," (",RCDP GC," of ", RCDPGT," s elected) = =======",!
  12248   "RTN","RCD PAPL1",278 ,0)
  12249    . S GOTBI LL=1
  12250   "RTN","RCD PAPL1",279 ,0)
  12251    . D DECRE ASE^RCBEAD J    ; Cal l into exi sting decr ease code
  12252   "RTN","RCD PAPL1",280 ,0)
  12253    . D WAIT^ VALM1
  12254   "RTN","RCD PAPL1",281 ,0)
  12255    . Q
  12256   "RTN","RCD PAPL1",282 ,0)
  12257    ;
  12258   "RTN","RCD PAPL1",283 ,0)
  12259    D INIT^RC DPAPLM   ;  refresh t he account  profile l ist of bil ls
  12260   "RTN","RCD PAPL1",284 ,0)
  12261    ;
  12262   "RTN","RCD PAPL1",285 ,0)
  12263   DECX ;
  12264   "RTN","RCD PAPL1",286 ,0)
  12265    S VALMBCK ="R"
  12266   "RTN","RCD PAPL1",287 ,0)
  12267    I $G(RCDP FXIT) S VA LMBCK="Q"
  12268   "RTN","RCD PAPL1",288 ,0)
  12269    Q
  12270   "RTN","RCD PAPL1",289 ,0)
  12271    ;
  12272   "RTN","RCD PAPLI")
  12273   0^65^B5395 1998^B4672 2534
  12274   "RTN","RCD PAPLI",1,0 )
  12275   RCDPAPLI ; WISC/RFJ-a ccount pro file top l ist manage r init ;1  Jun 99
  12276   "RTN","RCD PAPLI",2,0 )
  12277    ;;4.5;Acc ounts Rece ivable;**1 14,141,241 ,303,301,3 15**;Mar 2 0, 1995;Bu ild 55
  12278   "RTN","RCD PAPLI",3,0 )
  12279    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  12280   "RTN","RCD PAPLI",4,0 )
  12281    Q
  12282   "RTN","RCD PAPLI",5,0 )
  12283    ;
  12284   "RTN","RCD PAPLI",6,0 )
  12285   INIT ;  in it for lis t manager  screen
  12286   "RTN","RCD PAPLI",7,0 )
  12287    N DMCDATA ,RCBILLDA, RCCOMM,RCD ATA,RCDATE ,RCLINE,RC STATDA,RCT OTAL
  12288   "RTN","RCD PAPLI",8,0 )
  12289    N TOP4,TO P6
  12290   "RTN","RCD PAPLI",9,0 )
  12291    K ^TMP("R CDPAPLM",$ J),^TMP("R CDPAPLMX", $J),^TMP(" VALM VIDEO ",$J)
  12292   "RTN","RCD PAPLI",10, 0)
  12293    ;
  12294   "RTN","RCD PAPLI",11, 0)
  12295    ;  fast e xit
  12296   "RTN","RCD PAPLI",12, 0)
  12297    I $G(RCDP FXIT) S VA LMQUIT=1 Q
  12298   "RTN","RCD PAPLI",13, 0)
  12299    ;
  12300   "RTN","RCD PAPLI",14, 0)
  12301    I '$G(RCD EBTDA) D   Q
  12302   "RTN","RCD PAPLI",15, 0)
  12303    .   D SET ("",1,1,80 )
  12304   "RTN","RCD PAPLI",16, 0)
  12305    .   D SET ("*****  S elect an A CCOUNT  ** ***",2,1,8 0)
  12306   "RTN","RCD PAPLI",17, 0)
  12307    .   S VAL MCNT=2
  12308   "RTN","RCD PAPLI",18, 0)
  12309    .   D HDR ^RCDPAPLM
  12310   "RTN","RCD PAPLI",19, 0)
  12311    ;
  12312   "RTN","RCD PAPLI",20, 0)
  12313    ;  get bi lls for a  debtor
  12314   "RTN","RCD PAPLI",21, 0)
  12315    D GETBILL S^RCDPAPST (RCDEBTDA)
  12316   "RTN","RCD PAPLI",22, 0)
  12317    ;
  12318   "RTN","RCD PAPLI",23, 0)
  12319    I '$O(^TM P("RCDPAPS T",$J,0))  D  Q
  12320   "RTN","RCD PAPLI",24, 0)
  12321    .   D SET ("",1,1,80 ,IORVOFF,I ORVOFF)
  12322   "RTN","RCD PAPLI",25, 0)
  12323    .   D SET ("  *****   Account d oes not ha ve any bil ls *****", 2,1,80)
  12324   "RTN","RCD PAPLI",26, 0)
  12325    .   S VAL MCNT=2
  12326   "RTN","RCD PAPLI",27, 0)
  12327    .   S RCT OTAL(1)=0
  12328   "RTN","RCD PAPLI",28, 0)
  12329    .   D HDR ^RCDPAPLM
  12330   "RTN","RCD PAPLI",29, 0)
  12331    ;
  12332   "RTN","RCD PAPLI",30, 0)
  12333    ;  set th e listmana ger line n umber
  12334   "RTN","RCD PAPLI",31, 0)
  12335    S RCLINE= 0
  12336   "RTN","RCD PAPLI",32, 0)
  12337    ;
  12338   "RTN","RCD PAPLI",33, 0)
  12339    S RCDATE= 9999999 F   S RCDATE= $O(^TMP("R CDPAPST",$ J,RCDATE), -1) Q:'RCD ATE  D
  12340   "RTN","RCD PAPLI",34, 0)
  12341    .   S RCS TATDA=0 F   S RCSTATD A=$O(^TMP( "RCDPAPST" ,$J,RCDATE ,RCSTATDA) ) Q:'RCSTA TDA  D
  12342   "RTN","RCD PAPLI",35, 0)
  12343    .   .   S  RCBILLDA= 0 F  S RCB ILLDA=$O(^ TMP("RCDPA PST",$J,RC DATE,RCSTA TDA,RCBILL DA)) Q:'RC BILLDA  D
  12344   "RTN","RCD PAPLI",36, 0)
  12345    .   .   .    S RCDAT A=^TMP("RC DPAPST",$J ,RCDATE,RC STATDA,RCB ILLDA)
  12346   "RTN","RCD PAPLI",37, 0)
  12347    .   .   .    ;  add  up dollars  owed by a ccount (al l bills)
  12348   "RTN","RCD PAPLI",38, 0)
  12349    .   .   .    S RCTOT AL(1)=$G(R CTOTAL(1)) +$P(RCDATA ,"^")
  12350   "RTN","RCD PAPLI",39, 0)
  12351    .   .   .    S RCTOT AL(2)=$G(R CTOTAL(2)) +$P(RCDATA ,"^",2)
  12352   "RTN","RCD PAPLI",40, 0)
  12353    .   .   .    S RCTOT AL(3)=$G(R CTOTAL(3)) +$P(RCDATA ,"^",3)
  12354   "RTN","RCD PAPLI",41, 0)
  12355    .   .   .    ;
  12356   "RTN","RCD PAPLI",42, 0)
  12357    .   .   .    ;  if n ot a selec ted status , do not d isplay
  12358   "RTN","RCD PAPLI",43, 0)
  12359    .   .   .    I ("^"_ $G(^DISV(D UZ,"RCDPAP LM","STATU S"))_"^")' [("^"_RCST ATDA_"^")  Q
  12360   "RTN","RCD PAPLI",44, 0)
  12361    .   .   .    ;
  12362   "RTN","RCD PAPLI",45, 0)
  12363    .   .   .    ;  disp lay the bi ll in list manager if  the statu s selected
  12364   "RTN","RCD PAPLI",46, 0)
  12365    .   .   .    D SETBI LL
  12366   "RTN","RCD PAPLI",47, 0)
  12367    .   .   .    ;
  12368   "RTN","RCD PAPLI",48, 0)
  12369    .   .   .    ;  add  up dollars  owed by a ccount (bi lls displa yed)
  12370   "RTN","RCD PAPLI",49, 0)
  12371    .   .   .    S RCTOT AL(4)=$G(R CTOTAL(4)) +$P(RCDATA ,"^")
  12372   "RTN","RCD PAPLI",50, 0)
  12373    .   .   .    S RCTOT AL(5)=$G(R CTOTAL(5)) +$P(RCDATA ,"^",2)
  12374   "RTN","RCD PAPLI",51, 0)
  12375    .   .   .    S RCTOT AL(6)=$G(R CTOTAL(6)) +$P(RCDATA ,"^",3)
  12376   "RTN","RCD PAPLI",52, 0)
  12377    ;
  12378   "RTN","RCD PAPLI",53, 0)
  12379    ;  show t otals of a ll bills d isplayed i n listmana ger
  12380   "RTN","RCD PAPLI",54, 0)
  12381    S RCLINE= RCLINE+1
  12382   "RTN","RCD PAPLI",55, 0)
  12383    D SET("                                                          ---------  -------- - -------",R CLINE,1,80 )
  12384   "RTN","RCD PAPLI",56, 0)
  12385    S RCLINE= RCLINE+1
  12386   "RTN","RCD PAPLI",57, 0)
  12387    D SET("    TOTAL BAL ANCE OWED  FOR ALL BI LLS DISPLA YED",RCLIN E,1,80)
  12388   "RTN","RCD PAPLI",58, 0)
  12389    D SET($J( $G(RCTOTAL (4)),9,2), RCLINE,53, 62)
  12390   "RTN","RCD PAPLI",59, 0)
  12391    D SET($J( $G(RCTOTAL (5)),9,2), RCLINE,62, 71)
  12392   "RTN","RCD PAPLI",60, 0)
  12393    D SET($J( $G(RCTOTAL (6)),9,2), RCLINE,71, 80)
  12394   "RTN","RCD PAPLI",61, 0)
  12395    ;
  12396   "RTN","RCD PAPLI",62, 0)
  12397    ;  get th e pending  payments f or the deb tor
  12398   "RTN","RCD PAPLI",63, 0)
  12399    S RCTOTAL ("PP")=$$P ENDPAY^RCD PURET($P(^ RCD(340,RC DEBTDA,0), "^"))
  12400   "RTN","RCD PAPLI",64, 0)
  12401    I $O(^TMP ($J,"RCDPU REC","PP", 0)) D
  12402   "RTN","RCD PAPLI",65, 0)
  12403    .   S RCL INE=RCLINE +1 D SET("  ",RCLINE, 1,80)
  12404   "RTN","RCD PAPLI",66, 0)
  12405    .   S RCL INE=RCLINE +1 D SET(" Pending Pa yments",RC LINE,1,80, 0,IORVON,I ORVOFF)
  12406   "RTN","RCD PAPLI",67, 0)
  12407    .   N %,D ATA,DATE,R ECEIPT,REC TDA,TRANDA ,TYPE
  12408   "RTN","RCD PAPLI",68, 0)
  12409    .   S REC TDA=0 F  S  RECTDA=$O (^TMP($J," RCDPUREC", "PP",RECTD A)) Q:'REC TDA  D
  12410   "RTN","RCD PAPLI",69, 0)
  12411    .   .   S  RECEIPT=$ P($G(^RCY( 344,RECTDA ,0)),"^")
  12412   "RTN","RCD PAPLI",70, 0)
  12413    .   .   S  TYPE=$E($ P($G(^RC(3 41.1,+$P(^ RCY(344,RE CTDA,0),"^ ",4),0))," ^"),1,14)
  12414   "RTN","RCD PAPLI",71, 0)
  12415    .   .   S  TRANDA=0  F  S TRAND A=$O(^TMP( $J,"RCDPUR EC","PP",R ECTDA,TRAN DA)) Q:'TR ANDA  D
  12416   "RTN","RCD PAPLI",72, 0)
  12417    .   .   .    S DATA= ^TMP($J,"R CDPUREC"," PP",RECTDA ,TRANDA)
  12418   "RTN","RCD PAPLI",73, 0)
  12419    .   .   .    S RCLIN E=RCLINE+1
  12420   "RTN","RCD PAPLI",74, 0)
  12421    .   .   .    D SET(R ECEIPT_"/" _TRANDA,RC LINE,1,80)
  12422   "RTN","RCD PAPLI",75, 0)
  12423    .   .   .    S DATE= $P(DATA,"^ ",6)
  12424   "RTN","RCD PAPLI",76, 0)
  12425    .   .   .    S DATE= $E(DATE,4, 5)_"/"_$E( DATE,6,7)_ "/"_$E(DAT E,2,3)
  12426   "RTN","RCD PAPLI",77, 0)
  12427    .   .   .    D SET(D ATE,RCLINE ,13,21)
  12428   "RTN","RCD PAPLI",78, 0)
  12429    .   .   .    ;  buil d type of  payment di splay
  12430   "RTN","RCD PAPLI",79, 0)
  12431    .   .   .    S %=$E( TYPE_"                ",1,14)
  12432   "RTN","RCD PAPLI",80, 0)
  12433    .   .   .    I $P(DA TA,"^",7)' ="" S %=%_ "/"_$P(DAT A,"^",7)   ;  check #
  12434   "RTN","RCD PAPLI",81, 0)
  12435    .   .   .    I $P(DA TA,"^",8)' ="" S %=%_ "/"_$P(DAT A,"^",8)   ;  bank #
  12436   "RTN","RCD PAPLI",82, 0)
  12437    .   .   .    I $P(DA TA,"^",2)' ="" S %=%_ "/"_$P(DAT A,"^",2)   ;  confirm ation
  12438   "RTN","RCD PAPLI",83, 0)
  12439    .   .   .    D SET(% ,RCLINE,29 ,53)
  12440   "RTN","RCD PAPLI",84, 0)
  12441    .   .   .    ;  show  amount pa id
  12442   "RTN","RCD PAPLI",85, 0)
  12443    .   .   .    D SET($ J($P(DATA, "^",4),9,2 ),RCLINE,5 3,62)
  12444   "RTN","RCD PAPLI",86, 0)
  12445    .   S RCL INE=RCLINE +1
  12446   "RTN","RCD PAPLI",87, 0)
  12447    .   D SET ("                                                         ------ ---",RCLIN E,1,80)
  12448   "RTN","RCD PAPLI",88, 0)
  12449    .   S RCL INE=RCLINE +1
  12450   "RTN","RCD PAPLI",89, 0)
  12451    .   D SET ("   TOTAL  PENDING P AYMENTS",R CLINE,1,80 )
  12452   "RTN","RCD PAPLI",90, 0)
  12453    .   D SET ($J($G(RCT OTAL("PP") ),9,2),RCL INE,53,62)
  12454   "RTN","RCD PAPLI",91, 0)
  12455    .   K ^TM P($J,"RCDP UREC","PP" )
  12456   "RTN","RCD PAPLI",92, 0)
  12457    ;
  12458   "RTN","RCD PAPLI",93, 0)
  12459    ;  dmc in fo
  12460   "RTN","RCD PAPLI",94, 0)
  12461    I $D(^RCD (340,"DMC" ,1,+RCDEBT DA)) D
  12462   "RTN","RCD PAPLI",95, 0)
  12463    .   S DMC DATA=$G(^R CD(340,+RC DEBTDA,3))
  12464   "RTN","RCD PAPLI",96, 0)
  12465    .   S RCL INE=RCLINE +1 D SET("  ",RCLINE, 1,80)
  12466   "RTN","RCD PAPLI",97, 0)
  12467    .   S RCL INE=RCLINE +1
  12468   "RTN","RCD PAPLI",98, 0)
  12469    .   D SET ("** Accou nt forward ed to DMC:  "_$S('$P( DMCDATA,"^ ",2):"",1: $$SLH^RCFN 01($P(DMCD ATA,"^",2) )),RCLINE, 1,80)
  12470   "RTN","RCD PAPLI",99, 0)
  12471    .   D SET ("Total DM C Amount:  "_$J($P(DM CDATA,"^", 5),9,2),RC LINE,50,80 )
  12472   "RTN","RCD PAPLI",100 ,0)
  12473    .   I $P( DMCDATA,"^ ",9)'="" D
  12474   "RTN","RCD PAPLI",101 ,0)
  12475    .   .   S  RCLINE=RC LINE+1
  12476   "RTN","RCD PAPLI",102 ,0)
  12477    .   .   D  SET(" ",R CLINE,1,80 )
  12478   "RTN","RCD PAPLI",103 ,0)
  12479    .   .   D  SET("Less er Amt to  DMC: "_$J( $P(DMCDATA ,"^",9),9, 2),RCLINE, 49,80)
  12480   "RTN","RCD PAPLI",104 ,0)
  12481    ;   top i nfo
  12482   "RTN","RCD PAPLI",105 ,0)
  12483    I $D(^RCD (340,"TOP" ,+RCDEBTDA )) D
  12484   "RTN","RCD PAPLI",106 ,0)
  12485    .   S TOP 6=$G(^RCD( 340,+RCDEB TDA,6)),TO P4=$G(^(4) )
  12486   "RTN","RCD PAPLI",107 ,0)
  12487    .   S RCL INE=RCLINE +1 D SET("  ",RCLINE, 1,80)
  12488   "RTN","RCD PAPLI",108 ,0)
  12489    .   S RCL INE=RCLINE +1
  12490   "RTN","RCD PAPLI",109 ,0)
  12491    .   D SET ("** Accou nt forward ed to TOP:  "_$S('$P( TOP6,"^"): "",1:$$SLH ^RCFN01($P (TOP6,"^") )),RCLINE, 1,80)
  12492   "RTN","RCD PAPLI",110 ,0)
  12493    .   D SET ("Total TO P Amount:  "_$J($P(TO P4,"^",3), 13,2),RCLI NE,45,80)
  12494   "RTN","RCD PAPLI",111 ,0)
  12495    .   I $P( TOP6,"^",6 )'="" D
  12496   "RTN","RCD PAPLI",112 ,0)
  12497    .   .   S  RCLINE=RC LINE+1
  12498   "RTN","RCD PAPLI",113 ,0)
  12499    .   .   D  SET(" ",R CLINE,1,80 )
  12500   "RTN","RCD PAPLI",114 ,0)
  12501    .   .   D  SET("TOP  Hold Date:  "_$$SLH^R CFN01($P(T OP6,"^",6) ),RCLINE,4 5,80)
  12502   "RTN","RCD PAPLI",115 ,0)
  12503    ;
  12504   "RTN","RCD PAPLI",116 ,0)
  12505    ;   cross -servicing  info
  12506   "RTN","RCD PAPLI",117 ,0)
  12507    I $D(^RCD (340,"TCSP ",+RCDEBTD A)) D
  12508   "RTN","RCD PAPLI",118 ,0)
  12509    .   S RCL INE=RCLINE +1 D SET("  ",RCLINE, 1,80)
  12510   "RTN","RCD PAPLI",119 ,0)
  12511    .   S RCL INE=RCLINE +1
  12512   "RTN","RCD PAPLI",120 ,0)
  12513    .   D SET ^RCDPBPLM( "Debt Refe rred to Cr oss-Servic ing",RCLIN E,1,80)
  12514   "RTN","RCD PAPLI",121 ,0)
  12515    .   D SET ("Total CS  Debt: "_$ J($$TOTALB ^RCTCSPU(+ RCDEBTDA), 13,2),RCLI NE,45,80)
  12516   "RTN","RCD PAPLI",122 ,0)
  12517    ;
  12518   "RTN","RCD PAPLI",123 ,0)
  12519    ;  show i f hurrican e katrina  vet
  12520   "RTN","RCD PAPLI",124 ,0)
  12521    I $P(^RCD (340,+RCDE BTDA,0),U) ["DPT(" S  DFN=+^(0)  D
  12522   "RTN","RCD PAPLI",125 ,0)
  12523    .   Q:$$E MGRES^DGUT L(DFN)'["K "
  12524   "RTN","RCD PAPLI",126 ,0)
  12525    .   S RCL INE=RCLINE +1
  12526   "RTN","RCD PAPLI",127 ,0)
  12527    .   D SET ("EMERGENC Y RESPONSE  INDICATOR : HURRICAN E KATRINA" ,RCLINE,1, 80)
  12528   "RTN","RCD PAPLI",128 ,0)
  12529    ;
  12530   "RTN","RCD PAPLI",129 ,0)
  12531    ;  show c omments if  they exis t
  12532   "RTN","RCD PAPLI",130 ,0)
  12533    I $O(^RCD (340,RCDEB TDA,2,0))  D
  12534   "RTN","RCD PAPLI",131 ,0)
  12535    .   S RCL INE=RCLINE +1 D SET("  ",RCLINE, 1,80)
  12536   "RTN","RCD PAPLI",132 ,0)
  12537    .   S RCL INE=RCLINE +1 D SET(" Comments", RCLINE,1,8 0,0,IOUON, IOUOFF)
  12538   "RTN","RCD PAPLI",133 ,0)
  12539    .   S RCC OMM=0 F  S  RCCOMM=$O (^RCD(340, RCDEBTDA,2 ,RCCOMM))  Q:'RCCOMM   D
  12540   "RTN","RCD PAPLI",134 ,0)
  12541    .   .   S  RCLINE=RC LINE+1 D S ET(^RCD(34 0,RCDEBTDA ,2,RCCOMM, 0),RCLINE, 1,80)
  12542   "RTN","RCD PAPLI",135 ,0)
  12543    ;
  12544   "RTN","RCD PAPLI",136 ,0)
  12545    K ^TMP("R CDPAPST",$ J)
  12546   "RTN","RCD PAPLI",137 ,0)
  12547    ;
  12548   "RTN","RCD PAPLI",138 ,0)
  12549    ;  set va lmcnt to n umber of l ines in th e list
  12550   "RTN","RCD PAPLI",139 ,0)
  12551    S VALMCNT =RCLINE
  12552   "RTN","RCD PAPLI",140 ,0)
  12553    D HDR^RCD PAPLM
  12554   "RTN","RCD PAPLI",141 ,0)
  12555    Q
  12556   "RTN","RCD PAPLI",142 ,0)
  12557    ;
  12558   "RTN","RCD PAPLI",143 ,0)
  12559    ;
  12560   "RTN","RCD PAPLI",144 ,0)
  12561   SETBILL ;   set a bil l on the l istmanager  line
  12562   "RTN","RCD PAPLI",145 ,0)
  12563    N DATE,IB CNDATA,RCD PDATA,REJE CT,VALUE
  12564   "RTN","RCD PAPLI",146 ,0)
  12565    D DIQ430^ RCDPBPLM(R CBILLDA,". 01;2;3;8;6 0;")
  12566   "RTN","RCD PAPLI",147 ,0)
  12567    ;
  12568   "RTN","RCD PAPLI",148 ,0)
  12569    S RCLINE= RCLINE+1
  12570   "RTN","RCD PAPLI",149 ,0)
  12571    ;
  12572   "RTN","RCD PAPLI",150 ,0)
  12573    ;  create  an index  array for  bill looku p in list
  12574   "RTN","RCD PAPLI",151 ,0)
  12575    S ^TMP("R CDPAPLM",$ J,"IDX",RC LINE,RCLIN E)=RCBILLD A
  12576   "RTN","RCD PAPLI",152 ,0)
  12577    ;
  12578   "RTN","RCD PAPLI",153 ,0)
  12579    ;  bill n umber
  12580   "RTN","RCD PAPLI",154 ,0)
  12581    ;PRCA*4.5 *303 - add  reject in dicator to  kbill ; I A# 6060
  12582   "RTN","RCD PAPLI",155 ,0)
  12583    S REJECT= $$BILLREJ^ IBJTU6($P( RCDPDATA(4 30,RCBILLD A,.01,"E") ,"-",2))
  12584   "RTN","RCD PAPLI",156 ,0)
  12585    D SET(RCL INE,RCLINE ,1,80,0,IO RVON,IORVO FF)
  12586   "RTN","RCD PAPLI",157 ,0)
  12587    D SET($S( REJECT:"c" ,1:"")_$E( $P(RCDPDAT A(430,RCBI LLDA,.01," E"),"-",2) _"       " ,1,7),RCLI NE,7,14,0)  ;PRCA*3.5 *315 incre ase left m argin
  12588   "RTN","RCD PAPLI",158 ,0)
  12589    ;PRCA*4.5 *303 - End
  12590   "RTN","RCD PAPLI",159 ,0)
  12591    ;
  12592   "RTN","RCD PAPLI",160 ,0)
  12593    ; PRCA*4. 5*315 - ad d "x" or " y" indicat or to kbil l
  12594   "RTN","RCD PAPLI",161 ,0)
  12595    N CSDATE1 ,CSDATE2,R CIND
  12596   "RTN","RCD PAPLI",162 ,0)
  12597    S CSDATE1 =$$GET1^DI Q(430,RCBI LLDA,"DATE  BILL REFE RRED TO TC SP","I")
  12598   "RTN","RCD PAPLI",163 ,0)
  12599    S CSDATE2 =$$GET1^DI Q(430,RCBI LLDA,"ORIG INAL DATE  REFERRED T O TCSP","I ")
  12600   "RTN","RCD PAPLI",164 ,0)
  12601    D SET(RCL INE,RCLINE ,1,80,0,IO RVON,IORVO FF)
  12602   "RTN","RCD PAPLI",165 ,0)
  12603    S RCIND=$ S(CSDATE1' ="":"x",CS DATE2'="": "y",1:"")
  12604   "RTN","RCD PAPLI",166 ,0)
  12605    I RCIND]" " D SET(RC IND_$E($P( RCDPDATA(4 30,RCBILLD A,.01,"E") ,"-",2)_"        ",1, 7),RCLINE, 7,15,0)
  12606   "RTN","RCD PAPLI",167 ,0)
  12607    I RCIND=" " D SET(RC IND_$E($P( RCDPDATA(4 30,RCBILLD A,.01,"E") ,"-",2)_"        ",1, 7),RCLINE, 8,15,0)
  12608   "RTN","RCD PAPLI",168 ,0)
  12609    ;PRCA*4.5 *315 End
  12610   "RTN","RCD PAPLI",169 ,0)
  12611    ;
  12612   "RTN","RCD PAPLI",170 ,0)
  12613    ;  get da te of care
  12614   "RTN","RCD PAPLI",171 ,0)
  12615    D DIQ399^ RCXFMSUR(R CBILLDA)
  12616   "RTN","RCD PAPLI",172 ,0)
  12617    S DATE=$G (IBCNDATA( 399,RCBILL DA,151,"I" ))
  12618   "RTN","RCD PAPLI",173 ,0)
  12619    I 'DATE S  DATE=$G(R CDPDATA(43 0,RCBILLDA ,60,"I"))
  12620   "RTN","RCD PAPLI",174 ,0)
  12621    S DATE=$E (DATE,4,5) _"/"_$E(DA TE,6,7)_"/ "_$E(DATE, 2,3)
  12622   "RTN","RCD PAPLI",175 ,0)
  12623    ;D SET(DA TE,RCLINE, 13,21,0)
  12624   "RTN","RCD PAPLI",176 ,0)
  12625    D SET(DAT E,RCLINE,1 7,24,0) ;P RCA*4.5*31 5
  12626   "RTN","RCD PAPLI",177 ,0)
  12627    ;
  12628   "RTN","RCD PAPLI",178 ,0)
  12629    ;  status  (field 8)
  12630   "RTN","RCD PAPLI",179 ,0)
  12631    ;D SET("" ,RCLINE,23 ,26,8)
  12632   "RTN","RCD PAPLI",180 ,0)
  12633    D SET("", RCLINE,27, 30,8) ;PRC A*4.5*315
  12634   "RTN","RCD PAPLI",181 ,0)
  12635    ;
  12636   "RTN","RCD PAPLI",182 ,0)
  12637    ;  type o f care
  12638   "RTN","RCD PAPLI",183 ,0)
  12639    ;D SET("" ,RCLINE,29 ,71,2)
  12640   "RTN","RCD PAPLI",184 ,0)
  12641    D SET("", RCLINE,33, 53,2) ;PRC A*4.5*315
  12642   "RTN","RCD PAPLI",185 ,0)
  12643    ;
  12644   "RTN","RCD PAPLI",186 ,0)
  12645    ;  princi ple, inter est, admin
  12646   "RTN","RCD PAPLI",187 ,0)
  12647    D SET($J( $P(RCDATA, "^"),9,2), RCLINE,53, 62,0)
  12648   "RTN","RCD PAPLI",188 ,0)
  12649    D SET($J( $P(RCDATA, "^",2),9,2 ),RCLINE,6 2,71,0)
  12650   "RTN","RCD PAPLI",189 ,0)
  12651    D SET($J( $P(RCDATA, "^",3),9,2 ),RCLINE,7 1,80,0)
  12652   "RTN","RCD PAPLI",190 ,0)
  12653    Q
  12654   "RTN","RCD PAPLI",191 ,0)
  12655    ;
  12656   "RTN","RCD PAPLI",192 ,0)
  12657    ;
  12658   "RTN","RCD PAPLI",193 ,0)
  12659   SET(STRING ,LINE,COLB EG,COLEND, FIELD,ON,O FF) ;  set  array
  12660   "RTN","RCD PAPLI",194 ,0)
  12661    I $G(FIEL D) S STRIN G=STRING_$ S(STRING=" ":"",1:":  ")_$G(RCDP DATA(430,R CBILLDA,FI ELD,"E"))
  12662   "RTN","RCD PAPLI",195 ,0)
  12663    I STRING= "",'$G(FIE LD) D SET^ VALM10(LIN E,$J("",80 )) Q
  12664   "RTN","RCD PAPLI",196 ,0)
  12665    I '$D(@VA LMAR@(LINE ,0)) D SET ^VALM10(LI NE,$J("",8 0))
  12666   "RTN","RCD PAPLI",197 ,0)
  12667    D SET^VAL M10(LINE,$ $SETSTR^VA LM1(STRING ,@VALMAR@( LINE,0),CO LBEG,COLEN D-COLBEG+1 ))
  12668   "RTN","RCD PAPLI",198 ,0)
  12669    I $G(ON)] ""!($G(OFF )]"") D CN TRL^VALM10 (LINE,COLB EG,$L(STRI NG),ON,OFF )
  12670   "RTN","RCD PAPLI",199 ,0)
  12671    Q
  12672   "RTN","RCD PBPLI")
  12673   0^33^B6000 1669^B5725 1656
  12674   "RTN","RCD PBPLI",1,0 )
  12675   RCDPBPLI ; WISC/RFJ-b ill profil e (build a rray cont  employee/v endor) ;1  Jun 99
  12676   "RTN","RCD PBPLI",2,0 )
  12677    ;;4.5;Acc ounts Rece ivable;**1 14,153,301 ,315**;Mar  20, 1995; Build 55
  12678   "RTN","RCD PBPLI",3,0 )
  12679    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  12680   "RTN","RCD PBPLI",4,0 )
  12681    ;
  12682   "RTN","RCD PBPLI",5,0 )
  12683    Q
  12684   "RTN","RCD PBPLI",6,0 )
  12685    ;
  12686   "RTN","RCD PBPLI",7,0 )
  12687    ;
  12688   "RTN","RCD PBPLI",8,0 )
  12689   INIT ;  in itializati on for lis t manager  list
  12690   "RTN","RCD PBPLI",9,0 )
  12691    ;  report  type for  employee o r vendor,  show descr iption fie ld 106
  12692   "RTN","RCD PBPLI",10, 0)
  12693    N COMMDA, DATA,DESCD A,TEXT
  12694   "RTN","RCD PBPLI",11, 0)
  12695    S RCLINE= RCLINE+1 D  SET^RCDPB PLM(" ",RC LINE,1,80)
  12696   "RTN","RCD PBPLI",12, 0)
  12697    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("Date     ",RCLIN E,1,80,0,I OUON,IOUOF F)
  12698   "RTN","RCD PBPLI",13, 0)
  12699    D SET^RCD PBPLM("Des cription", RCLINE,12, 80,0,IOUON ,IOUOFF)
  12700   "RTN","RCD PBPLI",14, 0)
  12701    D SET^RCD PBPLM("Qua ntity",RCL INE,35,80, 0,IOUON,IO UOFF)
  12702   "RTN","RCD PBPLI",15, 0)
  12703    D SET^RCD PBPLM("Uni ts",RCLINE ,46,80,0,I OUON,IOUOF F)
  12704   "RTN","RCD PBPLI",16, 0)
  12705    D SET^RCD PBPLM("Cos t",RCLINE, 54,80,0,IO UON,IOUOFF )
  12706   "RTN","RCD PBPLI",17, 0)
  12707    D SET^RCD PBPLM("Tot al Cost",R CLINE,64,8 0,0,IOUON, IOUOFF)
  12708   "RTN","RCD PBPLI",18, 0)
  12709    S DESCDA= 0 F  S DES CDA=$O(^PR CA(430,RCB ILLDA,101, DESCDA)) Q :'DESCDA   D
  12710   "RTN","RCD PBPLI",19, 0)
  12711    .   S DAT A=$G(^PRCA (430,RCBIL LDA,101,DE SCDA,0)) I  DATA="" Q
  12712   "RTN","RCD PBPLI",20, 0)
  12713    .   S RCL INE=RCLINE +1
  12714   "RTN","RCD PBPLI",21, 0)
  12715    .   D SET ^RCDPBPLM( $E($P(DATA ,U),4,5)_" /"_$E($P(D ATA,U),6,7 )_"/"_$E($ P(DATA,U), 2,3),RCLIN E,1,80)
  12716   "RTN","RCD PBPLI",22, 0)
  12717    .   D SET ^RCDPBPLM( $J($P(DATA ,U,3),8,2) ,RCLINE,35 ,80)
  12718   "RTN","RCD PBPLI",23, 0)
  12719    .   D SET ^RCDPBPLM( $J($P($G(^ PRCD(420.5 ,+$P(DATA, U,5),0)),U ),5),RCLIN E,46,80)
  12720   "RTN","RCD PBPLI",24, 0)
  12721    .   D SET ^RCDPBPLM( $J($P(DATA ,U,4),0,4) ,RCLINE,54 ,80)
  12722   "RTN","RCD PBPLI",25, 0)
  12723    .   D SET ^RCDPBPLM( $J($P(DATA ,U,6),10,2 ),RCLINE,6 4,80)
  12724   "RTN","RCD PBPLI",26, 0)
  12725    .   ;  sh ow descrip tion
  12726   "RTN","RCD PBPLI",27, 0)
  12727    .   S DAT A=""
  12728   "RTN","RCD PBPLI",28, 0)
  12729    .   S COM MDA=0 F  S  COMMDA=$O (^PRCA(430 ,RCBILLDA, 101,DESCDA ,1,COMMDA) ) Q:'COMMD A  D
  12730   "RTN","RCD PBPLI",29, 0)
  12731    .   .   S  TEXT=$G(^ PRCA(430,R CBILLDA,10 1,DESCDA,1 ,COMMDA,0) ) I TEXT=" " Q
  12732   "RTN","RCD PBPLI",30, 0)
  12733    .   .   I  $L(DATA_T EXT)>240 D  SETDESC(1 1)
  12734   "RTN","RCD PBPLI",31, 0)
  12735    .   .   S  DATA=DATA _$S(DATA=" ":"",1:" " )_TEXT
  12736   "RTN","RCD PBPLI",32, 0)
  12737    .   I DAT A'="" D SE TDESC(11)
  12738   "RTN","RCD PBPLI",33, 0)
  12739    .   ;  ma ke sure al l data is  processed
  12740   "RTN","RCD PBPLI",34, 0)
  12741    .   I DAT A'="" D SE TDESC(11)
  12742   "RTN","RCD PBPLI",35, 0)
  12743    Q
  12744   "RTN","RCD PBPLI",36, 0)
  12745    ;
  12746   "RTN","RCD PBPLI",37, 0)
  12747    ;
  12748   "RTN","RCD PBPLI",38, 0)
  12749   SETDESC(ST ARTCOL) ;   set the d escription  line star ting in co lumn start col+1
  12750   "RTN","RCD PBPLI",39, 0)
  12751    N %,LENGT H,SPACE
  12752   "RTN","RCD PBPLI",40, 0)
  12753    S LENGTH= 80-STARTCO L-1
  12754   "RTN","RCD PBPLI",41, 0)
  12755    S SPACE=" ",$P(SPACE ," ",80)=" "
  12756   "RTN","RCD PBPLI",42, 0)
  12757    ;  break  text at sp ace if pos sible
  12758   "RTN","RCD PBPLI",43, 0)
  12759    I $L(DATA )>LENGTH D
  12760   "RTN","RCD PBPLI",44, 0)
  12761    .   F %=L ENGTH-1:-1 :0 Q:$E(DA TA,%)=" "
  12762   "RTN","RCD PBPLI",45, 0)
  12763    .   I % S  LENGTH=%
  12764   "RTN","RCD PBPLI",46, 0)
  12765    ;  set li ne
  12766   "RTN","RCD PBPLI",47, 0)
  12767    S RCLINE= RCLINE+1 D  SET^RCDPB PLM($E(SPA CE,1,START COL)_$E(DA TA,1,LENGT H),RCLINE, 1,80)
  12768   "RTN","RCD PBPLI",48, 0)
  12769    S DATA=$E (DATA,LENG TH+1,255)
  12770   "RTN","RCD PBPLI",49, 0)
  12771    I $L(DATA )>LENGTH D  SETDESC(S TARTCOL)
  12772   "RTN","RCD PBPLI",50, 0)
  12773    Q
  12774   "RTN","RCD PBPLI",51, 0)
  12775    ;
  12776   "RTN","RCD PBPLI",52, 0)
  12777    ;
  12778   "RTN","RCD PBPLI",53, 0)
  12779   TRANINIT ;   initiali zation for  transacti on and ib  data displ ay
  12780   "RTN","RCD PBPLI",54, 0)
  12781    N BILLCAT ,DATA,IBDA ,RCDATE,RC LIST,RCTOT AL,RCTRAND A,X
  12782   "RTN","RCD PBPLI",55, 0)
  12783    ;  get th e bill cat egory
  12784   "RTN","RCD PBPLI",56, 0)
  12785    S BILLCAT =$P($G(^PR CA(430,RCB ILLDA,0)), U,2)
  12786   "RTN","RCD PBPLI",57, 0)
  12787    S RCLINE= RCLINE+1 D  SET^RCDPB PLM(" ",RC LINE,1,80)
  12788   "RTN","RCD PBPLI",58, 0)
  12789    S RCLINE= RCLINE+1 D  SET^RCDPB PLM(" ",RC LINE,1,80)
  12790   "RTN","RCD PBPLI",59, 0)
  12791    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("Trans     Date       Type                  Amount   Descript ion                    User",RCL INE,1,80,0 ,IOUON,IOU OFF)  ;PRC A*4.5*315  Display Us er Ini
  12792   "RTN","RCD PBPLI",60, 0)
  12793    S RCTOTAL =$$GETTRAN S^RCDPBTLM (RCBILLDA)
  12794   "RTN","RCD PBPLI",61, 0)
  12795    S RCDATE= 0 F  S RCD ATE=$O(RCL IST(RCDATE )) Q:'RCDA TE  D
  12796   "RTN","RCD PBPLI",62, 0)
  12797    .   S RCT RANDA=0 F   S RCTRAND A=$O(RCLIS T(RCDATE,R CTRANDA))  Q:'RCTRAND A  D
  12798   "RTN","RCD PBPLI",63, 0)
  12799    .   .   S  RCLINE=RC LINE+1
  12800   "RTN","RCD PBPLI",64, 0)
  12801    .   .   D  SET^RCDPB PLM(RCTRAN DA,RCLINE, 1,80)
  12802   "RTN","RCD PBPLI",65, 0)
  12803    .   .   D  SET^RCDPB PLM($E(RCD ATE,4,5)_" /"_$E(RCDA TE,6,7)_"/ "_$E(RCDAT E,2,3),RCL INE,10,20)
  12804   "RTN","RCD PBPLI",66, 0)
  12805    .   .   D  SET^RCDPB PLM($E($P( RCLIST(RCD ATE,RCTRAN DA),U),1,1 4),RCLINE, 20,34)  ;P RCA*4.5*31 5
  12806   "RTN","RCD PBPLI",67, 0)
  12807    .   .   S  X=$P(RCLI ST(RCDATE, RCTRANDA), U,2)+$P(RC LIST(RCDAT E,RCTRANDA ),U,3)+$P( RCLIST(RCD ATE,RCTRAN DA),U,4)+$ P(RCLIST(R CDATE,RCTR ANDA),U,5) +$P(RCLIST (RCDATE,RC TRANDA),U, 6)
  12808   "RTN","RCD PBPLI",68, 0)
  12809    .   .   D  SET^RCDPB PLM($J(X,1 0,2),RCLIN E,36,75)   ;PRCA*4.5* 315
  12810   "RTN","RCD PBPLI",69, 0)
  12811    .   .   S  X=$P(RCLI ST(RCDATE, RCTRANDA), U,7)  ;PRC A*4.5*315
  12812   "RTN","RCD PBPLI",70, 0)
  12813    .   .   D  SET^RCDPB PLM(X,RCLI NE,77,80)   ;PRCA*4.5 *315
  12814   "RTN","RCD PBPLI",71, 0)
  12815    .   .   ;
  12816   "RTN","RCD PBPLI",72, 0)
  12817    .   .   ;   for cate gory c-mea ns test, r x copay (s c/nsc)
  12818   "RTN","RCD PBPLI",73, 0)
  12819    .   .   I  BILLCAT=1 8!(BILLCAT =22)!(BILL CAT=23) D
  12820   "RTN","RCD PBPLI",74, 0)
  12821    .   .   .    D STMT^ IBRFN1(RCT RANDA)
  12822   "RTN","RCD PBPLI",75, 0)
  12823    .   .   .    I '$D(^ TMP("IBRFN 1",$J)) Q
  12824   "RTN","RCD PBPLI",76, 0)
  12825    .   .   .    S IBDA= 0 F  S IBD A=$O(^TMP( "IBRFN1",$ J,IBDA)) Q :'IBDA  D
  12826   "RTN","RCD PBPLI",77, 0)
  12827    .   .   .    .   S D ATA=^TMP(" IBRFN1",$J ,IBDA)
  12828   "RTN","RCD PBPLI",78, 0)
  12829    .   .   .    .   ;   show rx
  12830   "RTN","RCD PBPLI",79, 0)
  12831    .   .   .    .   I B ILLCAT=22! (BILLCAT=2 3) D  Q
  12832   "RTN","RCD PBPLI",80, 0)
  12833    .   .   .    .   .    D SET^RCD PBPLM("RX  "_$P(DATA, U,2),RCLIN E,48,58)   ;PRCA*4.5* 315 Spacin g changed  next sever al lines
  12834   "RTN","RCD PBPLI",81, 0)
  12835    .   .   .    .   .    D SET^RCD PBPLM($P(D ATA,U,3),R CLINE,60,7 5)
  12836   "RTN","RCD PBPLI",82, 0)
  12837    .   .   .    .   .    ; D SET^R CDPBPLM("Q ty "_$P(DA TA,U,6),RC LINE,77,80 )
  12838   "RTN","RCD PBPLI",83, 0)
  12839    .   .   .    .   ;   show outpa tient (typ e of care  430.2 = 4  outpatient  care)
  12840   "RTN","RCD PBPLI",84, 0)
  12841    .   .   .    .   I $ P(^PRCA(43 0,RCBILLDA ,0),U,16)= 4 D  Q
  12842   "RTN","RCD PBPLI",85, 0)
  12843    .   .   .    .   .    D SET^RCD PBPLM("Out patient Vi sit Date:  "_$E($P(DA TA,U,2),4, 5)_"/"_$E( $P(DATA,U, 2),6,7)_"/ "_$E($P(DA TA,U,2),2, 3),RCLINE, 48,80)
  12844   "RTN","RCD PBPLI",86, 0)
  12845    .   .   .    .   ;   show inpat ient
  12846   "RTN","RCD PBPLI",87, 0)
  12847    .   .   .    .   D S ET^RCDPBPL M("Inpatie nt Adm Dat e: "_$E($P (DATA,U,2) ,4,5)_"/"_ $E($P(DATA ,U,2),6,7) _"/"_$E($P (DATA,U,2) ,2,3),RCLI NE,48,80)
  12848   "RTN","RCD PBPLI",88, 0)
  12849    .   .   .    K ^TMP( "IBRFN1",$ J)
  12850   "RTN","RCD PBPLI",89, 0)
  12851    Q
  12852   "RTN","RCD PBPLI",90, 0)
  12853    ;
  12854   "RTN","RCD PBPLI",91, 0)
  12855   REJECT ;   ; prca*4.5 *301 ; LEG
  12856   "RTN","RCD PBPLI",92, 0)
  12857    S RCLINE= RCLINE+1 D  SET^RCDPB PLM(" ",RC LINE,1,80)
  12858   "RTN","RCD PBPLI",93, 0)
  12859    S RCLINE= RCLINE+1 D  SET^RCDPB PLM(" ",RC LINE,1,80)
  12860   "RTN","RCD PBPLI",94, 0)
  12861    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("CS Re ject Data" ,RCLINE,1, 80,0,IOUON ,IOUOFF)
  12862   "RTN","RCD PBPLI",95, 0)
  12863    D PROFRJA ^RCTCSJS1( RCBILLDA,. RCLINE,.OU TARY)
  12864   "RTN","RCD PBPLI",96, 0)
  12865    M @VALMAR =OUTARY
  12866   "RTN","RCD PBPLI",97, 0)
  12867    K OUTARY
  12868   "RTN","RCD PBPLI",98, 0)
  12869    Q
  12870   "RTN","RCD PBPLI",99, 0)
  12871    ;
  12872   "RTN","RCD PBPLI",100 ,0)
  12873    ;
  12874   "RTN","RCD PBPLI",101 ,0)
  12875    ;
  12876   "RTN","RCD PBPLI",102 ,0)
  12877   REPAY ;  s how repaym ent plan
  12878   "RTN","RCD PBPLI",103 ,0)
  12879    S RCLINE= RCLINE+1 D  SET^RCDPB PLM(" ",RC LINE,1,80)
  12880   "RTN","RCD PBPLI",104 ,0)
  12881    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("Repay ment Plan  Data",RCLI NE,1,80,0, IOUON,IOUO FF)
  12882   "RTN","RCD PBPLI",105 ,0)
  12883    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("      Repayment  Plan Date" ,RCLINE,1, 80,41)
  12884   "RTN","RCD PBPLI",106 ,0)
  12885    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("Day o f Month Pa yment Due" ,RCLINE,1, 80,42)
  12886   "RTN","RCD PBPLI",107 ,0)
  12887    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("    R epayment A mount Due" ,RCLINE,1, 80,43)
  12888   "RTN","RCD PBPLI",108 ,0)
  12889    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("       Number of  Payments" ,RCLINE,1, 80,44)
  12890   "RTN","RCD PBPLI",109 ,0)
  12891    Q
  12892   "RTN","RCD PBPLI",110 ,0)
  12893    ;
  12894   "RTN","RCD PBPLI",111 ,0)
  12895    ;
  12896   "RTN","RCD PBPLI",112 ,0)
  12897   IRS ;  irs  data
  12898   "RTN","RCD PBPLI",113 ,0)
  12899    S RCLINE= RCLINE+1 D  SET^RCDPB PLM(" ",RC LINE,1,80)
  12900   "RTN","RCD PBPLI",114 ,0)
  12901    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("Forwa rded to IR S",RCLINE, 1,80,0,IOU ON,IOUOFF)
  12902   "RTN","RCD PBPLI",115 ,0)
  12903    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("On Da te",RCLINE ,40,80,68. 7)
  12904   "RTN","RCD PBPLI",116 ,0)
  12905    D SET^RCD PBPLM("Amo unt",RCLIN E,65,80,68 .92)
  12906   "RTN","RCD PBPLI",117 ,0)
  12907    S DATA=$G (^PRCA(430 ,RCBILLDA, 6))
  12908   "RTN","RCD PBPLI",118 ,0)
  12909    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("        Principa l Balance:  "_$J($P(D ATA,U,16), 10,2),RCLI NE,1,80)
  12910   "RTN","RCD PBPLI",119 ,0)
  12911    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("         Interes t Balance:  "_$J($P(D ATA,U,17), 10,2),RCLI NE,1,80)
  12912   "RTN","RCD PBPLI",120 ,0)
  12913    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("  Adm inistrativ e Balance:  "_$J($P(D ATA,U,18), 10,2),RCLI NE,1,80)
  12914   "RTN","RCD PBPLI",121 ,0)
  12915    Q
  12916   "RTN","RCD PBPLI",122 ,0)
  12917    ;
  12918   "RTN","RCD PBPLI",123 ,0)
  12919    ;
  12920   "RTN","RCD PBPLI",124 ,0)
  12921   DMC ;  dmc  data
  12922   "RTN","RCD PBPLI",125 ,0)
  12923    S RCLINE= RCLINE+1 D  SET^RCDPB PLM(" ",RC LINE,1,80)
  12924   "RTN","RCD PBPLI",126 ,0)
  12925    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("Forwa rded to DM C",RCLINE, 1,80,0,IOU ON,IOUOFF)
  12926   "RTN","RCD PBPLI",127 ,0)
  12927    D SET^RCD PBPLM("On  Date",RCLI NE,40,80,1 21)
  12928   "RTN","RCD PBPLI",128 ,0)
  12929    S DATA=$G (^PRCA(430 ,RCBILLDA, 12))
  12930   "RTN","RCD PBPLI",129 ,0)
  12931    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("        Principa l Balance:  "_$J($P(D ATA,U,2),1 0,2),RCLIN E,1,80)
  12932   "RTN","RCD PBPLI",130 ,0)
  12933    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("         Interes t Balance:  "_$J($P(D ATA,U,3),1 0,2),RCLIN E,1,80)
  12934   "RTN","RCD PBPLI",131 ,0)
  12935    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("  Adm inistrativ e Balance:  "_$J($P(D ATA,U,4),1 0,2),RCLIN E,1,80)
  12936   "RTN","RCD PBPLI",132 ,0)
  12937    Q
  12938   "RTN","RCD PBPLI",133 ,0)
  12939    ;
  12940   "RTN","RCD PBPLI",134 ,0)
  12941    ;
  12942   "RTN","RCD PBPLI",135 ,0)
  12943   TOP ;  top  data
  12944   "RTN","RCD PBPLI",136 ,0)
  12945    S RCLINE= RCLINE+1 D  SET^RCDPB PLM(" ",RC LINE,1,80)
  12946   "RTN","RCD PBPLI",137 ,0)
  12947    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("Forwa rded to TO P",RCLINE, 1,80,0,IOU ON,IOUOFF)
  12948   "RTN","RCD PBPLI",138 ,0)
  12949    D SET^RCD PBPLM("On  Date",RCLI NE,40,80,1 41)
  12950   "RTN","RCD PBPLI",139 ,0)
  12951    S DATA=$G (^RCD(340, +RCDPDATA( 430,RCBILL DA,9,"I"), 6))
  12952   "RTN","RCD PBPLI",140 ,0)
  12953    I $P(DATA ,U,6) D
  12954   "RTN","RCD PBPLI",141 ,0)
  12955    .   S Y=$ P(DATA,U,6 ) D DD^%DT
  12956   "RTN","RCD PBPLI",142 ,0)
  12957    .   S RCL INE=RCLINE +1 D SET^R CDPBPLM("   TOP Hold  Date: "_Y, RCLINE,1,8 0)
  12958   "RTN","RCD PBPLI",143 ,0)
  12959    Q
  12960   "RTN","RCD PBPLI",144 ,0)
  12961    ;
  12962   "RTN","RCD PBPLI",145 ,0)
  12963    ;
  12964   "RTN","RCD PBPLI",146 ,0)
  12965   TCSP ;  cr oss-servic ing data r eferral
  12966   "RTN","RCD PBPLI",147 ,0)
  12967    S RCLINE= RCLINE+1 D  SET^RCDPB PLM(" ",RC LINE,1,80)
  12968   "RTN","RCD PBPLI",148 ,0)
  12969    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("Debt  Referred t o Cross-Se rvicing",R CLINE,1,80 )
  12970   "RTN","RCD PBPLI",149 ,0)
  12971    D SET^RCD PBPLM("  C S Referred  Date",RCL INE,48,80, 151)
  12972   "RTN","RCD PBPLI",150 ,0)
  12973    Q
  12974   "RTN","RCD PBPLI",151 ,0)
  12975    ;
  12976   "RTN","RCD PBPLI",152 ,0)
  12977    ;
  12978   "RTN","RCD PBPLI",153 ,0)
  12979   TCSPRC ;   cross-serv icing data  recall
  12980   "RTN","RCD PBPLI",154 ,0)
  12981    S RCLINE= RCLINE+1 D  SET^RCDPB PLM(" ",RC LINE,1,80)
  12982   "RTN","RCD PBPLI",155 ,0)
  12983    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("CS Re call Reaso n:",RCLINE ,1,80)
  12984   "RTN","RCD PBPLI",156 ,0)
  12985    D SET^RCD PBPLM("",R CLINE,19,8 0,154)
  12986   "RTN","RCD PBPLI",157 ,0)
  12987    D SET^RCD PBPLM("  C S Recall D ate",RCLIN E,50,80,15 3)
  12988   "RTN","RCD PBPLI",158 ,0)
  12989    Q
  12990   "RTN","RCD PBPLI",159 ,0)
  12991    ;
  12992   "RTN","RCD PBPLI",160 ,0)
  12993    ;
  12994   "RTN","RCD PBPLI",161 ,0)
  12995   INSUR ;  s how insura nce data
  12996   "RTN","RCD PBPLI",162 ,0)
  12997    S RCLINE= RCLINE+1 D  SET^RCDPB PLM(" ",RC LINE,1,80)
  12998   "RTN","RCD PBPLI",163 ,0)
  12999    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("Insur ance Data" ,RCLINE,1, 80,0,IOUON ,IOUOFF)
  13000   "RTN","RCD PBPLI",164 ,0)
  13001    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("          Insure d Name",RC LINE,1,80, 239)
  13002   "RTN","RCD PBPLI",165 ,0)
  13003    D SET^RCD PBPLM("Sex ",RCLINE,5 0,80,240)
  13004   "RTN","RCD PBPLI",166 ,0)
  13005    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("             ID  Number",RC LINE,1,80, 242)
  13006   "RTN","RCD PBPLI",167 ,0)
  13007    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("            Grou p Name",RC LINE,1,80, 243)
  13008   "RTN","RCD PBPLI",168 ,0)
  13009    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("          Group  Number",RC LINE,1,80, 244)
  13010   "RTN","RCD PBPLI",169 ,0)
  13011    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("         Employe r Name",RC LINE,1,80, 247)
  13012   "RTN","RCD PBPLI",170 ,0)
  13013    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("   Em ployee ID  Number",RC LINE,1,80, 248)
  13014   "RTN","RCD PBPLI",171 ,0)
  13015    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("    E mployer Lo cation",RC LINE,1,80, 249)
  13016   "RTN","RCD PBPLI",172 ,0)
  13017    S RCLINE= RCLINE+1 D  SET^RCDPB PLM("Secon dary Ins C arrier",RC LINE,1,80, 19)
  13018   "RTN","RCD PBPLI",173 ,0)
  13019    S RCLINE= RCLINE+1 D  SET^RCDPB PLM(" Tert iary Ins C arrier",RC LINE,1,80, 19.1)
  13020   "RTN","RCD PBPLI",174 ,0)
  13021    Q
  13022   "RTN","RCD PBPLM")
  13023   0^47^B6243 6978^B6191 6200
  13024   "RTN","RCD PBPLM",1,0 )
  13025   RCDPBPLM ; WISC/RFJ -  bill prof ile ;1 Jun  99
  13026   "RTN","RCD PBPLM",2,0 )
  13027    ;;4.5;Acc ounts Rece ivable;**1 14,153,159 ,241,276,3 03,301,315 **;Mar 20,  1995;Buil d 55
  13028   "RTN","RCD PBPLM",3,0 )
  13029    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  13030   "RTN","RCD PBPLM",4,0 )
  13031    ;
  13032   "RTN","RCD PBPLM",5,0 )
  13033    ;
  13034   "RTN","RCD PBPLM",6,0 )
  13035    ;  called  from menu  option (1 9)
  13036   "RTN","RCD PBPLM",7,0 )
  13037    ;
  13038   "RTN","RCD PBPLM",8,0 )
  13039    N RCBILLD A,RCDPFXIT
  13040   "RTN","RCD PBPLM",9,0 )
  13041    ;
  13042   "RTN","RCD PBPLM",10, 0)
  13043    F  D  Q:' RCBILLDA
  13044   "RTN","RCD PBPLM",11, 0)
  13045    . W !! S  RCBILLDA=$ $SELBILL^R CDPBTLM
  13046   "RTN","RCD PBPLM",12, 0)
  13047    . I RCBIL LDA<1 S RC BILLDA=0 Q
  13048   "RTN","RCD PBPLM",13, 0)
  13049    . D EN^VA LM("RCDP B ILL PROFIL E")
  13050   "RTN","RCD PBPLM",14, 0)
  13051    . ;  fast  exit
  13052   "RTN","RCD PBPLM",15, 0)
  13053    . I $G(RC DPFXIT) S  RCBILLDA=0
  13054   "RTN","RCD PBPLM",16, 0)
  13055    Q
  13056   "RTN","RCD PBPLM",17, 0)
  13057    ;
  13058   "RTN","RCD PBPLM",18, 0)
  13059    ;
  13060   "RTN","RCD PBPLM",19, 0)
  13061   INIT ;  in itializati on for lis t manager  list
  13062   "RTN","RCD PBPLM",20, 0)
  13063    ;  requir es rcbilld a
  13064   "RTN","RCD PBPLM",21, 0)
  13065    N BILLED, COMMDA,DAT A,PAID,RCD PDATA,RCFY DA,RCLINE, REPTYPE,X1 ,X2,RCDEBT OR,DFN
  13066   "RTN","RCD PBPLM",22, 0)
  13067    K ^TMP("R CDPBPLM",$ J),^TMP("V ALM VIDEO" ,$J)
  13068   "RTN","RCD PBPLM",23, 0)
  13069    ;
  13070   "RTN","RCD PBPLM",24, 0)
  13071    ;  fast e xit
  13072   "RTN","RCD PBPLM",25, 0)
  13073    I $G(RCDP FXIT) S VA LMQUIT=1 Q
  13074   "RTN","RCD PBPLM",26, 0)
  13075    ;
  13076   "RTN","RCD PBPLM",27, 0)
  13077    D DIQ430( RCBILLDA," .01:300")
  13078   "RTN","RCD PBPLM",28, 0)
  13079    ;
  13080   "RTN","RCD PBPLM",29, 0)
  13081    ;  set th e listmana ger line n umber
  13082   "RTN","RCD PBPLM",30, 0)
  13083    S RCLINE= 0
  13084   "RTN","RCD PBPLM",31, 0)
  13085    ;
  13086   "RTN","RCD PBPLM",32, 0)
  13087    I '$D(RCD PDATA) Q   ;PRCA*4.5* 315
  13088   "RTN","RCD PBPLM",33, 0)
  13089    S DATA=$$ ACCNTHDR^R CDPAPLM(RC DPDATA(430 ,RCBILLDA, 9,"I"))
  13090   "RTN","RCD PBPLM",34, 0)
  13091    S RCLINE= RCLINE+1 D  SET("Acco unt: "_$P( DATA,"^")_ " "_$P(DAT A,"^",2),R CLINE,1,80 )
  13092   "RTN","RCD PBPLM",35, 0)
  13093    D SET($P( DATA,"^",3 ),RCLINE,6 0,80)
  13094   "RTN","RCD PBPLM",36, 0)
  13095    S %="" I  $TR($P(DAT A,"^",4,9) ,"^")'=""  S %=$P(DAT A,"^",4)_" , "_$P(DAT A,"^",7)_" , "_$P(DAT A,"^",8)_"   "_$P(DAT A,"^",9)
  13096   "RTN","RCD PBPLM",37, 0)
  13097    S RCLINE= RCLINE+1 D  SET("   A ddr: "_%,R CLINE,1,80 )
  13098   "RTN","RCD PBPLM",38, 0)
  13099    S RCLINE= RCLINE+1 D  SET("  Ph one: "_$P( DATA,"^",1 0),RCLINE, 1,80)
  13100   "RTN","RCD PBPLM",39, 0)
  13101    S RCDEBTO R=$P(^PRCA (430,RCBIL LDA,0),U,9 )
  13102   "RTN","RCD PBPLM",40, 0)
  13103    I $P(^RCD (340,+RCDE BTOR,0),U) ["DPT(" S  DFN=+^(0)  D
  13104   "RTN","RCD PBPLM",41, 0)
  13105    . Q:$$EMG RES^DGUTL( DFN)'["K"
  13106   "RTN","RCD PBPLM",42, 0)
  13107    . S RCLIN E=RCLINE+1
  13108   "RTN","RCD PBPLM",43, 0)
  13109    . D SET(" EMERGENCY  RESPONSE I NDICATOR:  HURRICANE  KATRINA",R CLINE,1,80 )
  13110   "RTN","RCD PBPLM",44, 0)
  13111    ;
  13112   "RTN","RCD PBPLM",45, 0)
  13113    ;  bill d escriptive  data
  13114   "RTN","RCD PBPLM",46, 0)
  13115    S RCLINE= RCLINE+1 D  SET(" ",R CLINE,1,80 )
  13116   "RTN","RCD PBPLM",47, 0)
  13117    ; PRCA*4. 5*276 - ge t 1st/3rd  party paym ent add EE OB indicat or when ap plicable
  13118   "RTN","RCD PBPLM",48, 0)
  13119    S PRCOUT= $$COMP3^PR CAAPR(RCBI LLDA)
  13120   "RTN","RCD PBPLM",49, 0)
  13121    I PRCOUT' ="%" S PRC OUT=$$IBEE OBCK^PRCAA PR1(RCBILL DA)
  13122   "RTN","RCD PBPLM",50, 0)
  13123    S RCLINE= RCLINE+1 ;  D SET("Bi ll Number" ,RCLINE,1, 80,.01,IOU ON,IOUOFF)
  13124   "RTN","RCD PBPLM",51, 0)
  13125    ; IA# 606 0 for $$BI LLREJ^IBJT U6
  13126   "RTN","RCD PBPLM",52, 0)
  13127    S PRCOUT= PRCOUT_$S( $$BILLREJ^ IBJTU6($P( $P($G(RCDP DATA(430,R CBILLDA,.0 1,"E")),"^ "),"-",2)) :"c",1:"")  ;PRCA*4.5 *303 Add i ndicator f or rejects
  13128   "RTN","RCD PBPLM",53, 0)
  13129    D SET("Bi ll Number:  "_$G(PRCO UT)_$P(RCD PDATA(430, RCBILLDA,. 01,"E"),"^ "),RCLINE, 1,80,0,IOU ON,IOUOFF)
  13130   "RTN","RCD PBPLM",54, 0)
  13131    D SET("Ca tegory",RC LINE,40,80 ,2)
  13132   "RTN","RCD PBPLM",55, 0)
  13133    S RCLINE= RCLINE+1 D  SET("Date   Prepared ",RCLINE,1 ,80,10)
  13134   "RTN","RCD PBPLM",56, 0)
  13135    D SET("St atus",RCLI NE,42,80,8 )
  13136   "RTN","RCD PBPLM",57, 0)
  13137    S RCLINE= RCLINE+1 D  SET("Date  Activated ",RCLINE,1 ,80,60)
  13138   "RTN","RCD PBPLM",58, 0)
  13139    S RCLINE= RCLINE+1 D  SET("Date  Status Up ",RCLINE,1 ,80,14)
  13140   "RTN","RCD PBPLM",59, 0)
  13141    D SET("By ",RCLINE,4 6,80,17)
  13142   "RTN","RCD PBPLM",60, 0)
  13143    ;display  TP bills D ivision of  Care
  13144   "RTN","RCD PBPLM",61, 0)
  13145    I "T"=$P( $G(^PRCA(4 30.2,+RCDP DATA(430,R CBILLDA,2, "I"),0))," ^",6) D
  13146   "RTN","RCD PBPLM",62, 0)
  13147    . S RCDIV =$$DIV^IBJ DF2(RCBILL DA) I +RCD IV D
  13148   "RTN","RCD PBPLM",63, 0)
  13149    .. S RCDI V=$P($G(^D G(40.8,RCD IV,0)),U,1 ) I RCDIV= "" Q
  13150   "RTN","RCD PBPLM",64, 0)
  13151    .. S RCLI NE=RCLINE+ 1 D SET("D ivision of  Care: "_R CDIV,RCLIN E,1,80)
  13152   "RTN","RCD PBPLM",65, 0)
  13153    S RCLINE= RCLINE+1 D  SET("Resu lting From ",RCLINE,1 ,80,4.5)
  13154   "RTN","RCD PBPLM",66, 0)
  13155    I RCDPDAT A(430,RCBI LLDA,15.1, "E")'="" D
  13156   "RTN","RCD PBPLM",67, 0)
  13157    . S RCLIN E=RCLINE+1  D SET("   Type of Ca re",RCLINE ,1,80,15.1 )
  13158   "RTN","RCD PBPLM",68, 0)
  13159    S RCLINE= RCLINE+1 D  SET("         Remark ",RCLINE,1 ,80,15)
  13160   "RTN","RCD PBPLM",69, 0)
  13161    ;  displa y comments  if there
  13162   "RTN","RCD PBPLM",70, 0)
  13163    I $O(^PRC A(430,RCBI LLDA,10,0) ) D
  13164   "RTN","RCD PBPLM",71, 0)
  13165    . S RCLIN E=RCLINE+1  D SET("Co mments:",R CLINE,1,80 )
  13166   "RTN","RCD PBPLM",72, 0)
  13167    . S COMMD A=0 F  S C OMMDA=$O(^ PRCA(430,R CBILLDA,10 ,COMMDA))  Q:'COMMDA   D
  13168   "RTN","RCD PBPLM",73, 0)
  13169    .. S RCLI NE=RCLINE+ 1 D SET("   "_$G(^PRC A(430,RCBI LLDA,10,CO MMDA,0)),R CLINE,1,80 )
  13170   "RTN","RCD PBPLM",74, 0)
  13171    ;
  13172   "RTN","RCD PBPLM",75, 0)
  13173    ;  int/ad m rate and  date
  13174   "RTN","RCD PBPLM",76, 0)
  13175    S RCLINE= RCLINE+1 D  SET(" ",R CLINE,1,80 )
  13176   "RTN","RCD PBPLM",77, 0)
  13177    S DATA=$$ INT^RCMSFN 01(RCDPDAT A(430,RCBI LLDA,10,"I "))
  13178   "RTN","RCD PBPLM",78, 0)
  13179    S Y=$P(DA TA,"^",2)  I Y D DD^% DT
  13180   "RTN","RCD PBPLM",79, 0)
  13181    S RCLINE= RCLINE+1 D  SET("Inte rest Effec tive Rate  Date: "_Y, RCLINE,1,8 0)
  13182   "RTN","RCD PBPLM",80, 0)
  13183    D SET(" A nnual Rate : "_$P(DAT A,"^"),RCL INE,55,80)
  13184   "RTN","RCD PBPLM",81, 0)
  13185    S DATA=$$ ADM^RCMSFN 01(RCDPDAT A(430,RCBI LLDA,10,"I "))
  13186   "RTN","RCD PBPLM",82, 0)
  13187    S Y=$P(DA TA,"^",2)  I Y D DD^% DT
  13188   "RTN","RCD PBPLM",83, 0)
  13189    S RCLINE= RCLINE+1 D  SET("   A dmin Effec tive Rate  Date: "_Y, RCLINE,1,8 0)
  13190   "RTN","RCD PBPLM",84, 0)
  13191    D SET("Mo nthly Rate : "_$P(DAT A,"^"),RCL INE,55,80)
  13192   "RTN","RCD PBPLM",85, 0)
  13193    S RCLINE= RCLINE+1 D  SET("  La st Int/Adm in Charge  Date",RCLI NE,1,80,67 )
  13194   "RTN","RCD PBPLM",86, 0)
  13195    ;
  13196   "RTN","RCD PBPLM",87, 0)
  13197    ;  put bi ll balance s on first  line of s econd scre en
  13198   "RTN","RCD PBPLM",88, 0)
  13199    F RCLINE= RCLINE+1:1 :16 D SET( " ",RCLINE ,1,80)
  13200   "RTN","RCD PBPLM",89, 0)
  13201    ;
  13202   "RTN","RCD PBPLM",90, 0)
  13203    ;  bill d ollars
  13204   "RTN","RCD PBPLM",91, 0)
  13205    S RCLINE= RCLINE+1 D  SET(" ",R CLINE,1,80 )
  13206   "RTN","RCD PBPLM",92, 0)
  13207    S RCLINE= RCLINE+1 D  SET("Bill  Balances             Billed           Paid ",RCLINE,1 ,80,0,IOUO N,IOUOFF)
  13208   "RTN","RCD PBPLM",93, 0)
  13209    S RCLINE= RCLINE+1 D  SET("      Principal : "_$J(RCD PDATA(430, RCBILLDA,7 1,"E"),14, 2)_$J(RCDP DATA(430,R CBILLDA,77 ,"E"),14,2 ),RCLINE,1 ,80)
  13210   "RTN","RCD PBPLM",94, 0)
  13211    D SET("        Origi nal Amt: " _$J(RCDPDA TA(430,RCB ILLDA,3,"E "),11,2),R CLINE,48,8 0)
  13212   "RTN","RCD PBPLM",95, 0)
  13213    S RCLINE= RCLINE+1 D  SET("       Interest : "_$J(RCD PDATA(430, RCBILLDA,7 2,"E"),14, 2)_$J(RCDP DATA(430,R CBILLDA,78 ,"E"),14,2 ),RCLINE,1 ,80)
  13214   "RTN","RCD PBPLM",96, 0)
  13215    I $G(RCDP DATA(430,R CBILLDA,13 1,"E")) D  SET("Medic are Contr   Adj: "_$J (RCDPDATA( 430,RCBILL DA,131,"E" ),11,2),RC LINE,48,80 )
  13216   "RTN","RCD PBPLM",97, 0)
  13217    I RCDPDAT A(430,RCBI LLDA,74,"E ") D
  13218   "RTN","RCD PBPLM",98, 0)
  13219    . S RCLIN E=RCLINE+1  D SET("   Marshall F ee: "_$J(R CDPDATA(43 0,RCBILLDA ,74,"E"),1 4,2)_$J(RC DPDATA(430 ,RCBILLDA, 79.1,"E"), 14,2),RCLI NE,1,80)
  13220   "RTN","RCD PBPLM",99, 0)
  13221    I RCDPDAT A(430,RCBI LLDA,75,"E ") D
  13222   "RTN","RCD PBPLM",100 ,0)
  13223    . S RCLIN E=RCLINE+1  D SET("     Court Co st: "_$J(R CDPDATA(43 0,RCBILLDA ,75,"E"),1 4,2),RCLIN E,1,80)
  13224   "RTN","RCD PBPLM",101 ,0)
  13225    S RCLINE= RCLINE+1 D  SET("Admi nistrative : "_$J(RCD PDATA(430, RCBILLDA,7 3,"E"),14, 2)_$J(RCDP DATA(430,R CBILLDA,79 ,"E"),14,2 ),RCLINE,1 ,80,0,IOUO N,IOUOFF)
  13226   "RTN","RCD PBPLM",102 ,0)
  13227    I $G(RCDP DATA(430,R CBILLDA,13 2,"E")) D  SET("Medic are Unreim  Exp: "_$J (RCDPDATA( 430,RCBILL DA,132,"E" ),11,2),RC LINE,48,80 )
  13228   "RTN","RCD PBPLM",103 ,0)
  13229    ;  comput e totals
  13230   "RTN","RCD PBPLM",104 ,0)
  13231    S BILLED= 0 F %=71,7 2,73,74,75  S BILLED= BILLED+RCD PDATA(430, RCBILLDA,% ,"E")
  13232   "RTN","RCD PBPLM",105 ,0)
  13233    S PAID=0  F %=77,78, 79,79.1 S  PAID=PAID+ RCDPDATA(4 30,RCBILLD A,%,"E")
  13234   "RTN","RCD PBPLM",106 ,0)
  13235    S RCLINE= RCLINE+1 D  SET("        Current : "_$J(BIL LED,14,2)_ $J(PAID,14 ,2),RCLINE ,1,80)
  13236   "RTN","RCD PBPLM",107 ,0)
  13237    ;
  13238   "RTN","RCD PBPLM",108 ,0)
  13239    ;  show r efund if t here
  13240   "RTN","RCD PBPLM",109 ,0)
  13241    I RCDPDAT A(430,RCBI LLDA,79.18 ,"E") D
  13242   "RTN","RCD PBPLM",110 ,0)
  13243    . S RCLIN E=RCLINE+1  D SET(" " ,RCLINE,1, 80)
  13244   "RTN","RCD PBPLM",111 ,0)
  13245    . S RCLIN E=RCLINE+1  D SET("Re funded Amo unt",RCLIN E,1,80,79. 18)
  13246   "RTN","RCD PBPLM",112 ,0)
  13247    . D SET(" Date",RCLI NE,27,80,7 9.19)
  13248   "RTN","RCD PBPLM",113 ,0)
  13249    . D SET(" By",RCLINE ,50,80,79. 21)
  13250   "RTN","RCD PBPLM",114 ,0)
  13251    ;
  13252   "RTN","RCD PBPLM",115 ,0)
  13253    ;  accoun ting data
  13254   "RTN","RCD PBPLM",116 ,0)
  13255    S RCLINE= RCLINE+1 D  SET(" ",R CLINE,1,80 )
  13256   "RTN","RCD PBPLM",117 ,0)
  13257    S RCLINE= RCLINE+1 D  SET("Acco unting Dat a",RCLINE, 1,80,0,IOU ON,IOUOFF)
  13258   "RTN","RCD PBPLM",118 ,0)
  13259    ;  fiscal  year mult iple
  13260   "RTN","RCD PBPLM",119 ,0)
  13261    D SET("Fi scal Year" ,RCLINE,20 ,32,0,IOUO N,IOUOFF)
  13262   "RTN","RCD PBPLM",120 ,0)
  13263    D SET("Ap prop Code" ,RCLINE,34 ,46,0,IOUO N,IOUOFF)
  13264   "RTN","RCD PBPLM",121 ,0)
  13265    D SET("Am ount",RCLI NE,50,60,0 ,IOUON,IOU OFF)
  13266   "RTN","RCD PBPLM",122 ,0)
  13267    S RCFYDA= 0 F  S RCF YDA=$O(^PR CA(430,RCB ILLDA,2,RC FYDA)) Q:' RCFYDA  D
  13268   "RTN","RCD PBPLM",123 ,0)
  13269    . S DATA= $G(^PRCA(4 30,RCBILLD A,2,RCFYDA ,0))
  13270   "RTN","RCD PBPLM",124 ,0)
  13271    . S RCLIN E=RCLINE+1
  13272   "RTN","RCD PBPLM",125 ,0)
  13273    . D SET($ J($P(DATA, "^"),30),R CLINE,1,80 )     ;fis cal year
  13274   "RTN","RCD PBPLM",126 ,0)
  13275    . D SET($ J(RCDPDATA (430,RCBIL LDA,203,"E "),6),RCLI NE,39,45)  ;fund
  13276   "RTN","RCD PBPLM",127 ,0)
  13277    . D SET($ J($P(DATA, "^",2),8,2 ),RCLINE,4 8,80)   ;a mount
  13278   "RTN","RCD PBPLM",128 ,0)
  13279    ; determi ne which r sc to disp lay
  13280   "RTN","RCD PBPLM",129 ,0)
  13281    S %=RCDPD ATA(430,RC BILLDA,255 .1,"E") I  %="" S %=R CDPDATA(43 0,RCBILLDA ,255,"E")
  13282   "RTN","RCD PBPLM",130 ,0)
  13283    S RCLINE= RCLINE+1 D  SET("Rev  Srce Code:  "_%,RCLIN E,1,80)
  13284   "RTN","RCD PBPLM",131 ,0)
  13285    ;
  13286   "RTN","RCD PBPLM",132 ,0)
  13287    ;  collec tion data
  13288   "RTN","RCD PBPLM",133 ,0)
  13289    S RCLINE= RCLINE+1 D  SET(" ",R CLINE,1,80 )
  13290   "RTN","RCD PBPLM",134 ,0)
  13291    S RCLINE= RCLINE+1 D  SET("Coll ection Fol low up Dat a",RCLINE, 1,80,0,IOU ON,IOUOFF)
  13292   "RTN","RCD PBPLM",135 ,0)
  13293    S RCLINE= RCLINE+1 D  SET("         Letter 1",RCLINE, 1,80,61)
  13294   "RTN","RCD PBPLM",136 ,0)
  13295    S RCLINE= RCLINE+1 D  SET("         Letter 2",RCLINE, 1,80,62)
  13296   "RTN","RCD PBPLM",137 ,0)
  13297    S RCLINE= RCLINE+1 D  SET("         Letter 3",RCLINE, 1,80,63)
  13298   "RTN","RCD PBPLM",138 ,0)
  13299    S RCLINE= RCLINE+1 D  SET("         Letter 4",RCLINE, 1,80,68)
  13300   "RTN","RCD PBPLM",139 ,0)
  13301    I RCDPDAT A(430,RCBI LLDA,68.6, "I") D
  13302   "RTN","RCD PBPLM",140 ,0)
  13303    . S RCLIN E=RCLINE+1  D SET("      IRS Let ter",RCLIN E,1,80,68. 6)
  13304   "RTN","RCD PBPLM",141 ,0)
  13305    . D SET(" Amount",RC LINE,65,80 ,68.93)
  13306   "RTN","RCD PBPLM",142 ,0)
  13307    I RCDPDAT A(430,RCBI LLDA,64,"I ") D
  13308   "RTN","RCD PBPLM",143 ,0)
  13309    . S RCLIN E=RCLINE+1  D SET("DC /DOJ Ref D ate",RCLIN E,1,80,64)
  13310   "RTN","RCD PBPLM",144 ,0)
  13311    . D SET(" To",RCLINE ,40,80,65)
  13312   "RTN","RCD PBPLM",145 ,0)
  13313    . D SET(" Amount",RC LINE,65,80 ,66)
  13314   "RTN","RCD PBPLM",146 ,0)
  13315    ;
  13316   "RTN","RCD PBPLM",147 ,0)
  13317   BILLRJ ;== ==== BILL  PROFILE RE JECT INSER TED HERE ; LEG
  13318   "RTN","RCD PBPLM",148 ,0)
  13319    I $D(^PRC A(430,RCBI LLDA,18))  D REJECT^R CDPBPLI ;  prca*4.5*3 01
  13320   "RTN","RCD PBPLM",149 ,0)
  13321    ;
  13322   "RTN","RCD PBPLM",150 ,0)
  13323    ;  repaym ent plan ( show only  if there)
  13324   "RTN","RCD PBPLM",151 ,0)
  13325    I RCDPDAT A(430,RCBI LLDA,41,"I ") D REPAY ^RCDPBPLI
  13326   "RTN","RCD PBPLM",152 ,0)
  13327    ;
  13328   "RTN","RCD PBPLM",153 ,0)
  13329    ;  irs da ta (show o nly if the re)
  13330   "RTN","RCD PBPLM",154 ,0)
  13331    I RCDPDAT A(430,RCBI LLDA,68.7, "I") D IRS ^RCDPBPLI
  13332   "RTN","RCD PBPLM",155 ,0)
  13333    ;
  13334   "RTN","RCD PBPLM",156 ,0)
  13335    ;  dmc da ta (show o nly if the re)
  13336   "RTN","RCD PBPLM",157 ,0)
  13337    I RCDPDAT A(430,RCBI LLDA,121," I") D DMC^ RCDPBPLI
  13338   "RTN","RCD PBPLM",158 ,0)
  13339    ;
  13340   "RTN","RCD PBPLM",159 ,0)
  13341    ;  top da ta (show o nly if the re)
  13342   "RTN","RCD PBPLM",160 ,0)
  13343    I $G(RCDP DATA(430,R CBILLDA,14 1,"I")) D  TOP^RCDPBP LI
  13344   "RTN","RCD PBPLM",161 ,0)
  13345    ;
  13346   "RTN","RCD PBPLM",162 ,0)
  13347    ;
  13348   "RTN","RCD PBPLM",163 ,0)
  13349    ;  cross- servicing  referral d ata(show o nly if the re)
  13350   "RTN","RCD PBPLM",164 ,0)
  13351    I $G(RCDP DATA(430,R CBILLDA,15 1,"I")) D  TCSP^RCDPB PLI
  13352   "RTN","RCD PBPLM",165 ,0)
  13353    ;
  13354   "RTN","RCD PBPLM",166 ,0)
  13355    ;
  13356   "RTN","RCD PBPLM",167 ,0)
  13357    ;  cross- servicing  recall dat a(show onl y if there )
  13358   "RTN","RCD PBPLM",168 ,0)
  13359    I $G(RCDP DATA(430,R CBILLDA,15 2,"I"))!$G (RCDPDATA( 430,RCBILL DA,153,"I" ))!$G(RCDP DATA(430,R CBILLDA,15 4,"I")) D  TCSPRC^RCD PBPLI
  13360   "RTN","RCD PBPLM",169 ,0)
  13361    ;
  13362   "RTN","RCD PBPLM",170 ,0)
  13363    ;
  13364   "RTN","RCD PBPLM",171 ,0)
  13365    ;  get th e report t ype based  on categor y.  if thi rd party s how
  13366   "RTN","RCD PBPLM",172 ,0)
  13367    ;  insura nce data
  13368   "RTN","RCD PBPLM",173 ,0)
  13369    S REPTYPE =$P($G(^PR CA(430.2,+ RCDPDATA(4 30,RCBILLD A,2,"I"),0 )),"^",6)
  13370   "RTN","RCD PBPLM",174 ,0)
  13371    I REPTYPE ="T" D INS UR^RCDPBPL I
  13372   "RTN","RCD PBPLM",175 ,0)
  13373    ;
  13374   "RTN","RCD PBPLM",176 ,0)
  13375    ;  report  type for  employee o r vendor,  show descr iption fie ld 106
  13376   "RTN","RCD PBPLM",177 ,0)
  13377    I REPTYPE ="O"!(REPT YPE="V") D  INIT^RCDP BPLI
  13378   "RTN","RCD PBPLM",178 ,0)
  13379    ;
  13380   "RTN","RCD PBPLM",179 ,0)
  13381    ;  show t ransaction s and reas ons
  13382   "RTN","RCD PBPLM",180 ,0)
  13383    D TRANINI T^RCDPBPLI
  13384   "RTN","RCD PBPLM",181 ,0)
  13385    ;
  13386   "RTN","RCD PBPLM",182 ,0)
  13387    ;  set va lmcnt to n umber of l ines in th e list
  13388   "RTN","RCD PBPLM",183 ,0)
  13389    S VALMCNT =RCLINE
  13390   "RTN","RCD PBPLM",184 ,0)
  13391    D HDR
  13392   "RTN","RCD PBPLM",185 ,0)
  13393    Q
  13394   "RTN","RCD PBPLM",186 ,0)
  13395    ;
  13396   "RTN","RCD PBPLM",187 ,0)
  13397    ;
  13398   "RTN","RCD PBPLM",188 ,0)
  13399   HDR ;  hea der code f or list ma nager disp lay
  13400   "RTN","RCD PBPLM",189 ,0)
  13401    ;  requir es rcbilld a
  13402   "RTN","RCD PBPLM",190 ,0)
  13403    S VALMHDR (1)="*****  ACCOUNTS  RECEIVABLE  BILL PROF ILE FOR "_ $P($G(^PRC A(430,RCBI LLDA,0))," ^")_" **** *"
  13404   "RTN","RCD PBPLM",191 ,0)
  13405    ; PRCA*4. 5*276 - ad d explanat ion of '%'  for the u ser
  13406   "RTN","RCD PBPLM",192 ,0)
  13407    S VALMSG= "|% EEOB |  Enter ??  for more a ctions|" ;  PRCA*4.5* 276
  13408   "RTN","RCD PBPLM",193 ,0)
  13409    Q
  13410   "RTN","RCD PBPLM",194 ,0)
  13411    ;
  13412   "RTN","RCD PBPLM",195 ,0)
  13413    ;
  13414   "RTN","RCD PBPLM",196 ,0)
  13415   EXIT ;  ex it list ma nager opti on and cle an up
  13416   "RTN","RCD PBPLM",197 ,0)
  13417    K ^TMP("R CDPBPLM",$ J)
  13418   "RTN","RCD PBPLM",198 ,0)
  13419    Q
  13420   "RTN","RCD PBPLM",199 ,0)
  13421    ;
  13422   "RTN","RCD PBPLM",200 ,0)
  13423    ;
  13424   "RTN","RCD PBPLM",201 ,0)
  13425   SET(STRING ,LINE,COLB EG,COLEND, FIELD,ON,O FF) ;  set  array
  13426   "RTN","RCD PBPLM",202 ,0)
  13427    I $G(FIEL D) S STRIN G=STRING_$ S(STRING=" ":"",1:":  ")_$G(RCDP DATA(430,R CBILLDA,FI ELD,"E"))
  13428   "RTN","RCD PBPLM",203 ,0)
  13429    I STRING= "",'$G(FIE LD) Q
  13430   "RTN","RCD PBPLM",204 ,0)
  13431    I '$D(@VA LMAR@(LINE ,0)) D SET ^VALM10(LI NE,$J("",8 0))
  13432   "RTN","RCD PBPLM",205 ,0)
  13433    D SET^VAL M10(LINE,$ $SETSTR^VA LM1(STRING ,@VALMAR@( LINE,0),CO LBEG,COLEN D-COLBEG+1 ))
  13434   "RTN","RCD PBPLM",206 ,0)
  13435    I $G(ON)] ""!($G(OFF )]"") D CN TRL^VALM10 (LINE,COLB EG,$L(STRI NG),ON,OFF )
  13436   "RTN","RCD PBPLM",207 ,0)
  13437    Q
  13438   "RTN","RCD PBPLM",208 ,0)
  13439    ;
  13440   "RTN","RCD PBPLM",209 ,0)
  13441    ;
  13442   "RTN","RCD PBPLM",210 ,0)
  13443   DIQ430(DA, DR) ;  diq  call to r etrieve da ta for dr  fields in  file 430
  13444   "RTN","RCD PBPLM",211 ,0)
  13445    N D0,DIC, DIQ,DIQ2
  13446   "RTN","RCD PBPLM",212 ,0)
  13447    K RCDPDAT A(430,DA)
  13448   "RTN","RCD PBPLM",213 ,0)
  13449    S DIQ(0)= "IE",DIC=" ^PRCA(430, ",DIQ="RCD PDATA" D E N^DIQ1
  13450   "RTN","RCD PBPLM",214 ,0)
  13451    Q
  13452   "RTN","RCD PBTLM")
  13453   0^34^B5228 0967^B4947 6140
  13454   "RTN","RCD PBTLM",1,0 )
  13455   RCDPBTLM ; WISC/RFJ -  bill tran sactions L ist Manage r top rout ine ;1 Jun  99
  13456   "RTN","RCD PBTLM",2,0 )
  13457    ;;4.5;Acc ounts Rece ivable;**1 14,148,153 ,168,169,1 98,247,271 ,276,315** ;Mar 20, 1 995;Build  55
  13458   "RTN","RCD PBTLM",3,0 )
  13459    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  13460   "RTN","RCD PBTLM",4,0 )
  13461    ;
  13462   "RTN","RCD PBTLM",5,0 )
  13463    ; Referen ce to $$RE C^IBRFN su pported by  DBIA 2031
  13464   "RTN","RCD PBTLM",6,0 )
  13465    ;
  13466   "RTN","RCD PBTLM",7,0 )
  13467    ;  called  from menu  option (1 9)
  13468   "RTN","RCD PBTLM",8,0 )
  13469    ;
  13470   "RTN","RCD PBTLM",9,0 )
  13471    N RCBILLD A,RCDPFXIT
  13472   "RTN","RCD PBTLM",10, 0)
  13473    ;
  13474   "RTN","RCD PBTLM",11, 0)
  13475    F  D  Q:' RCBILLDA
  13476   "RTN","RCD PBTLM",12, 0)
  13477    .   W !!  S RCBILLDA =$$SELBILL
  13478   "RTN","RCD PBTLM",13, 0)
  13479    .   I RCB ILLDA<1 S  RCBILLDA=0  Q
  13480   "RTN","RCD PBTLM",14, 0)
  13481    .   D EN^ VALM("RCDP  TRANSACTI ONS LIST")
  13482   "RTN","RCD PBTLM",15, 0)
  13483    .   ;  fa st exit
  13484   "RTN","RCD PBTLM",16, 0)
  13485    .   I $G( RCDPFXIT)  S RCBILLDA =0
  13486   "RTN","RCD PBTLM",17, 0)
  13487    Q
  13488   "RTN","RCD PBTLM",18, 0)
  13489    ;
  13490   "RTN","RCD PBTLM",19, 0)
  13491    ;
  13492   "RTN","RCD PBTLM",20, 0)
  13493   INIT ;  in itializati on for lis t manager  list
  13494   "RTN","RCD PBTLM",21, 0)
  13495    ;  requir es rcbilld a
  13496   "RTN","RCD PBTLM",22, 0)
  13497    ;  PRCA*3 .5*315 - R eplaced "^ " with VA  Standard V ariable U  throughout
  13498   "RTN","RCD PBTLM",23, 0)
  13499    N ADMIN,D ATE,RCLINE ,RCLIST,RC TOTAL,RCTR AN,RCTRAND A
  13500   "RTN","RCD PBTLM",24, 0)
  13501    K ^TMP("R CDPBTLM",$ J),^TMP("V ALM VIDEO" ,$J)
  13502   "RTN","RCD PBTLM",25, 0)
  13503    ;
  13504   "RTN","RCD PBTLM",26, 0)
  13505    ;  fast e xit
  13506   "RTN","RCD PBTLM",27, 0)
  13507    I $G(RCDP FXIT) S VA LMQUIT=1 Q
  13508   "RTN","RCD PBTLM",28, 0)
  13509    ;
  13510   "RTN","RCD PBTLM",29, 0)
  13511    ;  set th e List Man ager line  number
  13512   "RTN","RCD PBTLM",30, 0)
  13513    S RCLINE= 0
  13514   "RTN","RCD PBTLM",31, 0)
  13515    ;  set th e List Man ager trans action num ber
  13516   "RTN","RCD PBTLM",32, 0)
  13517    S RCTRAN= 0
  13518   "RTN","RCD PBTLM",33, 0)
  13519    ;
  13520   "RTN","RCD PBTLM",34, 0)
  13521    ;  get tr ansactions  and balan ce for bil l
  13522   "RTN","RCD PBTLM",35, 0)
  13523    S RCTOTAL =$$GETTRAN S(RCBILLDA )
  13524   "RTN","RCD PBTLM",36, 0)
  13525    ;
  13526   "RTN","RCD PBTLM",37, 0)
  13527    S DATE=""  F  S DATE =$O(RCLIST (DATE)) Q: 'DATE  D
  13528   "RTN","RCD PBTLM",38, 0)
  13529    .   S RCT RANDA="" F   S RCTRAN DA=$O(RCLI ST(DATE,RC TRANDA)) Q :RCTRANDA= ""  D
  13530   "RTN","RCD PBTLM",39, 0)
  13531    .   .   S  RCLINE=RC LINE+1
  13532   "RTN","RCD PBTLM",40, 0)
  13533    .   .   ;
  13534   "RTN","RCD PBTLM",41, 0)
  13535    .   .   ;   create a n index ar ray for tr ansaction  lookup in  list
  13536   "RTN","RCD PBTLM",42, 0)
  13537    .   .   I  RCTRANDA  D
  13538   "RTN","RCD PBTLM",43, 0)
  13539    .   .   .    S RCTRA N=RCTRAN+1
  13540   "RTN","RCD PBTLM",44, 0)
  13541    .   .   .    S ^TMP( "RCDPBTLM" ,$J,"IDX", RCTRAN,RCT RAN)=RCTRA NDA
  13542   "RTN","RCD PBTLM",45, 0)
  13543    .   .   .    D SET^R CDPAPLI(RC TRAN,RCLIN E,1,80,0,I ORVON,IORV OFF)
  13544   "RTN","RCD PBTLM",46, 0)
  13545    .   .   ;
  13546   "RTN","RCD PBTLM",47, 0)
  13547    .   .   D  SET^RCDPA PLI($S(RCT RANDA:RCTR ANDA,1:" " ),RCLINE,6 ,80) ; PRC A*4.5*315  Incr left  margin
  13548   "RTN","RCD PBTLM",48, 0)
  13549    .   .   D  SET^RCDPA PLI($E(DAT E,4,5)_"/" _$E(DATE,6 ,7)_"/"_$E (DATE,2,3) ,RCLINE,13 ,21)
  13550   "RTN","RCD PBTLM",49, 0)
  13551    .   .   D  SET^RCDPA PLI($TR($P (RCLIST(DA TE,RCTRAND A),U),"ABC DEFGHIJKLM NOPQRSTUVW XYZ","abcd efghijklmn opqrstuvwx yz"),RCLIN E,25,50)
  13552   "RTN","RCD PBTLM",50, 0)
  13553    .   .   D  SET^RCDPA PLI($J($P( RCLIST(DAT E,RCTRANDA ),U,2),9,2 ),RCLINE,5 3,62)
  13554   "RTN","RCD PBTLM",51, 0)
  13555    .   .   D  SET^RCDPA PLI($J($P( RCLIST(DAT E,RCTRANDA ),U,3),9,2 ),RCLINE,6 2,71)
  13556   "RTN","RCD PBTLM",52, 0)
  13557    .   .   ;   add mars hal fee an d court co st to crea te admin d ollars
  13558   "RTN","RCD PBTLM",53, 0)
  13559    .   .   S  ADMIN=$P( RCLIST(DAT E,RCTRANDA ),U,4)+$P( RCLIST(DAT E,RCTRANDA ),U,5)+$P( RCLIST(DAT E,RCTRANDA ),U,6)
  13560   "RTN","RCD PBTLM",54, 0)
  13561    .   .   D  SET^RCDPA PLI($J(ADM IN,9,2),RC LINE,71,80 )
  13562   "RTN","RCD PBTLM",55, 0)
  13563    ;
  13564   "RTN","RCD PBTLM",56, 0)
  13565    ;  show t otals
  13566   "RTN","RCD PBTLM",57, 0)
  13567    S RCLINE= RCLINE+1
  13568   "RTN","RCD PBTLM",58, 0)
  13569    D SET^RCD PAPLI("                                                         - -------- - ------- -- ------",RC LINE,1,80)
  13570   "RTN","RCD PBTLM",59, 0)
  13571    S RCLINE= RCLINE+1
  13572   "RTN","RCD PBTLM",60, 0)
  13573    D SET^RCD PAPLI("    TOTAL BALA NCE FOR BI LL",RCLINE ,1,80)
  13574   "RTN","RCD PBTLM",61, 0)
  13575    D SET^RCD PAPLI($J($ P(RCTOTAL, U,1),9,2), RCLINE,53, 62)
  13576   "RTN","RCD PBTLM",62, 0)
  13577    D SET^RCD PAPLI($J($ P(RCTOTAL, U,2),9,2), RCLINE,62, 71)
  13578   "RTN","RCD PBTLM",63, 0)
  13579    D SET^RCD PAPLI($J($ P(RCTOTAL, U,3)+$P(RC TOTAL,U,4) +$P(RCTOTA L,U,5),9,2 ),RCLINE,7 1,80)
  13580   "RTN","RCD PBTLM",64, 0)
  13581    ;
  13582   "RTN","RCD PBTLM",65, 0)
  13583    ;  compar e totals t o what is  stored in  the file
  13584   "RTN","RCD PBTLM",66, 0)
  13585    N RCDATA7 ,RCFOUT
  13586   "RTN","RCD PBTLM",67, 0)
  13587    S RCDATA7 =$G(^PRCA( 430,RCBILL DA,7))
  13588   "RTN","RCD PBTLM",68, 0)
  13589    ;  for a  write-off  bill, the  balance sh ould equal  all zeros , for
  13590   "RTN","RCD PBTLM",69, 0)
  13591    ;  these  bills, nod e 7 is the  write-off  amount, s o for the  out of
  13592   "RTN","RCD PBTLM",70, 0)
  13593    ;  balanc e check to  work, nod e 7 needs  to be adju sted to al l zeros
  13594   "RTN","RCD PBTLM",71, 0)
  13595    I $P(^PRC A(430,RCBI LLDA,0),U, 8)=23 S RC DATA7="0^0 ^0^0^0"
  13596   "RTN","RCD PBTLM",72, 0)
  13597    I +$P(RCD ATA7,U,1)' =+$P(RCTOT AL,U,1) S  RCFOUT=1
  13598   "RTN","RCD PBTLM",73, 0)
  13599    I +$P(RCD ATA7,U,2)' =+$P(RCTOT AL,U,2) S  RCFOUT=1
  13600   "RTN","RCD PBTLM",74, 0)
  13601    I ($P(RCD ATA7,U,3)+ $P(RCDATA7 ,U,4)+$P(R CDATA7,U,5 ))'=+$P(RC TOTAL,U,3)  S RCFOUT= 1
  13602   "RTN","RCD PBTLM",75, 0)
  13603    I $G(RCFO UT) D
  13604   "RTN","RCD PBTLM",76, 0)
  13605    .   S RCL INE=RCLINE +1
  13606   "RTN","RCD PBTLM",77, 0)
  13607    .   D SET ^RCDPAPLI( " ",RCLINE ,1,80)
  13608   "RTN","RCD PBTLM",78, 0)
  13609    .   S RCL INE=RCLINE +1
  13610   "RTN","RCD PBTLM",79, 0)
  13611    .   D SET ^RCDPAPLI( "  STORED  BALANCE FO R BILL (**  INCORRECT  **)",RCLI NE,1,80)
  13612   "RTN","RCD PBTLM",80, 0)
  13613    .   D SET ^RCDPAPLI( $J($P(RCDA TA7,U,1),9 ,2),RCLINE ,53,62)
  13614   "RTN","RCD PBTLM",81, 0)
  13615    .   D SET ^RCDPAPLI( $J($P(RCDA TA7,U,2),9 ,2),RCLINE ,62,71)
  13616   "RTN","RCD PBTLM",82, 0)
  13617    .   D SET ^RCDPAPLI( $J($P(RCDA TA7,U,3)+$ P(RCDATA7, U,4)+$P(RC DATA7,U,5) ,9,2),RCLI NE,71,80)
  13618   "RTN","RCD PBTLM",83, 0)
  13619    ;
  13620   "RTN","RCD PBTLM",84, 0)
  13621    ;  set va lmcnt to n umber of l ines in th e list
  13622   "RTN","RCD PBTLM",85, 0)
  13623    S VALMCNT =RCLINE
  13624   "RTN","RCD PBTLM",86, 0)
  13625    D HDR
  13626   "RTN","RCD PBTLM",87, 0)
  13627    Q
  13628   "RTN","RCD PBTLM",88, 0)
  13629    ;
  13630   "RTN","RCD PBTLM",89, 0)
  13631    ;
  13632   "RTN","RCD PBTLM",90, 0)
  13633   HDR ;  hea der code f or list ma nager disp lay
  13634   "RTN","RCD PBTLM",91, 0)
  13635    ;  requir es rcbilld a
  13636   "RTN","RCD PBTLM",92, 0)
  13637    N %,DATA, RCDEBTDA,R CDPDATA
  13638   "RTN","RCD PBTLM",93, 0)
  13639    ;
  13640   "RTN","RCD PBTLM",94, 0)
  13641    D DIQ430^ RCDPBPLM(R CBILLDA,". 01;8;")
  13642   "RTN","RCD PBTLM",95, 0)
  13643    ;
  13644   "RTN","RCD PBTLM",96, 0)
  13645    S RCDEBTD A=$P(^PRCA (430,RCBIL LDA,0),U,9 )
  13646   "RTN","RCD PBTLM",97, 0)
  13647    S DATA=$$ ACCNTHDR^R CDPAPLM(RC DEBTDA)
  13648   "RTN","RCD PBTLM",98, 0)
  13649    ;
  13650   "RTN","RCD PBTLM",99, 0)
  13651    S %="",$P (%," ",80) =""
  13652   "RTN","RCD PBTLM",100 ,0)
  13653    ; PRCA*4. 5*276 - ge t EEOB ind icator for  1st/3rd p arty payme nt and att ach to bil l when app licable
  13654   "RTN","RCD PBTLM",101 ,0)
  13655    S PRCOUT= $$COMP3^PR CAAPR(RCBI LLDA)
  13656   "RTN","RCD PBTLM",102 ,0)
  13657    I PRCOUT' ="%" S PRC OUT=$$IBEE OBCK^PRCAA PR1(RCBILL DA)
  13658   "RTN","RCD PBTLM",103 ,0)
  13659    S VALMHDR (1)=$E("Bi ll #: "_$G (PRCOUT)_$ G(RCDPDATA (430,RCBIL LDA,.01,"E "))_%,1,25 )_"Account : "_$P(DAT A,U)_$P(DA TA,U,2)
  13660   "RTN","RCD PBTLM",104 ,0)
  13661    S VALMHDR (2)=$E("St atus: "_$G (RCDPDATA( 430,RCBILL DA,8,"E")) _%,1,25)_$ E("   Addr : "_$P(DAT A,U,4)_",  "_$P(DATA, U,7)_", "_ $P(DATA,U, 8)_"  "_$P (DATA,U,9) _%,1,55)
  13662   "RTN","RCD PBTLM",105 ,0)
  13663    ; PRCA*4. 5*276 - sh ow caption  for user
  13664   "RTN","RCD PBTLM",106 ,0)
  13665    S VALMSG= "|% EEOB |  Enter ??  for more a ctions |"  ; PRCA*4.5 *276
  13666   "RTN","RCD PBTLM",107 ,0)
  13667    Q
  13668   "RTN","RCD PBTLM",108 ,0)
  13669    S VALMHDR (3)="  "_I ORVON_$E(" Bill Balan ce: "_$J($ P(RCTOTAL, U)+$P(RCTO TAL,U,2)+$ P(RCTOTAL, U,3)+$P(RC TOTAL,U,4) +$P(RCTOTA L,U,5),0,2 )_%,1,23)_ IORVOFF_"   Phone: "_ $P(DATA,U, 10)
  13670   "RTN","RCD PBTLM",109 ,0)
  13671    Q
  13672   "RTN","RCD PBTLM",110 ,0)
  13673    ;
  13674   "RTN","RCD PBTLM",111 ,0)
  13675    ;
  13676   "RTN","RCD PBTLM",112 ,0)
  13677   EXIT ;  ex it list ma nager opti on and cle an up
  13678   "RTN","RCD PBTLM",113 ,0)
  13679    K ^TMP("R CDPBTLM",$ J),^TMP("R CDPBTLMX", $J)
  13680   "RTN","RCD PBTLM",114 ,0)
  13681    Q
  13682   "RTN","RCD PBTLM",115 ,0)
  13683    ;
  13684   "RTN","RCD PBTLM",116 ,0)
  13685    ;
  13686   "RTN","RCD PBTLM",117 ,0)
  13687   SELBILL()  ;  select  a bill
  13688   "RTN","RCD PBTLM",118 ,0)
  13689    ;  return s -1 for t imeout or  ^, 0 for n o selectio n, or ien  of bill
  13690   "RTN","RCD PBTLM",119 ,0)
  13691    N %,%Y,C, DIC,DTOUT, DUOUT,RCBE FLUP,X,Y
  13692   "RTN","RCD PBTLM",120 ,0)
  13693    N DPTNOFZ Y,DPTNOFZK  S (DPTNOF ZY,DPTNOFZ K)=1
  13694   "RTN","RCD PBTLM",121 ,0)
  13695    N RCY,DIR ,DIRUT
  13696   "RTN","RCD PBTLM",122 ,0)
  13697    ; allow u ser to get  the recor d using bi ll# or ECM E#
  13698   "RTN","RCD PBTLM",123 ,0)
  13699    S DIR("A" )="Select  (B)ILL or  (E)CME#: "
  13700   "RTN","RCD PBTLM",124 ,0)
  13701    S DIR(0)= "SA^B:BILL  NUMBER;E: ECME#"
  13702   "RTN","RCD PBTLM",125 ,0)
  13703    S DIR("B" )="B"
  13704   "RTN","RCD PBTLM",126 ,0)
  13705    D ^DIR K  DIR I $D(D IRUT) Q 0
  13706   "RTN","RCD PBTLM",127 ,0)
  13707    S RCY=Y
  13708   "RTN","RCD PBTLM",128 ,0)
  13709    I RCY="E"  Q $$SELEC ME
  13710   "RTN","RCD PBTLM",129 ,0)
  13711    S DIC="^P RCA(430,", DIC(0)="QE AM",DIC("A ")="Select  BILL: "
  13712   "RTN","RCD PBTLM",130 ,0)
  13713    S DIC("W" )="D DICW^ RCBEUBI1"
  13714   "RTN","RCD PBTLM",131 ,0)
  13715    ;  specia l lookup o n input
  13716   "RTN","RCD PBTLM",132 ,0)
  13717    S RCBEFLU P=1
  13718   "RTN","RCD PBTLM",133 ,0)
  13719    D ^DIC
  13720   "RTN","RCD PBTLM",134 ,0)
  13721    I Y<0,'$G (DUOUT),'$ G(DTOUT) S  Y=0
  13722   "RTN","RCD PBTLM",135 ,0)
  13723    Q +Y
  13724   "RTN","RCD PBTLM",136 ,0)
  13725    ;
  13726   "RTN","RCD PBTLM",137 ,0)
  13727    ;
  13728   "RTN","RCD PBTLM",138 ,0)
  13729   GETTRANS(B ILLDA) ;   original a mount goes  first for  bill
  13730   "RTN","RCD PBTLM",139 ,0)
  13731    ;  return s list of  transactio ns in
  13732   "RTN","RCD PBTLM",140 ,0)
  13733    ;  rclist (date,tran da)=tranty pe ^ princ iple ^ int erest ^ ad min
  13734   "RTN","RCD PBTLM",141 ,0)
  13735    ;  return s principl e balance  ^ interest  balance ^  admin bal ance
  13736   "RTN","RCD PBTLM",142 ,0)
  13737    ;         ^ marshall  fee balan ce ^ court  cost bala nce
  13738   "RTN","RCD PBTLM",143 ,0)
  13739    N %,ADMBA L,AMTDISP, CCBAL,DATA 0,DATA1,DA TE,INTBAL, MFBAL,PRIN BAL,RCDPDA TA,RCUSER, TRANDA,VAL UE
  13740   "RTN","RCD PBTLM",144 ,0)
  13741    ;
  13742   "RTN","RCD PBTLM",145 ,0)
  13743    D DIQ430^ RCDPBPLM(B ILLDA,"3;6 0;")
  13744   "RTN","RCD PBTLM",146 ,0)
  13745    ;
  13746   "RTN","RCD PBTLM",147 ,0)
  13747    K RCLIST
  13748   "RTN","RCD PBTLM",148 ,0)
  13749    S (ADMBAL ,CCBAL,INT BAL,MFBAL, PRINBAL)=0
  13750   "RTN","RCD PBTLM",149 ,0)
  13751    S PRINBAL =RCDPDATA( 430,BILLDA ,3,"I")
  13752   "RTN","RCD PBTLM",150 ,0)
  13753    ;  loop t ransaction  and add t o list
  13754   "RTN","RCD PBTLM",151 ,0)
  13755    S TRANDA= 0 F  S TRA NDA=$O(^PR CA(433,"C" ,BILLDA,TR ANDA)) Q:' TRANDA  D
  13756   "RTN","RCD PBTLM",152 ,0)
  13757    .   S DAT A0=$G(^PRC A(433,TRAN DA,0))  ;P RCA*4.5*31 5 Needed f or User ID
  13758   "RTN","RCD PBTLM",153 ,0)
  13759    .   S RCU SER=$P(DAT A0,U,9)  ; PRCA*4.5*3 15
  13760   "RTN","RCD PBTLM",154 ,0)
  13761    .   S RCU SER=$$GET1 ^DIQ(200,R CUSER_",", 1)  ;PRCA* 4.5*315 
  13762   "RTN","RCD PBTLM",155 ,0)
  13763    .   S DAT A1=$G(^PRC A(433,TRAN DA,1))
  13764   "RTN","RCD PBTLM",156 ,0)
  13765    .   S DAT E=$P(DATA1 ,U,9) I 'D ATE Q
  13766   "RTN","RCD PBTLM",157 ,0)
  13767    .   S VAL UE=$$TRANV ALU(TRANDA )  ;PRCA*4 .5*315 (wa s I VALUE= "" Q)
  13768   "RTN","RCD PBTLM",158 ,0)
  13769    .   S RCL IST($P(DAT E,"."),TRA NDA)=$P($G (^PRCA(430 .3,+$P(DAT A1,U,2),0) ),U)_VALUE
  13770   "RTN","RCD PBTLM",159 ,0)
  13771    .   S $P( RCLIST($P( DATE,"."), TRANDA),U, 7)=RCUSER   ;PRCA*4.5 *315
  13772   "RTN","RCD PBTLM",160 ,0)
  13773    .   ;
  13774   "RTN","RCD PBTLM",161 ,0)
  13775    .   ;  ca lculate bi ll's balan ce
  13776   "RTN","RCD PBTLM",162 ,0)
  13777    .   S PRI NBAL=PRINB AL+$P(VALU E,U,2)
  13778   "RTN","RCD PBTLM",163 ,0)
  13779    .   S INT BAL=INTBAL +$P(VALUE, U,3)
  13780   "RTN","RCD PBTLM",164 ,0)
  13781    .   S ADM BAL=ADMBAL +$P(VALUE, U,4)
  13782   "RTN","RCD PBTLM",165 ,0)
  13783    .   S MFB AL=MFBAL+$ P(VALUE,U, 5)
  13784   "RTN","RCD PBTLM",166 ,0)
  13785    .   S CCB AL=CCBAL+$ P(VALUE,U, 6)
  13786   "RTN","RCD PBTLM",167 ,0)
  13787    ;
  13788   "RTN","RCD PBTLM",168 ,0)
  13789    S DATE=$G (RCDPDATA( 430,BILLDA ,60,"I"))
  13790   "RTN","RCD PBTLM",169 ,0)
  13791    ;  check  to make su re activat ion date i s not grea ter than f irst trans action
  13792   "RTN","RCD PBTLM",170 ,0)
  13793    S %=$O(RC LIST(0)) I  DATE>% S  DATE=%
  13794   "RTN","RCD PBTLM",171 ,0)
  13795    S RCLIST( +$P(DATE," ."),0)="or iginal amo unt^"_RCDP DATA(430,B ILLDA,3,"I ")
  13796   "RTN","RCD PBTLM",172 ,0)
  13797    ;
  13798   "RTN","RCD PBTLM",173 ,0)
  13799    Q PRINBAL _U_INTBAL_ U_ADMBAL_U _MFBAL_U_C CBAL
  13800   "RTN","RCD PBTLM",174 ,0)
  13801    ;
  13802   "RTN","RCD PBTLM",175 ,0)
  13803    ;
  13804   "RTN","RCD PBTLM",176 ,0)
  13805   TRANVALU(T RANDA) ;   return the  transacti on value a s displaye d (with +  or - sign)
  13806   "RTN","RCD PBTLM",177 ,0)
  13807    N TYPE,VA LUE
  13808   "RTN","RCD PBTLM",178 ,0)
  13809    S VALUE=$ $TRANBAL^R CRJRCOT(TR ANDA)
  13810   "RTN","RCD PBTLM",179 ,0)
  13811    ;  no dol lars on tr ansaction
  13812   "RTN","RCD PBTLM",180 ,0)
  13813    I '$P(VAL UE,U),'$P( VALUE,U,2) ,'$P(VALUE ,U,3),'$P( VALUE,U,4) ,'$P(VALUE ,U,5) Q ""
  13814   "RTN","RCD PBTLM",181 ,0)
  13815    ;  check  type for p ayments, e tc, make v alues (-)  to subtrac t
  13816   "RTN","RCD PBTLM",182 ,0)
  13817    S TYPE=$P ($G(^PRCA( 433,TRANDA ,1)),U,2)
  13818   "RTN","RCD PBTLM",183 ,0)
  13819    I TYPE=2! (TYPE=8)!( TYPE=9)!(T YPE=10)!(T YPE=11)!(T YPE=14)!(T YPE=29)!(T YPE=34)!(T YPE=35)!(T YPE=41) D
  13820   "RTN","RCD PBTLM",184 ,0)
  13821    .   S $P( VALUE,U,1) =-$P(VALUE ,U,1)
  13822   "RTN","RCD PBTLM",185 ,0)
  13823    .   S $P( VALUE,U,2) =-$P(VALUE ,U,2)
  13824   "RTN","RCD PBTLM",186 ,0)
  13825    .   S $P( VALUE,U,3) =-$P(VALUE ,U,3)
  13826   "RTN","RCD PBTLM",187 ,0)
  13827    .   S $P( VALUE,U,4) =-$P(VALUE ,U,4)
  13828   "RTN","RCD PBTLM",188 ,0)
  13829    .   S $P( VALUE,U,5) =-$P(VALUE ,U,5)
  13830   "RTN","RCD PBTLM",189 ,0)
  13831    ;
  13832   "RTN","RCD PBTLM",190 ,0)
  13833    ;  the fo llowing tr ansaction  types shou ld not cha nge the bi lls balanc e
  13834   "RTN","RCD PBTLM",191 ,0)
  13835    ;  return  the amoun t displaye d in the d escription  and 0 for  value
  13836   "RTN","RCD PBTLM",192 ,0)
  13837    ;    refe r to RC 3,  refer to  DOJ 4, ree stablish 5 , returned  6 and 32
  13838   "RTN","RCD PBTLM",193 ,0)
  13839    ;    repa yment plan  25, amend ed 33, sus pended 47,  unsuspend ed 46
  13840   "RTN","RCD PBTLM",194 ,0)
  13841    K AMTDISP
  13842   "RTN","RCD PBTLM",195 ,0)
  13843    I TYPE=3! (TYPE=4)!( TYPE=5)!(T YPE=6)!(TY PE=25)!(TY PE=32)!(TY PE=33)!(TY PE=46)!(TY PE=47) D
  13844   "RTN","RCD PBTLM",196 ,0)
  13845    .   S AMT DISP=" ($" _$J($P(VAL UE,U)+$P(V ALUE,U,2)+ $P(VALUE,U ,3)+$P(VAL UE,U,4)+$P (VALUE,U,5 ),0,2)_")"
  13846   "RTN","RCD PBTLM",197 ,0)
  13847    .   S VAL UE=""
  13848   "RTN","RCD PBTLM",198 ,0)
  13849    Q $G(AMTD ISP)_U_VAL UE
  13850   "RTN","RCD PBTLM",199 ,0)
  13851    ;
  13852   "RTN","RCD PBTLM",200 ,0)
  13853   SELECME()  ;
  13854   "RTN","RCD PBTLM",201 ,0)
  13855    ; functio n takes th e user inp ut of the  ECME # to  return a v alid ien o f file 430
  13856   "RTN","RCD PBTLM",202 ,0)
  13857    ; if an i nvalid ECM E is evalu ated then  the proces s keeps as king the u ser for EC ME #
  13858   "RTN","RCD PBTLM",203 ,0)
  13859    ; until a  valid ECM E# is ente red or unt il the use r enters a  U or null  value
  13860   "RTN","RCD PBTLM",204 ,0)
  13861    ; output  - returns  the IEN of  the recor d entry in  the ACCOU NT RECEIVA BLE file ( #430) or " ??"
  13862   "RTN","RCD PBTLM",205 ,0)
  13863    N RCECME, RCBILL,DIR ,DIRUT,Y
  13864   "RTN","RCD PBTLM",206 ,0)
  13865    S DIR(0)= "FO^1:12^I  X'?1.12N  W !!,""Can not contai n alpha ch aracters""  K X"
  13866   "RTN","RCD PBTLM",207 ,0)
  13867    S DIR("A" )="Select  ECME#"
  13868   "RTN","RCD PBTLM",208 ,0)
  13869   RET D ^DIR  I $D(DIRU T) Q 0
  13870   "RTN","RCD PBTLM",209 ,0)
  13871    S RCECME= $S(+Y>0:Y, 1:0)
  13872   "RTN","RCD PBTLM",210 ,0)
  13873    S RCBILL= $$REC^IBRF N(RCECME)     ; IA 20 31
  13874   "RTN","RCD PBTLM",211 ,0)
  13875    I RCBILL< 0 W !!,"?? " G RET
  13876   "RTN","RCD PBTLM",212 ,0)
  13877    E  W !!,$ P($G(^PRCA (430,+RCBI LL,0)),U), " "
  13878   "RTN","RCD PBTLM",213 ,0)
  13879    Q RCBILL
  13880   "RTN","RCD PBTLM",214 ,0)
  13881    ;RCDPBTLM
  13882   "RTN","RCD PRTEX")
  13883   0^10^B5963 2459^n/a
  13884   "RTN","RCD PRTEX",1,0 )
  13885   RCDPRTEX ; ALB/LMH -  Claims Mat ching Repo rt for Exc el ;30-SEP  2016
  13886   "RTN","RCD PRTEX",2,0 )
  13887    ;;4.5;Acc ounts Rece ivable;**3 15**;Mar 2 0, 1995;Bu ild 55
  13888   "RTN","RCD PRTEX",3,0 )
  13889    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  13890   "RTN","RCD PRTEX",4,0 )
  13891    ;
  13892   "RTN","RCD PRTEX",5,0 )
  13893    Q
  13894   "RTN","RCD PRTEX",6,0 )
  13895    ;
  13896   "RTN","RCD PRTEX",7,0 )
  13897   PRINT ; En try point  for printi ng the rep ort
  13898   "RTN","RCD PRTEX",8,0 )
  13899    ; Input: 
  13900   "RTN","RCD PRTEX",9,0 )
  13901    ;    RCEX CEL - 1 -  CSV format , 0 otherw ise
  13902   "RTN","RCD PRTEX",10, 0)
  13903    ; Output:  
  13904   "RTN","RCD PRTEX",11, 0)
  13905    ;    Repo rt is prin ted in tex t format f or Excel ( turn on lo gging)
  13906   "RTN","RCD PRTEX",12, 0)
  13907    ; 
  13908   "RTN","RCD PRTEX",13, 0)
  13909    Q:'RCEXCE L
  13910   "RTN","RCD PRTEX",14, 0)
  13911    K ^TMP("R CDPRTPB",$ J),^TMP("I BRBT",$J), ^TMP("IBRB F",$J)
  13912   "RTN","RCD PRTEX",15, 0)
  13913    N DAT,RCB IL,RCBIL0, RCNAM,RCPA Y,RCPAY1,R CREC,RCREC 1,RCRECTDA ,RCSSN,RCT YP
  13914   "RTN","RCD PRTEX",16, 0)
  13915    D @($S(RC SORT=1:"PA T",RCSORT= 2:"BILL",R CSORT=3:"D ATE",RCSOR T=4:"REC", RCSORT=5:" TYPE")_"^R CDPRTP0")
  13916   "RTN","RCD PRTEX",17, 0)
  13917    ;
  13918   "RTN","RCD PRTEX",18, 0)
  13919    N CRT,DIR ,DIROUT,DI RUT,DTOUT, DUOUT,RCST OP
  13920   "RTN","RCD PRTEX",19, 0)
  13921    N PAGE,SE PLINE,X,XX ,Y
  13922   "RTN","RCD PRTEX",20, 0)
  13923    S CRT=$S( IOST["C-": 1,1:0) ; 1  - Print t o Screen,  0 - Otherw ise
  13924   "RTN","RCD PRTEX",21, 0)
  13925    S:RCEXCEL  IOSL=9999 99 ; Long  screen len gth for Ex cel output
  13926   "RTN","RCD PRTEX",22, 0)
  13927    S PAGE=0, RCSTOP=0,$ P(SEPLINE, "-",81)=""
  13928   "RTN","RCD PRTEX",23, 0)
  13929    I '$D(^TM P("RCDPRTP B",$J)) D   Q
  13930   "RTN","RCD PRTEX",24, 0)
  13931    . W @IOF, $C(13) ; N o data was  compiled
  13932   "RTN","RCD PRTEX",25, 0)
  13933    . W !!?5, "No data f ound for t his report ."
  13934   "RTN","RCD PRTEX",26, 0)
  13935    . I CRT,' $D(ZTQUEUE D) D
  13936   "RTN","RCD PRTEX",27, 0)
  13937    . . D ^DI R
  13938   "RTN","RCD PRTEX",28, 0)
  13939    ;
  13940   "RTN","RCD PRTEX",29, 0)
  13941   START        ;
  13942   "RTN","RCD PRTEX",30, 0)
  13943    N RCPAT0, NAME,BILLN UM,BILLFRO M,BILLTO,R XCOV,LRCIB FN,DOB,AMT ,CHGTYP,ST ATUS
  13944   "RTN","RCD PRTEX",31, 0)
  13945    N RCH,AMT 1,PAYOR,PS T,FILLFROM ,FILLTO,ON HOLD,RCAMT ,RCAMT1,RC IBDAT,STRI NG,RCBILL0
  13946   "RTN","RCD PRTEX",32, 0)
  13947    N RCQ,RCS SN,RCTP,X, Y,RCEXNAM, ELIG,FPCBI LL,POSTDAT E,RCDOB,RC FLAG
  13948   "RTN","RCD PRTEX",33, 0)
  13949    D EXCELHD
  13950   "RTN","RCD PRTEX",34, 0)
  13951    ;
  13952   "RTN","RCD PRTEX",35, 0)
  13953    S RCNAM=" " F  S RCN AM=$O(^TMP ("RCDPRTPB ",$J,RCNAM )) Q:RCNAM =""  D
  13954   "RTN","RCD PRTEX",36, 0)
  13955    .S RCBILL =0 F  S RC BILL=$O(^T MP("RCDPRT PB",$J,RCN AM,RCBILL) ) Q:'RCBIL L  D
  13956   "RTN","RCD PRTEX",37, 0)
  13957    ..D DEMOG
  13958   "RTN","RCD PRTEX",38, 0)
  13959    ..D PROC^ RCDPRTP1 ;     Proces s each thi rd party b ill for a  patient.
  13960   "RTN","RCD PRTEX",39, 0)
  13961    ..K ^TMP( "IBRBT",$J ),^TMP("IB RBF",$J)
  13962   "RTN","RCD PRTEX",40, 0)
  13963    Q
  13964   "RTN","RCD PRTEX",41, 0)
  13965    ;
  13966   "RTN","RCD PRTEX",42, 0)
  13967   DEMOG   ;  Demographi c data for  third par ty bills &   
  13968   "RTN","RCD PRTEX",43, 0)
  13969    ;         first part y charges  detail lin e header 
  13970   "RTN","RCD PRTEX",44, 0)
  13971    ; 
  13972   "RTN","RCD PRTEX",45, 0)
  13973    S RCPAT0= $G(^TMP("R CDPRTPB",$ J,RCNAM))
  13974   "RTN","RCD PRTEX",46, 0)
  13975    S DATE=$G (^TMP("RCD PRTPB",$J, RCNAM,RCBI LL))
  13976   "RTN","RCD PRTEX",47, 0)
  13977    S RCNAME= $P(RCNAM," ^")
  13978   "RTN","RCD PRTEX",48, 0)
  13979    S RCBILL0 =$G(^PRCA( 430,RCBILL ,0))
  13980   "RTN","RCD PRTEX",49, 0)
  13981    S RCDFN=$ P($G(^PRCA (430,RCBIL L,0)),U,7)
  13982   "RTN","RCD PRTEX",50, 0)
  13983    S RCDOB=$ P($G(^DPT( RCDFN,0)), U,3)
  13984   "RTN","RCD PRTEX",51, 0)
  13985    S DOB=$$F MTE^XLFDT( RCDOB,"5Z" )
  13986   "RTN","RCD PRTEX",52, 0)
  13987    S DEBTOR= $P($G(RCBI LL0),U,9)
  13988   "RTN","RCD PRTEX",53, 0)
  13989    S RCDEBTO R=$O(^RCD( 340,"B",RC DFN_";DPT( ",0)) Q:'R CDEBTOR
  13990   "RTN","RCD PRTEX",54, 0)
  13991    S RCSSN=$ $SSN^RCFN0 1($G(RCDEB TOR))
  13992   "RTN","RCD PRTEX",55, 0)
  13993    S ELIG=$P ($G(RCPAT0 ),U,2)
  13994   "RTN","RCD PRTEX",56, 0)
  13995    Q
  13996   "RTN","RCD PRTEX",57, 0)
  13997    ;
  13998   "RTN","RCD PRTEX",58, 0)
  13999   PRNTPAT    ; setup &  print thir d party bi lls
  14000   "RTN","RCD PRTEX",59, 0)
  14001    S RCTP=RC BILL,RCIBD AT=$G(^TMP ("IBRBT",$ J,RCBILL,R CBILL))
  14002   "RTN","RCD PRTEX",60, 0)
  14003    S STATUS= $$STAT^RCD PRTP2(RCTP ) Q:STATUS ="CN"!(STA TUS="CB")   ;Added a  last minut e check fo r cancelle d third pa rty bills
  14004   "RTN","RCD PRTEX",61, 0)
  14005    S RXCOV=$ S('$G(^TMP ("IBRBT",$ J,RCBILL)) :"NO",1:"Y ES")
  14006   "RTN","RCD PRTEX",62, 0)
  14007    S BILLNUM =$P(RCIBDA T,U,4) ; B ILL #
  14008   "RTN","RCD PRTEX",63, 0)
  14009    S PST=$P( RCIBDAT,U, 5) ; P/S/T
  14010   "RTN","RCD PRTEX",64, 0)
  14011    S BILLFRO M=$$DATE^R CDPRTP2($P (RCIBDAT,U )) ; bill  date from
  14012   "RTN","RCD PRTEX",65, 0)
  14013    S BILLTO= $$DATE^RCD PRTP2($P(R CIBDAT,U,2 )) ; bill  date to
  14014   "RTN","RCD PRTEX",66, 0)
  14015    S RCDATE= $S($G(RCTP (RCTP)):RC TP(RCTP),$ G(^TMP("RC DPRTPB",$J ,RCNAM,RCB ILL)):^(RC BILL),1:"" ) I RCTP=R CBILL!($D( RCTP(RCTP) )) S POSTD ATE=$$DATE ^RCDPRTP2( RCDATE)
  14016   "RTN","RCD PRTEX",67, 0)
  14017    S RCIBFN= RCTP
  14018   "RTN","RCD PRTEX",68, 0)
  14019    S RCDATE= $P($G(^PRC A(430,+RCT P,0)),U,14 )
  14020   "RTN","RCD PRTEX",69, 0)
  14021    S POSTDAT E=$S(RCDAT E=DATE:$$D ATE^RCDPRT P2(RCDATE) ,RCDATE'=D ATE:"^")
  14022   "RTN","RCD PRTEX",70, 0)
  14023    S PAYOR=$ P(RCIBDAT, U,7) ; pay or
  14024   "RTN","RCD PRTEX",71, 0)
  14025    S RCAMT=$ P($G(^PRCA (430,+RCTP ,0)),"^",3 ) ; amt bi lled
  14026   "RTN","RCD PRTEX",72, 0)
  14027    S RCAMT1= $P($G(^PRC A(430,+RCT P,7)),"^", 7) ; amt p aid
  14028   "RTN","RCD PRTEX",73, 0)
  14029    S RCTYPE= $$TYP^IBRF N(RCTP) ;T hird party  bill type  of care
  14030   "RTN","RCD PRTEX",74, 0)
  14031    S RCTYPE= $S(RCTYPE= "":-1,RCTY PE="PR":"P ",RCTYPE=" PH":"R",1: RCTYPE)
  14032   "RTN","RCD PRTEX",75, 0)
  14033    S RCFLAG= RCTYPE
  14034   "RTN","RCD PRTEX",76, 0)
  14035    S RCTP=RC BILL
  14036   "RTN","RCD PRTEX",77, 0)
  14037    D EXCELPA T
  14038   "RTN","RCD PRTEX",78, 0)
  14039    ;
  14040   "RTN","RCD PRTEX",79, 0)
  14041   EXCELTPB ;  print oth er assoc.  third part y bills
  14042   "RTN","RCD PRTEX",80, 0)
  14043    S RCTP=0  F  S RCTP= $O(^TMP("I BRBT",$J,R CBILL,RCTP )) Q:'RCTP   D
  14044   "RTN","RCD PRTEX",81, 0)
  14045    .S STATUS =$$STAT^RC DPRTP2(RCT P) Q:STATU S="CN"!(ST ATUS="CB")   ;Added a  last minu te check f or cancell ed third p arty bills
  14046   "RTN","RCD PRTEX",82, 0)
  14047    .I RCBILL =RCTP Q  ;  don't rep rint the b ill that w as paid.
  14048   "RTN","RCD PRTEX",83, 0)
  14049    .S RCIBDA T=$G(^TMP( "IBRBT",$J ,RCBILL,RC TP))
  14050   "RTN","RCD PRTEX",84, 0)
  14051    .I 'RCAN, ($P(RCIBDA T,"^",3))  Q  ; exclu de cancell ed bills
  14052   "RTN","RCD PRTEX",85, 0)
  14053    .D DEMOG
  14054   "RTN","RCD PRTEX",86, 0)
  14055    .S RXCOV= $S('$G(^TM P("IBRBT", $J,RCBILL) ):"NO",1:" YES")
  14056   "RTN","RCD PRTEX",87, 0)
  14057    .S BILLNU M=$P(RCIBD AT,U,4) ;  BILL #
  14058   "RTN","RCD PRTEX",88, 0)
  14059    .S PST=$P (RCIBDAT,U ,5) ; P/S/ T
  14060   "RTN","RCD PRTEX",89, 0)
  14061    .S BILLFR OM=$$DATE^ RCDPRTP2($ P(RCIBDAT, U)) ; bill  date from
  14062   "RTN","RCD PRTEX",90, 0)
  14063    .S BILLTO =$$DATE^RC DPRTP2($P( RCIBDAT,U, 2)) ; bill  date to
  14064   "RTN","RCD PRTEX",91, 0)
  14065    .S RCDATE =$P($G(^PR CA(430,+RC TP,0)),U,1 4)
  14066   "RTN","RCD PRTEX",92, 0)
  14067    .S POSTDA TE=$S(RCDA TE=DATE:$$ DATE^RCDPR TP2(RCDATE ),RCDATE'= DATE:"^")
  14068   "RTN","RCD PRTEX",93, 0)
  14069    .S RCIBFN =RCTP
  14070   "RTN","RCD PRTEX",94, 0)
  14071    .;S STATU S=$$STAT^R CDPRTP2(RC IBFN)
  14072   "RTN","RCD PRTEX",95, 0)
  14073    .S PAYOR= $P(RCIBDAT ,U,7) ; pa yor 
  14074   "RTN","RCD PRTEX",96, 0)
  14075    .S RCAMT= $P($G(^PRC A(430,+RCT P,0)),"^", 3) ; amt b illed
  14076   "RTN","RCD PRTEX",97, 0)
  14077    .S RCAMT1 =$P($G(^PR CA(430,+RC TP,7)),"^" ,7) ; amt  paid
  14078   "RTN","RCD PRTEX",98, 0)
  14079    .S RCTYPE =$$TYP^IBR FN(RCTP) ; Third part y bill typ e of care
  14080   "RTN","RCD PRTEX",99, 0)
  14081    .S RCTYPE =$S(RCTYPE ="":-1,RCT YPE="PR":" P",RCTYPE= "PH":"R",1 :RCTYPE)
  14082   "RTN","RCD PRTEX",100 ,0)
  14083    .D EXCELP AT
  14084   "RTN","RCD PRTEX",101 ,0)
  14085    ;
  14086   "RTN","RCD PRTEX",102 ,0)
  14087   PRNTFPC    ; print as sociated f irst party  charges
  14088   "RTN","RCD PRTEX",103 ,0)
  14089    ;                                                                                             Thi s code scr eens entri es from fi le 350.1 r eturned by  API - REL BILL^IBRFN
  14090   "RTN","RCD PRTEX",104 ,0)
  14091    N RCACTYP ,J  ;Do th e next sec tion of co de only if  Care Type s were sel ected - St ored in RC TYPE([care  type])
  14092   "RTN","RCD PRTEX",105 ,0)
  14093    I $D(RCTY PE)>1 S J= 0 F  S J=$ O(^TMP("IB RBF",$J,RC BILL,J)) Q :'J  D  ;L oop throug h 1st part y bills
  14094   "RTN","RCD PRTEX",106 ,0)
  14095    . S RCACT YP=$P(^TMP ("IBRBF",$ J,RCBILL,J ),U,6) Q:R CACTYP=""   ;6th piec e is Actio n Type
  14096   "RTN","RCD PRTEX",107 ,0)
  14097    . I RCACT YP["TRICAR E"!(RCACTY P["CHAMPA" ) Q  ;Not  needed for  screening  1st party  charges
  14098   "RTN","RCD PRTEX",108 ,0)
  14099    . I RCACT YP["RX" S  RCTYP="R"  D KILFPTY^ RCDPRTP1 Q
  14100   "RTN","RCD PRTEX",109 ,0)
  14101    . I RCACT YP["OPT"!( RCACTYP["O BSERV") S  RCTYP="O"  D KILFPTY^ RCDPRTP1 Q
  14102   "RTN","RCD PRTEX",110 ,0)
  14103    . I RCACT YP["INPT"! (RCACTYP[" NHCU")!(RC ACTYP["ADM IS")!(RCAC TYP["MEDIC ARE DECUCT IBLE") S R CTYP="I" D  KILFPTY^R CDPRTP1 Q
  14104   "RTN","RCD PRTEX",111 ,0)
  14105    ;
  14106   "RTN","RCD PRTEX",112 ,0)
  14107    S RCTP(0) =0 F  S RC TP(0)=$O(^ TMP("IBRBF ",$J,RCTP( 0))) Q:'RC TP(0)!$G(R CQ)  D
  14108   "RTN","RCD PRTEX",113 ,0)
  14109    .S RCTP=0  F  S RCTP =$O(^TMP(" IBRBF",$J, RCTP(0),RC TP)) Q:'RC TP!$G(RCQ)   D 
  14110   "RTN","RCD PRTEX",114 ,0)
  14111    ..S RCNO= 1
  14112   "RTN","RCD PRTEX",115 ,0)
  14113    ..S RCIBD AT=$G(^TMP ("IBRBF",$ J,RCTP(0), RCTP))
  14114   "RTN","RCD PRTEX",116 ,0)
  14115    ..S RCIBF N=$P(RCIBD AT,U,4) I  RCIBFN S R CIBFN=$O(^ PRCA(430," B",RCIBFN, 0))
  14116   "RTN","RCD PRTEX",117 ,0)
  14117    ..D DEMOG
  14118   "RTN","RCD PRTEX",118 ,0)
  14119    ..S RXCOV =$S('$G(^T MP("IBRBT" ,$J,RCBILL )):"NO",1: "YES")
  14120   "RTN","RCD PRTEX",119 ,0)
  14121    ..S FILLF ROM=$$DATE ^RCDPRTP2( +RCIBDAT)  ; Bill fro m
  14122   "RTN","RCD PRTEX",120 ,0)
  14123    ..S FILLT O=$$DATE^R CDPRTP2($P (RCIBDAT,U ,2)) ; Bil l to
  14124   "RTN","RCD PRTEX",121 ,0)
  14125    ..S CHGTY P=$P(RCIBD AT,U,6)
  14126   "RTN","RCD PRTEX",122 ,0)
  14127    ..S RCIBF N=$P(RCIBD AT,"^",4)  I RCIBFN S  RCIBFN=$O (^PRCA(430 ,"B",RCIBF N,0))
  14128   "RTN","RCD PRTEX",123 ,0)
  14129    ..S FPCBI LL=$P(RCIB DAT,U,4)
  14130   "RTN","RCD PRTEX",124 ,0)
  14131    ..S STATU S=$$STAT^R CDPRTP2(RC IBFN) ; St atus
  14132   "RTN","RCD PRTEX",125 ,0)
  14133    ..S ONHOL D=$P(RCIBD AT,U,7) ;  # Days On  Hold
  14134   "RTN","RCD PRTEX",126 ,0)
  14135    ..S AMT=$ P(RCIBDAT, U,5) ; Amo unt billed
  14136   "RTN","RCD PRTEX",127 ,0)
  14137    ..S BAL=$ S($G(^PRCA (430,+RCIB FN,7)):+($ P(^(7),"^" )+$P(^(7), "^",2)+$P( ^(7),"^",3 )+$P(^(7), "^",4)+$P( ^(7),"^",4 )),1:0)
  14138   "RTN","RCD PRTEX",128 ,0)
  14139    ..D EXCEL FPC
  14140   "RTN","RCD PRTEX",129 ,0)
  14141    .Q
  14142   "RTN","RCD PRTEX",130 ,0)
  14143    Q
  14144   "RTN","RCD PRTEX",131 ,0)
  14145    ;
  14146   "RTN","RCD PRTEX",132 ,0)
  14147   EXCELHD      ; Print  an Excel C SV header  record
  14148   "RTN","RCD PRTEX",133 ,0)
  14149    ;
  14150   "RTN","RCD PRTEX",134 ,0)
  14151    ; Input:  None
  14152   "RTN","RCD PRTEX",135 ,0)
  14153    ; Output:  Header li ne printed  for CSV f ormat (exc el)
  14154   "RTN","RCD PRTEX",136 ,0)
  14155    ; :
  14156   "RTN","RCD PRTEX",137 ,0)
  14157    N RCH
  14158   "RTN","RCD PRTEX",138 ,0)
  14159    S STRING= ""
  14160   "RTN","RCD PRTEX",139 ,0)
  14161    S RCH=$$C SV("","Pat ient")
  14162   "RTN","RCD PRTEX",140 ,0)
  14163    S RCH=$$C SV(RCH,"SS N")
  14164   "RTN","RCD PRTEX",141 ,0)
  14165    S RCH=$$C SV(RCH,"DO B")
  14166   "RTN","RCD PRTEX",142 ,0)
  14167    S RCH=$$C SV(RCH,"Pr im. Elig")
  14168   "RTN","RCD PRTEX",143 ,0)
  14169    S RCH=$$C SV(RCH,"RX  Cvg")
  14170   "RTN","RCD PRTEX",144 ,0)
  14171    S RCH=$$C SV(RCH,"Bi ll Type")
  14172   "RTN","RCD PRTEX",145 ,0)
  14173    S RCH=$$C SV(RCH,"Bi ll#")
  14174   "RTN","RCD PRTEX",146 ,0)
  14175    S RCH=$$C SV(RCH,"P/ S/T")
  14176   "RTN","RCD PRTEX",147 ,0)
  14177    S RCH=$$C SV(RCH,"Ch g Type")
  14178   "RTN","RCD PRTEX",148 ,0)
  14179    S RCH=$$C SV(RCH,"St atus")
  14180   "RTN","RCD PRTEX",149 ,0)
  14181    S RCH=$$C SV(RCH,"Bi ll From")
  14182   "RTN","RCD PRTEX",150 ,0)
  14183    S RCH=$$C SV(RCH,"Bi ll To")
  14184   "RTN","RCD PRTEX",151 ,0)
  14185    S RCH=$$C SV(RCH,"Po sted")
  14186   "RTN","RCD PRTEX",152 ,0)
  14187    S RCH=$$C SV(RCH,"Am t Billed")
  14188   "RTN","RCD PRTEX",153 ,0)
  14189    S RCH=$$C SV(RCH,"Am t Pd")
  14190   "RTN","RCD PRTEX",154 ,0)
  14191    S RCH=$$C SV(RCH,"Ba l")
  14192   "RTN","RCD PRTEX",155 ,0)
  14193    S RCH=$$C SV(RCH,"Ca re Type")
  14194   "RTN","RCD PRTEX",156 ,0)
  14195    S RCH=$$C SV(RCH,"On  Hold")
  14196   "RTN","RCD PRTEX",157 ,0)
  14197    S RCH=$$C SV(RCH,"Pa yor")
  14198   "RTN","RCD PRTEX",158 ,0)
  14199    W RCH,!
  14200   "RTN","RCD PRTEX",159 ,0)
  14201    Q
  14202   "RTN","RCD PRTEX",160 ,0)
  14203    ;
  14204   "RTN","RCD PRTEX",161 ,0)
  14205   EXCELPAT    ; Print p atient thi rd party b ills
  14206   "RTN","RCD PRTEX",162 ,0)
  14207    ;
  14208   "RTN","RCD PRTEX",163 ,0)
  14209    ; Input:  None
  14210   "RTN","RCD PRTEX",164 ,0)
  14211    ; Output:  Detail li ne printed  for CSV f ormat (exc el)
  14212   "RTN","RCD PRTEX",165 ,0)
  14213    ;
  14214   "RTN","RCD PRTEX",166 ,0)
  14215    N RCD
  14216   "RTN","RCD PRTEX",167 ,0)
  14217    S STRING= ""
  14218   "RTN","RCD PRTEX",168 ,0)
  14219    S RCD=$$C SV("",RCNA ME)_"^"_$E (RCNAME,1) _$E(RCSSN, 6,9)
  14220   "RTN","RCD PRTEX",169 ,0)
  14221    S RCD=$$C SV(RCD,DOB )
  14222   "RTN","RCD PRTEX",170 ,0)
  14223    S RCD=$$C SV(RCD,ELI G)
  14224   "RTN","RCD PRTEX",171 ,0)
  14225    S RCD=$$C SV(RCD,RXC OV)
  14226   "RTN","RCD PRTEX",172 ,0)
  14227    S RCD=$$C SV(RCD,"Th ird Party  Bill")
  14228   "RTN","RCD PRTEX",173 ,0)
  14229    S RCD=$$C SV(RCD,BIL LNUM)
  14230   "RTN","RCD PRTEX",174 ,0)
  14231    S RCD=$$C SV(RCD,PST )
  14232   "RTN","RCD PRTEX",175 ,0)
  14233    S RCD=$$C SV(RCD,"^" )
  14234   "RTN","RCD PRTEX",176 ,0)
  14235    S RCD=$$C SV(RCD,STA TUS)
  14236   "RTN","RCD PRTEX",177 ,0)
  14237    S RCD=$$C SV(RCD,BIL LFROM)
  14238   "RTN","RCD PRTEX",178 ,0)
  14239    S RCD=$$C SV(RCD,BIL LTO)
  14240   "RTN","RCD PRTEX",179 ,0)
  14241    S RCD=$$C SV(RCD,POS TDATE)
  14242   "RTN","RCD PRTEX",180 ,0)
  14243    S RCD=$$C SV(RCD,RCA MT)
  14244   "RTN","RCD PRTEX",181 ,0)
  14245    S RCD=$$C SV(RCD,RCA MT1)
  14246   "RTN","RCD PRTEX",182 ,0)
  14247    S RCD=$$C SV(RCD,"^" )
  14248   "RTN","RCD PRTEX",183 ,0)
  14249    S RCD=$$C SV(RCD,RCT YPE)
  14250   "RTN","RCD PRTEX",184 ,0)
  14251    S RCD=$$C SV(RCD,"^" )
  14252   "RTN","RCD PRTEX",185 ,0)
  14253    S RCD=$$C SV(RCD,PAY OR)
  14254   "RTN","RCD PRTEX",186 ,0)
  14255    W RCD,!
  14256   "RTN","RCD PRTEX",187 ,0)
  14257    K RCTP(RC TP)
  14258   "RTN","RCD PRTEX",188 ,0)
  14259    Q
  14260   "RTN","RCD PRTEX",189 ,0)
  14261    ;
  14262   "RTN","RCD PRTEX",190 ,0)
  14263   EXCELFPC    ; Print p atient fir st party c harges
  14264   "RTN","RCD PRTEX",191 ,0)
  14265    ;
  14266   "RTN","RCD PRTEX",192 ,0)
  14267    ; Input:  None
  14268   "RTN","RCD PRTEX",193 ,0)
  14269    ; Output:  Detail li ne printed  for CSV f ormat (exc el)
  14270   "RTN","RCD PRTEX",194 ,0)
  14271    ;
  14272   "RTN","RCD PRTEX",195 ,0)
  14273    N RCB
  14274   "RTN","RCD PRTEX",196 ,0)
  14275    S STRING= ""
  14276   "RTN","RCD PRTEX",197 ,0)
  14277    S RCB=$$C SV("",RCNA ME)_"^"_$E (RCNAME,1) _$E(RCSSN, 6,9)
  14278   "RTN","RCD PRTEX",198 ,0)
  14279    S RCB=$$C SV(RCB,DOB )
  14280   "RTN","RCD PRTEX",199 ,0)
  14281    S RCB=$$C SV(RCB,ELI G)
  14282   "RTN","RCD PRTEX",200 ,0)
  14283    S RCB=$$C SV(RCB,"^" )
  14284   "RTN","RCD PRTEX",201 ,0)
  14285    S RCB=$$C SV(RCB,"Fi rst Party  Charge")
  14286   "RTN","RCD PRTEX",202 ,0)
  14287    S RCB=$$C SV(RCB,FPC BILL)
  14288   "RTN","RCD PRTEX",203 ,0)
  14289    S RCB=$$C SV(RCB,"^" )
  14290   "RTN","RCD PRTEX",204 ,0)
  14291    S RCB=$$C SV(RCB,CHG TYP)
  14292   "RTN","RCD PRTEX",205 ,0)
  14293    S RCB=$$C SV(RCB,STA TUS)
  14294   "RTN","RCD PRTEX",206 ,0)
  14295    S RCB=$$C SV(RCB,FIL LFROM)
  14296   "RTN","RCD PRTEX",207 ,0)
  14297    S RCB=$$C SV(RCB,FIL LTO)
  14298   "RTN","RCD PRTEX",208 ,0)
  14299    S RCB=$$C SV(RCB,"^" )
  14300   "RTN","RCD PRTEX",209 ,0)
  14301    S RCB=$$C SV(RCB,AMT )
  14302   "RTN","RCD PRTEX",210 ,0)
  14303    S RCB=$$C SV(RCB,"^" )
  14304   "RTN","RCD PRTEX",211 ,0)
  14305    S RCB=$$C SV(RCB,BAL )
  14306   "RTN","RCD PRTEX",212 ,0)
  14307    S RCB=$$C SV(RCB,"^" )
  14308   "RTN","RCD PRTEX",213 ,0)
  14309    S RCB=$$C SV(RCB,ONH OLD)
  14310   "RTN","RCD PRTEX",214 ,0)
  14311    W RCB,!
  14312   "RTN","RCD PRTEX",215 ,0)
  14313    Q
  14314   "RTN","RCD PRTEX",216 ,0)
  14315    ;
  14316   "RTN","RCD PRTEX",217 ,0)
  14317   CSV(STRING ,DATA) ; B uild the E xcel data  string for  CSV forma t
  14318   "RTN","RCD PRTEX",218 ,0)
  14319    ; Input:  STRING - C urrent str ing being  built or " "
  14320   "RTN","RCD PRTEX",219 ,0)
  14321    ; DATA -  New data t o be added  to the st ring
  14322   "RTN","RCD PRTEX",220 ,0)
  14323    ; Returns : STRING -  Updated s tring with  DATA adde d
  14324   "RTN","RCD PRTEX",221 ,0)
  14325    ; 
  14326   "RTN","RCD PRTEX",222 ,0)
  14327    S DATA="" _$TR(DATA, $C(94))
  14328   "RTN","RCD PRTEX",223 ,0)
  14329    S STRING= $S(STRING= "":DATA,1: STRING_"^" _DATA)
  14330   "RTN","RCD PRTEX",224 ,0)
  14331    Q STRING
  14332   "RTN","RCD PRTEX",225 ,0)
  14333    ;
  14334   "RTN","RCD PRTP")
  14335   0^2^B13526 370^B83050 80
  14336   "RTN","RCD PRTP",1,0)
  14337   RCDPRTP  ; ALB/LDB-CL AIMS MATCH ING REPORT  ;1/11/01   2:03 PM
  14338   "RTN","RCD PRTP",2,0)
  14339    ;;4.5;Acc ounts Rece ivable;**1 51,186,315 **;Mar 20,  1995;Buil d 55
  14340   "RTN","RCD PRTP",3,0)
  14341    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  14342   "RTN","RCD PRTP",4,0)
  14343    ;
  14344   "RTN","RCD PRTP",5,0)
  14345   EN ;
  14346   "RTN","RCD PRTP",6,0)
  14347    N DATEEND ,DATESTRT, DIC,DIR,DI RUT,POP,RC BILL,RCDEB T,RCDFN,RC PT,RCSORT, RCQUIT,%ZI S,ZTDESC,Z TSAVE,ZTRT N,Y,RCAN,D IOEND,ZTIO
  14348   "RTN","RCD PRTP",7,0)
  14349    W !
  14350   "RTN","RCD PRTP",8,0)
  14351    K DIRUT S  DIR(0)="S ^1:Patient ;2:Bill Nu mber;3:Pay ment dates ;4:Receipt  Number;5: Care Types ",DIR("A") ="Sort by"  D ^DIR K  DIR Q:$D(D IRUT)
  14352   "RTN","RCD PRTP",9,0)
  14353    S RCSORT= Y,RCQUIT=" "
  14354   "RTN","RCD PRTP",10,0 )
  14355    D @RCSORT  Q:RCQUIT   W !
  14356   "RTN","RCD PRTP",11,0 )
  14357    K DIRUT S  DIR(0)="Y ",DIR("A") ="Include  cancelled  bills",DIR ("B")="NO"  D ^DIR S  RCAN=+Y Q: $D(DIRUT)
  14358   "RTN","RCD PRTP",12,0 )
  14359    ;
  14360   "RTN","RCD PRTP",13,0 )
  14361    ;  select  device
  14362   "RTN","RCD PRTP",14,0 )
  14363    I $$FORMA T^RCDPRTP0 (.RCEXCEL)  D DEVICE^ RCDPRTP0()  I RCEXCEL =1,'QUIT G  PRINT^RCD PRTEX
  14364   "RTN","RCD PRTP",15,0 )
  14365    W !!,"Thi s report r equires 13 2 columns. ",!!
  14366   "RTN","RCD PRTP",16,0 )
  14367    K IOP,IO( "Q") S %ZI S="MQ",%ZI S("B")=""  D ^%ZIS Q: POP
  14368   "RTN","RCD PRTP",17,0 )
  14369    I $D(IO(" Q")) D  Q
  14370   "RTN","RCD PRTP",18,0 )
  14371    .S ZTDESC ="Claims M atching Re port",ZTRT N="DQ^RCDP RTP"
  14372   "RTN","RCD PRTP",19,0 )
  14373    .S ZTSAVE ("RCSORT") =""
  14374   "RTN","RCD PRTP",20,0 )
  14375    . I RCSOR T=1 S ZTSA VE("RCDEBT ")="",ZTSA VE("RCDFN" )="",ZTSAV E("RCTYPE* ")=""
  14376   "RTN","RCD PRTP",21,0 )
  14377    . I RCSOR T=2 S ZTSA VE("RCBILL ")="",ZTSA VE("RCDFN" )="",ZTSAV E("RCDEBT" )=""
  14378   "RTN","RCD PRTP",22,0 )
  14379    . I RCSOR T=4 S ZTSA VE("RCPT") =""
  14380   "RTN","RCD PRTP",23,0 )
  14381    . I RCSOR T=5 S ZTSA VE("RCTYPE *")=""
  14382   "RTN","RCD PRTP",24,0 )
  14383    . S ZTSAV E("RCAN")= "",ZTSAVE( "ZTREQ")=" @",ZTSAVE( "^TMP(""RC DPRTPB"",$ J,")=""
  14384   "RTN","RCD PRTP",25,0 )
  14385    . S ZTSAV E("DATEEND ")="",ZTSA VE("DATEST RT")="",ZT SAVE("RCQU IT")="",ZT SAVE("RCSO RT")="",ZT SAVE("RCEX CEL")=""
  14386   "RTN","RCD PRTP",26,0 )
  14387    . S ZTIO= ION_";"_IO ST_";"_IOM _";"_IOSL
  14388   "RTN","RCD PRTP",27,0 )
  14389    . S DIOEN D="K ^TMP( ""RCDPRTPB "",$J)"
  14390   "RTN","RCD PRTP",28,0 )
  14391    .D ^%ZTLO AD,HOME^%Z IS K IO("Q ") W !,"Ta sk# ",ZTSK
  14392   "RTN","RCD PRTP",29,0 )
  14393    W !!,?20, "<*> pleas e wait <*> "
  14394   "RTN","RCD PRTP",30,0 )
  14395   DQ     ;   queued rep ort starts  here
  14396   "RTN","RCD PRTP",31,0 )
  14397    U IO
  14398   "RTN","RCD PRTP",32,0 )
  14399    K ^TMP("R CDPRTPB",$ J),^TMP("I BRBT",$J), ^TMP("IBRB F",$J)
  14400   "RTN","RCD PRTP",33,0 )
  14401    N DAT,RCB IL,RCBIL0, RCNAM,RCPA Y,RCPAY1,R CREC,RCREC 1,RCRECTDA ,RCSSN,RCT YP
  14402   "RTN","RCD PRTP",34,0 )
  14403    D @($S(RC SORT=1:"PA T",RCSORT= 2:"BILL",R CSORT=3:"D ATE",RCSOR T=4:"REC", RCSORT=5:" TYPE")_"^R CDPRTP0")
  14404   "RTN","RCD PRTP",35,0 )
  14405    Q:RCQUIT
  14406   "RTN","RCD PRTP",36,0 )
  14407    D EN^RCDP RTP1
  14408   "RTN","RCD PRTP",37,0 )
  14409    W !!,?20, "<End of r eport>",!
  14410   "RTN","RCD PRTP",38,0 )
  14411    K DATESTR T,DATEEND, ^TMP("RCDP RTPB",$J), RCTYPE
  14412   "RTN","RCD PRTP",39,0 )
  14413    D ^%ZISC
  14414   "RTN","RCD PRTP",40,0 )
  14415    Q
  14416   "RTN","RCD PRTP",41,0 )
  14417    ;
  14418   "RTN","RCD PRTP",42,0 )
  14419   1 ; 
  14420   "RTN","RCD PRTP",43,0 )
  14421    S DIC(0)= "QEAMZ",DI C=340,DIC( "S")="I ^R CD(340,+Y, 0)[""DPT"" ",DIC("A") ="Patient  name: " D  ^DIC I Y<0  S RCQUIT= 1 Q
  14422   "RTN","RCD PRTP",44,0 )
  14423    S RCDEBT= +Y,RCDFN=+ $P(Y,"^",2 )
  14424   "RTN","RCD PRTP",45,0 )
  14425    D TYPEPIC ^RCDPRTP0( .RCTYPE) I  '$D(RCTYP E) S RCQUI T=1 Q
  14426   "RTN","RCD PRTP",46,0 )
  14427    D DATESEL ^RCRJRTRA( "Payment")
  14428   "RTN","RCD PRTP",47,0 )
  14429    I '$G(DAT ESTRT)!('$ G(DATEEND) ) S RCQUIT =1
  14430   "RTN","RCD PRTP",48,0 )
  14431    Q
  14432   "RTN","RCD PRTP",49,0 )
  14433    ;
  14434   "RTN","RCD PRTP",50,0 )
  14435   3 ; 
  14436   "RTN","RCD PRTP",51,0 )
  14437    D DATESEL ^RCRJRTRA( "Payment")
  14438   "RTN","RCD PRTP",52,0 )
  14439    I '$G(DAT ESTRT)!('$ G(DATEEND) ) S RCQUIT =1
  14440   "RTN","RCD PRTP",53,0 )
  14441    Q
  14442   "RTN","RCD PRTP",54,0 )
  14443    ;
  14444   "RTN","RCD PRTP",55,0 )
  14445   2 ; 
  14446   "RTN","RCD PRTP",56,0 )
  14447    N DIC,DUO UT
  14448   "RTN","RCD PRTP",57,0 )
  14449    K ^TMP("I BRBF",$J)
  14450   "RTN","RCD PRTP",58,0 )
  14451    S DIC(0)= "QEAM",DIC =430,DIC(" S")="I $P( ^(0),U,2)= 9" D ^DIC  I Y<0 S RC QUIT=1 Q
  14452   "RTN","RCD PRTP",59,0 )
  14453    S RCBILL= +Y,RCDFN=$ P($G(^PRCA (430,+RCBI LL,0)),"^" ,7) Q:'RCD FN
  14454   "RTN","RCD PRTP",60,0 )
  14455    S RCDEBT= $O(^RCD(34 0,"B",RCDF N_";DPT(", 0))
  14456   "RTN","RCD PRTP",61,0 )
  14457    I (RCDFN= "")!(RCDEB T="") W !, "This bill  has no ma tching fir st party b ills." G 2
  14458   "RTN","RCD PRTP",62,0 )
  14459    D RELBILL ^IBRFN(RCB ILL)
  14460   "RTN","RCD PRTP",63,0 )
  14461    I '$O(^TM P("IBRBF", $J,RCBILL, 0)) W !,"T his bill h as no matc hing first  party deb ts." K ^TM P("IBRBF", $J) G 2
  14462   "RTN","RCD PRTP",64,0 )
  14463    K ^TMP("I BRBF",$J)
  14464   "RTN","RCD PRTP",65,0 )
  14465    Q
  14466   "RTN","RCD PRTP",66,0 )
  14467    ;
  14468   "RTN","RCD PRTP",67,0 )
  14469   4 ;  
  14470   "RTN","RCD PRTP",68,0 )
  14471    N DIC,X,Y
  14472   "RTN","RCD PRTP",69,0 )
  14473    S DIC(0)= "QEAM",DIC =344 D ^DI C I Y<0 S  RCQUIT=1 Q
  14474   "RTN","RCD PRTP",70,0 )
  14475    S RCPT=$P (Y,"^",2)
  14476   "RTN","RCD PRTP",71,0 )
  14477    Q
  14478   "RTN","RCD PRTP",72,0 )
  14479    ;
  14480   "RTN","RCD PRTP",73,0 )
  14481   5 ; Select  care type  - added i n patch 31 5
  14482   "RTN","RCD PRTP",74,0 )
  14483    D TYPEPIC ^RCDPRTP0( .RCTYPE) I  '$D(RCTYP E) S RCQUI T=1 Q
  14484   "RTN","RCD PRTP",75,0 )
  14485    Q:RCQUIT
  14486   "RTN","RCD PRTP",76,0 )
  14487    D DATESEL ^RCRJRTRA( "Payment")
  14488   "RTN","RCD PRTP",77,0 )
  14489    I '$G(DAT ESTRT)!('$ G(DATEEND) ) S RCQUIT =1
  14490   "RTN","RCD PRTP",78,0 )
  14491    Q
  14492   "RTN","RCD PRTP",79,0 )
  14493    ;
  14494   "RTN","RCD PRTP",80,0 )
  14495   EXIT ;  
  14496   "RTN","RCD PRTP",81,0 )
  14497    K DATESTR T,DATEEND, RCEXCEL,^T MP("RCDPRT PB",$J),^T MP("IBRBT" ,$J)
  14498   "RTN","RCD PRTP",82,0 )
  14499    K ^TMP("I BRBT1",$J) ,^TMP("IBR BF",$J),^T MP("IBRBF1 ",$J),RCTY PE
  14500   "RTN","RCD PRTP",83,0 )
  14501    Q
  14502   "RTN","RCD PRTP",84,0 )
  14503    ;
  14504   "RTN","RCD PRTP0")
  14505   0^3^B47346 688^B10254 954
  14506   "RTN","RCD PRTP0",1,0 )
  14507   RCDPRTP0 ; ALB/LDB -  CLAIMS MAT CHING REPO RT ;5/24/0 0 10:48 AM
  14508   "RTN","RCD PRTP0",2,0 )
  14509    ;;4.5;Acc ounts Rece ivable;**1 51,315**;M ar 20, 199 5;Build 55
  14510   "RTN","RCD PRTP0",3,0 )
  14511    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  14512   "RTN","RCD PRTP0",4,0 )
  14513    ;
  14514   "RTN","RCD PRTP0",5,0 )
  14515   PAT      ; find patie nt bills
  14516   "RTN","RCD PRTP0",6,0 )
  14517    S RCNAM=$ $NAM^RCFN0 1(RCDEBT)
  14518   "RTN","RCD PRTP0",7,0 )
  14519    S RCSSN=$ $SSN^RCFN0 1(RCDEBT)
  14520   "RTN","RCD PRTP0",8,0 )
  14521    S RCBIL=0  F  S RCBI L=$O(^PRCA (430,"E",R CDFN,RCBIL )) Q:'RCBI L  D
  14522   "RTN","RCD PRTP0",9,0 )
  14523    .I $P($G( ^PRCA(430, +RCBIL,0)) ,"^",2)'=9  Q
  14524   "RTN","RCD PRTP0",10, 0)
  14525    .S RCPAY= 0 F  S RCP AY=$O(^PRC A(433,"C", RCBIL,RCPA Y)) Q:'RCP AY  D
  14526   "RTN","RCD PRTP0",11, 0)
  14527    ..S RCPAY 1=$G(^PRCA (433,+RCPA Y,1)) Q:RC PAY1=""
  14528   "RTN","RCD PRTP0",12, 0)
  14529    ..I "^2^3 4^"[("^"_$ P(RCPAY1," ^",2)_"^") ,($P(RCPAY 1,"^",9)'< DATESTRT), ($P(RCPAY1 ,"^",9)<(D ATEEND_".9 99999")) D
  14530   "RTN","RCD PRTP0",13, 0)
  14531    ...S DFN= RCDFN D DE M^VADPT,EL IG^VADPT
  14532   "RTN","RCD PRTP0",14, 0)
  14533    ...S RCTY PE=$$TYP^I BRFN(RCBIL ) ; added  care type  - 315
  14534   "RTN","RCD PRTP0",15, 0)
  14535    ...S RCTY PE=$S(RCTY PE="":-1,R CTYPE="PR" :"P",RCTYP E="PH":"R" ,1:RCTYPE)
  14536   "RTN","RCD PRTP0",16, 0)
  14537    ...I $D(R CTYPE(RCTY PE)) D  Q: 'RCTYPE
  14538   "RTN","RCD PRTP0",17, 0)
  14539    ....S ^TM P("RCDPRTP B",$J,RCNA M)=$P($G(V ADM(3)),"^ ",2)_"^"_$ P($G(VAEL( 1)),"^",2) _"^"_RCSSN
  14540   "RTN","RCD PRTP0",18, 0)
  14541    ....S ^TM P("RCDPRTP B",$J,RCNA M,RCBIL)=$ P($P(RCPAY 1,"^",9)," .")
  14542   "RTN","RCD PRTP0",19, 0)
  14543    ....K DFN ,VA,VADM,V AEL,VAERR
  14544   "RTN","RCD PRTP0",20, 0)
  14545    K RCDFN,R CDEBT
  14546   "RTN","RCD PRTP0",21, 0)
  14547    Q
  14548   "RTN","RCD PRTP0",22, 0)
  14549    ;
  14550   "RTN","RCD PRTP0",23, 0)
  14551   DATE     ; find third  party bil ls by date  of paymen ts
  14552   "RTN","RCD PRTP0",24, 0)
  14553    N RCDFN,R CDEBT
  14554   "RTN","RCD PRTP0",25, 0)
  14555    F RCTYP=2 ,34 S DAT= $$FMADD^XL FDT(DATEST RT,-1)_".9 99999" F   S DAT=$O(^ PRCA(433," AT",RCTYP, DAT)) Q:'D AT!(DAT>(D ATEEND_".9 99999"))   D
  14556   "RTN","RCD PRTP0",26, 0)
  14557    .S RCPAY= 0 F  S RCP AY=$O(^PRC A(433,"AT" ,RCTYP,DAT ,RCPAY)) Q :'RCPAY  D
  14558   "RTN","RCD PRTP0",27, 0)
  14559    ..S RCBIL =$P($G(^PR CA(433,+RC PAY,0)),"^ ",2)
  14560   "RTN","RCD PRTP0",28, 0)
  14561    ..S RCBIL 0=$G(^PRCA (430,+RCBI L,0)) Q:RC BIL0=""
  14562   "RTN","RCD PRTP0",29, 0)
  14563    ..Q:$P(RC BIL0,"^",2 )'=9
  14564   "RTN","RCD PRTP0",30, 0)
  14565    ..S RCDFN =$P(RCBIL0 ,"^",7)
  14566   "RTN","RCD PRTP0",31, 0)
  14567    ..S RCDEB T=$O(^RCD( 340,"B",RC DFN_";DPT( ",0)) Q:'R CDEBT
  14568   "RTN","RCD PRTP0",32, 0)
  14569    ..S RCNAM =$$NAM^RCF N01(RCDEBT )
  14570   "RTN","RCD PRTP0",33, 0)
  14571    ..S RCSSN =$$SSN^RCF N01(RCDEBT )
  14572   "RTN","RCD PRTP0",34, 0)
  14573    ..S DFN=R CDFN D DEM ^VADPT,ELI G^VADPT
  14574   "RTN","RCD PRTP0",35, 0)
  14575    ..S ^TMP( "RCDPRTPB" ,$J,RCNAM_ "^"_RCDEBT )=$P($G(VA DM(3)),"^" ,2)_"^"_$P ($G(VAEL(1 )),"^",2)_ "^"_RCSSN
  14576   "RTN","RCD PRTP0",36, 0)
  14577    ..S ^TMP( "RCDPRTPB" ,$J,RCNAM_ "^"_RCDEBT ,RCBIL)=$P (DAT,".")
  14578   "RTN","RCD PRTP0",37, 0)
  14579    ..K DFN,V A,VADM,VAE L,VAERR
  14580   "RTN","RCD PRTP0",38, 0)
  14581    Q
  14582   "RTN","RCD PRTP0",39, 0)
  14583    ;
  14584   "RTN","RCD PRTP0",40, 0)
  14585   TYPE     ; find third  party bil ls by care  type PRCA *4.5*315
  14586   "RTN","RCD PRTP0",41, 0)
  14587    N RCDFN,R CDEBT,RCTY P
  14588   "RTN","RCD PRTP0",42, 0)
  14589    F RCTYP=2 ,34 S DAT= $$FMADD^XL FDT(DATEST RT,-1)_".9 99999" F   S DAT=$O(^ PRCA(433," AT",RCTYP, DAT)) Q:'D AT!(DAT>(D ATEEND_".9 99999"))   D
  14590   "RTN","RCD PRTP0",43, 0)
  14591    .S RCPAY= 0 F  S RCP AY=$O(^PRC A(433,"AT" ,RCTYP,DAT ,RCPAY)) Q :'RCPAY  D
  14592   "RTN","RCD PRTP0",44, 0)
  14593    ..S RCBIL =$P($G(^PR CA(433,+RC PAY,0)),"^ ",2)
  14594   "RTN","RCD PRTP0",45, 0)
  14595    ..S RCBIL 0=$G(^PRCA (430,+RCBI L,0)) Q:RC BIL0=""
  14596   "RTN","RCD PRTP0",46, 0)
  14597    ..Q:$P(RC BIL0,"^",2 )'=9
  14598   "RTN","RCD PRTP0",47, 0)
  14599    ..S RCDFN =$P(RCBIL0 ,"^",7)
  14600   "RTN","RCD PRTP0",48, 0)
  14601    ..S RCDEB T=$O(^RCD( 340,"B",RC DFN_";DPT( ",0)) Q:'R CDEBT
  14602   "RTN","RCD PRTP0",49, 0)
  14603    ..S RCNAM =$$NAM^RCF N01(RCDEBT )
  14604   "RTN","RCD PRTP0",50, 0)
  14605    ..S RCSSN =$$SSN^RCF N01(RCDEBT )
  14606   "RTN","RCD PRTP0",51, 0)
  14607    ..S DFN=R CDFN D DEM ^VADPT,ELI G^VADPT
  14608   "RTN","RCD PRTP0",52, 0)
  14609    ..S RCTYP E=$$TYP^IB RFN(RCBIL)
  14610   "RTN","RCD PRTP0",53, 0)
  14611    ..S RCTYP E=$S(RCTYP E="":-1,RC TYPE="PR": "P",RCTYPE ="PH":"R", 1:RCTYPE)
  14612   "RTN","RCD PRTP0",54, 0)
  14613    ..I $D(RC TYPE(RCTYP E)) D  Q:' RCTYPE
  14614   "RTN","RCD PRTP0",55, 0)
  14615    ...S ^TMP ("RCDPRTPB ",$J,RCNAM _"^"_RCDEB T)=$P($G(V ADM(3)),"^ ",2)_"^"_$ P($G(VAEL( 1)),"^",2) _"^"_RCSSN
  14616   "RTN","RCD PRTP0",56, 0)
  14617    ...S ^TMP ("RCDPRTPB ",$J,RCNAM _"^"_RCDEB T,RCBIL)=$ P(DAT,".")
  14618   "RTN","RCD PRTP0",57, 0)
  14619    ...K DFN, VA,VADM,VA EL,VAERR
  14620   "RTN","RCD PRTP0",58, 0)
  14621    Q
  14622   "RTN","RCD PRTP0",59, 0)
  14623   BILL     ; set TMP ar ray
  14624   "RTN","RCD PRTP0",60, 0)
  14625    S RCDEBT= $O(^RCD(34 0,"B",RCDF N_";DPT(", 0)) Q:'RCD EBT
  14626   "RTN","RCD PRTP0",61, 0)
  14627    S RCNAM=$ $NAM^RCFN0 1(RCDEBT)
  14628   "RTN","RCD PRTP0",62, 0)
  14629    S RCSSN=$ $SSN^RCFN0 1(RCDEBT)
  14630   "RTN","RCD PRTP0",63, 0)
  14631    S DFN=+$G (^RCD(340, RCDEBT,0))
  14632   "RTN","RCD PRTP0",64, 0)
  14633    D DEM^VAD PT,ELIG^VA DPT
  14634   "RTN","RCD PRTP0",65, 0)
  14635    S RCTP=0  F  S RCTP= $O(^PRCA(4 33,"C",RCB ILL,RCTP))  Q:'RCTP   I "^2^34^" [("^"_$P($ G(^PRCA(43 3,+RCTP,1) ),"^",2)_" ^") S RCTP (0)=$P($P( $G(^PRCA(4 33,+RCTP,1 )),"^",9), ".")
  14636   "RTN","RCD PRTP0",66, 0)
  14637    S ^TMP("R CDPRTPB",$ J,RCNAM)=$ P($G(VADM( 3)),"^",2) _"^"_$P($G (VAEL(1)), "^",2)_"^" _RCSSN
  14638   "RTN","RCD PRTP0",67, 0)
  14639    S ^TMP("R CDPRTPB",$ J,RCNAM,RC BILL)=RCTP
  14640   "RTN","RCD PRTP0",68, 0)
  14641    K DFN,VA, VADM,VAEL, VAERR,RCBI LL,RCTP
  14642   "RTN","RCD PRTP0",69, 0)
  14643    Q
  14644   "RTN","RCD PRTP0",70, 0)
  14645    ;
  14646   "RTN","RCD PRTP0",71, 0)
  14647   REC      ; find recei pt payment s
  14648   "RTN","RCD PRTP0",72, 0)
  14649    N RCDEBT, RCDFN,RCRE C1,RCPAY1, RCBIL,RCBI L0,RCDFN,R CDEBT,RCSS N
  14650   "RTN","RCD PRTP0",73, 0)
  14651    S RCREC1= 0 F  S RCR EC1=$O(^PR CA(433,"AF ",RCPT,RCR EC1)) Q:'R CREC1  D
  14652   "RTN","RCD PRTP0",74, 0)
  14653    .S RCPAY1 =$G(^PRCA( 433,+RCREC 1,1)) Q:RC PAY1=""
  14654   "RTN","RCD PRTP0",75, 0)
  14655    .S RCBIL= 0 I "^2^34 ^"[("^"_$P (RCPAY1,"^ ",2)_"^")  S RCBIL=$P ($G(^PRCA( 433,+RCREC 1,0)),"^", 2)
  14656   "RTN","RCD PRTP0",76, 0)
  14657    .Q:'RCBIL
  14658   "RTN","RCD PRTP0",77, 0)
  14659    .S RCBIL0 =$G(^PRCA( 430,+RCBIL ,0))
  14660   "RTN","RCD PRTP0",78, 0)
  14661    .Q:$P(RCB IL0,"^",2) '=9
  14662   "RTN","RCD PRTP0",79, 0)
  14663    .S RCDFN= $P(RCBIL0, "^",7) Q:' RCDFN
  14664   "RTN","RCD PRTP0",80, 0)
  14665    .S RCDEBT =$O(^RCD(3 40,"B",RCD FN_";DPT(" ,0)) Q:'RC DEBT
  14666   "RTN","RCD PRTP0",81, 0)
  14667    .S RCSSN= $$SSN^RCFN 01(RCDEBT)
  14668   "RTN","RCD PRTP0",82, 0)
  14669    .S RCNAM= $$NAM^RCFN 01(RCDEBT)
  14670   "RTN","RCD PRTP0",83, 0)
  14671    .S DFN=RC DFN D DEM^ VADPT,ELIG ^VADPT
  14672   "RTN","RCD PRTP0",84, 0)
  14673    .S ^TMP(" RCDPRTPB", $J,RCNAM_" ^"_RCDEBT) =$P($G(VAD M(3)),"^", 2)_"^"_$P( $G(VAEL(1) ),"^",2)_" ^"_RCSSN
  14674   "RTN","RCD PRTP0",85, 0)
  14675    .K DFN,VA ,VADM,VAEL ,VAERR
  14676   "RTN","RCD PRTP0",86, 0)
  14677    .S ^TMP(" RCDPRTPB", $J,RCNAM_" ^"_RCDEBT, RCBIL)=$P( $P($G(^PRC A(433,+RCR EC1,1)),"^ ",9),".")
  14678   "RTN","RCD PRTP0",87, 0)
  14679    Q
  14680   "RTN","RCD PRTP0",88, 0)
  14681    ;
  14682   "RTN","RCD PRTP0",89, 0)
  14683   TYPEPIC(RC TYPE) ; fu nction for  user sele ction of c are types  PRCA*4.5*3 15
  14684   "RTN","RCD PRTP0",90, 0)
  14685    ; RCTYPE  is an outp ut array,  pass by re ference
  14686   "RTN","RCD PRTP0",91, 0)
  14687    ; RCTYPE( type)="" w here type  can be (I) npatient,  (O)utpatie nt,(P)rost hetics or  (R)x (Pres cription)
  14688   "RTN","RCD PRTP0",92, 0)
  14689    ; Functio n value is  1 if at l east 1 car e type was  selected,  0 otherwi se
  14690   "RTN","RCD PRTP0",93, 0)
  14691    ; User ca n select o ne, all or  a combina tion of ca re types.
  14692   "RTN","RCD PRTP0",94, 0)
  14693    ;
  14694   "RTN","RCD PRTP0",95, 0)
  14695    N DIR,X,Y ,OK,DTOUT, DUOUT,DIRU T,DIROUT,R C
  14696   "RTN","RCD PRTP0",96, 0)
  14697    K RCTYPE
  14698   "RTN","RCD PRTP0",97, 0)
  14699    S OK=1 ;  all OK def ault
  14700   "RTN","RCD PRTP0",98, 0)
  14701    S DIR(0)= "S"
  14702   "RTN","RCD PRTP0",99, 0)
  14703    S RC=";I: Inpatient"
  14704   "RTN","RCD PRTP0",100 ,0)
  14705    S RC=RC_" ;O:Outpati ent"
  14706   "RTN","RCD PRTP0",101 ,0)
  14707    S RC=RC_" ;P:Prosthe tic"
  14708   "RTN","RCD PRTP0",102 ,0)
  14709    S RC=RC_" ;R:Prescri ption"
  14710   "RTN","RCD PRTP0",103 ,0)
  14711    S RC=RC_" ;ALL:All"
  14712   "RTN","RCD PRTP0",104 ,0)
  14713    S $P(DIR( 0),U,2)=RC ,DIR("B")= "ALL"
  14714   "RTN","RCD PRTP0",105 ,0)
  14715    S DIR("A" )="Select  a Care Typ e"
  14716   "RTN","RCD PRTP0",106 ,0)
  14717    W ! D ^DI R K DIR
  14718   "RTN","RCD PRTP0",107 ,0)
  14719    I (Y["A")  D  Q  ; a ll types s elected so  set & qui t
  14720   "RTN","RCD PRTP0",108 ,0)
  14721    . F X="I" ,"O","P"," R" S RCTYP E(X)=""
  14722   "RTN","RCD PRTP0",109 ,0)
  14723    . Q
  14724   "RTN","RCD PRTP0",110 ,0)
  14725    I $D(DIRU T)!(Y="")  Q
  14726   "RTN","RCD PRTP0",111 ,0)
  14727    S X=$$UC( X)
  14728   "RTN","RCD PRTP0",112 ,0)
  14729    S RCTYPE( X)=""                   ; Toggle  back on
  14730   "RTN","RCD PRTP0",113 ,0)
  14731    ; Select  another ty pe
  14732   "RTN","RCD PRTP0",114 ,0)
  14733    I (Y'["A" ) F  D  Q: X=""!(RCQU IT)
  14734   "RTN","RCD PRTP0",115 ,0)
  14735    . I ($G(D IRUT)'="")  S OK=0,RC QUIT=1 Q
  14736   "RTN","RCD PRTP0",116 ,0)
  14737    . S DIR(0 )="SBO^I:I npatient;O :Outpatien t;P:Prosth etic;R:Pre scription"
  14738   "RTN","RCD PRTP0",117 ,0)
  14739    . S DIR(" A")="Selec t another  Care Type"  D ^DIR K  DIR
  14740   "RTN","RCD PRTP0",118 ,0)
  14741    . I $G(DU OUT) W !!, "User exit ed with '^ ', quittin g",! S RCQ UIT=1 Q
  14742   "RTN","RCD PRTP0",119 ,0)
  14743    . I $D(DI RUT) S OK= 0 Q
  14744   "RTN","RCD PRTP0",120 ,0)
  14745    . I (X="" ) Q
  14746   "RTN","RCD PRTP0",121 ,0)
  14747    . S X=$$U C(X)
  14748   "RTN","RCD PRTP0",122 ,0)
  14749    . S RCTYP E(X)=""
  14750   "RTN","RCD PRTP0",123 ,0)
  14751    . Q
  14752   "RTN","RCD PRTP0",124 ,0)
  14753    I $D(DUOU T)!$D(DTOU T) S OK=0  ; exit if  "^" or tim e-out
  14754   "RTN","RCD PRTP0",125 ,0)
  14755    I '$D(RCT YPE) S OK= 0 W $C(7)
  14756   "RTN","RCD PRTP0",126 ,0)
  14757    Q OK
  14758   "RTN","RCD PRTP0",127 ,0)
  14759   FORMAT(RCE XCEL) ; ca pture the  report for mat from t he user (n ormal or C SV output)  PRCA*4.5* 315
  14760   "RTN","RCD PRTP0",128 ,0)
  14761    ; RCEXCEL =0 for nor mal output
  14762   "RTN","RCD PRTP0",129 ,0)
  14763    ; RCEXCEL =1 (^ sepa rated valu es) for Ex cel output
  14764   "RTN","RCD PRTP0",130 ,0)
  14765    ; pass pa rameter by  reference
  14766   "RTN","RCD PRTP0",131 ,0)
  14767    ;
  14768   "RTN","RCD PRTP0",132 ,0)
  14769    N RET,DIR ,X,Y,DTOUT ,DUOUT,DIR UT,DIROUT
  14770   "RTN","RCD PRTP0",133 ,0)
  14771    S RCEXCEL =0,RET=1
  14772   "RTN","RCD PRTP0",134 ,0)
  14773    S DIR("A" )="Do you  want to ca pture repo rt data fo r an Excel  document"
  14774   "RTN","RCD PRTP0",135 ,0)
  14775    S DIR("B" )="NO"
  14776   "RTN","RCD PRTP0",136 ,0)
  14777    S DIR(0)= "Y"
  14778   "RTN","RCD PRTP0",137 ,0)
  14779    S DIR("?" ,1)="If yo u want to  capture th e output f rom this r eport in a  ^-separat ed"
  14780   "RTN","RCD PRTP0",138 ,0)
  14781    S DIR("?" ,2)="value s (Excel)  format, th en answer  YES here."
  14782   "RTN","RCD PRTP0",139 ,0)
  14783    S DIR("?" ,3)=" "
  14784   "RTN","RCD PRTP0",140 ,0)
  14785    S DIR("?" )="If you  just want  a normal r eport outp ut, then a nswer NO h ere."
  14786   "RTN","RCD PRTP0",141 ,0)
  14787    W ! D ^DI R K DIR
  14788   "RTN","RCD PRTP0",142 ,0)
  14789    I $D(DIRU T) S RET=0  W $C(7)
  14790   "RTN","RCD PRTP0",143 ,0)
  14791    S RCEXCEL =Y
  14792   "RTN","RCD PRTP0",144 ,0)
  14793    Q RCEXCEL
  14794   "RTN","RCD PRTP0",145 ,0)
  14795    ;
  14796   "RTN","RCD PRTP0",146 ,0)
  14797   DEVICE() ;  Device Se lection PR CA*4.5*315
  14798   "RTN","RCD PRTP0",147 ,0)
  14799    ; RCEXCEL =0 for nor mal output
  14800   "RTN","RCD PRTP0",148 ,0)
  14801    ; RCEXCEL =1 for Exc el ('^' se parated va lues)outpu t
  14802   "RTN","RCD PRTP0",149 ,0)
  14803    ; pass pa rameter by  reference
  14804   "RTN","RCD PRTP0",150 ,0)
  14805    ;
  14806   "RTN","RCD PRTP0",151 ,0)
  14807    N ZTRTN,Z TDESC,ZTSA VE,POP,RET ,ZTSK,DIR, X,Y,DIOEND
  14808   "RTN","RCD PRTP0",152 ,0)
  14809    S RET=1,Q UIT=0
  14810   "RTN","RCD PRTP0",153 ,0)
  14811    I RCEXCEL  D
  14812   "RTN","RCD PRTP0",154 ,0)
  14813    . W !!,"F or Excel o utput, tur n logging  or capture  on now."
  14814   "RTN","RCD PRTP0",155 ,0)
  14815    . W !,"To  avoid und esired wra pping of t he data sa ved to the  file,"
  14816   "RTN","RCD PRTP0",156 ,0)
  14817    . W !,"pl ease enter  ""0;256;9 9999"" at  the ""DEVI CE:"" prom pt.",!
  14818   "RTN","RCD PRTP0",157 ,0)
  14819    K IOP,IO( "Q") S %ZI S="MQ",%ZI S("B")=""  D ^%ZIS Q: POP
  14820   "RTN","RCD PRTP0",158 ,0)
  14821    I $D(IO(" Q")) D  Q
  14822   "RTN","RCD PRTP0",159 ,0)
  14823    .S ZTDESC ="Claims M atching Ex cel Report ",ZTRTN="P RINT^RCDPR TEX"
  14824   "RTN","RCD PRTP0",160 ,0)
  14825    .S ZTSAVE ("RCSORT") =""
  14826   "RTN","RCD PRTP0",161 ,0)
  14827    .I RCSORT =1 S ZTSAV E("RCDEBT" )="",ZTSAV E("RCDFN") ="",ZTSAVE ("RCTYPE*" )=""
  14828   "RTN","RCD PRTP0",162 ,0)
  14829    .I RCSORT =2 S ZTSAV E("RCBILL" )="",ZTSAV E("RCDFN") ="",ZTSAVE ("RCDEBT") =""
  14830   "RTN","RCD PRTP0",163 ,0)
  14831    .I RCSORT =4 S ZTSAV E("RCPT")= ""
  14832   "RTN","RCD PRTP0",164 ,0)
  14833    .I RCSORT =5 S ZTSAV E("RCTYPE* ")="",ZTSA VE("DATE*" )=""
  14834   "RTN","RCD PRTP0",165 ,0)
  14835    .S ZTSAVE ("DATEEND" )="",ZTSAV E("DATESTR T")="",ZTS AVE("RCQUI T")="",ZTS AVE("RCSOR T")="",ZTS AVE("RCEXC EL")=""
  14836   "RTN","RCD PRTP0",166 ,0)
  14837    .S ZTSAVE ("RCAN")=" ",ZTSAVE(" ZTREQ")="@ ",ZTSAVE(" ^TMP(""RCD PRTPB"",$J ,")=""
  14838   "RTN","RCD PRTP0",167 ,0)
  14839    .S DIOEND ="K ^TMP(" "RCDPRTPB" ",$J)"
  14840   "RTN","RCD PRTP0",168 ,0)
  14841    .I $G(ZTS K) W !!,"R eport comp ilation ha s started  with task#  ",ZTSK,". ",!
  14842   "RTN","RCD PRTP0",169 ,0)
  14843    .D ^%ZTLO AD,HOME^%Z IS S QUIT= 1
  14844   "RTN","RCD PRTP0",170 ,0)
  14845    .I POP S  RET=0
  14846   "RTN","RCD PRTP0",171 ,0)
  14847    Q RET
  14848   "RTN","RCD PRTP0",172 ,0)
  14849    ;
  14850   "RTN","RCD PRTP0",173 ,0)
  14851   UC(RCINPUT ) ;
  14852   "RTN","RCD PRTP0",174 ,0)
  14853    S RCINPUT =$TR(X,"ab cdefghijkl mnopqrstuv wxyz","ABC DEFGHIJKLM NOPQRSTUVW XYZ")
  14854   "RTN","RCD PRTP0",175 ,0)
  14855    Q RCINPUT
  14856   "RTN","RCD PRTP1")
  14857   0^45^B4961 9894^B3348 0590
  14858   "RTN","RCD PRTP1",1,0 )
  14859   RCDPRTP1   ;ALB/LDB -  CLAIMS MA TCHING REP ORT (PRINT ) ;1/26/01   2:56 PM
  14860   "RTN","RCD PRTP1",2,0 )
  14861    ;;4.5;Acc ounts Rece ivable;**1 51,169,276 ,284,315** ;Mar 20, 1 995;Build  55
  14862   "RTN","RCD PRTP1",3,0 )
  14863    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  14864   "RTN","RCD PRTP1",4,0 )
  14865    ;
  14866   "RTN","RCD PRTP1",5,0 )
  14867   EN       ;  Entry poi nt to prin t the Clai ms Matchin g Report.
  14868   "RTN","RCD PRTP1",6,0 )
  14869    N %,DATED IS1,DATEDI S2,NOW,PG, RCBILL,RCA MT,RCAMT1, RCIBDAT,RC IBFN,RCNAM ,RCNAM1,RC NO,RCNOW,R CDLINE,RCL INE,RCPHIT
  14870   "RTN","RCD PRTP1",7,0 )
  14871    ; PRCA*4. 5*284 - Re move RCPT  'new' as t his is the  receipt #  from user  entry
  14872   "RTN","RCD PRTP1",8,0 )
  14873    N RCQ,RCS SN,RCSTAT, RCTP,X,Y
  14874   "RTN","RCD PRTP1",9,0 )
  14875    ;
  14876   "RTN","RCD PRTP1",10, 0)
  14877    ; - initi alize repo rt header  variables
  14878   "RTN","RCD PRTP1",11, 0)
  14879    S PG=0
  14880   "RTN","RCD PRTP1",12, 0)
  14881    Q:RCQUIT
  14882   "RTN","RCD PRTP1",13, 0)
  14883    I RCSORT' =2,(RCSORT '=4) D
  14884   "RTN","RCD PRTP1",14, 0)
  14885    .S Y=$P(D ATESTRT,". ") D DD^%D T S DATEDI S1=Y
  14886   "RTN","RCD PRTP1",15, 0)
  14887    .S Y=$P(D ATEEND,"." ) D DD^%DT  S DATEDIS 2=Y
  14888   "RTN","RCD PRTP1",16, 0)
  14889    D NOW^%DT C S Y=% D  DD^%DT S R CNOW=$E(Y, 1,18)
  14890   "RTN","RCD PRTP1",17, 0)
  14891    S RCDLINE =$TR($J("" ,80)," "," -")
  14892   "RTN","RCD PRTP1",18, 0)
  14893    S RCLINE= $TR($J("", 80)," ","* ")
  14894   "RTN","RCD PRTP1",19, 0)
  14895    ;
  14896   "RTN","RCD PRTP1",20, 0)
  14897    ; - main  report loo p
  14898   "RTN","RCD PRTP1",21, 0)
  14899    K ^TMP($J )
  14900   "RTN","RCD PRTP1",22, 0)
  14901    ;
  14902   "RTN","RCD PRTP1",23, 0)
  14903    I 'RCEXCE L D HDR ;  initial he ader
  14904   "RTN","RCD PRTP1",24, 0)
  14905    S RCNO=0  ; flag to  indicate a t least on e matching  claim
  14906   "RTN","RCD PRTP1",25, 0)
  14907    ;
  14908   "RTN","RCD PRTP1",26, 0)
  14909    S RCNAM=" " F  S RCN AM=$O(^TMP ("RCDPRTPB ",$J,RCNAM )) Q:RCNAM =""!$G(RCQ )  D
  14910   "RTN","RCD PRTP1",27, 0)
  14911    .S RCBILL =0 F  S RC BILL=$O(^T MP("RCDPRT PB",$J,RCN AM,RCBILL) ) Q:'RCBIL L!$G(RCQ)   D
  14912   "RTN","RCD PRTP1",28, 0)
  14913    ..S RCPHI T=0 ; flag  that requ ires patie nt info to  print
  14914   "RTN","RCD PRTP1",29, 0)
  14915    ..D PROC  ;     proc ess a sing le third p arty bill
  14916   "RTN","RCD PRTP1",30, 0)
  14917    ..K ^TMP( "IBRBT",$J ),^TMP("IB RBF",$J)
  14918   "RTN","RCD PRTP1",31, 0)
  14919    ;
  14920   "RTN","RCD PRTP1",32, 0)
  14921    I $G(RCQ)  G ENQ
  14922   "RTN","RCD PRTP1",33, 0)
  14923    ;
  14924   "RTN","RCD PRTP1",34, 0)
  14925    I $O(^TMP ("RCDPRTPB ",$J,0))=" " W !!,?18 ,"No match ing debts. " Q
  14926   "RTN","RCD PRTP1",35, 0)
  14927    ;I 'RCNO  W !!,?18," No matchin g debts."
  14928   "RTN","RCD PRTP1",36, 0)
  14929   ENQ      ;
  14930   "RTN","RCD PRTP1",37, 0)
  14931    Q
  14932   "RTN","RCD PRTP1",38, 0)
  14933    ;
  14934   "RTN","RCD PRTP1",39, 0)
  14935    ;
  14936   "RTN","RCD PRTP1",40, 0)
  14937   PROC     ;  Process e ach third  party bill  for a pat ient.
  14938   "RTN","RCD PRTP1",41, 0)
  14939    D RELBILL ^IBRFN(RCB ILL)
  14940   "RTN","RCD PRTP1",42, 0)
  14941    S RCQUIT= 0  ;added  for care t ype check
  14942   "RTN","RCD PRTP1",43, 0)
  14943    ;Add code  to check  ^TMP("IBRB T",$J  --- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ------for  third part y charges
  14944   "RTN","RCD PRTP1",44, 0)
  14945    I $D(RCTY PE)>1,$D(^ TMP("IBRBT ",$J)) N J  S J=0 F   S J=$O(^TM P("IBRBT", $J,RCBILL, J)) Q:'J   D
  14946   "RTN","RCD PRTP1",45, 0)
  14947    . S RCTYP =$$TYP^IBR FN(J),RCTY P=$S(RCTYP ="":-1,RCT YP="PR":"P ",RCTYP="P H":"R",1:R CTYP)
  14948   "RTN","RCD PRTP1",46, 0)
  14949    . I '$D(R CTYPE(RCTY P)) K ^TMP ("IBRBT",$ J,RCBILL,J )  ;    Ve rify that  the type i s one of t he selecte d type, if  not delet e the ^TMP  global no de for tha t claim
  14950   "RTN","RCD PRTP1",47, 0)
  14951    ; - quit  if there a re no asso ciated fir st party b ills
  14952   "RTN","RCD PRTP1",48, 0)
  14953    I '$O(^TM P("IBRBF", $J,0)) K ^ TMP("RCDPR TPB",$J,RC NAM,RCBILL ) G PROCQ
  14954   "RTN","RCD PRTP1",49, 0)
  14955    ;
  14956   "RTN","RCD PRTP1",50, 0)
  14957    S (RCAMT( 0),RCAMT(1 ))=0
  14958   "RTN","RCD PRTP1",51, 0)
  14959    S RCTP(0) =0 F  S RC TP(0)=$O(^ TMP("IBRBF ",$J,RCTP( 0))) Q:'RC TP(0)  S R CTP(1)=0 F   S RCTP(1 )=$O(^TMP( "IBRBF",$J ,RCTP(0),R CTP(1))) Q :'RCTP(1)   S ^TMP($J ,"IBRBF",R CTP(1),RCT P(0))=""
  14960   "RTN","RCD PRTP1",52, 0)
  14961    ; PRCA*4. 5*284 - Ch ange typo  of RCPT(0) =0 to RCTP (0)=0
  14962   "RTN","RCD PRTP1",53, 0)
  14963    S RCTP(0) =0 F  S RC TP(0)=$O(^ TMP($J,"IB RBF",RCTP( 0))) Q:'RC TP(0)  S R CTP(1)=0 F   S RCTP(1 )=$O(^TMP( $J,"IBRBF" ,RCTP(0),R CTP(1))) Q :'RCTP(1)   D
  14964   "RTN","RCD PRTP1",54, 0)
  14965    .I RCTP(1 )=RCBILL Q
  14966   "RTN","RCD PRTP1",55, 0)
  14967    .I $D(^TM P($J,"IBRB F",RCTP(0) ,RCBILL))! (RCTP(1)'= $O(^TMP($J ,"IBRBF",R CTP(0),0)) ) K ^TMP(" IBRBF",$J, RCTP(1),RC TP(0)),^TM P($J,"IBRB F",RCTP(0) ,RCTP(1))  I '$O(^TMP ("IBRBF",$ J,RCTP(1), 0)) K ^TMP ("IBRBF",$ J,RCTP(1))
  14968   "RTN","RCD PRTP1",56, 0)
  14969    ;
  14970   "RTN","RCD PRTP1",57, 0)
  14971    S RCTP(0) ="" F  S R CTP(0)=$O( ^TMP("IBRB T",$J,RCBI LL,RCTP(0) )) Q:RCTP( 0)=""  D
  14972   "RTN","RCD PRTP1",58, 0)
  14973    .;if asso ciated thi rd party h as had pay ment also  do not lis t twice
  14974   "RTN","RCD PRTP1",59, 0)
  14975    .I $D(^TM P("RCDPRTP B",$J,RCNA M,RCTP(0)) ),(RCBILL' =RCTP(0))  S RCTP(RCT P(0))=^TMP ("RCDPRTPB ",$J,RCNAM ,RCTP(0))  K ^(RCTP(0 ))
  14976   "RTN","RCD PRTP1",60, 0)
  14977    .;if no p rescriptio n coverage  exclude a ssociated  rx co-pay  charges
  14978   "RTN","RCD PRTP1",61, 0)
  14979    .I '$P(^T MP("IBRBT" ,$J,RCBILL ),"^") D
  14980   "RTN","RCD PRTP1",62, 0)
  14981    ..S RCTP( 1)=0 F  S  RCTP(1)=$O (^TMP("IBR BF",$J,RCT P(0),RCTP( 1))) Q:RCT P(1)=""  I  $G(^TMP(" IBRBF",$J, RCTP(0),RC TP(1)))["R X" K ^TMP( "IBRBF",$J ,RCTP(0),R CTP(1)) I  '$O(^TMP(" IBRBF",$J, RCTP(0),"" )) K ^TMP( "IBRBF",$J ,RCTP(0))
  14982   "RTN","RCD PRTP1",63, 0)
  14983    .;if dupl icate char ges exclud e them fro m report
  14984   "RTN","RCD PRTP1",64, 0)
  14985    S RCTP(0) =0 F  S RC TP(0)=$O(^ TMP("IBRBF ",$J,RCTP( 0))) Q:RCT P(0)=""  S  RCTP(1)=0  F  S RCTP (1)=$O(^TM P("IBRBF", $J,RCTP(0) ,RCTP(1)))  Q:'RCTP(1 )  D
  14986   "RTN","RCD PRTP1",65, 0)
  14987    .I RCTP(0 )'=RCBILL, ($D(^TMP(" IBRBF",$J, RCBILL,RCT P(1)))) K  ^TMP("IBRB F",$J,RCTP (0),RCTP(1 )) K:'$O(^ TMP("IBRBF ",$J,RCTP( 0),0)) ^TM P("IBRBF", $J,RCTP(0) )
  14988   "RTN","RCD PRTP1",66, 0)
  14989    ;
  14990   "RTN","RCD PRTP1",67, 0)
  14991    ;exclude  cancelled  charges if  not selec ted to be  on report
  14992   "RTN","RCD PRTP1",68, 0)
  14993    I 'RCAN D
  14994   "RTN","RCD PRTP1",69, 0)
  14995    .S RCTP(0 )=0 F  S R CTP(0)=$O( ^TMP("IBRB F",$J,RCTP (0))) Q:RC TP(0)=""   S RCTP(1)= 0 F  S RCT P(1)=$O(^T MP("IBRBF" ,$J,RCTP(0 ),RCTP(1)) ) Q:'RCTP( 1)  D
  14996   "RTN","RCD PRTP1",70, 0)
  14997    ..I $P(^T MP("IBRBF" ,$J,RCTP(0 ),RCTP(1)) ,"^",3) K  ^TMP("IBRB F",$J,RCTP (0),RCTP(1 )) Q
  14998   "RTN","RCD PRTP1",71, 0)
  14999    ..S RCPT( 2)=$O(^PRC A(430,"B", +$P(^TMP(" IBRBF",$J, RCTP(0),RC TP(1)),"^" ,4),0)) I  ($P($G(^PR CA(430,+RC PT(2),0)), "^",8)=39) !($P($G(^P RCA(430,+R CPT(2),0)) ,"^",8)=26 ) K ^TMP(" IBRBF",$J, RCTP(0),RC TP(1))
  15000   "RTN","RCD PRTP1",72, 0)
  15001    ..I '$O(^ TMP("IBRBF ",$J,RCTP( 0),"")) K  ^TMP("IBRB F",$J,RCTP (0))
  15002   "RTN","RCD PRTP1",73, 0)
  15003    I '$O(^TM P("IBRBF", $J,RCBILL, 0)) K ^TMP ("RCDPRTPB ",$J,RCNAM ,RCBILL) G  PROCQ
  15004   "RTN","RCD PRTP1",74, 0)
  15005    ;
  15006   "RTN","RCD PRTP1",75, 0)
  15007    I RCEXCEL  D PRNTPAT ^RCDPRTEX  K ^TMP($J)  Q    ;Pri nt in clai ms in exce l format a nd quit
  15008   "RTN","RCD PRTP1",76, 0)
  15009    ;
  15010   "RTN","RCD PRTP1",77, 0)
  15011    ;  - prin t patient  detail lin e
  15012   "RTN","RCD PRTP1",78, 0)
  15013    I 'RCPHIT  S RCPHIT= 1 D PRINT3 ^RCDPRTP2  G:$G(RCQ)  PROCQ
  15014   "RTN","RCD PRTP1",79, 0)
  15015    ;
  15016   "RTN","RCD PRTP1",80, 0)
  15017    ; - print  third par ty bills
  15018   "RTN","RCD PRTP1",81, 0)
  15019    ;    o  p rint the h eader firs t; need ro om for the  header an d
  15020   "RTN","RCD PRTP1",82, 0)
  15021    ;       t he bill th at was pai d.
  15022   "RTN","RCD PRTP1",83, 0)
  15023    ;    o  p rint the b ill that w as paid.
  15024   "RTN","RCD PRTP1",84, 0)
  15025    S RCTP=RC BILL,RCIBD AT=$G(^TMP ("IBRBT",$ J,RCBILL,R CBILL))
  15026   "RTN","RCD PRTP1",85, 0)
  15027    I $Y>(IOS L-7) D PAU SE^RCDPRTP 2 G:$G(RCQ ) PROCQ D  HDR
  15028   "RTN","RCD PRTP1",86, 0)
  15029    D HDR1^RC DPRTP2,PRI NT1^RCDPRT P2 G:$G(RC Q) PROCQ
  15030   "RTN","RCD PRTP1",87, 0)
  15031    ;
  15032   "RTN","RCD PRTP1",88, 0)
  15033    ; PRCA*4. 5*284, cor rected typ o of 'asso icated' to  'associat ed'
  15034   "RTN","RCD PRTP1",89, 0)
  15035    ; - print  the other  associate d third pa rty bills
  15036   "RTN","RCD PRTP1",90, 0)
  15037    S RCTP=0  F  S RCTP= $O(^TMP("I BRBT",$J,R CBILL,RCTP )) Q:'RCTP !$G(RCQ)   D
  15038   "RTN","RCD PRTP1",91, 0)
  15039    .I RCBILL =RCTP Q  ;  don't rep rint the b ill that w as paid.
  15040   "RTN","RCD PRTP1",92, 0)
  15041    .S RCIBDA T=$G(^TMP( "IBRBT",$J ,RCBILL,RC TP))
  15042   "RTN","RCD PRTP1",93, 0)
  15043    .I 'RCAN, ($P(RCIBDA T,"^",3))  Q  ; exclu de cancell ed claims
  15044   "RTN","RCD PRTP1",94, 0)
  15045    .D PRINT1 ^RCDPRTP2
  15046   "RTN","RCD PRTP1",95, 0)
  15047    G:$G(RCQ)  PROCQ
  15048   "RTN","RCD PRTP1",96, 0)
  15049    ;
  15050   "RTN","RCD PRTP1",97, 0)
  15051    ; - print  the third  party tot als
  15052   "RTN","RCD PRTP1",98, 0)
  15053    ; PRCA*4. 5*276 - ad justed hea der to mak e room for  EEOB indi cator '%'
  15054   "RTN","RCD PRTP1",99, 0)
  15055    I $Y>(IOS L-2) D PAU SE^RCDPRTP 2 G:$G(RCQ ) PROCQ D  HDR W !
  15056   "RTN","RCD PRTP1",100 ,0)
  15057    W !,?63," ---------- ",?75,"--- -------"
  15058   "RTN","RCD PRTP1",101 ,0)
  15059    W !,?64,$ J(RCAMT(0) ,9,2),?76, $J(RCAMT(1 ),9,2)
  15060   "RTN","RCD PRTP1",102 ,0)
  15061    ;
  15062   "RTN","RCD PRTP1",103 ,0)
  15063    ; - print  the assoc iated firs t party ch arges
  15064   "RTN","RCD PRTP1",104 ,0)
  15065    ; 
  15066   "RTN","RCD PRTP1",105 ,0)
  15067    ;                                                                   PRCA*4. 5*315  new  screen fo r first pa rty charge s by (CARE  TYPES)
  15068   "RTN","RCD PRTP1",106 ,0)
  15069    ;check gl obal node  ^TMP("IBRB F",$J, all  bills, al l charges)  --
  15070   "RTN","RCD PRTP1",107 ,0)
  15071    N RCACTYP ,I,J  ;Do  the next s ection of  code only  if Care Ty pes were s elected -  Stored in  RCTYPE([ca re type])
  15072   "RTN","RCD PRTP1",108 ,0)
  15073    ;                                                                                                                                                                                    We m ust loop t hrough all  Bills and  First par ty charges  for this  screening
  15074   "RTN","RCD PRTP1",109 ,0)
  15075    I $D(RCTY PE)>1 S I= 0 F  S I=$ O(^TMP("IB RBF",$J,I) ) Q:'I  S  J=0 F  S J =$O(^TMP(" IBRBF",$J, I,J)) Q:'J   D
  15076   "RTN","RCD PRTP1",110 ,0)
  15077    . S RCACT YP=$P(^TMP ("IBRBF",$ J,I,J),U,6 ) Q:RCACTY P=""  ;6th  piece is  Action Typ e
  15078   "RTN","RCD PRTP1",111 ,0)
  15079    . I RCACT YP["TRICAR E"!(RCACTY P["CHAMPA" ) Q   ;                                                                   Tr i-care Not  needed fo r screenin g 1st part y charges
  15080   "RTN","RCD PRTP1",112 ,0)
  15081    . I RCACT YP["RX" S  RCTYP="R"  D KILFPTY  Q
  15082   "RTN","RCD PRTP1",113 ,0)
  15083    . I RCACT YP["OPT"!( RCACTYP["O BSERV") S  RCTYP="O"  D KILFPTY  Q
  15084   "RTN","RCD PRTP1",114 ,0)
  15085    . I RCACT YP["INPT"! (RCACTYP[" NHCU")!(RC ACTYP["ADM IS")!(RCAC TYP["MEDIC ARE DECUCT IBLE") S R CTYP="I" D  KILFPTY Q
  15086   "RTN","RCD PRTP1",115 ,0)
  15087    .Q
  15088   "RTN","RCD PRTP1",116 ,0)
  15089    ;
  15090   "RTN","RCD PRTP1",117 ,0)
  15091    S RCTP(0) =0 F  S RC TP(0)=$O(^ TMP("IBRBF ",$J,RCTP( 0))) Q:'RC TP(0)!$G(R CQ)  D
  15092   "RTN","RCD PRTP1",118 ,0)
  15093    .I RCTP(0 )=$O(^TMP( "IBRBF",$J ,0)) Q:$D( ^TMP("IBRB F",$J,RCTP (0)))<10   D   ;New c ode - quit  if ^TMP(" IBRBF" has  no sub no des
  15094   "RTN","RCD PRTP1",119 ,0)
  15095    ..I $Y>(I OSL-5) D P AUSE^RCDPR TP2 Q:$G(R CQ)  D HDR
  15096   "RTN","RCD PRTP1",120 ,0)
  15097    ..; - pri nt the hea der for th e first ch arge
  15098   "RTN","RCD PRTP1",121 ,0)
  15099    ..D HDR2^ RCDPRTP2
  15100   "RTN","RCD PRTP1",122 ,0)
  15101    .S RCTP=0  F  S RCTP =$O(^TMP(" IBRBF",$J, RCTP(0),RC TP)) Q:'RC TP!$G(RCQ)   D
  15102   "RTN","RCD PRTP1",123 ,0)
  15103    ..S RCNO= 1 ; set fl ag for at  least one  match
  15104   "RTN","RCD PRTP1",124 ,0)
  15105    ..S RCIBD AT=$G(^TMP ("IBRBF",$ J,RCTP(0), RCTP))
  15106   "RTN","RCD PRTP1",125 ,0)
  15107    ..; - pri nt the pat ient detai l line
  15108   "RTN","RCD PRTP1",126 ,0)
  15109    ..I RCNO  D PRINT2^R CDPRTP2
  15110   "RTN","RCD PRTP1",127 ,0)
  15111    ;.
  15112   "RTN","RCD PRTP1",128 ,0)
  15113    ; PRCA*4. 5*284, cle anup ^TMP( $J) only
  15114   "RTN","RCD PRTP1",129 ,0)
  15115   PROCQ  ;
  15116   "RTN","RCD PRTP1",130 ,0)
  15117    K ^TMP($J ) Q
  15118   "RTN","RCD PRTP1",131 ,0)
  15119    ;
  15120   "RTN","RCD PRTP1",132 ,0)
  15121    ;
  15122   "RTN","RCD PRTP1",133 ,0)
  15123   HDR      ;  Print the  main repo rt header.
  15124   "RTN","RCD PRTP1",134 ,0)
  15125    S PG=PG+1  I PG'=1!( $E(IOST,1, 2)="C-") W  @IOF
  15126   "RTN","RCD PRTP1",135 ,0)
  15127    W !,?5,"T HIRD PARTY  CLAIMS W/ MATCHING F IRST PARTY  DEBTS  ", RCNOW," PA GE ",PG
  15128   "RTN","RCD PRTP1",136 ,0)
  15129    I RCSORT' =2,(RCSORT '=4) W !,? 18,"FOR TH E PAYMENT  DATES: ",D ATEDIS1,"   TO  ",DAT EDIS2
  15130   "RTN","RCD PRTP1",137 ,0)
  15131    I RCSORT= 4 W !,?18, "RECEIPT N UMBER ",RC PT
  15132   "RTN","RCD PRTP1",138 ,0)
  15133    W !,RCDLI NE
  15134   "RTN","RCD PRTP1",139 ,0)
  15135    I PG=1 D
  15136   "RTN","RCD PRTP1",140 ,0)
  15137    .W !!,"Re member tha t any acti ons taken  to decreas e the firs t party re ceivables  must"
  15138   "RTN","RCD PRTP1",141 ,0)
  15139    .W !,"con sider any  applicable  deductibl es or coin surance am ounts spec ified on t he EOB."
  15140   "RTN","RCD PRTP1",142 ,0)
  15141    Q
  15142   "RTN","RCD PRTP1",143 ,0)
  15143    ;
  15144   "RTN","RCD PRTP1",144 ,0)
  15145    ;PRCA*4.5 *315
  15146   "RTN","RCD PRTP1",145 ,0)
  15147   KILFPTY ;K ILL 1st pa rty associ ated claim  from ^TMP ("IBRBF",  $J), used  to screen  out unwant ed 1st par ty bills ( wrong Care  Type)
  15148   "RTN","RCD PRTP1",146 ,0)
  15149    ;Verify t hat the ty pe is one  of the sel ected care  types, if  not delet e the ^TMP  global no de for tha t charge
  15150   "RTN","RCD PRTP1",147 ,0)
  15151    I '$D(RCT YPE(RCTYP) ) K ^TMP(" IBRBF",$J, I,J)
  15152   "RTN","RCD PRTP1",148 ,0)
  15153    Q
  15154   "RTN","RCD PRTP1",149 ,0)
  15155    ;
  15156   "RTN","RCD PRTP2")
  15157   0^4^B20782 087^B15639 829
  15158   "RTN","RCD PRTP2",1,0 )
  15159   RCDPRTP2 ; ALB/LDB -  CLAIMS MAT CHING REPO RT ;1/26/0 1  3:16 PM
  15160   "RTN","RCD PRTP2",2,0 )
  15161    ;;4.5;Acc ounts Rece ivable;**1 51,276,303 ,315**;Mar  20, 1995; Build 55
  15162   "RTN","RCD PRTP2",3,0 )
  15163    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  15164   "RTN","RCD PRTP2",4,0 )
  15165    ;
  15166   "RTN","RCD PRTP2",5,0 )
  15167    ; Referen ce to $$TY P^IBRFN su pported by  DBIA# 203 1
  15168   "RTN","RCD PRTP2",6,0 )
  15169    ;
  15170   "RTN","RCD PRTP2",7,0 )
  15171   PRINT1 ;
  15172   "RTN","RCD PRTP2",8,0 )
  15173    N REJECT, RCTYP
  15174   "RTN","RCD PRTP2",9,0 )
  15175    ; double  check the  status to  screen out  cancelled  third par ty bills
  15176   "RTN","RCD PRTP2",10, 0)
  15177    I 'RCAN N  TSTAT S T STAT=$$STA T(RCTP) Q: TSTAT="CN" !(TSTAT="C B")  ;Adde d a last m inute chec k for canc elled thir d party bi lls 
  15178   "RTN","RCD PRTP2",11, 0)
  15179    ;
  15180   "RTN","RCD PRTP2",12, 0)
  15181    I $Y>(IOS L-2) D PAU SE Q:$G(RC Q)  D HDR^ RCDPRTP1,H DR1
  15182   "RTN","RCD PRTP2",13, 0)
  15183    ; PRCA*4. 5*276 - ge t EEOB ind icator '%' and attach  it to the  bill numb er when ap plicable.  Adjust rep ort tabs t o make roo m for EEOB  indicator  '%'.
  15184   "RTN","RCD PRTP2",14, 0)
  15185    N RC430 S  RC430=+$O (^PRCA(430 ,"B",""_$P (RCIBDAT," ^",4)_"",0 ))
  15186   "RTN","RCD PRTP2",15, 0)
  15187    S RCEEOB= $$EEOB(RC4 30)
  15188   "RTN","RCD PRTP2",16, 0)
  15189    ; #IA 606 0 for $$BI LLREJ^IBJT U6
  15190   "RTN","RCD PRTP2",17, 0)
  15191    S REJECT= $S($$BILLR EJ^IBJTU6( $P($P(RCIB DAT,"^",4) ,"-",2)):" c",1:" ")  ;PRCA*4.5* 303 Add in dicator fo r rejects
  15192   "RTN","RCD PRTP2",18, 0)
  15193    W !,$S(RC TP=RCBILL: "*",$D(RCT P(RCTP)):" *",1:" "), $G(RCEEOB) _REJECT_$P (RCIBDAT," ^",4),?17, $P(RCIBDAT ,"^",5),?2 4
  15194   "RTN","RCD PRTP2",19, 0)
  15195    W $$STAT( RCTP),?31, $$DATE(+RC IBDAT),?42 ,$$DATE($P (RCIBDAT," ^",2))
  15196   "RTN","RCD PRTP2",20, 0)
  15197    S Y=$S($G (RCTP(RCTP )):RCTP(RC TP),$G(^TM P("RCDPRTP B",$J,RCNA M,RCBILL)) :^(RCBILL) ,1:"") I R CTP=RCBILL !($D(RCTP( RCTP))) W  ?53,$$DATE (Y)
  15198   "RTN","RCD PRTP2",21, 0)
  15199    S RCAMT=$ P($G(^PRCA (430,+RCTP ,0)),"^",3 ),RCAMT1=$ P($G(^PRCA (430,+RCTP ,7)),"^",7 ) W ?64,$J (RCAMT,9,2 )
  15200   "RTN","RCD PRTP2",22, 0)
  15201    W ?76,$J( RCAMT1,9,2 ) S RCAMT( 0)=RCAMT(0 )+RCAMT,RC AMT(1)=RCA MT(1)+RCAM T1
  15202   "RTN","RCD PRTP2",23, 0)
  15203    W ?88,$E( $P(RCIBDAT ,"^",7),1, 25)
  15204   "RTN","RCD PRTP2",24, 0)
  15205    ; #IA 203 1 for $$TY P^IBRFN
  15206   "RTN","RCD PRTP2",25, 0)
  15207    S RCTYP=$ $TYP^IBRFN (RCTP) ; g et bill ty pe for an  Accounts R eceivable
  15208   "RTN","RCD PRTP2",26, 0)
  15209    ; Convert  to single  character  care type s for: 
  15210   "RTN","RCD PRTP2",27, 0)
  15211    ; (I)npat ient, (O)u tpatient,  (R)Prescri ption & (P )rosthetic s
  15212   "RTN","RCD PRTP2",28, 0)
  15213    S RCTYP=$ S(RCTYP="" :-1,RCTYP= "PR":"P",R CTYP="PH": "R",1:RCTY P)
  15214   "RTN","RCD PRTP2",29, 0)
  15215    W ?119,RC TYP
  15216   "RTN","RCD PRTP2",30, 0)
  15217    K RCTP(RC TP)
  15218   "RTN","RCD PRTP2",31, 0)
  15219    Q
  15220   "RTN","RCD PRTP2",32, 0)
  15221    ;
  15222   "RTN","RCD PRTP2",33, 0)
  15223   PRINT2  ;  Print the  detail lin e for a fi rst party  bill.
  15224   "RTN","RCD PRTP2",34, 0)
  15225    I $Y>(IOS L-2) D PAU SE Q:$G(RC Q)  D HDR^ RCDPRTP1,H DR2
  15226   "RTN","RCD PRTP2",35, 0)
  15227    W !," ",$ P(RCIBDAT, "^",4),?14 ,$P(RCIBDA T,"^",6)
  15228   "RTN","RCD PRTP2",36, 0)
  15229    S RCIBFN= $P(RCIBDAT ,"^",4) I  RCIBFN S R CIBFN=$O(^ PRCA(430," B",RCIBFN, 0))
  15230   "RTN","RCD PRTP2",37, 0)
  15231    ; PRCA*4. 5*276 - ad just repor t tabs to  make room  for EEOB i ndicator ' %'.
  15232   "RTN","RCD PRTP2",38, 0)
  15233    W ?36,$$S TAT(RCIBFN ),?42,$$DA TE(+RCIBDA T),?54,$$D ATE($P(RCI BDAT,"^",2 ))
  15234   "RTN","RCD PRTP2",39, 0)
  15235    W ?66,$J( $P(RCIBDAT ,"^",5),9, 2),?78,$P( RCIBDAT,"^ ",7)
  15236   "RTN","RCD PRTP2",40, 0)
  15237    W ?87,$J( $S($G(^PRC A(430,+RCI BFN,7)):+( $P(^(7),"^ ")+$P(^(7) ,"^",2)+$P (^(7),"^", 3)+$P(^(7) ,"^",4)+$P (^(7),"^", 4)),1:0),9 ,2)
  15238   "RTN","RCD PRTP2",41, 0)
  15239    Q
  15240   "RTN","RCD PRTP2",42, 0)
  15241    ;
  15242   "RTN","RCD PRTP2",43, 0)
  15243    ;
  15244   "RTN","RCD PRTP2",44, 0)
  15245   PRINT3 ; P rint patie nt detail  informatio n.
  15246   "RTN","RCD PRTP2",45, 0)
  15247    N RCNAM1, RCBILL0,RC DFN,RCDOB, DOB
  15248   "RTN","RCD PRTP2",46, 0)
  15249    I $Y>(IOS L-5) D PAU SE Q:$G(RC Q)  D HDR^ RCDPRTP1
  15250   "RTN","RCD PRTP2",47, 0)
  15251    S RCNAM1= ^TMP("RCDP RTPB",$J,R CNAM)
  15252   "RTN","RCD PRTP2",48, 0)
  15253    S RCBILL0 =$G(^PRCA( 430,RCBILL ,0)) ;PRCA *4.3*315
  15254   "RTN","RCD PRTP2",49, 0)
  15255    S RCDFN=$ P($G(^PRCA (430,RCBIL L,0)),U,7)
  15256   "RTN","RCD PRTP2",50, 0)
  15257    S RCDOB=$ P($G(^DPT( RCDFN,0)), U,3)
  15258   "RTN","RCD PRTP2",51, 0)
  15259    S DOB=$$F MTE^XLFDT( RCDOB,"5Z" )
  15260   "RTN","RCD PRTP2",52, 0)
  15261    W !!,RCLI NE
  15262   "RTN","RCD PRTP2",53, 0)
  15263    W !,"NAME : ",$P(RCN AM,"^"),?4 4,"SSN: ", $E(RCNAM,1 )_$E($P(RC NAM1,"^",3 ),6,9)
  15264   "RTN","RCD PRTP2",54, 0)
  15265    W !,"Prim . Elig: ", $P(RCNAM1, "^",2)
  15266   "RTN","RCD PRTP2",55, 0)
  15267    W ?44,"DO B: ",DOB
  15268   "RTN","RCD PRTP2",56, 0)
  15269    W ?61,"RX  COVERAGE:  ",$S('$G( ^TMP("IBRB T",$J,RCBI LL)):"NO", 1:"YES")
  15270   "RTN","RCD PRTP2",57, 0)
  15271    W !,RCLIN E
  15272   "RTN","RCD PRTP2",58, 0)
  15273    Q
  15274   "RTN","RCD PRTP2",59, 0)
  15275    ;
  15276   "RTN","RCD PRTP2",60, 0)
  15277   HDR1    ;
  15278   "RTN","RCD PRTP2",61, 0)
  15279    W !!,"Thi rd Party B ills: * ->  bill for  which paym ent was po sted"
  15280   "RTN","RCD PRTP2",62, 0)
  15281    W !,"==== ========== ========== ====="
  15282   "RTN","RCD PRTP2",63, 0)
  15283    ; PRCA*4. 5*276 - ad just repor t tabs to  make room  for EEOB i ndicator ' %'.
  15284   "RTN","RCD PRTP2",64, 0)
  15285    ; PRCA*4. 5*315 - ad ded 1-char . care typ e (I)npati ent, (O)ut patient, ( R)x or (P) rosthetics ) under ne w Type col umn
  15286   "RTN","RCD PRTP2",65, 0)
  15287    W !!,"Bil l #",?15," P/S/T",?22 ,"Status", ?30,"Bill  From",?42, "Bill To", ?53,"Poste d",?63,"Am t Billed", ?76,"Amt P aid",?88," Payor",?11 5,"Care Ty pe"
  15288   "RTN","RCD PRTP2",66, 0)
  15289    W !,"---- ---------" ,?15,"---- -",?22,"-- ----",?30, "--------- ",?42,"--- -----",?53 ,"-------- ",?63,"--- -------",? 75,"------ ----",?88, "--------- ---------- ------",?1 15,"------ ---"
  15290   "RTN","RCD PRTP2",67, 0)
  15291    Q
  15292   "RTN","RCD PRTP2",68, 0)
  15293    ;
  15294   "RTN","RCD PRTP2",69, 0)
  15295   HDR2 ;
  15296   "RTN","RCD PRTP2",70, 0)
  15297    W !!,"Ass ociated Fi rst Party  Charges:"
  15298   "RTN","RCD PRTP2",71, 0)
  15299    W !,"==== ========== ========== ======="
  15300   "RTN","RCD PRTP2",72, 0)
  15301    W !," Bil l #",?14," Charge Typ e",?34,"St atus",?42, "From/Fill ",?54,"To/ Rel",?65," Amt Billed ",?78,"On  Hold",?87, "  Balance "
  15302   "RTN","RCD PRTP2",73, 0)
  15303    W !,"---- -------",? 14,"------ ---------- ",?34,"--- ---",?42," ---------" ,?54,"---- -----",?65 ,"-------- --",?78,"- ------",?8 7," ------ ----"
  15304   "RTN","RCD PRTP2",74, 0)
  15305    Q
  15306   "RTN","RCD PRTP2",75, 0)
  15307    ;
  15308   "RTN","RCD PRTP2",76, 0)
  15309   STAT(RCIBF N) ;AR Sta tus
  15310   "RTN","RCD PRTP2",77, 0)
  15311    I '$G(RCI BFN) Q ""
  15312   "RTN","RCD PRTP2",78, 0)
  15313    N RCSTAT
  15314   "RTN","RCD PRTP2",79, 0)
  15315    S RCSTAT= $P($G(^PRC A(430,+RCI BFN,0)),"^ ",8),RCSTA T=$P($G(^P RCA(430.3, +RCSTAT,0) ),"^",2)
  15316   "RTN","RCD PRTP2",80, 0)
  15317    Q RCSTAT
  15318   "RTN","RCD PRTP2",81, 0)
  15319    ;
  15320   "RTN","RCD PRTP2",82, 0)
  15321   DATE(X) ;  Convert Fi leMan date  to mm/dd/ yy
  15322   "RTN","RCD PRTP2",83, 0)
  15323    Q $S($G(X ):$E(X,4,5 )_"/"_$E(X ,6,7)_"/"_ $E(X,2,3), 1:"")
  15324   "RTN","RCD PRTP2",84, 0)
  15325    ;
  15326   "RTN","RCD PRTP2",85, 0)
  15327    ;
  15328   "RTN","RCD PRTP2",86, 0)
  15329   PAUSE ; Pa ge break.
  15330   "RTN","RCD PRTP2",87, 0)
  15331    I $E(IOST ,1,2)'="C- " Q
  15332   "RTN","RCD PRTP2",88, 0)
  15333    N RCX,DIR ,DIRUT,DUO UT,DTOUT,D IROUT,X,Y
  15334   "RTN","RCD PRTP2",89, 0)
  15335    I IOSL<10 0 F RCX=$Y :1:(IOSL-3 ) W !
  15336   "RTN","RCD PRTP2",90, 0)
  15337    S DIR(0)= "E" D ^DIR  I $D(DIRU T)!($D(DUO UT)) S RCQ =1
  15338   "RTN","RCD PRTP2",91, 0)
  15339    Q
  15340   "RTN","RCD PRTP2",92, 0)
  15341    ;
  15342   "RTN","RCD PRTP2",93, 0)
  15343   EEOB(RCBIL L) ; PRCA* 4.5*276 -  get EEOB i ndicator f or a bill
  15344   "RTN","RCD PRTP2",94, 0)
  15345    ; Interac tion with  IB file #3 61.1 cover ed by IA # 4051.
  15346   "RTN","RCD PRTP2",95, 0)
  15347    ; RCBILL  is the IEN  of the bi ll in file s #399/#43 0 and must  be valid,
  15348   "RTN","RCD PRTP2",96, 0)
  15349    ; Exclude  an EOB ty pe of MRA  when getti ng payment  informati on. Return
  15350   "RTN","RCD PRTP2",97, 0)
  15351    ; the EEO B indicato r '%' if p ayment act ivity was  found.
  15352   "RTN","RCD PRTP2",98, 0)
  15353    ;
  15354   "RTN","RCD PRTP2",99, 0)
  15355    N RCEEOB, RCVAL,Z
  15356   "RTN","RCD PRTP2",100 ,0)
  15357    I $G(RCBI LL)=0 Q ""
  15358   "RTN","RCD PRTP2",101 ,0)
  15359    I '$O(^IB M(361.1,"B ",RCBILL,0 )) Q ""  ;  no matchi ng entry f or bill
  15360   "RTN","RCD PRTP2",102 ,0)
  15361    I $P($G(^ DGCR(399,R CBILL,0)), "^",13)=1  Q ""  ;avo id 'ENTERE D/NOT REVI EWED' stat us
  15362   "RTN","RCD PRTP2",103 ,0)
  15363    ; handle  both singl e and mult iple bill  entries in  file #361 .1
  15364   "RTN","RCD PRTP2",104 ,0)
  15365    S Z=0 F   S Z=$O(^IB M(361.1,"B ",RCBILL,Z )) Q:'Z  D   Q:$G(RCE EOB)="%"
  15366   "RTN","RCD PRTP2",105 ,0)
  15367    . S RCVAL =$G(^IBM(3 61.1,Z,0))
  15368   "RTN","RCD PRTP2",106 ,0)
  15369    . S RCEEO B=$S($P(RC VAL,"^",4) =1:"",$P(R CVAL,"^",4 )=0:"%",1: "")
  15370   "RTN","RCD PRTP2",107 ,0)
  15371    Q RCEEOB   ; EEOB in dicator fo r 1st/3rd  party paym ent on bil l
  15372   "RTN","RCM SITE")
  15373   0^7^B10360 113^B84197 76
  15374   "RTN","RCM SITE",1,0)
  15375   RCMSITE ;A LB/RRG - E DIT SITE P ARAMETERS  ;Jul 02, 2 014@15:46: 14
  15376   "RTN","RCM SITE",2,0)
  15377   V ;;4.5;Ac counts Rec eivable;** 173,236,25 3,298,315* *;Mar 20,  1995;Build  55
  15378   "RTN","RCM SITE",3,0)
  15379    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  15380   "RTN","RCM SITE",4,0)
  15381    ;
  15382   "RTN","RCM SITE",5,0)
  15383   BEG ;Start  editing s ite paramt ers
  15384   "RTN","RCM SITE",6,0)
  15385    N DA,DIC, DIE,DLAYGO ,DR,X,Y
  15386   "RTN","RCM SITE",7,0)
  15387    ; edit SI TE field ( #.01) in A R SITE PAR AMETER fil e (#342)
  15388   "RTN","RCM SITE",8,0)
  15389    S DIC="^R C(342,",DI C(0)="QEAM L",DLAYGO= 342 D ^DIC  I Y>0 S D A=+Y,DR=.0 1,DIE="^RC (342," D ^ DIE
  15390   "RTN","RCM SITE",9,0)
  15391    Q
  15392   "RTN","RCM SITE",10,0 )
  15393    ;
  15394   "RTN","RCM SITE",11,0 )
  15395   ALC ;Edit  ALC parame ter
  15396   "RTN","RCM SITE",12,0 )
  15397    NEW DIC,D R,DA,Y
  15398   "RTN","RCM SITE",13,0 )
  15399    S DIE="^R C(342,",DA =1,DR=".07 ;31" D ^DI E
  15400   "RTN","RCM SITE",14,0 )
  15401    Q
  15402   "RTN","RCM SITE",15,0 )
  15403   IRS ;Edit  IRS OFFSET  site para meters
  15404   "RTN","RCM SITE",16,0 )
  15405    NEW DIE,D R,DA,Y
  15406   "RTN","RCM SITE",17,0 )
  15407    I '$D(^RC (342,1,0))  D BEG G:' $D(^RC(342 ,1,0)) Q
  15408   "RTN","RCM SITE",18,0 )
  15409    S DA=1,DR ="[RCMS IR S]",DIE="^ RC(342," D  ^DIE
  15410   "RTN","RCM SITE",19,0 )
  15411   Q Q
  15412   "RTN","RCM SITE",20,0 )
  15413   STAT ;Edit  NOTIFICAT ION site p arameters
  15414   "RTN","RCM SITE",21,0 )
  15415    NEW DIE,D R,DA,Y
  15416   "RTN","RCM SITE",22,0 )
  15417    I '$D(^RC (342,1,0))  D BEG G:' $D(^RC(342 ,1,0)) Q1
  15418   "RTN","RCM SITE",23,0 )
  15419    S DA=1,DR ="[RCMS NO TIFICATION ]",DIE="^R C(342," D  ^DIE
  15420   "RTN","RCM SITE",24,0 )
  15421   Q1 Q
  15422   "RTN","RCM SITE",25,0 )
  15423   GRP ;Edit  AR Group P arameters
  15424   "RTN","RCM SITE",26,0 )
  15425    NEW DIE,D R,DA,Y
  15426   "RTN","RCM SITE",27,0 )
  15427    F  W ! S  DIC(0)="QE AML",DIC=" ^RC(342.1, ",DLAYGO=3 42.1 D ^DI C K DIC G: Y<0 Q3 S D A=+Y,DIE=" ^RC(342.1, ",DR=$P($G (^RC(342.2 ,+$P(^RC(3 42.1,+Y,0) ,"^",2),1) ),"^") I D R]"" D ^DI E
  15428   "RTN","RCM SITE",28,0 )
  15429   Q3 Q
  15430   "RTN","RCM SITE",29,0 )
  15431   DEA ;Deact ive an AR  group
  15432   "RTN","RCM SITE",30,0 )
  15433    NEW DIE,D IC,DA,DR,Y ,GRP
  15434   "RTN","RCM SITE",31,0 )
  15435    S DIC="^R C(342.1,", DIC(0)="QE AM",DIC("S ")="I $P(^ (0),""^"", 2)'=7" D ^ DIC Q:Y<0   S GRP=+Y
  15436   "RTN","RCM SITE",32,0 )
  15437    W ! S DIR ("A")="Are  you sure  you want t o Deactive  Group '"_ $P(^RC(342 .1,GRP,0), "^")_"'",D IR(0)="Y", DIR("B")=" NO" D ^DIR  K DIR
  15438   "RTN","RCM SITE",33,0 )
  15439    I 'Y W !! ,"*** NO A CTION TAKE N ***" Q
  15440   "RTN","RCM SITE",34,0 )
  15441    I Y S DIE ="^RC(342. 1,",DA=GRP ,DR=".02// //^S X=7"  D ^DIE W ! !,"*** Gro up Deactiv ated ***"
  15442   "RTN","RCM SITE",35,0 )
  15443    Q
  15444   "RTN","RCM SITE",36,0 )
  15445   SITE() ;Re turn site  number
  15446   "RTN","RCM SITE",37,0 )
  15447    Q +$G(^DI C(4,+$P($G (^RC(342,1 ,0)),"^"), 99))
  15448   "RTN","RCM SITE",38,0 )
  15449   INT ;Print  Inter/Adm in/Pen eff ective rep ort
  15450   "RTN","RCM SITE",39,0 )
  15451    NEW DIC,B Y,FR,TO,FL DS,L
  15452   "RTN","RCM SITE",40,0 )
  15453    S DIC="^R C(342,",BY =.01,(FR,T O)="",FLDS ="[RCMS IN T/ADM/PEN] ",L=0 D EN 1^DIP
  15454   "RTN","RCM SITE",41,0 )
  15455    Q
  15456   "RTN","RCM SITE",42,0 )
  15457   UPINT ;Upd ate Rate s ite parame ters
  15458   "RTN","RCM SITE",43,0 )
  15459    NEW DIE,D R,DA,Y,IOP
  15460   "RTN","RCM SITE",44,0 )
  15461    S IOP=ION  D INT
  15462   "RTN","RCM SITE",45,0 )
  15463    I '$D(^XU SEC("PRCAF  LATE CHAR GES",DUZ))  D BMES^XP DUTL("A Se curity Key  is requir ed to edit  the Inter est/Admin  and Penalt y Rates.")  Q  ;PRCA* 4.5*315 Ad ded Securi ty Key
  15464   "RTN","RCM SITE",46,0 )
  15465    I '$D(^RC (342,1,0))  D BEG G:' $D(^RC(342 ,1,0)) Q4
  15466   "RTN","RCM SITE",47,0 )
  15467    F  W ! S  DA=1,DR="[ RCMS RATES ]",DIE="^R C(342," D  ^DIE Q:$D( Y)
  15468   "RTN","RCM SITE",48,0 )
  15469   Q4 Q
  15470   "RTN","RCM SITE",49,0 )
  15471    ;
  15472   "RTN","RCM SITE",50,0 )
  15473   EDILOCK()  ; function , Update E DI Lockbox  site para meters
  15474   "RTN","RCM SITE",51,0 )
  15475    ; returns  1 on succ ess, else  "^error me ssage"
  15476   "RTN","RCM SITE",52,0 )
  15477    N RSLT S  RSLT=""
  15478   "RTN","RCM SITE",53,0 )
  15479    I '$D(^RC (342,1,0))  D BEG
  15480   "RTN","RCM SITE",54,0 )
  15481    S:'$D(^RC (342,1,0))  RSLT="^no  site defi ned"  ; ca n't contin ue
  15482   "RTN","RCM SITE",55,0 )
  15483    ;
  15484   "RTN","RCM SITE",56,0 )
  15485    Q:RSLT]""  RSLT
  15486   "RTN","RCM SITE",57,0 )
  15487    ;
  15488   "RTN","RCM SITE",58,0 )
  15489    N DA,DIE, DR,Y
  15490   "RTN","RCM SITE",59,0 )
  15491    S DA=1,DR ="[RCMS ED I LOCKBOX] ",DIE="^RC (342," D ^ DIE
  15492   "RTN","RCM SITE",60,0 )
  15493    S RSLT=$S ($D(Y):"^u ser aborte d",1:1)  ;  if Y rema ins from ^ DIE call
  15494   "RTN","RCM SITE",61,0 )
  15495    ;
  15496   "RTN","RCM SITE",62,0 )
  15497    Q RSLT  ;  success
  15498   "RTN","RCM SITE",63,0 )
  15499    ;
  15500   "RTN","RCM SITE",64,0 )
  15501   EDITRDDT ; Update # O F DAYS FOR  RD ELIG C HG RPT sit e paramete r
  15502   "RTN","RCM SITE",65,0 )
  15503    ;This is  the number  of days f or the Rat ed Disabil ity Eligib ility
  15504   "RTN","RCM SITE",66,0 )
  15505    ;Change R eport to b e used whe n the repo rt is sche duled to b e run
  15506   "RTN","RCM SITE",67,0 )
  15507    ;on a rec urring bas is. (Added  for Hold  Debt to DM C Project)
  15508   "RTN","RCM SITE",68,0 )
  15509    N DIE,DR, DA,Y
  15510   "RTN","RCM SITE",69,0 )
  15511    I '$D(^RC (342,1,0))  D BEG G:' $D(^RC(342 ,1,0)) Q6
  15512   "RTN","RCM SITE",70,0 )
  15513    S DA=1,DR ="8.01",DI E="^RC(342 ," D ^DIE
  15514   "RTN","RCM SITE",71,0 )
  15515   Q6 Q
  15516   "RTN","RCM SITE",72,0 )
  15517    ;
  15518   "RTN","RCM SITE",73,0 )
  15519   GETRDDAY()  ;Return #  OF DAYS F OR RD ELIG  CHG RPT s ite parame ter
  15520   "RTN","RCM SITE",74,0 )
  15521    Q $$GET1^ DIQ(342,1_ ",",8.01)
  15522   "RTN","RCM SITE",75,0 )
  15523    ;
  15524   "RTN","RCM SITE",76,0 )
  15525   EDITRDAY ; Update NUM BER OF DAY S FOR DMC  REPORTS si te paramet er.
  15526   "RTN","RCM SITE",77,0 )
  15527    ;This is  the number  of days i n the past  bills for  episodes
  15528   "RTN","RCM SITE",78,0 )
  15529    ;of care  will be in cluded for  the follo wing repor ts when sc heduled by
  15530   "RTN","RCM SITE",79,0 )
  15531    ;IRM to b e run on a  recurring  basis:
  15532   "RTN","RCM SITE",80,0 )
  15533    ;   DMC D ebt Validi ty Report
  15534   "RTN","RCM SITE",81,0 )
  15535    ;   DMC D ebt Validi ty Managem ent Report
  15536   "RTN","RCM SITE",82,0 )
  15537    ;   Rated  Disabilit y Eligibil ity Change  Report
  15538   "RTN","RCM SITE",83,0 )
  15539    ;The mini mum value  for this f ield is 36 5 days (1  year) and  the maximu m
  15540   "RTN","RCM SITE",84,0 )
  15541    ;value is  3650 days  (10 years ). If no v alue is ad ded in thi s field th e
  15542   "RTN","RCM SITE",85,0 )
  15543    ;report w ill defaul t to 365 d ays. (Adde d for Hold  Debt to D MC Project )
  15544   "RTN","RCM SITE",86,0 )
  15545    N DIE,DR, DA,Y
  15546   "RTN","RCM SITE",87,0 )
  15547    I '$D(^RC (342,1,0))  D BEG G:' $D(^RC(342 ,1,0)) Q7
  15548   "RTN","RCM SITE",88,0 )
  15549    S DA=1,DR ="8.02",DI E="^RC(342 ," D ^DIE
  15550   "RTN","RCM SITE",89,0 )
  15551   Q7 Q
  15552   "RTN","RCM SITE",90,0 )
  15553    ;
  15554   "RTN","RCM SITE",91,0 )
  15555   GETRDAY()  ;Return NU MBER OF DA YS FOR DMC  REPORTS s ite parame ter
  15556   "RTN","RCM SITE",92,0 )
  15557    Q $$GET1^ DIQ(342,1_ ",",8.02)
  15558   "RTN","RCM SITE",93,0 )
  15559    ;
  15560   "RTN","RCR JRBD")
  15561   0^52^B7628 9018^B7424 7917
  15562   "RTN","RCR JRBD",1,0)
  15563   RCRJRBD ;W ISC/RFJ,TJ K-bad debt  extractor  and repor t ;10/18/1 0 9:00am
  15564   "RTN","RCR JRBD",2,0)
  15565    ;;4.5;Acc ounts Rece ivable;**1 01,139,170 ,193,203,2 15,220,138 ,239,273,2 82,310,315 **;Mar 20,  1995;Buil d 55
  15566   "RTN","RCR JRBD",3,0)
  15567    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  15568   "RTN","RCR JRBD",4,0)
  15569    ; IA 4385  for calls  to $$MRAT YPE^IBCEMU 2 and $$MR ADTACT^IBC EMU2
  15570   "RTN","RCR JRBD",5,0)
  15571    Q
  15572   "RTN","RCR JRBD",6,0)
  15573    ;
  15574   "RTN","RCR JRBD",7,0)
  15575    ;
  15576   "RTN","RCR JRBD",8,0)
  15577   START(DATE END) ;  ru n bad debt  report
  15578   "RTN","RCR JRBD",9,0)
  15579    ;  the DA TEEND is t he last da y of the m onth being  run
  15580   "RTN","RCR JRBD",10,0 )
  15581    ;  from t he routine  RCRJRCOL  which is t he data ex tractor.   The
  15582   "RTN","RCR JRBD",11,0 )
  15583    ;  curren t receivab le dollars  is stored  in ^TMP($ J,"RCRJRBD ",SGL)
  15584   "RTN","RCR JRBD",12,0 )
  15585    ;  where  SGL is the  standard  general le dger 1319,  1338, or  1339.
  15586   "RTN","RCR JRBD",13,0 )
  15587    ;
  15588   "RTN","RCR JRBD",14,0 )
  15589    N ACTDATE ,ACTUALCA, ACTUALWO,B EGDATE,BIL LDA,CATEGO RY
  15590   "RTN","RCR JRBD",15,0 )
  15591    N COLLECT ,CONTRACT, DR,ENDDATE ,FUND,PAY, PAYMENT,PR IN,PRINCPA L
  15592   "RTN","RCR JRBD",16,0 )
  15593    N RCRJFMM ,RCRJDATE, SGL,TRANDA ,TRANDATE, TRANTYPE,V ALUE,WRITE OFF
  15594   "RTN","RCR JRBD",17,0 )
  15595    N RCPRIN, RCTOMCCF,R CVALUE,RSC ,MRATYPE,A RACTDT
  15596   "RTN","RCR JRBD",18,0 )
  15597    ;
  15598   "RTN","RCR JRBD",19,0 )
  15599    ;  lock t he bad deb t file for  storing d ata, lock  cannot fai l
  15600   "RTN","RCR JRBD",20,0 )
  15601    ;  this l ock can be  used to m onitor if  the report  is runnin g
  15602   "RTN","RCR JRBD",21,0 )
  15603    F  L +^RC (348.1):$S ($G(DILOCK TM)>5:DILO CKTM,1:5)  Q:$T
  15604   "RTN","RCR JRBD",22,0 )
  15605    ;
  15606   "RTN","RCR JRBD",23,0 )
  15607    ;  calcul ate the ba se percent ages from  past data
  15608   "RTN","RCR JRBD",24,0 )
  15609    ;  exampl e:  DATEEN D=2980331   => BEGDAT E=2970300
  15610   "RTN","RCR JRBD",25,0 )
  15611    ;                                => ENDDAT E=2980229
  15612   "RTN","RCR JRBD",26,0 )
  15613    ;   add o ne day to  ending dat e to go to  next mont h
  15614   "RTN","RCR JRBD",27,0 )
  15615    S BEGDATE =($E(DATEE ND,1,3)-1) _$E(DATEEN D,4,5)_"00 "
  15616   "RTN","RCR JRBD",28,0 )
  15617    S ENDDATE =($$FMADD^ XLFDT($E(D ATEEND,1,5 )_"00",-1) )+1
  15618   "RTN","RCR JRBD",29,0 )
  15619    ;  loop b ills activ ated betwe en these d ates
  15620   "RTN","RCR JRBD",30,0 )
  15621    S ACTDATE =BEGDATE
  15622   "RTN","RCR JRBD",31,0 )
  15623    F  S ACTD ATE=$O(^PR CA(430,"AC TDT",ACTDA TE)) Q:'AC TDATE!(ACT DATE>ENDDA TE)  D
  15624   "RTN","RCR JRBD",32,0 )
  15625    . S BILLD A=0 F  S B ILLDA=$O(^ PRCA(430," ACTDT",ACT DATE,BILLD A)) Q:'BIL LDA  D
  15626   "RTN","RCR JRBD",33,0 )
  15627    . . S CAT EGORY=+$P( $G(^PRCA(4 30,BILLDA, 0)),"^",2)
  15628   "RTN","RCR JRBD",34,0 )
  15629    . . ;  do  not look  at prepaym ents
  15630   "RTN","RCR JRBD",35,0 )
  15631    . . I 'CA TEGORY!(CA TEGORY=26)  Q
  15632   "RTN","RCR JRBD",36,0 )
  15633    . . ;
  15634   "RTN","RCR JRBD",37,0 )
  15635    . . ;  on ly look at  bills wit h a 0 prin cipal bala nce
  15636   "RTN","RCR JRBD",38,0 )
  15637    . . I $P( $G(^PRCA(4 30,BILLDA, 7)),"^") Q
  15638   "RTN","RCR JRBD",39,0 )
  15639    . . ;
  15640   "RTN","RCR JRBD",40,0 )
  15641    . . ;  on ly report  fund 52870 1,03,04,11  and 4032/ 528709 bil ls
  15642   "RTN","RCR JRBD",41,0 )
  15643    . . S FUN D=$$GETFUN DB^RCXFMSU F(BILLDA,1 )
  15644   "RTN","RCR JRBD",42,0 )
  15645    . . I '$$ PTACCT^PRC AACC(FUND) ,$E(FUND,1 ,4)'=4032  Q
  15646   "RTN","RCR JRBD",43,0 )
  15647    . . ;
  15648   "RTN","RCR JRBD",44,0 )
  15649    . . ;  de termine MR A type of  bill, give n bill# an d bill act ive date
  15650   "RTN","RCR JRBD",45,0 )
  15651    . . ;  DB IA #4385 a ctivated o n 31-Mar-2 004
  15652   "RTN","RCR JRBD",46,0 )
  15653    . . S MRA TYPE=$$MRA TYPE^IBCEM U2(BILLDA, ACTDATE)
  15654   "RTN","RCR JRBD",47,0 )
  15655    . . ;
  15656   "RTN","RCR JRBD",48,0 )
  15657    . . ;  de rive stand ard genera l ledger ( SGL) from  cat/fund/M RA type
  15658   "RTN","RCR JRBD",49,0 )
  15659    . . S SGL =$$BDRSGL( CATEGORY,F UND,MRATYP E)
  15660   "RTN","RCR JRBD",50,0 )
  15661    . . ;
  15662   "RTN","RCR JRBD",51,0 )
  15663    . . ;  de termine th e original  amount of  the bill  (add incre ase
  15664   "RTN","RCR JRBD",52,0 )
  15665    . . ;  ad justments  below)
  15666   "RTN","RCR JRBD",53,0 )
  15667    . . S PRI N=$P($G(^P RCA(430,BI LLDA,0))," ^",3)
  15668   "RTN","RCR JRBD",54,0 )
  15669    . . S PAY =0
  15670   "RTN","RCR JRBD",55,0 )
  15671    . . ;
  15672   "RTN","RCR JRBD",56,0 )
  15673    . . ;  ge t the $ tr ansations  for bills
  15674   "RTN","RCR JRBD",57,0 )
  15675    . . S TRA NDA=0
  15676   "RTN","RCR JRBD",58,0 )
  15677    . . F  S  TRANDA=$O( ^PRCA(433, "C",BILLDA ,TRANDA))  Q:'TRANDA   D
  15678   "RTN","RCR JRBD",59,0 )
  15679    . . . S T RANTYPE=$P ($G(^PRCA( 433,TRANDA ,1)),"^",2 )
  15680   "RTN","RCR JRBD",60,0 )
  15681    . . . I " ^1^2^34^43 ^"'[("^"_T RANTYPE_"^ ") Q
  15682   "RTN","RCR JRBD",61,0 )
  15683    . . . S V ALUE=$$TRA NBAL^RCRJR COT(TRANDA ) I VALUE= "" Q
  15684   "RTN","RCR JRBD",62,0 )
  15685    . . . ;   increase a djustments  or re-est ablish
  15686   "RTN","RCR JRBD",63,0 )
  15687    . . . I T RANTYPE=1! (TRANTYPE= 43) S PRIN =PRIN+$P(V ALUE,"^")  Q
  15688   "RTN","RCR JRBD",64,0 )
  15689    . . . ;   payments
  15690   "RTN","RCR JRBD",65,0 )
  15691    . . . I T RANTYPE=2! (TRANTYPE= 34) S PAY= PAY+$P(VAL UE,"^") Q
  15692   "RTN","RCR JRBD",66,0 )
  15693    . . ;
  15694   "RTN","RCR JRBD",67,0 )
  15695    . . ;  pa yment cann ot be grea ter than p rinciple
  15696   "RTN","RCR JRBD",68,0 )
  15697    . . I PAY >PRIN S PA Y=PRIN
  15698   "RTN","RCR JRBD",69,0 )
  15699    . . ;
  15700   "RTN","RCR JRBD",70,0 )
  15701    . . ;  st ore the da ta
  15702   "RTN","RCR JRBD",71,0 )
  15703    . . S PRI NCPAL(SGL) =$G(PRINCP AL(SGL))+P RIN
  15704   "RTN","RCR JRBD",72,0 )
  15705    . . S PAY MENT(SGL)= $G(PAYMENT (SGL))+PAY
  15706   "RTN","RCR JRBD",73,0 )
  15707    . . ;
  15708   "RTN","RCR JRBD",74,0 )
  15709    ;
  15710   "RTN","RCR JRBD",75,0 )
  15711    ;  calcul ate the wr iteoffs fr om 2/0/98
  15712   "RTN","RCR JRBD",76,0 )
  15713    ;  2/0/98  is when f ms cleared  out actua l writeoff s and cont ract adj
  15714   "RTN","RCR JRBD",77,0 )
  15715    K ^XTMP(" PRCABDET")
  15716   "RTN","RCR JRBD",78,0 )
  15717    S ^XTMP(" PRCABDET", 0)=$$FMADD ^XLFDT(DT, 10)_"^"_DT _"^BAD DEB T REPORT A UDIT"
  15718   "RTN","RCR JRBD",79,0 )
  15719    F TRANTYP E=8,9,10,1 1,35 D
  15720   "RTN","RCR JRBD",80,0 )
  15721    . S TRAND ATE=298020 0
  15722   "RTN","RCR JRBD",81,0 )
  15723    . ;  do n ot pick up  transacti ons after  the end da te
  15724   "RTN","RCR JRBD",82,0 )
  15725    . F  S TR ANDATE=$O( ^PRCA(433, "AT",TRANT YPE,TRANDA TE)) Q:'TR ANDATE!($P (TRANDATE, ".")>DATEE ND)  D
  15726   "RTN","RCR JRBD",83,0 )
  15727    . . S TRA NDA=0 F  S  TRANDA=$O (^PRCA(433 ,"AT",TRAN TYPE,TRAND ATE,TRANDA )) Q:'TRAN DA  D
  15728   "RTN","RCR JRBD",84,0 )
  15729    . . . ;   do not loo k at decre ase adj wh ich are no t contract  adj
  15730   "RTN","RCR JRBD",85,0 )
  15731    . . . I T RANTYPE=35 ,'$P($G(^P RCA(433,TR ANDA,8))," ^",8) Q
  15732   "RTN","RCR JRBD",86,0 )
  15733    . . . ;
  15734   "RTN","RCR JRBD",87,0 )
  15735    . . . S B ILLDA=$P($ G(^PRCA(43 3,TRANDA,0 )),"^",2)
  15736   "RTN","RCR JRBD",88,0 )
  15737    . . . I ' BILLDA Q
  15738   "RTN","RCR JRBD",89,0 )
  15739    . . . S C ATEGORY=+$ P($G(^PRCA (430,BILLD A,0)),"^", 2)
  15740   "RTN","RCR JRBD",90,0 )
  15741    . . . ;   do not loo k at prepa yments
  15742   "RTN","RCR JRBD",91,0 )
  15743    . . . I ' CATEGORY!( CATEGORY=2 6) Q
  15744   "RTN","RCR JRBD",92,0 )
  15745    . . . ;
  15746   "RTN","RCR JRBD",93,0 )
  15747    . . . ;   only repor t fund 528 701,03,04, 11 and 403 2/528709 ( ltc) bills
  15748   "RTN","RCR JRBD",94,0 )
  15749    . . . S F UND=$$GETF UNDB^RCXFM SUF(BILLDA ,1)
  15750   "RTN","RCR JRBD",95,0 )
  15751    . . . I ' $$PTACCT^P RCAACC(FUN D),$E(FUND ,1,4)'=403 2 Q
  15752   "RTN","RCR JRBD",96,0 )
  15753    . . . ;
  15754   "RTN","RCR JRBD",97,0 )
  15755    . . . ;   get bill a ctive date
  15756   "RTN","RCR JRBD",98,0 )
  15757    . . . S A RACTDT=+$P ($P($G(^PR CA(430,BIL LDA,6)),"^ ",21),".")
  15758   "RTN","RCR JRBD",99,0 )
  15759    . . . ;   determine  MRA type o f bill, gi ven bill#  and bill a ctive date
  15760   "RTN","RCR JRBD",100, 0)
  15761    . . . ;   DBIA #4385  activated  on 31-Mar -2004
  15762   "RTN","RCR JRBD",101, 0)
  15763    . . . S M RATYPE=$$M RATYPE^IBC EMU2(BILLD A,ARACTDT)
  15764   "RTN","RCR JRBD",102, 0)
  15765    . . . ;
  15766   "RTN","RCR JRBD",103, 0)
  15767    . . . ; d erive stan dard gener al ledger  (SGL) from  cat/fund/ MRA type
  15768   "RTN","RCR JRBD",104, 0)
  15769    . . . S S GL=$$BDRSG L(CATEGORY ,FUND,MRAT YPE)
  15770   "RTN","RCR JRBD",105, 0)
  15771    . . . ;
  15772   "RTN","RCR JRBD",106, 0)
  15773    . . . ;   get the pr incipal tr ansaction  value
  15774   "RTN","RCR JRBD",107, 0)
  15775    . . . S R CVALUE=+$P ($$TRANBAL ^RCRJRCOT( TRANDA),"^ ")
  15776   "RTN","RCR JRBD",108, 0)
  15777    . . . ;   temp varia ble for va lue (used  below)
  15778   "RTN","RCR JRBD",109, 0)
  15779    . . . S R CPRIN=RCVA LUE
  15780   "RTN","RCR JRBD",110, 0)
  15781    . . . ;
  15782   "RTN","RCR JRBD",111, 0)
  15783    . . . ;   add actual  writeoff  amount for  fiscal ye ar
  15784   "RTN","RCR JRBD",112, 0)
  15785    . . . I T RANTYPE'=3 5 S ACTUAL WO(SGL)=$G (ACTUALWO( SGL))+RCVA LUE
  15786   "RTN","RCR JRBD",113, 0)
  15787    . . . ;   add actual  contract  adjustment s for fisc al year
  15788   "RTN","RCR JRBD",114, 0)
  15789    . . . I T RANTYPE=35  S ACTUALC A(SGL)=$G( ACTUALCA(S GL))+RCVAL UE
  15790   "RTN","RCR JRBD",115, 0)
  15791    . . . S R SC=$$CALCR SC^RCXFMSU R(BILLDA)
  15792   "RTN","RCR JRBD",116, 0)
  15793    . . . S ^ XTMP("PRCA BDET",BILL DA,CATEGOR Y,FUND,RSC ,SGL,TRAND A,TRANDATE ,TRANTYPE, RCPRIN,RCV ALUE,0,0)= ""
  15794   "RTN","RCR JRBD",117, 0)
  15795    ;
  15796   "RTN","RCR JRBD",118, 0)
  15797    ;  remove  all the e ntries fro m the bad  debt file
  15798   "RTN","RCR JRBD",119, 0)
  15799    D DELETAL L
  15800   "RTN","RCR JRBD",120, 0)
  15801    ;
  15802   "RTN","RCR JRBD",121, 0)
  15803    ;  calcul ate percen tages and  store them
  15804   "RTN","RCR JRBD",122, 0)
  15805    F SGL=131 9,1319.2,1 319.3,1319 .4,1319.5, 1319.6,133 8,1338.2,1 338.3,1339 ,1339.1,"1 33N","133N .2","133.N 3" D
  15806   "RTN","RCR JRBD",123, 0)
  15807    . ;  coll ection %
  15808   "RTN","RCR JRBD",124, 0)
  15809    . S COLLE CT=0 I $G( PRINCPAL(S GL)) S COL LECT=$J($G (PAYMENT(S GL))/PRINC PAL(SGL)*1 00,0,2)
  15810   "RTN","RCR JRBD",125, 0)
  15811    . ;  patc h PRCA*4.5 *138: for  the first  year from  when MRA i s activate d at a sit e, there i s no colle ction
  15812   "RTN","RCR JRBD",126, 0)
  15813    . ;  hist ory for po st-MRA non -Medicare  bills(SGL  133N). So,  to calcul ate the pe rcentage f or SGL 133 N, the
  15814   "RTN","RCR JRBD",127, 0)
  15815    . ;  paym ent and th e principa l for SGL  1339 are u sed in the  first yea r.
  15816   "RTN","RCR JRBD",128, 0)
  15817    . ;  over ride the c ollection  value for  SGL=133N f or the fir st year fr om MRA act ivation.
  15818   "RTN","RCR JRBD",129, 0)
  15819    . ;;  Re- evaluate t he calc. o f the perc entage for  133N as w ell as 133 9.
  15820   "RTN","RCR JRBD",130, 0)
  15821    . ;;I SGL ="133N",$G (PRINCIPAL (1339)) D   ;
  15822   "RTN","RCR JRBD",131, 0)
  15823    . ;;. N X 1,X2,X,%Y
  15824   "RTN","RCR JRBD",132, 0)
  15825    . ;;. ;   X2=MRA Act ivation Da te, X1=Tod ay, X=diff  in days,  %Y=0 inval id dates
  15826   "RTN","RCR JRBD",133, 0)
  15827    . ;;. ;   DBIA #4385  activated  on 31-Mar -2004
  15828   "RTN","RCR JRBD",134, 0)
  15829    . ;;. S X 2=$$MRADTA CT^IBCEMU2 ,X1=$$DT^X LFDT D ^%D TC
  15830   "RTN","RCR JRBD",135, 0)
  15831    . ;;. I % Y,X'>364.2 5 S COLLEC T=$J($G(PA YMENT(1339 ))/PRINCPA L(1339)*10 0,0,2)
  15832   "RTN","RCR JRBD",136, 0)
  15833    . S DR=". 02////"_+C OLLECT_";"
  15834   "RTN","RCR JRBD",137, 0)
  15835    . ;
  15836   "RTN","RCR JRBD",138, 0)
  15837    . ;  curr ent month  receivable  (this is  built in t he routine
  15838   "RTN","RCR JRBD",139, 0)
  15839    . ;  RCRJ RCO1 and i s stored i n ^TMP($J, "RCRJRBD", SGL))
  15840   "RTN","RCR JRBD",140, 0)
  15841    . S DR=DR _".07////" _+$G(^TMP( $J,"RCRJRB D",SGL))_" ;"
  15842   "RTN","RCR JRBD",141, 0)
  15843    . ;
  15844   "RTN","RCR JRBD",142, 0)
  15845    . ;  calc ulate allo wance esti mate for 1 319 and 13 38
  15846   "RTN","RCR JRBD",143, 0)
  15847    . ;  .08  allowance  estimate =  (writeoff  % * curre nt receiva bles)
  15848   "RTN","RCR JRBD",144, 0)
  15849    . ;  .09  actual wri teoffs fyt d
  15850   "RTN","RCR JRBD",145, 0)
  15851    . I SGL=1 319!(SGL=1 319.2)!(SG L=1319.3)! (SGL=1319. 4)!(SGL=13 19.5)!(SGL =1319.6)!( SGL=1338)! (SGL=1338. 2)!(SGL=13 38.3) D
  15852   "RTN","RCR JRBD",146, 0)
  15853    . . S WRI TEOFF=100- COLLECT
  15854   "RTN","RCR JRBD",147, 0)
  15855    . . S DR= DR_".03/// /"_WRITEOF F_";"
  15856   "RTN","RCR JRBD",148, 0)
  15857    . . S DR= DR_".08/// /"_$J((WRI TEOFF/100) *$G(^TMP($ J,"RCRJRBD ",SGL)),0, 2)_";"
  15858   "RTN","RCR JRBD",149, 0)
  15859    . . S DR= DR_".09/// /"_+$G(ACT UALWO(SGL) )_";"
  15860   "RTN","RCR JRBD",150, 0)
  15861    . ;  calc ulate allo wance esti mate for 1 339
  15862   "RTN","RCR JRBD",151, 0)
  15863    . ;  .08  allowance  estimate =  (contract  % * curre nt receiva bles)
  15864   "RTN","RCR JRBD",152, 0)
  15865    . ;  .09  actual con tract adju stments fy td
  15866   "RTN","RCR JRBD",153, 0)
  15867    . I SGL=1 339!(SGL=1 339.1)!(SG L="133N")! (SGL="133N .2")!(SGL= "133N.3")  D
  15868   "RTN","RCR JRBD",154, 0)
  15869    . . S CON TRACT=100- COLLECT
  15870   "RTN","RCR JRBD",155, 0)
  15871    . . S DR= DR_".04/// /"_CONTRAC T_";"
  15872   "RTN","RCR JRBD",156, 0)
  15873    . . S DR= DR_".08/// /"_$J((CON TRACT/100) *$G(^TMP($ J,"RCRJRBD ",SGL)),0, 2)_";"
  15874   "RTN","RCR JRBD",157, 0)
  15875    . . S DR= DR_".09/// /"_+$G(ACT UALCA(SGL) )_";"
  15876   "RTN","RCR JRBD",158, 0)
  15877    . ;
  15878   "RTN","RCR JRBD",159, 0)
  15879    . ;  set  changed lo cally flag  to no
  15880   "RTN","RCR JRBD",160, 0)
  15881    . S DR=DR _".1////0; "
  15882   "RTN","RCR JRBD",161, 0)
  15883    . D STORE (SGL,DR)
  15884   "RTN","RCR JRBD",162, 0)
  15885    ;
  15886   "RTN","RCR JRBD",163, 0)
  15887    L -^RC(34 8.1)
  15888   "RTN","RCR JRBD",164, 0)
  15889    ;
  15890   "RTN","RCR JRBD",165, 0)
  15891    ;   ;  pu t the repo rt in a ma il message  (rcrjfmm= 1)
  15892   "RTN","RCR JRBD",166, 0)
  15893    ;   S RCR JFMM=1
  15894   "RTN","RCR JRBD",167, 0)
  15895    ;   S RCR JDATE=DATE END
  15896   "RTN","RCR JRBD",168, 0)
  15897    ;   D DQ^ RCRJRBDR
  15898   "RTN","RCR JRBD",169, 0)
  15899    ;
  15900   "RTN","RCR JRBD",170, 0)
  15901    ;  transm it the all owances to  FMS, and  then gener ate the re port.
  15902   "RTN","RCR JRBD",171, 0)
  15903    D BADDEBT ^RCXFMSSV( DATEEND)
  15904   "RTN","RCR JRBD",172, 0)
  15905    Q
  15906   "RTN","RCR JRBD",173, 0)
  15907    ;
  15908   "RTN","RCR JRBD",174, 0)
  15909    ;
  15910   "RTN","RCR JRBD",175, 0)
  15911   STORE(SGL, DR) ;  sto re data fo r Standard  Ledger Ac count
  15912   "RTN","RCR JRBD",176, 0)
  15913    N D0,DA,D D,DI,DIC,D IE,DINUM,D O,DQ,X,Y
  15914   "RTN","RCR JRBD",177, 0)
  15915    S DIC="^R C(348.1,", DIC(0)="L" ,X=SGL,DIC ("DR")=DR
  15916   "RTN","RCR JRBD",178, 0)
  15917    D FILE^DI CN
  15918   "RTN","RCR JRBD",179, 0)
  15919    Q
  15920   "RTN","RCR JRBD",180, 0)
  15921    ;
  15922   "RTN","RCR JRBD",181, 0)
  15923    ;
  15924   "RTN","RCR JRBD",182, 0)
  15925   DELETALL ;   delete a ll the ent ries from  the bad de bt file
  15926   "RTN","RCR JRBD",183, 0)
  15927    N %,DA,DI C,DIK,X,Y
  15928   "RTN","RCR JRBD",184, 0)
  15929    S DIK="^R C(348.1,"
  15930   "RTN","RCR JRBD",185, 0)
  15931    S DA=0 F   S DA=$O(^ RC(348.1,D A)) Q:'DA   D ^DIK
  15932   "RTN","RCR JRBD",186, 0)
  15933    Q
  15934   "RTN","RCR JRBD",187, 0)
  15935    ;
  15936   "RTN","RCR JRBD",188, 0)
  15937    ;
  15938   "RTN","RCR JRBD",189, 0)
  15939   WD3() ;  r eturn the  third work  day of th e month
  15940   "RTN","RCR JRBD",190, 0)
  15941    N J,P,V,X
  15942   "RTN","RCR JRBD",191, 0)
  15943    S J=0 F P =$E(DT,1,5 )_"01":1 S  V=$$DOW^X LFDT(P,1)  I V,V<6,'$ D(^HOLIDAY ("B",P)) S  J=J+1 Q:J =3
  15944   "RTN","RCR JRBD",192, 0)
  15945    S X=+$E(P ,6,7)
  15946   "RTN","RCR JRBD",193, 0)
  15947    Q X
  15948   "RTN","RCR JRBD",194, 0)
  15949    ;
  15950   "RTN","RCR JRBD",195, 0)
  15951    ;
  15952   "RTN","RCR JRBD",196, 0)
  15953   PREVMONT(F ORDATE) ;  return the  previous  month's da te
  15954   "RTN","RCR JRBD",197, 0)
  15955    N PREVDAT E
  15956   "RTN","RCR JRBD",198, 0)
  15957    S PREVDAT E=$E(FORDA TE,1,5)-1
  15958   "RTN","RCR JRBD",199, 0)
  15959    I $E(PREV DATE,4,5)= "00" S PRE VDATE=($E( PREVDATE,1 ,3)-1)_12
  15960   "RTN","RCR JRBD",200, 0)
  15961    Q PREVDAT E_"00"
  15962   "RTN","RCR JRBD",201, 0)
  15963    ;
  15964   "RTN","RCR JRBD",202, 0)
  15965    ; derive  standard g eneral led ger (SGL)  from categ ory and fu nd
  15966   "RTN","RCR JRBD",203, 0)
  15967   SGL(CATEGO RY,FUND) ;
  15968   "RTN","RCR JRBD",204, 0)
  15969    I $G(FUND )=528709 Q  1319.2 ;n ew long te rm care fu nd
  15970   "RTN","RCR JRBD",205, 0)
  15971    I $E($G(F UND),1,4)= 4032 Q 131 9.2 ; brea kout long  term care  as a subse t
  15972   "RTN","RCR JRBD",206, 0)
  15973    I $G(FUND )=528711&( CAT=6)!(CA T=7) Q 131 9.5  ; bre akout phar macy
  15974   "RTN","RCR JRBD",207, 0)
  15975    I $G(FUND )=528711&( CAT=9) Q " 133N.2"  ;  pharmacy  reimburs h ealth ins
  15976   "RTN","RCR JRBD",208, 0)
  15977    I $G(FUND )=528711&( CAT=10) Q  1338.2  ;  pharmacy t ort feasor
  15978   "RTN","RCR JRBD",209, 0)
  15979    I CATEGOR Y=8 Q 1339    ; crime  or per. v io.
  15980   "RTN","RCR JRBD",210, 0)
  15981    I CATEGOR Y=9 Q 1339    ; reimb ursable he alth insur ance
  15982   "RTN","RCR JRBD",211, 0)
  15983    I CATEGOR Y=46 Q 133 9   ; EMER /HUMAN REI MB INS  ;3 15
  15984   "RTN","RCR JRBD",212, 0)
  15985    I CATEGOR Y=10 Q 133 8  ; tort  feasor
  15986   "RTN","RCR JRBD",213, 0)
  15987    I CATEGOR Y=21 Q 133 9  ; medic are
  15988   "RTN","RCR JRBD",214, 0)
  15989    I CATEGOR Y=45 Q 133 9.1  ; Fee  Basis
  15990   "RTN","RCR JRBD",215, 0)
  15991    Q 1319
  15992   "RTN","RCR JRBD",216, 0)
  15993    ;
  15994   "RTN","RCR JRBD",217, 0)
  15995    ;
  15996   "RTN","RCR JRBD",218, 0)
  15997   BDRSGL(CAT ,FUND,MRAT YPE) ; Cal culate SGL s for the  BDR proces s
  15998   "RTN","RCR JRBD",219, 0)
  15999    ;PRCA*4.5 *310/DRF A dded fund  528713, No n-VA Reimb ursable In surance
  16000   "RTN","RCR JRBD",220, 0)
  16001    ;
  16002   "RTN","RCR JRBD",221, 0)
  16003    ; This AP I will be  used by bo th the ARD C (routine  RCRJRCOC)
  16004   "RTN","RCR JRBD",222, 0)
  16005    ; and the  BDR estim ate calcul ator to as sociate re ceivables
  16006   "RTN","RCR JRBD",223, 0)
  16007    ; with th e correct  standard g eneral led ger accoun t (SGL).
  16008   "RTN","RCR JRBD",224, 0)
  16009    ; The fol lowing tab le will be  implement ed:
  16010   "RTN","RCR JRBD",225, 0)
  16011    ;
  16012   "RTN","RCR JRBD",226, 0)
  16013    ; Receiva ble Type ( Category)         Fun d      SGL
  16014   "RTN","RCR JRBD",227, 0)
  16015    ;======== ========== ========== ========== ========== ==
  16016   "RTN","RCR JRBD",228, 0)
  16017    ; Medical  Care Co-p ayments                   528703     1319
  16018   "RTN","RCR JRBD",229, 0)
  16019    ;  (plus  Inelig, Em erg./Hum.  rec.)
  16020   "RTN","RCR JRBD",230, 0)
  16021    ; Long Te rm Care Co -payments                 528709     1319.2
  16022   "RTN","RCR JRBD",231, 0)
  16023    ; Medicat ion Co-pay ments                     528701     1319.3
  16024   "RTN","RCR JRBD",232, 0)
  16025    ; Crimes  of Persona l Violence  (8),          528704     1319.4
  16026   "RTN","RCR JRBD",233, 0)
  16027    ;  Medica re (21), N o-Fault Au to
  16028   "RTN","RCR JRBD",234, 0)
  16029    ;  (7), W orkman's C omp (6)
  16030   "RTN","RCR JRBD",235, 0)
  16031    ; Tort Fe asor (10)                            528704     1338
  16032   "RTN","RCR JRBD",236, 0)
  16033    ; RHI (9) , pre-MRA                            528704     1339
  16034   "RTN","RCR JRBD",237, 0)
  16035    ; RHI (9) , post-MRA , MRA rec.                528704     133H
  16036   "RTN","RCR JRBD",238, 0)
  16037    ; RHI (9) , post-MRA , non-MRA  rec.           528704     133N
  16038   "RTN","RCR JRBD",239, 0)
  16039    ; Non-VA  RHI Tort F easor                     528713     1338.3
  16040   "RTN","RCR JRBD",240, 0)
  16041    ; Non-VA  RHI (45),  pre-MRA                   528713     1339.1
  16042   "RTN","RCR JRBD",241, 0)
  16043    ; Non-VA  RHI (45),  post-MRA,  MRA rec.       528713     133H.2
  16044   "RTN","RCR JRBD",242, 0)
  16045    ; Non-VA  RHI (45),  post-MRA,  non-MRA re c.  528713     133N.3
  16046   "RTN","RCR JRBD",243, 0)
  16047    ; Crimes  of Persona l Violence  (8),          528713     1319.6
  16048   "RTN","RCR JRBD",244, 0)
  16049    ;  Medica re (21), N o-Fault Au to
  16050   "RTN","RCR JRBD",245, 0)
  16051    ;  (7), W orkman's C omp (6)
  16052   "RTN","RCR JRBD",246, 0)
  16053    ; Pharmac y No Fault  Auto(7),                 528711     1319.5
  16054   "RTN","RCR JRBD",247, 0)
  16055    ; Pharmac y Workman' s Comp(6)
  16056   "RTN","RCR JRBD",248, 0)
  16057    ; Pharmac y RHI, non  MRA (9)                  528711     133N.2
  16058   "RTN","RCR JRBD",249, 0)
  16059    ; Pharmac y Tort Fea sor (10)                  528711     1338.2
  16060   "RTN","RCR JRBD",250, 0)
  16061    ;
  16062   "RTN","RCR JRBD",251, 0)
  16063    ;  Input:   CAT  --   Pointer t o the rece ivable cat egory in f ile 430.2
  16064   "RTN","RCR JRBD",252, 0)
  16065    ;          FUND  --   Receivabl e fund cal culated by  routine R CXFMSUF
  16066   "RTN","RCR JRBD",253, 0)
  16067    ;      MR ATYPE  --   Indicator  of an MRA  (2) or no n-MRA (3)  receivable
  16068   "RTN","RCR JRBD",254, 0)
  16069    ;
  16070   "RTN","RCR JRBD",255, 0)
  16071    ;
  16072   "RTN","RCR JRBD",256, 0)
  16073    I $G(FUND )=528709 Q  1319.2
  16074   "RTN","RCR JRBD",257, 0)
  16075    I $E($G(F UND),1,4)= 4032 Q 131 9.2
  16076   "RTN","RCR JRBD",258, 0)
  16077    I $G(FUND )=528701 Q  1319.3
  16078   "RTN","RCR JRBD",259, 0)
  16079    I $G(FUND )=528711&( (CAT=6)!(C AT=7)) Q 1 319.5
  16080   "RTN","RCR JRBD",260, 0)
  16081    I $G(FUND )=528711&( CAT=9) Q " 133N.2"
  16082   "RTN","RCR JRBD",261, 0)
  16083    I $G(FUND )=528711&( CAT=10) Q  1338.2
  16084   "RTN","RCR JRBD",262, 0)
  16085    I $G(FUND )=528713&( CAT=10) Q  1338.3
  16086   "RTN","RCR JRBD",263, 0)
  16087    I $G(FUND )=528713&( CAT=8!(CAT =21)!(CAT= 6)!(CAT=7) ) Q 1319.6
  16088   "RTN","RCR JRBD",264, 0)
  16089    I CAT=8!( CAT=21)!(C AT=7)!(CAT =6) Q 1319 .4
  16090   "RTN","RCR JRBD",265, 0)
  16091    I CAT=10  Q 1338
  16092   "RTN","RCR JRBD",266, 0)
  16093    I CAT=9 Q  $S(MRATYP E=2:"133H" ,MRATYPE=3 :"133N",1: 1339)
  16094   "RTN","RCR JRBD",267, 0)
  16095    I CAT=46  Q $S(MRATY PE=2:"133H ",MRATYPE= 3:"133N",1 :1339)  ;3 15 
  16096   "RTN","RCR JRBD",268, 0)
  16097    I CAT=45  Q $S(MRATY PE=2:"133H .2",MRATYP E=3:"133N. 3",1:1339. 1)
  16098   "RTN","RCR JRBD",269, 0)
  16099    Q 1319
  16100   "RTN","RCT CSJR")
  16101   0^13^B1237 88872^B113 325699
  16102   "RTN","RCT CSJR",1,0)
  16103   RCTCSJR ;A LBANY/LEG- CS DEBT RE FERRAL REJ ECT REPORT ING ;07/15 /14 3:34 P M
  16104   "RTN","RCT CSJR",2,0)
  16105    ;;4.5;Acc ounts Rece ivable;**3 01,315**;M ar 20, 199 5;Build 55
  16106   "RTN","RCT CSJR",3,0)
  16107    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  16108   "RTN","RCT CSJR",4,0)
  16109    ;
  16110   "RTN","RCT CSJR",5,0)
  16111    Q
  16112   "RTN","RCT CSJR",6,0)
  16113   ECLIST ; p rints IAI  Error Code s List
  16114   "RTN","RCT CSJR",7,0)
  16115    S DIC="^R C(348.5,", BY=.01
  16116   "RTN","RCT CSJR",8,0)
  16117    S (FR,TO) =""
  16118   "RTN","RCT CSJR",9,0)
  16119    S FLDS="[ TCS IAI ER ROR CODES  LIST]"
  16120   "RTN","RCT CSJR",10,0 )
  16121    S DHD="TC S IAI ERRO R CODES LI ST"
  16122   "RTN","RCT CSJR",11,0 )
  16123    S DIOBEG= "W !!"
  16124   "RTN","RCT CSJR",12,0 )
  16125    D EN1^DIP
  16126   "RTN","RCT CSJR",13,0 )
  16127    Q
  16128   "RTN","RCT CSJR",14,0 )
  16129    ; 
  16130   "RTN","RCT CSJR",15,0 )
  16131   RJRPT ; fo r CS REJEC T REPORT p rocessing
  16132   "RTN","RCT CSJR",16,0 )
  16133    D INIT S  STOP=0
  16134   "RTN","RCT CSJR",17,0 )
  16135    D PROMPTS  Q:POP
  16136   "RTN","RCT CSJR",18,0 )
  16137    Q:STOP
  16138   "RTN","RCT CSJR",19,0 )
  16139    D HEADING ,GETRECS,P RTRECS
  16140   "RTN","RCT CSJR",20,0 )
  16141    K %ZIS,AC TN,ASCDES, BILLID,BIL LIEN,BLNKS ,BY,CD,CDI EN,CDREC,C DSH,CHDR,C HDRS,CNTR, COLDASH,CO LHDRS,COLW IDTH1,COLW IDTH2,COLW IDTH3,CWID ,DASH,DATA ,DATAITMS, DATE,DEBTI DX,DEBTIEN ,DEBTOR,DE BTREC,DEBT REF,DEFAUL T,DESC,DHD ,DIOBEG
  16142   "RTN","RCT CSJR",21,0 )
  16143    K DTFRM,D TFRMTO,DTF ROM,DTTO,E CDS,EXCEL, FIELD,FLDS ,FR,GROUPB D,HDTITLE, I,INCLUDE, INDATE,L,L EV1,LEV2,L EV3,LEV4,L N,OUTDATE, PAGE,POP,Q UIT,RPTITE MS,RPTREC, SEQ,SRC,SS N,STOP,STR ,TO,TYP,UP DN,RECW1,R ECW2,EXCOL H,EXSSN,CD REC1
  16144   "RTN","RCT CSJR",22,0 )
  16145    Q
  16146   "RTN","RCT CSJR",23,0 )
  16147    ;
  16148   "RTN","RCT CSJR",24,0 )
  16149   INIT ;
  16150   "RTN","RCT CSJR",25,0 )
  16151    K ^XTMP(" RCTCSJS",$ J),REC
  16152   "RTN","RCT CSJR",26,0 )
  16153    S ^XTMP(" RCTCSJS",$ J,0)=$$FMA DD^XLFDT(D T,5)_"^"_D T_"^"_"CS  REJECT Rep ort"  ; Ma intain thi s entry fo r 5 days
  16154   "RTN","RCT CSJR",27,0 )
  16155    S DASH="" ,$P(DASH," -",78)=""   ; (as per  PRCA*4.5* 315)
  16156   "RTN","RCT CSJR",28,0 )
  16157    S BLNKS=" ",$P(BLNKS ," ",71)=" "
  16158   "RTN","RCT CSJR",29,0 )
  16159    S DATAITM S="DATE^SR C^ECD(1)^E CD(2)^ECD( 3)^ECD(4)^ ECD(5)^ECD (6)^ECD(7) ^ECD(8)^EC D(9)^TYP^A CTN"
  16160   "RTN","RCT CSJR",30,0 )
  16161    S RPTITEM S="BILLID^ DEBTOR^SSN ^TYP^ACTN^ OUTDATE^SR C^ECDS"
  16162   "RTN","RCT CSJR",31,0 )
  16163    I $G(EXCE L) S RPTIT EMS="BILLI D^DEBTOR^E XSSN^TYP^A CTN^OUTDAT E^SRC^ECDS ^RECDET"   ;PRCA*4.5* 315
  16164   "RTN","RCT CSJR",32,0 )
  16165    Q
  16166   "RTN","RCT CSJR",33,0 )
  16167    ;
  16168   "RTN","RCT CSJR",34,0 )
  16169   GETRECS ;
  16170   "RTN","RCT CSJR",35,0 )
  16171    N PC,RECD ET
  16172   "RTN","RCT CSJR",36,0 )
  16173    S (DATE,D TFRM)=$$FM ADD^XLFDT( +$P(DTFRMT O,U,2),-1) ,DTTO=$P(D TFRMTO,U,3 )
  16174   "RTN","RCT CSJR",37,0 )
  16175    F  S DATE =$O(^PRCA( 430,"AB",D ATE)),BILL IEN=0 Q:DA TE>DTTO!'D ATE  D  ;
  16176   "RTN","RCT CSJR",38,0 )
  16177    . S INDAT E=DATE,OUT DATE=$$FMT E^XLFDT(DA TE,"2Z")   ;Standardi ze dates ( as per PRC A*4.5*315)
  16178   "RTN","RCT CSJR",39,0 )
  16179    . F  S BI LLIEN=$O(^ PRCA(430," AB",DATE,B ILLIEN)),S EQ=0 Q:BIL LIEN=""  D   ;
  16180   "RTN","RCT CSJR",40,0 )
  16181    .. S BILL ID=$P(^PRC A(430,BILL IEN,0),U)
  16182   "RTN","RCT CSJR",41,0 )
  16183    .. S DEBT IEN=$P(^PR CA(430,BIL LIEN,0),U, 9) ;33460
  16184   "RTN","RCT CSJR",42,0 )
  16185    .. S DEBT IDX=$P($G( ^RCD(340,D EBTIEN,0)) ,U) ;77770 6050;DPT(
  16186   "RTN","RCT CSJR",43,0 )
  16187    .. Q:$G(D EBTIDX)=""
  16188   "RTN","RCT CSJR",44,0 )
  16189    .. S DEBT REF="^"_$P (DEBTIDX," ;",2)_$P(D EBTIDX,";" )_",0)"
  16190   "RTN","RCT CSJR",45,0 )
  16191    .. S DEBT REC=@(DEBT REF)
  16192   "RTN","RCT CSJR",46,0 )
  16193    .. S DEBT OR=$E($P(D EBTREC,U), 1,19),SSN= $E($$SSN^R CFN01($P($ G(^RCD(340 ,DEBTIEN,0 )),"^")),6 ,9)  ;Last  4 of SSN  only (as p er PRCA*4. 5*315)
  16194   "RTN","RCT CSJR",47,0 )
  16195    .. S SSN= $E($$SSN^R CFN01($P($ G(^RCD(340 ,DEBTIEN,0 )),"^")),6 ,9)  ;Last  4 of SSN  if Excel P RCA*4.5*31 5
  16196   "RTN","RCT CSJR",48,0 )
  16197    .. S EXSS N=$E(DEBTO R)_$S(SSN' ="":SSN,1: "    ")  ;  1st init  last name,  last 4 of  SSN if no t Excel PR CA*4.5*315
  16198   "RTN","RCT CSJR",49,0 )
  16199    .. F  S S EQ=$O(^PRC A(430,"AB" ,DATE,BILL IEN,SEQ))  Q:SEQ=""   D  ;
  16200   "RTN","RCT CSJR",50,0 )
  16201    ... S DAT A=$G(^PRCA (430,BILLI EN,18,SEQ, 0))
  16202   "RTN","RCT CSJR",51,0 )
  16203    ... Q:'$L (DATA)  ;  in the eve nt the X-R EF is out  of sync du e to test  clearing
  16204   "RTN","RCT CSJR",52,0 )
  16205    ... F PC= 2,12,13 S  CD=$P(DATA ,U,PC),X=$ P(DATAITMS ,U,PC)_"=" ""_$S(CD=" ":CD,PC=2: CD,PC=12:$ P($G(^RC(3 48.7,CD,0) ),U),PC=13 :$P($G(^RC (348.6,CD, 0)),U),1:" ")_"""",@X
  16206   "RTN","RCT CSJR",53,0 )
  16207    ... K ECD
  16208   "RTN","RCT CSJR",54,0 )
  16209    ... S ECD S=""
  16210   "RTN","RCT CSJR",55,0 )
  16211    ... F PC= 3:1:11 S C D=$P(DATA, U,PC) Q:'$ L(CD)  S C D=$S('$D(^ RC(348.5,C D,0)):CD,1 :$P(^RC(34 8.5,CD,0), U)) S X="S  "_$P(DATA ITMS,U,PC) _"="""_CD_ """" D  ;
  16212   "RTN","RCT CSJR",56,0 )
  16213    .... Q:'$ D(^RC(348. 5,$P(DATA, U,PC),0))! (CD="ZZ")   ; quits j ust in cas e bad erro r code got  thru
  16214   "RTN","RCT CSJR",57,0 )
  16215    .... X X
  16216   "RTN","RCT CSJR",58,0 )
  16217    .... S EC DS=ECDS_$S (PC>3:";", 1:"")_ECD( PC-2) ;Err or codes n ew delimit er ";"
  16218   "RTN","RCT CSJR",59,0 )
  16219    ... ;  ge ts record  layout bas ed on RPTT YP and pla ces into R PTTYP sort ing sequen ce
  16220   "RTN","RCT CSJR",60,0 )
  16221    ... D @RP TTYP ;1=BI LL NO.  2= DEBTOR  3= REJECT DAT E
  16222   "RTN","RCT CSJR",61,0 )
  16223    ... Q  ;
  16224   "RTN","RCT CSJR",62,0 )
  16225    ... ;
  16226   "RTN","RCT CSJR",63,0 )
  16227    S LEV1="" ,CNTR=0
  16228   "RTN","RCT CSJR",64,0 )
  16229    K REC
  16230   "RTN","RCT CSJR",65,0 )
  16231    S UPDN=$S (ASCDES="D ":-1,1:1)  ; determin es ASCendi ng or DeSC ending dir ection
  16232   "RTN","RCT CSJR",66,0 )
  16233    F  S LEV1 =$O(^XTMP( "RCTCSJS", $J,"RPT",L EV1),UPDN) ,LEV2="" Q :LEV1=""   D  ;
  16234   "RTN","RCT CSJR",67,0 )
  16235    . F  S LE V2=$O(^XTM P("RCTCSJS ",$J,"RPT" ,LEV1,LEV2 ),UPDN),LE V3="" Q:LE V2=""  D   ;
  16236   "RTN","RCT CSJR",68,0 )
  16237    .. F  S L EV3=$O(^XT MP("RCTCSJ S",$J,"RPT ",LEV1,LEV 2,LEV3),UP DN),LEV4=" " Q:LEV3=" "  D  ;
  16238   "RTN","RCT CSJR",69,0 )
  16239    ... F  S  LEV4=$O(^X TMP("RCTCS JS",$J,"RP T",LEV1,LE V2,LEV3,LE V4),UPDN)  Q:LEV4=""   D  ;
  16240   "RTN","RCT CSJR",70,0 )
  16241    .... S RP TREC=^XTMP ("RCTCSJS" ,$J,"RPT", LEV1,LEV2, LEV3,LEV4)
  16242   "RTN","RCT CSJR",71,0 )
  16243    .... I 'E XCEL S SRC =$E(RPTREC ,65)
  16244   "RTN","RCT CSJR",72,0 )
  16245    .... I EX CEL S SRC= $P(RPTREC, U,7)
  16246   "RTN","RCT CSJR",73,0 )
  16247    .... I IN CLUDE'="AL L",INCLUDE '=SRC Q  ;  unwanted  source
  16248   "RTN","RCT CSJR",74,0 )
  16249    .... S CN TR=CNTR+1
  16250   "RTN","RCT CSJR",75,0 )
  16251    .... S RE C(CNTR)=$P (RPTREC,"; ",1,$S(EXC EL:10,1:4) )
  16252   "RTN","RCT CSJR",76,0 )
  16253    .... I EX CEL S RECW 1=$E(REC(C NTR),1,70) ,RECW2=$TR ($E(REC(CN TR),71,999 ),"^","-") ,REC(CNTR) =RECW1_REC W2
  16254   "RTN","RCT CSJR",77,0 )
  16255    .... ;Q:E XCEL  ;      only nee ds single  line strin g if in Ex cel format
  16256   "RTN","RCT CSJR",78,0 )
  16257    .... I 'E XCEL S REC W1=$E(REC( CNTR),1,70 ),RECW2=$T R($E(REC(C NTR),71,99 9),"^",";" ),REC(CNTR )=RECW1_RE CW2
  16258   "RTN","RCT CSJR",79,0 )
  16259    .... I 'E XCEL,$L($P (RPTREC,"; ",5,8)) D
  16260   "RTN","RCT CSJR",80,0 )
  16261    ..... S C NTR=CNTR+1 ,REC(CNTR) =$E(BLNKS, 1,67)_$P(R PTREC,";", 5,8)
  16262   "RTN","RCT CSJR",81,0 )
  16263    .... I 'E XCEL,$L($P (RPTREC,"; ",9)) D
  16264   "RTN","RCT CSJR",82,0 )
  16265    ..... S C NTR=CNTR+1 ,REC(CNTR) =$E(BLNKS, 1,67)_$P(R PTREC,";", 9)
  16266   "RTN","RCT CSJR",83,0 )
  16267    .... I GR OUPBD="D"  D  ;
  16268   "RTN","RCT CSJR",84,0 )
  16269    ..... K E CD
  16270   "RTN","RCT CSJR",85,0 )
  16271    ..... S E CDS=$E(RPT REC,68,100 )
  16272   "RTN","RCT CSJR",86,0 )
  16273    ..... F I =1:1:9 S E CD(I)=$P(E CDS,";",I)  Q:'$L(ECD (I))  D
  16274   "RTN","RCT CSJR",87,0 )
  16275    ...... S  CD=$P(ECDS ,";",I),CD IEN=$O(^RC (348.5,"B" ,CD,0))
  16276   "RTN","RCT CSJR",88,0 )
  16277    ...... S  (CDREC,CDR EC1)="" I  CDIEN,$D(^ RC(348.5,C DIEN)) S C DREC=^RC(3 48.5,CDIEN ,0),CDREC1 =$G(^RC(34 8.5,CDIEN, 1))
  16278   "RTN","RCT CSJR",89,0 )
  16279    ...... S  (X,DESC,RE CDET)="  " _CD_" - "_ CDREC1
  16280   "RTN","RCT CSJR",90,0 )
  16281    ...... I  $L(DESC)<8 1 S CNTR=C NTR+1,REC( CNTR)=X
  16282   "RTN","RCT CSJR",91,0 )
  16283    ...... ;   splits li ne if > 80  chars
  16284   "RTN","RCT CSJR",92,0 )
  16285    ...... I  $L(DESC)>8 0 D  ;
  16286   "RTN","RCT CSJR",93,0 )
  16287    ....... F   S STR=$E (X,1,80) D   Q:'$L(X)   ;
  16288   "RTN","RCT CSJR",94,0 )
  16289    ........  I $L(X)<81  S CNTR=CN TR+1 S REC (CNTR)=X,X ="" Q
  16290   "RTN","RCT CSJR",95,0 )
  16291    ........  F L=$L(STR ):-1:1 I $ F(STR," ", L) D  Q  ;
  16292   "RTN","RCT CSJR",96,0 )
  16293    .........  S CNTR=CN TR+1
  16294   "RTN","RCT CSJR",97,0 )
  16295    .........  S REC(CNT R)=$E(X,1, L),X=$E(X, L+1,999)
  16296   "RTN","RCT CSJR",98,0 )
  16297    .........  I $L(X) S  X="     " _X
  16298   "RTN","RCT CSJR",99,0 )
  16299    .........  Q  ;
  16300   "RTN","RCT CSJR",100, 0)
  16301    M ^XTMP(" RCTCSJS",$ J,"REC")=R EC
  16302   "RTN","RCT CSJR",101, 0)
  16303    Q
  16304   "RTN","RCT CSJR",102, 0)
  16305    ;
  16306   "RTN","RCT CSJR",103, 0)
  16307   1 ; for re port by 1)  Bill Numb er
  16308   "RTN","RCT CSJR",104, 0)
  16309    S QUIT=0
  16310   "RTN","RCT CSJR",105, 0)
  16311    I 'EXCEL  D  Q:QUIT   ;
  16312   "RTN","RCT CSJR",106, 0)
  16313    . S RPTRE C=""
  16314   "RTN","RCT CSJR",107, 0)
  16315    . F PC=1: 1:7 D  Q:Q UIT  ;
  16316   "RTN","RCT CSJR",108, 0)
  16317    .. S FIEL D=$P(RPTIT EMS,U,PC)
  16318   "RTN","RCT CSJR",109, 0)
  16319    .. I PC=7 ,INCLUDE'= "ALL",@FIE LD'=INCLUD E S QUIT=1  Q  ;
  16320   "RTN","RCT CSJR",110, 0)
  16321    .. S RPTR EC=RPTREC_ $E(@FIELD_ BLNKS,1,$P (COLWIDTH1 ,U,PC))
  16322   "RTN","RCT CSJR",111, 0)
  16323    . F PC=8  S RPTREC=R PTREC_@$P( RPTITEMS,U ,PC)
  16324   "RTN","RCT CSJR",112, 0)
  16325    I EXCEL S  RPTREC=BI LLID_U_DEB TOR_U_EXSS N_U_TYP_U_ ACTN_U_OUT DATE_U_SRC _U_ECDS  ;  PRCA*4.5* 315
  16326   "RTN","RCT CSJR",113, 0)
  16327    S ^XTMP(" RCTCSJS",$ J,"RPT",BI LLID,INDAT E,DEBTOR,S EQ)=RPTREC
  16328   "RTN","RCT CSJR",114, 0)
  16329    Q
  16330   "RTN","RCT CSJR",115, 0)
  16331   2 ; for re port by 2)  Debtor Na me
  16332   "RTN","RCT CSJR",116, 0)
  16333    S QUIT=0
  16334   "RTN","RCT CSJR",117, 0)
  16335    I EXCEL S  RPTREC=DE BTOR_U_BIL LID_U_EXSS N_U_TYP_U_ ACTN_U_OUT DATE_U_SRC _U_ECDS  ;  PRCA*4.5* 315
  16336   "RTN","RCT CSJR",118, 0)
  16337    I 'EXCEL  D  Q:QUIT   ;
  16338   "RTN","RCT CSJR",119, 0)
  16339    . S RPTRE C=""
  16340   "RTN","RCT CSJR",120, 0)
  16341    . F PC=2, 1,3:1:7 D   Q:QUIT  ;
  16342   "RTN","RCT CSJR",121, 0)
  16343    .. S FIEL D=$P(RPTIT EMS,U,PC)
  16344   "RTN","RCT CSJR",122, 0)
  16345    .. I PC=7 ,INCLUDE'= "ALL",@FIE LD'=INCLUD E S QUIT=1  Q  ;
  16346   "RTN","RCT CSJR",123, 0)
  16347    .. S RPTR EC=RPTREC_ $E(@FIELD_ BLNKS,1,$P (COLWIDTH2 ,U,PC))
  16348   "RTN","RCT CSJR",124, 0)
  16349    . F PC=8  S RPTREC=R PTREC_@$P( RPTITEMS,U ,PC)
  16350   "RTN","RCT CSJR",125, 0)
  16351    S ^XTMP(" RCTCSJS",$ J,"RPT",DE BTOR,BILLI D,INDATE,S EQ)=RPTREC
  16352   "RTN","RCT CSJR",126, 0)
  16353    Q
  16354   "RTN","RCT CSJR",127, 0)
  16355   3 ; for re port by 3)  CS Reject  Date
  16356   "RTN","RCT CSJR",128, 0)
  16357    S QUIT=0
  16358   "RTN","RCT CSJR",129, 0)
  16359    I EXCEL S  RPTREC=OU TDATE_U_BI LLID_U_DEB TOR_U_EXSS N_U_TYP_U_ ACTN_U_SRC _U_ECDS  ;  PRCA*4.5* 315
  16360   "RTN","RCT CSJR",130, 0)
  16361    I 'EXCEL  D  Q:QUIT   ;
  16362   "RTN","RCT CSJR",131, 0)
  16363    . S RPTRE C=""
  16364   "RTN","RCT CSJR",132, 0)
  16365    . F PC=6, 1:1:5,7 D   Q:QUIT  ;
  16366   "RTN","RCT CSJR",133, 0)
  16367    .. S FIEL D=$P(RPTIT EMS,U,PC)
  16368   "RTN","RCT CSJR",134, 0)
  16369    .. I PC=7 ,INCLUDE'= "ALL",@FIE LD'=INCLUD E S QUIT=1  Q  ;
  16370   "RTN","RCT CSJR",135, 0)
  16371    .. S RPTR EC=RPTREC_ $E(@$P(RPT ITEMS,U,PC )_BLNKS,1, $P(COLWIDT H3,U,PC))
  16372   "RTN","RCT CSJR",136, 0)
  16373    . F PC=8  S RPTREC=R PTREC_@$P( RPTITEMS,U ,PC)
  16374   "RTN","RCT CSJR",137, 0)
  16375    S ^XTMP(" RCTCSJS",$ J,"RPT",IN DATE,BILLI D,DEBTOR,S EQ)=RPTREC
  16376   "RTN","RCT CSJR",138, 0)
  16377    Q
  16378   "RTN","RCT CSJR",139, 0)
  16379   QRPT ;if q ueued
  16380   "RTN","RCT CSJR",140, 0)
  16381    D HEADING ,GETRECS,P RTRECS
  16382   "RTN","RCT CSJR",141, 0)
  16383    Q
  16384   "RTN","RCT CSJR",142, 0)
  16385    ;
  16386   "RTN","RCT CSJR",143, 0)
  16387   PRTRECS ;  prints rep ort
  16388   "RTN","RCT CSJR",144, 0)
  16389    S PAGE=0
  16390   "RTN","RCT CSJR",145, 0)
  16391    D HEADING ,REJREPH
  16392   "RTN","RCT CSJR",146, 0)
  16393    S LN=0 F  LN=1:1 Q:' $D(^XTMP(" RCTCSJS",$ J,"REC",LN ))  D  Q:$ D(DIRUT)!$ D(DUOUT)!$ D(DTOUT)
  16394   "RTN","RCT CSJR",147, 0)
  16395    . W ^XTMP ("RCTCSJS" ,$J,"REC", LN),!
  16396   "RTN","RCT CSJR",148, 0)
  16397    . ;    ch eck for en d of page  here, if n ecessary f orm feed a nd print h eader
  16398   "RTN","RCT CSJR",149, 0)
  16399    . I $Y+3> IOSL D
  16400   "RTN","RCT CSJR",150, 0)
  16401    .. I $E(I OST,1,2)=" C-" S DIR( 0)="E" K D IRUT D ^DI R Q:$D(DIR UT)!$D(DUO UT)!$D(DTO UT)
  16402   "RTN","RCT CSJR",151, 0)
  16403    .. D REJR EPH
  16404   "RTN","RCT CSJR",152, 0)
  16405    . Q
  16406   "RTN","RCT CSJR",153, 0)
  16407    I $E(IOST ,1,2)="C-"  R !!,"END  OF REPORT ...PRESS R ETURN TO C ONTINUE",X :DTIME W @ IOF
  16408   "RTN","RCT CSJR",154, 0)
  16409    D ^%ZISC
  16410   "RTN","RCT CSJR",155, 0)
  16411    Q
  16412   "RTN","RCT CSJR",156, 0)
  16413   REJREPH ;
  16414   "RTN","RCT CSJR",157, 0)
  16415    U IO W @I OF S PAGE= PAGE+1
  16416   "RTN","RCT CSJR",158, 0)
  16417    W "PAGE " _PAGE,?10, HDTITLE,?6 8,$$FMTE^X LFDT(DT,"2 Z")   ;Sta ndardize t he date
  16418   "RTN","RCT CSJR",159, 0)
  16419    I EXCEL W  !,$TR(CHD R," ",""), ! Q
  16420   "RTN","RCT CSJR",160, 0)
  16421    W !,DASH, !,CHDR,!,C DSH,! Q
  16422   "RTN","RCT CSJR",161, 0)
  16423    Q
  16424   "RTN","RCT CSJR",162, 0)
  16425   COLHDR ; s ets report  line base d on type  of report
  16426   "RTN","RCT CSJR",163, 0)
  16427    S CHDR=CH DR_$P(COLH DRS,U,PC)_ $S(EXCEL:" ^",1:"")
  16428   "RTN","RCT CSJR",164, 0)
  16429    S CDSH=CD SH_$P(COLD ASH,U,PC)_ $S(EXCEL:" ^",1:"")
  16430   "RTN","RCT CSJR",165, 0)
  16431    Q
  16432   "RTN","RCT CSJR",166, 0)
  16433   HEADING ;   compiles  info for H eading and  titles fo r cross-se rvicing re ject repor t
  16434   "RTN","RCT CSJR",167, 0)
  16435    S HDTITLE ="DEBT REF ERRAL REJE CT REPORT  (SORTED BY  "_$P("BIL L NO.^DEBT OR^REJ DAT E",U,RPTTY P)
  16436   "RTN","RCT CSJR",168, 0)
  16437    S HDTITLE =HDTITLE_"  <"_$S(ASC DES="D":"D SC",1:"ASC ")_">)"
  16438   "RTN","RCT CSJR",169, 0)
  16439    ;
  16440   "RTN","RCT CSJR",170, 0)
  16441    S COLWIDT H1="12^20^ 9^5^5^13^3 ^11"  ;Cha nge SSN to  last init ial last 4  only (as  per PRCA*4 .5*315)
  16442   "RTN","RCT CSJR",171, 0)
  16443    S COLWIDT H2="12^20^ 9^5^5^13^3 ^8",COLWID TH3="12^20 ^9^5^6^12^ 3^11"
  16444   "RTN","RCT CSJR",172, 0)
  16445    S EXCOLH= "BILL NO.^ DEBTOR^Pt  ID^TYP ^AC TNCD ^REJE CT DATE ^S RC ^ERR CO DES"
  16446   "RTN","RCT CSJR",173, 0)
  16447    S COLHDRS ="BILL NO.     ^DEBTO R               ^Pt I D   ^TYP ^ ACTNCD ^RE JECT DATE  ^SRC ^ERR  CODES"
  16448   "RTN","RCT CSJR",174, 0)
  16449    S COLDASH ="-------- --- ^----- ---------- ---- ^---- -   ^--- ^ ------ ^-- ---------  ^--- ^---- -----"
  16450   "RTN","RCT CSJR",175, 0)
  16451    S (CHDR,C DSH,CWID)= ""
  16452   "RTN","RCT CSJR",176, 0)
  16453    I RPTTYP= 1 S CWID=C OLWIDTH1,C HDR=$S(EXC EL:COLHDRS ,1:$TR(COL HDRS,"^"," ")),CDSH=$ S(EXCEL:CO LDASH,1:$T R(COLDASH, "^",""))
  16454   "RTN","RCT CSJR",177, 0)
  16455    I RPTTYP= 2 F PC=2,1 ,3:1:8 D C OLHDR
  16456   "RTN","RCT CSJR",178, 0)
  16457    I RPTTYP= 3 F PC=6,1 :1:5,7,8 D  COLHDR
  16458   "RTN","RCT CSJR",179, 0)
  16459    Q
  16460   "RTN","RCT CSJR",180, 0)
  16461   PROMPTS S  U="^"
  16462   "RTN","RCT CSJR",181, 0)
  16463    S STOP=0, PROMPT="** * DEBT REF ERRAL REJE CT REPORT  ***"
  16464   "RTN","RCT CSJR",182, 0)
  16465    S DTFRMTO =$$DTFRMTO (PROMPT) I  'DTFRMTO  S (STOP,PO P)=1 Q
  16466   "RTN","RCT CSJR",183, 0)
  16467    ;
  16468   "RTN","RCT CSJR",184, 0)
  16469    S PROMPT= "Group Err or Codes:   Brief or  Detail"
  16470   "RTN","RCT CSJR",185, 0)
  16471    S DIR(0)= "SB^B:Brie f;D:Detail "
  16472   "RTN","RCT CSJR",186, 0)
  16473    S GROUPBD =$$SELECT( PROMPT,"B" ) I "BD"'[ GROUPBD S  (STOP,POP) =1 Q
  16474   "RTN","RCT CSJR",187, 0)
  16475    ;
  16476   "RTN","RCT CSJR",188, 0)
  16477    S SET="S^ 1:Bill Num ber;2:Debt or Name;3: CS Reject  Date"
  16478   "RTN","RCT CSJR",189, 0)
  16479    S RPTTYP= $$RPTTYP(" Select One  of the Fo llowing:", SET) I 'RP TTYP S (ST OP,POP)=1  Q
  16480   "RTN","RCT CSJR",190, 0)
  16481    ;
  16482   "RTN","RCT CSJR",191, 0)
  16483    S PROMPT= "Include O nly: AITC,  DMC, TREA SURY or 'A LL'"
  16484   "RTN","RCT CSJR",192, 0)
  16485    S DIR(0)= "SB^A:AITC ;D:DMC;T:T REASURY;AL L:ALL",DIR ("L")=PROM PT
  16486   "RTN","RCT CSJR",193, 0)
  16487    S INCLUDE =$$SELECT( PROMPT,"AL L") I "ADT "'[$E(INCL UDE) S (ST OP,POP)=1  Q
  16488   "RTN","RCT CSJR",194, 0)
  16489    ;
  16490   "RTN","RCT CSJR",195, 0)
  16491    S PROMPT= "Sort ASCE NDING or D ESCENDING" ,DIR(0)="S B^A:ASCEND ING;D:DESC ENDING"
  16492   "RTN","RCT CSJR",196, 0)
  16493    S DIR("L" )=PROMPT
  16494   "RTN","RCT CSJR",197, 0)
  16495    S ASCDES= $$SELECT(P ROMPT,"A")  I "AD"'[A SCDES S (S TOP,POP)=1  Q
  16496   "RTN","RCT CSJR",198, 0)
  16497    ;
  16498   "RTN","RCT CSJR",199, 0)
  16499    S EXCEL=0
  16500   "RTN","RCT CSJR",200, 0)
  16501    I GROUPBD ="B" D
  16502   "RTN","RCT CSJR",201, 0)
  16503    . S PROMP T="CAPTURE  Report da ta to an E xcel Docum ent"
  16504   "RTN","RCT CSJR",202, 0)
  16505    . S DIR(0 )="Y",DIR( "?")="^D H EXC^RCTCSJ R"
  16506   "RTN","RCT CSJR",203, 0)
  16507    . S EXCEL =$$SELECT( PROMPT,"NO ") I "01"' [EXCEL S ( POP,STOP)= 1 Q
  16508   "RTN","RCT CSJR",204, 0)
  16509    I EXCEL=1  D EXCMSG^ RCTCSJR ;  Display Ex cel displa y message
  16510   "RTN","RCT CSJR",205, 0)
  16511    ; 
  16512   "RTN","RCT CSJR",206, 0)
  16513    K IOP,IO( "Q") S %ZI S="MQ",%ZI S("B")=""  D ^%ZIS I  POP S STOP =1 Q
  16514   "RTN","RCT CSJR",207, 0)
  16515    I $D(IO(" Q")) D  Q
  16516   "RTN","RCT CSJR",208, 0)
  16517    .S ZTSAVE ("DEBTOR") ="",ZTSAVE ("DTFRMTO" )="",ZTSAV E("EXCEL") ="",ZTSAVE ("PROMPT") ="",ZTSAVE ("DASH")=" ",ZTSAVE(" BLNKS")="" ,ZTSAVE("D ATAITMS")= "",ZTSAVE( "RPTITEMS" )=""
  16518   "RTN","RCT CSJR",209, 0)
  16519    .S ZTSAVE ("GROUPBD" )="",ZTSAV E("RPTTYP" )="",ZTSAV E("INCLUDE ")="",ZTSA VE("ASCDES ")="",ZTSA VE("CHDR") ="",ZTSAVE ("CDSH")=" ",ZTSAVE(" ZTASK")=""
  16520   "RTN","RCT CSJR",210, 0)
  16521    .S ZTRTN= "QRPT^RCTC SJR",ZTDES C="CROSS-S ERVICING B ILL REPORT "
  16522   "RTN","RCT CSJR",211, 0)
  16523    .D ^%ZTLO AD,^%ZISC  S (STOP,PO P)=1
  16524   "RTN","RCT CSJR",212, 0)
  16525    .I $G(ZTS K) W !!,"R eport comp ilation ha s started  with task#  ",ZTSK,". ",! S DIR( 0)="E" D ^ DIR K DIR
  16526   "RTN","RCT CSJR",213, 0)
  16527    .Q
  16528   "RTN","RCT CSJR",214, 0)
  16529    Q  ; PROM PTS
  16530   "RTN","RCT CSJR",215, 0)
  16531    ;
  16532   "RTN","RCT CSJR",216, 0)
  16533   SELECT(PRO MPT,DEFAUL T) ; promp ts for a s election
  16534   "RTN","RCT CSJR",217, 0)
  16535    ;INPUT:
  16536   "RTN","RCT CSJR",218, 0)
  16537    ;   PROMP T - Messag e to displ ay prior t o promptin g for date s
  16538   "RTN","RCT CSJR",219, 0)
  16539    ;OUTPUT:
  16540   "RTN","RCT CSJR",220, 0)
  16541    ;    1^BE GDT^ENDDT  - Data fou nd
  16542   "RTN","RCT CSJR",221, 0)
  16543    ;    0               - User up  arrowed or  timed out
  16544   "RTN","RCT CSJR",222, 0)
  16545    N Y,X,DTO UT,OUT,DIR UT,DUOUT,D IROUT
  16546   "RTN","RCT CSJR",223, 0)
  16547    S OUT=0
  16548   "RTN","RCT CSJR",224, 0)
  16549    W !
  16550   "RTN","RCT CSJR",225, 0)
  16551    S DIR("A" )=PROMPT,D IR("B")=DE FAULT
  16552   "RTN","RCT CSJR",226, 0)
  16553    D ^DIR K  DIR
  16554   "RTN","RCT CSJR",227, 0)
  16555    ;Quit if  user time  out or did n't enter  valid date
  16556   "RTN","RCT CSJR",228, 0)
  16557    Q:Y<0 OUT
  16558   "RTN","RCT CSJR",229, 0)
  16559    Q Y
  16560   "RTN","RCT CSJR",230, 0)
  16561    ;
  16562   "RTN","RCT CSJR",231, 0)
  16563   RPTTYP(PRO MPT,SET) ; PRINT CROS S-SERVICIN G REPORT;  print cros s-servicin g report,  prints sor ted indivi dual bills  that make  up a cros s-servicin g account
  16564   "RTN","RCT CSJR",232, 0)
  16565    N DIC,ZTS AVE,ZTDESC ,ZTRTN,RCS ORT
  16566   "RTN","RCT CSJR",233, 0)
  16567    S OUT=0
  16568   "RTN","RCT CSJR",234, 0)
  16569    W !
  16570   "RTN","RCT CSJR",235, 0)
  16571    S DIR(0)= SET ;"S^1: Bill Numbe r;2:Debtor  Name;3:CS  Reject Da te"
  16572   "RTN","RCT CSJR",236, 0)
  16573    S DIR("A" )="Sort by ",DIR("B") =1 D ^DIR  K DIR
  16574   "RTN","RCT CSJR",237, 0)
  16575    Q:Y<0 OUT
  16576   "RTN","RCT CSJR",238, 0)
  16577    Q Y
  16578   "RTN","RCT CSJR",239, 0)
  16579    ;
  16580   "RTN","RCT CSJR",240, 0)
  16581   DTFRMTO(PR OMPT) ;Get  from and  to dates
  16582   "RTN","RCT CSJR",241, 0)
  16583    ;INPUT:
  16584   "RTN","RCT CSJR",242, 0)
  16585    ;   PROMP T - Messag e to displ ay prior t o promptin g for date s
  16586   "RTN","RCT CSJR",243, 0)
  16587    ;OUTPUT:
  16588   "RTN","RCT CSJR",244, 0)
  16589    ;    1^BE GDT^ENDDT  - Data fou nd
  16590   "RTN","RCT CSJR",245, 0)
  16591    ;    0               - User up  arrowed or  timed out
  16592   "RTN","RCT CSJR",246, 0)
  16593    ;
  16594   "RTN","RCT CSJR",247, 0)
  16595    N %DT,Y,X ,BEGDT,END DT,DTOUT,O UT,DIRUT,D UOUT,DIROU T
  16596   "RTN","RCT CSJR",248, 0)
  16597    S OUT=0
  16598   "RTN","RCT CSJR",249, 0)
  16599    W !,$G(PR OMPT)
  16600   "RTN","RCT CSJR",250, 0)
  16601    S %DT="AE X",%DT("A" )="Date Ra nge: FROM:  " ;Enter  Beginning  Date: "
  16602   "RTN","RCT CSJR",251, 0)
  16603    S %DT("B" )="T-7"
  16604   "RTN","RCT CSJR",252, 0)
  16605    W !
  16606   "RTN","RCT CSJR",253, 0)
  16607    D ^%DT K  %DT
  16608   "RTN","RCT CSJR",254, 0)
  16609    Q:Y<0 OUT   ;Quit if  user time  out or di dn't enter  valid dat e
  16610   "RTN","RCT CSJR",255, 0)
  16611    S DTFROM= +Y
  16612   "RTN","RCT CSJR",256, 0)
  16613    S %DT="AE X"
  16614   "RTN","RCT CSJR",257, 0)
  16615    S %DT("A" )="               TO:    ",%DT(" B")="T" ;" TODAY"
  16616   "RTN","RCT CSJR",258, 0)
  16617    D ^%DT K  %DT
  16618   "RTN","RCT CSJR",259, 0)
  16619    ;Quit if  user time  out or did n't enter  valid date
  16620   "RTN","RCT CSJR",260, 0)
  16621    Q:Y<0 OUT
  16622   "RTN","RCT CSJR",261, 0)
  16623    S DTTO=+Y ,OUT=1_U_D TFROM_U_DT TO
  16624   "RTN","RCT CSJR",262, 0)
  16625    ;Switch d ates if Be gin Date i s more rec ent than E nd Date
  16626   "RTN","RCT CSJR",263, 0)
  16627    S:DTFROM> DTTO OUT=1 _U_DTTO_U_ DTFROM
  16628   "RTN","RCT CSJR",264, 0)
  16629    Q OUT
  16630   "RTN","RCT CSJR",265, 0)
  16631    ;
  16632   "RTN","RCT CSJR",266, 0)
  16633   HEXC ; - ' Do you wan t to captu re data to  EXCEL' pr ompt
  16634   "RTN","RCT CSJR",267, 0)
  16635    W !!,"       Enter:   'Y'   -   To capture  detail re port data  to transfe r",!,"                           to an Exce l document "
  16636   "RTN","RCT CSJR",268, 0)
  16637    W !,"                '<CR>' -   To skip th is option" ,!,"               '^ '    -  To  quit this  option"
  16638   "RTN","RCT CSJR",269, 0)
  16639    Q
  16640   "RTN","RCT CSJR",270, 0)
  16641    ;
  16642   "RTN","RCT CSJR",271, 0)
  16643   EXCMSG ; -  Displays  the messag e about ca pturing to  an Excel  file forma t
  16644   "RTN","RCT CSJR",272, 0)
  16645    ;
  16646   "RTN","RCT CSJR",273, 0)
  16647    W !!?5,"T o capture  as an Exce l format,  it is reco mmended th at you que ue this"
  16648   "RTN","RCT CSJR",274, 0)
  16649    W !?5,"re port to a  spool devi ce with ma rgins of 2 56 and pag e length o f 99999"
  16650   "RTN","RCT CSJR",275, 0)
  16651    W !?5,"(e .g. 0;256; 99999). Th is should  help avoid  wrapping  problems."
  16652   "RTN","RCT CSJR",276, 0)
  16653    W !!?5,"A nother met hod would  be to set  up your te rminal to  capture th e detail"
  16654   "RTN","RCT CSJR",277, 0)
  16655    W !?5,"re port data.  On some t erminals,  this can b e done by  invoking ' Logging'"
  16656   "RTN","RCT CSJR",278, 0)
  16657    W !?5,"or  clicking  on the 'To ols' menu  above, the n click on  'Capture  Incoming "
  16658   "RTN","RCT CSJR",279, 0)
  16659    W !?5,"Da ta' to sav e to Deskt op. To avo id undesir ed wrappin g of the d ata saved"
  16660   "RTN","RCT CSJR",280, 0)
  16661    W !?5,"to  the file,  change th e DISPLAY  screen wid th size to  132 and y ou can"
  16662   "RTN","RCT CSJR",281, 0)
  16663    W !?5,"en ter '0;256 ;99999' at  the 'DEVI CE:' promp t.",!
  16664   "RTN","RCT CSJR",282, 0)
  16665    Q
  16666   "RTN","RCT CSJR",283, 0)
  16667    ; ======= ========== ========== ========== ========== ========== ========== =====
  16668   "RTN","RCT CSP1")
  16669   0^12^B1692 82916^B174 226266
  16670   "RTN","RCT CSP1",1,0)
  16671   RCTCSP1 ;A LBANY/BDB- CROSS-SERV ICING TRAN SMISSION ; 03/15/14 3 :34 PM
  16672   "RTN","RCT CSP1",2,0)
  16673    ;;4.5;Acc ounts Rece ivable;**3 01,331,315 **;Mar 20,  1995;Buil d 55
  16674   "RTN","RCT CSP1",3,0)
  16675    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  16676   "RTN","RCT CSP1",4,0)
  16677    ;
  16678   "RTN","RCT CSP1",5,0)
  16679    ;PRCA*4.5 *331 Modif y code to  ensure tha t the debt or address  info
  16680   "RTN","RCT CSP1",6,0)
  16681    ;              is co rrect on t ransmissio n of forei gn veteran
  16682   "RTN","RCT CSP1",7,0)
  16683    ;              debto r/bills to  Treasury.
  16684   "RTN","RCT CSP1",8,0)
  16685    Q
  16686   "RTN","RCT CSP1",9,0)
  16687    ;
  16688   "RTN","RCT CSP1",10,0 )
  16689   BILLREP ;C ross-servi cing bill  report, pr ints indiv idual bill s that mak e up a cro ss-servici ng account
  16690   "RTN","RCT CSP1",11,0 )
  16691    N DIC,DEB TOR,ZTSAVE ,ZTDESC,ZT RTN,POP,DT FRMTO,PROM PT,EXCEL
  16692   "RTN","RCT CSP1",12,0 )
  16693    K ^TMP("R CTCSP1",$J )
  16694   "RTN","RCT CSP1",13,0 )
  16695    S DIC=340 ,DIC(0)="A EQM",DIC(" S")="I $D( ^RCD(340," "TCSP"",+Y ))" D ^DIC
  16696   "RTN","RCT CSP1",14,0 )
  16697    Q:Y<1  S  DEBTOR=+Y
  16698   "RTN","RCT CSP1",15,0 )
  16699    S DTFRMTO =$$DTFRMTO ^RCTCSP2 Q :'DTFRMTO   ;Get date  range as  per PRCA*4 .5*315
  16700   "RTN","RCT CSP1",16,0 )
  16701    S EXCEL=0 ,PROMPT="C APTURE Rep ort data t o an Excel  Document" ,DIR(0)="Y ",DIR("?") ="^D HEXC^ RCTCSJR"
  16702   "RTN","RCT CSP1",17,0 )
  16703    S EXCEL=$ $SELECT^RC TCSJR(PROM PT,"NO") I  "01"'[EXC EL S STOP= 1 Q
  16704   "RTN","RCT CSP1",18,0 )
  16705    I EXCEL=1  D EXCMSG^ RCTCSJR ;  Display Ex cel displa y message
  16706   "RTN","RCT CSP1",19,0 )
  16707    K IOP,IO( "Q") S %ZI S="MQ",%ZI S("B")=""  D ^%ZIS G: POP BILLRE PQ S IOP=I ON_";"_IOM _";"_IOSL
  16708   "RTN","RCT CSP1",20,0 )
  16709    I $D(IO(" Q")) D  G  BILLREPQ
  16710   "RTN","RCT CSP1",21,0 )
  16711    .S ZTSAVE ("DEBTOR") ="",ZTSAVE ("DTFRMTO" )="",ZTSAV E("EXCEL") =""
  16712   "RTN","RCT CSP1",22,0 )
  16713    .S ZTRTN= "BILLREPP^ RCTCSP1",Z TDESC="CRO SS-SERVICI NG BILL RE PORT"
  16714   "RTN","RCT CSP1",23,0 )
  16715    .D ^%ZTLO AD,HOME^%Z IS
  16716   "RTN","RCT CSP1",24,0 )
  16717    .I $G(ZTS K) W !!,"R eport comp ilation ha s started  with task#  ",ZTSK,". ",! S DIR( 0)="E" D ^ DIR K DIR
  16718   "RTN","RCT CSP1",25,0 )
  16719    .Q
  16720   "RTN","RCT CSP1",26,0 )
  16721    ;
  16722   "RTN","RCT CSP1",27,0 )
  16723   BILLREPP ; Call to bu ild array  of bills r eferred
  16724   "RTN","RCT CSP1",28,0 )
  16725    U IO
  16726   "RTN","RCT CSP1",29,0 )
  16727    N BILL,B7 ,B14,B15,B 16,D4,FND, BAMT,TAMT, DIRUT,TNM, TID,TDT,DA SH,CSTAT,P AGE,DASH,T MP,I,DATE, DTFRM,DTTO ,DATDATE
  16728   "RTN","RCT CSP1",30,0 )
  16729    K ^TMP("R CTCSP1",$J )
  16730   "RTN","RCT CSP1",31,0 )
  16731    S DASH="" ,$P(DASH," -",78)=""   ;(as per  PRCA*4.5*3 15)
  16732   "RTN","RCT CSP1",32,0 )
  16733    S (DATE,D TFRM)=$$FM ADD^XLFDT( +$P(DTFRMT O,U,2)),DT TO=$P(DTFR MTO,U,3),C URDT=0
  16734   "RTN","RCT CSP1",33,0 )
  16735    S (BAMT,T AMT,BILL,P AGE)=0
  16736   "RTN","RCT CSP1",34,0 )
  16737    ; rewritt en to sort  by "TCSP"  (#151 dat e referred  to TCSP)  not the "A B" xref...  PRCA*4.5* 315 (TV8)
  16738   "RTN","RCT CSP1",35,0 )
  16739    F  S BILL =$O(^PRCA( 430,"TCSP" ,BILL)) Q: BILL=""!($ D(DIRUT))   D
  16740   "RTN","RCT CSP1",36,0 )
  16741    .Q:$P($G( ^PRCA(430, BILL,0)),U ,9)'=DEBTO R
  16742   "RTN","RCT CSP1",37,0 )
  16743    .Q:'+$G(^ PRCA(430,B ILL,15))
  16744   "RTN","RCT CSP1",38,0 )
  16745    .S DATDAT E=$P($G(^P RCA(430,BI LL,15)),U)  Q:DATDATE <DTFRM!(DA TDATE>DTTO )
  16746   "RTN","RCT CSP1",39,0 )
  16747    .S B7=$G( ^PRCA(430, BILL,7))
  16748   "RTN","RCT CSP1",40,0 )
  16749    .S BAMT=0  F I=1:1:5  S BAMT=BA MT+$P(B7,U ,I)
  16750   "RTN","RCT CSP1",41,0 )
  16751    .S TAMT=T AMT+BAMT
  16752   "RTN","RCT CSP1",42,0 )
  16753    .S ^TMP(" RCTCSP1",$ J,DEBTOR,B ILL)=BAMT
  16754   "RTN","RCT CSP1",43,0 )
  16755    D BILLREP H
  16756   "RTN","RCT CSP1",44,0 )
  16757    S DEBTOR= "" F  S DE BTOR=$O(^T MP("RCTCSP 1",$J,DEBT OR)) Q:'DE BTOR!($D(D IRUT))  D
  16758   "RTN","RCT CSP1",45,0 )
  16759    . S BILL= 0 F  S BIL L=$O(^TMP( "RCTCSP1", $J,DEBTOR, BILL)) Q:' BILL  D
  16760   "RTN","RCT CSP1",46,0 )
  16761    ..Q:'+$G( ^PRCA(430, BILL,15))
  16762   "RTN","RCT CSP1",47,0 )
  16763    ..S FND=1  W !,$P(^P RCA(430,BI LL,0),U) S  CSTAT=$P( ^(0),U,8), B7=$G(^(7) ),B15=$G(^ (15)),B16= $G(^(16))
  16764   "RTN","RCT CSP1",48,0 )
  16765    ..I 'EXCE L W ?12,$P (^PRCA(430 .3,CSTAT,0 ),U,2)
  16766   "RTN","RCT CSP1",49,0 )
  16767    ..I EXCEL  W U_$P(^P RCA(430.3, CSTAT,0),U ,2)
  16768   "RTN","RCT CSP1",50,0 )
  16769    ..I 'EXCE L W ?15
  16770   "RTN","RCT CSP1",51,0 )
  16771    ..I EXCEL  W U
  16772   "RTN","RCT CSP1",52,0 )
  16773    ..W $J($P (B16,U,9), 8,2)
  16774   "RTN","RCT CSP1",53,0 )
  16775    ..S BAMT= ^TMP("RCTC SP1",$J,DE BTOR,BILL)
  16776   "RTN","RCT CSP1",54,0 )
  16777    ..I 'EXCE L W ?25
  16778   "RTN","RCT CSP1",55,0 )
  16779    ..I EXCEL  W U
  16780   "RTN","RCT CSP1",56,0 )
  16781    ..W $J(BA MT,8,2)
  16782   "RTN","RCT CSP1",57,0 )
  16783    ..I 'EXCE L W $J($P( B7,U,1),9, 2),$J($P(B 7,U,2),7,2 ),$J($P(B7 ,U,3),8,2) ,$J($P(B7, U,4),8,2)   ;(as per  PRCA*4.5*3 15)
  16784   "RTN","RCT CSP1",58,0 )
  16785    ..I EXCEL  W $J($P(B 7,U,1),8,2 )_U_$J($P( B7,U,2),7, 2)_U_$J($P (B7,U,3),7 ,2)_U_$J($ P(B7,U,4), 8,2)
  16786   "RTN","RCT CSP1",59,0 )
  16787    ..S TMP=$ $FMTE^XLFD T($P(B15,U ,1),"2Z")   ;Format d ate to n/n /nn  (as p er PRCA*4. 5*315)
  16788   "RTN","RCT CSP1",60,0 )
  16789    ..I 'EXCE L W ?67,TM P  ;$P(TMP ,", ",1)_" ,"_$P(TMP, ", ",2)  ;
  16790   "RTN","RCT CSP1",61,0 )
  16791    ..I EXCEL  W U_TMP
  16792   "RTN","RCT CSP1",62,0 )
  16793    ..;check  for end of  page here , if neces sary form  feed and p rint heade r
  16794   "RTN","RCT CSP1",63,0 )
  16795    ..I ($Y+3 )>IOSL D
  16796   "RTN","RCT CSP1",64,0 )
  16797    ...I $E(I OST,1,2)=" C-" S DIR( 0)="E" K D IRUT D ^DI R Q:$D(DIR UT)
  16798   "RTN","RCT CSP1",65,0 )
  16799    ...D BILL REPH
  16800   "RTN","RCT CSP1",66,0 )
  16801    I $E(IOST ,1,2)="C-"  R !!,"END  OF REPORT ...PRESS R ETURN TO C ONTINUE",X :DTIME W @ IOF
  16802   "RTN","RCT CSP1",67,0 )
  16803    D:'$D(ZTQ UEUED) ^%Z ISC
  16804   "RTN","RCT CSP1",68,0 )
  16805    S:$D(ZTQU EUED) ZTRE Q="@"
  16806   "RTN","RCT CSP1",69,0 )
  16807    K ^TMP("R CTCSP1",$J )
  16808   "RTN","RCT CSP1",70,0 )
  16809    K IOP,%ZI S,ZTQUEUED
  16810   "RTN","RCT CSP1",71,0 )
  16811   BILLREPQ Q
  16812   "RTN","RCT CSP1",72,0 )
  16813    ;
  16814   "RTN","RCT CSP1",73,0 )
  16815   BILLREPH ; header for  cross-ser vicing bil l report
  16816   "RTN","RCT CSP1",74,0 )
  16817    W @IOF
  16818   "RTN","RCT CSP1",75,0 )
  16819    S PAGE=PA GE+1
  16820   "RTN","RCT CSP1",76,0 )
  16821    I 'EXCEL  W "PAGE "_ PAGE,?24," CROSS-SERV ICING BILL  REPORT",? 60,$$FMTE^ XLFDT(DT," 2Z"),!,DAS H
  16822   "RTN","RCT CSP1",77,0 )
  16823    I EXCEL W  "PAGE "_P AGE_U_"CRO SS-SERVICI NG BILL RE PORT"_U_U_ $$FMTE^XLF DT(DT,"2Z" )
  16824   "RTN","RCT CSP1",78,0 )
  16825    N RCHDR,R CSSN
  16826   "RTN","RCT CSP1",79,0 )
  16827    S RCHDR=$ $ACCNTHDR^ RCDPAPLM(D EBTOR),RCS SN=$S($P(R CHDR,U,2)[ "P":$E($P( RCHDR,U,2) ,7,11),1:$ E($P(RCHDR ,U,2),6,9) )  ;Pseudo  SSN shoul dn't be al lowed but  we allowed  for it to  print
  16828   "RTN","RCT CSP1",80,0 )
  16829    I 'EXCEL  D  Q 
  16830   "RTN","RCT CSP1",81,0 )
  16831    . W !!,"D EBTOR: ",$ E($P(RCHDR ,U,1),1,18 ),?22,"SSN : ",RCSSN, ?45,"CURRE NT CS DEBT : ",$J(TAM T,8,2),!,D ASH
  16832   "RTN","RCT CSP1",82,0 )
  16833    . W !,"BI LL NO.",?1 2,"ST",?15 ,"ORIG AMT ",?25,"CUR R AMT",?38 ,"PRIN",?4 6,"INT",?5 2,"ADMIN", ?60,"COURT ",?67,"CS  REF DT" ;( as per PRC A*4.5*315)
  16834   "RTN","RCT CSP1",83,0 )
  16835    . W !,"-- -- ---",?1 2,"--",?15 ,"---- --- ",?25,"--- - ---",?38 ,"----",?4 6,"---",?5 2,"-----", ?60,"----- ",?67,"--  -------"
  16836   "RTN","RCT CSP1",84,0 )
  16837    W !,"DEBT OR: "_$E($ P(RCHDR,U, 1),1,18)_U _U_"SSN: " _RCSSN_U_U _U_"CURREN T CS DEBT:  "_$J(TAMT ,8,2)
  16838   "RTN","RCT CSP1",85,0 )
  16839    W !,"BILL  NO."_U_"S T"_U_"ORIG  AMT"_U_"C URR AMT"_U _"PRIN"_U_ "INT"_U_"A DMIN"_U_"C OURT"_U_"C S REF DATE "
  16840   "RTN","RCT CSP1",86,0 )
  16841    Q
  16842   "RTN","RCT CSP1",87,0 )
  16843    ;
  16844   "RTN","RCT CSP1",88,0 )
  16845   CSRPRT ;Pr int Cross- Servicing  Report, pr ints sorte d individu al bills t hat make u p a cross- servicing  account
  16846   "RTN","RCT CSP1",89,0 )
  16847    ;
  16848   "RTN","RCT CSP1",90,0 )
  16849    K ^TMP("R CTCSP1",$J )
  16850   "RTN","RCT CSP1",91,0 )
  16851    N DIC,RCS ORT,PAGE,D ASH,DTOUT, DUOUT,DIRO UT,RCIEN,R CDEBTOR,RC REFDT,RCSS N,RCORIG,R CCAMT,RCRE FDT,RCBILL ,ITEM,DBTR ,SDT,SSN,N CIEN,TERMD IG
  16852   "RTN","RCT CSP1",92,0 )
  16853    S PAGE=0, DASH="",$P (DASH,"-", 81)=""
  16854   "RTN","RCT CSP1",93,0 )
  16855    W !
  16856   "RTN","RCT CSP1",94,0 )
  16857    S DIR(0)= "S^1:Bill  Number;2:D ebtor Name ;3:CS Refe rred Date" ,DIR("A")= "Sort by"  D ^DIR K D IR
  16858   "RTN","RCT CSP1",95,0 )
  16859    S RCSORT= Y Q:($D(DT OUT)!$D(DU OUT)!$D(DI ROUT))
  16860   "RTN","RCT CSP1",96,0 )
  16861    ; The fol lowing sec tions were  rewritten  to elimin ate using  ^DIP - (as  per PRCA* 4.5*315 re format dat es and SSN )
  16862   "RTN","RCT CSP1",97,0 )
  16863    S DTFRMTO =$$DTFRMTO ^RCTCSP2 Q :'DTFRMTO   ;Get date  range as  per PRCA*4 .5*315
  16864   "RTN","RCT CSP1",98,0 )
  16865    S (DATE,D TFRM)=$$FM ADD^XLFDT( +$P(DTFRMT O,U,2)),DT TO=$P(DTFR MTO,U,3),C URDT=0
  16866   "RTN","RCT CSP1",99,0 )
  16867    S EXCEL=0 ,PROMPT="C APTURE Rep ort data t o an Excel  Document" ,DIR(0)="Y ",DIR("?") ="^D HEXC^ RCTCSJR"
  16868   "RTN","RCT CSP1",100, 0)
  16869    S EXCEL=$ $SELECT^RC TCSJR(PROM PT,"NO") I  "01"'[EXC EL S STOP= 1 Q
  16870   "RTN","RCT CSP1",101, 0)
  16871    I EXCEL=1  D EXCMSG^ RCTCSJR ;  Display Ex cel displa y message
  16872   "RTN","RCT CSP1",102, 0)
  16873    K IOP,IO( "Q") S %ZI S="MQ",%ZI S("B")=""  D ^%ZIS G: POP CSRPRT R S IOP=IO N_";"_IOM_ ";"_IOSL
  16874   "RTN","RCT CSP1",103, 0)
  16875    I $D(IO(" Q")) D  G  BILLREPQ
  16876   "RTN","RCT CSP1",104, 0)
  16877    .S ZTSAVE ("RCSORT") ="",ZTSAVE ("DTFRMTO" )="",ZTSAV E("EXCEL") ="",ZTSAVE ("PROMPT") =""
  16878   "RTN","RCT CSP1",105, 0)
  16879    .S ZTRTN= "CSRPRTR^R CTCSP1",ZT DESC="PRIN T CROSS-SE RVICING RE PORT"
  16880   "RTN","RCT CSP1",106, 0)
  16881    .D ^%ZTLO AD,HOME^%Z IS
  16882   "RTN","RCT CSP1",107, 0)
  16883    .I $G(ZTS K) W !!,"R eport comp ilation ha s started  with task#  ",ZTSK,". ",! S DIR( 0)="E" D ^ DIR K DIR
  16884   "RTN","RCT CSP1",108, 0)
  16885    .Q
  16886   "RTN","RCT CSP1",109, 0)
  16887   CSRPRTR ; 
  16888   "RTN","RCT CSP1",110, 0)
  16889    I RCSORT= 1 D
  16890   "RTN","RCT CSP1",111, 0)
  16891    . D CSRPR TH1^RCTCSP 1A
  16892   "RTN","RCT CSP1",112, 0)
  16893    . S (DATE ,DTFRM)=$$ FMADD^XLFD T(+$P(DTFR MTO,U,2)), DTTO=$P(DT FRMTO,U,3) ,CURDT=0
  16894   "RTN","RCT CSP1",113, 0)
  16895    . S RCIEN ="" F  S R CIEN=$O(^P RCA(430,"T CSP",RCIEN )) Q:RCIEN =""  D
  16896   "RTN","RCT CSP1",114, 0)
  16897    .. Q:'$D( ^PRCA(430, RCIEN,15))    ;cross  servicing  data field s
  16898   "RTN","RCT CSP1",115, 0)
  16899    ..Q:$P($G (^PRCA(430 ,RCIEN,15) ),U)<DTFRM !($P($G(^P RCA(430,RC IEN,15)),U )>DTTO)
  16900   "RTN","RCT CSP1",116, 0)
  16901    ..K LIST, MSG,RCLIST  D GETS^DI Q(430,RCIE N_",",".01 ;9;121,141 ,161;169;1 51;11","IE ","LIST"," MSG") S RC LIST=$NA(L IST(430,RC IEN_","))
  16902   "RTN","RCT CSP1",117, 0)
  16903    ..;Q:$G(@ RCLIST@(14 1,"E"))'=" "   ;Date  sent to TO P
  16904   "RTN","RCT CSP1",118, 0)
  16905    ..S SSN=$ E($$SSN^RC FN01(@RCLI ST@(9,"I") ),6,9) S S SN=$S(SSN' ="":SSN,1: "     "),T ERMDIG=$E( @RCLIST@(9 ,"E"),1)_S SN
  16906   "RTN","RCT CSP1",119, 0)
  16907    ..I EXCEL  D  Q 
  16908   "RTN","RCT CSP1",120, 0)
  16909    ...S ^TMP ("RCTCSP1" ,$J,RCIEN, @RCLIST@(. 01,"E"))=@ RCLIST@(.0 1,"E")_U_$ E(@RCLIST@ (9,"E"),1, 19)_U_TERM DIG_U_$J(@ RCLIST@(16 9,"E"),8,2 )_U_$$FMTE ^XLFDT(@RC LIST@(151, "I"),"2Z")
  16910   "RTN","RCT CSP1",121, 0)
  16911    ...S ^TMP ("RCTCSP1" ,$J,RCIEN, @RCLIST@(. 01,"E"))=^ TMP("RCTCS P1",$J,RCI EN,@RCLIST @(.01,"E") )_U_$J(@RC LIST@(11," E"),8,2)
  16912   "RTN","RCT CSP1",122, 0)
  16913    ...Q
  16914   "RTN","RCT CSP1",123, 0)
  16915    ..S ^TMP( "RCTCSP1", $J,RCIEN,@ RCLIST@(.0 1,"E"))=@R CLIST@(.01 ,"E")_U_$E (@RCLIST@( 9,"E"),1,1 9)_U_SSN_U _$J(@RCLIS T@(169,"E" ),8,2)_U_$ $FMTE^XLFD T(@RCLIST@ (151,"I"), "2Z")
  16916   "RTN","RCT CSP1",124, 0)
  16917    ..S ^TMP( "RCTCSP1", $J,RCIEN,@ RCLIST@(.0 1,"E"))=^T MP("RCTCSP 1",$J,RCIE N,@RCLIST@ (.01,"E")) _U_$J(@RCL IST@(11,"E "),8,2)
  16918   "RTN","RCT CSP1",125, 0)
  16919    .S (NCIEN ,ITEM)=""  F  S NCIEN =$O(^TMP(" RCTCSP1",$ J,NCIEN))  Q:NCIEN=""   F  S ITE M=$O(^TMP( "RCTCSP1", $J,NCIEN,I TEM)) Q:IT EM=""  D
  16920   "RTN","RCT CSP1",126, 0)
  16921    ..I 'EXCE L W !,$P(^ TMP("RCTCS P1",$J,NCI EN,ITEM),U ),?14,$P(^ TMP("RCTCS P1",$J,NCI EN,ITEM),U ,2),?35,$P (^TMP("RCT CSP1",$J,N CIEN,ITEM) ,U,3),?43
  16922   "RTN","RCT CSP1",127, 0)
  16923    ..I 'EXCE L W $P(^TM P("RCTCSP1 ",$J,NCIEN ,ITEM),U,4 ),?58,$P(^ TMP("RCTCS P1",$J,NCI EN,ITEM),U ,5),?68,$P (^TMP("RCT CSP1",$J,N CIEN,ITEM) ,U,6) Q
  16924   "RTN","RCT CSP1",128, 0)
  16925    ..I EXCEL  W !,$P(^T MP("RCTCSP 1",$J,NCIE N,ITEM),U) _U_$P(^TMP ("RCTCSP1" ,$J,NCIEN, ITEM),U,2) _U_$P(^TMP ("RCTCSP1" ,$J,NCIEN, ITEM),U,3)
  16926   "RTN","RCT CSP1",129, 0)
  16927    ..I EXCEL  W U_$P(^T MP("RCTCSP 1",$J,NCIE N,ITEM),U, 4)_U_$P(^T MP("RCTCSP 1",$J,NCIE N,ITEM),U, 5)_U_$P(^T MP("RCTCSP 1",$J,NCIE N,ITEM),U, 6)
  16928   "RTN","RCT CSP1",130, 0)
  16929    .Q
  16930   "RTN","RCT CSP1",131, 0)
  16931    ;
  16932   "RTN","RCT CSP1",132, 0)
  16933    I RCSORT= 2 D
  16934   "RTN","RCT CSP1",133, 0)
  16935    . D CSRPR TH2^RCTCSP 1A
  16936   "RTN","RCT CSP1",134, 0)
  16937    . S (DATE ,DTFRM)=$$ FMADD^XLFD T(+$P(DTFR MTO,U,2),- 1),DTTO=$P (DTFRMTO,U ,3),CURDT= 0
  16938   "RTN","RCT CSP1",135, 0)
  16939    . S RCIEN ="" F  S R CIEN=$O(^P RCA(430,"T CSP",RCIEN )) Q:RCIEN =""  D
  16940   "RTN","RCT CSP1",136, 0)
  16941    ..Q:'$D(^ PRCA(430,R CIEN,15))    ;cross s ervicing d ata fields
  16942   "RTN","RCT CSP1",137, 0)
  16943    ..Q:$P($G (^PRCA(430 ,RCIEN,15) ),U)<DTFRM !($P($G(^P RCA(430,RC IEN,15)),U )>DTTO)
  16944   "RTN","RCT CSP1",138, 0)
  16945    ..K LIST, MSG,RCLIST  D GETS^DI Q(430,RCIE N_",",".01 ;9;121,141 ,161;169;1 51;11","IE ","LIST"," MSG") S RC LIST=$NA(L IST(430,RC IEN_","))
  16946   "RTN","RCT CSP1",139, 0)
  16947    ..;Q:$G(@ RCLIST@(12 1,"E"))'=" "   ;Date  sent to DM C
  16948   "RTN","RCT CSP1",140, 0)
  16949    ..;Q:$G(@ RCLIST@(14 1,"E"))'=" "   ;Date  sent to TO P
  16950   "RTN","RCT CSP1",141, 0)
  16951    ..S SSN=$ E($$SSN^RC FN01(@RCLI ST@(9,"I") ),6,9) S S SN=$S(SSN' ="":SSN,1: "     "),T ERMDIG=$E( @RCLIST@(9 ,"E"),1)_S SN
  16952   "RTN","RCT CSP1",142, 0)
  16953    ..I EXCEL  D  Q
  16954   "RTN","RCT CSP1",143, 0)
  16955    ...S ^TMP ("RCTCSP1" ,$J,@RCLIS T@(9,"E"), RCIEN)=$E( @RCLIST@(9 ,"E"),1,19 )_U_@RCLIS T@(.01,"E" )_U_TERMDI G_U_$J(@RC LIST@(169, "E"),8,2)_ U_$$FMTE^X LFDT(@RCLI ST@(151,"I "),"2Z")_U _$J(@RCLIS T@(11,"E") ,8,2) Q
  16956   "RTN","RCT CSP1",144, 0)
  16957    ..S ^TMP( "RCTCSP1", $J,@RCLIST @(9,"E"),R CIEN)=$E(@ RCLIST@(9, "E"),1,19) _U_@RCLIST @(.01,"E") _U_SSN_U_$ J(@RCLIST@ (169,"E"), 8,2)_U_$$F MTE^XLFDT( @RCLIST@(1 51,"I"),"2 Z")_U_$J(@ RCLIST@(11 ,"E"),8,2)
  16958   "RTN","RCT CSP1",145, 0)
  16959    .S (DBTR, NCIEN)=""  F  S DBTR= $O(^TMP("R CTCSP1",$J ,DBTR)) Q: DBTR=""  F   S NCIEN= $O(^TMP("R CTCSP1",$J ,DBTR,NCIE N)) Q:NCIE N=""  D
  16960   "RTN","RCT CSP1",146, 0)
  16961    ..I 'EXCE L W !,$P(^ TMP("RCTCS P1",$J,DBT R,NCIEN),U ),?21,$P(^ TMP("RCTCS P1",$J,DBT R,NCIEN),U ,2),?35,$P (^TMP("RCT CSP1",$J,D BTR,NCIEN) ,U,3),?43, $P(^TMP("R CTCSP1",$J ,DBTR,NCIE N),U,4)
  16962   "RTN","RCT CSP1",147, 0)
  16963    ..I 'EXCE L W ?58,$P (^TMP("RCT CSP1",$J,D BTR,NCIEN) ,U,5),?68, $P(^TMP("R CTCSP1",$J ,DBTR,NCIE N),U,6) Q
  16964   "RTN","RCT CSP1",148, 0)
  16965    ..I EXCEL  W !,$P(^T MP("RCTCSP 1",$J,DBTR ,NCIEN),U, 1,4)_U_$P( ^TMP("RCTC SP1",$J,DB TR,NCIEN), U,5)_U_$P( ^TMP("RCTC SP1",$J,DB TR,NCIEN), U,6) Q
  16966   "RTN","RCT CSP1",149, 0)
  16967    .Q
  16968   "RTN","RCT CSP1",150, 0)
  16969    ;
  16970   "RTN","RCT CSP1",151, 0)
  16971    I RCSORT= 3 D
  16972   "RTN","RCT CSP1",152, 0)
  16973    .D CSRPRT H3^RCTCSP1 A
  16974   "RTN","RCT CSP1",153, 0)
  16975    .S (DATE, DTFRM)=$$F MADD^XLFDT (+$P(DTFRM TO,U,2),-1 ),DTTO=$P( DTFRMTO,U, 3),CURDT=0
  16976   "RTN","RCT CSP1",154, 0)
  16977    .S RCIEN= "" F  S RC IEN=$O(^PR CA(430,"TC SP",RCIEN) ) Q:RCIEN= ""  D
  16978   "RTN","RCT CSP1",155, 0)
  16979    ..Q:'$D(^ PRCA(430,R CIEN,15))    ;cross s ervicing d ata fields
  16980   "RTN","RCT CSP1",156, 0)
  16981    ..Q:$P(^P RCA(430,RC IEN,15),U) <DTFRM!($P (^PRCA(430 ,RCIEN,15) ,U)>DTTO)
  16982   "RTN","RCT CSP1",157, 0)
  16983    ..K LIST, MSG,RCLIST  D GETS^DI Q(430,RCIE N_",",".01 ;9;121,141 ,161;169;1 51;11","IE ","LIST"," MSG") S RC LIST=$NA(L IST(430,RC IEN_","))
  16984   "RTN","RCT CSP1",158, 0)
  16985    ..;Q:$G(@ RCLIST@(12 1,"E"))'=" "   ;Date  sent to DM C
  16986   "RTN","RCT CSP1",159, 0)
  16987    ..;Q:$G(@ RCLIST@(14 1,"E"))'=" "   ;Date  sent to TO P
  16988   "RTN","RCT CSP1",160, 0)
  16989    ..S SSN=$ E($$SSN^RC FN01(@RCLI ST@(9,"I") ),6,9) S S SN=$S(SSN' ="":SSN,1: "     "),T ERMDIG=$E( @RCLIST@(9 ,"E"),1)_S SN
  16990   "RTN","RCT CSP1",161, 0)
  16991    ..I EXCEL  S ^TMP("R CTCSP1",$J ,@RCLIST@( 151,"I"),R CIEN)=$$FM TE^XLFDT(@ RCLIST@(15 1,"I"),"2Z ")_U_$E(@R CLIST@(9," E"),1,19)_ U_@RCLIST@ (.01,"E")_ U_TERMDIG_ U_$J(@RCLI ST@(169,"E "),8,2)_U_ $J(@RCLIST @(11,"E"), 8,2)
  16992   "RTN","RCT CSP1",162, 0)
  16993    ..I 'EXCE L S ^TMP(" RCTCSP1",$ J,@RCLIST@ (151,"I"), RCIEN)=$$F MTE^XLFDT( @RCLIST@(1 51,"I"),"2 Z")_U_$E(@ RCLIST@(9, "E"),1,19) _U_@RCLIST @(.01,"E") _U_SSN_U_$ J(@RCLIST@ (169,"E"), 8,2)_U_$J( @RCLIST@(1 1,"E"),8,2 )
  16994   "RTN","RCT CSP1",163, 0)
  16995    .S (SDT,N CIEN)="" F   S SDT=$O (^TMP("RCT CSP1",$J,S DT)) Q:SDT =""   F  S  NCIEN=$O( ^TMP("RCTC SP1",$J,SD T,NCIEN))  Q:NCIEN=""   D
  16996   "RTN","RCT CSP1",164, 0)
  16997    ..I 'EXCE L W !,$P(^ TMP("RCTCS P1",$J,SDT ,NCIEN),U) ,?12,$P(^T MP("RCTCSP 1",$J,SDT, NCIEN),U,2 ),?34,$P(^ TMP("RCTCS P1",$J,SDT ,NCIEN),U, 3),?49
  16998   "RTN","RCT CSP1",165, 0)
  16999    ..I 'EXCE L W $P(^TM P("RCTCSP1 ",$J,SDT,N CIEN),U,4) ,?58,$P(^T MP("RCTCSP 1",$J,SDT, NCIEN),U,5 ),?68,$P(^ TMP("RCTCS P1",$J,SDT ,NCIEN),U, 6) Q
  17000   "RTN","RCT CSP1",166, 0)
  17001    ..I EXCEL  W !,$P(^T MP("RCTCSP 1",$J,SDT, NCIEN),U)_ U_$P(^TMP( "RCTCSP1", $J,SDT,NCI EN),U,2)_U _$P(^TMP(" RCTCSP1",$ J,SDT,NCIE N),U,3)_U_ $P(^TMP("R CTCSP1",$J ,SDT,NCIEN ),U,4)
  17002   "RTN","RCT CSP1",167, 0)
  17003    ..I EXCEL  W U_$P(^T MP("RCTCSP 1",$J,SDT, NCIEN),U,5 )_U_$P(^TM P("RCTCSP1 ",$J,SDT,N CIEN),U,6)  Q
  17004   "RTN","RCT CSP1",168, 0)
  17005    .Q
  17006   "RTN","RCT CSP1",169, 0)
  17007    ;end of r eport
  17008   "RTN","RCT CSP1",170, 0)
  17009    I $E(IOST ,1,2)="C-"  R !!,"END  OF REPORT ...PRESS R ETURN TO C ONTINUE",X :DTIME W @ IOF
  17010   "RTN","RCT CSP1",171, 0)
  17011    K ^TMP("R CTCSP1",$J )
  17012   "RTN","RCT CSP1",172, 0)
  17013    Q
  17014   "RTN","RCT CSP1",173, 0)
  17015    ;
  17016   "RTN","RCT CSP1",174, 0)
  17017   HEADER ;
  17018   "RTN","RCT CSP1",175, 0)
  17019    ;incremen t batch se quence num ber, build  new heade r
  17020   "RTN","RCT CSP1",176, 0)
  17021    N RCMSG
  17022   "RTN","RCT CSP1",177, 0)
  17023    S SEQ=SEQ +1
  17024   "RTN","RCT CSP1",178, 0)
  17025    S CNTLID= $$JD()_$$R JZF(SEQ,4)
  17026   "RTN","RCT CSP1",179, 0)
  17027    K ^XTMP(" RCTCSPD",$ J,ACTION," BUILD",SEQ )
  17028   "RTN","RCT CSP1",180, 0)
  17029    ;header i s record t ype H
  17030   "RTN","RCT CSP1",181, 0)
  17031    S RCMSG=" H"_CNTLID_ $$BLANK(14 )_"3636001 200"
  17032   "RTN","RCT CSP1",182, 0)
  17033    S RCMSG=R CMSG_$$BLA NK(450-$L( RCMSG))
  17034   "RTN","RCT CSP1",183, 0)
  17035    S REC=REC +1
  17036   "RTN","RCT CSP1",184, 0)
  17037    S ^XTMP(" RCTCSPD",$ J,SEQ,"BUI LD",REC)=$ E(RCMSG,1, 225)_$C(94 )
  17038   "RTN","RCT CSP1",185, 0)
  17039    S REC=REC +1
  17040   "RTN","RCT CSP1",186, 0)
  17041    S ^XTMP(" RCTCSPD",$ J,SEQ,"BUI LD",REC)=$ E(RCMSG,22 6,999)_$C( 126)
  17042   "RTN","RCT CSP1",187, 0)
  17043    Q
  17044   "RTN","RCT CSP1",188, 0)
  17045    ;
  17046   "RTN","RCT CSP1",189, 0)
  17047   TRAILER ;
  17048   "RTN","RCT CSP1",190, 0)
  17049    ;trailer  is type Z  record
  17050   "RTN","RCT CSP1",191, 0)
  17051    I REC=0 K  ^XTMP("RC TCSPD",$J, SEQ,"BUILD ") Q  ;del ete batch  if no reco rds proces sed
  17052   "RTN","RCT CSP1",192, 0)
  17053    N RCMSG
  17054   "RTN","RCT CSP1",193, 0)
  17055    S CNTLID= $$JD()_$$R JZF(SEQ,4)
  17056   "RTN","RCT CSP1",194, 0)
  17057    S RCMSG=" Z"_$$RJZF( RECC,8)_$$ AMOUNT(AMO UNT/100,0) _CNTLID_$$ BLANK(14)_ "363600120 0"
  17058   "RTN","RCT CSP1",195, 0)
  17059    S RCMSG=R CMSG_$$BLA NK(450-$L( RCMSG))
  17060   "RTN","RCT CSP1",196, 0)
  17061    S REC=REC +1
  17062   "RTN","RCT CSP1",197, 0)
  17063    S ^XTMP(" RCTCSPD",$ J,SEQ,"BUI LD",REC)=$ E(RCMSG,1, 225)_$C(94 )
  17064   "RTN","RCT CSP1",198, 0)
  17065    S REC=REC +1
  17066   "RTN","RCT CSP1",199, 0)
  17067    S ^XTMP(" RCTCSPD",$ J,SEQ,"BUI LD",REC)=$ E(RCMSG,22 6,999)_$C( 126)
  17068   "RTN","RCT CSP1",200, 0)
  17069    S REC=0,R ECC=0,AMOU NT=0
  17070   "RTN","RCT CSP1",201, 0)
  17071    Q
  17072   "RTN","RCT CSP1",202, 0)
  17073    ;
  17074   "RTN","RCT CSP1",203, 0)
  17075   REC5B ;Cre ate record  5B for Tr easury
  17076   "RTN","RCT CSP1",204, 0)
  17077    ;  trnnum      trans action num ber file # 433 pass i n
  17078   "RTN","RCT CSP1",205, 0)
  17079    ;  trntyp      trans action typ e pointer  to 430.3
  17080   "RTN","RCT CSP1",206, 0)
  17081    ;  trntyp a    aia t ransaction  type  (ai o: dmc age ncy intern al offset,  abal: dec rease adju stment) 
  17082   "RTN","RCT CSP1",207, 0)
  17083    N REC,KNU M,DEBTNR,D EBTORNB,TA MOUNT,TAMT PBAL,TAMTI BAL,TAMTAB AL,TAMTFBA L,TAMTCBAL ,AMTRFRRD, TRNTYP,TRN TYPA,TRANS NB
  17084   "RTN","RCT CSP1",208, 0)
  17085    N AMTPBAL ,AMTIBAL,A MTABAL,AMT FBAL,AMTCB AL,TRN3,TR NNUME
  17086   "RTN","RCT CSP1",209, 0)
  17087    S TRNTYPA ="AIO"
  17088   "RTN","RCT CSP1",210, 0)
  17089    S REC="C5 B"_ACTION_ "363600120 0"_"DM1D " _"L"
  17090   "RTN","RCT CSP1",211, 0)
  17091    S KNUM=$P ($P(B0,U,1 ),"-",2)
  17092   "RTN","RCT CSP1",212, 0)
  17093    S DEBTNR= $E(SITE,1, 3)_$$RJZF( KNUM,7)_$T R($J(BILL, 20)," ",0) ,REC=REC_D EBTNR
  17094   "RTN","RCT CSP1",213, 0)
  17095    S DEBTORN B=$E(SITE, 1,3)_$TR($ J(DEBTOR,1 2)," ",0)
  17096   "RTN","RCT CSP1",214, 0)
  17097    S REC=REC _DEBTORNB
  17098   "RTN","RCT CSP1",215, 0)
  17099    S TRNTYP= $P($G(^PRC A(433,TRNN UM,1)),U,2 ) I ",35,7 3,74,"[TRN TYP S TRNT YPA="ABAL"
  17100   "RTN","RCT CSP1",216, 0)
  17101    S REC=REC _$$LJSF(TR NTYPA,9)
  17102   "RTN","RCT CSP1",217, 0)
  17103    S TRNNUME =$$RJZF(TR NNUM,10)
  17104   "RTN","RCT CSP1",218, 0)
  17105    S TRNNUME =$E(TRNNUM E,5,10) ;m ax is 9999 99
  17106   "RTN","RCT CSP1",219, 0)
  17107    I TRNNUME ="000000"  S TRNNUME= "000001" ; min is 1
  17108   "RTN","RCT CSP1",220, 0)
  17109    S REC=REC _$$RJZF(TR NNUME,10)
  17110   "RTN","RCT CSP1",221, 0)
  17111    S REC=REC _$$DATE8(D T)
  17112   "RTN","RCT CSP1",222, 0)
  17113    S TRANSNB =$E(SITE,1 ,3)_$TR($J (TRNNUM,12 )," ",0)
  17114   "RTN","RCT CSP1",223, 0)
  17115    S REC=REC _TRANSNB
  17116   "RTN","RCT CSP1",224, 0)
  17117    S REC=REC _$$BLANK(9 )
  17118   "RTN","RCT CSP1",225, 0)
  17119    S TRN3=$G (^PRCA(433 ,TRNNUM,3) )
  17120   "RTN","RCT CSP1",226, 0)
  17121    S TAMTPBA L=$P(TRN3, U,1) ;tran saction pr inciple ba lance
  17122   "RTN","RCT CSP1",227, 0)
  17123    S TAMTIBA L=$P(TRN3, U,2) ;tran saction in terest bal ance
  17124   "RTN","RCT CSP1",228, 0)
  17125    S TAMTABA L=$P(TRN3, U,3) ;tran saction ad ministrati ve balance
  17126   "RTN","RCT CSP1",229, 0)
  17127    S TAMTFBA L=$P(TRN3, U,4) ;tran saction ma rshal fee
  17128   "RTN","RCT CSP1",230, 0)
  17129    S TAMTCBA L=$P(TRN3, U,5) ;tran saction co urt cost
  17130   "RTN","RCT CSP1",231, 0)
  17131    I (TAMTPB AL+TAMTIBA L+TAMTABAL +TAMTFBAL+ TAMTCBAL)= 0 S TAMTPB AL=TRNAMT
  17132   "RTN","RCT CSP1",232, 0)
  17133    S TAMOUNT =$$AMOUNT( TAMTPBAL,T RNTYP)
  17134   "RTN","RCT CSP1",233, 0)
  17135    S TAMOUNT =TAMOUNT_$ $AMOUNT(TA MTIBAL,TRN TYP)
  17136   "RTN","RCT CSP1",234, 0)
  17137    S TAMOUNT =TAMOUNT_$ $AMOUNT(TA MTABAL,TRN TYP)
  17138   "RTN","RCT CSP1",235, 0)
  17139    S TAMOUNT =TAMOUNT_$ $AMOUNT(TA MTFBAL+TAM TCBAL,TRNT YP)
  17140   "RTN","RCT CSP1",236, 0)
  17141    S REC=REC _TAMOUNT
  17142   "RTN","RCT CSP1",237, 0)
  17143    S REC=REC _$$AMOUNT( TRNAMT,TRN TYP) ;315/ DRF Make m inus sign  conditiona l on trans action
  17144   "RTN","RCT CSP1",238, 0)
  17145    S REC=REC _$$BLANK(4 50-$L(REC) )
  17146   "RTN","RCT CSP1",239, 0)
  17147    S AMTPBAL =$P(B7,U,1 ) ;princip le balance
  17148   "RTN","RCT CSP1",240, 0)
  17149    S AMTIBAL =$P(B7,U,2 ) ;interes t balance
  17150   "RTN","RCT CSP1",241, 0)
  17151    S AMTABAL =$P(B7,U,3 ) ;adminis trative ba lance
  17152   "RTN","RCT CSP1",242, 0)
  17153    S AMTFBAL =$P(B7,U,4 ) ;marshal  fee
  17154   "RTN","RCT CSP1",243, 0)
  17155    S AMTCBAL =$P(B7,U,5 ) ;court c ost
  17156   "RTN","RCT CSP1",244, 0)
  17157    S AMTRFRR D=AMTPBAL+ AMTIBAL+AM TABAL+AMTF BAL+AMTCBA L
  17158   "RTN","RCT CSP1",245, 0)
  17159    I ACTION= "U" S $P(^ PRCA(430,B ILL,16),U, 10)=AMTRFR RD
  17160   "RTN","RCT CSP1",246, 0)
  17161    S ^XTMP(" RCTCSPD",$ J,BILL,ACT ION,"5B",T RNNUM)=REC
  17162   "RTN","RCT CSP1",247, 0)
  17163    S ^XTMP(" RCTCSPD",$ J,"BILL",A CTION,BILL )=$$TAXID( DEBTOR)_"^ "_$S(TRNTY P=35:"-",1 :"")_+$E(R EC,174,184 )_"."_$E(R EC,185,186 )
  17164   "RTN","RCT CSP1",248, 0)
  17165    Q
  17166   "RTN","RCT CSP1",249, 0)
  17167    ;
  17168   "RTN","RCT CSP1",250, 0)
  17169   DATE8(X) ; changes fi leman date  into 8 di git date y yyymmdd
  17170   "RTN","RCT CSP1",251, 0)
  17171    I +X S X= X+17000000
  17172   "RTN","RCT CSP1",252, 0)
  17173    S X=$E(X, 1,8)
  17174   "RTN","RCT CSP1",253, 0)
  17175    Q X
  17176   "RTN","RCT CSP1",254, 0)
  17177    ;
  17178   "RTN","RCT CSP1",255, 0)
  17179   AMOUNT(X,T T) ;change s amount t o zero fil led, right  justified
  17180   "RTN","RCT CSP1",256, 0)
  17181    N SIGN
  17182   "RTN","RCT CSP1",257, 0)
  17183    S X=$$SIG N(X,TT)
  17184   "RTN","RCT CSP1",258, 0)
  17185    S SIGN=$S (X<0:-1,1: 1)
  17186   "RTN","RCT CSP1",259, 0)
  17187    I X<0 S X =-X
  17188   "RTN","RCT CSP1",260, 0)
  17189    S X=$TR($ J(X,0,2)," .")
  17190   "RTN","RCT CSP1",261, 0)
  17191    S X=$E($S (SIGN<0:"- ",1:0)_"00 000000000" ,1,14-$L(X ))_X
  17192   "RTN","RCT CSP1",262, 0)
  17193    Q X
  17194   "RTN","RCT CSP1",263, 0)
  17195    ;
  17196   "RTN","RCT CSP1",264, 0)
  17197   SIGN(X,TT)  ;Sets sig n based on  value and  transacti on type
  17198   "RTN","RCT CSP1",265, 0)
  17199    I X=0 Q 0
  17200   "RTN","RCT CSP1",266, 0)
  17201    I X,TT=35  S X=-X
  17202   "RTN","RCT CSP1",267, 0)
  17203    Q X
  17204   "RTN","RCT CSP1",268, 0)
  17205    ;
  17206   "RTN","RCT CSP1",269, 0)
  17207   BLANK(X) ; returns 'x ' blank sp aces
  17208   "RTN","RCT CSP1",270, 0)
  17209    N BLANK
  17210   "RTN","RCT CSP1",271, 0)
  17211    S BLANK=" ",$P(BLANK ," ",X+1)= ""
  17212   "RTN","RCT CSP1",272, 0)
  17213    Q BLANK
  17214   "RTN","RCT CSP1",273, 0)
  17215    ;
  17216   "RTN","RCT CSP1",274, 0)
  17217   RJZF(X,Y)  ;right jus tify zero  fill width  Y
  17218   "RTN","RCT CSP1",275, 0)
  17219    S X=$E("0 0000000000 0",1,Y-$L( X))_X
  17220   "RTN","RCT CSP1",276, 0)
  17221    Q X
  17222   "RTN","RCT CSP1",277, 0)
  17223    ;
  17224   "RTN","RCT CSP1",278, 0)
  17225   LJSF(X,Y)  ;left just ified spac e filled
  17226   "RTN","RCT CSP1",279, 0)
  17227    S X=$E(X, 1,Y)
  17228   "RTN","RCT CSP1",280, 0)
  17229    S X=X_$$B LANK(Y-$L( X))
  17230   "RTN","RCT CSP1",281, 0)
  17231    Q X
  17232   "RTN","RCT CSP1",282, 0)
  17233    ;
  17234   "RTN","RCT CSP1",283, 0)
  17235   TAXID(DEBT OR) ;compu tes TAXID  to place o n document s
  17236   "RTN","RCT CSP1",284, 0)
  17237    N TAXID,D IC,DA,DR,D IQ
  17238   "RTN","RCT CSP1",285, 0)
  17239    S TAXID=$ $SSN^RCFN0 1(DEBTOR)
  17240   "RTN","RCT CSP1",286, 0)
  17241    S TAXID=$ $LJSF(TAXI D,9)
  17242   "RTN","RCT CSP1",287, 0)
  17243    Q TAXID
  17244   "RTN","RCT CSP1",288, 0)
  17245    ;
  17246   "RTN","RCT CSP1",289, 0)
  17247   JD() ; ret urns today 's Julian  date YDOY
  17248   "RTN","RCT CSP1",290, 0)
  17249    N XMDDD,X MNOW,XMDT
  17250   "RTN","RCT CSP1",291, 0)
  17251    S XMNOW=$ $NOW^XLFDT
  17252   "RTN","RCT CSP1",292, 0)
  17253    S XMDT=$E (XMNOW,1,7 )
  17254   "RTN","RCT CSP1",293, 0)
  17255    S XMDDD=$ $RJ^XLFSTR ($$FMDIFF^ XLFDT(XMDT ,$E(XMDT,1 ,3)_"0101" ,1)+1,3,"0 ")
  17256   "RTN","RCT CSP1",294, 0)
  17257    Q $E(DT,3 )_XMDDD
  17258   "RTN","RCT CSP1",295, 0)
  17259    ;
  17260   "RTN","RCT CSP1",296, 0)
  17261   ADDR(RCDFN ) ; return s patient  file addre ss
  17262   "RTN","RCT CSP1",297, 0)
  17263    N DFN,ADD RCS,STATEI EN,STATEAB ,VAPA
  17264   "RTN","RCT CSP1",298, 0)
  17265    S DFN=RCD FN
  17266   "RTN","RCT CSP1",299, 0)
  17267    D ADD^VAD PT
  17268   "RTN","RCT CSP1",300, 0)
  17269    S STATEIE N=+VAPA(5) ,STATEAB=$ $GET1^DIQ( 5,STATEIEN ,1)
  17270   "RTN","RCT CSP1",301, 0)
  17271    S ADDRCS= VAPA(1)_U_ VAPA(2)_U_ VAPA(4)_U_ STATEAB_U_ VAPA(6)_U_ VAPA(8)_U_ +VAPA(25)
  17272   "RTN","RCT CSP1",302, 0)
  17273    I $L(DEBT OR1)>0 I $ P(DEBTOR1, U,1,5)'?1" ^"."^" D
  17274   "RTN","RCT CSP1",303, 0)
  17275    .N ADDR34 0
  17276   "RTN","RCT CSP1",304, 0)
  17277    .S ADDR34 0=$P($$DAD D^RCAMADD( DEBTOR),U, 1,8)
  17278   "RTN","RCT CSP1",305, 0)
  17279    .I $P(ADD RCS,U,7)>1  S $P(ADDR 340,U,6)="      "     ;PRCA*4.5* 331
  17280   "RTN","RCT CSP1",306, 0)
  17281    .S ADDR34 0=$P(ADDR3 40,U,1,2)_ "^"_$P(ADD R340,U,4,7 )_U_$S($P( ADDRCS,U,7 )'="":$P(A DDRCS,U,7) ,1:1)    ; PRCA*4.5*3 31
  17282   "RTN","RCT CSP1",307, 0)
  17283    .I $P(ADD R340,U,7)= "" S $P(AD DR340,U,7) =$P(ADDRCS ,U,7)      ;PRCA*4.5* 331
  17284   "RTN","RCT CSP1",308, 0)
  17285    .I $P(ADD R340,U,7)' =1 S $P(AD DR340,U,4) ="  "      ;PRCA*4.5* 331
  17286   "RTN","RCT CSP1",309, 0)
  17287    .S ADDRCS =ADDR340
  17288   "RTN","RCT CSP1",310, 0)
  17289    Q ADDRCS
  17290   "RTN","RCT CSP1",311, 0)
  17291    ;
  17292   "RTN","RCT CSP1",312, 0)
  17293   DEM(RCDFN)  ; returns  patient f ile gender  and dob
  17294   "RTN","RCT CSP1",313, 0)
  17295    N DFN,VAD M
  17296   "RTN","RCT CSP1",314, 0)
  17297    S DFN=RCD FN
  17298   "RTN","RCT CSP1",315, 0)
  17299    D DEM^VAD PT
  17300   "RTN","RCT CSP1",316, 0)
  17301    ; return  string   s ex:m/f ^ d ob: yyyymm dd ^ ssn ^  deceased
  17302   "RTN","RCT CSP1",317, 0)
  17303    Q $P(VADM (5),U,1)_U _$P(VADM(3 ),U,1)_U_$ P(VADM(2), U,1)_U_VAD M(6)
  17304   "RTN","RCT CSP1",318, 0)
  17305    ;
  17306   "RTN","RCT CSP1A")
  17307   0^23^B3836 5602^n/a
  17308   "RTN","RCT CSP1A",1,0 )
  17309   RCTCSP1A ; ALBANY/PAW -CROSS-SER VICING REP ORT ;03/15 /14 3:34 P M
  17310   "RTN","RCT CSP1A",2,0 )
  17311    ;;4.5;Acc ounts Rece ivable;**3 15**;Mar 2 0, 1995;Bu ild 55
  17312   "RTN","RCT CSP1A",3,0 )
  17313    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  17314   "RTN","RCT CSP1A",4,0 )
  17315    ;
  17316   "RTN","RCT CSP1A",5,0 )
  17317    Q
  17318   "RTN","RCT CSP1A",6,0 )
  17319    ;
  17320   "RTN","RCT CSP1A",7,0 )
  17321   CSRPRTH1 ; header for  cross-ser vicing pri nt report  1
  17322   "RTN","RCT CSP1A",8,0 )
  17323    W @IOF
  17324   "RTN","RCT CSP1A",9,0 )
  17325    S PAGE=0, DASH=""
  17326   "RTN","RCT CSP1A",10, 0)
  17327    S PAGE=PA GE+1,EXCEL =$G(EXCEL)
  17328   "RTN","RCT CSP1A",11, 0)
  17329    I 'EXCEL  D  Q
  17330   "RTN","RCT CSP1A",12, 0)
  17331    .W !,"PAG E "_PAGE,? 16,"BILLS  AT CROSS-S ERVICING ( SORTED BY  BILL NO.)" ,?68,$$FMT E^XLFDT(DT ,"2Z")
  17332   "RTN","RCT CSP1A",13, 0)
  17333    .W !,DASH ,!
  17334   "RTN","RCT CSP1A",14, 0)
  17335    .W !,"BIL L NO.",?14 ,"DEBTOR", ?35,"Pt ID ",?43,"ORI G AMT",?55 ,"CS REF D ATE",?67,"  CURR AMT"   ; limite d SSN to 4  char - (a s per PRCA *4.5*315)
  17336   "RTN","RCT CSP1A",15, 0)
  17337    .W !,"--- - ---",?14 ,"------", ?35,"----- ",?43,"--- - ---",?55 ,"-- --- - ---",?67,"  ---- ---" ,!
  17338   "RTN","RCT CSP1A",16, 0)
  17339    ;EXCEL FO RMAT
  17340   "RTN","RCT CSP1A",17, 0)
  17341    W !,"PAGE  "_PAGE_U_ U_"BILLS A T CROSS-SE RVICING (S ORTED BY B ILL NO.)"_ U_U_$$FMTE ^XLFDT(DT, "2Z")
  17342   "RTN","RCT CSP1A",18, 0)
  17343    W !,"BILL  NO."_U_"D EBTOR"_U_" Pt ID"_U_" ORIG AMT"_ U_"CS REF  DATE"_U_"  CURR AMT"   ; limited  SSN to 4  char - (as  per PRCA* 4.5*315)
  17344   "RTN","RCT CSP1A",19, 0)
  17345    Q
  17346   "RTN","RCT CSP1A",20, 0)
  17347    ;
  17348   "RTN","RCT CSP1A",21, 0)
  17349   CSRPRTH2 ; header for  cross-ser vicing pri nt report  2
  17350   "RTN","RCT CSP1A",22, 0)
  17351    W @IOF
  17352   "RTN","RCT CSP1A",23, 0)
  17353    S PAGE=0, DASH=""
  17354   "RTN","RCT CSP1A",24, 0)
  17355    S PAGE=PA GE+1,EXCEL =$G(EXCEL)
  17356   "RTN","RCT CSP1A",25, 0)
  17357    I 'EXCEL  D  Q
  17358   "RTN","RCT CSP1A",26, 0)
  17359    .W !,"PAG E "_PAGE,? 16,"BILLS  AT CROSS-S ERVICING ( SORTED BY  DEBTOR)",? 68,$$FMTE^ XLFDT(DT," 2Z")
  17360   "RTN","RCT CSP1A",27, 0)
  17361    .W !,DASH ,!
  17362   "RTN","RCT CSP1A",28, 0)
  17363    .W !,"DEB TOR",?21," BILL NO.", ?35,"Pt ID ",?43,"ORI G AMT",?55 ,"CS REF D ATE",?67,"  CURR AMT"   ;limited  SSN to 4  char - (as  per PRCA* 4.5*315)
  17364   "RTN","RCT CSP1A",29, 0)
  17365    .W !,"--- ---",?21," ---- ---", ?35,"----- ",?43,"--- - ---",?55 ,"-- --- - ---",?67,"  ---- ---" ,!
  17366   "RTN","RCT CSP1A",30, 0)
  17367    ;EXCEL FO RMAT
  17368   "RTN","RCT CSP1A",31, 0)
  17369    W !,"PAGE  "_PAGE_U_ U_"BILLS A T CROSS-SE RVICING (S ORTED BY D EBTOR)"_U_ U_$$FMTE^X LFDT(DT,"2 Z")
  17370   "RTN","RCT CSP1A",32, 0)
  17371    W !,"DEBT OR"_U_"BIL L NO."_U_" Pt ID"_U_" ORIG AMT"_ U_"CS REF  DATE"_U_"  CURR AMT"   ; limited  SSN to 4  char - (as  per PRCA* 4.5*315)
  17372   "RTN","RCT CSP1A",33, 0)
  17373    Q
  17374   "RTN","RCT CSP1A",34, 0)
  17375    ;
  17376   "RTN","RCT CSP1A",35, 0)
  17377   CSRPRTH3 ; header for  cross-ser vicing pri nt report  3
  17378   "RTN","RCT CSP1A",36, 0)
  17379    W @IOF
  17380   "RTN","RCT CSP1A",37, 0)
  17381    S PAGE=0, DASH=""
  17382   "RTN","RCT CSP1A",38, 0)
  17383    S PAGE=PA GE+1,EXCEL =$G(EXCEL)
  17384   "RTN","RCT CSP1A",39, 0)
  17385    I 'EXCEL  D  Q
  17386   "RTN","RCT CSP1A",40, 0)
  17387    .W !,"PAG E "_PAGE,? 11,"BILLS  AT CROSS-S ERVICING ( SORTED BY  CS REFERRE D DATE)",? 68,$$FMTE^ XLFDT(DT," 2Z")
  17388   "RTN","RCT CSP1A",41, 0)
  17389    .W !,DASH ,!
  17390   "RTN","RCT CSP1A",42, 0)
  17391    .W !,"CS  REF DT",?1 2,"DEBTOR" ,?34,"BILL  NO.",?49, "Pt ID",?5 8,"ORIG AM T",?67," C URR AMT"   ;limited S SN to 4 ch ar - (as p er PRCA*4. 5*315)
  17392   "RTN","RCT CSP1A",43, 0)
  17393    .W !,"--  --- ----", ?12,"----- -",?34,"-- -- ---",?4 9,"-----", ?58,"----  ---",?67,"  ---- ---" ,!
  17394   "RTN","RCT CSP1A",44, 0)
  17395    ;EXCEL FO RMAT
  17396   "RTN","RCT CSP1A",45, 0)
  17397    W !,"PAGE  "_PAGE_U_ U_"BILLS A T CROSS-SE RVICING (S ORTED BY C S REFERRED  DATE)"_U_ U_$$FMTE^X LFDT(DT,"2 Z")
  17398   "RTN","RCT CSP1A",46, 0)
  17399    W !,"CS R EF DATE"_U _"DEBTOR"_ U_"BILL NO ."_U_"Pt I D"_U_"ORIG  AMT"_U_"  CURR AMT"   ; limited  SSN to 4  char - (as  per PRCA* 4.5*315)
  17400   "RTN","RCT CSP1A",47, 0)
  17401    Q
  17402   "RTN","RCT CSP1A",48, 0)
  17403    ;
  17404   "RTN","RCT CSP1A",49, 0)
  17405   COUNTRY(Z)  ;
  17406   "RTN","RCT CSP1A",50, 0)
  17407    N PRCACC
  17408   "RTN","RCT CSP1A",51, 0)
  17409    ;get trea sury count ry code -  moved out  of RCTCSP1 , due to S ACC size l imitation  error PRCA *4.5*315
  17410   "RTN","RCT CSP1A",52, 0)
  17411    I Z=1 S P RCACC="US"  G COUNTRY Q
  17412   "RTN","RCT CSP1A",53, 0)
  17413    I Z="" S  PRCACC="US " G COUNTR YQ
  17414   "RTN","RCT CSP1A",54, 0)
  17415    S PRCACC= $S(Z=4:"AF ",Z=5:"AL" ,Z=7:"DZ", Z=8:"AD",Z =9:"AO",Z= 180:"AI",Z =10:"AG",Z =12:"AR",Z =18:"AM",Z =151:"AW", Z=13:"AU", Z=14:"AT", Z=11:"AZ", Z=15:"BS", Z=16:"BH", Z=17:"BD", 1:"  ") G: PRCACC'="   " COUNTRY Q
  17416   "RTN","RCT CSP1A",55, 0)
  17417    S PRCACC= $S(Z=19:"B B",Z=36:"B Y",Z=20:"B E",Z=28:"B Z",Z=61:"B J",Z=21:"B M",Z=22:"B T",Z=23:"B O",Z=24:"B A",Z=25:"B W",Z=27:"B R",Z=29:"I O",Z=32:"B N",Z=33:"B G",Z=223:" Faso",Z=35 :"BI",1:"   ") G:PRCA CC'="  " C OUNTRYQ
  17418   "RTN","RCT CSP1A",56, 0)
  17419    S PRCACC= $S(Z=37:"K H",Z=38:"C M",Z=39:"C A",Z=40:"C V",Z=41:"K Y",Z=42:"C F",Z=44:"T D",Z=45:"C L",Z=46:"C N",Z=50:"C O",Z=51:"K M",Z=53:"C G",Z=54:"C D",Z=55:"C K",Z=56:"C R",Z=109:" CI",1:"  " ) G:PRCACC '="  " COU NTRYQ
  17420   "RTN","RCT CSP1A",57, 0)
  17421    S PRCACC= $S(Z=57:"H R",Z=58:"C U",Z=59:"C Y",Z=60:"C Z",Z=115:" KP",Z=62:" DK",Z=80:" DJ",Z=63:" DM",Z=64:" DO",Z=172: "TP",Z=65: "EC",Z=220 :"EG",Z=66 :"SV",Z=67 :"GQ",Z=69 :"ER",Z=70 :"EE",1:"   ") G:PRCA CC'="  " C OUNTRYQ
  17422   "RTN","RCT CSP1A",58, 0)
  17423    S PRCACC= $S(Z=68:"E T",Z=72:"F K",Z=71:"F O",Z=74:"F J",Z=75:"F I",Z=76:"F R",Z=77:"G F",Z=78:"P F",Z=79:"T F",Z=81:"G A",Z=83:"G M",Z=82:"G E",Z=84:"D E",Z=85:"G H",Z=86:"G I",Z=221:" GB",1:"  " ) G:PRCACC '="  " COU NTRYQ
  17424   "RTN","RCT CSP1A",59, 0)
  17425    S PRCACC= $S(Z=88:"G R",Z=89:"G L",Z=90:"G D",Z=91:"G P",Z=92:"G T",Z=93:"G N",Z=171:" GW",Z=94:" GY",Z=95:" HT",Z=98:" HN",Z=99:" HK",Z=100: "HU",Z=101 :"IS",Z=10 2:"IN",Z=1 03:"ID",1: "  ") G:PR CACC'="  "  COUNTRYQ
  17426   "RTN","RCT CSP1A",60, 0)
  17427    S PRCACC= $S(Z=105:" IQ",Z=106: "IE",Z=107 :"IL",Z=10 8:"IT",Z=1 10:"JM",Z= 111:"JP",Z =113:"JO", Z=112:"KZ" ,Z=114:"KE ",Z=87:"KI ",Z=116:"K R",Z=117:" KW",Z=118: "KG",Z=119 :"LA",Z=12 2:"LV",1:"   ") G:PRC ACC'="  "  COUNTRYQ
  17428   "RTN","RCT CSP1A",61, 0)
  17429    S PRCACC= $S(Z=120:" LB",Z=121: "LS",Z=123 :"LR",Z=12 4:"LY",Z=1 25:"LI",Z= 126:"LT",Z =127:"LU", Z=128:"MO" ,Z=129:"MG ",Z=130:"M W",Z=131:" MY",Z=132: "MV",Z=133 :"ML",Z=13 4:"MT",1:"   ") G:PRC ACC'="  "  COUNTRYQ
  17430   "RTN","RCT CSP1A",62, 0)
  17431    S PRCACC= $S(Z=999:" MH",Z=135: "MQ",Z=136 :"MR",Z=13 7:"MU",Z=5 2:"YT",Z=1 38:"MX",Z= 161:"FM",Z =141:"MD", Z=139:"MC" ,Z=140:"MN ",Z=142:"M S",Z=143:" MA",Z=144: "MZ",Z=34: "MM",Z=146 :"NA",1:"   ") G:PRCA CC'="  " C OUNTRYQ
  17432   "RTN","RCT CSP1A",63, 0)
  17433    S PRCACC= $S(Z=147:" NR",Z=148: "NP",Z=149 :"NL",Z=15 0:"AN",Z=1 52:"NC",Z= 154:"NZ",Z =155:"NI", Z=156:"NE" ,Z=157:"NG ",Z=158:"N U",Z=159:" NF",Z=160: "NO",Z=145 :"OM",Z=16 2:"PK",1:"   ") G:PRC ACC'="  "  COUNTRYQ
  17434   "RTN","RCT CSP1A",64, 0)
  17435    S PRCACC= $S(Z=999:" PW",Z=163: "PA",Z=164 :"PG",Z=16 5:"PY",Z=1 66:"PE",Z= 167:"PH",Z =168:"PN", Z=169:"PL" ,Z=170:"PT ",Z=173:"Q A",Z=999:" RE",Z=175: "RO",Z=176 :"RU",Z=17 7:"RW",Z=1 78:"SH",1: "  ") G:PR CACC'="  "  COUNTRYQ
  17436   "RTN","RCT CSP1A",65, 0)
  17437    S PRCACC= $S(Z=179:" KN",Z=181: "LC",Z=183 :"VC",Z=99 9:"WS",Z=1 84:"SM",Z= 185:"ST",Z =186:"SA", Z=187:"SN" ,Z=188:"SC ",Z=189:"S L",Z=190:" SG",Z=191: "SK",Z=193 :"SI",Z=30 :"SB",1:"   ") G:PRCA CC'="  " C OUNTRYQ
  17438   "RTN","RCT CSP1A",66, 0)
  17439    S PRCACC= $S(Z=194:" SO",Z=195: "ZA",Z=197 :"ES",Z=43 :"LK",Z=19 9:"SD",Z=2 00:"SR",Z= 201:"SZ",Z =202:"SE", Z=203:"CH" ,Z=204:"SY ",Z=205:"T J",Z=222:" TZ",Z=182: "PM",Z=206 :"TH",Z=21 9:"MK",1:"   ") G:PRC ACC'="  "  COUNTRYQ
  17440   "RTN","RCT CSP1A",67, 0)
  17441    S PRCACC= $S(Z=207:" TG",Z=208: "TK",Z=209 :"TO",Z=21 0:"TT",Z=2 12:"TN",Z= 213:"TR",Z =214:"TM", Z=215:"TC" ,Z=216:"TV ",Z=217:"U G",Z=218:" UA",Z=211: "AE",Z=1:" US",Z=224: "UY",1:"   ") G:PRCAC C'="  " CO UNTRYQ
  17442   "RTN","RCT CSP1A",68, 0)
  17443    S PRCACC= $S(Z=104:" IR",Z=225: "UZ",Z=153 :"VU",Z=97 :"VA",Z=22 6:"VE",Z=1 83:"VN",Z= 31:"VG",Z= 227:"WF",Z =228:"YE", Z=229:"YU" ,Z=230:"ZM ",Z=196:"Z W",1:"  ")  G:PRCACC' ="  " COUN TRYQ
  17444   "RTN","RCT CSP1A",69, 0)
  17445   COUNTRYQ ;
  17446   "RTN","RCT CSP1A",70, 0)
  17447    Q PRCACC
  17448   "RTN","RCT CSP1A",71, 0)
  17449    ;
  17450   "RTN","RCT CSP2")
  17451   0^14^B1390 76355^B878 61761
  17452   "RTN","RCT CSP2",1,0)
  17453   RCTCSP2 ;A LBANY/BDB- CROSS-SERV ICING TRAN SMISSION ; 03/15/14 3 :34 PM
  17454   "RTN","RCT CSP2",2,0)
  17455    ;;4.5;Acc ounts Rece ivable;**3 01,315**;M ar 20, 199 5;Build 55
  17456   "RTN","RCT CSP2",3,0)
  17457    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  17458   "RTN","RCT CSP2",4,0)
  17459    ;
  17460   "RTN","RCT CSP2",5,0)
  17461    Q
  17462   "RTN","RCT CSP2",6,0)
  17463    ;
  17464   "RTN","RCT CSP2",7,0)
  17465   COMPILE ;
  17466   "RTN","RCT CSP2",8,0)
  17467    N RCMSG,B CNTR,REC,R ECC,AMOUNT ,RCNTR,ACT ION,SEQ
  17468   "RTN","RCT CSP2",9,0)
  17469    S BCNTR=0 ,REC=0,REC C=0,AMOUNT =0,SEQ=0
  17470   "RTN","RCT CSP2",10,0 )
  17471    F  S BCNT R=$O(^XTMP ("RCTCSPD" ,$J,BCNTR) ) Q:+BCNTR '>0  D
  17472   "RTN","RCT CSP2",11,0 )
  17473    .I REC>50  D
  17474   "RTN","RCT CSP2",12,0 )
  17475    ..D TRAIL ER^RCTCSP1
  17476   "RTN","RCT CSP2",13,0 )
  17477    ..D AITCM SG
  17478   "RTN","RCT CSP2",14,0 )
  17479    ..S REC=0 ,RECC=0
  17480   "RTN","RCT CSP2",15,0 )
  17481    ..Q
  17482   "RTN","RCT CSP2",16,0 )
  17483    .S ACTION ="" F  S A CTION=$O(^ XTMP("RCTC SPD",$J,BC NTR,ACTION )) Q:ACTIO N=""  D
  17484   "RTN","RCT CSP2",17,0 )
  17485    ..I REC=0  D HEADER^ RCTCSP1
  17486   "RTN","RCT CSP2",18,0 )
  17487    ..F RCNTR =1,2,"2A", "2C",3 I $ D(^XTMP("R CTCSPD",$J ,BCNTR,ACT ION,RCNTR) ) D
  17488   "RTN","RCT CSP2",19,0 )
  17489    ...S REC= REC+1
  17490   "RTN","RCT CSP2",20,0 )
  17491    ...S RECC =RECC+1 ;r ecord coun t for 'c'  records on  trailer r ecord
  17492   "RTN","RCT CSP2",21,0 )
  17493    ...S ^XTM P("RCTCSPD ",$J,SEQ," BUILD",REC )=$E(^XTMP ("RCTCSPD" ,$J,BCNTR, ACTION,RCN TR),1,225) _$C(94)
  17494   "RTN","RCT CSP2",22,0 )
  17495    ...S REC= REC+1
  17496   "RTN","RCT CSP2",23,0 )
  17497    ...S ^XTM P("RCTCSPD ",$J,SEQ," BUILD",REC )=$E(^XTMP ("RCTCSPD" ,$J,BCNTR, ACTION,RCN TR),226,99 9)_$C(126)
  17498   "RTN","RCT CSP2",24,0 )
  17499    ...I $E(^ XTMP("RCTC SPD",$J,BC NTR,ACTION ,RCNTR),2) ="1" S AMO UNT=AMOUNT +$E(^(RCNT R),91,104)
  17500   "RTN","RCT CSP2",25,0 )
  17501    ...Q
  17502   "RTN","RCT CSP2",26,0 )
  17503    ..I $D(^X TMP("RCTCS PD",$J,BCN TR,ACTION, "5B")) D
  17504   "RTN","RCT CSP2",27,0 )
  17505    ...N TRNN UM
  17506   "RTN","RCT CSP2",28,0 )
  17507    ...S TRNN UM=0
  17508   "RTN","RCT CSP2",29,0 )
  17509    ...F  S T RNNUM=$O(^ XTMP("RCTC SPD",$J,BC NTR,ACTION ,"5B",TRNN UM)) Q:TRN NUM'?1N.N   D
  17510   "RTN","RCT CSP2",30,0 )
  17511    ....S REC =REC+1
  17512   "RTN","RCT CSP2",31,0 )
  17513    ....S REC C=RECC+1 ; record cou nt for 'c'  records o n trailer  record
  17514   "RTN","RCT CSP2",32,0 )
  17515    ....S ^XT MP("RCTCSP D",$J,SEQ, "BUILD",RE C)=$E(^XTM P("RCTCSPD ",$J,BCNTR ,ACTION,"5 B",TRNNUM) ,1,225)_$C (94)
  17516   "RTN","RCT CSP2",33,0 )
  17517    ....S REC =REC+1
  17518   "RTN","RCT CSP2",34,0 )
  17519    ....S ^XT MP("RCTCSP D",$J,SEQ, "BUILD",RE C)=$E(^XTM P("RCTCSPD ",$J,BCNTR ,ACTION,"5 B",TRNNUM) ,226,999)_ $C(126)
  17520   "RTN","RCT CSP2",35,0 )
  17521    ....S AMO UNT=AMOUNT +$TR($E(^X TMP("RCTCS PD",$J,BCN TR,ACTION, "5B",TRNNU M),173,186 ),"-")
  17522   "RTN","RCT CSP2",36,0 )
  17523    ....Q
  17524   "RTN","RCT CSP2",37,0 )
  17525    ...Q
  17526   "RTN","RCT CSP2",38,0 )
  17527    ..Q
  17528   "RTN","RCT CSP2",39,0 )
  17529    .Q
  17530   "RTN","RCT CSP2",40,0 )
  17531    D TRAILER ^RCTCSP1
  17532   "RTN","RCT CSP2",41,0 )
  17533    D AITCMSG
  17534   "RTN","RCT CSP2",42,0 )
  17535    D USRMSG
  17536   "RTN","RCT CSP2",43,0 )
  17537    Q
  17538   "RTN","RCT CSP2",44,0 )
  17539    ;
  17540   "RTN","RCT CSP2",45,0 )
  17541   RCLLCHK(BI LL) ;
  17542   "RTN","RCT CSP2",46,0 )
  17543    N TOTAL
  17544   "RTN","RCT CSP2",47,0 )
  17545    I $P(B15, U,7) Q 0 ; check stop  tcsp refe rral flag
  17546   "RTN","RCT CSP2",48,0 )
  17547    I $P(B15, U,2),'$P(B 15,U,3) D   ;recall b ill
  17548   "RTN","RCT CSP2",49,0 )
  17549    .N ACTION ,BILLCSL
  17550   "RTN","RCT CSP2",50,0 )
  17551    .S ACTION ="L"
  17552   "RTN","RCT CSP2",51,0 )
  17553    .S $P(^PR CA(430,BIL L,15),U,1) ="" ;clear  the date  referred
  17554   "RTN","RCT CSP2",52,0 )
  17555    .S $P(^PR CA(430,BIL L,15),U,3) =DT ;set t he recall  date
  17556   "RTN","RCT CSP2",53,0 )
  17557    .S $P(^PR CA(430,BIL L,15),U,5) =$$GET1^DI Q(430,BILL ,11) ;set  the recall  amount to  the curre nt amount
  17558   "RTN","RCT CSP2",54,0 )
  17559    .S B15=^P RCA(430,BI LL,15)
  17560   "RTN","RCT CSP2",55,0 )
  17561    .S BILLCS L=BILL ;la st cs bill
  17562   "RTN","RCT CSP2",56,0 )
  17563    .D REC1^R CTCSPD
  17564   "RTN","RCT CSP2",57,0 )
  17565    .K ^PRCA( 430,"TCSP" ,BILL) ;se t the bill  to not se nt to cros s-servicin g
  17566   "RTN","RCT CSP2",58,0 )
  17567    .D RCLL^R CTCSPD4 ;  set bill r ecall non- financial  transactio n PRCA*4.5 *315
  17568   "RTN","RCT CSP2",59,0 )
  17569    ;
  17570   "RTN","RCT CSP2",60,0 )
  17571    ;recall b ill if tot al <$25
  17572   "RTN","RCT CSP2",61,0 )
  17573    S TOTAL=$ P(B7,U)+$P (B7,U,2)+$ P(B7,U,3)+ $P(B7,U,4) +$P(B7,U,5 )
  17574   "RTN","RCT CSP2",62,0 )
  17575    I TOTAL<2 5 D  Q 0
  17576   "RTN","RCT CSP2",63,0 )
  17577    .N X1,X2, P366DT,X,P RCAEN,I,RE CALL
  17578   "RTN","RCT CSP2",64,0 )
  17579    .S RECALL =0
  17580   "RTN","RCT CSP2",65,0 )
  17581    .S X1=DT, X2=-366 D  C^%DTC S P 366DT=X
  17582   "RTN","RCT CSP2",66,0 )
  17583    .S PRCAEN =0 F I=0:0  S PRCAEN= $O(^PRCA(4 33,"C",BIL L,PRCAEN))  Q:'PRCAEN   S:$P($G( ^PRCA(433, PRCAEN,1)) ,U,1)>P366 DT RECALL= 1
  17584   "RTN","RCT CSP2",67,0 )
  17585    .I RECALL =0 D  Q
  17586   "RTN","RCT CSP2",68,0 )
  17587    ..S ACTIO N="L"
  17588   "RTN","RCT CSP2",69,0 )
  17589    ..S $P(^P RCA(430,BI LL,15),U,1 )="" ;clea r the date  referred
  17590   "RTN","RCT CSP2",70,0 )
  17591    ..S $P(^P RCA(430,BI LL,15),U,2 )=1 ;set t he recall  flag
  17592   "RTN","RCT CSP2",71,0 )
  17593    ..S $P(^P RCA(430,BI LL,15),U,3 )=DT ;set  the recall  date
  17594   "RTN","RCT CSP2",72,0 )
  17595    ..S $P(^P RCA(430,BI LL,15),U,4 )="07" ;se t the reca ll reason
  17596   "RTN","RCT CSP2",73,0 )
  17597    ..S $P(^P RCA(430,BI LL,15),U,5 )=$P($G(^P RCA(430,BI LL,16)),U, 10) ;set t he recall  amount to  the curren t tcsp amo unt
  17598   "RTN","RCT CSP2",74,0 )
  17599    ..S $P(^P RCA(430,BI LL,15),U,7 )=1 ;set t he stop fl ag
  17600   "RTN","RCT CSP2",75,0 )
  17601    ..S $P(^P RCA(430,BI LL,15),U,8 )=DT ;set  the stop d ate
  17602   "RTN","RCT CSP2",76,0 )
  17603    ..S $P(^P RCA(430,BI LL,15),U,9 )="O" ;set  the stop  date
  17604   "RTN","RCT CSP2",77,0 )
  17605    ..S $P(^P RCA(430,BI LL,15),U,1 0)="AUTORE CALL <$25"  ;set the  stop reaso n
  17606   "RTN","RCT CSP2",78,0 )
  17607    ..S B15=^ PRCA(430,B ILL,15)
  17608   "RTN","RCT CSP2",79,0 )
  17609    ..D REC1^ RCTCSPD,RC LL^RCTCSPD 4 ; set CS  Bill Reca ll transac tion PRCA* 4.5*315
  17610   "RTN","RCT CSP2",80,0 )
  17611    ..K ^PRCA (430,"TCSP ",BILL) ;s et the bil l to not s ent to cro ss-servici ng
  17612   "RTN","RCT CSP2",81,0 )
  17613    ..S $P(^P RCA(430,BI LL,19),U,1 0)=1 ;stop  interest  admin calc
  17614   "RTN","RCT CSP2",82,0 )
  17615    ..S B19=$ G(^PRCA(43 0,BILL,19) )
  17616   "RTN","RCT CSP2",83,0 )
  17617    ..Q
  17618   "RTN","RCT CSP2",84,0 )
  17619    .Q
  17620   "RTN","RCT CSP2",85,0 )
  17621    Q 0
  17622   "RTN","RCT CSP2",86,0 )
  17623    ;
  17624   "RTN","RCT CSP2",87,0 )
  17625   RCRPRT ;Re conciliati on report
  17626   "RTN","RCT CSP2",88,0 )
  17627    N ZTDESC, ZTRTN,POP, %ZIS,DTFRM TO,DTFRM,D TTO,PROMPT ,EXCEL
  17628   "RTN","RCT CSP2",89,0 )
  17629    S DTFRMTO =$$DTFRMTO  Q:'DTFRMT O  ;Get da te range a s per PRCA *4.5*315
  17630   "RTN","RCT CSP2",90,0 )
  17631    S (DATE,D TFRM)=$$FM ADD^XLFDT( +$P(DTFRMT O,U,2),-1) ,DTTO=$P(D TFRMTO,U,3 ),CURDT=0
  17632   "RTN","RCT CSP2",91,0 )
  17633    S EXCEL=0 ,PROMPT="C APTURE Rep ort data t o an Excel  Document" ,DIR(0)="Y ",DIR("?") ="^D HEXC^ RCTCSJR"
  17634   "RTN","RCT CSP2",92,0 )
  17635    S EXCEL=$ $SELECT^RC TCSJR(PROM PT,"NO") I  "01"'[EXC EL S STOP= 1 Q
  17636   "RTN","RCT CSP2",93,0 )
  17637    I EXCEL=1  D EXCMSG^ RCTCSJR ;  Display Ex cel displa y message
  17638   "RTN","RCT CSP2",94,0 )
  17639    K IOP,IO( "Q") S %ZI S="MQ",%ZI S("B")=""  D ^%ZIS Q: POP  S IOP =ION_";"_I OM_";"_IOS L
  17640   "RTN","RCT CSP2",95,0 )
  17641    I $D(IO(" Q")) D  Q   ;
  17642   "RTN","RCT CSP2",96,0 )
  17643    .S ZTSAVE ("DTFRMTO" )="",ZTSAV E("EXCEL") =""
  17644   "RTN","RCT CSP2",97,0 )
  17645    .S ZTRTN= "RCRPRTP^R CTCSP2",ZT DESC="RECO NCILIATION  REPORT"
  17646   "RTN","RCT CSP2",98,0 )
  17647    .D ^%ZTLO AD,HOME^%Z IS
  17648   "RTN","RCT CSP2",99,0 )
  17649    .I $G(ZTS K) W !!,"R eport comp ilation ha s started  with task#  ",ZTSK,". ",! S DIR( 0)="E" D ^ DIR K DIR
  17650   "RTN","RCT CSP2",100, 0)
  17651    .Q
  17652   "RTN","RCT CSP2",101, 0)
  17653    ;
  17654   "RTN","RCT CSP2",102, 0)
  17655   RCRPRTP ;p rint the -  reconcili ation repo rt, call t o build ar ray of bil ls returne d
  17656   "RTN","RCT CSP2",103, 0)
  17657    U IO
  17658   "RTN","RCT CSP2",104, 0)
  17659    N DASH,PA GE,DBTR,DB TRN,RCOUT, CURDT,FND1 ,RC18,RCRT CD
  17660   "RTN","RCT CSP2",105, 0)
  17661    K ^XTMP(" RCTCSPP",$ J)
  17662   "RTN","RCT CSP2",106, 0)
  17663    S ^XTMP(" RCTCSPP",0 )=$$FMADD^ XLFDT(DT,3 )_"^"_DT
  17664   "RTN","RCT CSP2",107, 0)
  17665    S (DATE,D TFRM)=$$FM ADD^XLFDT( +$P(DTFRMT O,U,2),-1) ,DTTO=$P(D TFRMTO,U,3 ),CURDT=0
  17666   "RTN","RCT CSP2",108, 0)
  17667    F  S DATE =$O(^PRCA( 430,"AN",D ATE)),BILL IEN=0 Q:DA TE=""!(DAT E>DTTO)  D   ;Use new  AN xref P RCA*4.5*31 5
  17668   "RTN","RCT CSP2",109, 0)
  17669    . F  S BI LLIEN=$O(^ PRCA(430," AN",DATE,B ILLIEN)) Q :BILLIEN=" "  D
  17670   "RTN","RCT CSP2",110, 0)
  17671    ..I +$P($ G(^PRCA(43 0,BILLIEN, 30)),U,1)= 0 Q   ;Ret urned date  is NULL
  17672   "RTN","RCT CSP2",111, 0)
  17673    ..S DBTR= $P($G(^PRC A(430,BILL IEN,0)),U, 9),DBTRN=$ $GET1^DIQ( 430,BILLIE N,9)
  17674   "RTN","RCT CSP2",112, 0)
  17675    ..Q:DBTRN ']""
  17676   "RTN","RCT CSP2",113, 0)
  17677    ..S ^XTMP ("RCTCSPP" ,$J,DBTRN, DBTR)=""
  17678   "RTN","RCT CSP2",114, 0)
  17679    ..;S FND1 =1
  17680   "RTN","RCT CSP2",115, 0)
  17681    S PAGE=0, RCOUT=0
  17682   "RTN","RCT CSP2",116, 0)
  17683    S DASH="" ,$P(DASH," -",78)=""
  17684   "RTN","RCT CSP2",117, 0)
  17685    D RCRPRTH 2
  17686   "RTN","RCT CSP2",118, 0)
  17687    S DBTRN=0
  17688   "RTN","RCT CSP2",119, 0)
  17689    F  S DBTR N=$O(^XTMP ("RCTCSPP" ,$J,DBTRN) ) Q:DBTRN= ""  D  Q:R COUT
  17690   "RTN","RCT CSP2",120, 0)
  17691    .S DBTR=$ O(^XTMP("R CTCSPP",$J ,DBTRN,0))  Q:'+DBTR
  17692   "RTN","RCT CSP2",121, 0)
  17693    .S BILL=0
  17694   "RTN","RCT CSP2",122, 0)
  17695    .F  S BIL L=$O(^PRCA (430,"C",D BTR,BILL))  Q:BILL'?1 N.N  D  Q: RCOUT
  17696   "RTN","RCT CSP2",123, 0)
  17697    ..N B0,B3 0,AMTREF,A MTPD,AMTFE E,DTRET,CO RDT,SSN
  17698   "RTN","RCT CSP2",124, 0)
  17699    ..S B0=$G (^PRCA(430 ,BILL,0)), B30=$G(^PR CA(430,BIL L,30))
  17700   "RTN","RCT CSP2",125, 0)
  17701    ..;New fi elds added  in PRCA*4 .5*315  AM TREF:(#169 ) ORIGINAL  TCSP AMOU NT, AMTPD: AMTREF - ( #169.1) CU RRENT TCSP  AMOUNT, A MTFEE:(#74 ) MARSHAL  FEE 
  17702   "RTN","RCT CSP2",126, 0)
  17703    ..; CORDT :(#153) TC SP RECALL  EFF. DATE,  AMTREF:(# 169) ORIGI NAL TCSP A MOUNT, DTR EJ: (#172)  REJECT DA TE (multip le)
  17704   "RTN","RCT CSP2",127, 0)
  17705    ..S AMTRE F=$P($G(^P RCA(430,BI LL,16)),U, 9),AMTPD=A MTREF-$P($ G(^PRCA(43 0,BILL,16) ),U,10)
  17706   "RTN","RCT CSP2",128, 0)
  17707    ..I 'EXCE L S AMTFEE =$J($P($G( ^PRCA(430, BILL,7)),U ,4),8,2)
  17708   "RTN","RCT CSP2",129, 0)
  17709    ..I EXCEL  S AMTFEE= $J($P($G(^ PRCA(430,B ILL,7)),U, 4),5,2)
  17710   "RTN","RCT CSP2",130, 0)
  17711    ..I 'EXCE L S AMTREF =$J(AMTREF ,8,2),AMTP D=$J(AMTPD ,8,2)
  17712   "RTN","RCT CSP2",131, 0)
  17713    ..I EXCEL  S AMTREF= $J(AMTREF, 7,2),AMTPD =$J(AMTPD, 7,2)
  17714   "RTN","RCT CSP2",132, 0)
  17715    ..S DEBTO R=$P($G(^P RCA(430,BI LL,0)),U,9 ),SSN=$$SS N^RCFN01($ P(^RCD(340 ,DEBTOR,0) ,"^")),SSN =$E(SSN,6, 9)
  17716   "RTN","RCT CSP2",133, 0)
  17717    ..S CORDT =$$FMTE^XL FDT($P($G( ^PRCA(430, BILL,15)), U,3),"2Z") ,DTRET=""
  17718   "RTN","RCT CSP2",134, 0)
  17719    ..S DTRET =$P($G(^PR CA(430,BIL L,30)),U)  I DTRET S  DTRET=$$FM TE^XLFDT(D TRET,"2Z")
  17720   "RTN","RCT CSP2",135, 0)
  17721    ..I +$P($ G(^PRCA(43 0,BILL,30) ),U,1)=0 Q
  17722   "RTN","RCT CSP2",136, 0)
  17723    ..I 'EXCE L W $E($$G ET1^DIQ(43 0,BILL,9), 1,16)
  17724   "RTN","RCT CSP2",137, 0)
  17725    ..I EXCEL  W !,$E($$ GET1^DIQ(4 30,BILL,9) ,1,14)
  17726   "RTN","RCT CSP2",138, 0)
  17727    ..I 'EXCE L W ?17,$P (B0,U,1),? 29,SSN,?31 ,AMTREF,?4 1,AMTPD,?4 7,AMTFEE,? 59,CORDT,? 69,DTRET,!
  17728   "RTN","RCT CSP2",139, 0)
  17729    ..I EXCEL  W U_$P($P (B0,U,1)," -",2)_U_SS N_U_AMTREF _U_AMTPD_U _AMTFEE_U_ CORDT_U_DT RET
  17730   "RTN","RCT CSP2",140, 0)
  17731    ..S RCRTC D=$P($G(^P RCA(430,BI LL,30)),U, 2)
  17732   "RTN","RCT CSP2",141, 0)
  17733    ..I 'EXCE L D
  17734   "RTN","RCT CSP2",142, 0)
  17735    ...D  ;Di splay retu rn reason  code
  17736   "RTN","RCT CSP2",143, 0)
  17737    ....I RCR TCD="" W ? 6,"NO RETU RN REASON  CODE",! Q
  17738   "RTN","RCT CSP2",144, 0)
  17739    ....W:$D( ^PRCA(430. 5,RCRTCD,0 )) ?6,$P(^ PRCA(430.5 ,RCRTCD,0) ,U,2),!
  17740   "RTN","RCT CSP2",145, 0)
  17741    ....W:'$D (^PRCA(430 .5,RCRTCD, 0)) ?6,"UN KNOWN RETU RN REASON  CODE: ",RC RTCD,!
  17742   "RTN","RCT CSP2",146, 0)
  17743    ....W:RCR TCD=14 ?7, "Compromis e, Please  write this  bill off  by the man ual proces s",!,?8,"A mount (not  collected ): "_$J($P ($G(^PRCA( 430,BILL,3 0)),U,4),9 ,2),!  ;Ad ded PRCA*4 .5*315
  17744   "RTN","RCT CSP2",147, 0)
  17745    ....W:RCR TCD=2 ?8," Date of De ath:  "_$$ FMTE^XLFDT ($P($G(^PR CA(430,BIL L,30)),U,7 ),"2Z"),!   ;date typ e (as per  PRCA*4.5*3 15)
  17746   "RTN","RCT CSP2",148, 0)
  17747    ....W:RCR TCD=3 ?8," Bankruptcy  Date:  "_ $$FMTE^XLF DT($P($G(^ PRCA(430,B ILL,30)),U ,6),"2Z"), !
  17748   "RTN","RCT CSP2",149, 0)
  17749    ...W:+$P( $G(^PRCA(4 30,BILL,30 )),U,8) ?6 ,"Date of  Dissolutio n:  "_$$FM TE^XLFDT($ P($G(^PRCA (430,BILL, 30)),U,8), "2Z"),!
  17750   "RTN","RCT CSP2",150, 0)
  17751    ..I EXCEL  D
  17752   "RTN","RCT CSP2",151, 0)
  17753    ...I RCRT CD=14 W U_ $P(^PRCA(4 30.5,RCRTC D,0),U,2)_ U_"AMT NOT  COLL"_U_$ P($G(^PRCA (430,BILL, 30)),U,4)
  17754   "RTN","RCT CSP2",152, 0)
  17755    ...I $P($ G(^PRCA(43 0,BILL,30) ),U,3)="Y"  W U_"CP"_ U_$J($P($G (^PRCA(430 ,BILL,30)) ,U,4),4,2)  Q
  17756   "RTN","RCT CSP2",153, 0)
  17757    ...I RCRT CD=2 W U_$ P(^PRCA(43 0.5,RCRTCD ,0),U,2)_"  "_$$FMTE^ XLFDT($P($ G(^PRCA(43 0,BILL,30) ),U,7),"2Z ") Q
  17758   "RTN","RCT CSP2",154, 0)
  17759    ...I RCRT CD=3 W U_$ P(^PRCA(43 0.5,RCRTCD ,0),U,2)_"  "_$$FMTE^ XLFDT($P($ G(^PRCA(43 0,BILL,30) ),U,6),"2Z ") Q
  17760   "RTN","RCT CSP2",155, 0)
  17761    ...I RCRT CD]"" W U_ $S($D(^PRC A(430.5,RC RTCD,0)):$ $GET1^DIQ( 430.5,RCRT CD,1),1:RC RTCD) Q
  17762   "RTN","RCT CSP2",156, 0)
  17763    ..;check  for end of  page here , if neces sary form  feed and p rint heade r
  17764   "RTN","RCT CSP2",157, 0)
  17765    ..I 'EXCE L W ! I ($ Y+3)>IOSL  D
  17766   "RTN","RCT CSP2",158, 0)
  17767    ...I $E(I OST,1,2)=" C-" S DIR( 0)="E" K D IRUT D ^DI R K DIR I  $D(DTOUT)! ($D(DUOUT) ) S RCOUT= 1 K X,Y,DI RUT,DTOUT, DUOUT,DIRO UT Q
  17768   "RTN","RCT CSP2",159, 0)
  17769    ...D RCRP RTH2
  17770   "RTN","RCT CSP2",160, 0)
  17771    I $E(IOST ,1,2)="C-"  R !!,"END  OF REPORT ...PRESS R ETURN TO C ONTINUE",X :DTIME W @ IOF
  17772   "RTN","RCT CSP2",161, 0)
  17773    D:'$D(ZTQ UEUED) ^%Z ISC
  17774   "RTN","RCT CSP2",162, 0)
  17775    S:$D(ZTQU EUED) ZTRE Q="@"
  17776   "RTN","RCT CSP2",163, 0)
  17777    K IOP,%ZI S,ZTQUEUED
  17778   "RTN","RCT CSP2",164, 0)
  17779    Q
  17780   "RTN","RCT CSP2",165, 0)
  17781    ;
  17782   "RTN","RCT CSP2",166, 0)
  17783   RCRPRTH2 ; header for  reconcili ation repo rt print r eport 2
  17784   "RTN","RCT CSP2",167, 0)
  17785    W @IOF
  17786   "RTN","RCT CSP2",168, 0)
  17787    S PAGE=PA GE+1
  17788   "RTN","RCT CSP2",169, 0)
  17789    I 'EXCEL  W "PAGE "_ PAGE,?12," RECONCILIA TION REPOR T ",?65,$$ FMTE^XLFDT (DT,"2Z")
  17790   "RTN","RCT CSP2",170, 0)
  17791    I 'EXCEL  D  Q 
  17792   "RTN","RCT CSP2",171, 0)
  17793    .W !,DASH
  17794   "RTN","RCT CSP2",172, 0)
  17795    .W !,"DEB TOR",?17," BILL NO.", ?29,"SSN", ?34,"Amoun t",?42,"Am ount",?51, "Amount",? 59,"Recall ",?69,"Dat e",!
  17796   "RTN","RCT CSP2",173, 0)
  17797    .W ?34,"R efer",?42, "Paid",?51 ,"of Fee", ?59,"Eff.  Dt",?69,"R eturn"
  17798   "RTN","RCT CSP2",174, 0)
  17799    .W !,"--- ---------- ---",?17," ---------- -",?29,"-- --",?34,"- ------",?4 2,"------- ",?51,"--- ---",?59," --------", ?69,"----- ---",!
  17800   "RTN","RCT CSP2",175, 0)
  17801    ;EXCEL FO RMAT
  17802   "RTN","RCT CSP2",176, 0)
  17803    W "PAGE " _PAGE_U_"R ECONCILIAT ION REPORT  "_U_$$FMT E^XLFDT(DT ,"2Z")
  17804   "RTN","RCT CSP2",177, 0)
  17805    W !,"DEBT OR"_U_"BIL L #"_U_"Pt  ID"_U_"AM T REF"_U_" AMT PD"_U_ "AMT FEE"_ U_"DT RPT" _U_"DT RET "_U_"COMME NT"
  17806   "RTN","RCT CSP2",178, 0)
  17807    Q
  17808   "RTN","RCT CSP2",179, 0)
  17809    ;
  17810   "RTN","RCT CSP2",180, 0)
  17811   AITCMSG ;
  17812   "RTN","RCT CSP2",181, 0)
  17813    N XMY,XMD UZ,XMSUB,X MTEXT,CNTL ID
  17814   "RTN","RCT CSP2",182, 0)
  17815    S CNTLID= $$JD^RCTCS P1()_$$RJZ F^RCTCSP1( SEQ,4)
  17816   "RTN","RCT CSP2",183, 0)
  17817    S XMDUZ=" AR PACKAGE "
  17818   "RTN","RCT CSP2",184, 0)
  17819    S XMY(" URL          ")=""
  17820   "RTN","RCT CSP2",185, 0)
  17821    S XMY("G. TCSP")=""
  17822   "RTN","RCT CSP2",186, 0)
  17823    S XMSUB=S ITE_"/CS T RANSMISSIO N/BATCH#:  "_CNTLID
  17824   "RTN","RCT CSP2",187, 0)
  17825    S XMTEXT= "^XTMP(""R CTCSPD""," _$J_","""_ SEQ_""","" BUILD"","
  17826   "RTN","RCT CSP2",188, 0)
  17827    D ^XMD
  17828   "RTN","RCT CSP2",189, 0)
  17829    Q
  17830   "RTN","RCT CSP2",190, 0)
  17831    ;
  17832   "RTN","RCT CSP2",191, 0)
  17833   USRMSG ;se nds mailma n message  of documen ts sent to  user
  17834   "RTN","RCT CSP2",192, 0)
  17835    N XMY,XMD UZ,XMSUB,X MTEXT,X,RC NT,RCDAT1, RCDAT2
  17836   "RTN","RCT CSP2",193, 0)
  17837    S ACTION= "" F  S AC TION=$O(^X TMP("RCTCS PD",$J,"BI LL",ACTION )) Q:ACTIO N=""  D
  17838   "RTN","RCT CSP2",194, 0)
  17839    .K ^XTMP( "RCTCSPD", $J,"BILL", "MSG")
  17840   "RTN","RCT CSP2",195, 0)
  17841    .S XMDUZ= "AR PACKAG E"
  17842   "RTN","RCT CSP2",196, 0)
  17843    .S XMY("G .TCSP")=""
  17844   "RTN","RCT CSP2",197, 0)
  17845    .S XMSUB= "CS "_$S(A CTION="A": "ADD REFER RAL",ACTIO N="U":"UPD ATES",ACTI ON="L":"RE CALLS",ACT ION="B":"E XISTING DE BTOR",1:"U NKNOWN")_"  SENT ON " _$E(DT,4,5 )_"/"_$E(D T,6,7)_"/" _$E(DT,2,3 )_" BATCH  ID: "_CNTL ID
  17846   "RTN","RCT CSP2",198, 0)
  17847    .S ^XTMP( "RCTCSPD", $J,"BILL", "MSG",1)=" Bill#                                TIN         TYPE        AMOU NT"
  17848   "RTN","RCT CSP2",199, 0)
  17849    .S ^XTMP( "RCTCSPD", $J,"BILL", "MSG",2)=" -----                                ---         ----        ---- --"
  17850   "RTN","RCT CSP2",200, 0)
  17851    .S X=0,RC NT=2 F  S  X=$O(^XTMP ("RCTCSPD" ,$J,"BILL" ,ACTION,X) ) Q:X=""   D
  17852   "RTN","RCT CSP2",201, 0)
  17853    ..S RCNT= RCNT+1
  17854   "RTN","RCT CSP2",202, 0)
  17855    ..S RCDAT 1=$P(^XTMP ("RCTCSPD" ,$J,"BILL" ,ACTION,X) ,U,1)
  17856   "RTN","RCT CSP2",203, 0)
  17857    ..S RCDAT 2=$P(^XTMP ("RCTCSPD" ,$J,"BILL" ,ACTION,X) ,U,2)
  17858   "RTN","RCT CSP2",204, 0)
  17859    ..S ^XTMP ("RCTCSPD" ,$J,"BILL" ,"MSG",RCN T)=$$RJZF( $P($G(^PRC A(430,X,0) ),U,1),7)_ $$BLANK(22 )_RCDAT1_"      "_ACT ION_"         "_$S(RC DAT2]"":RC DAT2,1:"")
  17860   "RTN","RCT CSP2",205, 0)
  17861    ..Q
  17862   "RTN","RCT CSP2",206, 0)
  17863    .S ^XTMP( "RCTCSPD", $J,"BILL", "MSG",RCNT +1)="Total  Bills: "_ (RCNT-2)
  17864   "RTN","RCT CSP2",207, 0)
  17865    .S XMTEXT ="^XTMP("" RCTCSPD"", "_$J_",""B ILL"",""MS G"","
  17866   "RTN","RCT CSP2",208, 0)
  17867    .D ^XMD
  17868   "RTN","RCT CSP2",209, 0)
  17869    .K ^XTMP( "RCTCSPD", $J,"BILL", "MSG")
  17870   "RTN","RCT CSP2",210, 0)
  17871    Q
  17872   "RTN","RCT CSP2",211, 0)
  17873    ;
  17874   "RTN","RCT CSP2",212, 0)
  17875   THIRD ;sen ds mailman  message t o user if  no third l etter foun d
  17876   "RTN","RCT CSP2",213, 0)
  17877    Q:'$D(^XT MP("RCTCSP D",$J,"THI RD"))
  17878   "RTN","RCT CSP2",214, 0)
  17879    N XMY,XMD UZ,XMSUB,X MTEXT
  17880   "RTN","RCT CSP2",215, 0)
  17881    S XMDUZ=" AR PACKAGE "
  17882   "RTN","RCT CSP2",216, 0)
  17883    S XMY("G. TCSP")=""
  17884   "RTN","RCT CSP2",217, 0)
  17885    N TCT,TDE B,TDEB0,TB IL,TSP,FST
  17886   "RTN","RCT CSP2",218, 0)
  17887    S XMSUB=" TCSP QUALI FIED/NO 3R D LETTER S ENT ON "_$ E(DT,4,5)_ "/"_$E(DT, 6,7)_"/"_$ E(DT,2,3)
  17888   "RTN","RCT CSP2",219, 0)
  17889    S ^XTMP(" RCTCSPD",$ J,"THIRD", 1)="The fo llowing li st of debt or bills w ere not se nt to TCSP ."
  17890   "RTN","RCT CSP2",220, 0)
  17891    S ^XTMP(" RCTCSPD",$ J,"THIRD", 2)="Please  review de btor's acc ount to de termine wh y the thir d"
  17892   "RTN","RCT CSP2",221, 0)
  17893    S ^XTMP(" RCTCSPD",$ J,"THIRD", 3)="notice  letter ha s not been  sent:"
  17894   "RTN","RCT CSP2",222, 0)
  17895    S ^XTMP(" RCTCSPD",$ J,"THIRD", 4)="Name                                  B ill #"
  17896   "RTN","RCT CSP2",223, 0)
  17897    S ^XTMP(" RCTCSPD",$ J,"THIRD", 5)="----                                  - -----"
  17898   "RTN","RCT CSP2",224, 0)
  17899    S TCT=6,T SP=0,TDEB= ""
  17900   "RTN","RCT CSP2",225, 0)
  17901    F  S TDEB =$O(^XTMP( "RCTCSPD", $J,"THIRD" ,TDEB)) Q: TDEB=""  D
  17902   "RTN","RCT CSP2",226, 0)
  17903    .S FST=1, TBIL=""
  17904   "RTN","RCT CSP2",227, 0)
  17905    .I FST,TC T'=6 S ^XT MP("RCTCSP D",$J,"THI RD",TCT)=" ",TCT=TCT+ 1,TSP=TSP+ 1
  17906   "RTN","RCT CSP2",228, 0)
  17907    .F  S TBI L=$O(^XTMP ("RCTCSPD" ,$J,"THIRD ",TDEB,TBI L)) Q:TBIL =""  D
  17908   "RTN","RCT CSP2",229, 0)
  17909    ..S TDEB0 =$S(FST:TD EB,1:"")
  17910   "RTN","RCT CSP2",230, 0)
  17911    ..S ^XTMP ("RCTCSPD" ,$J,"THIRD ",TCT)=TDE B0_$J(" ", 35-$L(TDEB 0))_TBIL
  17912   "RTN","RCT CSP2",231, 0)
  17913    ..S TCT=T CT+1,FST=0
  17914   "RTN","RCT CSP2",232, 0)
  17915    S ^XTMP(" RCTCSPD",$ J,"THIRD", TCT)="Tota l records:  "_(TCT-(6 +TSP))
  17916   "RTN","RCT CSP2",233, 0)
  17917    S XMTEXT= "^XTMP(""R CTCSPD""," _$J_",""TH IRD"","
  17918   "RTN","RCT CSP2",234, 0)
  17919    D ^XMD
  17920   "RTN","RCT CSP2",235, 0)
  17921    K ^XTMP(" RCTCSPD",$ J,"THIRD")
  17922   "RTN","RCT CSP2",236, 0)
  17923   THIRDQ Q
  17924   "RTN","RCT CSP2",237, 0)
  17925    ;
  17926   "RTN","RCT CSP2",238, 0)
  17927   REC3 ;
  17928   "RTN","RCT CSP2",239, 0)
  17929    N REC,KNU M,DEBTNR,D EBTORNB
  17930   "RTN","RCT CSP2",240, 0)
  17931    S REC="C3  "_ACTION_ "363600120 0"_"DM1D "
  17932   "RTN","RCT CSP2",241, 0)
  17933    S KNUM=$P ($P(B0,U,1 ),"-",2)
  17934   "RTN","RCT CSP2",242, 0)
  17935    S DEBTNR= $E(SITE,1, 3)_$$LJZF( KNUM,7)_$T R($J(BILL, 20)," ",0) ,REC=REC_D EBTNR
  17936   "RTN","RCT CSP2",243, 0)
  17937    S DEBTORN B=$E(SITE, 1,3)_$TR($ J(DEBTOR,1 2)," ",0)
  17938   "RTN","RCT CSP2",244, 0)
  17939    S REC=REC _DEBTORNB
  17940   "RTN","RCT CSP2",245, 0)
  17941    S REC=REC _$S(ACTION ="L":"15", 1:"  ")
  17942   "RTN","RCT CSP2",246, 0)
  17943    S REC=REC _"SLF"
  17944   "RTN","RCT CSP2",247, 0)
  17945    S REC=REC _$$BLANK(8 )
  17946   "RTN","RCT CSP2",248, 0)
  17947    S REC=REC _$$AMOUNT( 0)
  17948   "RTN","RCT CSP2",249, 0)
  17949    S REC=REC _$$BLANK(1 6)
  17950   "RTN","RCT CSP2",250, 0)
  17951    S REC=REC _"SLFIND"
  17952   "RTN","RCT CSP2",251, 0)
  17953    S REC=REC _$$BLANK(4 50-$L(REC) )
  17954   "RTN","RCT CSP2",252, 0)
  17955    S ^XTMP(" RCTCSPD",$ J,BILL,ACT ION,3)=REC
  17956   "RTN","RCT CSP2",253, 0)
  17957    S $P(^XTM P("RCTCSPD ",$J,"BILL ",ACTION,B ILL),U,1)= $$TAXID(DE BTOR)
  17958   "RTN","RCT CSP2",254, 0)
  17959    Q
  17960   "RTN","RCT CSP2",255, 0)
  17961    ;
  17962   "RTN","RCT CSP2",256, 0)
  17963   DATE8(X) ; changes fi leman date  into 8 di git date y yyymmdd
  17964   "RTN","RCT CSP2",257, 0)
  17965    I +X S X= X+17000000
  17966   "RTN","RCT CSP2",258, 0)
  17967    S X=$E(X, 1,8)
  17968   "RTN","RCT CSP2",259, 0)
  17969    Q X
  17970   "RTN","RCT CSP2",260, 0)
  17971    ;
  17972   "RTN","RCT CSP2",261, 0)
  17973   AMOUNT(X)  ;changes a mount to z ero filled , right ju stified
  17974   "RTN","RCT CSP2",262, 0)
  17975    S:X<0 X=- X
  17976   "RTN","RCT CSP2",263, 0)
  17977    S X=$TR($ J(X,0,2)," .")
  17978   "RTN","RCT CSP2",264, 0)
  17979    S X=$E("0 0000000000 0",1,14-$L (X))_X
  17980   "RTN","RCT CSP2",265, 0)
  17981    Q X
  17982   "RTN","RCT CSP2",266, 0)
  17983    ;
  17984   "RTN","RCT CSP2",267, 0)
  17985   BLANK(X) ; returns 'x ' blank sp aces
  17986   "RTN","RCT CSP2",268, 0)
  17987    N BLANK
  17988   "RTN","RCT CSP2",269, 0)
  17989    S BLANK=" ",$P(BLANK ," ",X+1)= ""
  17990   "RTN","RCT CSP2",270, 0)
  17991    Q BLANK
  17992   "RTN","RCT CSP2",271, 0)
  17993    ;
  17994   "RTN","RCT CSP2",272, 0)
  17995   RJZF(X,Y)  ;right jus tify zero  fill width  Y
  17996   "RTN","RCT CSP2",273, 0)
  17997    S X=$E("0 0000000000 0",1,Y-$L( X))_X
  17998   "RTN","RCT CSP2",274, 0)
  17999    Q X
  18000   "RTN","RCT CSP2",275, 0)
  18001    ;
  18002   "RTN","RCT CSP2",276, 0)
  18003   LJSF(X,Y)  ;left just ified spac e filled
  18004   "RTN","RCT CSP2",277, 0)
  18005    S X=$E(X, 1,Y)
  18006   "RTN","RCT CSP2",278, 0)
  18007    S X=X_$$B LANK(Y-$L( X))
  18008   "RTN","RCT CSP2",279, 0)
  18009    Q X
  18010   "RTN","RCT CSP2",280, 0)
  18011    ;
  18012   "RTN","RCT CSP2",281, 0)
  18013   LJZF(X,Y)  ;x left ju stified, y  zero fill ed
  18014   "RTN","RCT CSP2",282, 0)
  18015    S X=X_"00 00000000"
  18016   "RTN","RCT CSP2",283, 0)
  18017    S X=$E(X, X,Y)
  18018   "RTN","RCT CSP2",284, 0)
  18019    Q X
  18020   "RTN","RCT CSP2",285, 0)
  18021    ;
  18022   "RTN","RCT CSP2",286, 0)
  18023   TAXID(DEBT OR) ;compu tes TAXID  to place o n document s
  18024   "RTN","RCT CSP2",287, 0)
  18025    N TAXID,D IC,DA,DR,D IQ
  18026   "RTN","RCT CSP2",288, 0)
  18027    S TAXID=$ $SSN^RCFN0 1(DEBTOR)
  18028   "RTN","RCT CSP2",289, 0)
  18029    S TAXID=$ $LJSF(TAXI D,9)
  18030   "RTN","RCT CSP2",290, 0)
  18031    Q TAXID
  18032   "RTN","RCT CSP2",291, 0)
  18033    ;
  18034   "RTN","RCT CSP2",292, 0)
  18035   DTFRMTO(PR OMPT) ;Get  from and  to dates   (added as  per PRCA*4 .5*315 to  be able to  sort by d ates for r eports)
  18036   "RTN","RCT CSP2",293, 0)
  18037    ;INPUT:
  18038   "RTN","RCT CSP2",294, 0)
  18039    ;   PROMP T - Messag e to displ ay prior t o promptin g for date s
  18040   "RTN","RCT CSP2",295, 0)
  18041    ;OUTPUT:
  18042   "RTN","RCT CSP2",296, 0)
  18043    ;    1^BE GDT^ENDDT  - Data fou nd
  18044   "RTN","RCT CSP2",297, 0)
  18045    ;    0               - User up  arrowed or  timed out
  18046   "RTN","RCT CSP2",298, 0)
  18047    ;
  18048   "RTN","RCT CSP2",299, 0)
  18049    N %DT,Y,X ,BEGDT,END DT,DTOUT,O UT,DIRUT,D UOUT,DIROU T
  18050   "RTN","RCT CSP2",300, 0)
  18051    S OUT=0
  18052   "RTN","RCT CSP2",301, 0)
  18053    W !,$G(PR OMPT)
  18054   "RTN","RCT CSP2",302, 0)
  18055    S %DT="AE X"
  18056   "RTN","RCT CSP2",303, 0)
  18057    S %DT("A" )="Date Ra nge: FROM:  " ;Enter  Beginning  Date: "
  18058   "RTN","RCT CSP2",304, 0)
  18059    S %DT("B" )="T-30"
  18060   "RTN","RCT CSP2",305, 0)
  18061    W !
  18062   "RTN","RCT CSP2",306, 0)
  18063    D ^%DT
  18064   "RTN","RCT CSP2",307, 0)
  18065    K %DT
  18066   "RTN","RCT CSP2",308, 0)
  18067    Q:Y<0 OUT   ;Quit if  user time  out or di dn't enter  valid dat e
  18068   "RTN","RCT CSP2",309, 0)
  18069    S DTFROM= +Y
  18070   "RTN","RCT CSP2",310, 0)
  18071    S %DT="AE X"
  18072   "RTN","RCT CSP2",311, 0)
  18073    S %DT("A" )="               TO:    ",%DT(" B")="T" ;" TODAY"
  18074   "RTN","RCT CSP2",312, 0)
  18075    D ^%DT
  18076   "RTN","RCT CSP2",313, 0)
  18077    K %DT
  18078   "RTN","RCT CSP2",314, 0)
  18079    ;Quit if  user time  out or did n't enter  valid date
  18080   "RTN","RCT CSP2",315, 0)
  18081    Q:Y<0 OUT
  18082   "RTN","RCT CSP2",316, 0)
  18083    S DTTO=+Y
  18084   "RTN","RCT CSP2",317, 0)
  18085    S OUT=1_U _DTFROM_U_ DTTO
  18086   "RTN","RCT CSP2",318, 0)
  18087    ;Switch d ates if Be gin Date i s more rec ent than E nd Date
  18088   "RTN","RCT CSP2",319, 0)
  18089    S:DTFROM> DTTO OUT=1 _U_DTTO_U_ DTFROM
  18090   "RTN","RCT CSP2",320, 0)
  18091    Q OUT
  18092   "RTN","RCT CSP2",321, 0)
  18093    ;
  18094   "RTN","RCT CSP3")
  18095   0^22^B8043 0487^B7980 2534
  18096   "RTN","RCT CSP3",1,0)
  18097   RCTCSP3 ;A LBANY/BDB- CROSS-SERV ICING TRAN SMISSION ; 03/15/14 3 :34 PM
  18098   "RTN","RCT CSP3",2,0)
  18099    ;;4.5;Acc ounts Rece ivable;**3 01,315**;M ar 20, 199 5;Build 55
  18100   "RTN","RCT CSP3",3,0)
  18101    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  18102   "RTN","RCT CSP3",4,0)
  18103    ;
  18104   "RTN","RCT CSP3",5,0)
  18105    Q
  18106   "RTN","RCT CSP3",6,0)
  18107    ;
  18108   "RTN","RCT CSP3",7,0)
  18109   ENTER ;Ent ry point f rom the po st initial ization
  18110   "RTN","RCT CSP3",8,0)
  18111   RCCSTUP I  '$D(^XTMP( "REJCDCONV ")) D
  18112   "RTN","RCT CSP3",9,0)
  18113    . D NOW^% DTC S RCCS TART=%
  18114   "RTN","RCT CSP3",10,0 )
  18115    . S ^XTMP ("REJCDCON V","START  COMPILE")= RCCSTART
  18116   "RTN","RCT CSP3",11,0 )
  18117    . S ^XTMP ("REJCDCON V","STATUS ")="RUNNIN G"
  18118   "RTN","RCT CSP3",12,0 )
  18119    . S ^XTMP ("REJCDCON V",0)=$$FM ADD^XLFDT( RCCSTART,7 30)_"^"_RC CSTART
  18120   "RTN","RCT CSP3",13,0 )
  18121    S RCCCMPL T=0 I $G(^ XTMP("REJC DCONV","ST ATUS"))="C OMPLETE" S  RCCCMPLT= 1
  18122   "RTN","RCT CSP3",14,0 )
  18123   AA N DEBTO R
  18124   "RTN","RCT CSP3",15,0 )
  18125    S DEBTOR= 0
  18126   "RTN","RCT CSP3",16,0 )
  18127    F  S DEBT OR=$O(^PRC A(430,"C", DEBTOR)) Q :DEBTOR'?1 N.N  D
  18128   "RTN","RCT CSP3",17,0 )
  18129    .N X,RCDF N,DEMCS,DE BTOR0,DEBT OR1,DEBTOR 7,BILL
  18130   "RTN","RCT CSP3",18,0 )
  18131    .S DEBTOR 0=^RCD(340 ,DEBTOR,0) ,DEBTOR1=$ G(^(1)),DE BTOR7=$G(^ (7))
  18132   "RTN","RCT CSP3",19,0 )
  18133    .S RCDFN= +DEBTOR0
  18134   "RTN","RCT CSP3",20,0 )
  18135    .S DEMCS= $$DEM^RCTC SP1(RCDFN)  Q:$E($P(D EMCS,U,3), 1,5)="0000 0"
  18136   "RTN","RCT CSP3",21,0 )
  18137    .Q:+$P(DE MCS,U,4)   ;deceased  patient
  18138   "RTN","RCT CSP3",22,0 )
  18139    .S BILL=0
  18140   "RTN","RCT CSP3",23,0 )
  18141    .F  S BIL L=$O(^PRCA (430,"C",D EBTOR,BILL )) Q:BILL' ?1N.N  D
  18142   "RTN","RCT CSP3",24,0 )
  18143    ..N B0,B6 ,B7,B14,CA T,TOTAL
  18144   "RTN","RCT CSP3",25,0 )
  18145    ..S B0=$G (^PRCA(430 ,BILL,0)), B6=$G(^(6) ),B7=$G(^( 7)),B14=$G (^(14))
  18146   "RTN","RCT CSP3",26,0 )
  18147    ..I 'RCCC MPLT,$D(^P RCA(430,BI LL,18)) D  REJCODE
  18148   "RTN","RCT CSP3",27,0 )
  18149    ..I $D(^P RCA(430,"T CSP",BILL) ) Q  ;no d pn for cs  bills
  18150   "RTN","RCT CSP3",28,0 )
  18151    ..Q:'$P(B 0,U,2)  ;n o category
  18152   "RTN","RCT CSP3",29,0 )
  18153    ..S CAT=$ P($G(^PRCA (430.2,$P( B0,U,2),0) ),U,7)
  18154   "RTN","RCT CSP3",30,0 )
  18155    ..Q:'CAT
  18156   "RTN","RCT CSP3",31,0 )
  18157    ..I ",4,5 ,6,7,8,9,1 0,11,12,13 ,14,15,16, 17,18,19,2 0,21,22,23 ,25,26,27, 28,33,34,3 5,36,37,38 ,39,"[("," _CAT_",")  Q  ;1st pa rty check
  18158   "RTN","RCT CSP3",32,0 )
  18159    ..I +$P(B 14,U,1) Q   ;bill ref erred to T OP
  18160   "RTN","RCT CSP3",33,0 )
  18161    ..S TOTAL =$P(B7,U)+ $P(B7,U,2) +$P(B7,U,3 )+$P(B7,U, 4)+$P(B7,U ,5)
  18162   "RTN","RCT CSP3",34,0 )
  18163    ..I TOTAL '>0 Q  ;to tal must b e greater  than zero
  18164   "RTN","RCT CSP3",35,0 )
  18165    ..I '$P(B 0,U,8) Q   ;if no cur rent statu s
  18166   "RTN","RCT CSP3",36,0 )
  18167    ..I $P(B0 ,U,8)=23 Q   ;quit if  write-off
  18168   "RTN","RCT CSP3",37,0 )
  18169    ..I $P(B0 ,U,8)=26 Q   ;quit if  cancelled
  18170   "RTN","RCT CSP3",38,0 )
  18171    ..I $P(B0 ,U,8)=39 Q   ;quit if  cancellat ion
  18172   "RTN","RCT CSP3",39,0 )
  18173    ..I TOTAL <25 S $P(^ PRCA(430,B ILL,20),U, 3,8)="1^^^ ^^" ;set d pn flag
  18174   "RTN","RCT CSP3",40,0 )
  18175    ..Q
  18176   "RTN","RCT CSP3",41,0 )
  18177    .Q
  18178   "RTN","RCT CSP3",42,0 )
  18179    I RCCCMPL T'=1 D
  18180   "RTN","RCT CSP3",43,0 )
  18181    . D NOW^% DTC S RCCE ND=%
  18182   "RTN","RCT CSP3",44,0 )
  18183    . S ^XTMP ("REJCDCON V","END RE J CODE CON V")=RCCEND
  18184   "RTN","RCT CSP3",45,0 )
  18185    . S ^XTMP ("REJCDCON V","STATUS ")="COMPLE TE"
  18186   "RTN","RCT CSP3",46,0 )
  18187    Q
  18188   "RTN","RCT CSP3",47,0 )
  18189    ;  
  18190   "RTN","RCT CSP3",48,0 )
  18191   DUEPROC ;  called fro m rctcspd
  18192   "RTN","RCT CSP3",49,0 )
  18193    N TOTAL
  18194   "RTN","RCT CSP3",50,0 )
  18195    S TOTAL=$ P(B7,U)+$P (B7,U,2)+$ P(B7,U,3)+ $P(B7,U,4) +$P(B7,U,5 )
  18196   "RTN","RCT CSP3",51,0 )
  18197    I TOTAL<2 5 Q  ;no d pn record  for bills  less than  $25
  18198   "RTN","RCT CSP3",52,0 )
  18199    I $P($G(D EBTOR3),U, 10) Q  ;ch eck site d elete flag  null
  18200   "RTN","RCT CSP3",53,0 )
  18201    I +$P(B12 ,U,1) Q  ; check date  bill sent  to dmc
  18202   "RTN","RCT CSP3",54,0 )
  18203    I $P(B6,U ,4),($P(B6 ,U,5)="DOJ ") Q  ;bil l referred  to doj
  18204   "RTN","RCT CSP3",55,0 )
  18205    I $P(B0,U ,8)'=16 Q   ;status a ctive
  18206   "RTN","RCT CSP3",56,0 )
  18207    I '$P(B6, U,3) Q  ;m ust have a  3rd lette r
  18208   "RTN","RCT CSP3",57,0 )
  18209    D RECDPN  ;create a  dpn record
  18210   "RTN","RCT CSP3",58,0 )
  18211    Q
  18212   "RTN","RCT CSP3",59,0 )
  18213    ;
  18214   "RTN","RCT CSP3",60,0 )
  18215   RECDPN ;
  18216   "RTN","RCT CSP3",61,0 )
  18217    N KNUM,NA ME
  18218   "RTN","RCT CSP3",62,0 )
  18219    S REC="C"
  18220   "RTN","RCT CSP3",63,0 )
  18221    S REC=REC _$$RJZF(BI LL,10)
  18222   "RTN","RCT CSP3",64,0 )
  18223    S REC=REC _$$TAXID(D EBTOR)
  18224   "RTN","RCT CSP3",65,0 )
  18225    S NAME=$$ NAMEFF(+DE BTOR0),NAM E=$P(NAME, U)
  18226   "RTN","RCT CSP3",66,0 )
  18227    S REC=REC _$$LJSF(NA ME,30)
  18228   "RTN","RCT CSP3",67,0 )
  18229    S RCDFN=+ DEBTOR0
  18230   "RTN","RCT CSP3",68,0 )
  18231    S ADDRCS= $$ADDR(RCD FN)
  18232   "RTN","RCT CSP3",69,0 )
  18233    S REC=REC _$$LJSF($P (ADDRCS,U, 1),35)_$$L JSF($P(ADD RCS,U,2),3 5)_$$LJSF( $P(ADDRCS, U,3),15)
  18234   "RTN","RCT CSP3",70,0 )
  18235    S REC=REC _$$LJSF($P (ADDRCS,U, 8),20)
  18236   "RTN","RCT CSP3",71,0 )
  18237    S REC=REC _$$BLANK(5 )
  18238   "RTN","RCT CSP3",72,0 )
  18239    S REC=REC _$$LJSF($P (ADDRCS,U, 4),2)_$$LJ SF($P(ADDR CS,U,5),9)
  18240   "RTN","RCT CSP3",73,0 )
  18241    S REC=REC _$$COUNTRY ^RCTCSP1A( $P(ADDRCS, U,7))  ;Ch anged rout ine due to  SACC size  issue PRC A*4.5*315
  18242   "RTN","RCT CSP3",74,0 )
  18243    S TOTAL=$ P(B7,U)+$P (B7,U,2)+$ P(B7,U,3)+ $P(B7,U,4) +$P(B7,U,5 )
  18244   "RTN","RCT CSP3",75,0 )
  18245    S REC=REC _$$BLANK(9 )
  18246   "RTN","RCT CSP3",76,0 )
  18247    S REC=REC _$$DATE8(+ $P(B6,U,21 ))
  18248   "RTN","RCT CSP3",77,0 )
  18249    S KNUM=$P ($P(B0,U,1 ),"-",2)
  18250   "RTN","RCT CSP3",78,0 )
  18251    S REC=REC _$E(SITE,1 ,3)_$$LJSF (KNUM,7)
  18252   "RTN","RCT CSP3",79,0 )
  18253    S REC=REC _$$AMOUNT9 (TOTAL)
  18254   "RTN","RCT CSP3",80,0 )
  18255    S REC=REC _$$LJSF($P (ADDRCS,U, 9),10)
  18256   "RTN","RCT CSP3",81,0 )
  18257    S REC=REC _$S($P(ADD RCS,U,9)=" ":" ",$P(A DDRCS,U,9) ="US":" ", 1:"F")
  18258   "RTN","RCT CSP3",82,0 )
  18259    S REC=REC _$$BLANK(2 50-$L(REC) )
  18260   "RTN","RCT CSP3",83,0 )
  18261    S $P(^PRC A(430,BILL ,20),U,4)= DT ;set th e dpn requ est date
  18262   "RTN","RCT CSP3",84,0 )
  18263    S $P(^PRC A(430,BILL ,20),U,5,8 )="^^^" ;c lear the p rint date  and error  codes
  18264   "RTN","RCT CSP3",85,0 )
  18265    S ^XTMP(" RCTCSPDN", $J,BILL,"D PN",1)=REC
  18266   "RTN","RCT CSP3",86,0 )
  18267    S ^XTMP(" RCTCSPDN", $J,"BILL", "DPN",BILL )=$$TAXID( DEBTOR)_"^ "_+$E(REC, 201,207)_" ."_$E(REC, 208,209) ; sends mail man messag e of docum ents sent  to user
  18268   "RTN","RCT CSP3",87,0 )
  18269    Q
  18270   "RTN","RCT CSP3",88,0 )
  18271    ;
  18272   "RTN","RCT CSP3",89,0 )
  18273   COMPILED ;
  18274   "RTN","RCT CSP3",90,0 )
  18275    N RCMSG,B CNTR,REC,R ECC,AMOUNT ,AMOUNT,RC NTR,ACTION ,SEQ,EOF
  18276   "RTN","RCT CSP3",91,0 )
  18277    S BCNTR=0 ,REC=0,REC C=0,AMOUNT =0,SEQ=0,E OF=0
  18278   "RTN","RCT CSP3",92,0 )
  18279    F  S BCNT R=$O(^XTMP ("RCTCSPDN ",$J,BCNTR )) S:+BCNT R'>0 EOF=1  Q:+BCNTR' >0  D
  18280   "RTN","RCT CSP3",93,0 )
  18281    .I REC>12 0 D
  18282   "RTN","RCT CSP3",94,0 )
  18283    ..D TRAIL ERD
  18284   "RTN","RCT CSP3",95,0 )
  18285    ..D AITCM SGD
  18286   "RTN","RCT CSP3",96,0 )
  18287    ..S REC=0 ,RECC=0
  18288   "RTN","RCT CSP3",97,0 )
  18289    ..Q
  18290   "RTN","RCT CSP3",98,0 )
  18291    .S ACTION ="DPN"
  18292   "RTN","RCT CSP3",99,0 )
  18293    .I REC=0  D HEADERD
  18294   "RTN","RCT CSP3",100, 0)
  18295    .S RCNTR= 1 I $D(^XT MP("RCTCSP DN",$J,BCN TR,ACTION, RCNTR)) D
  18296   "RTN","RCT CSP3",101, 0)
  18297    ..S REC=R EC+1
  18298   "RTN","RCT CSP3",102, 0)
  18299    ..S RECC= RECC+1 ;re cord count  for 'c' r ecords on  trailer re cord
  18300   "RTN","RCT CSP3",103, 0)
  18301    ..S ^XTMP ("RCTCSPDN ",$J,SEQ," BUILD",REC )=^XTMP("R CTCSPDN",$ J,BCNTR,AC TION,RCNTR )_$C(126)
  18302   "RTN","RCT CSP3",104, 0)
  18303    ..S AMOUN T=AMOUNT+$ E(^XTMP("R CTCSPDN",$ J,BCNTR,AC TION,RCNTR ),201,209)
  18304   "RTN","RCT CSP3",105, 0)
  18305    ..Q
  18306   "RTN","RCT CSP3",106, 0)
  18307    .Q
  18308   "RTN","RCT CSP3",107, 0)
  18309    D TRAILER D
  18310   "RTN","RCT CSP3",108, 0)
  18311    D AITCMSG D
  18312   "RTN","RCT CSP3",109, 0)
  18313    D USRMSGD
  18314   "RTN","RCT CSP3",110, 0)
  18315    Q
  18316   "RTN","RCT CSP3",111, 0)
  18317    ;
  18318   "RTN","RCT CSP3",112, 0)
  18319   AITCMSGD ;
  18320   "RTN","RCT CSP3",113, 0)
  18321    N XMY,XMD UZ,XMSUB,X MTEXT
  18322   "RTN","RCT CSP3",114, 0)
  18323    Q:'$D(^XT MP("RCTCSP DN",$J))
  18324   "RTN","RCT CSP3",115, 0)
  18325    S CNTLID= $$JD()_$$R JZF(SEQ,4)
  18326   "RTN","RCT CSP3",116, 0)
  18327    S XMDUZ=" AR PACKAGE "
  18328   "RTN","RCT CSP3",117, 0)
  18329    S XMY(" UR L           ")=""
  18330   "RTN","RCT CSP3",118, 0)
  18331    S XMY("G. TCSP")=""
  18332   "RTN","RCT CSP3",119, 0)
  18333    S XMSUB=S ITE_"/DPN  TRANSMISSI ON/BATCH#:  "_CNTLID
  18334   "RTN","RCT CSP3",120, 0)
  18335    S XMTEXT= "^XTMP(""R CTCSPDN"", "_$J_",""" _SEQ_"""," "BUILD"","
  18336   "RTN","RCT CSP3",121, 0)
  18337    D ^XMD
  18338   "RTN","RCT CSP3",122, 0)
  18339    Q
  18340   "RTN","RCT CSP3",123, 0)
  18341    ;
  18342   "RTN","RCT CSP3",124, 0)
  18343   USRMSGD ;s ends mailm an message  of docume nts sent t o user
  18344   "RTN","RCT CSP3",125, 0)
  18345    N XMY,XMD UZ,XMSUB,X MTEXT,X,RC NT,RCDAT1, RCDAT2
  18346   "RTN","RCT CSP3",126, 0)
  18347    Q:'$D(^XT MP("RCTCSP DN",$J))
  18348   "RTN","RCT CSP3",127, 0)
  18349    S ACTION= "DPN"
  18350   "RTN","RCT CSP3",128, 0)
  18351    K ^XTMP(" RCTCSPDN", $J,"BILL", "MSG")
  18352   "RTN","RCT CSP3",129, 0)
  18353    S XMDUZ=" AR PACKAGE "
  18354   "RTN","RCT CSP3",130, 0)
  18355    S XMY("G. TCSP")=""
  18356   "RTN","RCT CSP3",131, 0)
  18357    S XMSUB=" CS DUE PRO CESS"_" SE NT ON "_$E (DT,4,5)_" /"_$E(DT,6 ,7)_"/"_$E (DT,2,3)_"  BATCH ID:  "_CNTLID
  18358   "RTN","RCT CSP3",132, 0)
  18359    S ^XTMP(" RCTCSPDN", $J,"BILL", "MSG",1)=" Bill#                               TIN          TYPE        AMOU NT"
  18360   "RTN","RCT CSP3",133, 0)
  18361    S ^XTMP(" RCTCSPDN", $J,"BILL", "MSG",2)=" -----                               ---          ----        ---- --"
  18362   "RTN","RCT CSP3",134, 0)
  18363    S X=0,RCN T=2 F  S X =$O(^XTMP( "RCTCSPDN" ,$J,"BILL" ,ACTION,X) ) Q:X=""   D
  18364   "RTN","RCT CSP3",135, 0)
  18365    .S RCNT=R CNT+1
  18366   "RTN","RCT CSP3",136, 0)
  18367    .S RCDAT1 =$P(^XTMP( "RCTCSPDN" ,$J,"BILL" ,ACTION,X) ,U,1)
  18368   "RTN","RCT CSP3",137, 0)
  18369    .S RCDAT2 =$P(^XTMP( "RCTCSPDN" ,$J,"BILL" ,ACTION,X) ,U,2)
  18370   "RTN","RCT CSP3",138, 0)
  18371    .S ^XTMP( "RCTCSPDN" ,$J,"BILL" ,"MSG",RCN T)=$$RJZF( $P($G(^PRC A(430,X,0) ),U,1),7)_ $$BLANK(22 )_RCDAT1_"    "_ACTIO N_"         "_$S(RCDA T2]"":RCDA T2,1:"")
  18372   "RTN","RCT CSP3",139, 0)
  18373    .Q
  18374   "RTN","RCT CSP3",140, 0)
  18375    S ^XTMP(" RCTCSPDN", $J,"BILL", "MSG",RCNT +1)="Total  Bills: "_ (RCNT-2)
  18376   "RTN","RCT CSP3",141, 0)
  18377    S XMTEXT= "^XTMP(""R CTCSPDN"", "_$J_",""B ILL"",""MS G"","
  18378   "RTN","RCT CSP3",142, 0)
  18379    D ^XMD
  18380   "RTN","RCT CSP3",143, 0)
  18381    K ^XTMP(" RCTCSPDN", $J,"BILL", "MSG")
  18382   "RTN","RCT CSP3",144, 0)
  18383    Q
  18384   "RTN","RCT CSP3",145, 0)
  18385    ;
  18386   "RTN","RCT CSP3",146, 0)
  18387   HEADERD ;
  18388   "RTN","RCT CSP3",147, 0)
  18389    ;incremen t batch se quence num ber, build  new heade r
  18390   "RTN","RCT CSP3",148, 0)
  18391    N RCMSG
  18392   "RTN","RCT CSP3",149, 0)
  18393    S SEQ=SEQ +1
  18394   "RTN","RCT CSP3",150, 0)
  18395    S CNTLID= $$JD()_$$R JZF(SEQ,4)
  18396   "RTN","RCT CSP3",151, 0)
  18397    K ^XTMP(" RCTCSPDN", $J,ACTION, "BUILD",SE Q)
  18398   "RTN","RCT CSP3",152, 0)
  18399    S RCMSG=" H"_CNTLID_ $$BLANK(14 )_"3636001 200" ;head er is reco rd type H
  18400   "RTN","RCT CSP3",153, 0)
  18401    S RCMSG=R CMSG_$$BLA NK(250-$L( RCMSG))
  18402   "RTN","RCT CSP3",154, 0)
  18403    S REC=REC +1
  18404   "RTN","RCT CSP3",155, 0)
  18405    S ^XTMP(" RCTCSPDN", $J,SEQ,"BU ILD",REC)= RCMSG_$C(1 26)
  18406   "RTN","RCT CSP3",156, 0)
  18407    Q
  18408   "RTN","RCT CSP3",157, 0)
  18409    ;
  18410   "RTN","RCT CSP3",158, 0)
  18411   TRAILERD ;
  18412   "RTN","RCT CSP3",159, 0)
  18413    ;trailer  is type Z  record
  18414   "RTN","RCT CSP3",160, 0)
  18415    I REC=0 K  ^XTMP("RC TCSPDN",$J ,SEQ,"BUIL D") Q  ;de lete batch  if no rec ords proce ssed
  18416   "RTN","RCT CSP3",161, 0)
  18417    N RCMSG
  18418   "RTN","RCT CSP3",162, 0)
  18419    S CNTLID= $$JD()_$$R JZF(SEQ,4)
  18420   "RTN","RCT CSP3",163, 0)
  18421    S RCMSG=" Z"_$$RJZF( RECC,8)_$$ AMOUNT(AMO UNT/100)_C NTLID_$$BL ANK(14)_"3 636001200"
  18422   "RTN","RCT CSP3",164, 0)
  18423    S RCMSG=R CMSG_$$BLA NK(250-$L( RCMSG))
  18424   "RTN","RCT CSP3",165, 0)
  18425    S:EOF $E( RCMSG,229, 236)="0001 "_$$RJZF(S EQ,4)
  18426   "RTN","RCT CSP3",166, 0)
  18427    S REC=REC +1
  18428   "RTN","RCT CSP3",167, 0)
  18429    S ^XTMP(" RCTCSPDN", $J,SEQ,"BU ILD",REC)= RCMSG_$C(1 26)
  18430   "RTN","RCT CSP3",168, 0)
  18431    S REC=0,R ECC=0,AMOU NT=0
  18432   "RTN","RCT CSP3",169, 0)
  18433    Q
  18434   "RTN","RCT CSP3",170, 0)
  18435    ;
  18436   "RTN","RCT CSP3",171, 0)
  18437   DATE8(X) ; changes fi leman date  into 8 di git date y yyymmdd
  18438   "RTN","RCT CSP3",172, 0)
  18439    I +X S X= X+17000000
  18440   "RTN","RCT CSP3",173, 0)
  18441    S X=$E(X, 1,8)
  18442   "RTN","RCT CSP3",174, 0)
  18443    Q X
  18444   "RTN","RCT CSP3",175, 0)
  18445    ;
  18446   "RTN","RCT CSP3",176, 0)
  18447   AMOUNT(X)  ;changes a mount to z ero filled , right ju stified, 1 4 characte rs
  18448   "RTN","RCT CSP3",177, 0)
  18449    S:X<0 X=- X
  18450   "RTN","RCT CSP3",178, 0)
  18451    S X=$TR($ J(X,0,2)," .")
  18452   "RTN","RCT CSP3",179, 0)
  18453    S X=$E("0 0000000000 0",1,14-$L (X))_X
  18454   "RTN","RCT CSP3",180, 0)
  18455    Q X
  18456   "RTN","RCT CSP3",181, 0)
  18457    ;
  18458   "RTN","RCT CSP3",182, 0)
  18459   AMOUNT9(X)  ;changes  amount to  zero fille d, right j ustified
  18460   "RTN","RCT CSP3",183, 0)
  18461    S:X<0 X=- X
  18462   "RTN","RCT CSP3",184, 0)
  18463    S X=$TR($ J(X,0,2)," .")
  18464   "RTN","RCT CSP3",185, 0)
  18465    S X=$E("0 0000000000 0",1,9-$L( X))_X
  18466   "RTN","RCT CSP3",186, 0)
  18467    Q X
  18468   "RTN","RCT CSP3",187, 0)
  18469    ;
  18470   "RTN","RCT CSP3",188, 0)
  18471   BLANK(X) ; returns 'x ' blank sp aces
  18472   "RTN","RCT CSP3",189, 0)
  18473    N BLANK
  18474   "RTN","RCT CSP3",190, 0)
  18475    S BLANK=" ",$P(BLANK ," ",X+1)= ""
  18476   "RTN","RCT CSP3",191, 0)
  18477    Q BLANK
  18478   "RTN","RCT CSP3",192, 0)
  18479    ;
  18480   "RTN","RCT CSP3",193, 0)
  18481   RJZF(X,Y)  ;right jus tify zero  fill width  Y
  18482   "RTN","RCT CSP3",194, 0)
  18483    S X=$E("0 0000000000 0",1,Y-$L( X))_X
  18484   "RTN","RCT CSP3",195, 0)
  18485    Q X
  18486   "RTN","RCT CSP3",196, 0)
  18487    ;
  18488   "RTN","RCT CSP3",197, 0)
  18489   LJSF(X,Y)  ;left just ified spac e filled
  18490   "RTN","RCT CSP3",198, 0)
  18491    S X=$E(X, 1,Y)
  18492   "RTN","RCT CSP3",199, 0)
  18493    S X=X_$$B LANK(Y-$L( X))
  18494   "RTN","RCT CSP3",200, 0)
  18495    Q X
  18496   "RTN","RCT CSP3",201, 0)
  18497    ;
  18498   "RTN","RCT CSP3",202, 0)
  18499   LJZF(X,Y)  ;x left ju stified, y  zero fill ed
  18500   "RTN","RCT CSP3",203, 0)
  18501    S X=X_"00 00000000"
  18502   "RTN","RCT CSP3",204, 0)
  18503    S X=$E(X, X,Y)
  18504   "RTN","RCT CSP3",205, 0)
  18505    Q X
  18506   "RTN","RCT CSP3",206, 0)
  18507    ;
  18508   "RTN","RCT CSP3",207, 0)
  18509   TAXID(DEBT OR) ;compu tes TAXID  to place o n document s
  18510   "RTN","RCT CSP3",208, 0)
  18511    N TAXID,D IC,DA,DR,D IQ
  18512   "RTN","RCT CSP3",209, 0)
  18513    S TAXID=$ $SSN^RCFN0 1(DEBTOR)
  18514   "RTN","RCT CSP3",210, 0)
  18515    S TAXID=$ $LJSF(TAXI D,9)
  18516   "RTN","RCT CSP3",211, 0)
  18517    Q TAXID
  18518   "RTN","RCT CSP3",212, 0)
  18519    ;
  18520   "RTN","RCT CSP3",213, 0)
  18521   JD() ; ret urns today 's Julian  date YDOY
  18522   "RTN","RCT CSP3",214, 0)
  18523    N XMDDD,X MNOW,XMDT
  18524   "RTN","RCT CSP3",215, 0)
  18525    S XMNOW=$ $NOW^XLFDT
  18526   "RTN","RCT CSP3",216, 0)
  18527    S XMDT=$E (XMNOW,1,7 )
  18528   "RTN","RCT CSP3",217, 0)
  18529    S XMDDD=$ $RJ^XLFSTR ($$FMDIFF^ XLFDT(XMDT ,$E(XMDT,1 ,3)_"0101" ,1)+1,3,"0 ")
  18530   "RTN","RCT CSP3",218, 0)
  18531    Q $E(DT,3 )_XMDDD
  18532   "RTN","RCT CSP3",219, 0)
  18533    ;
  18534   "RTN","RCT CSP3",220, 0)
  18535   NAMEFF(DFN ) ;returns  name for  document a nd name in  file
  18536   "RTN","RCT CSP3",221, 0)
  18537    N FN,LN,M N,NM,DOCNM ,VA,VADM
  18538   "RTN","RCT CSP3",222, 0)
  18539    S NM=""
  18540   "RTN","RCT CSP3",223, 0)
  18541    D DEM^VAD PT
  18542   "RTN","RCT CSP3",224, 0)
  18543    I $D(VADM ) S NM=VAD M(1)
  18544   "RTN","RCT CSP3",225, 0)
  18545    S LN=$TR( $P(NM,",") ," .'-"),M N=$P($P(NM ,",",2),"  ",2)
  18546   "RTN","RCT CSP3",226, 0)
  18547    I ($E(MN, 1,2)="SR") !($E(MN,1, 2)="JR")!( MN?2.3"I") !(MN?0.1"I "1"V"1.3"I ") S MN=""
  18548   "RTN","RCT CSP3",227, 0)
  18549    S FN=$P($ P(NM,",",2 )," ")
  18550   "RTN","RCT CSP3",228, 0)
  18551    S DOCNM=L N_", "_FN_ " "_MN
  18552   "RTN","RCT CSP3",229, 0)
  18553    Q DOCNM
  18554   "RTN","RCT CSP3",230, 0)
  18555    ;
  18556   "RTN","RCT CSP3",231, 0)
  18557   ADDR(RCDFN ) ; return s patient  file addre ss
  18558   "RTN","RCT CSP3",232, 0)
  18559    N DFN,ADD RCS,STATEI EN,STATEAB ,VAPA
  18560   "RTN","RCT CSP3",233, 0)
  18561    S DFN=RCD FN
  18562   "RTN","RCT CSP3",234, 0)
  18563    D ADD^VAD PT
  18564   "RTN","RCT CSP3",235, 0)
  18565    S STATEIE N=+VAPA(5) ,STATEAB=$ $GET1^DIQ( 5,STATEIEN ,1)
  18566   "RTN","RCT CSP3",236, 0)
  18567    S ADDRCS= VAPA(1)_U_ VAPA(2)_U_ VAPA(4)_U_ STATEAB_U_ VAPA(6)_U_ VAPA(8)_U_ +VAPA(25)_ U_VAPA(23) _U_VAPA(24 ) ;25-coun try,23-pro vince,24-p ostal code
  18568   "RTN","RCT CSP3",237, 0)
  18569    I $L(DEBT OR1)>0 I $ P(DEBTOR1, U,1,5)'?1" ^"."^" D
  18570   "RTN","RCT CSP3",238, 0)
  18571    .N ADDR34 0
  18572   "RTN","RCT CSP3",239, 0)
  18573    .S ADDR34 0=$P($$DAD D^RCAMADD( DEBTOR),U, 1,7)_"^"_1
  18574   "RTN","RCT CSP3",240, 0)
  18575    .S ADDR34 0=$P(ADDR3 40,U,1,2)_ "^"_$P(ADD R340,U,4,9 9)
  18576   "RTN","RCT CSP3",241, 0)
  18577    .I $P(ADD R340,U,6)= "" S $P(AD DR340,U,6) =$P(ADDRCS ,U,6)
  18578   "RTN","RCT CSP3",242, 0)
  18579    .S ADDRCS =ADDR340
  18580   "RTN","RCT CSP3",243, 0)
  18581    Q ADDRCS
  18582   "RTN","RCT CSP3",244, 0)
  18583    ;
  18584   "RTN","RCT CSP3",245, 0)
  18585   REJCODE ;C onverts AI TC reject  codes in r eject mult iple to po inter to f ile 348.5
  18586   "RTN","RCT CSP3",246, 0)
  18587    N RRI,REJ I,REJCD,HR EJREC,REJR EC S RRI=0
  18588   "RTN","RCT CSP3",247, 0)
  18589   REJA S RRI =$O(^PRCA( 430,BILL,1 8,RRI)) Q: 'RRI
  18590   "RTN","RCT CSP3",248, 0)
  18591    S REJREC= $G(^PRCA(4 30,BILL,18 ,RRI,0)),H REJREC=REJ REC,REJI=3  G REJA:RE JREC=""
  18592   "RTN","RCT CSP3",249, 0)
  18593    I $D(^XTM P("REJCDCO NV","BB",B ILL,18,RRI ,0)) G REJ A
  18594   "RTN","RCT CSP3",250, 0)
  18595    F REJI=RE JI:1:13 S  REJCD=$P(R EJREC,U,RE JI) I REJC D'="" D
  18596   "RTN","RCT CSP3",251, 0)
  18597    . I REJI= 12,$D(^RC( 348.7,"B", REJCD)) S  $P(REJREC, U,REJI)=$O (^RC(348.7 ,"B",REJCD ,0)) Q
  18598   "RTN","RCT CSP3",252, 0)
  18599    . I REJI= 13,$D(^RC( 348.6,"B", REJCD)) S  $P(REJREC, U,REJI)=$O (^RC(348.6 ,"B",REJCD ,0)) Q
  18600   "RTN","RCT CSP3",253, 0)
  18601    . I REJI> 11 S ^XTMP ("REJCDCON V","XX",BI LL,18,RRI, 0)=REJI_U_ HREJREC Q
  18602   "RTN","RCT CSP3",254, 0)
  18603    . I REJCD >9,REJCD<1 00 Q
  18604   "RTN","RCT CSP3",255, 0)
  18605    . I REJCD ?1.N,((REJ CD>"00")&( REJCD<"10" ))!((+REJC D>0)&(+REJ CD<10)) S  $P(REJREC, U,REJI)=+R EJCD Q
  18606   "RTN","RCT CSP3",256, 0)
  18607    . I $D(^R C(348.5,"B ",REJCD))  S $P(REJRE C,U,REJI)= $O(^RC(348 .5,"B",REJ CD,0)) Q
  18608   "RTN","RCT CSP3",257, 0)
  18609    . S $P(RE JREC,U,REJ I)=298,^XT MP("REJCDC ONV","ZZ", BILL,18,RR I,0)=$P(HR EJREC,U,RE JI)
  18610   "RTN","RCT CSP3",258, 0)
  18611    . Q
  18612   "RTN","RCT CSP3",259, 0)
  18613    I HREJREC '=REJREC S  ^XTMP("RE JCDCONV"," BB",BILL,1 8,RRI,0)=H REJREC,^XT MP("REJCDC ONV","BB", BILL,18,RR I,1)=REJRE C,^PRCA(43 0,BILL,18, RRI,0)=REJ REC
  18614   "RTN","RCT CSP3",260, 0)
  18615    G REJA
  18616   "RTN","RCT CSP4")
  18617   0^15^B2234 32725^n/a
  18618   "RTN","RCT CSP4",1,0)
  18619   RCTCSP4 ;A LB/ESG - C S Debt Ref erral Stop  Reactivat e Report ; 6/1/2017
  18620   "RTN","RCT CSP4",2,0)
  18621    ;;4.5;Acc ounts Rece ivable;**3 15**;Mar 2 0, 1995;Bu ild 55
  18622   "RTN","RCT CSP4",3,0)
  18623    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  18624   "RTN","RCT CSP4",4,0)
  18625    ;
  18626   "RTN","RCT CSP4",5,0)
  18627    Q
  18628   "RTN","RCT CSP4",6,0)
  18629    ;
  18630   "RTN","RCT CSP4",7,0)
  18631   EN ; main  report ent ry point
  18632   "RTN","RCT CSP4",8,0)
  18633    ;
  18634   "RTN","RCT CSP4",9,0)
  18635    N RCTCFLG ,RCTCDEBT1 ,RCTCDEBT2 ,RCTCDATE, RCTCEXCEL
  18636   "RTN","RCT CSP4",10,0 )
  18637    ;
  18638   "RTN","RCT CSP4",11,0 )
  18639   P1 I '$$FL AGGED(.RCT CFLG) G EX                  ; cu rrently fl agged/reac tivated/bo th
  18640   "RTN","RCT CSP4",12,0 )
  18641   P2 I '$$DE BTFR(.RCTC DEBT1) G E X:$$STOP,P 1     ; st art with d ebtor
  18642   "RTN","RCT CSP4",13,0 )
  18643   P3 I '$$DE BTTO(.RCTC DEBT2) G E X:$$STOP,P 2     ; go  to debtor
  18644   "RTN","RCT CSP4",14,0 )
  18645   P4 I '$$DA TES(.RCTCD ATE) G EX: $$STOP,P3        ; al l dates or  a date ra nge; from  and thru d ates
  18646   "RTN","RCT CSP4",15,0 )
  18647   P5 I '$$FO RMAT(.RCTC EXCEL) G E X:$$STOP,P 4     ; ou tput forma t (standar d or Excel )
  18648   "RTN","RCT CSP4",16,0 )
  18649   P6 I '$$DE VICE() G E X:$$STOP,P 5                ; ou tput devic e/queueing
  18650   "RTN","RCT CSP4",17,0 )
  18651    ;
  18652   "RTN","RCT CSP4",18,0 )
  18653   EX ; main  report exi t point
  18654   "RTN","RCT CSP4",19,0 )
  18655    Q
  18656   "RTN","RCT CSP4",20,0 )
  18657    ;
  18658   "RTN","RCT CSP4",21,0 )
  18659   STOP() ; D etermine i f user wan ts to exit  out of th e option e ntirely
  18660   "RTN","RCT CSP4",22,0 )
  18661    ; 1=yes,  get out en tirely
  18662   "RTN","RCT CSP4",23,0 )
  18663    ; 0=no, j ust go bac k to the p revious qu estion
  18664   "RTN","RCT CSP4",24,0 )
  18665    ;
  18666   "RTN","RCT CSP4",25,0 )
  18667    N DIR,X,Y ,DTOUT,DUO UT,DIRUT,D IROUT
  18668   "RTN","RCT CSP4",26,0 )
  18669    ;
  18670   "RTN","RCT CSP4",27,0 )
  18671    S DIR(0)= "Y"
  18672   "RTN","RCT CSP4",28,0 )
  18673    S DIR("A" )="Do you  want to ex it out of  this optio n entirely "
  18674   "RTN","RCT CSP4",29,0 )
  18675    S DIR("B" )="YES"
  18676   "RTN","RCT CSP4",30,0 )
  18677    S DIR("?" ,1)="  Ent er YES to  immediatel y exit out  of this o ption."
  18678   "RTN","RCT CSP4",31,0 )
  18679    S DIR("?" )="  Enter  NO to ret urn to the  previous  question."
  18680   "RTN","RCT CSP4",32,0 )
  18681    W ! D ^DI R K DIR
  18682   "RTN","RCT CSP4",33,0 )
  18683    I $D(DIRU T) S Y=1
  18684   "RTN","RCT CSP4",34,0 )
  18685    Q Y
  18686   "RTN","RCT CSP4",35,0 )
  18687    ;
  18688   "RTN","RCT CSP4",36,0 )
  18689   FLAGGED(RC TCFLG) ; c apture if  the user w ants bills  with a cu rrent flag , reactiva ted, or bo th
  18690   "RTN","RCT CSP4",37,0 )
  18691    ; RCTCFLG =C meaning  data is c urrently p resent in  the STOP T CSP REFERR AL FLAG fi eld (430,1 57)
  18692   "RTN","RCT CSP4",38,0 )
  18693    ; RCTCFLG =R meaning  data is c urrently b lank in th e STOP TCS P REFERRAL  FLAG fiel d (430,157 )
  18694   "RTN","RCT CSP4",39,0 )
  18695    ; RCTCFLG =B meaning  either is  wanted
  18696   "RTN","RCT CSP4",40,0 )
  18697    ; pass pa rameter by  reference
  18698   "RTN","RCT CSP4",41,0 )
  18699    ;
  18700   "RTN","RCT CSP4",42,0 )
  18701    N RET,DIR ,X,Y,DTOUT ,DUOUT,DIR UT,DIROUT
  18702   "RTN","RCT CSP4",43,0 )
  18703    S RCTCFLG ="",RET=1
  18704   "RTN","RCT CSP4",44,0 )
  18705    S DIR(0)= "S"
  18706   "RTN","RCT CSP4",45,0 )
  18707    S $P(DIR( 0),U,2)="C :Currently  Flagged;R :Reactivat ed;B:Both"
  18708   "RTN","RCT CSP4",46,0 )
  18709    S DIR("A" )="Run the  Report fo r"
  18710   "RTN","RCT CSP4",47,0 )
  18711    S DIR("B" )="B"
  18712   "RTN","RCT CSP4",48,0 )
  18713    S DIR("?" ,1)="Selec t 'Current ly Flagged ' to see b ills which  currently  have the  Cross-"
  18714   "RTN","RCT CSP4",49,0 )
  18715    S DIR("?" ,2)="Servi cing activ ity stop f lag set."
  18716   "RTN","RCT CSP4",50,0 )
  18717    S DIR("?" ,3)="Selec t 'Reactiv ated' to s ee bills i n which th e stop fla g is not c urrently"
  18718   "RTN","RCT CSP4",51,0 )
  18719    S DIR("?" ,4)="set,  but was on ce set in  the past."
  18720   "RTN","RCT CSP4",52,0 )
  18721    S DIR("?" )="Select  'Both' to  see bills  of both ty pes."
  18722   "RTN","RCT CSP4",53,0 )
  18723    W ! D ^DI R K DIR
  18724   "RTN","RCT CSP4",54,0 )
  18725    I $D(DIRU T)!(Y="")  S RET=0 W  $C(7) G FL X
  18726   "RTN","RCT CSP4",55,0 )
  18727    S RCTCFLG =Y
  18728   "RTN","RCT CSP4",56,0 )
  18729   FLX ;
  18730   "RTN","RCT CSP4",57,0 )
  18731    Q RET
  18732   "RTN","RCT CSP4",58,0 )
  18733    ;
  18734   "RTN","RCT CSP4",59,0 )
  18735   DEBTFR(RCT CDEBT1) ;  start with  debtor
  18736   "RTN","RCT CSP4",60,0 )
  18737    N RET,DIR ,X,Y,DTOUT ,DUOUT,DIR UT,DIROUT
  18738   "RTN","RCT CSP4",61,0 )
  18739    S RCTCDEB T1="",RET= 1
  18740   "RTN","RCT CSP4",62,0 )
  18741    S DIR(0)= "F^1:75"
  18742   "RTN","RCT CSP4",63,0 )
  18743    S DIR("A" )="Start w ith Debtor "
  18744   "RTN","RCT CSP4",64,0 )
  18745    S DIR("B" )="FIRST"
  18746   "RTN","RCT CSP4",65,0 )
  18747    S DIR("?" ,1)="If yo u want to  specify a  range of A R debtor n ames, ente r the begi nning"
  18748   "RTN","RCT CSP4",66,0 )
  18749    S DIR("?" ,2)="debto r name her e. If you  want to in clude all  debtors, a ccept the  default"
  18750   "RTN","RCT CSP4",67,0 )
  18751    S DIR("?" )="value o f FIRST he re."
  18752   "RTN","RCT CSP4",68,0 )
  18753    W ! D ^DI R K DIR
  18754   "RTN","RCT CSP4",69,0 )
  18755    I $D(DIRU T)!(Y="")  S RET=0 W  $C(7) G DF X
  18756   "RTN","RCT CSP4",70,0 )
  18757    S RCTCDEB T1=Y
  18758   "RTN","RCT CSP4",71,0 )
  18759   DFX ;
  18760   "RTN","RCT CSP4",72,0 )
  18761    Q RET
  18762   "RTN","RCT CSP4",73,0 )
  18763    ;
  18764   "RTN","RCT CSP4",74,0 )
  18765   DEBTTO(RCT CDEBT2) ;  go to debt or
  18766   "RTN","RCT CSP4",75,0 )
  18767    N RET,DIR ,X,Y,DTOUT ,DUOUT,DIR UT,DIROUT
  18768   "RTN","RCT CSP4",76,0 )
  18769   DBT1 S RCT CDEBT2="", RET=1
  18770   "RTN","RCT CSP4",77,0 )
  18771    S DIR(0)= "F^1:75"
  18772   "RTN","RCT CSP4",78,0 )
  18773    S DIR("A" )="     Go  to Debtor "
  18774   "RTN","RCT CSP4",79,0 )
  18775    S DIR("B" )="LAST"
  18776   "RTN","RCT CSP4",80,0 )
  18777    S DIR("?" ,1)="If yo u want to  specify a  range of A R debtor n ames, ente r the endi ng debtor"
  18778   "RTN","RCT CSP4",81,0 )
  18779    S DIR("?" ,2)="name  here. If y ou want to  include a ll debtors , accept t he default  value of"
  18780   "RTN","RCT CSP4",82,0 )
  18781    S DIR("?" )="LAST he re."
  18782   "RTN","RCT CSP4",83,0 )
  18783    D ^DIR K  DIR
  18784   "RTN","RCT CSP4",84,0 )
  18785    I $D(DIRU T)!(Y="")  S RET=0 W  $C(7) G DT X
  18786   "RTN","RCT CSP4",85,0 )
  18787    S RCTCDEB T2=Y
  18788   "RTN","RCT CSP4",86,0 )
  18789    I RCTCDEB T1'="FIRST ",RCTCDEBT 2'="LAST", RCTCDEBT1] RCTCDEBT2  W $C(7),!! ,"You must  enter som ething aft er '",RCTC DEBT1,"'!" ,! G DBT1
  18790   "RTN","RCT CSP4",87,0 )
  18791   DTX ;
  18792   "RTN","RCT CSP4",88,0 )
  18793    Q RET
  18794   "RTN","RCT CSP4",89,0 )
  18795    ;
  18796   "RTN","RCT CSP4",90,0 )
  18797   DATES(RCTC DATE) ; al l dates or  a date ra nge - also  capture f rom and th ru dates
  18798   "RTN","RCT CSP4",91,0 )
  18799    ; RCTCDAT E="A" or " R" if user  wants All  Dates or  to select  a Date Ran ge
  18800   "RTN","RCT CSP4",92,0 )
  18801    ; RCTCDAT E("BEGIN") =starting  FM date
  18802   "RTN","RCT CSP4",93,0 )
  18803    ; RCTCDAT E("END")=e nding FM d ate
  18804   "RTN","RCT CSP4",94,0 )
  18805    ;
  18806   "RTN","RCT CSP4",95,0 )
  18807    N RET,DIR ,X,Y,DTOUT ,DUOUT,DIR UT,DIROUT
  18808   "RTN","RCT CSP4",96,0 )
  18809    K RCTCDAT E
  18810   "RTN","RCT CSP4",97,0 )
  18811    S RET=1
  18812   "RTN","RCT CSP4",98,0 )
  18813    S DIR(0)= "S^A:All D ates;R:Dat e Range"
  18814   "RTN","RCT CSP4",99,0 )
  18815    S DIR("A" )="Include  All Dates  or Select  by Date R ange"
  18816   "RTN","RCT CSP4",100, 0)
  18817    S DIR("B" )="Date Ra nge"
  18818   "RTN","RCT CSP4",101, 0)
  18819    S DIR("?" ,1)="If yo u want to  include al l transact ion entere d dates, p lease sele ct 'A' -"
  18820   "RTN","RCT CSP4",102, 0)
  18821    S DIR("?" ,2)="All D ates here.   But if y ou want to  specify a  date rang e for the"
  18822   "RTN","RCT CSP4",103, 0)
  18823    S DIR("?" ,3)="trans action ent ered dates , then ent er 'R' her e and then  choose th e from and "
  18824   "RTN","RCT CSP4",104, 0)
  18825    S DIR("?" )="through  dates."
  18826   "RTN","RCT CSP4",105, 0)
  18827    W ! D ^DI R K DIR
  18828   "RTN","RCT CSP4",106, 0)
  18829    I $D(DIRU T)!(Y="")  S RET=0 W  $C(7) G DA TESX
  18830   "RTN","RCT CSP4",107, 0)
  18831    S RCTCDAT E=Y
  18832   "RTN","RCT CSP4",108, 0)
  18833    I RCTCDAT E="A" G DA TESX
  18834   "RTN","RCT CSP4",109, 0)
  18835    ;
  18836   "RTN","RCT CSP4",110, 0)
  18837    S DIR(0)= "DA^:DT:EX "
  18838   "RTN","RCT CSP4",111, 0)
  18839    S DIR("A" )="Date En tered From : "
  18840   "RTN","RCT CSP4",112, 0)
  18841    S DIR("?" ,1)="The F rom and To  dates for  this repo rt refer t o the date  that the  AR"
  18842   "RTN","RCT CSP4",113, 0)
  18843    S DIR("?" )="transac tion was e ntered."
  18844   "RTN","RCT CSP4",114, 0)
  18845    W ! D ^DI R K DIR
  18846   "RTN","RCT CSP4",115, 0)
  18847    I $D(DIRU T)!'Y S RE T=0 W $C(7 ) K RCTCDA TE G DATES X
  18848   "RTN","RCT CSP4",116, 0)
  18849    S RCTCDAT E("BEGIN") =Y
  18850   "RTN","RCT CSP4",117, 0)
  18851    ;
  18852   "RTN","RCT CSP4",118, 0)
  18853    S DIR(0)= "DA^"_RCTC DATE("BEGI N")_":DT:E X"
  18854   "RTN","RCT CSP4",119, 0)
  18855    S DIR("A" )="  Date  Entered To : "
  18856   "RTN","RCT CSP4",120, 0)
  18857    S DIR("B" )="T"
  18858   "RTN","RCT CSP4",121, 0)
  18859    S DIR("?" ,1)="The F rom and To  dates for  this repo rt refer t o the date  that the  AR"
  18860   "RTN","RCT CSP4",122, 0)
  18861    S DIR("?" )="transac tion was e ntered."
  18862   "RTN","RCT CSP4",123, 0)
  18863    D ^DIR K  DIR
  18864   "RTN","RCT CSP4",124, 0)
  18865    I $D(DIRU T)!'Y S RE T=0 W $C(7 ) K RCTCDA TE G DATES X
  18866   "RTN","RCT CSP4",125, 0)
  18867    S RCTCDAT E("END")=Y
  18868   "RTN","RCT CSP4",126, 0)
  18869   DATESX ;
  18870   "RTN","RCT CSP4",127, 0)
  18871    Q RET
  18872   "RTN","RCT CSP4",128, 0)
  18873    ;
  18874   "RTN","RCT CSP4",129, 0)
  18875   FORMAT(RCT CEXCEL) ;  output for mat is Exc el format  or normal  report out put
  18876   "RTN","RCT CSP4",130, 0)
  18877    ; RCTCEXC EL=0 for n ormal repo rt output
  18878   "RTN","RCT CSP4",131, 0)
  18879    ; RCTCEXC EL=1 for E xcel outpu t
  18880   "RTN","RCT CSP4",132, 0)
  18881    ; pass pa rameter by  reference
  18882   "RTN","RCT CSP4",133, 0)
  18883    ;
  18884   "RTN","RCT CSP4",134, 0)
  18885    N RET,DIR ,X,Y,DTOUT ,DUOUT,DIR UT,DIROUT
  18886   "RTN","RCT CSP4",135, 0)
  18887    S RCTCEXC EL=0,RET=1
  18888   "RTN","RCT CSP4",136, 0)
  18889    S DIR(0)= "Y"
  18890   "RTN","RCT CSP4",137, 0)
  18891    S DIR("A" )="Do you  want to ca pture the  output in  Excel form at"
  18892   "RTN","RCT CSP4",138, 0)
  18893    S DIR("B" )="NO"
  18894   "RTN","RCT CSP4",139, 0)
  18895    S DIR("?" ,1)="If yo u want to  capture th e output f rom this r eport in a  format wh ich can"
  18896   "RTN","RCT CSP4",140, 0)
  18897    S DIR("?" ,2)="easil y be impor ted into E xcel, then  answer YE S here."
  18898   "RTN","RCT CSP4",141, 0)
  18899    S DIR("?" ,3)=" "
  18900   "RTN","RCT CSP4",142, 0)
  18901    S DIR("?" )="If you  just want  a normal r eport outp ut, then a nswer NO h ere."
  18902   "RTN","RCT CSP4",143, 0)
  18903    W ! D ^DI R K DIR
  18904   "RTN","RCT CSP4",144, 0)
  18905    I $D(DIRU T) S RET=0  W $C(7) G  FMX
  18906   "RTN","RCT CSP4",145, 0)
  18907    S RCTCEXC EL=Y
  18908   "RTN","RCT CSP4",146, 0)
  18909   FMX ;
  18910   "RTN","RCT CSP4",147, 0)
  18911    Q RET
  18912   "RTN","RCT CSP4",148, 0)
  18913    ;
  18914   "RTN","RCT CSP4",149, 0)
  18915   DEVICE() ;  Device Se lection
  18916   "RTN","RCT CSP4",150, 0)
  18917    N ZTRTN,Z TDESC,ZTSA VE,POP,RET ,ZTSK,DIR, X,Y
  18918   "RTN","RCT CSP4",151, 0)
  18919    S RET=1
  18920   "RTN","RCT CSP4",152, 0)
  18921    I 'RCTCEX CEL W !!," This repor t is 132 c haracters  wide.  Ple ase choose  an approp riate devi ce.",!
  18922   "RTN","RCT CSP4",153, 0)
  18923    I RCTCEXC EL D
  18924   "RTN","RCT CSP4",154, 0)
  18925    . W !!,"F or Excel o utput, tur n logging  or capture  on now."
  18926   "RTN","RCT CSP4",155, 0)
  18927    . W !,"To  avoid und esired wra pping of t he data sa ved to the  file,"
  18928   "RTN","RCT CSP4",156, 0)
  18929    . W !,"pl ease enter  ""0;256;9 9999"" at  the ""DEVI CE:"" prom pt.",!
  18930   "RTN","RCT CSP4",157, 0)
  18931    ;
  18932   "RTN","RCT CSP4",158, 0)
  18933    S ZTRTN=" COMPILE^RC TCSP4"
  18934   "RTN","RCT CSP4",159, 0)
  18935    S ZTDESC= "RCTC AR C ross-Servi cing Stop  Reactivate  Report"
  18936   "RTN","RCT CSP4",160, 0)
  18937    S ZTSAVE( "RCTCFLG") =""
  18938   "RTN","RCT CSP4",161, 0)
  18939    S ZTSAVE( "RCTCDEBT1 ")=""
  18940   "RTN","RCT CSP4",162, 0)
  18941    S ZTSAVE( "RCTCDEBT2 ")=""
  18942   "RTN","RCT CSP4",163, 0)
  18943    S ZTSAVE( "RCTCDATE" )=""
  18944   "RTN","RCT CSP4",164, 0)
  18945    S ZTSAVE( "RCTCDATE( ")=""
  18946   "RTN","RCT CSP4",165, 0)
  18947    S ZTSAVE( "RCTCEXCEL ")=""
  18948   "RTN","RCT CSP4",166, 0)
  18949    D EN^XUTM DEVQ(ZTRTN ,ZTDESC,.Z TSAVE,"QM" ,1)
  18950   "RTN","RCT CSP4",167, 0)
  18951    I POP S R ET=0
  18952   "RTN","RCT CSP4",168, 0)
  18953    I $G(ZTSK ) W !!,"Re port compi lation has  started w ith task#  ",ZTSK,"." ,! S DIR(0 )="E" D ^D IR K DIR
  18954   "RTN","RCT CSP4",169, 0)
  18955    Q RET
  18956   "RTN","RCT CSP4",170, 0)
  18957    ;
  18958   "RTN","RCT CSP4",171, 0)
  18959    ;
  18960   "RTN","RCT CSP4",172, 0)
  18961   COMPILE ;  entry poin t for the  report com pile to bu ild the sc ratch glob al
  18962   "RTN","RCT CSP4",173, 0)
  18963    ; may be  a backgrou nd task if  job queue d
  18964   "RTN","RCT CSP4",174, 0)
  18965    ;
  18966   "RTN","RCT CSP4",175, 0)
  18967    K ^TMP("R CTCSP4",$J )              ; kill  scratch a t start
  18968   "RTN","RCT CSP4",176, 0)
  18969    I '$D(ZTQ UEUED) W ! !,"Compili ng Cross-S ervicing S top Reacti vate Repor t.  Please  wait ...  "
  18970   "RTN","RCT CSP4",177, 0)
  18971    ;
  18972   "RTN","RCT CSP4",178, 0)
  18973    D COMP                              ; buil d scratch  global
  18974   "RTN","RCT CSP4",179, 0)
  18975    D PRINT                             ; prin t the repo rt
  18976   "RTN","RCT CSP4",180, 0)
  18977    D ^%ZISC                            ; clos e the devi ce
  18978   "RTN","RCT CSP4",181, 0)
  18979    K ^TMP("R CTCSP4",$J )              ; kill  scratch g lobal at e nd
  18980   "RTN","RCT CSP4",182, 0)
  18981    I $D(ZTQU EUED) S ZT REQ="@"        ; purg e the task
  18982   "RTN","RCT CSP4",183, 0)
  18983   COMIPLX ;
  18984   "RTN","RCT CSP4",184, 0)
  18985    Q
  18986   "RTN","RCT CSP4",185, 0)
  18987    ;
  18988   "RTN","RCT CSP4",186, 0)
  18989   COMP ; com pile data  into scrat ch global
  18990   "RTN","RCT CSP4",187, 0)
  18991    N ARTTIEN ,RCTCTT,RC TCDTENT,RC 433,P0,RCI BN,USER,RC TTNAME,RC3 40,DEBTNAM E,FLAG,RCD EBTOR,RCBI LLNUM
  18992   "RTN","RCT CSP4",188, 0)
  18993    ;
  18994   "RTN","RCT CSP4",189, 0)
  18995    ; first i dentify th e AR Trans action typ es eligibl e for this  report (C S STOP PLA CED or CS  STOP DELET ED)
  18996   "RTN","RCT CSP4",190, 0)
  18997    ; load in to the RCT CTT local  array
  18998   "RTN","RCT CSP4",191, 0)
  18999    S ARTTIEN =0 F  S AR TTIEN=$O(^ PRCA(430.3 ,ARTTIEN))  Q:'ARTTIE N  I $P($G (^PRCA(430 .3,ARTTIEN ,0)),U,1)[ "CS STOP"  S RCTCTT(A RTTIEN)=""
  19000   "RTN","RCT CSP4",192, 0)
  19001    ;
  19002   "RTN","RCT CSP4",193, 0)
  19003    ; if no e nd date sp ecified th en assume  all dates  are OK
  19004   "RTN","RCT CSP4",194, 0)
  19005    I '$G(RCT CDATE("END ")) S RCTC DATE("END" )=9999999
  19006   "RTN","RCT CSP4",195, 0)
  19007    ;
  19008   "RTN","RCT CSP4",196, 0)
  19009    ; start l oop
  19010   "RTN","RCT CSP4",197, 0)
  19011    S ARTTIEN =0 F  S AR TTIEN=$O(R CTCTT(ARTT IEN)) Q:'A RTTIEN  D
  19012   "RTN","RCT CSP4",198, 0)
  19013    . ;
  19014   "RTN","RCT CSP4",199, 0)
  19015    . ; deter mine date  to start l ooping bas ed on if t he user sp ecified a  start date  or not
  19016   "RTN","RCT CSP4",200, 0)
  19017    . S RCTCD TENT=0
  19018   "RTN","RCT CSP4",201, 0)
  19019    . I $G(RC TCDATE("BE GIN")) S R CTCDTENT=$ O(^PRCA(43 3,"AT",ART TIEN,RCTCD ATE("BEGIN ")),-1)    ; get one  day earlie r to start
  19020   "RTN","RCT CSP4",202, 0)
  19021    . ;
  19022   "RTN","RCT CSP4",203, 0)
  19023    . F  S RC TCDTENT=$O (^PRCA(433 ,"AT",ARTT IEN,RCTCDT ENT)) Q:'R CTCDTENT!( RCTCDTENT> RCTCDATE(" END"))  D
  19024   "RTN","RCT CSP4",204, 0)
  19025    .. S RC43 3=0 F  S R C433=$O(^P RCA(433,"A T",ARTTIEN ,RCTCDTENT ,RC433)) Q :'RC433  D
  19026   "RTN","RCT CSP4",205, 0)
  19027    ... S P0= $G(^PRCA(4 33,RC433,0 ))
  19028   "RTN","RCT CSP4",206, 0)
  19029    ... S RCI BN=+$P(P0, U,2) Q:'RC IBN                   ; bill# ie n
  19030   "RTN","RCT CSP4",207, 0)
  19031    ... S USE R=$P($G(^V A(200,+$P( P0,U,9),0) ),U,1)     ; processe d by user
  19032   "RTN","RCT CSP4",208, 0)
  19033    ... S RCT TNAME=$$GE T1^DIQ(433 ,RC433,12)            ; trans ty pe name
  19034   "RTN","RCT CSP4",209, 0)
  19035    ... ;
  19036   "RTN","RCT CSP4",210, 0)
  19037    ... ; now  get some  bill data  from 430
  19038   "RTN","RCT CSP4",211, 0)
  19039    ... S RC3 40=+$P($G( ^PRCA(430, RCIBN,0)), U,9)       ; ar debto r ien
  19040   "RTN","RCT CSP4",212, 0)
  19041    ... Q:'RC 340
  19042   "RTN","RCT CSP4",213, 0)
  19043    ... S DEB TNAME=$$GE T1^DIQ(340 ,RC340,.01 )          ; external  ar debtor  name
  19044   "RTN","RCT CSP4",214, 0)
  19045    ... Q:DEB TNAME=""
  19046   "RTN","RCT CSP4",215, 0)
  19047    ... ;
  19048   "RTN","RCT CSP4",216, 0)
  19049    ... ; che ck report  filter on  debtor nam e
  19050   "RTN","RCT CSP4",217, 0)
  19051    ... I RCT CDEBT1'="F IRST",RCTC DEBT1'=DEB TNAME,RCTC DEBT1]DEBT NAME Q     ; before n ame range
  19052   "RTN","RCT CSP4",218, 0)
  19053    ... I RCT CDEBT2'="L AST",RCTCD EBT2'=DEBT NAME,DEBTN AME]RCTCDE BT2 Q      ; after na me range
  19054   "RTN","RCT CSP4",219, 0)
  19055    ... ;
  19056   "RTN","RCT CSP4",220, 0)
  19057    ... ; get  the curre nt flag va lue and ch eck report  filter
  19058   "RTN","RCT CSP4",221, 0)
  19059    ... S FLA G=+$P($G(^ PRCA(430,R CIBN,15)), U,7)       ; stop tcs p referral  flag fiel d (430,157 )  1:flag  set
  19060   "RTN","RCT CSP4",222, 0)
  19061    ... I RCT CFLG="R",F LAG Q                            ; user wan ts only Re activated  bills and  this one i s still fl agged
  19062   "RTN","RCT CSP4",223, 0)
  19063    ... I RCT CFLG="C",' FLAG Q                           ; user wan ts only cu rrently fl agged bill s and this  flag is c lear
  19064   "RTN","RCT CSP4",224, 0)
  19065    ... ;
  19066   "RTN","RCT CSP4",225, 0)
  19067    ... S RCD EBTOR=DEBT NAME_U_RC3 40                    ; debtor n ame^debtor  ien (used  in subscr ipt)
  19068   "RTN","RCT CSP4",226, 0)
  19069    ... S RCB ILLNUM=$$G ET1^DIQ(43 0,RCIBN,.0 1)         ; bill#
  19070   "RTN","RCT CSP4",227, 0)
  19071    ... Q:RCB ILLNUM=""
  19072   "RTN","RCT CSP4",228, 0)
  19073    ... ;
  19074   "RTN","RCT CSP4",229, 0)
  19075    ... ; sto re data at  the debto r level if  not alrea dy there
  19076   "RTN","RCT CSP4",230, 0)
  19077    ... ; sto re data at  the debto r level if  not alrea dy there
  19078   "RTN","RCT CSP4",231, 0)
  19079    ... I '$D (^TMP("RCT CSP4",$J,R CDEBTOR))  D
  19080   "RTN","RCT CSP4",232, 0)
  19081    .... N RC DV,SSN,PTI D
  19082   "RTN","RCT CSP4",233, 0)
  19083    .... S (S SN,PTID)=" "
  19084   "RTN","RCT CSP4",234, 0)
  19085    .... S SS N=$$SSN^RC FN01(RC340 )
  19086   "RTN","RCT CSP4",235, 0)
  19087    .... S PT ID=$E(DEBT NAME,1)_$S (SSN'="":$ E(SSN,6,9) ,1:"0000")              ; patien t id
  19088   "RTN","RCT CSP4",236, 0)
  19089    .... S ^T MP("RCTCSP 4",$J,RCDE BTOR)=PTID _U_DEBTNAM E           ; save in to scratch
  19090   "RTN","RCT CSP4",237, 0)
  19091    .... Q
  19092   "RTN","RCT CSP4",238, 0)
  19093    ... ;
  19094   "RTN","RCT CSP4",239, 0)
  19095    ... ; sto re data at  the bill#  level if  not alread y there
  19096   "RTN","RCT CSP4",240, 0)
  19097    ... I '$D (^TMP("RCT CSP4",$J,R CDEBTOR,RC BILLNUM))  D
  19098   "RTN","RCT CSP4",241, 0)
  19099    .... N RC X,CAT
  19100   "RTN","RCT CSP4",242, 0)
  19101    .... S RC X=RCBILLNU M                                            ; bill#
  19102   "RTN","RCT CSP4",243, 0)
  19103    .... S $P (RCX,U,2)= $$GET1^DIQ (430,RCIBN ,11)                   ; current  balance
  19104   "RTN","RCT CSP4",244, 0)
  19105    .... S $P (RCX,U,3)= $$GET1^DIQ (430,RCIBN ,8)                    ; current  ar status  name
  19106   "RTN","RCT CSP4",245, 0)
  19107    .... S $P (RCX,U,4)= $$GET1^DIQ (430,RCIBN ,2)                    ; ar cate gory name
  19108   "RTN","RCT CSP4",246, 0)
  19109    .... S $P (RCX,U,5)= $$GET1^DIQ (430,RCIBN ,61,"I")               ; letter1  date FM f ormat
  19110   "RTN","RCT CSP4",247, 0)
  19111    .... S $P (RCX,U,6)= $$GET1^DIQ (430,RCIBN ,158,"I")              ; stop tc sp referra l eff. dat e FM forma t
  19112   "RTN","RCT CSP4",248, 0)
  19113    .... S $P (RCX,U,7)= $$GET1^DIQ (430,RCIBN ,159)                  ; stop tc sp referra l reason d esc
  19114   "RTN","RCT CSP4",249, 0)
  19115    .... S CA T=+$P($G(^ PRCA(430,R CIBN,0)),U ,2)                    ; ar cate gory ien
  19116   "RTN","RCT CSP4",250, 0)
  19117    .... S $P (RCX,U,8)= $$GET1^DIQ (430.2,CAT ,1)                    ; ar cate gory abbre viation
  19118   "RTN","RCT CSP4",251, 0)
  19119    .... S ^T MP("RCTCSP 4",$J,RCDE BTOR,RCBIL LNUM)=RCX
  19120   "RTN","RCT CSP4",252, 0)
  19121    ... ;
  19122   "RTN","RCT CSP4",253, 0)
  19123    ... ; now  we can st ore the AR  transacti on data
  19124   "RTN","RCT CSP4",254, 0)
  19125    ... S ^TM P("RCTCSP4 ",$J,RCDEB TOR,RCBILL NUM,RC433) =RCTTNAME_ U_RCTCDTEN T_U_USER
  19126   "RTN","RCT CSP4",255, 0)
  19127    . Q
  19128   "RTN","RCT CSP4",256, 0)
  19129    ;
  19130   "RTN","RCT CSP4",257, 0)
  19131    ;
  19132   "RTN","RCT CSP4",258, 0)
  19133   COMPX ;
  19134   "RTN","RCT CSP4",259, 0)
  19135    Q
  19136   "RTN","RCT CSP4",260, 0)
  19137    ;
  19138   "RTN","RCT CSP4",261, 0)
  19139    ;
  19140   "RTN","RCT CSP4",262, 0)
  19141   PRINT ; en try point  for printi ng the rep ort
  19142   "RTN","RCT CSP4",263, 0)
  19143    N CRT,PAG E,RCTCSTOP ,SEPLINE,D IR,DIROUT, DIRUT,DTOU T,DUOUT,X, Y,RCD,DEBT DATA,BILL, BILLDATA,R C433,TRAND ATA
  19144   "RTN","RCT CSP4",264, 0)
  19145    S CRT=$S( IOST["C-": 1,1:0)
  19146   "RTN","RCT CSP4",265, 0)
  19147    I RCTCEXC EL S IOSL= 999999         ; long  screen le ngth for E xcel outpu t
  19148   "RTN","RCT CSP4",266, 0)
  19149    S PAGE=0, RCTCSTOP=0 ,$P(SEPLIN E,"-",133) =""
  19150   "RTN","RCT CSP4",267, 0)
  19151    ;
  19152   "RTN","RCT CSP4",268, 0)
  19153    I '$D(^TM P("RCTCSP4 ",$J)) D H DR W !!?5, "No data f ound for t his report ." G PX
  19154   "RTN","RCT CSP4",269, 0)
  19155    I $G(ZTST OP) D HDR  W !!?5,"Th is report  was halted  during co mpilation  by TaskMan ager Reque st." G PX
  19156   "RTN","RCT CSP4",270, 0)
  19157    ;
  19158   "RTN","RCT CSP4",271, 0)
  19159    D HDR I R CTCSTOP G  PX         ; display  headers fi rst for bo th types o f output
  19160   "RTN","RCT CSP4",272, 0)
  19161    ;
  19162   "RTN","RCT CSP4",273, 0)
  19163    ; loop th ru scratch , check fo r RCTCSTOP  as we go
  19164   "RTN","RCT CSP4",274, 0)
  19165    S RCD=""  F  S RCD=$ O(^TMP("RC TCSP4",$J, RCD)) Q:RC D=""!RCTCS TOP  D
  19166   "RTN","RCT CSP4",275, 0)
  19167    . S DEBTD ATA=$G(^TM P("RCTCSP4 ",$J,RCD))
  19168   "RTN","RCT CSP4",276, 0)
  19169    . S BILL= "" F  S BI LL=$O(^TMP ("RCTCSP4" ,$J,RCD,BI LL)) Q:BIL L=""!RCTCS TOP  D
  19170   "RTN","RCT CSP4",277, 0)
  19171    .. S BILL DATA=$G(^T MP("RCTCSP 4",$J,RCD, BILL))
  19172   "RTN","RCT CSP4",278, 0)
  19173    .. S RC43 3=0 F  S R C433=$O(^T MP("RCTCSP 4",$J,RCD, BILL,RC433 )) Q:'RC43 3!RCTCSTOP   D
  19174   "RTN","RCT CSP4",279, 0)
  19175    ... S TRA NDATA=$G(^ TMP("RCTCS P4",$J,RCD ,BILL,RC43 3))
  19176   "RTN","RCT CSP4",280, 0)
  19177    ... D RPT LN
  19178   "RTN","RCT CSP4",281, 0)
  19179    ... Q
  19180   "RTN","RCT CSP4",282, 0)
  19181    .. Q
  19182   "RTN","RCT CSP4",283, 0)
  19183    . Q
  19184   "RTN","RCT CSP4",284, 0)
  19185    ;
  19186   "RTN","RCT CSP4",285, 0)
  19187    I RCTCSTO P G PRINTX        ; g et out rig ht away if  stop flag  is set
  19188   "RTN","RCT CSP4",286, 0)
  19189    ;
  19190   "RTN","RCT CSP4",287, 0)
  19191    I $Y+3>IO SL D HDR I  RCTCSTOP  G PRINTX
  19192   "RTN","RCT CSP4",288, 0)
  19193    W !!?5,"* ** End of  Report *** "
  19194   "RTN","RCT CSP4",289, 0)
  19195    ;
  19196   "RTN","RCT CSP4",290, 0)
  19197   PX ;
  19198   "RTN","RCT CSP4",291, 0)
  19199    I CRT,'$D (ZTQUEUED)  S DIR(0)= "E" D ^DIR  K DIR
  19200   "RTN","RCT CSP4",292, 0)
  19201   PRINTX ;
  19202   "RTN","RCT CSP4",293, 0)
  19203    Q
  19204   "RTN","RCT CSP4",294, 0)
  19205    ;
  19206   "RTN","RCT CSP4",295, 0)
  19207   RPTLN ; di splay one  line on th e report -  either no rmal or Ex cel
  19208   "RTN","RCT CSP4",296, 0)
  19209    N TT
  19210   "RTN","RCT CSP4",297, 0)
  19211    ;
  19212   "RTN","RCT CSP4",298, 0)
  19213    ; for Exc el output,  print a l ine and ge t out
  19214   "RTN","RCT CSP4",299, 0)
  19215    I RCTCEXC EL D EXCEL N G RPTLNX
  19216   "RTN","RCT CSP4",300, 0)
  19217    ;
  19218   "RTN","RCT CSP4",301, 0)
  19219    ; page br eak check
  19220   "RTN","RCT CSP4",302, 0)
  19221    I $Y+3>IO SL D HDR I  RCTCSTOP  G RPTLNX
  19222   "RTN","RCT CSP4",303, 0)
  19223    ;
  19224   "RTN","RCT CSP4",304, 0)
  19225    ; write a  line of r eport data
  19226   "RTN","RCT CSP4",305, 0)
  19227    W !,$E($P (DEBTDATA, U,2),1,18)                                   ; debtor  name
  19228   "RTN","RCT CSP4",306, 0)
  19229    W ?20,$P( DEBTDATA,U ,1)                                          ; Pt ID
  19230   "RTN","RCT CSP4",307, 0)
  19231    W ?27,$P( $P(BILLDAT A,U,1),"-" ,2)                               ; bill#
  19232   "RTN","RCT CSP4",308, 0)
  19233    W ?34,$$R J^XLFSTR($ FN($P(BILL DATA,U,2), "",2),10)              ; current  balance
  19234   "RTN","RCT CSP4",309, 0)
  19235    W ?46,$E( $P(BILLDAT A,U,3),1,1 6)                                ; current  status
  19236   "RTN","RCT CSP4",310, 0)
  19237    W ?64,$P( BILLDATA,U ,8)                                          ; categor y abbr
  19238   "RTN","RCT CSP4",311, 0)
  19239    W ?68,$$F MTE^XLFDT( $P(BILLDAT A,U,5),"2Z ")                     ; letter  1 date
  19240   "RTN","RCT CSP4",312, 0)
  19241    W ?78,$$F MTE^XLFDT( $P(BILLDAT A,U,6),"2Z ")                     ; stop da te
  19242   "RTN","RCT CSP4",313, 0)
  19243    W ?88,$E( $P(BILLDAT A,U,7),1,1 0)                                ; stop re ason
  19244   "RTN","RCT CSP4",314, 0)
  19245    S TT=$P(T RANDATA,U, 1)
  19246   "RTN","RCT CSP4",315, 0)
  19247    W ?100,$S (TT["DELET ED":"DEL", TT["PLACED ":"ADD",1: "UNK")      ; transac tion type
  19248   "RTN","RCT CSP4",316, 0)
  19249    W ?105,$$ FMTE^XLFDT ($P(TRANDA TA,U,2),"2 Z")                    ; date en tered
  19250   "RTN","RCT CSP4",317, 0)
  19251    W ?115,$E ($P(TRANDA TA,U,3),1, 17)                               ; user
  19252   "RTN","RCT CSP4",318, 0)
  19253    ;
  19254   "RTN","RCT CSP4",319, 0)
  19255   RPTLNX ;
  19256   "RTN","RCT CSP4",320, 0)
  19257    Q
  19258   "RTN","RCT CSP4",321, 0)
  19259    ;
  19260   "RTN","RCT CSP4",322, 0)
  19261   HDR ; repo rt header
  19262   "RTN","RCT CSP4",323, 0)
  19263    ;
  19264   "RTN","RCT CSP4",324, 0)
  19265    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,Y
  19266   "RTN","RCT CSP4",325, 0)
  19267    ;
  19268   "RTN","RCT CSP4",326, 0)
  19269    ; Do an e nd of page  reader ca ll if page # exists a nd device  is the scr een
  19270   "RTN","RCT CSP4",327, 0)
  19271    I PAGE,CR T S DIR(0) ="E" D ^DI R K DIR I  'Y S RCTCS TOP=1 G HD RX
  19272   "RTN","RCT CSP4",328, 0)
  19273    ;
  19274   "RTN","RCT CSP4",329, 0)
  19275    ; If scre en output  or page# e xists, do  a form fee d
  19276   "RTN","RCT CSP4",330, 0)
  19277    I PAGE!CR T W @IOF
  19278   "RTN","RCT CSP4",331, 0)
  19279    ;
  19280   "RTN","RCT CSP4",332, 0)
  19281    ; First p rinter/fil e page - d o a left m argin rese t
  19282   "RTN","RCT CSP4",333, 0)
  19283    I 'PAGE,' CRT W $C(1 3)
  19284   "RTN","RCT CSP4",334, 0)
  19285    ;
  19286   "RTN","RCT CSP4",335, 0)
  19287    S PAGE=PA GE+1    ;  increment  page#
  19288   "RTN","RCT CSP4",336, 0)
  19289    ;
  19290   "RTN","RCT CSP4",337, 0)
  19291    ; For Exc el format,  display t he column  headers on ly
  19292   "RTN","RCT CSP4",338, 0)
  19293    I RCTCEXC EL D EXCEL HD G HDRX
  19294   "RTN","RCT CSP4",339, 0)
  19295    ;
  19296   "RTN","RCT CSP4",340, 0)
  19297    ; Display  the repor t headers
  19298   "RTN","RCT CSP4",341, 0)
  19299    W "Debtor  Range: "
  19300   "RTN","RCT CSP4",342, 0)
  19301    I RCTCDEB T1="FIRST" ,RCTCDEBT2 ="LAST" W  "ALL"
  19302   "RTN","RCT CSP4",343, 0)
  19303    E  D
  19304   "RTN","RCT CSP4",344, 0)
  19305    . W $S(RC TCDEBT1="F IRST":"FIR ST",1:($C( 34)_$E(RCT CDEBT1,1,1 0)_$C(34)) )," - "
  19306   "RTN","RCT CSP4",345, 0)
  19307    . W $S(RC TCDEBT2="L AST":"LAST ",1:($C(34 )_$E(RCTCD EBT2,1,10) _$C(34)))
  19308   "RTN","RCT CSP4",346, 0)
  19309    . Q
  19310   "RTN","RCT CSP4",347, 0)
  19311    ;
  19312   "RTN","RCT CSP4",348, 0)
  19313    W ?47,"Cr oss-Servic ing Stop R eactivate  Report",?1 22,"Page:  ",PAGE
  19314   "RTN","RCT CSP4",349, 0)
  19315    ;
  19316   "RTN","RCT CSP4",350, 0)
  19317    W !?2,"Da te Range:  "
  19318   "RTN","RCT CSP4",351, 0)
  19319    I RCTCDAT E="A" W "A LL"
  19320   "RTN","RCT CSP4",352, 0)
  19321    E  D
  19322   "RTN","RCT CSP4",353, 0)
  19323    . W $$FMT E^XLFDT($G (RCTCDATE( "BEGIN")), "2Z")," -  "
  19324   "RTN","RCT CSP4",354, 0)
  19325    . W $$FMT E^XLFDT($G (RCTCDATE( "END")),"2 Z")
  19326   "RTN","RCT CSP4",355, 0)
  19327    . Q
  19328   "RTN","RCT CSP4",356, 0)
  19329    ;
  19330   "RTN","RCT CSP4",357, 0)
  19331    W ?44,"Cu rrently Fl agged, Rea ctivated,  or Both: "
  19332   "RTN","RCT CSP4",358, 0)
  19333    W $S(RCTC FLG="C":"C urrently F lagged",RC TCFLG="R": "Reactivat ed",1:"Bot h")
  19334   "RTN","RCT CSP4",359, 0)
  19335    W ?111,$$ FMTE^XLFDT ($$NOW^XLF DT)
  19336   "RTN","RCT CSP4",360, 0)
  19337    ;
  19338   "RTN","RCT CSP4",361, 0)
  19339    W !,SEPLI NE
  19340   "RTN","RCT CSP4",362, 0)
  19341    W !,"Debt or Name",? 20,"Pt ID" ,?27,"Bill #",?37,"Ba lance",?46 ,"Status", ?63,"Cat", ?68,"Lette r1",?78,"S topDate"
  19342   "RTN","RCT CSP4",363, 0)
  19343    W ?88,"Re ason",?97, "CS STOP", ?106,"Ente red",?115, "User"
  19344   "RTN","RCT CSP4",364, 0)
  19345    W !,SEPLI NE
  19346   "RTN","RCT CSP4",365, 0)
  19347    ;
  19348   "RTN","RCT CSP4",366, 0)
  19349    ; check f or a TaskM anager sto p request
  19350   "RTN","RCT CSP4",367, 0)
  19351    I $D(ZTQU EUED),$$S^ %ZTLOAD()  D  G HDRX
  19352   "RTN","RCT CSP4",368, 0)
  19353    . S (ZTST OP,RCTCSTO P)=1
  19354   "RTN","RCT CSP4",369, 0)
  19355    . W !!!?5 ,"*** Repo rt Halted  by TaskMan ager Reque st ***"
  19356   "RTN","RCT CSP4",370, 0)
  19357    . Q
  19358   "RTN","RCT CSP4",371, 0)
  19359    ;
  19360   "RTN","RCT CSP4",372, 0)
  19361   HDRX ;
  19362   "RTN","RCT CSP4",373, 0)
  19363    Q
  19364   "RTN","RCT CSP4",374, 0)
  19365    ;
  19366   "RTN","RCT CSP4",375, 0)
  19367   EXCELHD ;  print an E xcel heade r record ( only 1 Exc el header  should pri nt for the  whole rep ort)
  19368   "RTN","RCT CSP4",376, 0)
  19369    N RCH
  19370   "RTN","RCT CSP4",377, 0)
  19371    S RCH=$$C SV("","Deb tor Name")
  19372   "RTN","RCT CSP4",378, 0)
  19373    S RCH=$$C SV(RCH,"Pa tient ID")
  19374   "RTN","RCT CSP4",379, 0)
  19375    S RCH=$$C SV(RCH,"Bi ll Number" )
  19376   "RTN","RCT CSP4",380, 0)
  19377    S RCH=$$C SV(RCH,"Cu rrent Bala nce")
  19378   "RTN","RCT CSP4",381, 0)
  19379    S RCH=$$C SV(RCH,"Cu rrent Stat us")
  19380   "RTN","RCT CSP4",382, 0)
  19381    S RCH=$$C SV(RCH,"Ca tegory Nam e")
  19382   "RTN","RCT CSP4",383, 0)
  19383    S RCH=$$C SV(RCH,"Ca tegory Abb r")
  19384   "RTN","RCT CSP4",384, 0)
  19385    S RCH=$$C SV(RCH,"Le tter1 Date ")
  19386   "RTN","RCT CSP4",385, 0)
  19387    S RCH=$$C SV(RCH,"St op Date")
  19388   "RTN","RCT CSP4",386, 0)
  19389    S RCH=$$C SV(RCH,"St op Reason" )
  19390   "RTN","RCT CSP4",387, 0)
  19391    S RCH=$$C SV(RCH,"Tr ansaction  Type")
  19392   "RTN","RCT CSP4",388, 0)
  19393    S RCH=$$C SV(RCH,"Tr ansaction  Date Enter ed")
  19394   "RTN","RCT CSP4",389, 0)
  19395    S RCH=$$C SV(RCH,"Tr ansaction  Processed  By")
  19396   "RTN","RCT CSP4",390, 0)
  19397    W RCH
  19398   "RTN","RCT CSP4",391, 0)
  19399    Q
  19400   "RTN","RCT CSP4",392, 0)
  19401    ;
  19402   "RTN","RCT CSP4",393, 0)
  19403   EXCELN ; w rite a lin e of Excel  data
  19404   "RTN","RCT CSP4",394, 0)
  19405    N RCZ
  19406   "RTN","RCT CSP4",395, 0)
  19407    S RCZ=$$C SV("",$P(D EBTDATA,U, 2))                           ;  AR Debtor  Name
  19408   "RTN","RCT CSP4",396, 0)
  19409    S RCZ=$$C SV(RCZ,$P( DEBTDATA,U ,1))                          ;  patient ID
  19410   "RTN","RCT CSP4",397, 0)
  19411    S RCZ=$$C SV(RCZ,$P( BILLDATA,U ,1))                          ;  bill#
  19412   "RTN","RCT CSP4",398, 0)
  19413    S RCZ=$$C SV(RCZ,+$P (BILLDATA, U,2))                         ;  current ba lance
  19414   "RTN","RCT CSP4",399, 0)
  19415    S RCZ=$$C SV(RCZ,$P( BILLDATA,U ,3))                          ;  AR status  name
  19416   "RTN","RCT CSP4",400, 0)
  19417    S RCZ=$$C SV(RCZ,$P( BILLDATA,U ,4))                          ;  AR categor y name
  19418   "RTN","RCT CSP4",401, 0)
  19419    S RCZ=$$C SV(RCZ,$P( BILLDATA,U ,8))                          ;  AR categor y abbr
  19420   "RTN","RCT CSP4",402, 0)
  19421    S RCZ=$$C SV(RCZ,$$F MTE^XLFDT( $P(BILLDAT A,U,5),"2Z "))     ;  letter1 da te
  19422   "RTN","RCT CSP4",403, 0)
  19423    S RCZ=$$C SV(RCZ,$$F MTE^XLFDT( $P(BILLDAT A,U,6),"2Z "))     ;  stop flag  effective  date
  19424   "RTN","RCT CSP4",404, 0)
  19425    S RCZ=$$C SV(RCZ,$P( BILLDATA,U ,7))                          ;  stop flag  reason
  19426   "RTN","RCT CSP4",405, 0)
  19427    S RCZ=$$C SV(RCZ,$P( TRANDATA,U ,1))                          ;  ar transac tion type  desc
  19428   "RTN","RCT CSP4",406, 0)
  19429    S RCZ=$$C SV(RCZ,$$F MTE^XLFDT( $P(TRANDAT A,U,2),"2Z "))     ;  transactio n date ent ered
  19430   "RTN","RCT CSP4",407, 0)
  19431    S RCZ=$$C SV(RCZ,$P( TRANDATA,U ,3))                          ;  trans user
  19432   "RTN","RCT CSP4",408, 0)
  19433    W !,RCZ
  19434   "RTN","RCT CSP4",409, 0)
  19435    Q
  19436   "RTN","RCT CSP4",410, 0)
  19437    ;
  19438   "RTN","RCT CSP4",411, 0)
  19439   CSV(STRING ,DATA) ; b uild the E xcel data  string for mat
  19440   "RTN","RCT CSP4",412, 0)
  19441    S STRING= $S(STRING= "":DATA,1: STRING_U_D ATA)
  19442   "RTN","RCT CSP4",413, 0)
  19443    Q STRING
  19444   "RTN","RCT CSP4",414, 0)
  19445    ;
  19446   "RTN","RCT CSP5")
  19447   0^21^B1227 48822^n/a
  19448   "RTN","RCT CSP5",1,0)
  19449   RCTCSP5 ;A LBANY/PAW- CROSS-SERV ICING RECA LL REPORT  ;03/15/14  3:34 PM
  19450   "RTN","RCT CSP5",2,0)
  19451    ;;4.5;Acc ounts Rece ivable;**3 15**;Mar 2 0, 1995;Bu ild 55
  19452   "RTN","RCT CSP5",3,0)
  19453    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  19454   "RTN","RCT CSP5",4,0)
  19455    ;
  19456   "RTN","RCT CSP5",5,0)
  19457    Q
  19458   "RTN","RCT CSP5",6,0)
  19459    ;
  19460   "RTN","RCT CSP5",7,0)
  19461   CSRCLRT  ;                    cr oss-servic ing recall  report, p rints sort ed individ ual bills  that make  up a cross -servicing  account
  19462   "RTN","RCT CSP5",8,0)
  19463    N RCSORT, PAGE,DASH, DTOUT,DUOU T,DIROUT,V ALUE,SSN,P ROMPT,EXCE L,RCIEN,BI LLN,RCDTV, RCUSER,RCT RAN,RCDATE ,TERMDIG,C URDT,DATE, DBTR
  19464   "RTN","RCT CSP5",9,0)
  19465    N DTFRM,D TTO,DTFRMT O,POP,ZTDE SC,ZTREQ,Z TSAVE,ZTRT N,ZTSK,X,Y ,DIRUT,STO P
  19466   "RTN","RCT CSP5",10,0 )
  19467    S PAGE=0, DASH="",$P (DASH,"-", 78)="",SSN =0000
  19468   "RTN","RCT CSP5",11,0 )
  19469    W !
  19470   "RTN","RCT CSP5",12,0 )
  19471    K ^TMP("R CTCSP5",$J )
  19472   "RTN","RCT CSP5",13,0 )
  19473    S DIR(0)= "S^1:Bill  Number;2:D ebtor Name ",DIR("A") ="Sort by" ,DIR("B")= 2 D ^DIR K  DIR
  19474   "RTN","RCT CSP5",14,0 )
  19475    S RCSORT= Y Q:($D(DT OUT)!$D(DU OUT)!$D(DI ROUT))
  19476   "RTN","RCT CSP5",15,0 )
  19477    S DTFRMTO =$$DTFRMTO ^RCTCSP2 Q :'DTFRMTO   ;Get date  range as  per PRCA*4 .5*315
  19478   "RTN","RCT CSP5",16,0 )
  19479    S (DATE,D TFRM)=$$FM ADD^XLFDT( +$P(DTFRMT O,U,2)),DT TO=$P(DTFR MTO,U,3),C URDT=0
  19480   "RTN","RCT CSP5",17,0 )
  19481    S EXCEL=0 ,PROMPT="C APTURE Rep ort data t o an Excel  Document" ,DIR(0)="Y ",DIR("?") ="^D HEXC^ RCTCSJR"
  19482   "RTN","RCT CSP5",18,0 )
  19483    S EXCEL=$ $SELECT^RC TCSJR(PROM PT,"NO") I  "01"'[EXC EL S STOP= 1 Q
  19484   "RTN","RCT CSP5",19,0 )
  19485    I EXCEL=1  D EXCMSG^ RCTCSJR ;  Display Ex cel displa y message
  19486   "RTN","RCT CSP5",20,0 )
  19487    K IOP,IO( "Q") S %ZI S="MQ",%ZI S("B")=""  D ^%ZIS Q: POP
  19488   "RTN","RCT CSP5",21,0 )
  19489    I $D(IO(" Q")) D  Q
  19490   "RTN","RCT CSP5",22,0 )
  19491    .S ZTSAVE ("RCSORT") ="",ZTSAVE ("EXCEL")= "",ZTSAVE( "DTFRM")=" ",ZTSAVE(" DTTO")=""
  19492   "RTN","RCT CSP5",23,0 )
  19493    .S ZTSAVE ("PAGE")=" ",ZTSAVE(" SSN")="",Z TSAVE("DAS H")=""
  19494   "RTN","RCT CSP5",24,0 )
  19495    .S ZTRTN= "PRTSORT^R CTCSP5",ZT DESC="CROS S-SERVICIN G RECALL R EPORT"
  19496   "RTN","RCT CSP5",25,0 )
  19497    .D ^%ZTLO AD,^%ZISC
  19498   "RTN","RCT CSP5",26,0 )
  19499    .I $G(ZTS K) W !!,"R eport comp ilation ha s started  with task#  ",ZTSK,". ",! S DIR( 0)="E" D ^ DIR K DIR
  19500   "RTN","RCT CSP5",27,0 )
  19501    .Q
  19502   "RTN","RCT CSP5",28,0 )
  19503    I 'EXCEL  W !!,"Comp iling Cros s-Servicin g Recall R eport.  Pl ease wait  ... ",!
  19504   "RTN","RCT CSP5",29,0 )
  19505    ; This ro utine uses  GETS^DIQ  rather tha n a print  template,  then is us es $Name f or simplic ity and le ss typing
  19506   "RTN","RCT CSP5",30,0 )
  19507   PRTSORT  ;
  19508   "RTN","RCT CSP5",31,0 )
  19509    N FLAG S  FLAG=1  ;U sed mainly  for 433 t o stop if  not a vali d transact ion type
  19510   "RTN","RCT CSP5",32,0 )
  19511    ;
  19512   "RTN","RCT CSP5",33,0 )
  19513    I RCSORT= 1 D   ;               rewrite fo r EXCEL an d faster p rocessing,  added Use r ID (as p er PRCA*4. 5*315)
  19514   "RTN","RCT CSP5",34,0 )
  19515    .S (RCIEN )=0 F  S R CIEN=$O(^P RCA(430,RC IEN)) Q:'R CIEN  D
  19516   "RTN","RCT CSP5",35,0 )
  19517    ..Q:('+$P ($G(^PRCA( 430,RCIEN, 15)),U,2))   ;QUIT if  'TCSP REC ALL FLAG'  is Null
  19518   "RTN","RCT CSP5",36,0 )
  19519    ..I $P($G (^PRCA(430 ,RCIEN,15) ),U,3)'=""  S FLAG=0  Q:$P($G(^P RCA(430,RC IEN,15)),U ,3)<DTFRM! ($P($G(^PR CA(430,RCI EN,15)),U, 3)>DTTO)   ;If using  "recall ef fective da te" to scr een
  19520   "RTN","RCT CSP5",37,0 )
  19521    ..K RCLIS T,LIST,MSG  D GETS^DI Q(430,RCIE N_",",".01 ;9;155;151 ;153;154", "IE","LIST ","MSG") Q :$D(LIST)< 10  S RCLI ST=$NA(LIS T(430,RCIE N_","))
  19522   "RTN","RCT CSP5",38,0 )
  19523    ..S DEBTO R=$P($G(^P RCA(430,RC IEN,0)),U, 9)
  19524   "RTN","RCT CSP5",39,0 )
  19525    ..I '$D(^ RCD(340,DE BTOR,0)) S  SSN="     "  ;set SS N to blank  if not VA  employee  or Patient
  19526   "RTN","RCT CSP5",40,0 )
  19527    ..I $D(^R CD(340,DEB TOR,0)) S  SSN=$E($$S SN^RCFN01( $P($G(^RCD (340,DEBTO R,0)),"^") ),6,9) S T ERMDIG=$E( @RCLIST@(9 ,"E"),1)_$ S(SSN'="": SSN,1:"      ")
  19528   "RTN","RCT CSP5",41,0 )
  19529    ..S RCUSE R="",RCTRA N=""
  19530   "RTN","RCT CSP5",42,0 )
  19531    ..I $P(^P RCA(430,RC IEN,15),U, 3)="" D
  19532   "RTN","RCT CSP5",43,0 )
  19533    ...F  S R CTRAN=$O(^ PRCA(433," C",RCIEN,R CTRAN),-1)  Q:RCTRAN= ""  D
  19534   "RTN","RCT CSP5",44,0 )
  19535    ....I $P( $G(^PRCA(4 33,RCTRAN, 5)),U,2)=" CS BILL RE CALL"!($P( $G(^PRCA(4 33,RCTRAN, 5)),U,2)=" CS CASE RE CALL")!($P ($G(^PRCA( 433,RCTRAN ,5)),U,2)= "CS DEBTOR  RECALL")! ($P($G(^PR CA(433,RCT RAN,5)),U, 2)="CS REC ALL PLACED ") D
  19536   "RTN","RCT CSP5",45,0 )
  19537    .....S RC USER=$P(^P RCA(433,RC TRAN,0),U, 9),RCUSER= $E($$GET1^ DIQ(200,RC USER_",",. 01),1,10), FLAG=0
  19538   "RTN","RCT CSP5",46,0 )
  19539    ..I $P(^P RCA(430,RC IEN,15),U, 3)'="" D
  19540   "RTN","RCT CSP5",47,0 )
  19541    ...F  S R CTRAN=$O(^ PRCA(433," C",RCIEN,R CTRAN)) Q: RCTRAN=""   D
  19542   "RTN","RCT CSP5",48,0 )
  19543    ....I $P( $G(^PRCA(4 33,RCTRAN, 5)),U,2)=" CS BILL RE CALL"!($P( $G(^PRCA(4 33,RCTRAN, 5)),U,2)=" CS CASE RE CALL")!($P ($G(^PRCA( 433,RCTRAN ,5)),U,2)= "CS DEBTOR  RECALL")  D
  19544   "RTN","RCT CSP5",49,0 )
  19545    .....S RC USER=$P(^P RCA(433,RC TRAN,0),U, 9),RCUSER= $E($$GET1^ DIQ(200,RC USER_",",. 01),1,10), FLAG=0
  19546   "RTN","RCT CSP5",50,0 )
  19547    ..;Specia l logic ap plied PRCA *4.5*315
  19548   "RTN","RCT CSP5",51,0 )
  19549    ..; They  want to so rt by date , but when  the date  is NULL we  need to u se alterna te data fi eld, so if  a date is  present u se negativ e value ot herwise us e RCIEN 
  19550   "RTN","RCT CSP5",52,0 )
  19551    ..; that  allows us  to sort by  date (new est first) .  When we  print if  the number  is longer  than 8 (n egative da te) char p rint "Pend ing".
  19552   "RTN","RCT CSP5",53,0 )
  19553    ..Q:FLAG
  19554   "RTN","RCT CSP5",54,0 )
  19555    ..S RCDTV =@RCLIST@( 153,"I"),R CDTV=$S(RC DTV'="":-R CDTV,1:RCI EN)
  19556   "RTN","RCT CSP5",55,0 )
  19557    ..I RCDTV >0 S RCDTV =-RCDTV D
  19558   "RTN","RCT CSP5",56,0 )
  19559    ...I $L(R CDTV)<10 S  RCDTV=$E( -99999999, 1,(11-$L(R CDTV)))_$E (RCDTV,2,9 ) Q  ;Ensu re that en tries that  use IEN a re 9 chara cters, thi s makes em pty dates  float to t he top
  19560   "RTN","RCT CSP5",57,0 )
  19561    ...I $E(R CDTV,2)<3  S $E(RCDTV ,1,4)=-999   ;If IEN  is long we  need to a ssure that  the first  4 charact ers are -9 99 , so th at null da tes float  to the top
  19562   "RTN","RCT CSP5",58,0 )
  19563    ...Q
  19564   "RTN","RCT CSP5",59,0 )
  19565    ..S ^TMP( "RCTCSP5", $J,@RCLIST @(.01,"E") ,RCDTV)=@R CLIST@(.01 ,"E")_U_$E (@RCLIST@( 9,"E"),1,1 7)_U_TERMD IG
  19566   "RTN","RCT CSP5",60,0 )
  19567    ..S ^TMP( "RCTCSP5", $J,@RCLIST @(.01,"E") ,RCDTV)=^T MP("RCTCSP 5",$J,@RCL IST@(.01," E"),RCDTV) _U_$J(@RCL IST@(155," E"),9,2)_U _$S($L(RCD TV)=8:$$FM TE^XLFDT(- RCDTV,"2Z" ),1:"Pendi ng")_U_@RC LIST@(154, "I")_"-"_$ E(@RCLIST@ (154,"E"), 1,7)_U_RCU SER
  19568   "RTN","RCT CSP5",61,0 )
  19569    .D CSRCLH 1
  19570   "RTN","RCT CSP5",62,0 )
  19571    .S (BILLN ,RCDTV)=""  F  S BILL N=$O(^TMP( "RCTCSP5", $J,BILLN))  Q:BILLN=" "  F  S RC DTV=$O(^TM P("RCTCSP5 ",$J,BILLN ,RCDTV)) Q :RCDTV=""   D
  19572   "RTN","RCT CSP5",63,0 )
  19573    ..I 'EXCE L W !,$P(^ TMP("RCTCS P5",$J,BIL LN,RCDTV), U),?13,$P( ^TMP("RCTC SP5",$J,BI LLN,RCDTV) ,U,2),?31, $P(^TMP("R CTCSP5",$J ,BILLN,RCD TV),U,3)
  19574   "RTN","RCT CSP5",64,0 )
  19575    ..I 'EXCE L W ?33,$P (^TMP("RCT CSP5",$J,B ILLN,RCDTV ),U,4),?47 ,$P(^TMP(" RCTCSP5",$ J,BILLN,RC DTV),U,5), ?56,$P(^TM P("RCTCSP5 ",$J,BILLN ,RCDTV),U, 6),?67,$P( ^TMP("RCTC SP5",$J,BI LLN,RCDTV) ,U,7) Q
  19576   "RTN","RCT CSP5",65,0 )
  19577    ..I EXCEL  W !,$P(^T MP("RCTCSP 5",$J,BILL N,RCDTV),U ,1,4)_U_$S ($L(RCDTV) =8:$$FMTE^ XLFDT(-RCD TV,"2Z"),1 :"Pending" )_U_$P(^TM P("RCTCSP5 ",$J,BILLN ,RCDTV),U, 6,10)
  19578   "RTN","RCT CSP5",66,0 )
  19579    .I '$D(^T MP("RCTCSP 5",$J)) W  !,"No reco rds found" ,!!
  19580   "RTN","RCT CSP5",67,0 )
  19581    .Q
  19582   "RTN","RCT CSP5",68,0 )
  19583    ;
  19584   "RTN","RCT CSP5",69,0 )
  19585    I RCSORT= 2 D  ; rew rite for E XCEL and f aster proc essing, ad ded User I D (as per  PRCA*4.5*3 15)
  19586   "RTN","RCT CSP5",70,0 )
  19587    .S (RCIEN )=0 F  S R CIEN=$O(^P RCA(430,RC IEN)) Q:'R CIEN  D
  19588   "RTN","RCT CSP5",71,0 )
  19589    ..Q:('+$P ($G(^PRCA( 430,RCIEN, 15)),U,2))   ;QUIT if  'DATE BIL L REFERRED  TO TCSP'  is Null
  19590   "RTN","RCT CSP5",72,0 )
  19591    ..I $P($G (^PRCA(430 ,RCIEN,15) ),U,3)'=""  S FLAG=0  Q:$P($G(^P RCA(430,RC IEN,15)),U ,3)<DTFRM! ($P($G(^PR CA(430,RCI EN,15)),U, 3)>DTTO)   ;If using  "recall ef fective da te" to scr een
  19592   "RTN","RCT CSP5",73,0 )
  19593    ..K RCLIS T,LIST,MSG  D GETS^DI Q(430,RCIE N_",",".01 ;9;155;151 ;153;154", "IE","LIST ","MSG") Q :$D(LIST)< 10  S RCLI ST=$NA(LIS T(430,RCIE N_","))
  19594   "RTN","RCT CSP5",74,0 )
  19595    ..S DEBTO R=$P($G(^P RCA(430,RC IEN,0)),U, 9)
  19596   "RTN","RCT CSP5",75,0 )
  19597    ..I '$D(^ RCD(340,DE BTOR,0)) S  SSN="     "  ;set SS N to blank  if not VA  employee  or Patient
  19598   "RTN","RCT CSP5",76,0 )
  19599    ..I $D(^R CD(340,DEB TOR,0)) S  SSN=$E($$S SN^RCFN01( $P($G(^RCD (340,DEBTO R,0)),"^") ),6,9) S T ERMDIG=$E( @RCLIST@(9 ,"E"),1)_$ S(SSN'="": SSN,1:"      ")
  19600   "RTN","RCT CSP5",77,0 )
  19601    ..S RCUSE R="",RCTRA N=""
  19602   "RTN","RCT CSP5",78,0 )
  19603    ..I $P(^P RCA(430,RC IEN,15),U, 3)="" D
  19604   "RTN","RCT CSP5",79,0 )
  19605    ...F  S R CTRAN=$O(^ PRCA(433," C",RCIEN,R CTRAN),-1)  Q:RCTRAN= ""  D
  19606   "RTN","RCT CSP5",80,0 )
  19607    ....I $P( $G(^PRCA(4 33,RCTRAN, 5)),U,2)=" CS BILL RE CALL"!($P( $G(^PRCA(4 33,RCTRAN, 5)),U,2)=" CS CASE RE CALL")!($P ($G(^PRCA( 433,RCTRAN ,5)),U,2)= "CS DEBTOR  RECALL")! ($P($G(^PR CA(433,RCT RAN,5)),U, 2)="CS REC ALL PLACED ") D
  19608   "RTN","RCT CSP5",81,0 )
  19609    .....S RC USER=$P(^P RCA(433,RC TRAN,0),U, 9),RCUSER= $E($$GET1^ DIQ(200,RC USER_",",. 01),1,10), FLAG=0
  19610   "RTN","RCT CSP5",82,0 )
  19611    ..I $P(^P RCA(430,RC IEN,15),U, 3)'="" D
  19612   "RTN","RCT CSP5",83,0 )
  19613    ...F  S R CTRAN=$O(^ PRCA(433," C",RCIEN,R CTRAN)) Q: RCTRAN=""   D
  19614   "RTN","RCT CSP5",84,0 )
  19615    ....I $P( $G(^PRCA(4 33,RCTRAN, 5)),U,2)=" CS BILL RE CALL"!($P( $G(^PRCA(4 33,RCTRAN, 5)),U,2)=" CS CASE RE CALL")!($P ($G(^PRCA( 433,RCTRAN ,5)),U,2)= "CS DEBTOR  RECALL")  D
  19616   "RTN","RCT CSP5",85,0 )
  19617    .....S RC USER=$P(^P RCA(433,RC TRAN,0),U, 9),RCUSER= $E($$GET1^ DIQ(200,RC USER_",",. 01),1,10), FLAG=0
  19618   "RTN","RCT CSP5",86,0 )
  19619    ..; They  want to so rt by date , but when  the date  is NULL we  need to u se alterna te data fi eld, so if  a date is  present u se negativ e value ot herwise us e RCIEN 
  19620   "RTN","RCT CSP5",87,0 )
  19621    ..; that  allows us  to sort by  date (new est first) .  When we  print if  the number  is longer  than 8 (n egative da te) char p rint "Pend ing".
  19622   "RTN","RCT CSP5",88,0 )
  19623    ..Q:FLAG
  19624   "RTN","RCT CSP5",89,0 )
  19625    ..S RCDTV =@RCLIST@( 153,"I"),R CDTV=$S(RC DTV'="":-R CDTV,1:RCI EN)
  19626   "RTN","RCT CSP5",90,0 )
  19627    ..I RCDTV >0 S RCDTV =-RCDTV D
  19628   "RTN","RCT CSP5",91,0 )
  19629    ...I $L(R CDTV)<10 S  RCDTV=$E( -99999999, 1,(11-$L(R CDTV)))_$E (RCDTV,2,9 ) Q  ;Ensu re that en tries that  use IEN a re 9 chara cters, thi s makes em pty dates  float to t he top
  19630   "RTN","RCT CSP5",92,0 )
  19631    ...I $E(R CDTV,2)<3  S $E(RCDTV ,1,4)=-999   ;If IEN  is long we  need to a ssure that  the first  4 charact ers are -9 99 , so th at null da tes float  to the top
  19632   "RTN","RCT CSP5",93,0 )
  19633    ...Q
  19634   "RTN","RCT CSP5",94,0 )
  19635    .. I EXCE L D  Q
  19636   "RTN","RCT CSP5",95,0 )
  19637    ...S ^TMP ("RCTCSP5" ,$J,@RCLIS T@(9,"E"), RCIEN,RCDT V)=$E(@RCL IST@(9,"E" ),1,16)_U_ @RCLIST@(. 01,"E")_U_ TERMDIG_U_ $J(@RCLIST @(155,"E") ,9,2)_U
  19638   "RTN","RCT CSP5",96,0 )
  19639    ...S ^TMP ("RCTCSP5" ,$J,@RCLIS T@(9,"E"), RCIEN,RCDT V)=^TMP("R CTCSP5",$J ,@RCLIST@( 9,"E"),RCI EN,RCDTV)_ $S($L(RCDT V)=8:$$FMT E^XLFDT(-R CDTV,"2Z") ,1:"Pendin g")_U_@RCL IST@(154," I")_"-"_$E (@RCLIST@( 154,"E"),1 ,7)_U_RCUS ER Q
  19640   "RTN","RCT CSP5",97,0 )
  19641    ..I 'EXCE L D  Q
  19642   "RTN","RCT CSP5",98,0 )
  19643    ...S ^TMP ("RCTCSP5" ,$J,@RCLIS T@(9,"E"), RCIEN,RCDT V)=$E(@RCL IST@(9,"E" ),1,16)_U_ @RCLIST@(. 01,"E")_U_ SSN_U_$J(@ RCLIST@(15 5,"E"),9,2 )_U_$S($L( RCDTV)=8:$ $FMTE^XLFD T(-RCDTV," 2Z"),1:"Pe nding")
  19644   "RTN","RCT CSP5",99,0 )
  19645    ...S ^TMP ("RCTCSP5" ,$J,@RCLIS T@(9,"E"), RCIEN,RCDT V)=^TMP("R CTCSP5",$J ,@RCLIST@( 9,"E"),RCI EN,RCDTV)_ U_@RCLIST@ (154,"I")_ "-"_$E(@RC LIST@(154, "E"),1,7)_ U_RCUSER
  19646   "RTN","RCT CSP5",100, 0)
  19647    .D CSRCLH 2
  19648   "RTN","RCT CSP5",101, 0)
  19649    .S (DBTR, RCDTV,RCIE N)="" F  S  DBTR=$O(^ TMP("RCTCS P5",$J,DBT R)) Q:DBTR =""  F  S  RCIEN=$O(^ TMP("RCTCS P5",$J,DBT R,RCIEN))  Q:RCIEN=""   F  S RCD TV=$O(^TMP ("RCTCSP5" ,$J,DBTR,R CIEN,RCDTV )) Q:RCDTV =""  D
  19650   "RTN","RCT CSP5",102, 0)
  19651    ..I 'EXCE L W !,$P(^ TMP("RCTCS P5",$J,DBT R,RCIEN,RC DTV),U),?1 8,$P(^TMP( "RCTCSP5", $J,DBTR,RC IEN,RCDTV) ,U,2),?31, $P(^TMP("R CTCSP5",$J ,DBTR,RCIE N,RCDTV),U ,3)
  19652   "RTN","RCT CSP5",103, 0)
  19653    ..I 'EXCE L W ?36,$P (^TMP("RCT CSP5",$J,D BTR,RCIEN, RCDTV),U,4 ),?47,$P(^ TMP("RCTCS P5",$J,DBT R,RCIEN,RC DTV),U,5), ?56,$P(^TM P("RCTCSP5 ",$J,DBTR, RCIEN,RCDT V),U,6),?6 7,$P(^TMP( "RCTCSP5", $J,DBTR,RC IEN,RCDTV) ,U,7) Q
  19654   "RTN","RCT CSP5",104, 0)
  19655    ..I EXCEL  W !,^TMP( "RCTCSP5", $J,DBTR,RC IEN,RCDTV)
  19656   "RTN","RCT CSP5",105, 0)
  19657    .Q
  19658   "RTN","RCT CSP5",106, 0)
  19659    ;
  19660   "RTN","RCT CSP5",107, 0)
  19661    K ^TMP("R CTCSP5",$J )
  19662   "RTN","RCT CSP5",108, 0)
  19663    I $E(IOST ,1,2)="C-"  R !!,"END  OF REPORT ...PRESS R ETURN TO C ONTINUE",X :DTIME W @ IOF
  19664   "RTN","RCT CSP5",109, 0)
  19665    D:'$D(ZTQ UEUED) ^%Z ISC
  19666   "RTN","RCT CSP5",110, 0)
  19667    S:$D(ZTQU EUED) ZTRE Q="@"
  19668   "RTN","RCT CSP5",111, 0)
  19669    K IOP,%ZI S,ZTQUEUED
  19670   "RTN","RCT CSP5",112, 0)
  19671    Q
  19672   "RTN","RCT CSP5",113, 0)
  19673    ;
  19674   "RTN","RCT CSP5",114, 0)
  19675   CSRCLH1  ; header for  cross-ser vicing rec all report  1
  19676   "RTN","RCT CSP5",115, 0)
  19677    W @IOF
  19678   "RTN","RCT CSP5",116, 0)
  19679    S PAGE=PA GE+1
  19680   "RTN","RCT CSP5",117, 0)
  19681    I 'EXCEL  D  Q
  19682   "RTN","RCT CSP5",118, 0)
  19683    .W !,"PAG E "_PAGE,? 12,"CROSS- SERVICING  RECALL REP ORT (SORTE D BY BILL  NUMBER)",? 68,$$FMTE^ XLFDT(DT," 2Z")
  19684   "RTN","RCT CSP5",119, 0)
  19685    .W !,DASH ,!
  19686   "RTN","RCT CSP5",120, 0)
  19687    .W !,"BIL L NO.",?13 ,"DEBTOR", ?31,"Pt ID ",?37,"REC L AMT",?47 ,"RECL DT" ,?56,"RECA LL RSN",?6 7,"USER ID "
  19688   "RTN","RCT CSP5",121, 0)
  19689    .W !,"--- -----",?13 ,"------", ?31,"----- ",?37,"--- -----",?47 ,"-------" ,?56,"---- ------",?6 7,"------- ",!
  19690   "RTN","RCT CSP5",122, 0)
  19691    ;EXCEL FO RM
  19692   "RTN","RCT CSP5",123, 0)
  19693    W !,"PAGE  "_PAGE_U_ U_"CS RECA LL RPT (BI LL)"_U_U_$ $FMTE^XLFD T(DT,"2Z")
  19694   "RTN","RCT CSP5",124, 0)
  19695    W !,"BILL  NO."_U_"D EBTOR"_U_" Pt ID"_U_" RECL AMT"_ U_"RECALL  DT"_U_"REC ALL RSN"_U _"USER ID"
  19696   "RTN","RCT CSP5",125, 0)
  19697    Q
  19698   "RTN","RCT CSP5",126, 0)
  19699    ;
  19700   "RTN","RCT CSP5",127, 0)
  19701   CSRCLH2  ; header for  cross-ser vicing rec all report  2
  19702   "RTN","RCT CSP5",128, 0)
  19703    I 'EXCEL  W @IOF
  19704   "RTN","RCT CSP5",129, 0)
  19705    S PAGE=PA GE+1
  19706   "RTN","RCT CSP5",130, 0)
  19707    I 'EXCEL  D  Q
  19708   "RTN","RCT CSP5",131, 0)
  19709    .W !,"PAG E "_PAGE,? 14,"CROSS- SERVICING  RECALL REP ORT (SORTE D BY DEBTO R)",?68,$$ FMTE^XLFDT (DT,"2Z")
  19710   "RTN","RCT CSP5",132, 0)
  19711    .W !,DASH ,!
  19712   "RTN","RCT CSP5",133, 0)
  19713    .W !,"DEB TOR",?18," BILL NO.", ?31,"Pt ID ",?37,"REC L AMT",?47 ,"RECL DT" ,?56,"RECA LL RSN",?6 7,"USER ID "
  19714   "RTN","RCT CSP5",134, 0)
  19715    .W !,"--- ---",?18," --------", ?31,"----- ",?37,"--- -----",?47 ,"-------" ,?56,"---- ------",?6 7,"------- ",!
  19716   "RTN","RCT CSP5",135, 0)
  19717    ;EXCEL FO RMAT
  19718   "RTN","RCT CSP5",136, 0)
  19719    W !,"PAGE  "_PAGE_U_ U_"CS RECA LL RPT (DE BTOR)"_U_U _$$FMTE^XL FDT(DT,"2Z ")
  19720   "RTN","RCT CSP5",137, 0)
  19721    W !,"DEBT OR"_U_"BIL L NO."_U_" Pt ID"_U_" RECL AMT"_ U_"RECALL  DT"_U_"REC ALL RSN"_U _"USER ID"
  19722   "RTN","RCT CSP5",138, 0)
  19723    Q
  19724   "RTN","RCT CSP5",139, 0)
  19725    ;
  19726   "RTN","RCT CSP5",140, 0)
  19727   IAIRPT ;    Treasury  Cross-Serv icing IAI  Report
  19728   "RTN","RCT CSP5",141, 0)
  19729    ;This rep ort displa ys a recor d of curre nt VHA bil ls at Trea sury. It i s a tool t hat can be  used to i dentify bi lls errone ously 
  19730   "RTN","RCT CSP5",142, 0)
  19731    ;listed i n a referr al status  in VistA w hen reconc iled with  the Print  Cross-Serv icing Repo rt.
  19732   "RTN","RCT CSP5",143, 0)
  19733    ;
  19734   "RTN","RCT CSP5",144, 0)
  19735    N RDATES, RDGBL,NODE ,PAGE,DASH ,EXCEL,DEB TOR,BILLDA ,RCBILL,CN T,CURDT,PO P,RCNAME,Z TDESC,ZTRE Q,ZTSAVE,Z TSK,ZTRTN, X,Y,STOP
  19736   "RTN","RCT CSP5",145, 0)
  19737    S PAGE=0, DASH="",$P (DASH,"-", 78)=""
  19738   "RTN","RCT CSP5",146, 0)
  19739    ;Get avai lable repo rt dates
  19740   "RTN","RCT CSP5",147, 0)
  19741    S RDGBL=" RCTCSP6",C NT=1 F  S  RDGBL=$O(^ XTMP(RDGBL ),-1) Q:RD GBL=""!($E (RDGBL,1)= "Q")  I RD GBL["RCTCS P5" D
  19742   "RTN","RCT CSP5",148, 0)
  19743    . I $P(RD GBL," - ", 2)="" S VA LUE="No re port data  to print"  Q
  19744   "RTN","RCT CSP5",149, 0)
  19745    . S RDATE S(CNT)=$P( RDGBL," -  ",2)_U_$$F MTE^XLFDT( $P(RDGBL,"  - ",2),"2 Z"),RDGBL( CNT)=RDGBL ,CNT=CNT+1
  19746   "RTN","RCT CSP5",150, 0)
  19747    . Q
  19748   "RTN","RCT CSP5",151, 0)
  19749    I '$D(RDA TES(1)) W  !,?5,"Ther e is no da ta availab le for the  report, q uitting.", ! Q
  19750   "RTN","RCT CSP5",152, 0)
  19751    ; Show da tes sorted  by newest  first and  only show  the last  two report  dates if  they exist
  19752   "RTN","RCT CSP5",153, 0)
  19753    I '$D(RDA TES(2)) S  DIR(0)="S^ 1:"_$P(RDA TES(1),U,2 ),DIR("A") ="Print da te?",DIR(" B")=1 D ^D IR K DIR
  19754   "RTN","RCT CSP5",154, 0)
  19755    I $D(RDAT ES(2)) S D IR(0)="S^1 :"_$P(RDAT ES(1),U,2) _";2:"_$P( RDATES(2), U,2),DIR(" A")="      Print IAI  report dat e?",DIR("B ")=1 D ^DI R K DIR
  19756   "RTN","RCT CSP5",155, 0)
  19757    Q:$G(DUOU T)
  19758   "RTN","RCT CSP5",156, 0)
  19759    S NODE=RD GBL(Y),RDA TES=+RDATE S(Y)
  19760   "RTN","RCT CSP5",157, 0)
  19761    S EXCEL=0 ,PROMPT="C APTURE Rep ort data t o an Excel  Document" ,DIR(0)="Y ",DIR("?") ="^D HEXC^ RCTCSJR"
  19762   "RTN","RCT CSP5",158, 0)
  19763    S EXCEL=$ $SELECT^RC TCSJR(PROM PT,"NO") I  "01"'[EXC EL S STOP= 1 Q
  19764   "RTN","RCT CSP5",159, 0)
  19765    I EXCEL=1  D EXCMSG^ RCTCSJR ;  Display Ex cel displa y message
  19766   "RTN","RCT CSP5",160, 0)
  19767    ;
  19768   "RTN","RCT CSP5",161, 0)
  19769    K IOP,IO( "Q") S %ZI S="MQ",%ZI S("B")=""  D ^%ZIS Q: POP
  19770   "RTN","RCT CSP5",162, 0)
  19771    I $D(IO(" Q")) D  Q
  19772   "RTN","RCT CSP5",163, 0)
  19773    .S ZTSAVE ("NODE")=" ",ZTSAVE(" EXCEL")="" ,ZTSAVE("R DATES")=""
  19774   "RTN","RCT CSP5",164, 0)
  19775    .S ZTRTN= "IAIPRNT^R CTCSP5",ZT DESC="CROS S-SERVICIN G IAI REPO RT"
  19776   "RTN","RCT CSP5",165, 0)
  19777    .D ^%ZTLO AD,^%ZISC
  19778   "RTN","RCT CSP5",166, 0)
  19779    .I $G(ZTS K) W !!,"R eport comp ilation ha s started  with task#  ",ZTSK,". ",!
  19780   "RTN","RCT CSP5",167, 0)
  19781    .Q
  19782   "RTN","RCT CSP5",168, 0)
  19783    .;
  19784   "RTN","RCT CSP5",169, 0)
  19785   IAIPRNT ;
  19786   "RTN","RCT CSP5",170, 0)
  19787    N GETNM,G ETBL,GLO
  19788   "RTN","RCT CSP5",171, 0)
  19789    S PAGE=0
  19790   "RTN","RCT CSP5",172, 0)
  19791    S GLO=$NA (^TMP("RCT CSP5",$J))  K @GLO
  19792   "RTN","RCT CSP5",173, 0)
  19793    D IAIHDR
  19794   "RTN","RCT CSP5",174, 0)
  19795    S DEBTOR= 0 F  S DEB TOR=$O(^XT MP(NODE,DE BTOR)) Q:' DEBTOR  D
  19796   "RTN","RCT CSP5",175, 0)
  19797    . S BILLD A="" F  S  BILLDA=$O( ^XTMP(NODE ,DEBTOR,BI LLDA)) Q:' BILLDA  D
  19798   "RTN","RCT CSP5",176, 0)
  19799    ..S RCBIL L=$P($G(^P RCA(430,BI LLDA,0)),U ),RCNAME=$ E($$GET1^D IQ(430,BIL LDA,9),1,2 0)
  19800   "RTN","RCT CSP5",177, 0)
  19801    ..S SSN=$ S($P($G(^R CD(340,DEB TOR,0)),U) '="":$$SSN ^RCFN01($P (^RCD(340, DEBTOR,0), "^")),1:"N one")
  19802   "RTN","RCT CSP5",178, 0)
  19803    ..I SSN<1  S SSN="No ne"
  19804   "RTN","RCT CSP5",179, 0)
  19805    ..S @GLO@ (RCNAME,RC BILL)=RCBI LL_U_RCNAM E_U_SSN Q
  19806   "RTN","RCT CSP5",180, 0)
  19807    S GETNM=" " F  S GET NM=$O(@GLO @(GETNM))  Q:GETNM=""   S GETBL= "" F  S GE TBL=$O(@GL O@(GETNM,G ETBL)) Q:G ETBL=""  D
  19808   "RTN","RCT CSP5",181, 0)
  19809    .I 'EXCEL  W $P(@GLO @(GETNM,GE TBL),U),?1 5,$P(@GLO@ (GETNM,GET BL),U,2),? 40,$P(@GLO @(GETNM,GE TBL),U,3), !
  19810   "RTN","RCT CSP5",182, 0)
  19811    .I EXCEL  W @GLO@(GE TNM,GETBL) ,!
  19812   "RTN","RCT CSP5",183, 0)
  19813    .;check f or end of  page here,  if necess ary form f eed and pr int header
  19814   "RTN","RCT CSP5",184, 0)
  19815    .I 'EXCEL ,($Y+3)>IO SL D
  19816   "RTN","RCT CSP5",185, 0)
  19817    ..I $E(IO ST,1,2)="C -" S DIR(0 )="E" K DI RUT D ^DIR  Q:$D(DIRU T)
  19818   "RTN","RCT CSP5",186, 0)
  19819    ..D IAIHD R
  19820   "RTN","RCT CSP5",187, 0)
  19821    I 'EXCEL  I $E(IOST, 1,2)="C-"  R !!,"END  OF REPORT. ..PRESS RE TURN TO CO NTINUE",X: DTIME W @I OF
  19822   "RTN","RCT CSP5",188, 0)
  19823    Q
  19824   "RTN","RCT CSP5",189, 0)
  19825   IAIHDR ;
  19826   "RTN","RCT CSP5",190, 0)
  19827    S PAGE=PA GE+1
  19828   "RTN","RCT CSP5",191, 0)
  19829    I 'EXCEL  D  Q
  19830   "RTN","RCT CSP5",192, 0)
  19831    .W @IOF
  19832   "RTN","RCT CSP5",193, 0)
  19833    .W ?10,"T reasury Cr oss-Servic ing IAI Re port",!!," IAI data c ompiled da te: ",$$FM TE^XLFDT(R DATES,"2Z" ),?50,"Pag e ",PAGE
  19834   "RTN","RCT CSP5",194, 0)
  19835    .W !!,"Bi ll Number" ,?20,"Debt or",?43,"S SN",!
  19836   "RTN","RCT CSP5",195, 0)
  19837    .W !,"--- --------", ?15,"----- ---------- --------", ?40,"----- ----",!
  19838   "RTN","RCT CSP5",196, 0)
  19839    ;EXCEL FO RMAT
  19840   "RTN","RCT CSP5",197, 0)
  19841    W !,"PAGE  "_PAGE_U_ U_"Treasur y Cross-Se rvicing IA I Report"_ U_U_$$FMTE ^XLFDT(RDA TES,"2Z")
  19842   "RTN","RCT CSP5",198, 0)
  19843    W !,"Bill  Number"_U _"Debtor"_ U_"SSN",!
  19844   "RTN","RCT CSP5",199, 0)
  19845    Q
  19846   "RTN","RCT CSP7")
  19847   0^68^B5563 240^B51123 76
  19848   "RTN","RCT CSP7",1,0)
  19849   RCTCSP7 ;A LBANY/RGB- CROSS-SERV ICING TRAN SMISSION C ONT'D ;08/ 03/17 3:34  PM
  19850   "RTN","RCT CSP7",2,0)
  19851    ;;4.5;Acc ounts Rece ivable;**3 27,315**;M ar 20, 199 5;Build 55
  19852   "RTN","RCT CSP7",3,0)
  19853    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  19854   "RTN","RCT CSP7",4,0)
  19855    ;
  19856   "RTN","RCT CSP7",5,0)
  19857    ;PRCA*4.5 *327 Moved  rec code  from RCTCS PD to crea te room
  19858   "RTN","RCT CSP7",6,0)
  19859    ;              for b atch mods.
  19860   "RTN","RCT CSP7",7,0)
  19861    ;
  19862   "RTN","RCT CSP7",8,0)
  19863   REC2C ;
  19864   "RTN","RCT CSP7",9,0)
  19865    N REC,KNU M,DEBTNR,D EBTORNB,TA XID,RCDFN, PHONE,ADDR CS
  19866   "RTN","RCT CSP7",10,0 )
  19867    S REC="C2 C"_ACTION_ "363600120 0"_"DM1D "
  19868   "RTN","RCT CSP7",11,0 )
  19869    S KNUM=$P ($P(B0,U,1 ),"-",2)
  19870   "RTN","RCT CSP7",12,0 )
  19871    S DEBTNR= $E(SITE,1, 3)_$$LJZF( KNUM,7)_$T R($J(BILL, 20)," ",0) ,REC=REC_D EBTNR
  19872   "RTN","RCT CSP7",13,0 )
  19873    S DEBTORN B=$E(SITE, 1,3)_$TR($ J(DEBTOR,1 2)," ",0)
  19874   "RTN","RCT CSP7",14,0 )
  19875    S REC=REC _DEBTORNB
  19876   "RTN","RCT CSP7",15,0 )
  19877    S TAXID=$ $TAXID(DEB TOR)
  19878   "RTN","RCT CSP7",16,0 )
  19879    S REC=REC _TAXID
  19880   "RTN","RCT CSP7",17,0 )
  19881    S REC=REC _"SLFIND"
  19882   "RTN","RCT CSP7",18,0 )
  19883    S REC=REC _$$BLANK(2 0)
  19884   "RTN","RCT CSP7",19,0 )
  19885    S RCDFN=+ DEBTOR0
  19886   "RTN","RCT CSP7",20,0 )
  19887    S REC=REC _$$LJSF($$ NAMEFF(RCD FN),60)_"Y "
  19888   "RTN","RCT CSP7",21,0 )
  19889    S ADDRCS= $$ADDR^RCT CSP1(RCDFN ),PHONE=$P (ADDRCS,U, 6)
  19890   "RTN","RCT CSP7",22,0 )
  19891    S REC=REC _$$LJSF($P (ADDRCS,U, 1),35)_$$L JSF($P(ADD RCS,U,2),3 5)_$$LJSF( $P(ADDRCS, U,3),15)_$ $LJSF($P(A DDRCS,U,4) ,2)_$$LJSF ($P(ADDRCS ,U,5),9)
  19892   "RTN","RCT CSP7",23,0 )
  19893    S REC=REC _$$COUNTRY ^RCTCSP1A( $P(ADDRCS, U,7)) ;COU NTRY label  moved due  to routin e size PRC A*4.5*315/ DRF
  19894   "RTN","RCT CSP7",24,0 )
  19895    S REC=REC _"Y"
  19896   "RTN","RCT CSP7",25,0 )
  19897    S REC=REC _$S(PHONE] "":"P",1:"  ")
  19898   "RTN","RCT CSP7",26,0 )
  19899    S REC=REC _$$LJSF($T R(PHONE,"( ) -"),10)_ $$BLANK(4)
  19900   "RTN","RCT CSP7",27,0 )
  19901    S REC=REC _$S(PHONE] "":"Y",1:"  ")
  19902   "RTN","RCT CSP7",28,0 )
  19903    S REC=REC _$$BLANK(4 50-$L(REC) )
  19904   "RTN","RCT CSP7",29,0 )
  19905    S ^XTMP(" RCTCSPD",$ J,BILL,ACT ION,"2C")= REC
  19906   "RTN","RCT CSP7",30,0 )
  19907    S $P(^XTM P("RCTCSPD ",$J,"BILL ",ACTION,B ILL),U,1)= $$TAXID(DE BTOR)
  19908   "RTN","RCT CSP7",31,0 )
  19909    D CLR19(B ILL,4)
  19910   "RTN","RCT CSP7",32,0 )
  19911    Q
  19912   "RTN","RCT CSP7",33,0 )
  19913    ;
  19914   "RTN","RCT CSP7",34,0 )
  19915   NAMEFF(DFN ) ;returns  name for  document a nd name in  file
  19916   "RTN","RCT CSP7",35,0 )
  19917    N FN,LN,M N,NM,DOCNM ,VA,VADM
  19918   "RTN","RCT CSP7",36,0 )
  19919    S NM=""
  19920   "RTN","RCT CSP7",37,0 )
  19921    D DEM^VAD PT
  19922   "RTN","RCT CSP7",38,0 )
  19923    I $D(VADM ) S NM=VAD M(1)
  19924   "RTN","RCT CSP7",39,0 )
  19925    S LN=$TR( $P(NM,",") ," .'-"),M N=$P($P(NM ,",",2),"  ",2)
  19926   "RTN","RCT CSP7",40,0 )
  19927    I ($E(MN, 1,2)="SR") !($E(MN,1, 2)="JR")!( MN?2.3"I") !(MN?0.1"I "1"V"1.3"I ") S MN=""
  19928   "RTN","RCT CSP7",41,0 )
  19929    S FN=$P($ P(NM,",",2 )," ")
  19930   "RTN","RCT CSP7",42,0 )
  19931    S DOCNM=L N_" "_FN_"  "_MN
  19932   "RTN","RCT CSP7",43,0 )
  19933    Q DOCNM
  19934   "RTN","RCT CSP7",44,0 )
  19935    ;
  19936   "RTN","RCT CSP7",45,0 )
  19937   BLANK(X) ; returns 'x ' blank sp aces
  19938   "RTN","RCT CSP7",46,0 )
  19939    N BLANK
  19940   "RTN","RCT CSP7",47,0 )
  19941    S BLANK=" ",$P(BLANK ," ",X+1)= ""
  19942   "RTN","RCT CSP7",48,0 )
  19943    Q BLANK
  19944   "RTN","RCT CSP7",49,0 )
  19945    ;
  19946   "RTN","RCT CSP7",50,0 )
  19947   TAXID(DEBT OR) ;compu tes TAXID  to place o n document s
  19948   "RTN","RCT CSP7",51,0 )
  19949    N TAXID,D IC,DA,DR,D IQ
  19950   "RTN","RCT CSP7",52,0 )
  19951    S TAXID=$ $SSN^RCFN0 1(DEBTOR)
  19952   "RTN","RCT CSP7",53,0 )
  19953    S TAXID=$ $LJSF(TAXI D,9)
  19954   "RTN","RCT CSP7",54,0 )
  19955    Q TAXID
  19956   "RTN","RCT CSP7",55,0 )
  19957    ;
  19958   "RTN","RCT CSP7",56,0 )
  19959   LJSF(X,Y)  ;x left ju stified, y  space fil led
  19960   "RTN","RCT CSP7",57,0 )
  19961    S X=$E(X, 1,Y)
  19962   "RTN","RCT CSP7",58,0 )
  19963    S X=X_$$B LANK(Y-$L( X))
  19964   "RTN","RCT CSP7",59,0 )
  19965    Q X
  19966   "RTN","RCT CSP7",60,0 )
  19967    ;
  19968   "RTN","RCT CSP7",61,0 )
  19969   LJZF(X,Y)  ;x left ju stified, y  zero fill ed
  19970   "RTN","RCT CSP7",62,0 )
  19971    S X=X_"00 00000000"
  19972   "RTN","RCT CSP7",63,0 )
  19973    S X=$E(X, X,Y)
  19974   "RTN","RCT CSP7",64,0 )
  19975    Q X
  19976   "RTN","RCT CSP7",65,0 )
  19977    ;
  19978   "RTN","RCT CSP7",66,0 )
  19979   CLR19(BILL ,X) ; clea r the send  flag
  19980   "RTN","RCT CSP7",67,0 )
  19981    S $P(^PRC A(430,BILL ,19),U,X)= ""
  19982   "RTN","RCT CSP7",68,0 )
  19983    ;
  19984   "RTN","RCT CSPD")
  19985   0^17^B1598 25609^B153 936257
  19986   "RTN","RCT CSPD",1,0)
  19987   RCTCSPD ;A LBANY/BDB- CROSS-SERV ICING TRAN SMISSION ; 03/15/14 3 :34 PM
  19988   "RTN","RCT CSPD",2,0)
  19989    ;;4.5;Acc ounts Rece ivable;**3 01,327,315 **;Mar 20,  1995;Buil d 55
  19990   "RTN","RCT CSPD",3,0)
  19991    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  19992   "RTN","RCT CSPD",4,0)
  19993    ;
  19994   "RTN","RCT CSPD",5,0)
  19995    ;PRCA*4.5 *327 a. Ad d check to  insure de btor exist s to preve nt 
  19996   "RTN","RCT CSPD",6,0)
  19997    ;                 un defined er ror and se t in XTMP  work globa l to
  19998   "RTN","RCT CSPD",7,0)
  19999    ;                 be  reported  via 'TCSP'  mailgroup .
  20000   "RTN","RCT CSPD",8,0)
  20001    ;              b. Ad ded proces s controls  throughou t entire b atch
  20002   "RTN","RCT CSPD",9,0)
  20003    ;                 ru n and mess age to mai l group 'T CSP' batch  run
  20004   "RTN","RCT CSPD",10,0 )
  20005    ;                 is  complete
  20006   "RTN","RCT CSPD",11,0 )
  20007    ;              c. Mo ve SETUP/F INISH to n ew routine  RCTCSPD0
  20008   "RTN","RCT CSPD",12,0 )
  20009    ;                 du e to SACC  size const raints
  20010   "RTN","RCT CSPD",13,0 )
  20011    ;              d. Mo ve REC2C t ag/code to  RCTCSP7 t o create s pace
  20012   "RTN","RCT CSPD",14,0 )
  20013    ;                 fo r debtor u ndefined l ogic
  20014   "RTN","RCT CSPD",15,0 )
  20015    ;
  20016   "RTN","RCT CSPD",16,0 )
  20017   ENTER ;           Ent ry point f rom nightl y process  PRCABJ
  20018   "RTN","RCT CSPD",17,0 )
  20019    N DEBTOR, P150DT,PRI N,INT,ADMI N,TDEB,TFI L,RCDFN,CN TR,SITE,LN ,FN,MN,SIT E,F60DT,VA DM,PHONE,Q UIT,TOTAL, ZIPCODE,FU LLNM,RCNT, REPAY,X1,X 2,ERROR,AD DR,CAT,BIL LDT,CURRTO T,SITECD
  20020   "RTN","RCT CSPD",18,0 )
  20021    N SEQ,CNT LID,PREPDT ,X1,X2,X,D ELDT,ACTDT
  20022   "RTN","RCT CSPD",19,0 )
  20023    D SETUP^R CTCSPD0
  20024   "RTN","RCT CSPD",20,0 )
  20025    S (DEBTOR ,RCNT)=0,S EQ=0
  20026   "RTN","RCT CSPD",21,0 )
  20027   RSDEBTOR ;
  20028   "RTN","RCT CSPD",22,0 )
  20029    F  S DEBT OR=$O(^PRC A(430,"C", DEBTOR)) Q :DEBTOR'?1 N.N  D
  20030   "RTN","RCT CSPD",23,0 )
  20031    .D NOW^%D TC S ^XTMP ("RCTCSPD" ,$J,"ZZBDE BTOR")=%_U _DEBTOR
  20032   "RTN","RCT CSPD",24,0 )
  20033    .N X,RCDF N,DEMCS,DO B,GNDR,DEB TOR0,DEBTO R1,DEBTOR3 ,DEBTOR7,B ILL
  20034   "RTN","RCT CSPD",25,0 )
  20035    .I '$D(^R CD(340,DEB TOR,0)) S  ^XTMP("RCT CSPD",$J," ZZUNDEF",D EBTOR)=""  Q
  20036   "RTN","RCT CSPD",26,0 )
  20037    .S DEBTOR 0=^RCD(340 ,DEBTOR,0) ,DEBTOR1=$ G(^(1)),DE BTOR3=$G(^ (3)),DEBTO R7=$G(^(7) )
  20038   "RTN","RCT CSPD",27,0 )
  20039    .S RCDFN= +DEBTOR0
  20040   "RTN","RCT CSPD",28,0 )
  20041    .S DEMCS= $$DEM^RCTC SP1(RCDFN)
  20042   "RTN","RCT CSPD",29,0 )
  20043    .S DOB=$P (DEMCS,U,2 )
  20044   "RTN","RCT CSPD",30,0 )
  20045    .S GNDR=$ P(DEMCS,U, 1) S:"MF"' [GNDR GNDR ="U"
  20046   "RTN","RCT CSPD",31,0 )
  20047    .I $P(DEB TOR7,U,2)  I '+$P(DEB TOR7,U,3)  D  ;send t ype 2 reca ll record
  20048   "RTN","RCT CSPD",32,0 )
  20049    ..N ACTIO N,B0,B15,B ILL
  20050   "RTN","RCT CSPD",33,0 )
  20051    ..S ACTIO N="L"
  20052   "RTN","RCT CSPD",34,0 )
  20053    ..S B0="" ,B15="",BI LL=0
  20054   "RTN","RCT CSPD",35,0 )
  20055    ..; The c ode below  is designe d to get O NLY one bi ll #.  It  is not a b ug! As per  VA SME co ntacts.
  20056   "RTN","RCT CSPD",36,0 )
  20057    ..F  S BI LL=$O(^PRC A(430,"C", DEBTOR,BIL L)) Q:BILL '?1N.N  I  $D(^PRCA(4 30,"TCSP", BILL)) I $ P(^PRCA(43 0,BILL,15) ,U,7)'=1 S  B0=$G(^PR CA(430,BIL L,0)),B15= $G(^(15))  Q  ;get on e bill
  20058   "RTN","RCT CSPD",37,0 )
  20059    ..I BILL= "" S BILL= 0 S $P(^RC D(340,DEBT OR,7),U,2, 4)="^^",$P (DEBTOR7,U ,2,4)="^^"  Q  ;cs de btor with  no cs bill , clear th e debtor r ecall flag , quit
  20060   "RTN","RCT CSPD",38,0 )
  20061    ..D REC2
  20062   "RTN","RCT CSPD",39,0 )
  20063    ..S $P(^R CD(340,DEB TOR,7),U,3 )=DT
  20064   "RTN","RCT CSPD",40,0 )
  20065    ..S DEBTO R7=^RCD(34 0,DEBTOR,7 )
  20066   "RTN","RCT CSPD",41,0 )
  20067    ..S BILL= 0 ;set deb tor cross- serviced b ills as re called
  20068   "RTN","RCT CSPD",42,0 )
  20069    ..F  S BI LL=$O(^PRC A(430,"C", DEBTOR,BIL L)) Q:BILL '?1N.N  D
  20070   "RTN","RCT CSPD",43,0 )
  20071    ...D NOW^ %DTC S ^XT MP("RCTCSP D",$J,"ZZC RBILL")=%_ U_BILL
  20072   "RTN","RCT CSPD",44,0 )
  20073    ...I $D(^ PRCA(430," TCSP",BILL )) D  Q  ; bill previ ously sent  to TCSP
  20074   "RTN","RCT CSPD",45,0 )
  20075    ....S $P( ^PRCA(430, BILL,15),U ,1)="" ;cl ear the da te referre d
  20076   "RTN","RCT CSPD",46,0 )
  20077    ....S $P( ^PRCA(430, BILL,15),U ,2)=1 ;set  the recal l flag
  20078   "RTN","RCT CSPD",47,0 )
  20079    ....S $P( ^PRCA(430, BILL,15),U ,3)=DT ;se t the reca ll date
  20080   "RTN","RCT CSPD",48,0 )
  20081    ....S $P( ^PRCA(430, BILL,15),U ,4)=$P(DEB TOR7,U,4)  ;set the r ecall reas on
  20082   "RTN","RCT CSPD",49,0 )
  20083    ....S $P( ^PRCA(430, BILL,15),U ,5)=$$GET1 ^DIQ(430,B ILL,11) ;s et the rec all amount  to the cu rrent amou nt
  20084   "RTN","RCT CSPD",50,0 )
  20085    ....K ^PR CA(430,"TC SP",BILL)  ;kill the  cross-serv icing cros s referenc e
  20086   "RTN","RCT CSPD",51,0 )
  20087    ....D RCR SD^RCTCSPD 4 ; set de btor recal l non-fina ncial tran saction PR CA*4.5*315
  20088   "RTN","RCT CSPD",52,0 )
  20089    .S (BILL, TOTAL,REPA Y)=0
  20090   "RTN","RCT CSPD",53,0 )
  20091    .F  S BIL L=$O(^PRCA (430,"C",D EBTOR,BILL )) Q:BILL' ?1N.N  D
  20092   "RTN","RCT CSPD",54,0 )
  20093    ..D NOW^% DTC S ^XTM P("RCTCSPD ",$J,"ZZCT RACKER")=% _U_DEBTOR_ U_BILL
  20094   "RTN","RCT CSPD",55,0 )
  20095    ..N B0,B4 ,B6,B7,B9, B12,B121,B 14,B15,B16 ,B19,B20,A CTION
  20096   "RTN","RCT CSPD",56,0 )
  20097    ..S B0=$G (^PRCA(430 ,BILL,0)), B4=$G(^(4) ),B6=$G(^( 6)),B7=$G( ^(7)),B9=$ G(^(9)),B1 2=$G(^(12) ),B121=$G( ^(12.1)),B 14=$G(^(14 )),B15=$G( ^(15)),B16 =$G(^(16)) ,B19=$G(^( 19)),B20=$ G(^(20))
  20098   "RTN","RCT CSPD",57,0 )
  20099    ..Q:($P(B 6,U,21)\1) <ACTDT  ;c s activati on date cu toff
  20100   "RTN","RCT CSPD",58,0 )
  20101    ..I $D(^P RCA(430,"T CSP",BILL) ),$$RCLLCH K^RCTCSP2( BILL) Q  ; bill previ ously sent  to TCSP
  20102   "RTN","RCT CSPD",59,0 )
  20103    ..I $$UPD CHK(BILL)  Q
  20104   "RTN","RCT CSPD",60,0 )
  20105    ..Q:B4  ; repayment  plan
  20106   "RTN","RCT CSPD",61,0 )
  20107    ..Q:+$P(B 15,U,7)  ; quit if bi ll is stop ped
  20108   "RTN","RCT CSPD",62,0 )
  20109    ..Q:+$P(B 14,U,1)  ; bill refer red to TOP
  20110   "RTN","RCT CSPD",63,0 )
  20111    ..Q:$P(DE BTOR1,"^", 9)=1  ;qui t if debto r address  marked unk nown
  20112   "RTN","RCT CSPD",64,0 )
  20113    ..Q:$E($P (DEMCS,U,3 ),1,5)="00 000"  ;qui t if the s sn is not  valid
  20114   "RTN","RCT CSPD",65,0 )
  20115    ..I +$P(B 12,U,1) Q   ;check da te bill se nt to dmc
  20116   "RTN","RCT CSPD",66,0 )
  20117    ..Q:($P(B 121,U,1)=" N")!($P(B1 21,U,1)="P ")  ;dmc d ebt valid
  20118   "RTN","RCT CSPD",67,0 )
  20119    ..I $P(B6 ,U,4),($P( B6,U,5)="D OJ") Q
  20120   "RTN","RCT CSPD",68,0 )
  20121    ..Q:+$P(D EMCS,U,4)   ;deceased  patient
  20122   "RTN","RCT CSPD",69,0 )
  20123    ..Q:'$P(B 0,U,2)  ;n o category
  20124   "RTN","RCT CSPD",70,0 )
  20125    ..S CAT=$ P($G(^PRCA (430.2,$P( B0,U,2),0) ),U,7)
  20126   "RTN","RCT CSPD",71,0 )
  20127    ..Q:'CAT
  20128   "RTN","RCT CSPD",72,0 )
  20129    ..I ",4,5 ,6,7,8,9,1 0,11,12,13 ,14,15,16, 17,18,19,2 0,21,22,23 ,25,26,27, 28,33,34,3 5,36,37,38 ,39,48,49" [(","_CAT_ ",") Q
  20130   "RTN","RCT CSPD",73,0 )
  20131    ..;dpn ch ecks
  20132   "RTN","RCT CSPD",74,0 )
  20133    ..I $P(B2 0,U,3)=1,( 10000+$G(^ RC(342,1," CS")))>DT, '$P(B20,U, 4) D DUEPR OC^RCTCSP3  Q  ;check  to send d pn file to  aitc
  20134   "RTN","RCT CSPD",75,0 )
  20135    ..I $P(B2 0,U,3)=1,( 10000+$G(^ RC(342,1," CS")))>DT, $P(B20,U,4 ),'$P(B20, U,5) Q  ;c heck for p rint lette r date
  20136   "RTN","RCT CSPD",76,0 )
  20137    ..I $P(B2 0,U,3)=1,( 10000+$G(^ RC(342,1," CS")))>DT, $P(B20,U,4 ),$P(B20,U ,5) D  I X <60 Q  ;ch eck for 60  day wait  from print  letter da te
  20138   "RTN","RCT CSPD",77,0 )
  20139    ...N X1,X 2
  20140   "RTN","RCT CSPD",78,0 )
  20141    ...S X1=D T,X2=$P(B2 0,U,5) D ^ %DTC
  20142   "RTN","RCT CSPD",79,0 )
  20143    ...I X'<6 0 S $P(B20 ,U,6)=DT,^ PRCA(430,B ILL,20)=B2 0 ;set the  bill refe rral date  to the cur rent date
  20144   "RTN","RCT CSPD",80,0 )
  20145    ..S BILLD T=$P(B6,U, 21),PREPDT =$P(B0,U,1 0)
  20146   "RTN","RCT CSPD",81,0 )
  20147    ..I BILLD T>P150DT Q   ;150 day  old check
  20148   "RTN","RCT CSPD",82,0 )
  20149    ..I ($P(B 0,U,8)=16) ,('$P(B6,U ,3)) D  Q
  20150   "RTN","RCT CSPD",83,0 )
  20151    ...;no 3r d letter b eing sent
  20152   "RTN","RCT CSPD",84,0 )
  20153    ...N DNM
  20154   "RTN","RCT CSPD",85,0 )
  20155    ...S DNM= $$NAMEFF(+ DEBTOR0),^ XTMP("RCTC SPD",$J,"T HIRD",DNM, $P(B0,U))= ""
  20156   "RTN","RCT CSPD",86,0 )
  20157    ..I $P(B0 ,U,8)=16 I  $$ADDCHKN D(BILL) Q
  20158   "RTN","RCT CSPD",87,0 )
  20159    ..I $P(B0 ,U,8)=16 I  $$ADDCHKN B(BILL) Q
  20160   "RTN","RCT CSPD",88,0 )
  20161    ..Q
  20162   "RTN","RCT CSPD",89,0 )
  20163    .Q
  20164   "RTN","RCT CSPD",90,0 )
  20165    ;
  20166   "RTN","RCT CSPD",91,0 )
  20167    D NOW^%DT C S ^XTMP( "RCTCSPD", $J,"ZZDEND ")=%
  20168   "RTN","RCT CSPD",92,0 )
  20169    D THIRD^R CTCSP2
  20170   "RTN","RCT CSPD",93,0 )
  20171    D NOW^%DT C S ^XTMP( "RCTCSPD", $J,"ZZETRA NSMIT CS R ECS")=%
  20172   "RTN","RCT CSPD",94,0 )
  20173    D COMPILE ^RCTCSP2 ; compile cr oss-servic ed records
  20174   "RTN","RCT CSPD",95,0 )
  20175    D NOW^%DT C S ^XTMP( "RCTCSPD", $J,"ZZFTRA NSMIT DPN" )=%
  20176   "RTN","RCT CSPD",96,0 )
  20177    D COMPILE D^RCTCSP3  ;compile t he aitc du e process  notificati on records
  20178   "RTN","RCT CSPD",97,0 )
  20179    D NOW^%DT C S ^XTMP( "RCTCSPD", $J,"ZZGTRA NSMIT FINI SHED")=%
  20180   "RTN","RCT CSPD",98,0 )
  20181    D NOW^%DT C S ^XTMP( "RCTCSPD", $J,"ZZHCOM PLETE")=%
  20182   "RTN","RCT CSPD",99,0 )
  20183    D FINISH^ RCTCSPD0
  20184   "RTN","RCT CSPD",100, 0)
  20185    Q
  20186   "RTN","RCT CSPD",101, 0)
  20187    ;
  20188   "RTN","RCT CSPD",102, 0)
  20189   ADDCHKND(B ILL) ;add  a new bill  referral,  new debto r
  20190   "RTN","RCT CSPD",103, 0)
  20191    N TOTAL,A CTION,X
  20192   "RTN","RCT CSPD",104, 0)
  20193    S ACTION= "A"
  20194   "RTN","RCT CSPD",105, 0)
  20195    I $D(^RCD (340,"TCSP ",DEBTOR))  Q 0 ;chec k debtor p reviously  referred
  20196   "RTN","RCT CSPD",106, 0)
  20197    I $P(B15, U,2) Q 0 ; check tcsp  bill reca ll flag
  20198   "RTN","RCT CSPD",107, 0)
  20199    I $P(DEBT OR7,U,2) Q  0 ;check  debtor rec all
  20200   "RTN","RCT CSPD",108, 0)
  20201    I $P(B15, U,7) Q 0 ; check stop  tcsp refe rral flag
  20202   "RTN","RCT CSPD",109, 0)
  20203    I $D(^PRC A(430,"TCS P",BILL))  Q 0 ;bill  previously  sent to T CSP
  20204   "RTN","RCT CSPD",110, 0)
  20205    S TOTAL=$ P(B7,U)+$P (B7,U,2)+$ P(B7,U,3)+ $P(B7,U,4) +$P(B7,U,5 )
  20206   "RTN","RCT CSPD",111, 0)
  20207    I TOTAL<2 5 Q 1 ;no  adds for b ills less  than $25
  20208   "RTN","RCT CSPD",112, 0)
  20209    D REC1,RE C2,REC2A
  20210   "RTN","RCT CSPD",113, 0)
  20211    S $P(^PRC A(430,BILL ,16),U,13) =DOB,B16=^ (16)
  20212   "RTN","RCT CSPD",114, 0)
  20213    S $P(^PRC A(430,BILL ,15),U,14) =GNDR,B15= ^(15)
  20214   "RTN","RCT CSPD",115, 0)
  20215    D REC2C^R CTCSP7     ;PRCA*4.5* 327
  20216   "RTN","RCT CSPD",116, 0)
  20217    S ADDRCS= $$ADDR^RCT CSP1(RCDFN )
  20218   "RTN","RCT CSPD",117, 0)
  20219    S $P(^PRC A(430,BILL ,16),U,4,8 )=$P(ADDRC S,U,1,5),$ P(^(16),U, 11)=$P(ADD RCS,U,6),$ P(^(16),U, 12)=$P(ADD RCS,U,7)
  20220   "RTN","RCT CSPD",118, 0)
  20221    S B16=^PR CA(430,BIL L,16)
  20222   "RTN","RCT CSPD",119, 0)
  20223    D REC3^RC TCSP2
  20224   "RTN","RCT CSPD",120, 0)
  20225    S TAXID=$ $TAXID(DEB TOR)
  20226   "RTN","RCT CSPD",121, 0)
  20227    S NAME=$$ NAME(+DEBT OR0),NAME= $P(NAME,U)
  20228   "RTN","RCT CSPD",122, 0)
  20229    S $P(^PRC A(430,BILL ,15),U,1)= DT,$P(^(16 ),U,1)=TAX ID,$P(^(16 ),U,2)=NAM E
  20230   "RTN","RCT CSPD",123, 0)
  20231    S X1=BILL DT,X2=+30  D C^%DTC S  DELDT=X
  20232   "RTN","RCT CSPD",124, 0)
  20233    S $P(^PRC A(430,BILL ,16),U,3)= DELDT,^PRC A(430,"TCS P",BILL)=" "
  20234   "RTN","RCT CSPD",125, 0)
  20235    I $P($G(^ PRCA(430,B ILL,21)),U ,21)="" S  $P(^PRCA(4 30,BILL,21 ),U,1)=DT
  20236   "RTN","RCT CSPD",126, 0)
  20237    I '$D(^RC D(340,"TCS P",DEBTOR) ) S $P(^RC D(340,DEBT OR,7),U,5) =DT,^RCD(3 40,"TCSP", DEBTOR)=""
  20238   "RTN","RCT CSPD",127, 0)
  20239    D NEWDEBT R^RCTCSPD4  ; set CS  new debtor  new bill  non-financ ial transa ction PRCA *4.5*315
  20240   "RTN","RCT CSPD",128, 0)
  20241    Q 1
  20242   "RTN","RCT CSPD",129, 0)
  20243    ;
  20244   "RTN","RCT CSPD",130, 0)
  20245   ADDCHKNB(B ILL) ;add  a new bill  referral,  existing  debtor
  20246   "RTN","RCT CSPD",131, 0)
  20247    N TOTAL,A CTION,TAXI D,NAME,ADD RCS,X
  20248   "RTN","RCT CSPD",132, 0)
  20249    I '$D(^RC D(340,"TCS P",DEBTOR) ) Q 0 ;che ck debtor  previously  referred
  20250   "RTN","RCT CSPD",133, 0)
  20251    I $P(B15, U,2) Q 0 ; check tcsp  bill reca ll flag
  20252   "RTN","RCT CSPD",134, 0)
  20253    I $P(B15, U,7) Q 0 ; check stop  tcsp refe rral flag
  20254   "RTN","RCT CSPD",135, 0)
  20255    I $D(^PRC A(430,"TCS P",BILL))  Q 0 ;bill  previously  sent to T CSP
  20256   "RTN","RCT CSPD",136, 0)
  20257    S TOTAL=$ P(B7,U)+$P (B7,U,2)+$ P(B7,U,3)+ $P(B7,U,4) +$P(B7,U,5 )
  20258   "RTN","RCT CSPD",137, 0)
  20259    I TOTAL<2 5 Q 0 ;no  adds for b ills less  than $25
  20260   "RTN","RCT CSPD",138, 0)
  20261    S ACTION= "A" D REC1
  20262   "RTN","RCT CSPD",139, 0)
  20263    S ACTION= "B" D REC2
  20264   "RTN","RCT CSPD",140, 0)
  20265    S ACTION= "A" D REC3 ^RCTCSP2
  20266   "RTN","RCT CSPD",141, 0)
  20267    S TAXID=$ $TAXID(DEB TOR)
  20268   "RTN","RCT CSPD",142, 0)
  20269    S NAME=$$ NAME(+DEBT OR0),NAME= $P(NAME,U)
  20270   "RTN","RCT CSPD",143, 0)
  20271    S $P(^PRC A(430,BILL ,15),U,1)= DT,$P(^(16 ),U,1)=TAX ID,$P(^(16 ),U,2)=NAM E,$P(^(16) ,U,3)=BILL DT,^PRCA(4 30,"TCSP", BILL)=""
  20272   "RTN","RCT CSPD",144, 0)
  20273    I $P($G(^ PRCA(430,B ILL,21)),U ,21)="" S  $P(^PRCA(4 30,BILL,21 ),U,1)=DT
  20274   "RTN","RCT CSPD",145, 0)
  20275    S ADDRCS= $$ADDR^RCT CSP1(RCDFN )
  20276   "RTN","RCT CSPD",146, 0)
  20277    S $P(^PRC A(430,BILL ,16),U,4,8 )=$P(ADDRC S,U,1,5),$ P(^(16),U, 11)=$P(ADD RCS,U,6),$ P(^(16),U, 12)=$P(ADD RCS,U,7)
  20278   "RTN","RCT CSPD",147, 0)
  20279    S $P(^PRC A(430,BILL ,16),U,13) =DOB,B16=^ (16)
  20280   "RTN","RCT CSPD",148, 0)
  20281    S $P(^PRC A(430,BILL ,15),U,14) =GNDR,B15= ^(15)
  20282   "RTN","RCT CSPD",149, 0)
  20283    I '$D(^RC D(340,"TCS P",DEBTOR) ) S $P(^RC D(340,DEBT OR,7),U,5) =DT,^RCD(3 40,"TCSP", DEBTOR)=""
  20284   "RTN","RCT CSPD",150, 0)
  20285    D DEBTOR^ RCTCSPD4 ;  set CS de btor new b ill non-fi nancial tr ansaction  PRCA*4.5*3 15
  20286   "RTN","RCT CSPD",151, 0)
  20287    Q 1
  20288   "RTN","RCT CSPD",152, 0)
  20289    ;
  20290   "RTN","RCT CSPD",153, 0)
  20291   UPDCHK(BIL L) ;update  5b or exi sting bill
  20292   "RTN","RCT CSPD",154, 0)
  20293    I '$D(^PR CA(430,BIL L,16)) Q 0  ;quit nul l node 16  old addres s
  20294   "RTN","RCT CSPD",155, 0)
  20295    N TOTAL,T AXID,OTAXI D,NAME,ONA ME,ADDR,OA DDR,ADDRCS ,COUNTRY,O COUNTRY,OP HONE,ODOB, OGNDR,TRNI DX,TRN1,TR N8,TRNAMT, TRNNUM,TRN FLG,FIVBFL G
  20296   "RTN","RCT CSPD",156, 0)
  20297    I $P(B15, U,2) Q 0 ; check tcsp  bill reca ll flag
  20298   "RTN","RCT CSPD",157, 0)
  20299    I $P(B15, U,7) Q 0 ; check stop  tcsp refe rral flag
  20300   "RTN","RCT CSPD",158, 0)
  20301    ;5b check
  20302   "RTN","RCT CSPD",159, 0)
  20303    S FIVBFLG =0
  20304   "RTN","RCT CSPD",160, 0)
  20305    S TRNIDX= 0 F  S TRN IDX=$O(^PR CA(430,BIL L,17,TRNID X)) Q:+TRN IDX=0  D
  20306   "RTN","RCT CSPD",161, 0)
  20307    .S TRNNUM =$P($G(^PR CA(430,BIL L,17,TRNID X,0)),U,1) ,TRNFLG=$P ($G(^PRCA( 430,BILL,1 7,TRNIDX,0 )),U,2)
  20308   "RTN","RCT CSPD",162, 0)
  20309    .Q:+TRNFL G=0
  20310   "RTN","RCT CSPD",163, 0)
  20311    .S TRN1=$ G(^PRCA(43 3,TRNNUM,1 )),TRNAMT= $P(TRN1,U, 5) S:TRNAM T<0 TRNAMT =-TRNAMT
  20312   "RTN","RCT CSPD",164, 0)
  20313    .S TRN8=$ G(^PRCA(43 3,TRNNUM,8 ))
  20314   "RTN","RCT CSPD",165, 0)
  20315    .S ACTION ="U"
  20316   "RTN","RCT CSPD",166, 0)
  20317    .D REC5B^ RCTCSP1
  20318   "RTN","RCT CSPD",167, 0)
  20319    .S $P(^PR CA(430,BIL L,17,TRNID X,0),U,2)= ""
  20320   "RTN","RCT CSPD",168, 0)
  20321    .S FIVBFL G=1
  20322   "RTN","RCT CSPD",169, 0)
  20323    S TOTAL=$ P(B7,U)+$P (B7,U,2)+$ P(B7,U,3)+ $P(B7,U,4) +$P(B7,U,5 )
  20324   "RTN","RCT CSPD",170, 0)
  20325    I FIVBFLG ,(TOTAL=0)  S DR="151 ///@",DIE= "^PRCA(430 ,",DA=BILL  D ^DIE K  DR,DIE,DA
  20326   "RTN","RCT CSPD",171, 0)
  20327    I $P(B19, U,1)=1 S A CTION="U"  D REC1 S $ P(B19,U,1) ="" S $P(^ PRCA(430,B ILL,19),U, 1)=""
  20328   "RTN","RCT CSPD",172, 0)
  20329    I $P(B19, U,2)=1 S A CTION="U"  D REC2 S $ P(B19,U,2) ="" S $P(^ PRCA(430,B ILL,19),U, 2)=""
  20330   "RTN","RCT CSPD",173, 0)
  20331    I $P(B19, U,3)=1 S A CTION="U"  D REC2A S  $P(B19,U,3 )="" S $P( ^PRCA(430, BILL,19),U ,3)=""
  20332   "RTN","RCT CSPD",174, 0)
  20333    I $P(B19, U,4)=1 S A CTION="A"  D REC2C^RC TCSP7 S $P (B19,U,4)= "" S $P(^P RCA(430,BI LL,19),U,4 )="" ;PRCA *4.5*327
  20334   "RTN","RCT CSPD",175, 0)
  20335    I FIVBFLG =1 Q 1 ;if  5b sent,  then do no t continue  to referr al check
  20336   "RTN","RCT CSPD",176, 0)
  20337    I '$D(^PR CA(430,"TC SP",BILL))  Q 0 ;if n ot cross-s erviced, t hen contin ue referra l check
  20338   "RTN","RCT CSPD",177, 0)
  20339    S TAXID=$ $TAXID(DEB TOR)
  20340   "RTN","RCT CSPD",178, 0)
  20341    S OTAXID= $P(B16,U,1 )
  20342   "RTN","RCT CSPD",179, 0)
  20343    S NAME=$$ NAME(+DEBT OR0),NAME= $P(NAME,U)
  20344   "RTN","RCT CSPD",180, 0)
  20345    S ONAME=$ P(B16,U,2)
  20346   "RTN","RCT CSPD",181, 0)
  20347    I $P(B0,U ,8)=16,$D( ^PRCA(430, "TCSP",BIL L)) I (NAM E'=ONAME)! (TAXID'=OT AXID) D
  20348   "RTN","RCT CSPD",182, 0)
  20349    .S ACTION ="U"
  20350   "RTN","RCT CSPD",183, 0)
  20351    .D REC2
  20352   "RTN","RCT CSPD",184, 0)
  20353    .S $P(^PR CA(430,BIL L,16),U,1) =TAXID,$P( ^(16),U,2) =NAME,$P(^ (19),U,2)= "",$P(B19, U,2)=""
  20354   "RTN","RCT CSPD",185, 0)
  20355    S OADDR=$ P(^PRCA(43 0,BILL,16) ,U,4,8),OP HONE=$P(^( 16),U,11), OCOUNTRY=$ P(^(16),U, 12)
  20356   "RTN","RCT CSPD",186, 0)
  20357    S ADDRCS= $$ADDR^RCT CSP1(RCDFN ),PHONE=$P (ADDRCS,U, 6),COUNTRY =$P(ADDRCS ,U,7)
  20358   "RTN","RCT CSPD",187, 0)
  20359    I $P(DEBT OR1,"^",9) '=1 D  ;if  debtor ad dress is n ot marked  unknown, t hen check  address
  20360   "RTN","RCT CSPD",188, 0)
  20361    .I $P(B0, U,8)=16,$D (^PRCA(430 ,"TCSP",BI LL)) I ($P (ADDRCS,U, 1,5)'=$P(O ADDR,U,1,5 ))!(PHONE' =OPHONE)!( COUNTRY'=O COUNTRY) D
  20362   "RTN","RCT CSPD",189, 0)
  20363    ..S ACTIO N="A" ;2c  records ha ve action  code 'a'
  20364   "RTN","RCT CSPD",190, 0)
  20365    ..D REC2C ^RCTCSP7
  20366   "RTN","RCT CSPD",191, 0)
  20367    ..S $P(B1 9,U,4)=""
  20368   "RTN","RCT CSPD",192, 0)
  20369    ..S $P(^P RCA(430,BI LL,16),U,4 ,8)=$P(ADD RCS,U,1,5) ,$P(^(16), U,11)=PHON E,$P(^(16) ,U,12)=$P( ADDRCS,U,7 )
  20370   "RTN","RCT CSPD",193, 0)
  20371    S B16=^PR CA(430,BIL L,16)
  20372   "RTN","RCT CSPD",194, 0)
  20373    S ODOB=$P (^PRCA(430 ,BILL,16), U,13)
  20374   "RTN","RCT CSPD",195, 0)
  20375    S OGNDR=$ P(^PRCA(43 0,BILL,15) ,U,14)
  20376   "RTN","RCT CSPD",196, 0)
  20377    I $P(B0,U ,8)=16,$D( ^PRCA(430, "TCSP",BIL L)) I (DOB '=ODOB)!(G NDR'=OGNDR ) D
  20378   "RTN","RCT CSPD",197, 0)
  20379    .S ACTION ="U"
  20380   "RTN","RCT CSPD",198, 0)
  20381    .D REC2A
  20382   "RTN","RCT CSPD",199, 0)
  20383    .S $P(^PR CA(430,BIL L,16),U,13 )=DOB,B16= ^(16)
  20384   "RTN","RCT CSPD",200, 0)
  20385    .S $P(^PR CA(430,BIL L,15),U,14 )=GNDR,B15 =^(15)
  20386   "RTN","RCT CSPD",201, 0)
  20387    .Q
  20388   "RTN","RCT CSPD",202, 0)
  20389    Q 1 ;bill  is cross- serviced s o do not c ontinue re ferral che ck
  20390   "RTN","RCT CSPD",203, 0)
  20391    ;
  20392   "RTN","RCT CSPD",204, 0)
  20393   REC1 ;reco rd type 1
  20394   "RTN","RCT CSPD",205, 0)
  20395    N REC,KNU M,DEBTNR,A MTORIG,AMT PBAL,AMTIB AL,AMTABAL ,AMTFBAL,A MTCBAL,AMT RFRRD,AMOU NT,DELDT,X ,X1,X2,BIL LDT,PREPDT
  20396   "RTN","RCT CSPD",206, 0)
  20397    S REC="C1  "_ACTION_ "363600120 0"_"DM1D "
  20398   "RTN","RCT CSPD",207, 0)
  20399    S KNUM=$P ($P(B0,U,1 ),"-",2)
  20400   "RTN","RCT CSPD",208, 0)
  20401    S DEBTNR= $E(SITE,1, 3)_$$LJZF( KNUM,7)_$T R($J(BILL, 20)," ",0) ,REC=REC_D EBTNR_" "
  20402   "RTN","RCT CSPD",209, 0)
  20403    S REC=REC _"I   A MS CC"
  20404   "RTN","RCT CSPD",210, 0)
  20405    S BILLDT= $P(B6,U,21 ),PREPDT=$ P(B0,U,10)
  20406   "RTN","RCT CSPD",211, 0)
  20407    S REC=REC _$$DATE8(P REPDT)
  20408   "RTN","RCT CSPD",212, 0)
  20409    S X1=BILL DT,X2=+30  D C^%DTC S  DELDT=X
  20410   "RTN","RCT CSPD",213, 0)
  20411    S REC=REC _$$DATE8(D ELDT)
  20412   "RTN","RCT CSPD",214, 0)
  20413    S AMTPBAL =$P(B7,U,1 ) ;princip le balance
  20414   "RTN","RCT CSPD",215, 0)
  20415    S AMTIBAL =$P(B7,U,2 ) ;interes t balance
  20416   "RTN","RCT CSPD",216, 0)
  20417    S AMTABAL =$P(B7,U,3 ) ;adminis trative ba lance
  20418   "RTN","RCT CSPD",217, 0)
  20419    S AMTFBAL =$P(B7,U,4 ) ;marshal  fee
  20420   "RTN","RCT CSPD",218, 0)
  20421    S AMTCBAL =$P(B7,U,5 ) ;court c ost
  20422   "RTN","RCT CSPD",219, 0)
  20423    S AMTRFRR D=AMTPBAL+ AMTIBAL+AM TABAL+AMTF BAL+AMTCBA L
  20424   "RTN","RCT CSPD",220, 0)
  20425    S AMTORIG =$P(B0,U,3 )
  20426   "RTN","RCT CSPD",221, 0)
  20427    D  ;
  20428   "RTN","RCT CSPD",222, 0)
  20429    .I ACTION ="A" S REC =REC_$$AMO UNT(AMTRFR RD)_$$AMOU NT(AMTRFRR D) Q
  20430   "RTN","RCT CSPD",223, 0)
  20431    .I ACTION ="L" S AMT RFRRD=0 S  REC=REC_$$ AMOUNT(AMT RFRRD)_$$A MOUNT(AMTR FRRD) Q
  20432   "RTN","RCT CSPD",224, 0)
  20433    .S REC=RE C_$$BLANK( 28)
  20434   "RTN","RCT CSPD",225, 0)
  20435    S REC=REC _"                                                 N         "
  20436   "RTN","RCT CSPD",226, 0)
  20437    S AMOUNT= $$AMOUNT(A MTPBAL)_$$ AMOUNT(AMT IBAL)_$$AM OUNT(AMTAB AL)_$$AMOU NT(AMTFBAL +AMTCBAL)
  20438   "RTN","RCT CSPD",227, 0)
  20439    I ACTION= "L" S AMOU NT=$$AMOUN T(0)_$$AMO UNT(0)_$$A MOUNT(0)_$ $AMOUNT(0)  ;by iai s pec
  20440   "RTN","RCT CSPD",228, 0)
  20441    I ACTION= "U" S AMOU NT=$$BLANK (56) ;by i ai spec
  20442   "RTN","RCT CSPD",229, 0)
  20443    S REC=REC _AMOUNT
  20444   "RTN","RCT CSPD",230, 0)
  20445    I ACTION= "L" D
  20446   "RTN","RCT CSPD",231, 0)
  20447    .S REC=RE C_$$BLANK( 252-$L(REC ))
  20448   "RTN","RCT CSPD",232, 0)
  20449    .S RCD=$P (B15,U,4)
  20450   "RTN","RCT CSPD",233, 0)
  20451    .S REC=RE C_$S(RCD=" 01":"01",R CD="07":"0 7",RCD="08 ":"08",RCD ="15":"01" ,RCD="03": "01",RCD=" 05":"01",R CD="06":"0 1",1:"01")
  20452   "RTN","RCT CSPD",234, 0)
  20453    S REC=REC _$$BLANK(4 50-$L(REC) )
  20454   "RTN","RCT CSPD",235, 0)
  20455    I ACTION= "A" S $P(^ PRCA(430,B ILL,16),U, 9)=AMTRFRR D,$P(^(16) ,U,10)=AMT RFRRD
  20456   "RTN","RCT CSPD",236, 0)
  20457    I ACTION= "L" S $P(^ PRCA(430,B ILL,16),U, 9)="",$P(^ (16),U,10) =""
  20458   "RTN","RCT CSPD",237, 0)
  20459    S ^XTMP(" RCTCSPD",$ J,BILL,ACT ION,1)=REC
  20460   "RTN","RCT CSPD",238, 0)
  20461    S ^XTMP(" RCTCSPD",$ J,"BILL",A CTION,BILL )=$$TAXID( DEBTOR)_"^ "_+$E(REC, 91,102)_". "_$E(REC,1 03,104) ;s ends mailm an message  of docume nts sent t o user
  20462   "RTN","RCT CSPD",239, 0)
  20463    D CLR19(B ILL,1)
  20464   "RTN","RCT CSPD",240, 0)
  20465    Q
  20466   "RTN","RCT CSPD",241, 0)
  20467    ;
  20468   "RTN","RCT CSPD",242, 0)
  20469   REC2 ;
  20470   "RTN","RCT CSPD",243, 0)
  20471    N REC,KNU M,DEBTNR,D EBTORNB,TA XID,NAME,R CD
  20472   "RTN","RCT CSPD",244, 0)
  20473    S REC="C2  "_ACTION_ "363600120 0"_"DM1D "
  20474   "RTN","RCT CSPD",245, 0)
  20475    S KNUM=$P ($P(B0,U,1 ),"-",2)
  20476   "RTN","RCT CSPD",246, 0)
  20477    S DEBTNR= $E(SITE,1, 3)_$$LJZF( KNUM,7)_$T R($J(BILL, 20)," ",0) ,REC=REC_D EBTNR
  20478   "RTN","RCT CSPD",247, 0)
  20479    S DEBTORN B=$E(SITE, 1,3)_$TR($ J(DEBTOR,1 2)," ",0)
  20480   "RTN","RCT CSPD",248, 0)
  20481    S REC=REC _DEBTORNB
  20482   "RTN","RCT CSPD",249, 0)
  20483    S TAXID=$ $TAXID(DEB TOR)
  20484   "RTN","RCT CSPD",250, 0)
  20485    S REC=REC _TAXID_"SS N"
  20486   "RTN","RCT CSPD",251, 0)
  20487    S NAME=$$ NAME(+DEBT OR0),NAME= $P(NAME,U)
  20488   "RTN","RCT CSPD",252, 0)
  20489    S REC=REC _NAME_$$BL ANK(5)_"I"
  20490   "RTN","RCT CSPD",253, 0)
  20491    I ACTION= "L" D
  20492   "RTN","RCT CSPD",254, 0)
  20493    .S REC=RE C_$$BLANK( 232-$L(REC ))
  20494   "RTN","RCT CSPD",255, 0)
  20495    .S RCD=$P (B15,U,4)
  20496   "RTN","RCT CSPD",256, 0)
  20497    .S REC=RE C_$S(RCD=" 01":"12",R CD="07":"1 2",RCD="08 ":"12",RCD ="15":"12" ,RCD="03": "03",RCD=" 05":"05",R CD="06":"0 6",1:"12")
  20498   "RTN","RCT CSPD",257, 0)
  20499    S REC=REC _$$BLANK(4 50-$L(REC) )
  20500   "RTN","RCT CSPD",258, 0)
  20501    S ^XTMP(" RCTCSPD",$ J,BILL,ACT ION,2)=REC
  20502   "RTN","RCT CSPD",259, 0)
  20503    S $P(^XTM P("RCTCSPD ",$J,"BILL ",ACTION,B ILL),U,1)= $$TAXID(DE BTOR)
  20504   "RTN","RCT CSPD",260, 0)
  20505    D CLR19(B ILL,2)
  20506   "RTN","RCT CSPD",261, 0)
  20507    Q
  20508   "RTN","RCT CSPD",262, 0)
  20509    ;
  20510   "RTN","RCT CSPD",263, 0)
  20511   REC2A ;
  20512   "RTN","RCT CSPD",264, 0)
  20513    N REC,KNU M,DEBTNR,D EBTORNB
  20514   "RTN","RCT CSPD",265, 0)
  20515    S REC="C2 A"_ACTION_ "363600120 0"_"DM1D "
  20516   "RTN","RCT CSPD",266, 0)
  20517    S KNUM=$P ($P(B0,U,1 ),"-",2)
  20518   "RTN","RCT CSPD",267, 0)
  20519    S DEBTNR= $E(SITE,1, 3)_$$LJZF( KNUM,7)_$T R($J(BILL, 20)," ",0) ,REC=REC_D EBTNR
  20520   "RTN","RCT CSPD",268, 0)
  20521    S DEBTORN B=$E(SITE, 1,3)_$TR($ J(DEBTOR,1 2)," ",0)
  20522   "RTN","RCT CSPD",269, 0)
  20523    S REC=REC _DEBTORNB
  20524   "RTN","RCT CSPD",270, 0)
  20525    S REC=REC _$$BLANK(3 )
  20526   "RTN","RCT CSPD",271, 0)
  20527    S REC=REC _GNDR
  20528   "RTN","RCT CSPD",272, 0)
  20529    S REC=REC _$$DATE8($ P(DEMCS,U, 2))
  20530   "RTN","RCT CSPD",273, 0)
  20531    S REC=REC _$$BLANK(4 50-$L(REC) )
  20532   "RTN","RCT CSPD",274, 0)
  20533    S ^XTMP(" RCTCSPD",$ J,BILL,ACT ION,"2A")= REC
  20534   "RTN","RCT CSPD",275, 0)
  20535    S $P(^XTM P("RCTCSPD ",$J,"BILL ",ACTION,B ILL),U,1)= $$TAXID(DE BTOR)
  20536   "RTN","RCT CSPD",276, 0)
  20537    D CLR19(B ILL,3)
  20538   "RTN","RCT CSPD",277, 0)
  20539    Q
  20540   "RTN","RCT CSPD",278, 0)
  20541    ;
  20542   "RTN","RCT CSPD",279, 0)
  20543   DATE8(X) ; changes fi leman date  into 8 di git date y yyymmdd
  20544   "RTN","RCT CSPD",280, 0)
  20545    I +X S X= X+17000000
  20546   "RTN","RCT CSPD",281, 0)
  20547    S X=$E(X, 1,8)
  20548   "RTN","RCT CSPD",282, 0)
  20549    Q X
  20550   "RTN","RCT CSPD",283, 0)
  20551    ;
  20552   "RTN","RCT CSPD",284, 0)
  20553   AMOUNT(X)  ;changes a mount to z ero filled , right ju stified
  20554   "RTN","RCT CSPD",285, 0)
  20555    S:X<0 X=- X
  20556   "RTN","RCT CSPD",286, 0)
  20557    S X=$TR($ J(X,0,2)," .")
  20558   "RTN","RCT CSPD",287, 0)
  20559    S X=$E("0 0000000000 0",1,14-$L (X))_X
  20560   "RTN","RCT CSPD",288, 0)
  20561    Q X
  20562   "RTN","RCT CSPD",289, 0)
  20563    ;
  20564   "RTN","RCT CSPD",290, 0)
  20565   NAME(DFN)  ;returns n ame for do cument and  name in f ile
  20566   "RTN","RCT CSPD",291, 0)
  20567    N FN,LN,M N,NM,DOCNM ,VA,VADM
  20568   "RTN","RCT CSPD",292, 0)
  20569    S NM=""
  20570   "RTN","RCT CSPD",293, 0)
  20571    D DEM^VAD PT
  20572   "RTN","RCT CSPD",294, 0)
  20573    I $D(VADM ) S NM=VAD M(1)
  20574   "RTN","RCT CSPD",295, 0)
  20575    S LN=$TR( $P(NM,",") ," .'-"),M N=$P($P(NM ,",",2),"  ",2)
  20576   "RTN","RCT CSPD",296, 0)
  20577    I ($E(MN, 1,2)="SR") !($E(MN,1, 2)="JR")!( MN?2.3"I") !(MN?0.1"I "1"V"1.3"I ") S MN=""
  20578   "RTN","RCT CSPD",297, 0)
  20579    S FN=$P($ P(NM,",",2 )," ")
  20580   "RTN","RCT CSPD",298, 0)
  20581    S DOCNM=$ $LJ^XLFSTR ($E(LN,1,3 5),35)_$$L J^XLFSTR($ E(FN,1,35) ,35)_$$LJ^ XLFSTR($E( MN,1,35),3 5)
  20582   "RTN","RCT CSPD",299, 0)
  20583    Q DOCNM
  20584   "RTN","RCT CSPD",300, 0)
  20585    ;
  20586   "RTN","RCT CSPD",301, 0)
  20587   NAMEFF(DFN ) ;returns  name for  document a nd name in  file
  20588   "RTN","RCT CSPD",302, 0)
  20589    N FN,LN,M N,NM,DOCNM ,VA,VADM
  20590   "RTN","RCT CSPD",303, 0)
  20591    S NM=""
  20592   "RTN","RCT CSPD",304, 0)
  20593    D DEM^VAD PT
  20594   "RTN","RCT CSPD",305, 0)
  20595    I $D(VADM ) S NM=VAD M(1)
  20596   "RTN","RCT CSPD",306, 0)
  20597    S LN=$TR( $P(NM,",") ," .'-"),M N=$P($P(NM ,",",2),"  ",2)
  20598   "RTN","RCT CSPD",307, 0)
  20599    I ($E(MN, 1,2)="SR") !($E(MN,1, 2)="JR")!( MN?2.3"I") !(MN?0.1"I "1"V"1.3"I ") S MN=""
  20600   "RTN","RCT CSPD",308, 0)
  20601    S FN=$P($ P(NM,",",2 )," ")
  20602   "RTN","RCT CSPD",309, 0)
  20603    S DOCNM=L N_" "_FN_"  "_MN
  20604   "RTN","RCT CSPD",310, 0)
  20605    Q DOCNM
  20606   "RTN","RCT CSPD",311, 0)
  20607    ;
  20608   "RTN","RCT CSPD",312, 0)
  20609   BLANK(X) ; returns 'x ' blank sp aces
  20610   "RTN","RCT CSPD",313, 0)
  20611    N BLANK
  20612   "RTN","RCT CSPD",314, 0)
  20613    S BLANK=" ",$P(BLANK ," ",X+1)= ""
  20614   "RTN","RCT CSPD",315, 0)
  20615    Q BLANK
  20616   "RTN","RCT CSPD",316, 0)
  20617    ;
  20618   "RTN","RCT CSPD",317, 0)
  20619   NOW() ;com piles curr ent date,t ime
  20620   "RTN","RCT CSPD",318, 0)
  20621    N X,Y,%,% H
  20622   "RTN","RCT CSPD",319, 0)
  20623    S %H=$H D  YX^%DTC
  20624   "RTN","RCT CSPD",320, 0)
  20625    Q Y
  20626   "RTN","RCT CSPD",321, 0)
  20627    ;
  20628   "RTN","RCT CSPD",322, 0)
  20629   RJZF(X,Y)  ;right jus tify zero  fill width  Y
  20630   "RTN","RCT CSPD",323, 0)
  20631    S X=$E("0 0000000000 0",1,Y-$L( X))_X
  20632   "RTN","RCT CSPD",324, 0)
  20633    Q X
  20634   "RTN","RCT CSPD",325, 0)
  20635    ;
  20636   "RTN","RCT CSPD",326, 0)
  20637   TAXID(DEBT OR) ;compu tes TAXID  to place o n document s
  20638   "RTN","RCT CSPD",327, 0)
  20639    N TAXID,D IC,DA,DR,D IQ
  20640   "RTN","RCT CSPD",328, 0)
  20641    S TAXID=$ $SSN^RCFN0 1(DEBTOR)
  20642   "RTN","RCT CSPD",329, 0)
  20643    S TAXID=$ $LJSF(TAXI D,9)
  20644   "RTN","RCT CSPD",330, 0)
  20645    Q TAXID
  20646   "RTN","RCT CSPD",331, 0)
  20647    ;
  20648   "RTN","RCT CSPD",332, 0)
  20649   LJSF(X,Y)  ;x left ju stified, y  space fil led
  20650   "RTN","RCT CSPD",333, 0)
  20651    S X=$E(X, 1,Y)
  20652   "RTN","RCT CSPD",334, 0)
  20653    S X=X_$$B LANK(Y-$L( X))
  20654   "RTN","RCT CSPD",335, 0)
  20655    Q X
  20656   "RTN","RCT CSPD",336, 0)
  20657    ;
  20658   "RTN","RCT CSPD",337, 0)
  20659   LJZF(X,Y)  ;x left ju stified, y  zero fill ed
  20660   "RTN","RCT CSPD",338, 0)
  20661    S X=X_"00 00000000"
  20662   "RTN","RCT CSPD",339, 0)
  20663    S X=$E(X, X,Y)
  20664   "RTN","RCT CSPD",340, 0)
  20665    Q X
  20666   "RTN","RCT CSPD",341, 0)
  20667    ;
  20668   "RTN","RCT CSPD",342, 0)
  20669   RECALL(BIL L) ; set t he recall  flag
  20670   "RTN","RCT CSPD",343, 0)
  20671    S $P(^PRC A(430,BILL ,15),U,2)= 1
  20672   "RTN","RCT CSPD",344, 0)
  20673    Q
  20674   "RTN","RCT CSPD",345, 0)
  20675    ;
  20676   "RTN","RCT CSPD",346, 0)
  20677   CLR19(BILL ,X) ; clea r the send  flag
  20678   "RTN","RCT CSPD",347, 0)
  20679    S $P(^PRC A(430,BILL ,19),U,X)= ""
  20680   "RTN","RCT CSPD",348, 0)
  20681    ;
  20682   "RTN","RCT CSPD4")
  20683   0^18^B8894 2969^n/a
  20684   "RTN","RCT CSPD4",1,0 )
  20685   RCTCSPD4 ; ALB/LMH-CR OSS-SERVIC ING NON-FI NANCIAL TR ANSACTIONS  ;03/15/14  3:34 PM
  20686   "RTN","RCT CSPD4",2,0 )
  20687    ;;4.5;Acc ounts Rece ivable;**3 15**;Mar 2 0, 1995;Bu ild 55
  20688   "RTN","RCT CSPD4",3,0 )
  20689    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  20690   "RTN","RCT CSPD4",4,0 )
  20691    ;
  20692   "RTN","RCT CSPD4",5,0 )
  20693    Q 
  20694   "RTN","RCT CSPD4",6,0 )
  20695    ;
  20696   "RTN","RCT CSPD4",7,0 )
  20697   STOP ; CS  stop place d non-fina ncial tx
  20698   "RTN","RCT CSPD4",8,0 )
  20699    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER
  20700   "RTN","RCT CSPD4",9,0 )
  20701    S PRCABN= BILL
  20702   "RTN","RCT CSPD4",10, 0)
  20703    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  20704   "RTN","RCT CSPD4",11, 0)
  20705    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  20706   "RTN","RCT CSPD4",12, 0)
  20707    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  20708   "RTN","RCT CSPD4",13, 0)
  20709    S DIE="^P RCA(433,", DA=PRCAEN
  20710   "RTN","RCT CSPD4",14, 0)
  20711    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  20712   "RTN","RCT CSPD4",15, 0)
  20713    S DR=DR_" ;3///0" ;C alm Code D one
  20714   "RTN","RCT CSPD4",16, 0)
  20715    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",33 ,0)) ;Tran saction Ty pe
  20716   "RTN","RCT CSPD4",17, 0)
  20717    S DR=DR_" ;15///0" ; Transactio n Amount
  20718   "RTN","RCT CSPD4",18, 0)
  20719    S DR=DR_" ;42///"_DU Z ;Process ed by user
  20720   "RTN","RCT CSPD4",19, 0)
  20721    S DR=DR_" ;11///"_DT  ;Transact ion date
  20722   "RTN","RCT CSPD4",20, 0)
  20723    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  20724   "RTN","RCT CSPD4",21, 0)
  20725    S DR=DR_" ;5.02///CS  STOP PLAC ED" D ^DIE
  20726   "RTN","RCT CSPD4",22, 0)
  20727    Q
  20728   "RTN","RCT CSPD4",23, 0)
  20729    ;
  20730   "RTN","RCT CSPD4",24, 0)
  20731   DELSTOP ;  CS delete  stop non-f inancial t x
  20732   "RTN","RCT CSPD4",25, 0)
  20733    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER
  20734   "RTN","RCT CSPD4",26, 0)
  20735    S PRCABN= BILL
  20736   "RTN","RCT CSPD4",27, 0)
  20737    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  20738   "RTN","RCT CSPD4",28, 0)
  20739    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  20740   "RTN","RCT CSPD4",29, 0)
  20741    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  20742   "RTN","RCT CSPD4",30, 0)
  20743    S DIE="^P RCA(433,", DA=PRCAEN
  20744   "RTN","RCT CSPD4",31, 0)
  20745    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  20746   "RTN","RCT CSPD4",32, 0)
  20747    S DR=DR_" ;3///0" ;C alm Code D one
  20748   "RTN","RCT CSPD4",33, 0)
  20749    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",36 ,0)) ;Tran saction Ty pe
  20750   "RTN","RCT CSPD4",34, 0)
  20751    S DR=DR_" ;15///0" ; Transactio n Amount
  20752   "RTN","RCT CSPD4",35, 0)
  20753    S DR=DR_" ;42///"_DU Z ;Process ed by user
  20754   "RTN","RCT CSPD4",36, 0)
  20755    S DR=DR_" ;11///"_DT  ;Transact ion date
  20756   "RTN","RCT CSPD4",37, 0)
  20757    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  20758   "RTN","RCT CSPD4",38, 0)
  20759    S DR=DR_" ;5.02///CS  STOP DELE TED" D ^DI E
  20760   "RTN","RCT CSPD4",39, 0)
  20761    Q
  20762   "RTN","RCT CSPD4",40, 0)
  20763    ;
  20764   "RTN","RCT CSPD4",41, 0)
  20765   RCLL ; Rec all from C ross-Servi cing non-f inancial t x
  20766   "RTN","RCT CSPD4",42, 0)
  20767    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER,DU Z
  20768   "RTN","RCT CSPD4",43, 0)
  20769    ;DUZ is r eserved, b ut in this  case DUZ  may be und efined due  to batch  background  job
  20770   "RTN","RCT CSPD4",44, 0)
  20771    S PRCABN= BILL,DUZ=. 5,DUZ(0)=" @",DUZ(2)= 1 ; Server  has no DU Z, use Pos tmaster
  20772   "RTN","RCT CSPD4",45, 0)
  20773    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  20774   "RTN","RCT CSPD4",46, 0)
  20775    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  20776   "RTN","RCT CSPD4",47, 0)
  20777    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  20778   "RTN","RCT CSPD4",48, 0)
  20779    S DIE="^P RCA(433,", DA=PRCAEN
  20780   "RTN","RCT CSPD4",49, 0)
  20781    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  20782   "RTN","RCT CSPD4",50, 0)
  20783    S DR=DR_" ;3///0" ;C alm Code D one
  20784   "RTN","RCT CSPD4",51, 0)
  20785    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",34 ,0)) ;Tran saction Ty pe
  20786   "RTN","RCT CSPD4",52, 0)
  20787    S DR=DR_" ;15///0" ; Transactio n Amount
  20788   "RTN","RCT CSPD4",53, 0)
  20789    S DR=DR_" ;42///"_DU Z ;Process ed by user
  20790   "RTN","RCT CSPD4",54, 0)
  20791    S DR=DR_" ;11///"_DT  ;Transact ion date
  20792   "RTN","RCT CSPD4",55, 0)
  20793    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  20794   "RTN","RCT CSPD4",56, 0)
  20795    S DR=DR_" ;5.02///CS  BILL RECA LL" D ^DIE
  20796   "RTN","RCT CSPD4",57, 0)
  20797    Q
  20798   "RTN","RCT CSPD4",58, 0)
  20799    ;
  20800   "RTN","RCT CSPD4",59, 0)
  20801   DELRCLL ;  Cross-Serv icing Dele te Bill Re call non-f inancial t x
  20802   "RTN","RCT CSPD4",60, 0)
  20803    ;
  20804   "RTN","RCT CSPD4",61, 0)
  20805    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER
  20806   "RTN","RCT CSPD4",62, 0)
  20807    S PRCABN= BILL
  20808   "RTN","RCT CSPD4",63, 0)
  20809    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  20810   "RTN","RCT CSPD4",64, 0)
  20811    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  20812   "RTN","RCT CSPD4",65, 0)
  20813    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  20814   "RTN","RCT CSPD4",66, 0)
  20815    S DIE="^P RCA(433,", DA=PRCAEN
  20816   "RTN","RCT CSPD4",67, 0)
  20817    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  20818   "RTN","RCT CSPD4",68, 0)
  20819    S DR=DR_" ;3///0" ;C alm Code D one
  20820   "RTN","RCT CSPD4",69, 0)
  20821    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",37 ,0)) ;Tran saction Ty pe
  20822   "RTN","RCT CSPD4",70, 0)
  20823    S DR=DR_" ;15///0" ; Transactio n Amount
  20824   "RTN","RCT CSPD4",71, 0)
  20825    S DR=DR_" ;42///"_DU Z ;Process ed by user
  20826   "RTN","RCT CSPD4",72, 0)
  20827    S DR=DR_" ;11///"_DT  ;Transact ion date
  20828   "RTN","RCT CSPD4",73, 0)
  20829    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  20830   "RTN","RCT CSPD4",74, 0)
  20831    S DR=DR_" ;5.02///CS  DEL BILL  RECALL" D  ^DIE
  20832   "RTN","RCT CSPD4",75, 0)
  20833    Q
  20834   "RTN","RCT CSPD4",76, 0)
  20835    ;
  20836   "RTN","RCT CSPD4",77, 0)
  20837   NEWDEBTR ;  CS add ne w debtor n on-financi al tx
  20838   "RTN","RCT CSPD4",78, 0)
  20839    ;          Called by  RCTCSPD
  20840   "RTN","RCT CSPD4",79, 0)
  20841    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER,X, PRCABN
  20842   "RTN","RCT CSPD4",80, 0)
  20843    S PRCABN= BILL,DUZ=. 5,DUZ(0)=" @",DUZ(2)= 1 ; Server  has no DU Z, use Pos tmaster
  20844   "RTN","RCT CSPD4",81, 0)
  20845    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  20846   "RTN","RCT CSPD4",82, 0)
  20847    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  20848   "RTN","RCT CSPD4",83, 0)
  20849    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  20850   "RTN","RCT CSPD4",84, 0)
  20851    S DIE="^P RCA(433,", DA=PRCAEN
  20852   "RTN","RCT CSPD4",85, 0)
  20853    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  20854   "RTN","RCT CSPD4",86, 0)
  20855    S DR=DR_" ;3///0" ;C alm Code D one
  20856   "RTN","RCT CSPD4",87, 0)
  20857    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",48 ,0)) ;Tran saction Ty pe
  20858   "RTN","RCT CSPD4",88, 0)
  20859    S DR=DR_" ;15///0" ; Transactio n Amount
  20860   "RTN","RCT CSPD4",89, 0)
  20861    S DR=DR_" ;42///"_DU Z ;Process ed by user
  20862   "RTN","RCT CSPD4",90, 0)
  20863    S DR=DR_" ;11///"_DT  ;Transact ion date
  20864   "RTN","RCT CSPD4",91, 0)
  20865    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  20866   "RTN","RCT CSPD4",92, 0)
  20867    S DR=DR_" ;5.02///CS  NEW DBTR  NEW BILL"  D ^DIE
  20868   "RTN","RCT CSPD4",93, 0)
  20869    Q
  20870   "RTN","RCT CSPD4",94, 0)
  20871    ;
  20872   "RTN","RCT CSPD4",95, 0)
  20873   RCRSD ; CS  Debtor Re call non-f inancial t x
  20874   "RTN","RCT CSPD4",96, 0)
  20875    ; Set thi s debtor f or Recall  from Cross -Servicing
  20876   "RTN","RCT CSPD4",97, 0)
  20877    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER,X
  20878   "RTN","RCT CSPD4",98, 0)
  20879    ;DUZ is r eserved, b ut in this  case DUZ  may be und efined due  to batch  background  job
  20880   "RTN","RCT CSPD4",99, 0)
  20881    S PRCABN= BILL,DUZ=. 5,DUZ(0)=" @",DUZ(2)= 1 ; Server  has no DU Z, use Pos tmaster
  20882   "RTN","RCT CSPD4",100 ,0)
  20883    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  20884   "RTN","RCT CSPD4",101 ,0)
  20885    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  20886   "RTN","RCT CSPD4",102 ,0)
  20887    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  20888   "RTN","RCT CSPD4",103 ,0)
  20889    S DIE="^P RCA(433,", DA=PRCAEN
  20890   "RTN","RCT CSPD4",104 ,0)
  20891    S DR=".03 ///"_PRCAB N ; BILL N UMBER
  20892   "RTN","RCT CSPD4",105 ,0)
  20893    S DR=DR_" ;3///0" ;C alm Code D one
  20894   "RTN","RCT CSPD4",106 ,0)
  20895    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",35 ,0)) ;Tran saction Ty pe
  20896   "RTN","RCT CSPD4",107 ,0)
  20897    S DR=DR_" ;15///0" ; Transactio n Amount
  20898   "RTN","RCT CSPD4",108 ,0)
  20899    S DR=DR_" ;42///"_DU Z ;Process ed by user
  20900   "RTN","RCT CSPD4",109 ,0)
  20901    S DR=DR_" ;11///"_DT  ;Transact ion date
  20902   "RTN","RCT CSPD4",110 ,0)
  20903    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  20904   "RTN","RCT CSPD4",111 ,0)
  20905    S DR=DR_" ;5.02///CS  Debtor Re call" D ^D IE
  20906   "RTN","RCT CSPD4",112 ,0)
  20907    Q
  20908   "RTN","RCT CSPD4",113 ,0)
  20909    ;
  20910   "RTN","RCT CSPD4",114 ,0)
  20911   DELSETD(BI LL) ; CS D elete Debt or Recall  non-financ ial tx
  20912   "RTN","RCT CSPD4",115 ,0)
  20913    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSERX
  20914   "RTN","RCT CSPD4",116 ,0)
  20915    S PRCABN= BILL
  20916   "RTN","RCT CSPD4",117 ,0)
  20917    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  20918   "RTN","RCT CSPD4",118 ,0)
  20919    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  20920   "RTN","RCT CSPD4",119 ,0)
  20921    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  20922   "RTN","RCT CSPD4",120 ,0)
  20923    S DIE="^P RCA(433,", DA=PRCAEN
  20924   "RTN","RCT CSPD4",121 ,0)
  20925    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  20926   "RTN","RCT CSPD4",122 ,0)
  20927    S DR=DR_" ;3///0" ;C alm Code D one
  20928   "RTN","RCT CSPD4",123 ,0)
  20929    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",38 ,0)) ;Tran saction Ty pe
  20930   "RTN","RCT CSPD4",124 ,0)
  20931    S DR=DR_" ;15///0" ; Transactio n Amount
  20932   "RTN","RCT CSPD4",125 ,0)
  20933    S DR=DR_" ;42///"_DU Z ;Process ed by user
  20934   "RTN","RCT CSPD4",126 ,0)
  20935    S DR=DR_" ;11///"_DT  ;Transact ion date
  20936   "RTN","RCT CSPD4",127 ,0)
  20937    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  20938   "RTN","RCT CSPD4",128 ,0)
  20939    S DR=DR_" ;5.02///CS  DEL DEBTO R RECALL"  D ^DIE
  20940   "RTN","RCT CSPD4",129 ,0)
  20941    Q
  20942   "RTN","RCT CSPD4",130 ,0)
  20943    ;
  20944   "RTN","RCT CSPD4",131 ,0)
  20945   DEBTOR ; C S New Bill  Existing  Debtor non -financial  tx
  20946   "RTN","RCT CSPD4",132 ,0)
  20947    ;
  20948   "RTN","RCT CSPD4",133 ,0)
  20949    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER,PR CABN
  20950   "RTN","RCT CSPD4",134 ,0)
  20951    S PRCABN= BILL,DUZ=. 5,DUZ(0)=" @",DUZ(2)= 1 ; Server  has no DU Z, use Pos tmaster
  20952   "RTN","RCT CSPD4",135 ,0)
  20953    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  20954   "RTN","RCT CSPD4",136 ,0)
  20955    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  20956   "RTN","RCT CSPD4",137 ,0)
  20957    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  20958   "RTN","RCT CSPD4",138 ,0)
  20959    S DIE="^P RCA(433,", DA=PRCAEN
  20960   "RTN","RCT CSPD4",139 ,0)
  20961    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  20962   "RTN","RCT CSPD4",140 ,0)
  20963    S DR=DR_" ;3///0" ;C alm Code D one
  20964   "RTN","RCT CSPD4",141 ,0)
  20965    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",39 ,0)) ;Tran saction Ty pe
  20966   "RTN","RCT CSPD4",142 ,0)
  20967    S DR=DR_" ;15///0" ; Transactio n Amount
  20968   "RTN","RCT CSPD4",143 ,0)
  20969    S DR=DR_" ;42///"_DU Z ;Process ed by user
  20970   "RTN","RCT CSPD4",144 ,0)
  20971    S DR=DR_" ;11///"_DT  ;Transact ion date
  20972   "RTN","RCT CSPD4",145 ,0)
  20973    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  20974   "RTN","RCT CSPD4",146 ,0)
  20975    S DR=DR_" ;5.02///CS  DEBTOR NE W BILL" D  ^DIE ; Rev ised as re quested
  20976   "RTN","RCT CSPD4",147 ,0)
  20977    Q
  20978   "RTN","RCT CSPD4",148 ,0)
  20979    ;
  20980   "RTN","RCT CSPD4",149 ,0)
  20981   CSCASE ;   Add Case I nfo non-fi nancial tx  
  20982   "RTN","RCT CSPD4",150 ,0)
  20983    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER
  20984   "RTN","RCT CSPD4",151 ,0)
  20985    S PRCABN= BILL,DUZ=. 5,DUZ(0)=" @",DUZ(2)= 1 ; Server  has no DU Z, use Pos tmaster
  20986   "RTN","RCT CSPD4",152 ,0)
  20987    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  20988   "RTN","RCT CSPD4",153 ,0)
  20989    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  20990   "RTN","RCT CSPD4",154 ,0)
  20991    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  20992   "RTN","RCT CSPD4",155 ,0)
  20993    S DIE="^P RCA(433,", DA=PRCAEN
  20994   "RTN","RCT CSPD4",156 ,0)
  20995    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  20996   "RTN","RCT CSPD4",157 ,0)
  20997    S DR=DR_" ;3///0" ;C alm Code D one
  20998   "RTN","RCT CSPD4",158 ,0)
  20999    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",47 ,0)) ;Tran saction Ty pe
  21000   "RTN","RCT CSPD4",159 ,0)
  21001    S DR=DR_" ;15///0" ; Transactio n Amount
  21002   "RTN","RCT CSPD4",160 ,0)
  21003    S DR=DR_" ;42///"_DU Z ;Process ed by user
  21004   "RTN","RCT CSPD4",161 ,0)
  21005    S DR=DR_" ;11///"_DT  ;Transact ion date
  21006   "RTN","RCT CSPD4",162 ,0)
  21007    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  21008   "RTN","RCT CSPD4",163 ,0)
  21009    S DR=DR_" ;5.02///CS  ADD CASE  INFO" D ^D IE
  21010   "RTN","RCT CSPD4",164 ,0)
  21011    Q
  21012   "RTN","RCT CSPD4",165 ,0)
  21013    ;
  21014   "RTN","RCT CSPD4",166 ,0)
  21015   DELSETC ;  Cross-Serv icing dele te case re call non-f inancial t x
  21016   "RTN","RCT CSPD4",167 ,0)
  21017    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER
  21018   "RTN","RCT CSPD4",168 ,0)
  21019    S PRCABN= BILL
  21020   "RTN","RCT CSPD4",169 ,0)
  21021    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  21022   "RTN","RCT CSPD4",170 ,0)
  21023    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  21024   "RTN","RCT CSPD4",171 ,0)
  21025    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  21026   "RTN","RCT CSPD4",172 ,0)
  21027    S DIE="^P RCA(433,", DA=PRCAEN
  21028   "RTN","RCT CSPD4",173 ,0)
  21029    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  21030   "RTN","RCT CSPD4",174 ,0)
  21031    S DR=DR_" ;3///0" ;C alm Code D one
  21032   "RTN","RCT CSPD4",175 ,0)
  21033    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",46 ,0)) ;Tran saction Ty pe
  21034   "RTN","RCT CSPD4",176 ,0)
  21035    S DR=DR_" ;15///0" ; Transactio n Amount
  21036   "RTN","RCT CSPD4",177 ,0)
  21037    S DR=DR_" ;42///"_DU Z ;Process ed by user
  21038   "RTN","RCT CSPD4",178 ,0)
  21039    S DR=DR_" ;11///"_DT  ;Transact ion date
  21040   "RTN","RCT CSPD4",179 ,0)
  21041    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  21042   "RTN","RCT CSPD4",180 ,0)
  21043    S DR=DR_" ;5.02///CS  DEL CASE  RECALL" D  ^DIE
  21044   "RTN","RCT CSPD4",181 ,0)
  21045    Q
  21046   "RTN","RCT CSPD4",182 ,0)
  21047    ;
  21048   "RTN","RCT CSPD4",183 ,0)
  21049   DECADJ ; n on-financi al decreas e adjustme nt transac tion for 5 b cross-se rvicing re cord
  21050   "RTN","RCT CSPD4",184 ,0)
  21051    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER
  21052   "RTN","RCT CSPD4",185 ,0)
  21053    S PRCABN= BILL
  21054   "RTN","RCT CSPD4",186 ,0)
  21055    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  21056   "RTN","RCT CSPD4",187 ,0)
  21057    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  21058   "RTN","RCT CSPD4",188 ,0)
  21059    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  21060   "RTN","RCT CSPD4",189 ,0)
  21061    S DIE="^P RCA(433,", DA=PRCAEN
  21062   "RTN","RCT CSPD4",190 ,0)
  21063    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  21064   "RTN","RCT CSPD4",191 ,0)
  21065    S DR=DR_" ;3///0" ;C alm Code D one
  21066   "RTN","RCT CSPD4",192 ,0)
  21067    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",49 ,0)) ;Tran saction Ty pe
  21068   "RTN","RCT CSPD4",193 ,0)
  21069    S DR=DR_" ;15///0" ; Transactio n Amount
  21070   "RTN","RCT CSPD4",194 ,0)
  21071    S DR=DR_" ;42///"_DU Z ;Process ed by user
  21072   "RTN","RCT CSPD4",195 ,0)
  21073    S DR=DR_" ;11///"_DT  ;Transact ion date
  21074   "RTN","RCT CSPD4",196 ,0)
  21075    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  21076   "RTN","RCT CSPD4",197 ,0)
  21077    S DR=DR_" ;5.02///CS  DECREASE  ADJ" D ^DI E
  21078   "RTN","RCT CSPD4",198 ,0)
  21079    Q 
  21080   "RTN","RCT CSPD4",199 ,0)
  21081    ;
  21082   "RTN","RCT CSPD4",200 ,0)
  21083   DECADJ0 ;  decrease a djustment  transactio n deletes  cs date
  21084   "RTN","RCT CSPD4",201 ,0)
  21085    ; 5B tx t akes bal.  of bill to  0 
  21086   "RTN","RCT CSPD4",202 ,0)
  21087    ; if node  7 balance s = 0.  Ca lled by RC TCSPD
  21088   "RTN","RCT CSPD4",203 ,0)
  21089    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER
  21090   "RTN","RCT CSPD4",204 ,0)
  21091    S PRCABN= BILL
  21092   "RTN","RCT CSPD4",205 ,0)
  21093    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  21094   "RTN","RCT CSPD4",206 ,0)
  21095    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  21096   "RTN","RCT CSPD4",207 ,0)
  21097    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  21098   "RTN","RCT CSPD4",208 ,0)
  21099    S DIE="^P RCA(433,", DA=PRCAEN
  21100   "RTN","RCT CSPD4",209 ,0)
  21101    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  21102   "RTN","RCT CSPD4",210 ,0)
  21103    S DR=DR_" ;3///0" ;C alm Code D one
  21104   "RTN","RCT CSPD4",211 ,0)
  21105    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",40 ,0)) ;Tran saction Ty pe
  21106   "RTN","RCT CSPD4",212 ,0)
  21107    S DR=DR_" ;15///0" ; Transactio n Amount
  21108   "RTN","RCT CSPD4",213 ,0)
  21109    S DR=DR_" ;42///"_DU Z ;Process ed by user
  21110   "RTN","RCT CSPD4",214 ,0)
  21111    S DR=DR_" ;11///"_DT  ;Transact ion date
  21112   "RTN","RCT CSPD4",215 ,0)
  21113    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  21114   "RTN","RCT CSPD4",216 ,0)
  21115    S DR=DR_" ;5.02///CS  DECR ADJ  NOT APP" D  ^DIE
  21116   "RTN","RCT CSPD4",217 ,0)
  21117    D CHKS
  21118   "RTN","RCT CSPD4",218 ,0)
  21119    Q 
  21120   "RTN","RCT CSPD4",219 ,0)
  21121    ;
  21122   "RTN","RCT CSPD4",220 ,0)
  21123   RCRSC ; Cr oss-Servic ing case r ecall non- financial  tx
  21124   "RTN","RCT CSPD4",221 ,0)
  21125    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER
  21126   "RTN","RCT CSPD4",222 ,0)
  21127    ;DUZ is r eserved, b ut in this  case DUZ  may be und efined due  to batch  background  job
  21128   "RTN","RCT CSPD4",223 ,0)
  21129    S PRCABN= BILL,DUZ=. 5,DUZ(0)=" @",DUZ(2)= 1 ; Server  has no DU Z, use Pos tmaster
  21130   "RTN","RCT CSPD4",224 ,0)
  21131    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  21132   "RTN","RCT CSPD4",225 ,0)
  21133    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  21134   "RTN","RCT CSPD4",226 ,0)
  21135    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  21136   "RTN","RCT CSPD4",227 ,0)
  21137    S DIE="^P RCA(433,", DA=PRCAEN
  21138   "RTN","RCT CSPD4",228 ,0)
  21139    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  21140   "RTN","RCT CSPD4",229 ,0)
  21141    S DR=DR_" ;3///0" ;C alm Code D one
  21142   "RTN","RCT CSPD4",230 ,0)
  21143    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",45 ,0)) ;Tran saction Ty pe
  21144   "RTN","RCT CSPD4",231 ,0)
  21145    S DR=DR_" ;15///0" ; Transactio n Amount
  21146   "RTN","RCT CSPD4",232 ,0)
  21147    S DR=DR_" ;42///"_DU Z ;Process ed by user
  21148   "RTN","RCT CSPD4",233 ,0)
  21149    S DR=DR_" ;11///"_DT  ;Transact ion date
  21150   "RTN","RCT CSPD4",234 ,0)
  21151    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  21152   "RTN","RCT CSPD4",235 ,0)
  21153    S DR=DR_" ;5.02///CS  CASE RECA LL" D ^DIE
  21154   "RTN","RCT CSPD4",236 ,0)
  21155    Q
  21156   "RTN","RCT CSPD4",237 ,0)
  21157    ;
  21158   "RTN","RCT CSPD4",238 ,0)
  21159   CHKS ;Leav e validati on checks  in place
  21160   "RTN","RCT CSPD4",239 ,0)
  21161    I $P($G(^ PRCA(433,P RCAEN,5)), "^",2)=""! '$P(^PRCA( 433,PRCAEN ,1),"^") S  PRCACOMM= "TRANSACTI ON INCOMPL ETE" D DEL ETE^PRCAWO 1 K PRCACO MM Q
  21162   "RTN","RCT CSPD4",240 ,0)
  21163    I '$D(PRC AD("DELETE ")) S RCAS K=1 D TRAN UP^PRCAUTL ,UPPRIN^PR CADJ
  21164   "RTN","RCT CSPD4",241 ,0)
  21165    I $P($G(^ RCD(340,+$ P(^PRCA(43 0,PRCABN,0 ),"^",9),0 )),"^")["; DPT(" D
  21166   "RTN","RCT CSPD4",242 ,0)
  21167    .;Ensure  comment do es not app ear on pat ient state ment
  21168   "RTN","RCT CSPD4",243 ,0)
  21169    .S $P(^PR CA(433,PRC AEN,0),"^" ,10)=1
  21170   "RTN","RCT CSPD4",244 ,0)
  21171    Q
  21172   "RTN","RCT CSPD4",245 ,0)
  21173    ; End of  RCTCSPD4
  21174   "RTN","RCT CSPD5")
  21175   0^60^B1997 1041^n/a
  21176   "RTN","RCT CSPD5",1,0 )
  21177   RCTCSPD5 ; ALB/LMH-CR OSS-SERVIC ING NON-FI NANCIAL TR ANSACTIONS  ;03/15/14  3:34 PM
  21178   "RTN","RCT CSPD5",2,0 )
  21179    ;;4.5;Acc ounts Rece ivable;**3 15**;Mar 2 0, 1995;Bu ild 55
  21180   "RTN","RCT CSPD5",3,0 )
  21181    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  21182   "RTN","RCT CSPD5",4,0 )
  21183    ;
  21184   "RTN","RCT CSPD5",5,0 )
  21185    Q
  21186   "RTN","RCT CSPD5",6,0 )
  21187    ;
  21188   "RTN","RCT CSPD5",7,0 )
  21189   CSATRY ; C ross-Servi cing Admin  Adj Treas ury Rev? Y es non-fin ancial tx
  21190   "RTN","RCT CSPD5",8,0 )
  21191    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER,X
  21192   "RTN","RCT CSPD5",9,0 )
  21193    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  21194   "RTN","RCT CSPD5",10, 0)
  21195    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  21196   "RTN","RCT CSPD5",11, 0)
  21197    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  21198   "RTN","RCT CSPD5",12, 0)
  21199    S DIE="^P RCA(433,", DA=PRCAEN
  21200   "RTN","RCT CSPD5",13, 0)
  21201    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  21202   "RTN","RCT CSPD5",14, 0)
  21203    S DR=DR_" ;3///0" ;C alm Code D one
  21204   "RTN","RCT CSPD5",15, 0)
  21205    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",53 ,0)) ;Tran saction Ty pe
  21206   "RTN","RCT CSPD5",16, 0)
  21207    S DR=DR_" ;15///0" ; Transactio n Amount
  21208   "RTN","RCT CSPD5",17, 0)
  21209    S DR=DR_" ;42///"_DU Z ;Process ed by user
  21210   "RTN","RCT CSPD5",18, 0)
  21211    S DR=DR_" ;11///"_DT  ;Transact ion date
  21212   "RTN","RCT CSPD5",19, 0)
  21213    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  21214   "RTN","RCT CSPD5",20, 0)
  21215    S DR=DR_" ;5.02///CS  ADMIN ADJ  TR REV?Y"  D ^DIE
  21216   "RTN","RCT CSPD5",21, 0)
  21217    Q
  21218   "RTN","RCT CSPD5",22, 0)
  21219    ;
  21220   "RTN","RCT CSPD5",23, 0)
  21221   CSATRN ; C ross-Servi cing Admin  Adj Treas ury Rev? N o non-fina ncial tx
  21222   "RTN","RCT CSPD5",24, 0)
  21223    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER,X
  21224   "RTN","RCT CSPD5",25, 0)
  21225    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  21226   "RTN","RCT CSPD5",26, 0)
  21227    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  21228   "RTN","RCT CSPD5",27, 0)
  21229    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  21230   "RTN","RCT CSPD5",28, 0)
  21231    S DIE="^P RCA(433,", DA=PRCAEN
  21232   "RTN","RCT CSPD5",29, 0)
  21233    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  21234   "RTN","RCT CSPD5",30, 0)
  21235    S DR=DR_" ;3///0" ;C alm Code D one
  21236   "RTN","RCT CSPD5",31, 0)
  21237    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",54 ,0)) ;Tran saction Ty pe
  21238   "RTN","RCT CSPD5",32, 0)
  21239    S DR=DR_" ;15///0" ; Transactio n Amount
  21240   "RTN","RCT CSPD5",33, 0)
  21241    S DR=DR_" ;42///"_DU Z ;Process ed by user
  21242   "RTN","RCT CSPD5",34, 0)
  21243    S DR=DR_" ;11///"_DT  ;Transact ion date
  21244   "RTN","RCT CSPD5",35, 0)
  21245    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  21246   "RTN","RCT CSPD5",36, 0)
  21247    S DR=DR_" ;5.02///CS  ADMIN ADJ  TR REV?N"  D ^DIE
  21248   "RTN","RCT CSPD5",37, 0)
  21249    Q
  21250   "RTN","RCT CSPD5",38, 0)
  21251    ;
  21252   "RTN","RCT CSPD5",39, 0)
  21253   CSITRY ; C ross-Servi cing Incr  Adj Treasu ry Rev? Ye s non-fina ncial tx
  21254   "RTN","RCT CSPD5",40, 0)
  21255    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER,X
  21256   "RTN","RCT CSPD5",41, 0)
  21257    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  21258   "RTN","RCT CSPD5",42, 0)
  21259    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  21260   "RTN","RCT CSPD5",43, 0)
  21261    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  21262   "RTN","RCT CSPD5",44, 0)
  21263    S DIE="^P RCA(433,", DA=PRCAEN
  21264   "RTN","RCT CSPD5",45, 0)
  21265    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  21266   "RTN","RCT CSPD5",46, 0)
  21267    S DR=DR_" ;3///0" ;C alm Code D one
  21268   "RTN","RCT CSPD5",47, 0)
  21269    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",57 ,0)) ;Tran saction Ty pe
  21270   "RTN","RCT CSPD5",48, 0)
  21271    S DR=DR_" ;15///0" ; Transactio n Amount
  21272   "RTN","RCT CSPD5",49, 0)
  21273    S DR=DR_" ;42///"_DU Z ;Process ed by user
  21274   "RTN","RCT CSPD5",50, 0)
  21275    S DR=DR_" ;11///"_DT  ;Transact ion date
  21276   "RTN","RCT CSPD5",51, 0)
  21277    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  21278   "RTN","RCT CSPD5",52, 0)
  21279    S DR=DR_" ;5.02///CS  INC ADJ T R REV?Y" D  ^DIE
  21280   "RTN","RCT CSPD5",53, 0)
  21281    Q
  21282   "RTN","RCT CSPD5",54, 0)
  21283    ;
  21284   "RTN","RCT CSPD5",55, 0)
  21285   CSITRN ; C ross-Servi cing Incr  Adj Treasu ry Rev? No  non-finan cial tx
  21286   "RTN","RCT CSPD5",56, 0)
  21287    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER,X
  21288   "RTN","RCT CSPD5",57, 0)
  21289    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  21290   "RTN","RCT CSPD5",58, 0)
  21291    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  21292   "RTN","RCT CSPD5",59, 0)
  21293    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  21294   "RTN","RCT CSPD5",60, 0)
  21295    S DIE="^P RCA(433,", DA=PRCAEN
  21296   "RTN","RCT CSPD5",61, 0)
  21297    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  21298   "RTN","RCT CSPD5",62, 0)
  21299    S DR=DR_" ;3///0" ;C alm Code D one
  21300   "RTN","RCT CSPD5",63, 0)
  21301    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",58 ,0)) ;Tran saction Ty pe
  21302   "RTN","RCT CSPD5",64, 0)
  21303    S DR=DR_" ;15///0" ; Transactio n Amount
  21304   "RTN","RCT CSPD5",65, 0)
  21305    S DR=DR_" ;42///"_DU Z ;Process ed by user
  21306   "RTN","RCT CSPD5",66, 0)
  21307    S DR=DR_" ;11///"_DT  ;Transact ion date
  21308   "RTN","RCT CSPD5",67, 0)
  21309    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  21310   "RTN","RCT CSPD5",68, 0)
  21311    S DR=DR_" ;5.02///CS  INC ADJ T R REV?N" D  ^DIE
  21312   "RTN","RCT CSPD5",69, 0)
  21313    Q
  21314   "RTN","RCT CSPD5",70, 0)
  21315    ;
  21316   "RTN","RCT CSPD5",71, 0)
  21317   CSPRTR ; C ross-Servi cing PENDI NG RECONCI LIATION no n-financia l tx  
  21318   "RTN","RCT CSPD5",72, 0)
  21319    ;       C alled by R 1^RCTCSPRS
  21320   "RTN","RCT CSPD5",73, 0)
  21321    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER,DU Z
  21322   "RTN","RCT CSPD5",74, 0)
  21323    ; DUZ is  reserved,  but in thi s case DUZ  may be un defined du e to a ser ver backgr ound job,  but we don 't want to  overwrite  DUZ if it  exists
  21324   "RTN","RCT CSPD5",75, 0)
  21325    S PRCABN= BILL,DUZ=. 5,DUZ(0)=" @",DUZ(2)= 1 ; Server  has no DU Z, use Pos tmaster
  21326   "RTN","RCT CSPD5",76, 0)
  21327    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  21328   "RTN","RCT CSPD5",77, 0)
  21329    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  21330   "RTN","RCT CSPD5",78, 0)
  21331    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  21332   "RTN","RCT CSPD5",79, 0)
  21333    S DIE="^P RCA(433,", DA=PRCAEN
  21334   "RTN","RCT CSPD5",80, 0)
  21335    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  21336   "RTN","RCT CSPD5",81, 0)
  21337    S DR=DR_" ;3///0" ;C alm Code D one
  21338   "RTN","RCT CSPD5",82, 0)
  21339    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",61 ,0)) ;Tran saction Ty pe
  21340   "RTN","RCT CSPD5",83, 0)
  21341    S DR=DR_" ;15///0" ; Transactio n Amount
  21342   "RTN","RCT CSPD5",84, 0)
  21343    S DR=DR_" ;42///"_DU Z ;Process ed by user
  21344   "RTN","RCT CSPD5",85, 0)
  21345    S DR=DR_" ;11///"_DT  ;Transact ion date
  21346   "RTN","RCT CSPD5",86, 0)
  21347    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  21348   "RTN","RCT CSPD5",87, 0)
  21349    S DR=DR_" ;5.02///CS  PENDING R ECON" D ^D IE
  21350   "RTN","RCT CSPD5",88, 0)
  21351    Q
  21352   "RTN","RCT CSPD5",89, 0)
  21353    ;
  21354   "RTN","RCT CSPD5",90, 0)
  21355   CSRCLPL ;  CS RECALL  placed non -financial  tx
  21356   "RTN","RCT CSPD5",91, 0)
  21357    N PRCAEN, PRCAA1,DR, DIE,DA,D0, PRCAD,RCAS K,PRCAA2,P RCA,PRCATY ,RCUSER
  21358   "RTN","RCT CSPD5",92, 0)
  21359    S PRCABN= BILL
  21360   "RTN","RCT CSPD5",93, 0)
  21361    D SETTR^P RCAUTL,PAT TR^PRCAUTL  Q:'$D(PRC AEN)
  21362   "RTN","RCT CSPD5",94, 0)
  21363    S PRCAA1= $S($D(^PRC A(433,PRCA EN,4,0)):+ $P(^(0),U, 4),1:0)
  21364   "RTN","RCT CSPD5",95, 0)
  21365    Q:PRCAA1' >0  S PRCA A2=$P(^(0) ,U,3)
  21366   "RTN","RCT CSPD5",96, 0)
  21367    S DIE="^P RCA(433,", DA=PRCAEN
  21368   "RTN","RCT CSPD5",97, 0)
  21369    S DR=".03 ///"_PRCAB N ;Bill Nu mber
  21370   "RTN","RCT CSPD5",98, 0)
  21371    S DR=DR_" ;3///0" ;C alm Code D one
  21372   "RTN","RCT CSPD5",99, 0)
  21373    S DR=DR_" ;12///"_$O (^PRCA(430 .3,"AC",62 ,0)) ;Tran saction Ty pe
  21374   "RTN","RCT CSPD5",100 ,0)
  21375    S DR=DR_" ;15///0" ; Transactio n Amount
  21376   "RTN","RCT CSPD5",101 ,0)
  21377    S DR=DR_" ;42///"_DU Z ;Process ed by user
  21378   "RTN","RCT CSPD5",102 ,0)
  21379    S DR=DR_" ;11///"_DT  ;Transact ion date
  21380   "RTN","RCT CSPD5",103 ,0)
  21381    S DR=DR_" ;4///2" ;T ransaction  status (c omplete)
  21382   "RTN","RCT CSPD5",104 ,0)
  21383    S DR=DR_" ;5.02///CS  RECALL PL ACED" D ^D IE
  21384   "RTN","RCT CSPD5",105 ,0)
  21385    Q
  21386   "RTN","RCT CSPD5",106 ,0)
  21387    ; End of  RCTCSPD5
  21388   "RTN","RCT CSPRS")
  21389   0^35^B6092 2582^B5392 8265
  21390   "RTN","RCT CSPRS",1,0 )
  21391   RCTCSPRS ; ALBANY/BDB  - CROSS-S ERVICING ( RECONCILIA TION SERVE R);02/19/1 4 3:21 PM
  21392   "RTN","RCT CSPRS",2,0 )
  21393    ;;4.5;Acc ounts Rece ivable;**3 01,315**;M ar 20, 199 5;Build 55
  21394   "RTN","RCT CSPRS",3,0 )
  21395    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  21396   "RTN","RCT CSPRS",4,0 )
  21397    ;
  21398   "RTN","RCT CSPRS",5,0 )
  21399    ;Program  to process  reconcili ation serv er message s from AIT C
  21400   "RTN","RCT CSPRS",6,0 )
  21401    ;
  21402   "RTN","RCT CSPRS",7,0 )
  21403    ;
  21404   "RTN","RCT CSPRS",8,0 )
  21405   READ ;READ S MESSAGE  INTO TEMPO RARY GLOBA L
  21406   "RTN","RCT CSPRS",9,0 )
  21407    N FDT,RDN ODE S FDT= 0
  21408   "RTN","RCT CSPRS",10, 0)
  21409    K ^XTMP(" RCTCSPD",$ J)
  21410   "RTN","RCT CSPRS",11, 0)
  21411    ;New repo rt for cla ims return ed from tr easury PRC A*4.5*315
  21412   "RTN","RCT CSPRS",12, 0)
  21413    S ^XTMP(" RCTCSP5 -  "_DT,0)=$$ FMADD^XLFD T(DT,57)_" ^"_DT_"^"_ "Treasury  Cross-Serv icing IAI  Report"  ;  Maintain  this entry  for 57 da ys
  21414   "RTN","RCT CSPRS",13, 0)
  21415    S RDNODE= $NA(^XTMP( "RCTCSP5 -  "_DT))
  21416   "RTN","RCT CSPRS",14, 0)
  21417    ;
  21418   "RTN","RCT CSPRS",15, 0)
  21419    S XMA=0
  21420   "RTN","RCT CSPRS",16, 0)
  21421   READ1 X XM REC I $D(X MER) G:XME R<0 READQ
  21422   "RTN","RCT CSPRS",17, 0)
  21423    I $E(XMRG ,1)="H" S  FDT=$E(XMR G,2,9)
  21424   "RTN","RCT CSPRS",18, 0)
  21425    S ^XTMP(" RCTCSPRS", $J,"READ", FDT,XMPOS) =XMRG
  21426   "RTN","RCT CSPRS",19, 0)
  21427    G READ1
  21428   "RTN","RCT CSPRS",20, 0)
  21429    ;
  21430   "RTN","RCT CSPRS",21, 0)
  21431   READQ K XM A,XMER,XMR EC,XMPOS,X MRG
  21432   "RTN","RCT CSPRS",22, 0)
  21433    N TYPE,VA LC,VFASTCD ,VSTTN,VSI TE,LN,REC, REC1,REC2
  21434   "RTN","RCT CSPRS",23, 0)
  21435    S VALC="3 6001200"
  21436   "RTN","RCT CSPRS",24, 0)
  21437    S VFASTCD ="36"
  21438   "RTN","RCT CSPRS",25, 0)
  21439    S VSTTN=" DM1D "
  21440   "RTN","RCT CSPRS",26, 0)
  21441    S VSITE=$ E($$SITE^R CMSITE(),1 ,3)
  21442   "RTN","RCT CSPRS",27, 0)
  21443    S LN=0
  21444   "RTN","RCT CSPRS",28, 0)
  21445    F  S LN=$ O(^XTMP("R CTCSPRS",$ J,"READ",F DT,LN)) Q: LN=""  S R EC1=$G(^(L N)),LN=LN+ 1,REC2=$G( ^(LN)),REC =$E(REC1,1 ,225)_$E(R EC2,1,225)  D
  21446   "RTN","RCT CSPRS",29, 0)
  21447    .S TYPE=$ E(REC,1,2)
  21448   "RTN","RCT CSPRS",30, 0)
  21449    .I TYPE[" H" D HDR Q
  21450   "RTN","RCT CSPRS",31, 0)
  21451    .I TYPE=" A1" Q
  21452   "RTN","RCT CSPRS",32, 0)
  21453    .I TYPE=" C1" Q
  21454   "RTN","RCT CSPRS",33, 0)
  21455    .I TYPE=" R1" D R1 Q
  21456   "RTN","RCT CSPRS",34, 0)
  21457    .I TYPE=" R2" D R2 Q
  21458   "RTN","RCT CSPRS",35, 0)
  21459    .I TYPE[" Z" K TYPE  Q
  21460   "RTN","RCT CSPRS",36, 0)
  21461    .Q
  21462   "RTN","RCT CSPRS",37, 0)
  21463    ;
  21464   "RTN","RCT CSPRS",38, 0)
  21465   TRDT ;send s mailman  message to  user for  returned d ebts
  21466   "RTN","RCT CSPRS",39, 0)
  21467    Q:'$D(^XT MP("RCTCSP D",$J,"TRD TRDB"))
  21468   "RTN","RCT CSPRS",40, 0)
  21469    S XMDUZ=" AR PACKAGE ",XMY("G.T CSP")=""
  21470   "RTN","RCT CSPRS",41, 0)
  21471    N TCT1,TD EB1,TDEB10 ,TBIL1,TSP 1,FST1,TBC NT,TTXT1
  21472   "RTN","RCT CSPRS",42, 0)
  21473    S XMSUB=" CS QUALIFI ED/RETURNE D DEBTS "_ $E(DT,4,5) _"/"_$E(DT ,6,7)_"/"_ $E(DT,2,3)
  21474   "RTN","RCT CSPRS",43, 0)
  21475    S ^XTMP(" RCTCSPD",$ J,"TRDT",1 )="The fol lowing Deb tors and D ebts were  Returned b y Reconcil iation."
  21476   "RTN","RCT CSPRS",44, 0)
  21477    S ^XTMP(" RCTCSPD",$ J,"TRDT",2 )=""
  21478   "RTN","RCT CSPRS",45, 0)
  21479    S ^XTMP(" RCTCSPD",$ J,"TRDT",3 )="Name                                         Bill #     Return ed Date    Closed Dat e"
  21480   "RTN","RCT CSPRS",46, 0)
  21481    S ^XTMP(" RCTCSPD",$ J,"TRDT",4 )="----                                         ------     ------ -- ----    ------ --- -"
  21482   "RTN","RCT CSPRS",47, 0)
  21483    S TCT1=5, TSP1=0,TDE B1="",TBCN T=0
  21484   "RTN","RCT CSPRS",48, 0)
  21485    F  S TDEB 1=$O(^XTMP ("RCTCSPD" ,$J,"TRDTR DB",TDEB1) ) Q:TDEB1= ""  D
  21486   "RTN","RCT CSPRS",49, 0)
  21487    .S FST1=1 ,TBIL1=""
  21488   "RTN","RCT CSPRS",50, 0)
  21489    .I FST1,T CT1'=5 S ^ XTMP("RCTC SPD",$J,"T RDT",TCT1) ="",TCT1=T CT1+1,TSP1 =TSP1+1
  21490   "RTN","RCT CSPRS",51, 0)
  21491    .F  S TBI L1=$O(^XTM P("RCTCSPD ",$J,"TRDT RDB",TDEB1 ,TBIL1)) Q :TBIL1=""   S TBCNT=T BCNT+1 D
  21492   "RTN","RCT CSPRS",52, 0)
  21493    ..S TDEB1 0=$S(FST1: TDEB1,1:"" ),TTXT1=""
  21494   "RTN","RCT CSPRS",53, 0)
  21495    ..F  S TT XT1=$O(^XT MP("RCTCSP D",$J,"TRD TRDB",TDEB 1,TBIL1,TT XT1)) Q:TT XT1=""  S  ^XTMP("RCT CSPD",$J," TRDT",TCT1 )=^XTMP("R CTCSPD",$J ,"TRDTRDB" ,TDEB1,TBI L1,TTXT1)  S TCT1=TCT 1+1
  21496   "RTN","RCT CSPRS",54, 0)
  21497    ..S TCT1= TCT1+1,FST 1=0
  21498   "RTN","RCT CSPRS",55, 0)
  21499    S ^XTMP(" RCTCSPD",$ J,"TRDT",T CT1)="Tota l records:  "_TBCNT
  21500   "RTN","RCT CSPRS",56, 0)
  21501    S XMTEXT= "^XTMP(""R CTCSPD""," _$J_",""TR DT"","
  21502   "RTN","RCT CSPRS",57, 0)
  21503    D ^XMD K  XMDUZ,XMSU B,XMTEXT,X MY
  21504   "RTN","RCT CSPRS",58, 0)
  21505    K ^XTMP(" RCTCSPD",$ J,"TRDT")
  21506   "RTN","RCT CSPRS",59, 0)
  21507   TRDTQ Q
  21508   "RTN","RCT CSPRS",60, 0)
  21509    ;
  21510   "RTN","RCT CSPRS",61, 0)
  21511   HDR ; head er record
  21512   "RTN","RCT CSPRS",62, 0)
  21513    S TFASTCD =$E(REC,10 ,11),TALC= $E(REC,12, 19) ;repea ted on r1  AND r2
  21514   "RTN","RCT CSPRS",63, 0)
  21515    Q
  21516   "RTN","RCT CSPRS",64, 0)
  21517    ;
  21518   "RTN","RCT CSPRS",65, 0)
  21519   R1 ;return ed debt re cord
  21520   "RTN","RCT CSPRS",66, 0)
  21521    N TFASTCD ,TALC,TSTT N,TDBTID,T RDT,TSITE, BILLNO,BIL L,B0,B4,B6 ,B7,B9,B14 ,B15,B16,D EBTOR,RJND
  21522   "RTN","RCT CSPRS",67, 0)
  21523    S TFASTCD =$E(REC,3, 4),TALC=$E (REC,5,12) ,TSTTN=$E( REC,13,17) ,TDBTID=$E (REC,18,47 ),TRDT=$E( REC,58,65)
  21524   "RTN","RCT CSPRS",68, 0)
  21525    I TFASTCD '=VFASTCD  D NPMSG("F ASTCD",TFA STCD,VFAST CD) Q
  21526   "RTN","RCT CSPRS",69, 0)
  21527    I TALC'=V ALC D NPMS G("ALC",TA LC,VALC) Q
  21528   "RTN","RCT CSPRS",70, 0)
  21529    I TSTTN'= VSTTN D NP MSG("STATI ON",TSTTN, VSTTN)
  21530   "RTN","RCT CSPRS",71, 0)
  21531    S TSITE=$ E(TDBTID,1 ,3) I TSIT E'=VSITE D  NPMSG("SI TE",TSITE, VSITE) Q
  21532   "RTN","RCT CSPRS",72, 0)
  21533    S BILLNO= $E(TDBTID, 4,10),BILL =+$E(TDBTI D,11,30)   ;BILL = IE N
  21534   "RTN","RCT CSPRS",73, 0)
  21535    S B0=$G(^ PRCA(430,B ILL,0)),B4 =$G(^(4)), B6=$G(^(6) ),B7=$G(^( 7)),B9=$G( ^(9)),B14= $G(^(14)), B15=$G(^(1 5)),B16=$G (^(16))
  21536   "RTN","RCT CSPRS",74, 0)
  21537    S DEBTOR= $P(B0,U,9)
  21538   "RTN","RCT CSPRS",75, 0)
  21539     ;PRCA*4. 5*315  set  data for  IAI report  (^RCTCSP5 )
  21540   "RTN","RCT CSPRS",76, 0)
  21541    S @RDNODE @(DEBTOR,B ILL)=""    ;set to de btor then  bill IEN f or sorting  the IAI r eport
  21542   "RTN","RCT CSPRS",77, 0)
  21543    ;set comm ent transa ction in 4 33
  21544   "RTN","RCT CSPRS",78, 0)
  21545    D CSPRTR^ RCTCSPD5   ;PRCA*4.5* 315
  21546   "RTN","RCT CSPRS",79, 0)
  21547    ;
  21548   "RTN","RCT CSPRS",80, 0)
  21549    S RJND=0  F  S RJND= $O(^PRCA(4 30,BILL,18 ,RJND)) Q: 'RJND  D
  21550   "RTN","RCT CSPRS",81, 0)
  21551    .N DAT
  21552   "RTN","RCT CSPRS",82, 0)
  21553    .S DAT=+$ G(^PRCA(43 0,BILL,18, RJND,0))
  21554   "RTN","RCT CSPRS",83, 0)
  21555    .I DAT K  ^PRCA(430, "AB",DAT,B ILL)
  21556   "RTN","RCT CSPRS",84, 0)
  21557    K ^PRCA(4 30,BILL,15 ),^(16),^( 17),^(18), ^(19),^(20 )
  21558   "RTN","RCT CSPRS",85, 0)
  21559    I +TRDT D
  21560   "RTN","RCT CSPRS",86, 0)
  21561    .N DNM
  21562   "RTN","RCT CSPRS",87, 0)
  21563    .I $D(^XT MP("RCTCSP D",$J,"TRD TRDB",DEBT OR,BILL,1) ) S $E(^XT MP("RCTCSP D",$J,"TRD TRDB",DEBT OR,BILL,1) ,52,63)=$$ DTT2E(TRDT ) Q
  21564   "RTN","RCT CSPRS",88, 0)
  21565    .S DNM=$E ($$NAMEFF( +^RCD(340, DEBTOR,0)) ,1,30),DNM =$$LJSF(DN M,30)
  21566   "RTN","RCT CSPRS",89, 0)
  21567    .S ^XTMP( "RCTCSPD", $J,"TRDTRD B",DEBTOR, BILL,1)=$$ LJSF(DNM,3 0)_"            "_$$L JSF(BILLNO ,7)_"   "_ $$DTT2E(TR DT)
  21568   "RTN","RCT CSPRS",90, 0)
  21569    .S EFFDT= $$HL7TFM^X LFDT(TRDT) ,REASON="O ",COMMENT= "BY RECONC ILIATION"
  21570   "RTN","RCT CSPRS",91, 0)
  21571    .S $P(^PR CA(430,BIL L,15),U,7, 10)="1^"_E FFDT_U_REA SON_U_$G(C OMMENT)
  21572   "RTN","RCT CSPRS",92, 0)
  21573    .S $P(^PR CA(430,BIL L,30),U,1) =$$HL7TFM^ XLFDT(TRDT )
  21574   "RTN","RCT CSPRS",93, 0)
  21575    .S ^PRCA( 430,"AN",D T,BILL)=""   ;PRCA*4. 5*315 Adde d cross-re ference to  streamlin e report l oop
  21576   "RTN","RCT CSPRS",94, 0)
  21577    K ^PRCA(4 30,"TCSP", BILL) ;set  the bill  to not sen t to cross -servicing
  21578   "RTN","RCT CSPRS",95, 0)
  21579    Q
  21580   "RTN","RCT CSPRS",96, 0)
  21581    ;
  21582   "RTN","RCT CSPRS",97, 0)
  21583   R2 ;return ed debtor  record
  21584   "RTN","RCT CSPRS",98, 0)
  21585    N TFASTCD ,TALC,TSTT N,TDBTID,T SITE,TFDA, TDBTORID,T RRSNCD,TCM PIND,TCMPA MT,TCLSDT, TBNKDT,TDT HDT,TDISDT ,RJND
  21586   "RTN","RCT CSPRS",99, 0)
  21587    S TFASTCD =$E(REC,3, 4),TALC=$E (REC,5,12) ,TSTTN=$E( REC,13,17) ,TDBTID=$E (REC,18,47 ),TDBTORID =$E(REC,48 ,62),TRRSN CD=$E(REC, 261,262)
  21588   "RTN","RCT CSPRS",100 ,0)
  21589    S TCMPIND =$E(REC,26 3,263),TCM PAMT=$E(RE C,264,277) ,TCLSDT=$E (REC,278,2 85),TBNKDT =$E(REC,28 6,293),TDT HDT=$E(REC ,294,301), TDISDT=$E( REC,302,30 9)
  21590   "RTN","RCT CSPRS",101 ,0)
  21591    I TFASTCD '=VFASTCD  D NPMSG("F ASTCD",TFA STCD,VFAST CD) Q
  21592   "RTN","RCT CSPRS",102 ,0)
  21593    I TALC'=V ALC D NPMS G("ALC",TA LC,VALC) Q
  21594   "RTN","RCT CSPRS",103 ,0)
  21595    I TSTTN'= VSTTN D NP MSG("STATI ON",TSTTN, VSTTN)
  21596   "RTN","RCT CSPRS",104 ,0)
  21597    S TSITE=$ E(TDBTID,1 ,3) I TSIT E'=VSITE D  NPMSG("SI TE",TSITE, VSITE) Q
  21598   "RTN","RCT CSPRS",105 ,0)
  21599    S BILLNO= $E(TDBTID, 4,10),BILL =+$E(TDBTI D,11,30)
  21600   "RTN","RCT CSPRS",106 ,0)
  21601    S B0=$G(^ PRCA(430,B ILL,0))
  21602   "RTN","RCT CSPRS",107 ,0)
  21603    S TRRSNCD =$$CLRBLNK (TRRSNCD)
  21604   "RTN","RCT CSPRS",108 ,0)
  21605    S DEBTOR= $P(B0,U,9)
  21606   "RTN","RCT CSPRS",109 ,0)
  21607    S RJND=0  F  S RJND= $O(^PRCA(4 30,BILL,18 ,RJND)) Q: 'RJND  D
  21608   "RTN","RCT CSPRS",110 ,0)
  21609    .N DAT
  21610   "RTN","RCT CSPRS",111 ,0)
  21611    .S DAT=+$ G(^PRCA(43 0,BILL,18, RJND,0))
  21612   "RTN","RCT CSPRS",112 ,0)
  21613    .I DAT K  ^PRCA(430, "AB",DAT,B ILL)
  21614   "RTN","RCT CSPRS",113 ,0)
  21615    K ^PRCA(4 30,BILL,15 ),^(16),^( 17),^(18), ^(19),^(20 )
  21616   "RTN","RCT CSPRS",114 ,0)
  21617    I TRRSNCD ]"" D
  21618   "RTN","RCT CSPRS",115 ,0)
  21619    .N DNM,EF FDT,REASON ,COMMENT
  21620   "RTN","RCT CSPRS",116 ,0)
  21621    .I $D(^XT MP("RCTCSP D",$J,"TRD TRDB",DEBT OR,BILL,1) ) S $E(^XT MP("RCTCSP D",$J,"TRD TRDB",DEBT OR,BILL,1) ,68,79)=$S ($G(TCLSDT )]"":$$DTT 2E(TCLSDT) ,1:"")
  21622   "RTN","RCT CSPRS",117 ,0)
  21623    .I '$D(^X TMP("RCTCS PD",$J,"TR DTRDB",DEB TOR,BILL,1 )) D
  21624   "RTN","RCT CSPRS",118 ,0)
  21625    ..S DNM=$ E($$NAMEFF (+^RCD(340 ,DEBTOR,0) ),1,30),DN M=$$LJSF(D NM,30),^XT MP("RCTCSP D",$J,"TRD TRDB",DEBT OR,BILL,1) =DNM_"            "_$ $LJSF(BILL NO,7)_"                     "_$S ($G(TCLSDT )]"":$$DTT 2E(TCLSDT) ,1:"")
  21626   "RTN","RCT CSPRS",119 ,0)
  21627    .S DIC="^ PRCA(430.5 ,",DIC(0)= "Z",X=TRRS NCD D ^DIC  K DIC I + Y>0 D
  21628   "RTN","RCT CSPRS",120 ,0)
  21629    ..S ^XTMP ("RCTCSPD" ,$J,"TRDTR DB",DEBTOR ,BILL,2)="      "_$P( Y(0),U,2)
  21630   "RTN","RCT CSPRS",121 ,0)
  21631    ..S $P(^P RCA(430,BI LL,30),U,2 )=+Y
  21632   "RTN","RCT CSPRS",122 ,0)
  21633    ..S ^PRCA (430,"AN", DT,BILL)=" "  ;PRCA*4 .5*315 Add ed cross-r eference t o streamli ne report  loop
  21634   "RTN","RCT CSPRS",123 ,0)
  21635    I TCMPIND ="Y" D
  21636   "RTN","RCT CSPRS",124 ,0)
  21637    .S ^XTMP( "RCTCSPD", $J,"TRDTRD B",DEBTOR, BILL,3)="      COMPRO MISE, PLEA SE WRITE T HIS BILL O FF BY THE  MANUAL PRO CESS."
  21638   "RTN","RCT CSPRS",125 ,0)
  21639    .S $P(^PR CA(430,BIL L,30),U,3) =TCMPIND
  21640   "RTN","RCT CSPRS",126 ,0)
  21641    .I +TCMPA MT D
  21642   "RTN","RCT CSPRS",127 ,0)
  21643    ..S ^XTMP ("RCTCSPD" ,$J,"TRDTR DB",DEBTOR ,BILL,4)="      COMPR OMISED AMO UNT (NOT C OLLECTED): "_$J(TCMPA MT/100,9,2 )
  21644   "RTN","RCT CSPRS",128 ,0)
  21645    ..S $P(^P RCA(430,BI LL,30),U,4 )=TCMPAMT/ 100
  21646   "RTN","RCT CSPRS",129 ,0)
  21647    I +TBNKDT  D
  21648   "RTN","RCT CSPRS",130 ,0)
  21649    .S ^XTMP( "RCTCSPD", $J,"TRDTRD B",DEBTOR, BILL,5)="      BANKRU PTCY DATE:  "_$$DTT2E (TBNKDT)
  21650   "RTN","RCT CSPRS",131 ,0)
  21651    .S $P(^PR CA(430,BIL L,30),U,6) =$$HL7TFM^ XLFDT(TBNK DT)
  21652   "RTN","RCT CSPRS",132 ,0)
  21653    I +TDTHDT  D
  21654   "RTN","RCT CSPRS",133 ,0)
  21655    .S ^XTMP( "RCTCSPD", $J,"TRDTRD B",DEBTOR, BILL,6)="      DATE O F DEATH:   "_$$DTT2E( TDTHDT)
  21656   "RTN","RCT CSPRS",134 ,0)
  21657    .S $P(^PR CA(430,BIL L,30),U,7) =$$HL7TFM^ XLFDT(TDTH DT)
  21658   "RTN","RCT CSPRS",135 ,0)
  21659    I +TDISDT  D
  21660   "RTN","RCT CSPRS",136 ,0)
  21661    .S ^XTMP( "RCTCSPD", $J,"TRDTRD B",DEBTOR, BILL,7)="      DATE O F DISSOLUT ION:  "_$$ DTT2E(TDIS DT)
  21662   "RTN","RCT CSPRS",137 ,0)
  21663    .S $P(^PR CA(430,BIL L,30),U,8) =$$HL7TFM^ XLFDT(TDIS DT)
  21664   "RTN","RCT CSPRS",138 ,0)
  21665    I +TCLSDT  D
  21666   "RTN","RCT CSPRS",139 ,0)
  21667    .S EFFDT= $$HL7TFM^X LFDT(TCLSD T),REASON= "O",COMMEN T="BY RECO NCILIATION "
  21668   "RTN","RCT CSPRS",140 ,0)
  21669    .S $P(^PR CA(430,BIL L,15),U,7, 10)="1^"_E FFDT_U_REA SON_U_$G(C OMMENT)
  21670   "RTN","RCT CSPRS",141 ,0)
  21671    .S $P(^PR CA(430,BIL L,30),U,5) =$$HL7TFM^ XLFDT(TCLS DT)
  21672   "RTN","RCT CSPRS",142 ,0)
  21673    K ^PRCA(4 30,"TCSP", BILL) ;set  the bill  to not sen t to cross -servicing
  21674   "RTN","RCT CSPRS",143 ,0)
  21675    S ^XTMP(" RCTCSPD",$ J,"TRDTRDB ",DEBTOR,B ILL,8)=""
  21676   "RTN","RCT CSPRS",144 ,0)
  21677    I +DEBTOR  D
  21678   "RTN","RCT CSPRS",145 ,0)
  21679    .N TCSPFL ,BILLX
  21680   "RTN","RCT CSPRS",146 ,0)
  21681    .S BILLX= "",TCSPFL= 0 ;check i f last cro ss-service d bill
  21682   "RTN","RCT CSPRS",147 ,0)
  21683    .F  S BIL LX=$O(^PRC A(430,"C", DEBTOR,BIL LX)) Q:BIL LX'?1N.N   I $D(^PRCA (430,"TCSP ",BILLX))  S TCSPFL=1  Q
  21684   "RTN","RCT CSPRS",148 ,0)
  21685    .I 'TCSPF L D  Q
  21686   "RTN","RCT CSPRS",149 ,0)
  21687    ..N BILL
  21688   "RTN","RCT CSPRS",150 ,0)
  21689    ..S $P(^R CD(340,DEB TOR,7),U,5 )=""
  21690   "RTN","RCT CSPRS",151 ,0)
  21691    ..K ^RCD( 340,"TCSP" ,DEBTOR) ; set the de btor to no t sent to  cross-serv icing
  21692   "RTN","RCT CSPRS",152 ,0)
  21693    Q
  21694   "RTN","RCT CSPRS",153 ,0)
  21695    ;
  21696   "RTN","RCT CSPRS",154 ,0)
  21697   NPMSG(FLD, TCD,VCD) ; error not  processed
  21698   "RTN","RCT CSPRS",155 ,0)
  21699    Q
  21700   "RTN","RCT CSPRS",156 ,0)
  21701    ;
  21702   "RTN","RCT CSPRS",157 ,0)
  21703   LJSF(X,Y)  ;left just ified spac e filled
  21704   "RTN","RCT CSPRS",158 ,0)
  21705    S X=$E(X, 1,Y)
  21706   "RTN","RCT CSPRS",159 ,0)
  21707    S X=X_$$B LANK(Y-$L( X))
  21708   "RTN","RCT CSPRS",160 ,0)
  21709    Q X
  21710   "RTN","RCT CSPRS",161 ,0)
  21711    ;
  21712   "RTN","RCT CSPRS",162 ,0)
  21713   BLANK(X) ; returns 'x ' blank sp aces
  21714   "RTN","RCT CSPRS",163 ,0)
  21715    N BLANK
  21716   "RTN","RCT CSPRS",164 ,0)
  21717    S BLANK=" ",$P(BLANK ," ",X+1)= ""
  21718   "RTN","RCT CSPRS",165 ,0)
  21719    Q BLANK
  21720   "RTN","RCT CSPRS",166 ,0)
  21721    ;
  21722   "RTN","RCT CSPRS",167 ,0)
  21723   CLRBLNK(X)  ;clear bl anks
  21724   "RTN","RCT CSPRS",168 ,0)
  21725    S X=$TR(X ," ","")
  21726   "RTN","RCT CSPRS",169 ,0)
  21727    Q X
  21728   "RTN","RCT CSPRS",170 ,0)
  21729    ;
  21730   "RTN","RCT CSPRS",171 ,0)
  21731   NAMEFF(DFN ) ;returns  name for  document a nd name in  file
  21732   "RTN","RCT CSPRS",172 ,0)
  21733    N FN,LN,M N,NM,DOCNM ,VA,VADM
  21734   "RTN","RCT CSPRS",173 ,0)
  21735    S NM=""
  21736   "RTN","RCT CSPRS",174 ,0)
  21737    D DEM^VAD PT
  21738   "RTN","RCT CSPRS",175 ,0)
  21739    I $D(VADM ) S NM=VAD M(1)
  21740   "RTN","RCT CSPRS",176 ,0)
  21741    S LN=$TR( $P(NM,",") ," .'-"),M N=$P($P(NM ,",",2),"  ",2)
  21742   "RTN","RCT CSPRS",177 ,0)
  21743    I ($E(MN, 1,2)="SR") !($E(MN,1, 2)="JR")!( MN?2.3"I") !(MN?0.1"I "1"V"1.3"I ") S MN=""
  21744   "RTN","RCT CSPRS",178 ,0)
  21745    S FN=$P($ P(NM,",",2 )," ")
  21746   "RTN","RCT CSPRS",179 ,0)
  21747    S DOCNM=L N_" "_FN_"  "_MN
  21748   "RTN","RCT CSPRS",180 ,0)
  21749    Q DOCNM
  21750   "RTN","RCT CSPRS",181 ,0)
  21751    ;
  21752   "RTN","RCT CSPRS",182 ,0)
  21753   DTT2E(TDT)  ;date tre asury to e xternal fo rmat
  21754   "RTN","RCT CSPRS",183 ,0)
  21755    Q $$UPPER ^VALM1($$F MTE^XLFDT( $$HL7TFM^X LFDT(TDT)) )
  21756   "RTN","RCT CSPU")
  21757   0^16^B7947 4233^B5561 6924
  21758   "RTN","RCT CSPU",1,0)
  21759   RCTCSPU ;A LBANY/BDB- CROSS-SERV ICING UTIL ITIES ;03/ 15/14 3:34  PM
  21760   "RTN","RCT CSPU",2,0)
  21761    ;;4.5;Acc ounts Rece ivable;**3 01,315**;M ar 20, 199 5;Build 55
  21762   "RTN","RCT CSPU",3,0)
  21763    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  21764   "RTN","RCT CSPU",4,0)
  21765    Q
  21766   "RTN","RCT CSPU",5,0)
  21767    ;
  21768   "RTN","RCT CSPU",6,0)
  21769    ;total am ount of bi lls for a  debtor
  21770   "RTN","RCT CSPU",7,0)
  21771   TOTALB(DEB TOR) ;
  21772   "RTN","RCT CSPU",8,0)
  21773    N TOTAL,B ILL,B7
  21774   "RTN","RCT CSPU",9,0)
  21775    S TOTAL=0 ,BILL=0
  21776   "RTN","RCT CSPU",10,0 )
  21777    F  S BILL =$O(^PRCA( 430,"C",DE BTOR,BILL) ) Q:BILL'? 1N.N  D
  21778   "RTN","RCT CSPU",11,0 )
  21779    .Q:'$D(^P RCA(430,"T CSP",BILL) )
  21780   "RTN","RCT CSPU",12,0 )
  21781    .S B7=$G( ^PRCA(430, BILL,7))
  21782   "RTN","RCT CSPU",13,0 )
  21783    .S TOTAL= TOTAL+$P(B 7,U)+$P(B7 ,U,2)+$P(B 7,U,3)+$P( B7,U,4)+$P (B7,U,5)
  21784   "RTN","RCT CSPU",14,0 )
  21785    Q TOTAL
  21786   "RTN","RCT CSPU",15,0 )
  21787    ;
  21788   "RTN","RCT CSPU",16,0 )
  21789    ;stop TCS P referral  on a bill
  21790   "RTN","RCT CSPU",17,0 )
  21791   STOP ;stop  Cross-Ser vicing ref erral
  21792   "RTN","RCT CSPU",18,0 )
  21793    N DIC,DIE ,DA,DR,DIR ,Y,BILL,RE ASON,COMME NT,EFFDT
  21794   "RTN","RCT CSPU",19,0 )
  21795    I $G(GOTB ILL) S BIL L=RCBILLDA   ;PRCA*4. 5*315
  21796   "RTN","RCT CSPU",20,0 )
  21797    I '$G(GOT BILL) S DI C=430,DIC( 0)="AEQM"  D ^DIC Q:Y <0  ;PRCA* 4.5*315
  21798   "RTN","RCT CSPU",21,0 )
  21799    I '$G(GOT BILL) S BI LL=+Y  ;PR CA*4.5*315
  21800   "RTN","RCT CSPU",22,0 )
  21801    I $P($G(^ PRCA(430,B ILL,15)),U ,7) G DELS TOP
  21802   "RTN","RCT CSPU",23,0 )
  21803    W !,"Stop  flag for  Cross-Serv icing Refe rral set?  : NO"
  21804   "RTN","RCT CSPU",24,0 )
  21805    S DIR(0)= "Y",DIR("B ")="NO",DI R("A")="Ar e you sure  you want  to stop th e Cross-Se rvicing Re ferral for  this bill " D ^DIR
  21806   "RTN","RCT CSPU",25,0 )
  21807    I $G(GOTB ILL),$D(DI RUT) S RCD PGQ=1       ; account  profile l istman qui t flag  *3 15
  21808   "RTN","RCT CSPU",26,0 )
  21809    I 'Y W !, *7,"No act ion taken"  Q
  21810   "RTN","RCT CSPU",27,0 )
  21811    ;
  21812   "RTN","RCT CSPU",28,0 )
  21813   REASON ;as k referral  reason
  21814   "RTN","RCT CSPU",29,0 )
  21815    K DIR S D IR("A")="E nter Stop  Cross-Serv icing Reas on ",DA=BI LL,DIR(0)= "430,159"  D ^DIR
  21816   "RTN","RCT CSPU",30,0 )
  21817    Q:(Y="")! (Y=U)
  21818   "RTN","RCT CSPU",31,0 )
  21819    S REASON= Y I REASON ="O" D  Q: COMMENT=U   G REASON: COMMENT=""
  21820   "RTN","RCT CSPU",32,0 )
  21821       .S COM MENT="",DI R("A")="En ter Stop R eason Comm ent ",DA=B ILL,DIR(0) ="430,159. 1" D ^DIR  S COMMENT= Y
  21822   "RTN","RCT CSPU",33,0 )
  21823       .I COM MENT="" W  !,"A Reaso n of Other  requires  a comment  to be ente red"
  21824   "RTN","RCT CSPU",34,0 )
  21825       .Q
  21826   "RTN","RCT CSPU",35,0 )
  21827    I REASON' ="O",$P($G (^PRCA(430 ,BILL,15)) ,U,10)'=""  S $P(^(15 ),U,10)=""
  21828   "RTN","RCT CSPU",36,0 )
  21829    ;
  21830   "RTN","RCT CSPU",37,0 )
  21831    ;ask effe ctive date
  21832   "RTN","RCT CSPU",38,0 )
  21833    ;
  21834   "RTN","RCT CSPU",39,0 )
  21835    S DIR(0)= "430,158", DA=BILL,DI R("A")="En ter Effect ive Date "  D ^DIR G: Y=U STOPQ  S EFFDT=Y
  21836   "RTN","RCT CSPU",40,0 )
  21837    ;
  21838   "RTN","RCT CSPU",41,0 )
  21839   STOPFILE ; set stop r eferral da ta in file  430
  21840   "RTN","RCT CSPU",42,0 )
  21841    S $P(^PRC A(430,BILL ,15),U,7,1 0)="1^"_EF FDT_U_REAS ON_U_$G(CO MMENT)
  21842   "RTN","RCT CSPU",43,0 )
  21843    ;
  21844   "RTN","RCT CSPU",44,0 )
  21845    W !,"Stop  Cross-Ser vicing Ref erral comp lete"
  21846   "RTN","RCT CSPU",45,0 )
  21847    D STOP^RC TCSPD4 ; * 315 Create  CS Stop P laced comm ent tx in  433
  21848   "RTN","RCT CSPU",46,0 )
  21849    G STOPQ
  21850   "RTN","RCT CSPU",47,0 )
  21851    ;
  21852   "RTN","RCT CSPU",48,0 )
  21853   DELSTOP ;A llows Cros s-Servicin g Referral  to be re- instituted  for bill
  21854   "RTN","RCT CSPU",49,0 )
  21855    N I
  21856   "RTN","RCT CSPU",50,0 )
  21857    W !!,*7," Referral t o Cross-Se rvicing ha s already  been stopp ed for thi s bill."
  21858   "RTN","RCT CSPU",51,0 )
  21859    W !,"Stop  Cross-Ser vicing ref erral effe ctive date : ",$$GET1 ^DIQ(430,B ILL,158,"E ")
  21860   "RTN","RCT CSPU",52,0 )
  21861    W !,"Stop  Cross-Ser vicing ref erral reas on         : ",$$GET1 ^DIQ(430,B ILL,159,"E ")
  21862   "RTN","RCT CSPU",53,0 )
  21863    I $$GET1^ DIQ(430,BI LL,159,"E" )="OTHER"  W !,"Stop  Cross-Serv icing refe rral comme nt       :  ",$$GET1^ DIQ(430,BI LL,159.1," E")
  21864   "RTN","RCT CSPU",54,0 )
  21865    S DIR(0)= "Y",DIR("A ")="Do you  wish to r e-institut e Cross-Se rvicing Re ferral for  this bill ",DIR("B") ="NO"
  21866   "RTN","RCT CSPU",55,0 )
  21867    D ^DIR
  21868   "RTN","RCT CSPU",56,0 )
  21869    I $G(GOTB ILL),$D(DI RUT) S RCD PGQ=1 G ST OPQ         ; account  profile l istman qui t flag  *3 15
  21870   "RTN","RCT CSPU",57,0 )
  21871    G EDSTOP: 'Y
  21872   "RTN","RCT CSPU",58,0 )
  21873    ;
  21874   "RTN","RCT CSPU",59,0 )
  21875    ;reset fi le to allo w cross-se rvicing re ferral to  be re-star ted
  21876   "RTN","RCT CSPU",60,0 )
  21877    F I=7:1:1 0 S $P(^PR CA(430,BIL L,15),U,I) =""
  21878   "RTN","RCT CSPU",61,0 )
  21879    W !!,"Bil l is now e ligible to  be Referr ed to Cros s-Servicin g" D DELST OP^RCTCSPD 4 G STOPQ  ; *315 cre ate CS Sto p Deleted  transactio n
  21880   "RTN","RCT CSPU",62,0 )
  21881    ;
  21882   "RTN","RCT CSPU",63,0 )
  21883   EDSTOP S D IR(0)="Y", DIR("A")=" Do you wis h to edit  the Stop R eferral Da ta for thi s bill",DI R("B")="NO " D ^DIR G  REASON:Y
  21884   "RTN","RCT CSPU",64,0 )
  21885   STOPQ Q
  21886   "RTN","RCT CSPU",65,0 )
  21887    ;
  21888   "RTN","RCT CSPU",66,0 )
  21889    ;Set Cros s-Servicin g recall f or a bill
  21890   "RTN","RCT CSPU",67,0 )
  21891   RCLLSETB ; Set Cross- Servicing  recall
  21892   "RTN","RCT CSPU",68,0 )
  21893    N DIC,DIE ,DA,DR,DIR ,Y,BILL,RE ASON
  21894   "RTN","RCT CSPU",69,0 )
  21895    I '$G(GOT BILL) S DI C=430,DIC( 0)="AEQM"  D ^DIC Q:Y <0
  21896   "RTN","RCT CSPU",70,0 )
  21897    I '$G(GOT BILL) S BI LL=+Y
  21898   "RTN","RCT CSPU",71,0 )
  21899    I $G(GOTB ILL) S BIL L=RCBILLDA
  21900   "RTN","RCT CSPU",72,0 )
  21901    I $P($G(^ PRCA(430,B ILL,15)),U ,2) G DELS ETB
  21902   "RTN","RCT CSPU",73,0 )
  21903    S DIR(0)= "Y",DIR("B ")="NO",DI R("A")="Ar e you sure  you want  to set thi s bill to  be recalle d from Cro ss-Servici ng" D ^DIR
  21904   "RTN","RCT CSPU",74,0 )
  21905    I $G(GOTB ILL),$D(DI RUT) S RCD PGQ=1         ; accou nt profile  listman q uit flag   *315
  21906   "RTN","RCT CSPU",75,0 )
  21907    I 'Y W !, *7,"No act ion taken"  Q
  21908   "RTN","RCT CSPU",76,0 )
  21909    I '$D(^PR CA(430,"TC SP",BILL))  W !,*7,"N o action t aken.  Bil l has not  been refer red to Cro ss-Servici ng." Q
  21910   "RTN","RCT CSPU",77,0 )
  21911    ; 
  21912   "RTN","RCT CSPU",78,0 )
  21913   RCRSB ;ask  recall re ason
  21914   "RTN","RCT CSPU",79,0 )
  21915    K DIR S D IR(0)="S^0 1:DEBT REF ERRED IN E RROR;07:AG ENCY IS FO RGIVING DE BT;08:AGEN CY CAN COL LECT THROU GH INTERNA L OFFSET"  D ^DIR
  21916   "RTN","RCT CSPU",80,0 )
  21917    Q:(Y="")! (Y=U)
  21918   "RTN","RCT CSPU",81,0 )
  21919    ;set reca ll data in  file 430
  21920   "RTN","RCT CSPU",82,0 )
  21921    S REASON= Y
  21922   "RTN","RCT CSPU",83,0 )
  21923    S $P(^PRC A(430,BILL ,15),U,2,4 )="1^^"_RE ASON
  21924   "RTN","RCT CSPU",84,0 )
  21925    D CSRCLPL ^RCTCSPD5  ; *315 CS  Recall Pla ced commen t tx in 43 3
  21926   "RTN","RCT CSPU",85,0 )
  21927    W !,"Sett ing this b ill for Re call from  Cross-Serv icing is c omplete"
  21928   "RTN","RCT CSPU",86,0 )
  21929    G SETBQ
  21930   "RTN","RCT CSPU",87,0 )
  21931    ;
  21932   "RTN","RCT CSPU",88,0 )
  21933   DELSETB ;A llows Cros s-Servicin g Recall t o be delet ed for bil l
  21934   "RTN","RCT CSPU",89,0 )
  21935    W !!,*7," This bill  has alread y been set  for recal l from Cro ss-Servici ng."
  21936   "RTN","RCT CSPU",90,0 )
  21937    I +$P($G( ^PRCA(430, BILL,15)), U,3) W !!, "Not avail able for r eactivatio n.  The Re call reque st has alr eady been  processed. " G SETBQ
  21938   "RTN","RCT CSPU",91,0 )
  21939    S DIR(0)= "Y",DIR("A ")="Do you  wish to d elete the  Cross-Serv icing Reca ll for thi s bill",DI R("B")="NO "
  21940   "RTN","RCT CSPU",92,0 )
  21941    D ^DIR
  21942   "RTN","RCT CSPU",93,0 )
  21943    I $G(GOTB ILL),$D(DI RUT) S RCD PGQ=1 G SE TBQ          ; accoun t profile  listman qu it flag  * 315
  21944   "RTN","RCT CSPU",94,0 )
  21945    G EDSETB: 'Y
  21946   "RTN","RCT CSPU",95,0 )
  21947    ;
  21948   "RTN","RCT CSPU",96,0 )
  21949    ;delete t he recall
  21950   "RTN","RCT CSPU",97,0 )
  21951    F I=2:1:5  S $P(^PRC A(430,BILL ,15),U,I)= ""
  21952   "RTN","RCT CSPU",98,0 )
  21953    D DELRCLL ^RCTCSPD4  ; *315 Cre ate CS Del ete Recall  comment t x in 433
  21954   "RTN","RCT CSPU",99,0 )
  21955    W !!,"Rec all from C ross-Servi cing has b een delete d for this  bill."
  21956   "RTN","RCT CSPU",100, 0)
  21957    G SETBQ
  21958   "RTN","RCT CSPU",101, 0)
  21959    ;
  21960   "RTN","RCT CSPU",102, 0)
  21961   EDSETB S D IR(0)="Y", DIR("A")=" Do you wis h to edit  the Recall  data for  this bill" ,DIR("B")= "NO" D ^DI R G RCRSB: Y
  21962   "RTN","RCT CSPU",103, 0)
  21963   SETBQ Q
  21964   "RTN","RCT CSPU",104, 0)
  21965    ;
  21966   "RTN","RCT CSPU",105, 0)
  21967    ;Set Cros s-Servicin g recall f or a debto r
  21968   "RTN","RCT CSPU",106, 0)
  21969   RCLLSETD ; Set Cross- Servicing  debtor rec all
  21970   "RTN","RCT CSPU",107, 0)
  21971    N DIC,DIE ,DA,DR,DIR ,Y,DEBTOR, REASON,BIL L
  21972   "RTN","RCT CSPU",108, 0)
  21973    ; GOTDEBT , RCDEBTDA   - are de fined if c alled from  List Mana ger
  21974   "RTN","RCT CSPU",109, 0)
  21975    I '$G(GOT DEBT) S DI C=340,DIC( 0)="AEQM"  D ^DIC Q:Y <0      ;  *315
  21976   "RTN","RCT CSPU",110, 0)
  21977    I '$G(GOT DEBT) S DE BTOR=+Y                                  ;  *315
  21978   "RTN","RCT CSPU",111, 0)
  21979    I $G(GOTD EBT) S DEB TOR=RCDEBT DA                            ;  *315  
  21980   "RTN","RCT CSPU",112, 0)
  21981    I $P($G(^ RCD(340,DE BTOR,7)),U ,2),'$P($G (^RCD(340, DEBTOR,7)) ,U,3) G DE LSETD
  21982   "RTN","RCT CSPU",113, 0)
  21983    S DIR(0)= "Y",DIR("B ")="NO",DI R("A")="Ar e you sure  you want  to recall  this debto r and bill s from Cro ss-Servici ng" D ^DIR
  21984   "RTN","RCT CSPU",114, 0)
  21985    I 'Y W !, *7,"No act ion taken"  Q
  21986   "RTN","RCT CSPU",115, 0)
  21987    I '$D(^RC D(340,"TCS P",DEBTOR) ) W !,*7," No action  taken.  De btor has n ot been re ferred to  Cross-Serv icing." Q
  21988   "RTN","RCT CSPU",116, 0)
  21989    ;
  21990   "RTN","RCT CSPU",117, 0)
  21991   RCRSD ;ask  debtor re call reaso n
  21992   "RTN","RCT CSPU",118, 0)
  21993    K DIR S D IR(0)="340 ,7.04" D ^ DIR
  21994   "RTN","RCT CSPU",119, 0)
  21995    Q:(Y="")! (Y=U)
  21996   "RTN","RCT CSPU",120, 0)
  21997    ;set debt or recall  data in fi le 340
  21998   "RTN","RCT CSPU",121, 0)
  21999    S REASON= Y
  22000   "RTN","RCT CSPU",122, 0)
  22001    S $P(^RCD (340,DEBTO R,7),U,2,4 )="1^^"_RE ASON
  22002   "RTN","RCT CSPU",123, 0)
  22003    ;go throu gh debtor  bills and  set reason  in the bi ll recall  reason
  22004   "RTN","RCT CSPU",124, 0)
  22005    S BILL=0
  22006   "RTN","RCT CSPU",125, 0)
  22007    F  S BILL =$O(^PRCA( 430,"C",DE BTOR,BILL) ) Q:BILL'? 1N.N  D
  22008   "RTN","RCT CSPU",126, 0)
  22009    .I $D(^PR CA(430,"TC SP",BILL))  D  Q  ;bi ll previou sly sent t o TCSP
  22010   "RTN","RCT CSPU",127, 0)
  22011    ..S $P(^P RCA(430,BI LL,15),U,2 ,4)="1^^"_ REASON ;se t the reca ll flag an d reason ( TV9)
  22012   "RTN","RCT CSPU",128, 0)
  22013    ..D CSRCL PL^RCTCSPD 5 ; *315 C reate CS R ECALL PLAC ED tx in 4 33
  22014   "RTN","RCT CSPU",129, 0)
  22015    W !,"Sett ing this d ebtor for  Recall fro m Cross-Se rvicing is  complete"
  22016   "RTN","RCT CSPU",130, 0)
  22017    G SETDQ
  22018   "RTN","RCT CSPU",131, 0)
  22019    ;
  22020   "RTN","RCT CSPU",132, 0)
  22021   DELSETD ;A llows Cros s-Servicin g Recall t o be delet ed for deb tor
  22022   "RTN","RCT CSPU",133, 0)
  22023    W !!,*7," This debto r has alre ady been s et for rec all from C ross-Servi cing."
  22024   "RTN","RCT CSPU",134, 0)
  22025    S DIR(0)= "Y",DIR("A ")="Do you  wish to d elete the  Cross-Serv icing Reca ll for thi s debtor", DIR("B")=" NO" D ^DIR  G EDSETD: 'Y
  22026   "RTN","RCT CSPU",135, 0)
  22027    ;
  22028   "RTN","RCT CSPU",136, 0)
  22029    ;delete t he recall  in file 34 0
  22030   "RTN","RCT CSPU",137, 0)
  22031    F I=2:1:4  S $P(^RCD (340,DEBTO R,7),U,I)= ""
  22032   "RTN","RCT CSPU",138, 0)
  22033    ;go throu gh debtor  bills and  delete the  recall fl ag & reaso n
  22034   "RTN","RCT CSPU",139, 0)
  22035    S BILL=0
  22036   "RTN","RCT CSPU",140, 0)
  22037    F  S BILL =$O(^PRCA( 430,"C",DE BTOR,BILL) ) Q:BILL'? 1N.N  D
  22038   "RTN","RCT CSPU",141, 0)
  22039    .I $D(^PR CA(430,"TC SP",BILL))  D  Q  ;bi ll previou sly sent t o TCSP 
  22040   "RTN","RCT CSPU",142, 0)
  22041    ..S $P(^P RCA(430,BI LL,15),U,2 )="" ; del ete the re call flag  PRCA*4.5*3 15 
  22042   "RTN","RCT CSPU",143, 0)
  22043    ..S $P(^P RCA(430,BI LL,15),U,4 )="" ; del ete the re call reaso n
  22044   "RTN","RCT CSPU",144, 0)
  22045    ..D DELRC LL^RCTCSPD 4 ; *315 C S DEL BILL  RECALL in  433
  22046   "RTN","RCT CSPU",145, 0)
  22047    ;
  22048   "RTN","RCT CSPU",146, 0)
  22049    W !!,"Rec all from C ross-Servi cing has b een delete d for this  debtor."
  22050   "RTN","RCT CSPU",147, 0)
  22051    G SETDQ
  22052   "RTN","RCT CSPU",148, 0)
  22053    ;
  22054   "RTN","RCT CSPU",149, 0)
  22055   EDSETD S D IR(0)="Y", DIR("A")=" Do you wis h to edit  the Recall  data for  this debto r",DIR("B" )="NO" D ^ DIR G RCRS D:Y
  22056   "RTN","RCT CSPU",150, 0)
  22057   SETDQ Q
  22058   "RTN","RCT CSPU",151, 0)
  22059    ;
  22060   "RTN","RCT CSPU",152, 0)
  22061   DECADJ(RCB ILLDA,RCTR ANDA) ;dec rease adju stment tra nsaction h istory for  5b cross- servicing  record
  22062   "RTN","RCT CSPU",153, 0)
  22063    ;rcbillda  - file 43 0 bill ien
  22064   "RTN","RCT CSPU",154, 0)
  22065    ;rctranda  - file 43 3 transact ion ien
  22066   "RTN","RCT CSPU",155, 0)
  22067    N BILL,DI C,DA,DIE,D R,Y,X
  22068   "RTN","RCT CSPU",156, 0)
  22069    I '$D(RCB ILLDA)!('$ D(RCTRANDA )) Q
  22070   "RTN","RCT CSPU",157, 0)
  22071    S X=RCTRA NDA
  22072   "RTN","RCT CSPU",158, 0)
  22073    S DIC="^P RCA(430,"_ RCBILLDA_" ,17,",DIC( 0)="L"
  22074   "RTN","RCT CSPU",159, 0)
  22075    I '$D(^PR CA(430,RCB ILLDA,17,0 )) S ^PRCA (430,RCBIL LDA,17,0)= "^430.0171 PA^0^0"
  22076   "RTN","RCT CSPU",160, 0)
  22077    S DIC("P" )=$P(^PRCA (430,RCBIL LDA,17,0), "^",2)
  22078   "RTN","RCT CSPU",161, 0)
  22079    S DA(1)=R CBILLDA
  22080   "RTN","RCT CSPU",162, 0)
  22081    S BILL=RC BILLDA
  22082   "RTN","RCT CSPU",163, 0)
  22083    D ^DIC I  Y=-1 K DIC ,DA Q
  22084   "RTN","RCT CSPU",164, 0)
  22085    S DIE=DIC  K DIC
  22086   "RTN","RCT CSPU",165, 0)
  22087    S DA=+Y
  22088   "RTN","RCT CSPU",166, 0)
  22089    S DR="1// //1" D ^DI E ; Reinst ated the 4  slashes
  22090   "RTN","RCT CSPU",167, 0)
  22091    Q
  22092   "RTN","RCT CSPU",168, 0)
  22093    ;
  22094   "RTN","RCT CSPU",169, 0)
  22095   INCADJ(RCB ILLDA,RCTR ANDA) ;inc rease adju stment tra nsaction h istory for  5b cross- servicing  record 315 /DRF
  22096   "RTN","RCT CSPU",170, 0)
  22097    ;rcbillda  - file 43 0 bill ien
  22098   "RTN","RCT CSPU",171, 0)
  22099    ;rctranda  - file 43 3 transact ion ien
  22100   "RTN","RCT CSPU",172, 0)
  22101    N DIC,DA, DIE,DR,Y,X
  22102   "RTN","RCT CSPU",173, 0)
  22103    I '$D(RCB ILLDA)!('$ D(RCTRANDA )) Q
  22104   "RTN","RCT CSPU",174, 0)
  22105    S X=RCTRA NDA
  22106   "RTN","RCT CSPU",175, 0)
  22107    S DIC="^P RCA(430,"_ RCBILLDA_" ,17,",DIC( 0)="L"
  22108   "RTN","RCT CSPU",176, 0)
  22109    I '$D(^PR CA(430,RCB ILLDA,17,0 )) S ^PRCA (430,RCBIL LDA,17,0)= "^430.0171 PA^0^0"
  22110   "RTN","RCT CSPU",177, 0)
  22111    S DIC("P" )=$P(^PRCA (430,RCBIL LDA,17,0), "^",2)
  22112   "RTN","RCT CSPU",178, 0)
  22113    S DA(1)=R CBILLDA
  22114   "RTN","RCT CSPU",179, 0)
  22115    D ^DIC I  Y=-1 K DIC ,DA Q
  22116   "RTN","RCT CSPU",180, 0)
  22117    S DIE=DIC  K DIC
  22118   "RTN","RCT CSPU",181, 0)
  22119    S DA=+Y
  22120   "RTN","RCT CSPU",182, 0)
  22121    S DR="1// //1" D ^DI E
  22122   "RTN","RCT CSPU",183, 0)
  22123    Q
  22124   "RTN","RCT CSPU",184, 0)
  22125    ;
  22126   "RTN","RCT CSPU",185, 0)
  22127   RCLLSETC ; Set Cross- Servicing  recall for  a case
  22128   "RTN","RCT CSPU",186, 0)
  22129    N DIC,DIE ,DA,DR,DIR ,Y,BILL,RE ASON
  22130   "RTN","RCT CSPU",187, 0)
  22131    S DIC=430 ,DIC(0)="A EQM" D ^DI C Q:Y<0
  22132   "RTN","RCT CSPU",188, 0)
  22133    S BILL=+Y
  22134   "RTN","RCT CSPU",189, 0)
  22135    I $P($G(^ PRCA(430,B ILL,15)),U ,11) G DEL SETC
  22136   "RTN","RCT CSPU",190, 0)
  22137    S DIR(0)= "Y",DIR("B ")="NO",DI R("A")="Ar e you sure  you want  to set thi s case to  be recalle d from Cro ss-Servici ng" D ^DIR
  22138   "RTN","RCT CSPU",191, 0)
  22139    I 'Y W !, *7,"No act ion taken"  Q
  22140   "RTN","RCT CSPU",192, 0)
  22141    I '$D(^PR CA(430,"TC SP",BILL))  W !,*7,"N o action t aken.  Cas e has not  been refer red to Cro ss-Servici ng." Q
  22142   "RTN","RCT CSPU",193, 0)
  22143    ; 
  22144   "RTN","RCT CSPU",194, 0)
  22145   RCRSC ;set  case reca ll reason
  22146   "RTN","RCT CSPU",195, 0)
  22147    ;set reca ll data in  file 430  for the bi ll and the  case
  22148   "RTN","RCT CSPU",196, 0)
  22149    S REASON= 15
  22150   "RTN","RCT CSPU",197, 0)
  22151    S $P(^PRC A(430,BILL ,15),U,11, 13)="1^^"_ REASON
  22152   "RTN","RCT CSPU",198, 0)
  22153    S $P(^PRC A(430,BILL ,15),U,2,4 )="1^^"_RE ASON
  22154   "RTN","RCT CSPU",199, 0)
  22155    ;
  22156   "RTN","RCT CSPU",200, 0)
  22157    D RCRSC^R CTCSPD4 ;  *315 CS CA SE RECALL  tx
  22158   "RTN","RCT CSPU",201, 0)
  22159    W !,"Sett ing this c ase for Re call from  Cross-Serv icing is c omplete"
  22160   "RTN","RCT CSPU",202, 0)
  22161    G SETCQ
  22162   "RTN","RCT CSPU",203, 0)
  22163    ;
  22164   "RTN","RCT CSPU",204, 0)
  22165   DELSETC ;A llows Cros s-Servicin g Recall t o be delet ed for cas e
  22166   "RTN","RCT CSPU",205, 0)
  22167    W !!,*7," This case  has alread y been set  for recal l from Cro ss-Servici ng."
  22168   "RTN","RCT CSPU",206, 0)
  22169    S DIR(0)= "Y",DIR("A ")="Do you  wish to d elete the  Cross-Serv icing Reca ll for thi s case",DI R("B")="NO " D ^DIR G  SETCQ:'Y
  22170   "RTN","RCT CSPU",207, 0)
  22171    ;
  22172   "RTN","RCT CSPU",208, 0)
  22173    ;delete t he case re call
  22174   "RTN","RCT CSPU",209, 0)
  22175    F I=11:1: 13 S $P(^P RCA(430,BI LL,15),U,I )=""
  22176   "RTN","RCT CSPU",210, 0)
  22177    F I=2:1:5  S $P(^PRC A(430,BILL ,15),U,I)= ""
  22178   "RTN","RCT CSPU",211, 0)
  22179    D DELSETC ^RCTCSPD4  ; *315 Cre ate CS Del ete Case R ecall comm ent tx in  433 
  22180   "RTN","RCT CSPU",212, 0)
  22181    W !!,"Rec all from C ross-Servi cing has b een delete d for this  case."
  22182   "RTN","RCT CSPU",213, 0)
  22183    G SETCQ
  22184   "RTN","RCT CSPU",214, 0)
  22185    ;
  22186   "RTN","RCT CSPU",215, 0)
  22187   SETCQ Q
  22188   "RTN","RCT CSPU",216, 0)
  22189    ;
  22190   "RTN","RCT CSPU",217, 0)
  22191   SSN(DEBT)  ;Get SSN f or debtor
  22192   "RTN","RCT CSPU",218, 0)
  22193    ;Input De btor (340)
  22194   "RTN","RCT CSPU",219, 0)
  22195    ;Output:  SSN # or n ull
  22196   "RTN","RCT CSPU",220, 0)
  22197    NEW Y
  22198   "RTN","RCT CSPU",221, 0)
  22199    S Y=-1 G: '$G(DEBT)  Q1
  22200   "RTN","RCT CSPU",222, 0)
  22201    S:DEBT?1N .N DEBT=$P ($G(^RCD(3 40,DEBT,0) ),"^")
  22202   "RTN","RCT CSPU",223, 0)
  22203    I DEBT["; DPT(" S Y= $P($G(^DPT (+DEBT,0)) ,"^",9)
  22204   "RTN","RCT CSPU",224, 0)
  22205    I DEBT["; VA(200," S  Y=$P($G(^ VA(200,+DE BT,1)),"^" ,9)
  22206   "RTN","RCT CSPU",225, 0)
  22207   Q1 Q Y
  22208   "RTN","RCT CSPU",226, 0)
  22209    ;
  22210   "RTN","RCT CSPU",227, 0)
  22211    Q
  22212   "RTN","RCT CSWL")
  22213   0^27^B1570 58726^n/a
  22214   "RTN","RCT CSWL",1,0)
  22215   RCTCSWL ;A LB/PAW-Cro ss Servici ng Worklis t ;30-SEP- 2015
  22216   "RTN","RCT CSWL",2,0)
  22217    ;;4.5;ACC OUNTS RECE IVABLE;**3 15**;Mar 2 0, 1995;Bu ild 55
  22218   "RTN","RCT CSWL",3,0)
  22219    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  22220   "RTN","RCT CSWL",4,0)
  22221    ;
  22222   "RTN","RCT CSWL",5,0)
  22223    ; Call to  EN^DGRPD  supported  by DBIA# 1 0037
  22224   "RTN","RCT CSWL",6,0)
  22225    ; Call to  EN1AR^IBE CEA suppor ted by DBI A# 4047
  22226   "RTN","RCT CSWL",7,0)
  22227    ;
  22228   "RTN","RCT CSWL",8,0)
  22229   EN ; -- Ma in entry p oint for R CTCSP RECO NCILIATION  WORKLIST
  22230   "RTN","RCT CSWL",9,0)
  22231    N FILTERS ,RCRPT,RCD IVS,RCBEG, RCEND,DAT, RCSC1,RCSC 2,DIV,RCDP FXIT,RCRSN ,RCRPTX,RC IENS,RCDIV
  22232   "RTN","RCT CSWL",10,0 )
  22233    I '$$FILT ER(.FILTER S) Q
  22234   "RTN","RCT CSWL",11,0 )
  22235    S RCRPT=$ P($G(FILTE RS(0)),U,1 )
  22236   "RTN","RCT CSWL",12,0 )
  22237    K XQORS,V ALMEVL
  22238   "RTN","RCT CSWL",13,0 )
  22239    D EN^VALM ("RCTCSP W ORKLIST")   ;Looks at  List Temp late RCTCS P WORKLIST
  22240   "RTN","RCT CSWL",14,0 )
  22241    Q
  22242   "RTN","RCT CSWL",15,0 )
  22243    ;
  22244   "RTN","RCT CSWL",16,0 )
  22245   INIT ; Ini tialize va riables
  22246   "RTN","RCT CSWL",17,0 )
  22247    D KILLGLB
  22248   "RTN","RCT CSWL",18,0 )
  22249    S RCRPT=$ P(FILTERS( 0),U,1)
  22250   "RTN","RCT CSWL",19,0 )
  22251    ;
  22252   "RTN","RCT CSWL",20,0 )
  22253    I RCRPT[" ," F RCRSN =1:1 S RCR PTX=$P(RCR PT,",",RCR SN) Q:RCRP TX=""  D G ETRPT^RCTC SWL1(RCRPT X)
  22254   "RTN","RCT CSWL",21,0 )
  22255    I RCRPT'[ "," D GETR PT^RCTCSWL 1(RCRPT)
  22256   "RTN","RCT CSWL",22,0 )
  22257    I '$D(^TM P("RCTCSWL ",$J)) D   Q
  22258   "RTN","RCT CSWL",23,0 )
  22259    .W !!,*7, "The repor t found no  patient d ata that m eets the c riteria se lected.",!
  22260   "RTN","RCT CSWL",24,0 )
  22261    .S DIR(0) ="E"
  22262   "RTN","RCT CSWL",25,0 )
  22263    .D ^DIR
  22264   "RTN","RCT CSWL",26,0 )
  22265    .S VALMQU IT=1
  22266   "RTN","RCT CSWL",27,0 )
  22267    .D EXIT
  22268   "RTN","RCT CSWL",28,0 )
  22269    ; If Exce l Selected
  22270   "RTN","RCT CSWL",29,0 )
  22271    I EXCEL D   Q
  22272   "RTN","RCT CSWL",30,0 )
  22273    .D EXCEL^ RCTCSWL1
  22274   "RTN","RCT CSWL",31,0 )
  22275    .S DIR(0) ="E"
  22276   "RTN","RCT CSWL",32,0 )
  22277    .D ^DIR
  22278   "RTN","RCT CSWL",33,0 )
  22279    .S VALMQU IT=1
  22280   "RTN","RCT CSWL",34,0 )
  22281    .D EXIT
  22282   "RTN","RCT CSWL",35,0 )
  22283    ; If List  Manager S elected
  22284   "RTN","RCT CSWL",36,0 )
  22285    I 'EXCEL  D BLDWL^RC TCSWL1
  22286   "RTN","RCT CSWL",37,0 )
  22287    Q
  22288   "RTN","RCT CSWL",38,0 )
  22289    ;
  22290   "RTN","RCT CSWL",39,0 )
  22291   HDR ; Set  header for  CS Workli st
  22292   "RTN","RCT CSWL",40,0 )
  22293    N RCDIVS, RCX
  22294   "RTN","RCT CSWL",41,0 )
  22295    I SORTBY= 2 S VALMCA P="    Bil l No.      Pt ID  Pat ient                     Balance   Ret Rsn        "
  22296   "RTN","RCT CSWL",42,0 )
  22297    I SORTBY= 3 S VALMCA P="    Ret  Rsn Bill  No.     Pt  ID  Patie nt                      Balance        "
  22298   "RTN","RCT CSWL",43,0 )
  22299    S RCX=$P( FILTERS(0) ,U,1)  ;Re port
  22300   "RTN","RCT CSWL",44,0 )
  22301    S VALMHDR (1)=$S(RCX =1:"Bankru ptcy",RCX= 2:"Deaths" ,RCX=3:"Un collectibl e",RCX=4:" Paymt. in  Full",RCX= 5:"Satisfi ed PA",RCX =6:"Compro mise",RCX= 7:"All Ret urns",1:"" )
  22302   "RTN","RCT CSWL",45,0 )
  22303    D
  22304   "RTN","RCT CSWL",46,0 )
  22305    . I RCX[7  S VALMHDR (1)="Recon ciliation  "_VALMHDR( 1)_" Repor t" Q
  22306   "RTN","RCT CSWL",47,0 )
  22307    . ;I RCX' [7 S VALMH DR(1)="Rec onciliatio n Reports  Selected:  "_$P(RCX," ,",$TR(1," Bankruptcy "))_", "_$ TR(2,"Deat hs")_", "_ $TR(3,"Unc ollectible ")_", "_$T R(4,"Payme nt in Full ")_", "_$T R(5,"Satis fied PA")_ ", "_$TR(6 ,"Compromi se")
  22308   "RTN","RCT CSWL",48,0 )
  22309    . N X S X ="" F I=1: 1:6 I RCX[ I S X=X_$S (X="":"",1 :", "),X=X _$S(I=1:"B ankruptcy" ,I=2:"Deat hs",I=3:"U ncollectbl .",I=4:"Pm t. In Full ",I=5:"Sat isfied PA" ,I=6:"Comp romise",1: "")
  22310   "RTN","RCT CSWL",49,0 )
  22311    . S VALMH DR(1)="Typ es: "_X
  22312   "RTN","RCT CSWL",50,0 )
  22313    . W !,VAL MHDR(1)
  22314   "RTN","RCT CSWL",51,0 )
  22315    ;S VALMHD R(1)=$S(RC X=1:"Bankr uptcy",RCX =2:"Deaths ",RCX=3:"U ncollectib le",RCX=4: "Paymt. in  Full",RCX =5:"Satisf ied PA",RC X=6:"Compr omise",RCX =7:"All Re turns",1:" ")
  22316   "RTN","RCT CSWL",52,0 )
  22317    ;I RCX[7  S VALMHDR( 1)="Reconc iliation " _VALMHDR(1 )_" Report "
  22318   "RTN","RCT CSWL",53,0 )
  22319    ;I RCX'[7  S VALMHDR (1)="Recon ciliation  Reports Se lected: "_ $P(RCX,"," ,$TR(1,"Ba nkruptcy") )_", "_$TR (2,"Deaths ")_", "_$T R(3,"Uncol lectible") _", "_$TR( 4,"Payment  in Full") _", "_$TR( 5,"Satisfi ed PA")_",  "_$TR(6," Compromise ")
  22320   "RTN","RCT CSWL",54,0 )
  22321    S VALMHDR (2)="Selec ted Divisi on(s): "
  22322   "RTN","RCT CSWL",55,0 )
  22323    I VAUTD=1  S VALMHDR (2)=VALMHD R(2)_"ALL"
  22324   "RTN","RCT CSWL",56,0 )
  22325    I VAUTD=0  D
  22326   "RTN","RCT CSWL",57,0 )
  22327    .S RCY=0  F  S RCY=$ O(VAUTD(RC Y)) Q:RCY= ""  D 
  22328   "RTN","RCT CSWL",58,0 )
  22329    ..S VALMH DR(2)=VALM HDR(2)_RCY _" "
  22330   "RTN","RCT CSWL",59,0 )
  22331    Q
  22332   "RTN","RCT CSWL",60,0 )
  22333    ;
  22334   "RTN","RCT CSWL",61,0 )
  22335   FILTER(FIL TERS) ; Se t filters
  22336   "RTN","RCT CSWL",62,0 )
  22337    ; Sets an  array of  filters to  determine  which ent ries to in clude in d isplay
  22338   "RTN","RCT CSWL",63,0 )
  22339    ; Input:    None
  22340   "RTN","RCT CSWL",64,0 )
  22341    ; Output:   
  22342   "RTN","RCT CSWL",65,0 )
  22343    ; Returns : 0 if the  user ente red '^' or  timed out , 1 otherw ise
  22344   "RTN","RCT CSWL",66,0 )
  22345    ; FILTERS (0) = Piec e 1 = 1=Ba nkruptcy,2 =Deaths,3= Uncollecta ble,4=Paym ent in Ful l,5=Satisf ied PA,6=C ompromise, 7=All Retu rns
  22346   "RTN","RCT CSWL",67,0 )
  22347    ;               Piec e 3 = All  (0) or Sel ect (1) Pa tients
  22348   "RTN","RCT CSWL",68,0 )
  22349    ;
  22350   "RTN","RCT CSWL",69,0 )
  22351    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,RCXX,X,X X,RCRRC,Y
  22352   "RTN","RCT CSWL",70,0 )
  22353    K FILTERS
  22354   "RTN","RCT CSWL",71,0 )
  22355    ;
  22356   "RTN","RCT CSWL",72,0 )
  22357    ; Select  type of re port
  22358   "RTN","RCT CSWL",73,0 )
  22359    W !,"Plea se Select  Type of Re port"
  22360   "RTN","RCT CSWL",74,0 )
  22361    W !!?11," 1        B ankruptcy"
  22362   "RTN","RCT CSWL",75,0 )
  22363    W !?11,"2         De aths"
  22364   "RTN","RCT CSWL",76,0 )
  22365    W !?11,"3         Un collectibl e"
  22366   "RTN","RCT CSWL",77,0 )
  22367    W !?11,"4         Pa yment in F ull"
  22368   "RTN","RCT CSWL",78,0 )
  22369    W !?11,"5         Sa tisfied PA "
  22370   "RTN","RCT CSWL",79,0 )
  22371    W !?11,"6         Co mpromise"
  22372   "RTN","RCT CSWL",80,0 )
  22373    W !?11,"7         Al l Returns"
  22374   "RTN","RCT CSWL",81,0 )
  22375    W !
  22376   "RTN","RCT CSWL",82,0 )
  22377    S DIR(0)= "L^1:7"
  22378   "RTN","RCT CSWL",83,0 )
  22379    W ! D ^DI R K DIR
  22380   "RTN","RCT CSWL",84,0 )
  22381    I $G(DIRU T) Q 0
  22382   "RTN","RCT CSWL",85,0 )
  22383    S X=$$UP^ XLFSTR(X)
  22384   "RTN","RCT CSWL",86,0 )
  22385    S $P(FILT ERS(0),U)= Y
  22386   "RTN","RCT CSWL",87,0 )
  22387    I Y[7 S $ P(FILTERS( 0),U)=$P(Y ,",")
  22388   "RTN","RCT CSWL",88,0 )
  22389    I Y'[7 S  $P(FILTERS (0),U)=Y
  22390   "RTN","RCT CSWL",89,0 )
  22391    ;
  22392   "RTN","RCT CSWL",90,0 )
  22393    ; Site (D ivision) F ilter - Us es MEDICAL  CENTER DI VISION fil e
  22394   "RTN","RCT CSWL",91,0 )
  22395    S DIR(0)= "S",DIR("A ")="Select (A)ll or ( S)elected  Division(s ) ",DIR("B ")="All"
  22396   "RTN","RCT CSWL",92,0 )
  22397    S DIR("?" ,1)="Enter  'A' to no t filter b y Division ."
  22398   "RTN","RCT CSWL",93,0 )
  22399    S DIR("?" )="Enter ' S' to view  entries f or selecte d Division (s)."
  22400   "RTN","RCT CSWL",94,0 )
  22401    S $P(DIR( 0),U,2)="A :All Divis ions;S:Sel ected Divi sions"
  22402   "RTN","RCT CSWL",95,0 )
  22403    W ! D ^DI R K DIR
  22404   "RTN","RCT CSWL",96,0 )
  22405    I $G(DIRU T)!($G(DUO UT)) W !!, *7,"No Div ision(s) s elected.   Quitting." ,! D ^DIR  Q 0
  22406   "RTN","RCT CSWL",97,0 )
  22407    S X=$$UP^ XLFSTR(X)
  22408   "RTN","RCT CSWL",98,0 )
  22409    S $P(FILT ERS(0),U,3 )=$S(Y="S" :1,1:0) S  VAUTD=$S(Y ="A":1,1:0 )
  22410   "RTN","RCT CSWL",99,0 )
  22411    ; Set Div ision filt er
  22412   "RTN","RCT CSWL",100, 0)
  22413    I $G(VAUT D)=1 S $P( FILTERS(0) ,U,3)=0,RC DIVS="All"
  22414   "RTN","RCT CSWL",101, 0)
  22415    I $P(FILT ERS(0),U,3 )=1 D
  22416   "RTN","RCT CSWL",102, 0)
  22417    .D ASKDIV (.FILTERS)
  22418   "RTN","RCT CSWL",103, 0)
  22419    ;
  22420   "RTN","RCT CSWL",104, 0)
  22421    I 'FILTER S(0) Q 0
  22422   "RTN","RCT CSWL",105, 0)
  22423    ;
  22424   "RTN","RCT CSWL",106, 0)
  22425    S SORTBY= 1
  22426   "RTN","RCT CSWL",107, 0)
  22427    ; 
  22428   "RTN","RCT CSWL",108, 0)
  22429    ; Display  Selection  Criteria  to Screen
  22430   "RTN","RCT CSWL",109, 0)
  22431    D SHOWFIL T(.FILTERS )
  22432   "RTN","RCT CSWL",110, 0)
  22433    ;
  22434   "RTN","RCT CSWL",111, 0)
  22435    ; Excel o r List Man ager
  22436   "RTN","RCT CSWL",112, 0)
  22437    S DIR(0)= "S^1:List  Manager;2: Excel Form at",DIR("A ")="List M anager or  Excel Form at",DIR("B ")=1
  22438   "RTN","RCT CSWL",113, 0)
  22439    S DIR("?" ,1)="Enter  1 to sele ct List Ma nager."
  22440   "RTN","RCT CSWL",114, 0)
  22441    S DIR("?" )="Enter 2  to select  Excel For mat."
  22442   "RTN","RCT CSWL",115, 0)
  22443    W ! D ^DI R K DIR
  22444   "RTN","RCT CSWL",116, 0)
  22445    I $G(DIRU T) Q 0
  22446   "RTN","RCT CSWL",117, 0)
  22447    S X=$$UP^ XLFSTR(X)
  22448   "RTN","RCT CSWL",118, 0)
  22449    S EXCEL=$ S(Y=1:0,1: 1)
  22450   "RTN","RCT CSWL",119, 0)
  22451    S STOP=0
  22452   "RTN","RCT CSWL",120, 0)
  22453    I EXCEL=1  D
  22454   "RTN","RCT CSWL",121, 0)
  22455    .D EXCMSG ^RCTCSJR ;  Display E xcel displ ay message
  22456   "RTN","RCT CSWL",122, 0)
  22457    .S %ZIS=" AEQ" D ^%Z IS I POP S  STOP=1
  22458   "RTN","RCT CSWL",123, 0)
  22459    I STOP Q  0
  22460   "RTN","RCT CSWL",124, 0)
  22461    ;
  22462   "RTN","RCT CSWL",125, 0)
  22463    Q 1
  22464   "RTN","RCT CSWL",126, 0)
  22465    ;
  22466   "RTN","RCT CSWL",127, 0)
  22467   SHOWFILT(F ILTERS) ;  Display
  22468   "RTN","RCT CSWL",128, 0)
  22469    ; Display s the curr ently sele cted filte r selectio ns for the
  22470   "RTN","RCT CSWL",129, 0)
  22471    ; Billing  and NVC P recert Wor klist disp lay
  22472   "RTN","RCT CSWL",130, 0)
  22473    ; Input:    FILTERS( )   - Arra y of filte r settings . See FILT ERS for a  detailed
  22474   "RTN","RCT CSWL",131, 0)
  22475    ;                 ex planation  of the FIL TERS array
  22476   "RTN","RCT CSWL",132, 0)
  22477    ; Output:   Current  Filter set tings are  displayed
  22478   "RTN","RCT CSWL",133, 0)
  22479    ;
  22480   "RTN","RCT CSWL",134, 0)
  22481    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,IEN,LEN, RCXX,RCY,R CZ,RCYY
  22482   "RTN","RCT CSWL",135, 0)
  22483    W !!!,"Ty pe of Repo rt: "
  22484   "RTN","RCT CSWL",136, 0)
  22485    S RCRPT=$ P(FILTERS( 0),U,1)
  22486   "RTN","RCT CSWL",137, 0)
  22487    W $S(RCRP T[99:"All  Returns",1 :"Selected ")
  22488   "RTN","RCT CSWL",138, 0)
  22489    ;
  22490   "RTN","RCT CSWL",139, 0)
  22491    W !,"Show  All or Se lected Div isions: "
  22492   "RTN","RCT CSWL",140, 0)
  22493    W $S($G(V AUTD)=0:"S elected",1 :"All")
  22494   "RTN","RCT CSWL",141, 0)
  22495    ;
  22496   "RTN","RCT CSWL",142, 0)
  22497    W !,"All  Patients"    ; or Sel ected Pati ents: "
  22498   "RTN","RCT CSWL",143, 0)
  22499    K DIR
  22500   "RTN","RCT CSWL",144, 0)
  22501    Q
  22502   "RTN","RCT CSWL",145, 0)
  22503    ;
  22504   "RTN","RCT CSWL",146, 0)
  22505   ASKDIV(FIL TERS) ; Se ts a list  of Divisio ns to be d isplayed i n the Reco nciliation  Worklist
  22506   "RTN","RCT CSWL",147, 0)
  22507    ; Input:  FILTERS -  Current Ar ray of fil ter settin gs
  22508   "RTN","RCT CSWL",148, 0)
  22509    ; Output:  FILTERS -  Updated A rray of fi lter setti ngs
  22510   "RTN","RCT CSWL",149, 0)
  22511    N DIC,DIR ,DIVS,FIRS T,IBIENS,I BIENS2,IEN ,N,X,XX,Y
  22512   "RTN","RCT CSWL",150, 0)
  22513    S DIC=40. 8,DIC(0)=" AEM",FIRST =1
  22514   "RTN","RCT CSWL",151, 0)
  22515    F  D  Q:+ IEN<1
  22516   "RTN","RCT CSWL",152, 0)
  22517    . D ONEDI V(.DIC,.IE N,.FIRST)  ; One Divi sion promp t
  22518   "RTN","RCT CSWL",153, 0)
  22519    . Q:+IEN< 1
  22520   "RTN","RCT CSWL",154, 0)
  22521    . S IBIEN S($P(IEN,U ,2))=$P(IE N,U,1)
  22522   "RTN","RCT CSWL",155, 0)
  22523    . S IBIEN S2($P(IEN, U,1))=$P(I EN,U,2)
  22524   "RTN","RCT CSWL",156, 0)
  22525    . S DIV=$ P(IEN,U)
  22526   "RTN","RCT CSWL",157, 0)
  22527    . S RCDIV =$$GET1^DI Q(40.8,DIV _",",1,"E" )
  22528   "RTN","RCT CSWL",158, 0)
  22529    . S VAUTD (RCDIV)=RC DIV
  22530   "RTN","RCT CSWL",159, 0)
  22531    I ($G(DUO UT))!('$D( IBIENS)) D  ^DIR S FI LTERS(0)=0  Q 0
  22532   "RTN","RCT CSWL",160, 0)
  22533    I '$D(IBI ENS) S $P( FILTERS(0) ,U,3)=0
  22534   "RTN","RCT CSWL",161, 0)
  22535    ;
  22536   "RTN","RCT CSWL",162, 0)
  22537    ; Set the  filter no de respons es in alph abetical o rder
  22538   "RTN","RCT CSWL",163, 0)
  22539    S XX=""
  22540   "RTN","RCT CSWL",164, 0)
  22541    F  D  Q:X X=""
  22542   "RTN","RCT CSWL",165, 0)
  22543    . S XX=$O (IBIENS(XX ))
  22544   "RTN","RCT CSWL",166, 0)
  22545    . Q:XX=""
  22546   "RTN","RCT CSWL",167, 0)
  22547    . S N=IBI ENS(XX)
  22548   "RTN","RCT CSWL",168, 0)
  22549    . S FILTE RS(1,N)=""
  22550   "RTN","RCT CSWL",169, 0)
  22551    . D CHKFI LT
  22552   "RTN","RCT CSWL",170, 0)
  22553    Q
  22554   "RTN","RCT CSWL",171, 0)
  22555    ;
  22556   "RTN","RCT CSWL",172, 0)
  22557   ONEDIV(DIC ,IEN,FIRST ) ; Prompt s the user  for a Div ision
  22558   "RTN","RCT CSWL",173, 0)
  22559    ; Input:  DIC - Vari able/Array  of settin gs needed  for ^DIC c all
  22560   "RTN","RCT CSWL",174, 0)
  22561    ; FIRST -  Set to 1  initially  and then 0  for subse quent call s
  22562   "RTN","RCT CSWL",175, 0)
  22563    ; Output:  FIRST - S et to 0
  22564   "RTN","RCT CSWL",176, 0)
  22565    ; IEN - I EN of the  selected D ivision
  22566   "RTN","RCT CSWL",177, 0)
  22567    ; null if  no select ion was ma de
  22568   "RTN","RCT CSWL",178, 0)
  22569    S DIC("A" )=$S(FIRST :"Select a  Division:  ",1:"Sele ct Another  Division:  ")
  22570   "RTN","RCT CSWL",179, 0)
  22571    D ^DIC
  22572   "RTN","RCT CSWL",180, 0)
  22573    I FIRST,X ="" W !!,* 7,"Divisio n entry is  required! ",! D ONED IV(.DIC,.I EN,.FIRST)
  22574   "RTN","RCT CSWL",181, 0)
  22575    I $G(DUOU T) W !!,*7 ,"User exi ted the op tion with  '^',quitti ng.",! S I EN=Y,FILTE RS(0)=0 Q  0
  22576   "RTN","RCT CSWL",182, 0)
  22577    S FIRST=0 ,IEN=Y_U_X
  22578   "RTN","RCT CSWL",183, 0)
  22579    Q
  22580   "RTN","RCT CSWL",184, 0)
  22581    ;
  22582   "RTN","RCT CSWL",185, 0)
  22583   EXPAND ; A CTION - Ex pand Patie nt (EP)
  22584   "RTN","RCT CSWL",186, 0)
  22585    D FULL^VA LM1
  22586   "RTN","RCT CSWL",187, 0)
  22587    N I,J,RCB ILL,RCBILL EX,RCDFN,R CNAME,RCPT ID,RCXX,VA LMY,ECNT
  22588   "RTN","RCT CSWL",188, 0)
  22589    D EN^VALM 2($G(XQORN OD(0)))
  22590   "RTN","RCT CSWL",189, 0)
  22591    I $D(VALM Y) S RCXX= 0 F  S RCX X=$O(VALMY (RCXX)) Q: 'RCXX  D
  22592   "RTN","RCT CSWL",190, 0)
  22593    .K ^TMP(" RCTCSWE",$ J)
  22594   "RTN","RCT CSWL",191, 0)
  22595    .S ECNT=$ G(^TMP("RC TCSWLX",$J ,RCXX))
  22596   "RTN","RCT CSWL",192, 0)
  22597    .S RCDFN= $P(ECNT,U, 1),RCNAME= $P(ECNT,U, 2),RCPTID= $P(ECNT,U, 3),RCBILL= $P(ECNT,U, 5),RCBILLE X=$P(ECNT, U,6)
  22598   "RTN","RCT CSWL",193, 0)
  22599    .S ^TMP(" RCTCSWE",$ J)=RCDFN_U _RCNAME_U_ RCPTID_U_R CBILL_U_RC BILLEX
  22600   "RTN","RCT CSWL",194, 0)
  22601    .D EN^VAL M("RCTCSP  WORKLIST E XPAND")
  22602   "RTN","RCT CSWL",195, 0)
  22603    .Q
  22604   "RTN","RCT CSWL",196, 0)
  22605    K ^TMP("R CTCSWE",$J )
  22606   "RTN","RCT CSWL",197, 0)
  22607    S VALMBCK ="R"
  22608   "RTN","RCT CSWL",198, 0)
  22609    Q
  22610   "RTN","RCT CSWL",199, 0)
  22611    ;  
  22612   "RTN","RCT CSWL",200, 0)
  22613   LINKI ; AC TION - Vie w Patient  Insurance  (VI)
  22614   "RTN","RCT CSWL",201, 0)
  22615    D FULL^VA LM1
  22616   "RTN","RCT CSWL",202, 0)
  22617    N I,J,DFN ,RCXX,VALM Y,ECNT,GOT PAT,REC
  22618   "RTN","RCT CSWL",203, 0)
  22619    D EN^VALM 2($G(XQORN OD(0)))
  22620   "RTN","RCT CSWL",204, 0)
  22621    I $D(VALM Y) S RCXX= 0 F  S RCX X=$O(VALMY (RCXX)) Q: 'RCXX  D
  22622   "RTN","RCT CSWL",205, 0)
  22623    .S (ECNT, REC)=$G(^T MP("RCTCSW LX",$J,RCX X))
  22624   "RTN","RCT CSWL",206, 0)
  22625    .S DFN=$P (ECNT,U,1)   ;Need DF N for VI
  22626   "RTN","RCT CSWL",207, 0)
  22627    .I DFN=""  W !!,"Deb tor is not  a VA Pati ent" D WAI T^VALM1 Q
  22628   "RTN","RCT CSWL",208, 0)
  22629    .S ^TMP($ J,"PATINS" )=$P(REC,U ,1),GOTPAT =1
  22630   "RTN","RCT CSWL",209, 0)
  22631    .D EN^VAL M("IBCNS V IEW PAT IN S")
  22632   "RTN","RCT CSWL",210, 0)
  22633    S VALMBCK ="R"
  22634   "RTN","RCT CSWL",211, 0)
  22635    Q
  22636   "RTN","RCT CSWL",212, 0)
  22637    ;
  22638   "RTN","RCT CSWL",213, 0)
  22639   ACCTPR ; A CTION - Ac count Prof ile (AP)
  22640   "RTN","RCT CSWL",214, 0)
  22641    D FULL^VA LM1
  22642   "RTN","RCT CSWL",215, 0)
  22643    N I,J,DFN ,RCXX,VALM Y,ECNT,REC ,RCDEBTDA
  22644   "RTN","RCT CSWL",216, 0)
  22645    D EN^VALM 2($G(XQORN OD(0)))
  22646   "RTN","RCT CSWL",217, 0)
  22647    I $D(VALM Y) S RCXX= 0 F  S RCX X=$O(VALMY (RCXX)) Q: 'RCXX  D   Q:$G(RCDPF XIT)     ;  also get  out of loo p upon fas t exit
  22648   "RTN","RCT CSWL",218, 0)
  22649    . S (ECNT ,REC)=$G(^ TMP("RCTCS WLX",$J,RC XX))
  22650   "RTN","RCT CSWL",219, 0)
  22651    . S RCDEB TDA=$P(ECN T,U,4)  ;N eed DEBTOR  for AP
  22652   "RTN","RCT CSWL",220, 0)
  22653    . D EN^VA LM("PRCA T CSP ACCOUN T PROFILE" )
  22654   "RTN","RCT CSWL",221, 0)
  22655    . Q
  22656   "RTN","RCT CSWL",222, 0)
  22657    S VALMBCK ="R"
  22658   "RTN","RCT CSWL",223, 0)
  22659    I $G(RCDP FXIT) S VA LMBCK="Q"     ; user  wants to e xit entire ly
  22660   "RTN","RCT CSWL",224, 0)
  22661    Q
  22662   "RTN","RCT CSWL",225, 0)
  22663    ;
  22664   "RTN","RCT CSWL",226, 0)
  22665   PTVW ; ACT ION - View  Patient ( PT)
  22666   "RTN","RCT CSWL",227, 0)
  22667    D FULL^VA LM1
  22668   "RTN","RCT CSWL",228, 0)
  22669    N I,J,DFN ,RCXX,VALM Y,ECNT,GOT PAT,REC
  22670   "RTN","RCT CSWL",229, 0)
  22671    D EN^VALM 2($G(XQORN OD(0)))
  22672   "RTN","RCT CSWL",230, 0)
  22673    I $D(VALM Y) S RCXX= 0 F  S RCX X=$O(VALMY (RCXX)) Q: 'RCXX  D
  22674   "RTN","RCT CSWL",231, 0)
  22675    .S (ECNT, REC)=$G(^T MP("RCTCSW LX",$J,RCX X))
  22676   "RTN","RCT CSWL",232, 0)
  22677    .S DFN=$P (ECNT,U,1)   ;Need DF N for PT
  22678   "RTN","RCT CSWL",233, 0)
  22679    .I DFN=""  W !!,"Deb tor is not  a VA Pati ent." D WA IT^VALM1 Q
  22680   "RTN","RCT CSWL",234, 0)
  22681    .D EN^DGR PD          ; DBIA# 1 0037
  22682   "RTN","RCT CSWL",235, 0)
  22683    S VALMBCK ="R"
  22684   "RTN","RCT CSWL",236, 0)
  22685    Q
  22686   "RTN","RCT CSWL",237, 0)
  22687    ;
  22688   "RTN","RCT CSWL",238, 0)
  22689   CEA ; ACTI ON - CANCE L EDIT ADD  (CN)
  22690   "RTN","RCT CSWL",239, 0)
  22691    N DFN,RCD EBTDA,GOTP AT
  22692   "RTN","RCT CSWL",240, 0)
  22693    D FULL^VA LM1
  22694   "RTN","RCT CSWL",241, 0)
  22695    I '$D(ECN T) G CEAX     ; ECNT  is set by  the ACCTPR  - Account  Profile a ction prot ocol code  and must b e defined
  22696   "RTN","RCT CSWL",242, 0)
  22697    ;
  22698   "RTN","RCT CSWL",243, 0)
  22699    S DFN=+$P (ECNT,U,1)             ; patient  ien
  22700   "RTN","RCT CSWL",244, 0)
  22701    S RCDEBTD A=+$P(ECNT ,U,4)       ; AR debt or ien
  22702   "RTN","RCT CSWL",245, 0)
  22703    ;
  22704   "RTN","RCT CSWL",246, 0)
  22705    ; check o n security  key - sam e one used  in the IB  option IB  CANCEL/ED IT/ADD CHA RGES
  22706   "RTN","RCT CSWL",247, 0)
  22707    I '$D(^XU SEC("IB AU THORIZE",D UZ)) D  G  CEAX
  22708   "RTN","RCT CSWL",248, 0)
  22709    . W *7,!! ?3,"You mu st hold th e IB AUTHO RIZE secur ity key in  order to  access thi s option." ,!
  22710   "RTN","RCT CSWL",249, 0)
  22711    . D WAIT^ VALM1
  22712   "RTN","RCT CSWL",250, 0)
  22713    . Q
  22714   "RTN","RCT CSWL",251, 0)
  22715    ;
  22716   "RTN","RCT CSWL",252, 0)
  22717    ; check t o make sur e we have  a DFN here .  Debtor  may not be  a patient
  22718   "RTN","RCT CSWL",253, 0)
  22719    I 'DFN D   G CEAX
  22720   "RTN","RCT CSWL",254, 0)
  22721    . N DP,DE BTTYP
  22722   "RTN","RCT CSWL",255, 0)
  22723    . S DP=$P ($G(^RCD(3 40,RCDEBTD A,0)),U,1)
  22724   "RTN","RCT CSWL",256, 0)
  22725    . S DEBTT YP=$S(DP[" VA(200":"a  VistA use r",DP["DIC (36":"a 3r d party pa yer",DP["D IC(4":"a V A institut ion",DP["P RC(440":"a n IFCAP ve ndor",1:"U NKNOWN!?")
  22726   "RTN","RCT CSWL",257, 0)
  22727    . W *7,!! ?3,"The AR  Debtor mu st be a pa tient for  this actio n."
  22728   "RTN","RCT CSWL",258, 0)
  22729    . W !?3," For this a ccount, th e AR Debto r is ",DEB TTYP,".",!
  22730   "RTN","RCT CSWL",259, 0)
  22731    . D WAIT^ VALM1
  22732   "RTN","RCT CSWL",260, 0)
  22733    . Q
  22734   "RTN","RCT CSWL",261, 0)
  22735    ;
  22736   "RTN","RCT CSWL",262, 0)
  22737    ; new a b unch of va riables le ft hanging  around af ter this c all
  22738   "RTN","RCT CSWL",263, 0)
  22739    N %X,%Y,C ,D,DA,DESC ,DI,DIC,DI CR,DIE,DIG ,DIH,DILN, DIU,DIV,DI W,DQ,DR,EN T,FMSNUM1, IBAFY,IBAT YPN,IBSTAR 80,PRCA,RC REF
  22740   "RTN","RCT CSWL",264, 0)
  22741    N RCVXCTY ,RCXQFL,RC XVBDT,RCXV BST,RCXVDA ,X,Y
  22742   "RTN","RCT CSWL",265, 0)
  22743    S GOTPAT= 1
  22744   "RTN","RCT CSWL",266, 0)
  22745    W !
  22746   "RTN","RCT CSWL",267, 0)
  22747    D EN1AR^I BECEA       ; DBIA 40 47
  22748   "RTN","RCT CSWL",268, 0)
  22749    D INIT^RC DPAPLM      ; refresh  account p rofile dat a
  22750   "RTN","RCT CSWL",269, 0)
  22751   CEAX ;
  22752   "RTN","RCT CSWL",270, 0)
  22753    S VALMBCK ="R"
  22754   "RTN","RCT CSWL",271, 0)
  22755    Q
  22756   "RTN","RCT CSWL",272, 0)
  22757    ;
  22758   "RTN","RCT CSWL",273, 0)
  22759   PRTSTAT ;  ACTION - P RINT A PAY MENT STATE MENT (PR)
  22760   "RTN","RCT CSWL",274, 0)
  22761    D FULL^VA LM1
  22762   "RTN","RCT CSWL",275, 0)
  22763    N I,J,DFN ,RCXX,VALM Y,ECNT,GOT BILL,REC,P RCABN
  22764   "RTN","RCT CSWL",276, 0)
  22765    D EN^VALM 2($G(XQORN OD(0)))
  22766   "RTN","RCT CSWL",277, 0)
  22767    I $D(VALM Y) S RCXX= 0 F  S RCX X=$O(VALMY (RCXX)) Q: 'RCXX  D
  22768   "RTN","RCT CSWL",278, 0)
  22769    . S (ECNT ,REC)=$G(^ TMP("RCTCS WLX",$J,RC XX))
  22770   "RTN","RCT CSWL",279, 0)
  22771    . S PRCAB N=$P(ECNT, U,5)  ;Nee d Bill IEN  for PR
  22772   "RTN","RCT CSWL",280, 0)
  22773    . I $G(DI RUT) Q
  22774   "RTN","RCT CSWL",281, 0)
  22775    . S GOTBI LL=1
  22776   "RTN","RCT CSWL",282, 0)
  22777    . D ^PRCA CM K DTOUT
  22778   "RTN","RCT CSWL",283, 0)
  22779    . D WAIT^ VALM1
  22780   "RTN","RCT CSWL",284, 0)
  22781    . Q
  22782   "RTN","RCT CSWL",285, 0)
  22783    S VALMBCK ="R"
  22784   "RTN","RCT CSWL",286, 0)
  22785    Q
  22786   "RTN","RCT CSWL",287, 0)
  22787    ;
  22788   "RTN","RCT CSWL",288, 0)
  22789   REMOVE ; A CTION - RE MOVE FROM  WORKLIST ( RM)
  22790   "RTN","RCT CSWL",289, 0)
  22791    D FULL^VA LM1
  22792   "RTN","RCT CSWL",290, 0)
  22793    S VALMBCK ="R"
  22794   "RTN","RCT CSWL",291, 0)
  22795    N I,J,DFN ,RCXX,VALM Y,ECNT,GOT PAT,REC,RC BILLDA,RCB ILLEX,RCDA TE,RCNAME, RCRRSN
  22796   "RTN","RCT CSWL",292, 0)
  22797    D EN^VALM 2($G(XQORN OD(0)))
  22798   "RTN","RCT CSWL",293, 0)
  22799    I $D(VALM Y) S RCXX= 0 F  S RCX X=$O(VALMY (RCXX)) Q: 'RCXX  D
  22800   "RTN","RCT CSWL",294, 0)
  22801    .S (ECNT, REC)=$G(^T MP("RCTCSW LX",$J,RCX X))
  22802   "RTN","RCT CSWL",295, 0)
  22803    .S RCNAME =$P(ECNT,U ,2)
  22804   "RTN","RCT CSWL",296, 0)
  22805    .S RCBILL DA=$P(ECNT ,U,5)
  22806   "RTN","RCT CSWL",297, 0)
  22807    .S RCBILL EX=$P(ECNT ,U,6)
  22808   "RTN","RCT CSWL",298, 0)
  22809    .S RCDATE =$P(ECNT,U ,7)
  22810   "RTN","RCT CSWL",299, 0)
  22811    .S RCRRSN =$P(ECNT,U ,8)
  22812   "RTN","RCT CSWL",300, 0)
  22813    .W !!,"Re move BILL  "_RCBILLEX _" from Re conciliati on Worklis t Y/N? "
  22814   "RTN","RCT CSWL",301, 0)
  22815    .S %=2 D  YN^DICN
  22816   "RTN","RCT CSWL",302, 0)
  22817    .I %=1 D
  22818   "RTN","RCT CSWL",303, 0)
  22819    ..N PRCAE N,PRCAA1,D R,DIE,DA,D 0,PRCAD,RC ASK,PRCAA2 ,PRCA,PRCA TY,RCUSER
  22820   "RTN","RCT CSWL",304, 0)
  22821    ..K ^PRCA (430,"AN", RCDATE,RCB ILLDA)
  22822   "RTN","RCT CSWL",305, 0)
  22823    ..K ^TMP( "RCTCSWL", $J,$P(REC, U,2)) ;del eting the  selected e ntry from  the temp g bl
  22824   "RTN","RCT CSWL",306, 0)
  22825    ..S RCUSE R=DUZ
  22826   "RTN","RCT CSWL",307, 0)
  22827    ..S PRCAB N=RCBILLDA
  22828   "RTN","RCT CSWL",308, 0)
  22829    ..D SETTR ^PRCAUTL,P ATTR^PRCAU TL Q:'$D(P RCAEN)
  22830   "RTN","RCT CSWL",309, 0)
  22831    ..S PRCAA 1=$S($D(^P RCA(433,PR CAEN,4,0)) :+$P(^(0), U,4),1:0)
  22832   "RTN","RCT CSWL",310, 0)
  22833    ..Q:PRCAA 1'>0  S PR CAA2=$P(^( 0),U,3)
  22834   "RTN","RCT CSWL",311, 0)
  22835    ..S DIE=" ^PRCA(433, ",DA=PRCAE N
  22836   "RTN","RCT CSWL",312, 0)
  22837    ..S DR=". 03///"_PRC ABN ;Bill  Number
  22838   "RTN","RCT CSWL",313, 0)
  22839    ..S DR=DR _";3///0"  ;Calm Code  Done
  22840   "RTN","RCT CSWL",314, 0)
  22841    ..S DR=DR _";12///"_ $O(^PRCA(4 30.3,"AC", 50,0)) ;Tr ansaction  Type
  22842   "RTN","RCT CSWL",315, 0)
  22843    ..S DR=DR _";15///0"  ;Transact ion Amount
  22844   "RTN","RCT CSWL",316, 0)
  22845    ..S DR=DR _";42///"_ RCUSER ;Pr ocessed by  user
  22846   "RTN","RCT CSWL",317, 0)
  22847    ..S DR=DR _";4///2"  ;Transacti on status  (complete)
  22848   "RTN","RCT CSWL",318, 0)
  22849    ..D ^DIE
  22850   "RTN","RCT CSWL",319, 0)
  22851    ..; DIE s eemed to f ail with t oo many va riables, s o we run i t twice.
  22852   "RTN","RCT CSWL",320, 0)
  22853    ..S DR="5 .02///CS R ECON WORKE D"  ;Brief  comment
  22854   "RTN","RCT CSWL",321, 0)
  22855    ..S DR=DR _";11///"_ DT ;Transa ction date
  22856   "RTN","RCT CSWL",322, 0)
  22857    ..D ^DIE
  22858   "RTN","RCT CSWL",323, 0)
  22859    ..I $P($G (^PRCA(433 ,PRCAEN,5) ),"^",2)=" "!('$P(^PR CA(433,PRC AEN,1),"^" )) S PRCAC OMM="TRANS ACTION INC OMPLETE" D  DELETE^PR CAWO1 K PR CACOMM Q
  22860   "RTN","RCT CSWL",324, 0)
  22861    ..I '$D(P RCAD("DELE TE")) S RC ASK=1 D TR ANUP^PRCAU TL,UPPRIN^ PRCADJ
  22862   "RTN","RCT CSWL",325, 0)
  22863    ..I $P($G (^RCD(340, +$P(^PRCA( 430,PRCABN ,0),"^",9) ,0)),"^")[ ";DPT(" D
  22864   "RTN","RCT CSWL",326, 0)
  22865    ...S $P(^ PRCA(433,P RCAEN,0)," ^",10)=1
  22866   "RTN","RCT CSWL",327, 0)
  22867    ..W !,"BI LL "_RCBIL LEX_" has  been remov ed from th e worklist ."
  22868   "RTN","RCT CSWL",328, 0)
  22869    ..D RESET
  22870   "RTN","RCT CSWL",329, 0)
  22871    ..D PAUSE ^VALM1
  22872   "RTN","RCT CSWL",330, 0)
  22873    ..D CLEAN ^VALM10
  22874   "RTN","RCT CSWL",331, 0)
  22875    ..D BLDWL ^RCTCSWL1
  22876   "RTN","RCT CSWL",332, 0)
  22877    ..S VALMB CK="R"
  22878   "RTN","RCT CSWL",333, 0)
  22879    Q
  22880   "RTN","RCT CSWL",334, 0)
  22881    ;
  22882   "RTN","RCT CSWL",335, 0)
  22883   RESET ; Re set ^TMP(" RCTCSWL") 
  22884   "RTN","RCT CSWL",336, 0)
  22885    N RCX,RCX X
  22886   "RTN","RCT CSWL",337, 0)
  22887    S RCX=""  F  S RCX=$ O(^TMP("RC TCSWL",$J, RCX)) Q:RC X=""  D
  22888   "RTN","RCT CSWL",338, 0)
  22889    .S RCXX=" "  F  S RC XX=$O(^TMP ("RCTCSWL" ,$J,RCX,RC XX)) Q:RCX X=""  D
  22890   "RTN","RCT CSWL",339, 0)
  22891    ..I SORTB Y=1,$D(VAL MY),$D(^TM P("RCTCSWL ",$J,RCNAM E,RCBILLEX )) K ^TMP( "RCTCSWL", $J,RCNAME, RCBILLEX)
  22892   "RTN","RCT CSWL",340, 0)
  22893    ..I SORTB Y=2,$D(VAL MY),$D(^TM P("RCTCSWL ",$J,RCBIL LEX,RCNAME )) K ^TMP( "RCTCSWL", $J,RCBILLE X,RCNAME)
  22894   "RTN","RCT CSWL",341, 0)
  22895    Q
  22896   "RTN","RCT CSWL",342, 0)
  22897    ;
  22898   "RTN","RCT CSWL",343, 0)
  22899   KILLGLB ;  Kill Workl ist Global s
  22900   "RTN","RCT CSWL",344, 0)
  22901    K ^TMP("R CTCSWL",$J )
  22902   "RTN","RCT CSWL",345, 0)
  22903    K ^TMP("R CTCSWLX",$ J)
  22904   "RTN","RCT CSWL",346, 0)
  22905    K ^TMP("R CTCSWE",$J )
  22906   "RTN","RCT CSWL",347, 0)
  22907    K ^TMP("V ALMAR",$J)
  22908   "RTN","RCT CSWL",348, 0)
  22909    K ^TMP("X QORS",$J)
  22910   "RTN","RCT CSWL",349, 0)
  22911    K ^TMP("R CTPAPLM",$ J)
  22912   "RTN","RCT CSWL",350, 0)
  22913    K ^TMP("R CTCBPLM",$ J)
  22914   "RTN","RCT CSWL",351, 0)
  22915    K RCFP,RC FPNO,RCFPN OT,RCFPNUM ,RCINLN2,R CINV
  22916   "RTN","RCT CSWL",352, 0)
  22917    D CLEAR^V ALM1
  22918   "RTN","RCT CSWL",353, 0)
  22919    Q
  22920   "RTN","RCT CSWL",354, 0)
  22921    ;
  22922   "RTN","RCT CSWL",355, 0)
  22923   HELP ; --  help code
  22924   "RTN","RCT CSWL",356, 0)
  22925    S X="?" D  DISP^XQOR M1 W !!
  22926   "RTN","RCT CSWL",357, 0)
  22927    Q
  22928   "RTN","RCT CSWL",358, 0)
  22929    ;
  22930   "RTN","RCT CSWL",359, 0)
  22931   EXIT ; --  exit code
  22932   "RTN","RCT CSWL",360, 0)
  22933    D KILLGLB
  22934   "RTN","RCT CSWL",361, 0)
  22935    K EXCEL,P OP,SORTBY, VAUTC,VAUT D
  22936   "RTN","RCT CSWL",362, 0)
  22937    D CLEAN^V ALM10
  22938   "RTN","RCT CSWL",363, 0)
  22939    D ^%ZISC
  22940   "RTN","RCT CSWL",364, 0)
  22941    Q
  22942   "RTN","RCT CSWL",365, 0)
  22943   EXDIV ;
  22944   "RTN","RCT CSWL",366, 0)
  22945    D KILLGLB
  22946   "RTN","RCT CSWL",367, 0)
  22947    K EXCEL,P OP,SORTBY, VAUTC,VAUT D
  22948   "RTN","RCT CSWL",368, 0)
  22949    Q
  22950   "RTN","RCT CSWL",369, 0)
  22951    ;
  22952   "RTN","RCT CSWL",370, 0)
  22953   CHKFILT ;  Check Filt ers
  22954   "RTN","RCT CSWL",371, 0)
  22955    N RCSTAT, RCXX,RCXXX ,RCXXXX,RC FST,RCDIVS
  22956   "RTN","RCT CSWL",372, 0)
  22957    I '$D(RCI ENS)=1 S $ P(FILTERS( 0),U,3)=0, RCDIVS="Al l"
  22958   "RTN","RCT CSWL",373, 0)
  22959    I $G(VAUT D)=0 D
  22960   "RTN","RCT CSWL",374, 0)
  22961    .I $D(RCI ENS) S $P( FILTERS(0) ,U,3)=1
  22962   "RTN","RCT CSWL",375, 0)
  22963    .S RCSTAT =0,RCFST=1
  22964   "RTN","RCT CSWL",376, 0)
  22965    .F  S RCS TAT=$O(VAU TD(RCSTAT) ) Q:RCSTAT =""  D
  22966   "RTN","RCT CSWL",377, 0)
  22967    ..S RCXX= $E($$GET1^ DIQ(40.8,R CSTAT_",", .01),1,15)
  22968   "RTN","RCT CSWL",378, 0)
  22969    ..S RCXXX =$$GET1^DI Q(40.8,RCS TAT_",",1, "E")
  22970   "RTN","RCT CSWL",379, 0)
  22971    ..S RCXXX X=$$GET1^D IQ(40.8,RC STAT_",",. 07,"I")
  22972   "RTN","RCT CSWL",380, 0)
  22973    ..I 'RCFS T S RCDIVS =RCDIVS_", "_RCXX_"-" _RCXXX
  22974   "RTN","RCT CSWL",381, 0)
  22975    ..I RCFST  S RCFST=0 ,RCDIVS=RC XX_"-"_RCX XX
  22976   "RTN","RCT CSWL",382, 0)
  22977    Q
  22978   "RTN","RCT CSWL1")
  22979   0^28^B5328 9265^n/a
  22980   "RTN","RCT CSWL1",1,0 )
  22981   RCTCSWL1 ; ALB/PAW-Cr oss Servic ing Workli st ;30-SEP -2015
  22982   "RTN","RCT CSWL1",2,0 )
  22983    ;;4.5;ACC OUNTS RECE IVABLE;**3 15**;Mar 2 0, 1995;Bu ild 55
  22984   "RTN","RCT CSWL1",3,0 )
  22985    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  22986   "RTN","RCT CSWL1",4,0 )
  22987    ;
  22988   "RTN","RCT CSWL1",5,0 )
  22989   GETRPT(RCR PT) ; Crea te patient  report ba sed upon r eport sele ction
  22990   "RTN","RCT CSWL1",6,0 )
  22991    ; require d input RC RPT (see c omments be low for nu mber/repor t correlat ion)
  22992   "RTN","RCT CSWL1",7,0 )
  22993    ; output  ^TMP("RCTC SWL",$J),  containing  auths for  group que ue
  22994   "RTN","RCT CSWL1",8,0 )
  22995    N RCBILLE X,RCDATE,R CDEBTOR,RC DFN,RCBILL ,RCDBTRN,R CDFN,RCFND 1,RCTRAN,R CRTCD,RCRT CDX,RCUNC, RCPIF,RCSP A,RCDIV,RC DIVX
  22996   "RTN","RCT CSWL1",9,0 )
  22997    ; Loop th rough ACCO UNTS RECEI VABLE File  (#430) Cr oss-Servic ing Index
  22998   "RTN","RCT CSWL1",10, 0)
  22999    S RCDATE= "" F  S RC DATE=$O(^P RCA(430,"A N",RCDATE) ) Q:RCDATE =""  D
  23000   "RTN","RCT CSWL1",11, 0)
  23001    .S RCBILL ="" F  S R CBILL=$O(^ PRCA(430," AN",RCDATE ,RCBILL))  Q:RCBILL=" "  D
  23002   "RTN","RCT CSWL1",12, 0)
  23003    ..S RCDEB TOR=$P($G( ^PRCA(430, RCBILL,0)) ,U,9)  ;De btor in Fi le 340
  23004   "RTN","RCT CSWL1",13, 0)
  23005    ..I $P($G (^RCD(340, RCDEBTOR,0 )),U,1)["D PT" S RCDF N=+$P($G(^ RCD(340,RC DEBTOR,0)) ,U,1)
  23006   "RTN","RCT CSWL1",14, 0)
  23007    ..S RCRTC D=$P($G(^P RCA(430,RC BILL,30)), U,2)
  23008   "RTN","RCT CSWL1",15, 0)
  23009    ..I RCRTC D="" Q
  23010   "RTN","RCT CSWL1",16, 0)
  23011    ..S RCRTC DX=$P(^PRC A(430.5,RC RTCD,0),U)
  23012   "RTN","RCT CSWL1",17, 0)
  23013    ..S RCBIL LEX=$P(^PR CA(430,RCB ILL,0),U)
  23014   "RTN","RCT CSWL1",18, 0)
  23015    ..; Check  if runnin g for spec ific Divis ion - MEDI CAL CENTER  DIVISION  File #40.8
  23016   "RTN","RCT CSWL1",19, 0)
  23017    ..S RCDIV =$P(RCBILL EX,"-")
  23018   "RTN","RCT CSWL1",20, 0)
  23019    ..S RCDIV X="" I VAU TD=0 I '$D (VAUTD(RCD IV)) Q
  23020   "RTN","RCT CSWL1",21, 0)
  23021    ..; Check  if runnin g for spec ific Patie nt
  23022   "RTN","RCT CSWL1",22, 0)
  23023    ..I $P(FI LTERS(0),U ,3)=1 I '$ D(RCDFN) Q
  23024   "RTN","RCT CSWL1",23, 0)
  23025    ..I $P(FI LTERS(0),U ,3)=1 I '$ D(FILTERS( 2,RCDFN))  Q
  23026   "RTN","RCT CSWL1",24, 0)
  23027    ..; Speci fic checks  for each  type of re port
  23028   "RTN","RCT CSWL1",25, 0)
  23029    ..I RCRPT =1 I RCRTC DX'="B" Q   ;Bankrupt cy Return  Reason cod e B
  23030   "RTN","RCT CSWL1",26, 0)
  23031    ..I RCRPT =2 I RCRTC DX'="D" Q   ;Death Re turn Reaso n Code D
  23032   "RTN","RCT CSWL1",27, 0)
  23033    ..I RCRPT =3 I RCRTC DX'="Z" Q   ;Uncollec table Retu rn Reason  Code Z
  23034   "RTN","RCT CSWL1",28, 0)
  23035    ..I RCRPT =4 I RCRTC DX'="F" Q   ;Payment  in Full -  Return Rea son Code =  F
  23036   "RTN","RCT CSWL1",29, 0)
  23037    ..I RCRPT =5 I RCRTC DX'="P" Q   ;Satisfie d PA - Ret urn Reason  Code = P,  but nothi ng in Comp romise Fie ld
  23038   "RTN","RCT CSWL1",30, 0)
  23039    ..I RCRPT =6 I RCRTC DX'="S" Q   ;Compromi se Field s et to Y
  23040   "RTN","RCT CSWL1",31, 0)
  23041    ..I RCRPT =7 I RCRTC DX="" Q  ; Any Return  Reason Co de
  23042   "RTN","RCT CSWL1",32, 0)
  23043    ..D BLDTM P
  23044   "RTN","RCT CSWL1",33, 0)
  23045    Q
  23046   "RTN","RCT CSWL1",34, 0)
  23047    ;
  23048   "RTN","RCT CSWL1",35, 0)
  23049   BLDTMP ; B uild ^TMP( "RCTCSWL", $J) for th e main lis t screen
  23050   "RTN","RCT CSWL1",36, 0)
  23051    N A1,A2,P RCA3,DFN,R CBAL,RCBIL LEX,RCNAME ,RCPTID,RC RTRSN,RCLI NE,VA,VADM ,VAERR,TRT YP,RCBIND
  23052   "RTN","RCT CSWL1",37, 0)
  23053    I $D(RCDF N) D
  23054   "RTN","RCT CSWL1",38, 0)
  23055    . S DFN=R CDFN
  23056   "RTN","RCT CSWL1",39, 0)
  23057    . D DEM^V ADPT
  23058   "RTN","RCT CSWL1",40, 0)
  23059    . I VAERR  K VADM
  23060   "RTN","RCT CSWL1",41, 0)
  23061    . S RCNAM E=VADM(1)
  23062   "RTN","RCT CSWL1",42, 0)
  23063    . S RCPTI D=$E(RCNAM E,1)_VA("B ID")
  23064   "RTN","RCT CSWL1",43, 0)
  23065    S A1=$P(^ RCD(340,RC DEBTOR,0), ";",1),A2= $P($P(^(0) ,U,1),";", 2),PRCA3=U _A2_A1_",0 )",RCNAME= $S($D(@PRC A3):$P(^(0 ),U,1),1:" ")
  23066   "RTN","RCT CSWL1",44, 0)
  23067    S RCBAL=$ $GET1^DIQ( 430,RCBILL _",",11)
  23068   "RTN","RCT CSWL1",45, 0)
  23069    S RCBILLE X=$P($G(^P RCA(430,RC BILL,0)),U ,1)  ;Exte rnal Bill  Number
  23070   "RTN","RCT CSWL1",46, 0)
  23071    ; Set his torical in dicator "y " when ret urned from  Treasury
  23072   "RTN","RCT CSWL1",47, 0)
  23073    I $D(^PRC A(430,"AN" ,RCDATE,RC BILL)) S R CBIND="y"
  23074   "RTN","RCT CSWL1",48, 0)
  23075    S RCLINE= $G(RCNAME) _U_$G(RCPT ID)_U_$G(R CBAL)_U_$G (DFN)_U_$G (RCBIND)_$ G(RCBILLEX )_U_RCDEBT OR_U_RCBIL L_U_RCDATE _U_RCRTCDX
  23076   "RTN","RCT CSWL1",49, 0)
  23077    ; Sort by  Patient N ame
  23078   "RTN","RCT CSWL1",50, 0)
  23079    I SORTBY= 1 S ^TMP(" RCTCSWL",$ J,RCNAME,R CBILLEX)=R CLINE
  23080   "RTN","RCT CSWL1",51, 0)
  23081    ; Sort by  Bill Numb er
  23082   "RTN","RCT CSWL1",52, 0)
  23083    I SORTBY= 2 S ^TMP(" RCTCSWL",$ J,RCBILLEX ,RCNAME)=R CLINE
  23084   "RTN","RCT CSWL1",53, 0)
  23085    ; Sort by  Return Re ason Code
  23086   "RTN","RCT CSWL1",54, 0)
  23087    I SORTBY= 3 S ^TMP(" RCTCSWL",$ J,RCRTCDX, RCBILLEX)= RCLINE
  23088   "RTN","RCT CSWL1",55, 0)
  23089    ;
  23090   "RTN","RCT CSWL1",56, 0)
  23091   BLDWL ; Fo rmat main  list scree n data lin es
  23092   "RTN","RCT CSWL1",57, 0)
  23093    ; build d isplay lin es
  23094   "RTN","RCT CSWL1",58, 0)
  23095    K ^TMP("R CTCSWLX",$ J)
  23096   "RTN","RCT CSWL1",59, 0)
  23097    N RCBILL, RCBILLEX,R CDATE,RCDE BTOR,RCDFN ,RCNAME,RC PATNAM,RCP TID,RCRRSN ,RCXX,RCY, RCYY,FIRST ,LINE,VCNT
  23098   "RTN","RCT CSWL1",60, 0)
  23099    S (VALMCN T,FIRST,VC NT)=0
  23100   "RTN","RCT CSWL1",61, 0)
  23101    S RCY=""  F  S RCY=$ O(^TMP("RC TCSWL",$J, RCY)) Q:RC Y=""  D
  23102   "RTN","RCT CSWL1",62, 0)
  23103    .S RCYY=" " F  S RCY Y=$O(^TMP( "RCTCSWL", $J,RCY,RCY Y)) Q:RCYY =""  D
  23104   "RTN","RCT CSWL1",63, 0)
  23105    ..S VCNT= VCNT+1
  23106   "RTN","RCT CSWL1",64, 0)
  23107    ..S LINE= $$LJ^XLFST R(VCNT,6)  ;line #
  23108   "RTN","RCT CSWL1",65, 0)
  23109    ..S RCXX= ^TMP("RCTC SWL",$J,RC Y,RCYY)
  23110   "RTN","RCT CSWL1",66, 0)
  23111    ..S RCPAT NAM=$P(RCX X,U)
  23112   "RTN","RCT CSWL1",67, 0)
  23113    ..S RCPTI D=$P(RCXX, U,2)
  23114   "RTN","RCT CSWL1",68, 0)
  23115    ..S RCDFN =$P(RCXX,U ,4)
  23116   "RTN","RCT CSWL1",69, 0)
  23117    ..S RCBIL LEX=$P(RCX X,U,5)
  23118   "RTN","RCT CSWL1",70, 0)
  23119    ..S RCDEB TOR=$P(RCX X,U,6)
  23120   "RTN","RCT CSWL1",71, 0)
  23121    ..S RCBIL L=$P(RCXX, U,7)
  23122   "RTN","RCT CSWL1",72, 0)
  23123    ..S RCDAT E=$P(RCXX, U,8)
  23124   "RTN","RCT CSWL1",73, 0)
  23125    ..S RCRRS N=$P(RCXX, U,9)
  23126   "RTN","RCT CSWL1",74, 0)
  23127    ..I SORTB Y=1 D
  23128   "RTN","RCT CSWL1",75, 0)
  23129    ...;Patie nt^Patient  ID^Bill N o.^Balance ^Ret Rsn
  23130   "RTN","RCT CSWL1",76, 0)
  23131    ...S LINE =$$SETL(LI NE,$P(RCXX ,U),"",4,2 7)
  23132   "RTN","RCT CSWL1",77, 0)
  23133    ...S LINE =$$SETL(LI NE,$P(RCXX ,U,2),"",3 2,5)
  23134   "RTN","RCT CSWL1",78, 0)
  23135    ...S LINE =$$SETL(LI NE,$P(RCXX ,U,5),"",4 0,12)
  23136   "RTN","RCT CSWL1",79, 0)
  23137    ...S LINE =$$SETL(LI NE,$J($P(R CXX,U,3),1 0,2),"",55 ,12)
  23138   "RTN","RCT CSWL1",80, 0)
  23139    ...S LINE =$$SETL(LI NE,$P(RCXX ,U,9),"",6 7,3)
  23140   "RTN","RCT CSWL1",81, 0)
  23141    ..I SORTB Y=2 D
  23142   "RTN","RCT CSWL1",82, 0)
  23143    ...;Bill  No.^Patien t ID^Patie nt^Balance ^Ret Rsn
  23144   "RTN","RCT CSWL1",83, 0)
  23145    ...S LINE =$$SETL(LI NE,$P(RCXX ,U,5),"",4 ,12)
  23146   "RTN","RCT CSWL1",84, 0)
  23147    ...S LINE =$$SETL(LI NE,$P(RCXX ,U,2),"",1 7,5)
  23148   "RTN","RCT CSWL1",85, 0)
  23149    ...S LINE =$$SETL(LI NE,$P(RCXX ,U),"",24, 27)
  23150   "RTN","RCT CSWL1",86, 0)
  23151    ...S LINE =$$SETL(LI NE,$J($P(R CXX,U,3),1 0,2),"",55 ,12)
  23152   "RTN","RCT CSWL1",87, 0)
  23153    ...S LINE =$$SETL(LI NE,$P(RCXX ,U,9),"",6 7,3)
  23154   "RTN","RCT CSWL1",88, 0)
  23155    ..I SORTB Y=3 D
  23156   "RTN","RCT CSWL1",89, 0)
  23157    ...;Ret R sn^Bill No .^Pt ID^Pa tient^Bala nce  
  23158   "RTN","RCT CSWL1",90, 0)
  23159    ...S LINE =$$SETL(LI NE,$P(RCXX ,U,9),"",4 ,7)
  23160   "RTN","RCT CSWL1",91, 0)
  23161    ...S LINE =$$SETL(LI NE,$P(RCXX ,U,5),"",1 2,12)
  23162   "RTN","RCT CSWL1",92, 0)
  23163    ...S LINE =$$SETL(LI NE,$P(RCXX ,U,2),"",2 5,5)
  23164   "RTN","RCT CSWL1",93, 0)
  23165    ...S LINE =$$SETL(LI NE,$P(RCXX ,U),"",32, 27)
  23166   "RTN","RCT CSWL1",94, 0)
  23167    ...S LINE =$$SETL(LI NE,$J($P(R CXX,U,2),1 0,2),"",64 ,12)
  23168   "RTN","RCT CSWL1",95, 0)
  23169    ..S VALMC NT=VALMCNT +1
  23170   "RTN","RCT CSWL1",96, 0)
  23171    ..D SET^V ALM10(VALM CNT,LINE,V CNT)
  23172   "RTN","RCT CSWL1",97, 0)
  23173    ..S ^TMP( "RCTCSWLX" ,$J,VCNT)= RCDFN_U_RC PATNAM_U_R CPTID_U_RC DEBTOR_U_R CBILL_U_RC BILLEX_U_R CDATE_U_RC RRSN  ;Thi s is set f or ACTIONS
  23174   "RTN","RCT CSWL1",98, 0)
  23175    Q
  23176   "RTN","RCT CSWL1",99, 0)
  23177    ;
  23178   "RTN","RCT CSWL1",100 ,0)
  23179   SETL(LINE, DATA,LABEL ,COL,LNG)  ; Creates  a line of  data to be  set into  the body
  23180   "RTN","RCT CSWL1",101 ,0)
  23181    ; of the  worklist
  23182   "RTN","RCT CSWL1",102 ,0)
  23183    ; Input:  LINE - Cur rent line  being crea ted
  23184   "RTN","RCT CSWL1",103 ,0)
  23185    ; DATA -  Informatio n to be ad ded to the  end of th e current  line
  23186   "RTN","RCT CSWL1",104 ,0)
  23187    ; LABEL -  Label to  describe t he informa tion being  added
  23188   "RTN","RCT CSWL1",105 ,0)
  23189    ; COL - C olumn posi tion in li ne to add  informatio n add
  23190   "RTN","RCT CSWL1",106 ,0)
  23191    ; LNG - M aximum len gth of dat a informat ion to inc lude on th e line
  23192   "RTN","RCT CSWL1",107 ,0)
  23193    ; Returns : Line upd ated with  added info rmation
  23194   "RTN","RCT CSWL1",108 ,0)
  23195    S LINE=LI NE_$J("",( COL-$L(LAB EL)-$L(LIN E)))_LABEL _$E(DATA,1 ,LNG)
  23196   "RTN","RCT CSWL1",109 ,0)
  23197    Q LINE
  23198   "RTN","RCT CSWL1",110 ,0)
  23199    ;
  23200   "RTN","RCT CSWL1",111 ,0)
  23201   EXCEL ;For mat and Pr int EXCEL  file
  23202   "RTN","RCT CSWL1",112 ,0)
  23203    W @IOF
  23204   "RTN","RCT CSWL1",113 ,0)
  23205    N RCX,RCX X,RCY,RCYY ,RCZ,RCAMT
  23206   "RTN","RCT CSWL1",114 ,0)
  23207    S RCX=$P( FILTERS(0) ,U,1)
  23208   "RTN","RCT CSWL1",115 ,0)
  23209    S RCXX=$S (RCX=1:"Ba nkruptcy", RCX=2:"Dea ths",RCX=3 :"Uncollec tible",RCX =4:"Paymen t in Full" ,1:"")
  23210   "RTN","RCT CSWL1",116 ,0)
  23211    I $G(RCXX )="" S RCX X=$S(RCX=5 :"Satisfie d PA",RCX= 6:"Comprom ise",RCX=7 :"All Retu rns",1:"")
  23212   "RTN","RCT CSWL1",117 ,0)
  23213    W !,RCXX_ " Report"
  23214   "RTN","RCT CSWL1",118 ,0)
  23215    I SORTBY= 1 W !,"Pat ient Name^ Patient ID ^Bill Numb er^Current  Amount^Rt  Rsn Code"
  23216   "RTN","RCT CSWL1",119 ,0)
  23217    I SORTBY= 2 W !,"Bil l Number^P atient ID^ Patient Na me^Current  Amount^Rt  Rsn Code"
  23218   "RTN","RCT CSWL1",120 ,0)
  23219    I SORTBY= 3 W !,"Rt  Rsn Code^B ill Number ^Patient I D^Patient  Name^Curre nt Amount"
  23220   "RTN","RCT CSWL1",121 ,0)
  23221    S RCY=""  F  S RCY=$ O(^TMP("RC TCSWL",$J, RCY)) Q:RC Y=""  D
  23222   "RTN","RCT CSWL1",122 ,0)
  23223    .S RCYY=" " F  S RCY Y=$O(^TMP( "RCTCSWL", $J,RCY,RCY Y)) Q:RCYY =""  D
  23224   "RTN","RCT CSWL1",123 ,0)
  23225    ..S RCZ=^ TMP("RCTCS WL",$J,RCY ,RCYY)
  23226   "RTN","RCT CSWL1",124 ,0)
  23227    ..;Reform at Excel l ine, based  upon sort
  23228   "RTN","RCT CSWL1",125 ,0)
  23229    ..;Input  from RCZ:  PtName_U_P tID_U_CurB al_U_DFN_U _Bill No_U _Debtor_U_ InternalBi ll_U_Date_ U_ReturnRe asonCode
  23230   "RTN","RCT CSWL1",126 ,0)
  23231    ..S RCAMT =$P(RCZ,U, 3)
  23232   "RTN","RCT CSWL1",127 ,0)
  23233    ..I RCAMT ="" S RCAM T=0
  23234   "RTN","RCT CSWL1",128 ,0)
  23235    ..S RCAMT =$J(RCAMT, 10,2)
  23236   "RTN","RCT CSWL1",129 ,0)
  23237    ..I SORTB Y=1 W !,$P (RCZ,U)_"^ ",$P(RCZ,U ,2)_"^"_$P (RCZ,U,5)_ "^"_RCAMT_ "^"_$P(RCZ ,U,9)
  23238   "RTN","RCT CSWL1",130 ,0)
  23239    ..I SORTB Y=2 W !,$P (RCZ,U,5)_ "^",$P(RCZ ,U,2)_"^"_ $P(RCZ,U)_ "^"_RCAMT_ "^"_$P(RCZ ,U,9)
  23240   "RTN","RCT CSWL1",131 ,0)
  23241    ..I SORTB Y=3 W !,$P (RCZ,U,9)_ "^",$P(RCZ ,U,5)_"^"_ $P(RCZ,U,2 )_"^"_$P(R CZ,U)_"^"_ RCAMT
  23242   "RTN","RCT CSWL1",132 ,0)
  23243    I $E(IOST ,1,2)="C-" ,'EXCEL R  !!,"END OF  REPORT... PRESS RETU RN TO CONT INUE",X:DT IME W @IOF
  23244   "RTN","RCT CSWL1",133 ,0)
  23245    D:'$D(ZTQ UEUED) ^%Z ISC
  23246   "RTN","RCT CSWL1",134 ,0)
  23247    S:$D(ZTQU EUED) ZTRE Q="@"
  23248   "RTN","RCT CSWL1",135 ,0)
  23249    K IOP,%ZI S,ZTQUEUED
  23250   "RTN","RCT CSWL1",136 ,0)
  23251    Q
  23252   "RTN","RCT CSWL1",137 ,0)
  23253    ;
  23254   "RTN","RCT CSWL1",138 ,0)
  23255    ;RCDIV()  N DIC,DIR, DIRUT,DTOU T,DUOUT,X, Y
  23256   "RTN","RCT CSWL1",139 ,0)
  23257    ;
  23258   "RTN","RCT CSWL1",140 ,0)
  23259    ;Reset RC DIV array
  23260   "RTN","RCT CSWL1",141 ,0)
  23261    K RCDIV
  23262   "RTN","RCT CSWL1",142 ,0)
  23263    ;
  23264   "RTN","RCT CSWL1",143 ,0)
  23265    ;First se e if they  want to en ter indivi dual divis ions or AL L
  23266   "RTN","RCT CSWL1",144 ,0)
  23267    S DIR(0)= "S^D:DIVIS ION;A:ALL"
  23268   "RTN","RCT CSWL1",145 ,0)
  23269    S DIR("A" )="Select  Certain (D )ivisions  or (A)LL"
  23270   "RTN","RCT CSWL1",146 ,0)
  23271    S DIR("L" ,1)="Selec t one of t he followi ng:"
  23272   "RTN","RCT CSWL1",147 ,0)
  23273    S DIR("L" ,2)=""
  23274   "RTN","RCT CSWL1",148 ,0)
  23275    S DIR("L" ,3)="      D          DIVISION"
  23276   "RTN","RCT CSWL1",149 ,0)
  23277    S DIR("L" ,4)="      A          ALL"
  23278   "RTN","RCT CSWL1",150 ,0)
  23279    D ^DIR K  DIR
  23280   "RTN","RCT CSWL1",151 ,0)
  23281    ;
  23282   "RTN","RCT CSWL1",152 ,0)
  23283    ;Check fo r "^" or t imeout, ot herwise de fine BPPHA RM
  23284   "RTN","RCT CSWL1",153 ,0)
  23285    I ($G(DUO UT)=1)!($G (DTOUT)=1)  S Y="^"
  23286   "RTN","RCT CSWL1",154 ,0)
  23287    E  S RCDI V=$S(Y="A" :0,1:1)
  23288   "RTN","RCT CSWL1",155 ,0)
  23289    ;
  23290   "RTN","RCT CSWL1",156 ,0)
  23291    ;If divis ion select ed, ask pr ompt
  23292   "RTN","RCT CSWL1",157 ,0)
  23293    I $G(RCDI V)=1 F  D   Q:Y="^"!( Y="") 
  23294   "RTN","RCT CSWL1",158 ,0)
  23295    .;
  23296   "RTN","RCT CSWL1",159 ,0)
  23297    .;Prompt  for entry
  23298   "RTN","RCT CSWL1",160 ,0)
  23299    .K X S DI C(0)="QEAM ",DIC=40.8 ,DIC("A")= "Select Di vision(s):  "
  23300   "RTN","RCT CSWL1",161 ,0)
  23301    .W ! D ^D IC
  23302   "RTN","RCT CSWL1",162 ,0)
  23303    .;
  23304   "RTN","RCT CSWL1",163 ,0)
  23305    .;Check f or "^" or  timeout 
  23306   "RTN","RCT CSWL1",164 ,0)
  23307    .I ($G(DU OUT)=1)!($ G(DTOUT)=1 ) K RCDIV  S Y="^" Q
  23308   "RTN","RCT CSWL1",165 ,0)
  23309    .;
  23310   "RTN","RCT CSWL1",166 ,0)
  23311    .;Check f or blank e ntry, quit  if no pre vious sele ctions
  23312   "RTN","RCT CSWL1",167 ,0)
  23313    .I $G(X)= "" S Y=$S( $D(RCDIV)> 9:"",1:"^" ) K:Y="^"  RCDIV Q
  23314   "RTN","RCT CSWL1",168 ,0)
  23315    .;
  23316   "RTN","RCT CSWL1",169 ,0)
  23317    .;Handle  Deletes
  23318   "RTN","RCT CSWL1",170 ,0)
  23319    .I $D(RCD IV(+Y)) D   Q:Y="^"   I 1
  23320   "RTN","RCT CSWL1",171 ,0)
  23321    ..N P
  23322   "RTN","RCT CSWL1",172 ,0)
  23323    ..S P=Y   ;Save Orig inal Value
  23324   "RTN","RCT CSWL1",173 ,0)
  23325    ..S DIR(0 )="S^Y:YES ;N:NO",DIR ("A")="Del ete "_$P(P ,U,2)_" fr om your li st?"
  23326   "RTN","RCT CSWL1",174 ,0)
  23327    ..S DIR(" B")="NO" D  ^DIR
  23328   "RTN","RCT CSWL1",175 ,0)
  23329    ..I ($G(D UOUT)=1)!( $G(DTOUT)= 1) K RCDIV  S Y="^" Q
  23330   "RTN","RCT CSWL1",176 ,0)
  23331    ..I Y="Y"  K RCDIV(+ P),RCDIV(" B",$P(P,U, 2),+P)
  23332   "RTN","RCT CSWL1",177 ,0)
  23333    ..S Y=P   ;Restore O riginal Va lue
  23334   "RTN","RCT CSWL1",178 ,0)
  23335    ..K P
  23336   "RTN","RCT CSWL1",179 ,0)
  23337    .E  D
  23338   "RTN","RCT CSWL1",180 ,0)
  23339    ..;Define  new entri es in RCDI V array
  23340   "RTN","RCT CSWL1",181 ,0)
  23341    ..S VAUTD (+Y)=Y
  23342   "RTN","RCT CSWL1",182 ,0)
  23343    ..S RCDIV ("B",$P(Y, U,2),+Y)=" "
  23344   "RTN","RCT CSWL1",183 ,0)
  23345    .;
  23346   "RTN","RCT CSWL1",184 ,0)
  23347    .;Display  a list of  selected  divisions
  23348   "RTN","RCT CSWL1",185 ,0)
  23349    .I $D(RCD IV)>9 D
  23350   "RTN","RCT CSWL1",186 ,0)
  23351    ..N X
  23352   "RTN","RCT CSWL1",187 ,0)
  23353    ..W !,?2, "Selected: "
  23354   "RTN","RCT CSWL1",188 ,0)
  23355    ..S X=""  F  S X=$O( RCDIV("B", X)) Q:X=""   W !,?10, X
  23356   "RTN","RCT CSWL1",189 ,0)
  23357    ..K X
  23358   "RTN","RCT CSWL1",190 ,0)
  23359    .Q
  23360   "RTN","RCT CSWL1",191 ,0)
  23361    ;
  23362   "RTN","RCT CSWL1",192 ,0)
  23363    K RCDIV(" B")
  23364   "RTN","RCT CSWL1",193 ,0)
  23365    Q Y
  23366   "RTN","RCT CSWL1",194 ,0)
  23367    ;
  23368   "RTN","RCT CSWL1",195 ,0)
  23369   CSTOP(BILL ) ;
  23370   "RTN","RCT CSWL1",196 ,0)
  23371    ; Input:
  23372   "RTN","RCT CSWL1",197 ,0)
  23373    ; BILL -  Bill numbe r from #43 0 - Extern al Value ( .01), not  IEN
  23374   "RTN","RCT CSWL1",198 ,0)
  23375    ; Output:
  23376   "RTN","RCT CSWL1",199 ,0)
  23377    ; CSTOP -  Cross-ser viced stat us (blank  = not foun d, 0 = not  stopped,  1 = stoppe d)
  23378   "RTN","RCT CSWL1",200 ,0)
  23379    ;
  23380   "RTN","RCT CSWL1",201 ,0)
  23381    N CSTOP,I EN
  23382   "RTN","RCT CSWL1",202 ,0)
  23383    I BILL=""  Q ""  ;no  bill #
  23384   "RTN","RCT CSWL1",203 ,0)
  23385    I '$D(^PR CA(430,"TC SP",BILL))  Q ""
  23386   "RTN","RCT CSWL1",204 ,0)
  23387    S CSTOP=$ $GET1^DIQ( 430,BILL," 157,","IE" )
  23388   "RTN","RCT CSWL1",205 ,0)
  23389    Q CSTOP
  23390   "RTN","RCT CSWL2")
  23391   0^29^B2252 9907^n/a
  23392   "RTN","RCT CSWL2",1,0 )
  23393   RCTCSWL2 ; ALB/PAW-Cr oss Servic ing Workli st ;30-SEP -2015
  23394   "RTN","RCT CSWL2",2,0 )
  23395    ;;4.5;ACC OUNTS RECE IVABLE;**3 15**;Mar 2 0, 1995;Bu ild 55
  23396   "RTN","RCT CSWL2",3,0 )
  23397    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  23398   "RTN","RCT CSWL2",4,0 )
  23399    ; 
  23400   "RTN","RCT CSWL2",5,0 )
  23401   HDR ; -- h eader code  for Expan d Screen
  23402   "RTN","RCT CSWL2",6,0 )
  23403    N RCNAM,R CDFN,RCPTN AME,RCPTID ,RCBILL,RC BILLEX,RCB DT,RCDOD2, RCX,LIST
  23404   "RTN","RCT CSWL2",7,0 )
  23405    S RCDFN=$ P(ECNT,U,1 ),RCPTNAME =$P(ECNT,U ,2),RCPTID =$P(ECNT,U ,3),RCBILL =$P(ECNT,U ,4),RCBILL EX=$P(ECNT ,U,6)
  23406   "RTN","RCT CSWL2",8,0 )
  23407    S RCX=$P( FILTERS(0) ,U)
  23408   "RTN","RCT CSWL2",9,0 )
  23409    S VALMHDR (1)=$S(RCX =1:"Bankru ptcy",RCX= 2:"Deaths" ,RCX=3:"Un collectibl e",RCX=4:" Paymt. in  Full",RCX= 5:"Satisfi ed PA",RCX =6:"Compro mise",RCX= 7:"All Ret urns",1:"" )
  23410   "RTN","RCT CSWL2",10, 0)
  23411    S VALM("T ITLE")="Ex panded Bil l Screen"
  23412   "RTN","RCT CSWL2",11, 0)
  23413    D
  23414   "RTN","RCT CSWL2",12, 0)
  23415    . I RCX[7  S VALMHDR (1)="Recon ciliation  "_VALMHDR( 1)_" Repor t" Q
  23416   "RTN","RCT CSWL2",13, 0)
  23417    . ;I RCX' [7 S VALMH DR(1)="Rec onciliatio n Reports  Selected:  "_$P(RCX," ,",$TR(1," Bankruptcy "))_", "_$ TR(2,"Deat hs")_", "_ $TR(3,"Unc ollectible ")_", "_$T R(4,"Payme nt in Full ")_", "_$T R(5,"Satis fied PA")_ ", "_$TR(6 ,"Compromi se")
  23418   "RTN","RCT CSWL2",14, 0)
  23419    . N X S X ="" F I=1: 1:6 I RCX[ I S X=X_$S (X="":"",1 :", "),X=X _$S(I=1:"B ankruptcy" ,I=2:"Deat hs",I=3:"U ncollectbl .",I=4:"Pm t. In Full ",I=5:"Sat isfied PA" ,I=6:"Comp romise",1: "")
  23420   "RTN","RCT CSWL2",15, 0)
  23421    . S VALMH DR(1)="Typ es: "_X
  23422   "RTN","RCT CSWL2",16, 0)
  23423    S VALMHDR (2)="Bill  Number: "_ RCBILLEX
  23424   "RTN","RCT CSWL2",17, 0)
  23425    Q
  23426   "RTN","RCT CSWL2",18, 0)
  23427    ;
  23428   "RTN","RCT CSWL2",19, 0)
  23429   INIT ; --  init varia bles and l ist array
  23430   "RTN","RCT CSWL2",20, 0)
  23431    ; input -  ^TMP("RCT CSWE",$J)= RCDFN^RCNA ME
  23432   "RTN","RCT CSWL2",21, 0)
  23433    ; output  - Expanded  worklist  screen
  23434   "RTN","RCT CSWL2",22, 0)
  23435    I '$D(^TM P("RCTCSWE ",$J)) Q
  23436   "RTN","RCT CSWL2",23, 0)
  23437    N ECNT,RC DFN,RCDFN2 ,RCPTNAME, RCPTID,RCB ILL,RCBILL EX,VALMBCK
  23438   "RTN","RCT CSWL2",24, 0)
  23439    S ECNT=$G (^TMP("RCT CSWE",$J))
  23440   "RTN","RCT CSWL2",25, 0)
  23441    S RCDFN=$ P(ECNT,U,1 ),RCPTNAME =$P(ECNT,U ,2),RCPTID =$P(ECNT,U ,3),RCBILL =$P(ECNT,U ,4),RCBILL EX=$P(ECNT ,U,5)
  23442   "RTN","RCT CSWL2",26, 0)
  23443    S RCDFN2= RCDFN
  23444   "RTN","RCT CSWL2",27, 0)
  23445    I RCDFN2= "" S RCDFN 2=" "
  23446   "RTN","RCT CSWL2",28, 0)
  23447    D BLD
  23448   "RTN","RCT CSWL2",29, 0)
  23449    D BLDEXP
  23450   "RTN","RCT CSWL2",30, 0)
  23451    S VALMBCK ="R"
  23452   "RTN","RCT CSWL2",31, 0)
  23453    Q
  23454   "RTN","RCT CSWL2",32, 0)
  23455    ;
  23456   "RTN","RCT CSWL2",33, 0)
  23457   BLD ; buil d data to  display
  23458   "RTN","RCT CSWL2",34, 0)
  23459    N CNT,RCA MTPD,RCAMT RF,RCDEBT, RCBDT,RCDT RET,RCCORD T,RCDOD,RC FEE,RCRSN, RCDEBT,RCD IV,RCDIVNM ,RCSTNUM,R C18
  23460   "RTN","RCT CSWL2",35, 0)
  23461    N CBEGDT, RCCOMP,RCD DT,RCBEGDT
  23462   "RTN","RCT CSWL2",36, 0)
  23463    S CNT=0
  23464   "RTN","RCT CSWL2",37, 0)
  23465    S RCDEBT= $E($$GET1^ DIQ(430,RC BILL,9),1, 16)
  23466   "RTN","RCT CSWL2",38, 0)
  23467    S RCDIV=$ P(RCBILLEX ,"-")
  23468   "RTN","RCT CSWL2",39, 0)
  23469    I RCDIV[" y" S RCDIV =$P(RCDIV, "y",2)
  23470   "RTN","RCT CSWL2",40, 0)
  23471    S RCDIVNM =""
  23472   "RTN","RCT CSWL2",41, 0)
  23473    S RCDIVNM =$O(^DIC(4 ,"D",RCDIV ,RCDIVNM))
  23474   "RTN","RCT CSWL2",42, 0)
  23475    I $G(RCDI VNM)'="" S  RCDIVNM=$ P(^DIC(4,R CDIVNM,0), U)
  23476   "RTN","RCT CSWL2",43, 0)
  23477    I RCBILLE X'["-" S R CDIV=""
  23478   "RTN","RCT CSWL2",44, 0)
  23479    S RCRSN=+ $P($G(^PRC A(430,RCBI LL,30)),U, 2)
  23480   "RTN","RCT CSWL2",45, 0)
  23481    I RCRSN'= "" S RCRSN =$P(^PRCA( 430.5,RCRS N,0),U,2)
  23482   "RTN","RCT CSWL2",46, 0)
  23483    S RCAMTRF =$J($P($G( ^PRCA(430, RCBILL,16) ),U,9),10, 2)
  23484   "RTN","RCT CSWL2",47, 0)
  23485    S RCAMTPD =RCAMTRF-$ P($G(^PRCA (430,RCBIL L,16)),U,1 0),RCAMTPD =$J(RCAMTP D,10,2)
  23486   "RTN","RCT CSWL2",48, 0)
  23487    S RCFEE=$ J($P($G(^P RCA(430,RC BILL,7)),U ,4),10,2)
  23488   "RTN","RCT CSWL2",49, 0)
  23489    S RCCORDT =$$FMTE^XL FDT($P($G( ^PRCA(430, RCBILL,15) ),U,3),"5D Z")
  23490   "RTN","RCT CSWL2",50, 0)
  23491    S RCBEGDT =$$FMTE^XL FDT($P($G( ^PRCA(430, RCBILL,0)) ,U,10),"5D Z")
  23492   "RTN","RCT CSWL2",51, 0)
  23493    S RCDTRET =$$FMTE^XL FDT($P($G( ^PRCA(430, RCBILL,30) ),U),"5DZ" )
  23494   "RTN","RCT CSWL2",52, 0)
  23495    S CNT=CNT +1,^TMP("R CTCSWE",$J ,RCNAME,RC DFN2,CNT)= " Patient           :  "_RCPTNAM E_" (ID: " _RCPTID_") "
  23496   "RTN","RCT CSWL2",53, 0)
  23497    S CNT=CNT +1,^TMP("R CTCSWE",$J ,RCNAME,RC DFN2,CNT)= " Debtor            :  "_RCDEBT
  23498   "RTN","RCT CSWL2",54, 0)
  23499    S CNT=CNT +1,^TMP("R CTCSWE",$J ,RCNAME,RC DFN2,CNT)= " Division          :  "_$G(RCDI V)_" - "_$ G(RCDIVNM)
  23500   "RTN","RCT CSWL2",55, 0)
  23501    S CNT=CNT +1,^TMP("R CTCSWE",$J ,RCNAME,RC DFN2,CNT)= " Return R esn Code :  "_$G(RCRS N)
  23502   "RTN","RCT CSWL2",56, 0)
  23503    S CNT=CNT +1,^TMP("R CTCSWE",$J ,RCNAME,RC DFN2,CNT)= " Dt Bill  Created  :  "_$G(RCBE GDT)
  23504   "RTN","RCT CSWL2",57, 0)
  23505    S CNT=CNT +1,^TMP("R CTCSWE",$J ,RCNAME,RC DFN2,CNT)= " Date Cor r Rep/Rec:  "_$G(RCCO RDT)
  23506   "RTN","RCT CSWL2",58, 0)
  23507    S CNT=CNT +1,^TMP("R CTCSWE",$J ,RCNAME,RC DFN2,CNT)= " Date Ret urned    :  "_$G(RCDT RET)
  23508   "RTN","RCT CSWL2",59, 0)
  23509    S RCBDT=$ $FMTE^XLFD T($P($G(^P RCA(430,RC BILL,30)), U,6),"5DZ" )  ;Get Ba nkruptcy D ate
  23510   "RTN","RCT CSWL2",60, 0)
  23511    S RCDDT=$ $FMTE^XLFD T($P($G(^P RCA(430,RC BILL,30)), U,8),"5DZ" )  ;Get Di ssolution  Date
  23512   "RTN","RCT CSWL2",61, 0)
  23513    S CNT=CNT +1,^TMP("R CTCSWE",$J ,RCNAME,RC DFN2,CNT)= " Bankrupt cy Date  :  "_RCBDT
  23514   "RTN","RCT CSWL2",62, 0)
  23515    S CNT=CNT +1,^TMP("R CTCSWE",$J ,RCNAME,RC DFN2,CNT)= " Dt of Di ssolution:  "_RCDDT
  23516   "RTN","RCT CSWL2",63, 0)
  23517    S RCDOD=$ $FMTE^XLFD T($P($G(^P RCA(430,RC BILL,30)), U,7),"5DZ" )
  23518   "RTN","RCT CSWL2",64, 0)
  23519    S CNT=CNT +1,^TMP("R CTCSWE",$J ,RCNAME,RC DFN2,CNT)= " Death No tice Rcvd:  "_RCDOD
  23520   "RTN","RCT CSWL2",65, 0)
  23521    S CNT=CNT +1,^TMP("R CTCSWE",$J ,RCNAME,RC DFN2,CNT)= " Amount R eferred  :  "_$G(RCAM TRF)
  23522   "RTN","RCT CSWL2",66, 0)
  23523    S CNT=CNT +1,^TMP("R CTCSWE",$J ,RCNAME,RC DFN2,CNT)= " Amount P aid      :  "_$G(RCAM TPD)
  23524   "RTN","RCT CSWL2",67, 0)
  23525    S CNT=CNT +1,^TMP("R CTCSWE",$J ,RCNAME,RC DFN2,CNT)= " Fees              :  "_$G(RCFE E)
  23526   "RTN","RCT CSWL2",68, 0)
  23527    S RCCOMP= $J($P($G(^ PRCA(430,R CBILL,30)) ,U,4),10,2 )
  23528   "RTN","RCT CSWL2",69, 0)
  23529    S CNT=CNT +1,^TMP("R CTCSWE",$J ,RCNAME,RC DFN2,CNT)= " Compromi se Amount:  "_RCCOMP
  23530   "RTN","RCT CSWL2",70, 0)
  23531    Q
  23532   "RTN","RCT CSWL2",71, 0)
  23533    ;
  23534   "RTN","RCT CSWL2",72, 0)
  23535   BLDEXP ; B uild expan d screen 
  23536   "RTN","RCT CSWL2",73, 0)
  23537    D FULL^VA LM1
  23538   "RTN","RCT CSWL2",74, 0)
  23539    N VALMCNT ,RCXX,LINE
  23540   "RTN","RCT CSWL2",75, 0)
  23541    S VALMCNT =0
  23542   "RTN","RCT CSWL2",76, 0)
  23543    S RCXX=""
  23544   "RTN","RCT CSWL2",77, 0)
  23545    F  S RCXX =$O(^TMP(" RCTCSWE",$ J,RCNAME,R CDFN2,RCXX )) Q:+RCXX =0  D
  23546   "RTN","RCT CSWL2",78, 0)
  23547    . S LINE= ^TMP("RCTC SWE",$J,RC NAME,RCDFN 2,RCXX)
  23548   "RTN","RCT CSWL2",79, 0)
  23549    . S VALMC NT=VALMCNT +1
  23550   "RTN","RCT CSWL2",80, 0)
  23551    . D SET^V ALM10(VALM CNT,LINE," ")
  23552   "RTN","RCT CSWL2",81, 0)
  23553    S VALMCNT =VALMCNT+1
  23554   "RTN","RCT CSWL2",82, 0)
  23555    Q
  23556   "RTN","RCT CSWL2",83, 0)
  23557    ; 
  23558   "RTN","RCT CSWL2",84, 0)
  23559   HELP ; --  help code
  23560   "RTN","RCT CSWL2",85, 0)
  23561    N X
  23562   "RTN","RCT CSWL2",86, 0)
  23563    S X="?" D  DISP^XQOR M1 W !!
  23564   "RTN","RCT CSWL2",87, 0)
  23565    Q
  23566   "RTN","RCT CSWL2",88, 0)
  23567    ;
  23568   "RTN","RCT CSWL2",89, 0)
  23569   EXIT ; --  exit code
  23570   "RTN","RCT CSWL2",90, 0)
  23571    K ^TMP("R CTCSWE",$J )
  23572   "RTN","RCT CSWL2",91, 0)
  23573    D ^%ZISC
  23574   "RTN","RCT CSWL2",92, 0)
  23575    S VALMBCK ="R" Q
  23576   "RTN","RCT CSWL2",93, 0)
  23577    Q
  23578   "RTN","RCT OPD")
  23579   0^43^B7155 6644^B7012 3756
  23580   "RTN","RCT OPD",1,0)
  23581   RCTOPD ;WA SH IRMFO@A LTOONA,PA/ TJK-TOP TR ANSMISSION  ;2/11/00  3:34 PM
  23582   "RTN","RCT OPD",2,0)
  23583   V ;;4.5;Ac counts Rec eivable;** 141,187,22 4,236,229, 301,315**; Mar 20, 19 95;Build 5 5
  23584   "RTN","RCT OPD",3,0)
  23585    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  23586   "RTN","RCT OPD",4,0)
  23587   ENTER ;Ent ry point f rom nightl y process
  23588   "RTN","RCT OPD",5,0)
  23589    Q:'$D(RCD OC)
  23590   "RTN","RCT OPD",6,0)
  23591    N DEBTOR, BILL,DEBTO R0,B0,B6,B 7,P121DT,P RIN,INT,AD MIN,B4  ;P RCA*4.5*31 5 - P181Dt  change to  P121DT -  FY16 HAPE  RRE [TOPS]
  23592   "RTN","RCT OPD",7,0)
  23593    N EFFDT,D FN,CNTR,SI TE,LN,FN,M N,DOB,SITE ,F60DT,VAD M,DEBTOR4, DEBTOR6
  23594   "RTN","RCT OPD",8,0)
  23595    N PHONE,Q UIT,TOTAL, ZIPCODE,FU LLNM,RCNT, REPAY,X1,X 2
  23596   "RTN","RCT OPD",9,0)
  23597    N ERROR,A DDR,CAT,BI LLDT,P10YD T,CURRTOT, HOLD,SITEC D,RCNEW,AC TDT
  23598   "RTN","RCT OPD",10,0)
  23599    ;
  23600   "RTN","RCT OPD",11,0)
  23601    ;initiali ze tempora ry global,  variables
  23602   "RTN","RCT OPD",12,0)
  23603    ;
  23604   "RTN","RCT OPD",13,0)
  23605    K ^XTMP(" RCTOPD") S  ^XTMP("RC TOPD",0)=$ $FMADD^XLF DT(DT,5)_" ^"_DT   ;P RCA*4.5*31 5 Allow gl obal to be  purged in  5 days
  23606   "RTN","RCT OPD",14,0)
  23607    S SITE=$E ($$SITE^RC MSITE(),1, 3),SITECD= $P(^RC(342 ,1,3),U,5)
  23608   "RTN","RCT OPD",15,0)
  23609    S X1=DT,X 2=-121 D C ^%DTC S (P 121DT,EFFD T)=X  ; PR CA*4.5*315  - FY16 HA PE RRE [TO PS] - chan ge -181 to  -121 (120  vs 180 da ys)
  23610   "RTN","RCT OPD",16,0)
  23611    S X1=DT,X 2=-3650 D  C^%DTC S P 10YDT=X
  23612   "RTN","RCT OPD",17,0)
  23613    S X1=DT,X 2=+60 D C^ %DTC S F60 DT=X
  23614   "RTN","RCT OPD",18,0)
  23615    S ACTDT=3 150801 ;ac tivation d ate for al l sites ex cept beckl ey, little  rock, ups tate ny 
  23616   "RTN","RCT OPD",19,0)
  23617    S:SITE=59 8 ACTDT=31 50201 ;act ivation da te for lit tle rock
  23618   "RTN","RCT OPD",20,0)
  23619    S:SITE=51 7 ACTDT=31 50201 ;act ivation da te for bec kley
  23620   "RTN","RCT OPD",21,0)
  23621    S:SITE=52 8 ACTDT=31 50201 ;act ivation da te for ups tate ny
  23622   "RTN","RCT OPD",22,0)
  23623    S (CNTR(1 ),CNTR(2), CNTR(4),DE BTOR,RCNT) =0
  23624   "RTN","RCT OPD",23,0)
  23625    ;
  23626   "RTN","RCT OPD",24,0)
  23627    ;branch i f recertif ication do cument
  23628   "RTN","RCT OPD",25,0)
  23629    I RCDOC=" Y" D RECER T G EXIT
  23630   "RTN","RCT OPD",26,0)
  23631    ;
  23632   "RTN","RCT OPD",27,0)
  23633    ;branch t o do updat e document s
  23634   "RTN","RCT OPD",28,0)
  23635    D UPDATE  I RCDOC="U " G EXIT
  23636   "RTN","RCT OPD",29,0)
  23637    ;
  23638   "RTN","RCT OPD",30,0)
  23639    ;master s heet compi lation
  23640   "RTN","RCT OPD",31,0)
  23641    ;
  23642   "RTN","RCT OPD",32,0)
  23643    F  S DEBT OR=$O(^PRC A(430,"C", DEBTOR)) Q :DEBTOR'?1 N.N  D
  23644   "RTN","RCT OPD",33,0)
  23645    .N X,RCDF N
  23646   "RTN","RCT OPD",34,0)
  23647    .S RCDFN= $G(^RCD(34 0,DEBTOR,0 ))
  23648   "RTN","RCT OPD",35,0)
  23649    .I $P(RCD FN,";",2)[ "DPT",$$EM ERES^PRCAU TL(+RCDFN) ]"" Q  ;st op the mas ter sheet  compilatio n for hurr icane Katr ina sites  (patients)
  23650   "RTN","RCT OPD",36,0)
  23651       .Q:$D( ^RCD(340," TOP",DEBTO R))
  23652   "RTN","RCT OPD",37,0)
  23653       .; qui t if debto r address  marked unk nown
  23654   "RTN","RCT OPD",38,0)
  23655       .Q:$P( $G(^RCD(34 0,+DEBTOR, 1)),"^",9) =1
  23656   "RTN","RCT OPD",39,0)
  23657       .S DEB TOR6=$G(^R CD(340,DEB TOR,6)),DE BTOR0=$G(^ (0)),HOLD= 0,RCNEW=1
  23658   "RTN","RCT OPD",40,0)
  23659       .I $P( DEBTOR6,U, 2),'$P(DEB TOR6,U,3)  Q
  23660   "RTN","RCT OPD",41,0)
  23661       .S QUI T=1,FILE=$ $FILE(DEBT OR0) Q:'FI LE
  23662   "RTN","RCT OPD",42,0)
  23663       .S EFF DT=P121DT
  23664   "RTN","RCT OPD",43,0)
  23665       .D PRO C(DEBTOR,. QUIT,FILE, .HOLD,.EFF DT) Q:QUIT
  23666   "RTN","RCT OPD",44,0)
  23667       .D EN1 ^RCTOP2(DE BTOR,"M",F ILE)
  23668   "RTN","RCT OPD",45,0)
  23669       .D EN1 ^RCTOP1(DE BTOR,TOTAL ,"M",EFFDT ,0,FILE)
  23670   "RTN","RCT OPD",46,0)
  23671       .;set  hold date  in file fo r employee , ex-emplo yee, vendo r records
  23672   "RTN","RCT OPD",47,0)
  23673       .;Aust in holds t hese for 6 0 days bef ore transm itting to  TOP
  23674   "RTN","RCT OPD",48,0)
  23675       .I $G( HOLD) S $P (^RCD(340, DEBTOR,6), U,6)=F60DT
  23676   "RTN","RCT OPD",49,0)
  23677       .Q
  23678   "RTN","RCT OPD",50,0)
  23679    ;compile  documents  into mail  messages-- sets refer ral date i n 430
  23680   "RTN","RCT OPD",51,0)
  23681    D COMPILE
  23682   "RTN","RCT OPD",52,0)
  23683   EXIT K RCD OC,^XTMP(" RCTOPD"),^ TMP("RCTOP D"),XMDUZ  D KVAR^VAD PT
  23684   "RTN","RCT OPD",53,0)
  23685    Q
  23686   "RTN","RCT OPD",54,0)
  23687    ;
  23688   "RTN","RCT OPD",55,0)
  23689   UPDATE ;we ekly updat e compilat ion
  23690   "RTN","RCT OPD",56,0)
  23691    F  S DEBT OR=$O(^RCD (340,"TOP" ,DEBTOR))  Q:DEBTOR'? 1N.N  D
  23692   "RTN","RCT OPD",57,0)
  23693       .S QUI T=1,DEBTOR 0=^RCD(340 ,DEBTOR,0) ,DEBTOR6=^ (6),DEBTOR 4=^(4),FIL E=$$FILE(D EBTOR0),EF FDT=$P(DEB TOR4,U,6), RCNEW=0
  23694   "RTN","RCT OPD",58,0)
  23695       .D EN1 ^RCTOP2(DE BTOR,"U",F ILE)
  23696   "RTN","RCT OPD",59,0)
  23697       .D PRO C(DEBTOR,. QUIT,FILE, 0,.EFFDT)  I QUIT D   Q
  23698   "RTN","RCT OPD",60,0)
  23699          ..; process ty pe 4 docum ent if nec essary
  23700   "RTN","RCT OPD",61,0)
  23701          ..S  TAXID=$$T AXID^RCTOP 1(DEBTOR,F ILE),OTAXI D=$P(DEBTO R4,U)
  23702   "RTN","RCT OPD",62,0)
  23703          ..S  NAME=$$NA ME^RCTOP1( +DEBTOR0,F ILE),ONAME =$P(DEBTOR 4,U,2),NAM E=$P(NAME, U)
  23704   "RTN","RCT OPD",63,0)
  23705          ..I  NAME=ONAM E,TAXID=OT AXID Q
  23706   "RTN","RCT OPD",64,0)
  23707          ..D  EN1^RCTOP 4(NAME,TAX ID,DEBTOR4 ,DEBTOR,FI LE)
  23708   "RTN","RCT OPD",65,0)
  23709          ..Q
  23710   "RTN","RCT OPD",66,0)
  23711       .D EN1 ^RCTOP1(DE BTOR,TOTAL ,"U",EFFDT ,0,FILE)
  23712   "RTN","RCT OPD",67,0)
  23713       .Q
  23714   "RTN","RCT OPD",68,0)
  23715    ;refund/r efund reve rsal docum ents
  23716   "RTN","RCT OPD",69,0)
  23717    D REFDOC
  23718   "RTN","RCT OPD",70,0)
  23719    ;compile  documents  into mail  messages-- sets refer ral date i n 430
  23720   "RTN","RCT OPD",71,0)
  23721    D:$G(RCDO C)="U" COM PILE
  23722   "RTN","RCT OPD",72,0)
  23723    Q
  23724   "RTN","RCT OPD",73,0)
  23725    ;
  23726   "RTN","RCT OPD",74,0)
  23727   RECERT ;se nd yearly  recertific ation docu ments
  23728   "RTN","RCT OPD",75,0)
  23729    F  S DEBT OR=$O(^RCD (340,"TOP" ,DEBTOR))  Q:DEBTOR'? 1N.N  D
  23730   "RTN","RCT OPD",76,0)
  23731       .S DEB TOR4=$G(^R CD(340,DEB TOR,4)),TO TAL=$P(DEB TOR4,U,3), EFFDT=$P(D EBTOR4,U,6 ),DEBTOR0= $G(^(0)),F ILE=$$FILE (DEBTOR0)
  23732   "RTN","RCT OPD",77,0)
  23733       .I TOT AL D EN1^R CTOP1(DEBT OR,TOTAL," Y",EFFDT,0 ,FILE)
  23734   "RTN","RCT OPD",78,0)
  23735       .Q
  23736   "RTN","RCT OPD",79,0)
  23737    ;compile  documents  into mail  messages
  23738   "RTN","RCT OPD",80,0)
  23739    D COMPILE
  23740   "RTN","RCT OPD",81,0)
  23741    Q
  23742   "RTN","RCT OPD",82,0)
  23743    ;
  23744   "RTN","RCT OPD",83,0)
  23745   REFDOC ; r efund, ref und revers al documen ts
  23746   "RTN","RCT OPD",84,0)
  23747    N CODE,BI LL,DEBTOR, TOTAL,EFFD T,FILE,RFC ODE
  23748   "RTN","RCT OPD",85,0)
  23749    F RFCODE= 1,3 S CODE =$S(RFCODE =1:"R",1:" RV") D
  23750   "RTN","RCT OPD",86,0)
  23751       .S BIL L=0 F  S B ILL=$O(^PR CA(430,"TR EF",RFCODE ,BILL)) Q: 'BILL  D
  23752   "RTN","RCT OPD",87,0)
  23753          ..S  DEBTOR=$P ($G(^PRCA( 430,BILL,0 )),U,9) Q: 'DEBTOR
  23754   "RTN","RCT OPD",88,0)
  23755          ..S  TOTAL=$P( $G(^(7)),U ,18) Q:'TO TAL  ;NAKE D TO LINE  ABOVE
  23756   "RTN","RCT OPD",89,0)
  23757          ..S  EFFDT=$P( $G(^RCD(34 0,+DEBTOR, 4)),U,6),F ILE=$$FILE (^(0))
  23758   "RTN","RCT OPD",90,0)
  23759          ..D  EN1^RCTOP 1(DEBTOR,T OTAL,CODE, EFFDT,BILL ,FILE)
  23760   "RTN","RCT OPD",91,0)
  23761         ..Q
  23762   "RTN","RCT OPD",92,0)
  23763       .Q
  23764   "RTN","RCT OPD",93,0)
  23765    Q
  23766   "RTN","RCT OPD",94,0)
  23767    ;
  23768   "RTN","RCT OPD",95,0)
  23769   COMPILE ;c ompiles do cuments in to mail me ssages and  transmits  them
  23770   "RTN","RCT OPD",96,0)
  23771    ;builds m essage arr ay
  23772   "RTN","RCT OPD",97,0)
  23773    N CNT,SEQ ,REC,XMDUZ ,DOCTYPE,L RTYPE,XMSU B,XMTEXT,X MY,TSEQ,DO CAMT
  23774   "RTN","RCT OPD",98,0)
  23775    S (SEQ,TS EQ)=0
  23776   "RTN","RCT OPD",99,0)
  23777    F I=1,2,4  S TSEQ=TS EQ+($G(CNT R(I))\150) +$S($G(CNT R(I))#150: 1,1:0)
  23778   "RTN","RCT OPD",100,0 )
  23779    F DOCTYPE =1,2,4 D:$ D(^XTMP("R CTOPD",$J, DOCTYPE))  COMPILE1(D OCTYPE,CNT R(DOCTYPE) )
  23780   "RTN","RCT OPD",101,0 )
  23781    D USRMSG
  23782   "RTN","RCT OPD",102,0 )
  23783    Q
  23784   "RTN","RCT OPD",103,0 )
  23785   COMPILE1(D OCTYPE,CNT R) ; compi les each t ype of doc ument sepa rately
  23786   "RTN","RCT OPD",104,0 )
  23787    S RCNT=RC NT+CNTR
  23788   "RTN","RCT OPD",105,0 )
  23789    I '$G(LRT YPE) F I=1 ,2,4 S:$D( ^XTMP("RCT OPD",$J,I) ) LRTYPE=I
  23790   "RTN","RCT OPD",106,0 )
  23791    F CNT=1:1 :CNTR D
  23792   "RTN","RCT OPD",107,0 )
  23793       .D:CNT #150=1
  23794   "RTN","RCT OPD",108,0 )
  23795          ..K  ^XTMP("RC TOPD",$J," BUILD") S  SEQ=SEQ+1
  23796   "RTN","RCT OPD",109,0 )
  23797          ..S  REC=1,DOC AMT=0
  23798   "RTN","RCT OPD",110,0 )
  23799          ..Q
  23800   "RTN","RCT OPD",111,0 )
  23801       .S REC =REC+1,^XT MP("RCTOPD ",$J,"BUIL D",REC)=^X TMP("RCTOP D",$J,DOCT YPE,CNT)_U  S:DOCTYPE =1 DOCAMT= DOCAMT+($E (^(REC),13 5,146)/100 )
  23802   "RTN","RCT OPD",112,0 )
  23803       .I CNT R=CNT,LRTY PE=DOCTYPE  S ^XTMP(" RCTOPD",$J ,"BUILD",R EC+1)="END  OF TRANSM ISSION FOR  SITE# "_S ITE_":  TO TAL RECORD S: "_RCNT
  23804   "RTN","RCT OPD",113,0 )
  23805       .I $S( CNTR=CNT:1 ,CNT#150=0 :1,1:0) D
  23806   "RTN","RCT OPD",114,0 )
  23807          ..S  ^XTMP("RC TOPD",$J," BUILD",1)= SITE_U_$TR ($J(SEQ,2) ," ",0)_U_ $TR($J(TSE Q,2)," ",0 )_U_(REC-1 )_U_DOCAMT _U
  23808   "RTN","RCT OPD",115,0 )
  23809          ..S  XMDUZ="AR  PACKAGE"
  23810   "RTN","RCT OPD",116,0 )
  23811            ..S XMY(" URL          ")=""
  23812   "RTN","RCT OPD",117,0 )
  23813          ..S  XMY("G.TO P")=""
  23814   "RTN","RCT OPD",118,0 )
  23815          ..S  XMSUB=SIT E_"/TOP TR ANSMISSION /SEQ#: "_S EQ_"/"_$$N OW()
  23816   "RTN","RCT OPD",119,0 )
  23817          ..S  XMTEXT="^ XTMP(""RCT OPD"","_$J _",""BUILD "","
  23818   "RTN","RCT OPD",120,0 )
  23819          ..D  ^XMD
  23820   "RTN","RCT OPD",121,0 )
  23821          ..Q
  23822   "RTN","RCT OPD",122,0 )
  23823       .Q
  23824   "RTN","RCT OPD",123,0 )
  23825    Q
  23826   "RTN","RCT OPD",124,0 )
  23827    ;
  23828   "RTN","RCT OPD",125,0 )
  23829   USRMSG ;se nds mailma n message  of documen ts sent to  user
  23830   "RTN","RCT OPD",126,0 )
  23831    N XMY,XMD UZ,XMSUB,X ,RCNT
  23832   "RTN","RCT OPD",127,0 )
  23833    S XMDUZ=" AR PACKAGE ",XMY("G.T OP")=""
  23834   "RTN","RCT OPD",128,0 )
  23835    S XMSUB=" TOP "_$S(R CDOC="M":" MASTER/UPD ATE",RCDOC ="U":"UPDA TE",1:"REC ERTIFICATI ON")_" REC ORDS SENT  ON "_$E(DT ,4,5)_"/"_ $E(DT,6,7) _"/"_$E(DT ,2,3)
  23836   "RTN","RCT OPD",129,0 )
  23837    S ^XTMP(" RCTOPD",$J ,"REC1",1) ="Name                                TIN         TYPE        AMO UNT"
  23838   "RTN","RCT OPD",130,0 )
  23839    S ^XTMP(" RCTOPD",$J ,"REC1",2) ="----                                ---         ----        --- ---"
  23840   "RTN","RCT OPD",131,0 )
  23841    S X="",RC NT=3 F  S  X=$O(^XTMP ("RCTOPD", $J,"REC",X )) Q:X=""   S ^XTMP(" RCTOPD",$J ,"REC1",RC NT)=^(X),R CNT=RCNT+1
  23842   "RTN","RCT OPD",132,0 )
  23843    S ^XTMP(" RCTOPD",$J ,"REC1",RC NT)="Total  Records:  "_(RCNT-3)
  23844   "RTN","RCT OPD",133,0 )
  23845    S XMTEXT= "^XTMP(""R CTOPD"","_ $J_",""REC 1"","
  23846   "RTN","RCT OPD",134,0 )
  23847    D ^XMD
  23848   "RTN","RCT OPD",135,0 )
  23849    ;
  23850   "RTN","RCT OPD",136,0 )
  23851   THIRD ;sen ds mailman  message t o user if  no third l etter foun d
  23852   "RTN","RCT OPD",137,0 )
  23853    Q:'$D(^XT MP("RCTOPD ",$J,"THIR D"))
  23854   "RTN","RCT OPD",138,0 )
  23855    K ^XTMP(" RCTOPD",$J ,"REC1")
  23856   "RTN","RCT OPD",139,0 )
  23857    S XMDUZ=" AR PACKAGE ",XMY("G.T OP")=""
  23858   "RTN","RCT OPD",140,0 )
  23859    N TCT,TDE B,TDEB0,TB IL,TSP,FST
  23860   "RTN","RCT OPD",141,0 )
  23861    S XMSUB=" TOP QUALIF IED/NO 3RD  LETTER SE NT ON "_$E (DT,4,5)_" /"_$E(DT,6 ,7)_"/"_$E (DT,2,3)
  23862   "RTN","RCT OPD",142,0 )
  23863    S ^XTMP(" RCTOPD",$J ,"REC1",1) ="The foll owing list  of debtor  bills wer e not sent  to TOP."
  23864   "RTN","RCT OPD",143,0 )
  23865    S ^XTMP(" RCTOPD",$J ,"REC1",2) ="Please r eview debt or's accou nt to dete rmine why  the third"
  23866   "RTN","RCT OPD",144,0 )
  23867           S  ^XTMP("RCT OPD",$J,"R EC1",3)="n otice lett er has not  been sent :"
  23868   "RTN","RCT OPD",145,0 )
  23869    S ^XTMP(" RCTOPD",$J ,"REC1",4) ="Name                                  Bil l #"
  23870   "RTN","RCT OPD",146,0 )
  23871    S ^XTMP(" RCTOPD",$J ,"REC1",5) ="----                                  --- ---"
  23872   "RTN","RCT OPD",147,0 )
  23873    S TCT=6,T SP=0,TDEB= ""
  23874   "RTN","RCT OPD",148,0 )
  23875    F  S TDEB =$O(^XTMP( "RCTOPD",$ J,"THIRD", TDEB)) Q:T DEB=""  D
  23876   "RTN","RCT OPD",149,0 )
  23877    .S FST=1, TBIL=""
  23878   "RTN","RCT OPD",150,0 )
  23879    .I FST,TC T'=6 S ^XT MP("RCTOPD ",$J,"REC1 ",TCT)="", TCT=TCT+1, TSP=TSP+1
  23880   "RTN","RCT OPD",151,0 )
  23881    .F  S TBI L=$O(^XTMP ("RCTOPD", $J,"THIRD" ,TDEB,TBIL )) Q:TBIL= ""  D
  23882   "RTN","RCT OPD",152,0 )
  23883    ..S TDEB0 =$S(FST:TD EB,1:"")
  23884   "RTN","RCT OPD",153,0 )
  23885    ..S ^XTMP ("RCTOPD", $J,"REC1", TCT)=TDEB0 _$J(" ",35 -$L(TDEB0) )_TBIL
  23886   "RTN","RCT OPD",154,0 )
  23887    ..S TCT=T CT+1,FST=0
  23888   "RTN","RCT OPD",155,0 )
  23889    S ^XTMP(" RCTOPD",$J ,"REC1",TC T)="Total  records: " _(TCT-(6+T SP))
  23890   "RTN","RCT OPD",156,0 )
  23891    S XMTEXT= "^XTMP(""R CTOPD"","_ $J_",""REC 1"","
  23892   "RTN","RCT OPD",157,0 )
  23893    D ^XMD
  23894   "RTN","RCT OPD",158,0 )
  23895   COMPQ Q
  23896   "RTN","RCT OPD",159,0 )
  23897    ;
  23898   "RTN","RCT OPD",160,0 )
  23899   PROC(DEBTO R,QUIT,FIL E,HOLD,EFF DT) ;proce ss bills f or a speci fic debtor
  23900   "RTN","RCT OPD",161,0 )
  23901    K ^TMP("R CTOPD",$J, "BILL")
  23902   "RTN","RCT OPD",162,0 )
  23903    S DEBTOR0 =$G(^RCD(3 40,DEBTOR, 0))
  23904   "RTN","RCT OPD",163,0 )
  23905    Q:'FILE
  23906   "RTN","RCT OPD",164,0 )
  23907    I FILE=2  S DFN=+DEB TOR0 D DEM ^VADPT Q:$ E(VADM(2), 1,5)="0000 0"
  23908   "RTN","RCT OPD",165,0 )
  23909    S (BILL,T OTAL,REPAY )=0
  23910   "RTN","RCT OPD",166,0 )
  23911    I RCNEW,F ILE=440 S  HOLD=1
  23912   "RTN","RCT OPD",167,0 )
  23913    I 'RCNEW, $P(^RCD(34 0,DEBTOR,6 ),U,2),'$P (^(6),U,3)  G TOTAL
  23914   "RTN","RCT OPD",168,0 )
  23915    I RCNEW,$ D(^RCD(340 ,"DMC",1,D EBTOR)) G  TOTAL
  23916   "RTN","RCT OPD",169,0 )
  23917    F  S BILL =$O(^PRCA( 430,"C",DE BTOR,BILL) ) Q:BILL'? 1N.N  D
  23918   "RTN","RCT OPD",170,0 )
  23919       .I FIL E=2,+VADM( 6) S TOTAL =0,REPAY=1  Q
  23920   "RTN","RCT OPD",171,0 )
  23921       .S B0= $G(^PRCA(4 30,BILL,0) ),B4=$G(^( 4)),B6=$G( ^(6)),B7=$ G(^(7)),B1 4=$G(^(14) )
  23922   "RTN","RCT OPD",172,0 )
  23923       .Q:$P( B0,U,8)'=1 6
  23924   "RTN","RCT OPD",173,0 )
  23925       .Q:B4
  23926   "RTN","RCT OPD",174,0 )
  23927       .Q:'$P (B0,U,2)   S CAT=$P($ G(^PRCA(43 0.2,$P(B0, U,2),0)),U ,7)
  23928   "RTN","RCT OPD",175,0 )
  23929       .Q:'CA T  I ",16, 17,21,22,2 3,26,27,33 ,"[(","_CA T_",") Q
  23930   "RTN","RCT OPD",176,0 )
  23931       .Q:$D( ^PRCA(430, "TCSP",BIL L))  ;cros s-serviced  bills
  23932   "RTN","RCT OPD",177,0 )
  23933       .I '+B 14,($P(B6, U,21)'<ACT DT) I ",1, 2,3,24,29, 30,31,32,4 0,41,42,43 ,44,45,46, "[(","_CAT _",") Q  ; prca*4.5*3 01 cs acti vation dat e and 1st  party bill
  23934   "RTN","RCT OPD",178,0 )
  23935       .;chec k for DOJ  referral h ere
  23936   "RTN","RCT OPD",179,0 )
  23937       .I $P( B6,U,4),($ P(B6,U,5)= "DOJ") Q
  23938   "RTN","RCT OPD",180,0 )
  23939       .S BIL LDT=$P(B6, U,21) I (B ILLDT<P10Y DT)!(BILLD T>P121DT)! (BILLDT<$P (DEBTOR6,U ,3)) Q
  23940   "RTN","RCT OPD",181,0 )
  23941       .I '$P (B6,U,3) D   Q
  23942   "RTN","RCT OPD",182,0 )
  23943       ..;no  3rd letter  being sen
  23944   "RTN","RCT OPD",183,0 )
  23945       ..N TD EB,TFIL
  23946   "RTN","RCT OPD",184,0 )
  23947       ..S TD EB=$G(^RCD (340,DEBTO R,0)),TFIL =$$FILE(TD EB),TDEB=$ $NAME^RCTO P1(+TDEB,T FIL),TDEB= $P(TDEB,U, 2),^XTMP(" RCTOPD",$J ,"THIRD",T DEB,$P(B0, U))=""
  23948   "RTN","RCT OPD",185,0 )
  23949       .I RCN EW,CAT>12, CAT<15 S H OLD=1
  23950   "RTN","RCT OPD",186,0 )
  23951       .I BIL LDT,BILLDT <EFFDT S E FFDT=BILLD T
  23952   "RTN","RCT OPD",187,0 )
  23953       .S TOT AL=TOTAL+$ P(B7,U)+$P (B7,U,2)+$ P(B7,U,3)+ $P(B7,U,4) +$P(B7,U,5 )
  23954   "RTN","RCT OPD",188,0 )
  23955       .S ^TM P("RCTOPD" ,$J,"BILL" ,BILL)=""
  23956   "RTN","RCT OPD",189,0 )
  23957       .Q
  23958   "RTN","RCT OPD",190,0 )
  23959    ;
  23960   "RTN","RCT OPD",191,0 )
  23961   TOTAL ;set  transmiss ion total,  reset qui t variable
  23962   "RTN","RCT OPD",192,0 )
  23963    N RCSWINF O S RCSWIN FO=$$SWSTA T^IBBAPI()                    ;P RCA*4.5*22 9
  23964   "RTN","RCT OPD",193,0 )
  23965    I RCNEW,' +RCSWINFO  Q:TOTAL<25                               ;P RCA*4.5*22 9
  23966   "RTN","RCT OPD",194,0 )
  23967    I RCNEW,+ RCSWINFO Q :TOTAL'>0                                ;P RCA*4.5*22 9
  23968   "RTN","RCT OPD",195,0 )
  23969    ;
  23970   "RTN","RCT OPD",196,0 )
  23971    I 'RCNEW  S:TOTAL<25  TOTAL=0   S CURRTOT= $P($G(^RCD (340,DEBTO R,4)),U,3)  Q:CURRTOT =TOTAL  S  TOTAL=TOTA L-CURRTOT
  23972   "RTN","RCT OPD",197,0 )
  23973    S QUIT=0
  23974   "RTN","RCT OPD",198,0 )
  23975   PROCQ Q
  23976   "RTN","RCT OPD",199,0 )
  23977    ;
  23978   "RTN","RCT OPD",200,0 )
  23979   NOW() ;com piles curr ent date,t ime
  23980   "RTN","RCT OPD",201,0 )
  23981    N X,Y,%,% H
  23982   "RTN","RCT OPD",202,0 )
  23983    S %H=$H D  YX^%DTC
  23984   "RTN","RCT OPD",203,0 )
  23985    Q Y
  23986   "RTN","RCT OPD",204,0 )
  23987    ;
  23988   "RTN","RCT OPD",205,0 )
  23989   FILE(DEBTO R0) ;gets  file numbe r for debt or
  23990   "RTN","RCT OPD",206,0 )
  23991    S FILE=$P ($P(DEBTOR 0,U),";",2 )
  23992   "RTN","RCT OPD",207,0 )
  23993    S FILE=$S (FILE["DPT (":2,FILE[ "PRC(440": 440,FILE[" VA(200":20 0,1:0)
  23994   "RTN","RCT OPD",208,0 )
  23995   FILEQ Q FI LE
  23996   "RTN","RCT RAN")
  23997   0^36^B1642 4066^B1662 6175
  23998   "RTN","RCT RAN",1,0)
  23999   RCTRAN ;WA SH-ISC@ALT OONA,PA/LD B-Transact ion Histor y Report ; 1/19/95  4 :33 PM
  24000   "RTN","RCT RAN",2,0)
  24001    ;;4.5;Acc ounts Rece ivable;**1 04,154,315 **;Mar 20,  1995;Buil d 55
  24002   "RTN","RCT RAN",3,0)
  24003    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  24004   "RTN","RCT RAN",4,0)
  24005    ;
  24006   "RTN","RCT RAN",5,0)
  24007    N AMT,APP ,BDATE,BIL L,BY,CAT,D IC,DIR,DIR UT,EDATE,F UND,LINE,L N,NODE0,NO DE1,NODE2, NODE3,PG,P OP,PX2,RCX ,RCX1,TDAT ,TYP
  24008   "RTN","RCT RAN",6,0)
  24009    N X,X1,X1 1,X12,X1A, X2,X3,XFND ,XF1,Y,ZTD ESC,ZTRTN, ZTSAVE,%ZI S
  24010   "RTN","RCT RAN",7,0)
  24011   EN S X=$$D ATE^RCEVUT L1("")
  24012   "RTN","RCT RAN",8,0)
  24013    Q:X<0
  24014   "RTN","RCT RAN",9,0)
  24015    S BDATE=+ X,EDATE=$P (X,"^",2)
  24016   "RTN","RCT RAN",10,0)
  24017   TYPE S DIC ="^PRCA(43 0.3,",DIC( 0)="QEMZ"
  24018   "RTN","RCT RAN",11,0)
  24019    S Y=0 W ! ,"TRANSACT ION TYPE:  "_$S('$O(T YP("")):"A LL// ",1:" ")
  24020   "RTN","RCT RAN",12,0)
  24021    R X:DTIME  I '$T!(X= "^") Q
  24022   "RTN","RCT RAN",13,0)
  24023    I ((X="") !(X="ALL") ),'$O(TYP( "")) S (TY P,X)="ALL"  G CAT
  24024   "RTN","RCT RAN",14,0)
  24025    I X="" G  CAT
  24026   "RTN","RCT RAN",15,0)
  24027    I X'="ALL " D ^DIC S  TYP=+Y
  24028   "RTN","RCT RAN",16,0)
  24029    I X["?" W  !!,"Enter  'ALL' for  all types  of transa ctions in  the AR TRA NSACTION T YPE FILE", ! G TYPE
  24030   "RTN","RCT RAN",17,0)
  24031    ;I $P($G( ^PRCA(430. 3,+Y,0))," ^",3)>100  W !!,"This  is a STAT US. Enter  a transact ion type o nly.",! G  TYPE
  24032   "RTN","RCT RAN",18,0)
  24033    I TYP'="A LL",(+TYP> 0) S TYP(+ TYP)="" G  TYPE
  24034   "RTN","RCT RAN",19,0)
  24035    G:+TYP<0  TYPE
  24036   "RTN","RCT RAN",20,0)
  24037   CAT K DIC  S Y=0 W !, "CATEGORY  OF BILL: " _$S('$O(CA T("")):"AL L// ",1:"" )
  24038   "RTN","RCT RAN",21,0)
  24039    R X:DTIME  I '$T!(X= "^") Q
  24040   "RTN","RCT RAN",22,0)
  24041    I ((X="") !(X="ALL") ),'$O(CAT( "")) S (CA T,X)="ALL"  G DEV
  24042   "RTN","RCT RAN",23,0)
  24043    I X="" G  DEV
  24044   "RTN","RCT RAN",24,0)
  24045    I X'="ALL " S DIC="^ PRCA(430.2 ,",DIC(0)= "QEMZ" D ^ DIC S CAT= +Y
  24046   "RTN","RCT RAN",25,0)
  24047    I X["?" W  !!,"Enter  'ALL' for  all categ ories of b ills.",! G  CAT
  24048   "RTN","RCT RAN",26,0)
  24049    I CAT'="A LL",(+CAT> 0) S CAT(+ CAT)="" G  CAT
  24050   "RTN","RCT RAN",27,0)
  24051    G:+CAT<0  CAT
  24052   "RTN","RCT RAN",28,0)
  24053   DEV W !!," This repor t takes a  long time  to compile ."
  24054   "RTN","RCT RAN",29,0)
  24055    W !,"It i s recommen ded that i t be queue d to print  later.",! !
  24056   "RTN","RCT RAN",30,0)
  24057    S %ZIS="A EQ" D ^%ZI S G:POP EX IT
  24058   "RTN","RCT RAN",31,0)
  24059    I $D(IO(" Q")) D  Q
  24060   "RTN","RCT RAN",32,0)
  24061    .S ZTSAVE ("BDATE")= "",ZTSAVE( "EDATE")=" ",ZTSAVE(" TYP")="",Z TSAVE("CAT ")="",ZTRT N="DQ^RCTR AN",ZTDESC ="Transact ion Histor y Report"
  24062   "RTN","RCT RAN",33,0)
  24063    .S:$O(TYP ("")) ZTSA VE("TYP(") =""
  24064   "RTN","RCT RAN",34,0)
  24065    .S:$O(CAT ("")) ZTSA VE("CAT(") =""
  24066   "RTN","RCT RAN",35,0)
  24067    .D ^%ZTLO AD,^%ZISC, EXIT K ZTS AVE,ZTRTN  Q
  24068   "RTN","RCT RAN",36,0)
  24069    ;
  24070   "RTN","RCT RAN",37,0)
  24071   DQ ;Call t o build ar ray of pay ment trans actions
  24072   "RTN","RCT RAN",38,0)
  24073    ;
  24074   "RTN","RCT RAN",39,0)
  24075    U IO
  24076   "RTN","RCT RAN",40,0)
  24077    D DT^DICR W W:$E(IOS T,1,2)'="P -" @IOF S  PG=0,LINE= "",$P(LINE ,"-",79)=" "
  24078   "RTN","RCT RAN",41,0)
  24079    K ^TMP($J ) D TRANS^ RCTRAN1
  24080   "RTN","RCT RAN",42,0)
  24081    I '$D(^TM P($J)) D H DR^RCTRAN1  W !!,"The re is no a ctivity of  this type  during th is time pe riod."
  24082   "RTN","RCT RAN",43,0)
  24083    I $D(^TMP ($J)) D PR INT
  24084   "RTN","RCT RAN",44,0)
  24085    K ^TMP($J ) D ^%ZISC
  24086   "RTN","RCT RAN",45,0)
  24087    Q
  24088   "RTN","RCT RAN",46,0)
  24089    ;
  24090   "RTN","RCT RAN",47,0)
  24091   PRINT ;Pri nt transac tions of t ype within  selected  date range
  24092   "RTN","RCT RAN",48,0)
  24093    D HDR^RCT RAN1
  24094   "RTN","RCT RAN",49,0)
  24095    S (AMT("T OT"),RCX)= 0
  24096   "RTN","RCT RAN",50,0)
  24097    F  S RCX1 =RCX,RCX=$ O(^TMP($J, RCX)) Q:$D (DIRUT)!'R CX  S X11= 0 F  S X12 =X11,X11=$ O(^TMP($J, RCX,X11))  Q:$D(DIRUT )  Q:'X11   S XFND=""  F  S XFND =$O(^TMP($ J,RCX,X11, XFND)) Q:$ D(DIRUT)!( XFND="")   D FCHK D
  24098   "RTN","RCT RAN",51,0)
  24099    .S AMT(X1 1)=0,X2=0, PX2=X2 F   S X2=$O(^T MP($J,RCX, X11,XFND,X 2)) Q:$D(D IRUT)  D:' X2 SUB^RCT RAN1 Q:'X2   S X3=0 F   S AMT(X1 1,XFND)=0, X3=$O(^TMP ($J,RCX,X1 1,XFND,X2, X3)) Q:'X3 !$D(DIRUT)   D
  24100   "RTN","RCT RAN",52,0)
  24101    ..W:$$SLH ^RCFN01(X2 )'=$$SLH^R CFN01(PX2) !'LN !,$$S LH^RCFN01( X2)
  24102   "RTN","RCT RAN",53,0)
  24103    ..W:RCX'= RCX1!'LN ? 12,$E($P($ G(^PRCA(43 0.3,+RCX,0 )),"^"),1, 23)
  24104   "RTN","RCT RAN",54,0)
  24105    ..W ?37,$ P($G(^PRCA (430.2,+X1 1,0)),"^", 2)
  24106   "RTN","RCT RAN",55,0)
  24107    ..S BILL= $P(^TMP($J ,RCX,X11,X FND,X2,X3) ,"^",2) W  ?41,BILL
  24108   "RTN","RCT RAN",56,0)
  24109    ..W ?55,$ J(X3,8)
  24110   "RTN","RCT RAN",57,0)
  24111    ..S AMT=+ ^TMP($J,RC X,X11,XFND ,X2,X3)
  24112   "RTN","RCT RAN",58,0)
  24113    ..I ",2,8 ,9,10,11,1 4,19,47,34 ,35,29,"[( ","_TYP_", ") I AMT'< 0 S AMT=-A MT
  24114   "RTN","RCT RAN",59,0)
  24115    ..I ",2,8 ,9,10,11,1 2,14,19,47 ,34,35,29, "'[(","_TY P_",") I A MT<0 S AMT =-AMT
  24116   "RTN","RCT RAN",60,0)
  24117    ..I +CAT= 26,TYP=1 I  AMT'<0 S  AMT=-AMT
  24118   "RTN","RCT RAN",61,0)
  24119    ..I +CAT= 26,TYP=35  I AMT'<0 S  AMT=-AMT
  24120   "RTN","RCT RAN",62,0)
  24121    ..S AMT(" TOT")=AMT( "TOT")+AMT
  24122   "RTN","RCT RAN",63,0)
  24123    ..S AMT(X 11)=AMT(X1 1)+AMT
  24124   "RTN","RCT RAN",64,0)
  24125    ..S AMT(X 11,XFND)=A MT(X11,XFN D)+AMT
  24126   "RTN","RCT RAN",65,0)
  24127    ..S:AMT<0  AMT=-AMT  W ?64,$J(A MT,11,2)
  24128   "RTN","RCT RAN",66,0)
  24129    ..S BY=$P (^TMP($J,R CX,X11,XFN D,X2,X3)," ^",3) S:BY  BY=$P($G( ^VA(200,+B Y,0)),"^", 2)
  24130   "RTN","RCT RAN",67,0)
  24131    ..W ?76,B Y
  24132   "RTN","RCT RAN",68,0)
  24133    ..I RCX=4 5 W !?10,$ P($G(^PRCA (433,+X3,5 )),"^",2), !
  24134   "RTN","RCT RAN",69,0)
  24135    ..S LN=LN +1
  24136   "RTN","RCT RAN",70,0)
  24137    ..I $O(^T MP($J,RCX) )!TYP,$Y+3 >IOSL D
  24138   "RTN","RCT RAN",71,0)
  24139    ...I $E(I OST,1,2)=" C-" S DIR( 0)="E" K D IRUT D ^DI R Q:$D(DIR UT)
  24140   "RTN","RCT RAN",72,0)
  24141    ...W @IOF  D HDR^RCT RAN1
  24142   "RTN","RCT RAN",73,0)
  24143    Q:$D(DIRU T)
  24144   "RTN","RCT RAN",74,0)
  24145    I $O(^TMP ($J,RCX))! TYP,($Y+10 >IOSL) D
  24146   "RTN","RCT RAN",75,0)
  24147    .I $E(IOS T,1,2)="C- " S DIR(0) ="E" K DIR UT D ^DIR  Q:$D(DIRUT )
  24148   "RTN","RCT RAN",76,0)
  24149    .W @IOF D  HDR^RCTRA N1
  24150   "RTN","RCT RAN",77,0)
  24151    Q:$D(DIRU T)
  24152   "RTN","RCT RAN",78,0)
  24153    S:AMT("TO T")<0 AMT( "TOT")=-AM T("TOT") W :TYP !?64, "--------- ---",!,?57 ,"TOTAL:", ?64,$J(AMT ("TOT"),12 ,2)
  24154   "RTN","RCT RAN",79,0)
  24155    D KEY^RCT RAN1
  24156   "RTN","RCT RAN",80,0)
  24157    Q
  24158   "RTN","RCT RAN",81,0)
  24159    ;
  24160   "RTN","RCT RAN",82,0)
  24161   FCHK ;Chec k fund
  24162   "RTN","RCT RAN",83,0)
  24163    W !,"FUND : ",XFND
  24164   "RTN","RCT RAN",84,0)
  24165    Q
  24166   "RTN","RCT RAN",85,0)
  24167    ;
  24168   "RTN","RCT RAN",86,0)
  24169   EXIT ;Exit  routine
  24170   "RTN","RCT RAN",87,0)
  24171    K ^TMP($J ) D ^%ZISC  Q
  24172   "RTN","RCW ROFF")
  24173   0^31^B4435 8365^B4015 1788
  24174   "RTN","RCW ROFF",1,0)
  24175   RCWROFF ;W ISC/RFJ-wr ite off, t erminated  ;1 Feb 200 0
  24176   "RTN","RCW ROFF",2,0)
  24177    ;;4.5;Acc ounts Rece ivable;**1 68,204,309 ,301,315** ;Mar 20, 1 995;Build  55
  24178   "RTN","RCW ROFF",3,0)
  24179    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  24180   "RTN","RCW ROFF",4,0)
  24181    Q
  24182   "RTN","RCW ROFF",5,0)
  24183    ;
  24184   "RTN","RCW ROFF",6,0)
  24185    ;
  24186   "RTN","RCW ROFF",7,0)
  24187   8 ;  termi nated by f iscal offi cer (trant ype=8) (me nu option)
  24188   "RTN","RCW ROFF",8,0)
  24189    N RCDRSTR G
  24190   "RTN","RCW ROFF",9,0)
  24191    S RCDRSTR G="11TERMI NATION DAT E;"
  24192   "RTN","RCW ROFF",10,0 )
  24193    S RCDRSTR G=RCDRSTRG _"17;"  ;t ermination  reason
  24194   "RTN","RCW ROFF",11,0 )
  24195    D MAIN("8 ^Fiscal Of ficer Term ination",R CDRSTRG)
  24196   "RTN","RCW ROFF",12,0 )
  24197    Q
  24198   "RTN","RCW ROFF",13,0 )
  24199    ;
  24200   "RTN","RCW ROFF",14,0 )
  24201    ;
  24202   "RTN","RCW ROFF",15,0 )
  24203   9 ;  termi nated by c ompromise  (trantype= 9) (menu o ption)
  24204   "RTN","RCW ROFF",16,0 )
  24205    N RCDRSTR G
  24206   "RTN","RCW ROFF",17,0 )
  24207    S RCDRSTR G="11TERMI NATION DAT E;"
  24208   "RTN","RCW ROFF",18,0 )
  24209    S RCDRSTR G=RCDRSTRG _"17;"  ;t ermination  reason
  24210   "RTN","RCW ROFF",19,0 )
  24211    D MAIN("9 ^Compromis e Terminat ion",RCDRS TRG)
  24212   "RTN","RCW ROFF",20,0 )
  24213    Q
  24214   "RTN","RCW ROFF",21,0 )
  24215    ;
  24216   "RTN","RCW ROFF",22,0 )
  24217    ;
  24218   "RTN","RCW ROFF",23,0 )
  24219   A9 ;  comp romised by  rc/doj (u se trantyp e=9) (menu  option)
  24220   "RTN","RCW ROFF",24,0 )
  24221    N RCDRSTR G
  24222   "RTN","RCW ROFF",25,0 )
  24223    S RCDRSTR G="11TERMI NATION DAT E;"
  24224   "RTN","RCW ROFF",26,0 )
  24225    S RCDRSTR G=RCDRSTRG _"17;"  ;t ermination  reason
  24226   "RTN","RCW ROFF",27,0 )
  24227    D MAIN("9 ^Compromis e Terminat ion by RC/ DOJ",RCDRS TRG)
  24228   "RTN","RCW ROFF",28,0 )
  24229    Q
  24230   "RTN","RCW ROFF",29,0 )
  24231    ;
  24232   "RTN","RCW ROFF",30,0 )
  24233    ;
  24234   "RTN","RCW ROFF",31,0 )
  24235   10 ;  waiv ed in full  transacti on (tranty pe=10) (me nu option)
  24236   "RTN","RCW ROFF",32,0 )
  24237    D MAIN("1 0^Waiver", "11WAIVED  DATE;")
  24238   "RTN","RCW ROFF",33,0 )
  24239    Q
  24240   "RTN","RCW ROFF",34,0 )
  24241    ;
  24242   "RTN","RCW ROFF",35,0 )
  24243    ;
  24244   "RTN","RCW ROFF",36,0 )
  24245   A10 ;  wai ved by rc/ doj (use t rantype=10 ) (menu op tion)
  24246   "RTN","RCW ROFF",37,0 )
  24247    D MAIN("1 0^RC/DOJ W aiver","11 WAIVED DAT E;")
  24248   "RTN","RCW ROFF",38,0 )
  24249    Q
  24250   "RTN","RCW ROFF",39,0 )
  24251    ;
  24252   "RTN","RCW ROFF",40,0 )
  24253    ;
  24254   "RTN","RCW ROFF",41,0 )
  24255   29 ;  term inated by  rc/doj (tr antype=29)  (menu opt ion)
  24256   "RTN","RCW ROFF",42,0 )
  24257    N RCDRSTR G
  24258   "RTN","RCW ROFF",43,0 )
  24259    S RCDRSTR G="11TERMI NATION DAT E;"
  24260   "RTN","RCW ROFF",44,0 )
  24261    S RCDRSTR G=RCDRSTRG _"17;"  ;t ermination  reason
  24262   "RTN","RCW ROFF",45,0 )
  24263    D MAIN("2 9^RC/DOJ T ermination ",RCDRSTRG )
  24264   "RTN","RCW ROFF",46,0 )
  24265    Q
  24266   "RTN","RCW ROFF",47,0 )
  24267    ;
  24268   "RTN","RCW ROFF",48,0 )
  24269    ;
  24270   "RTN","RCW ROFF",49,0 )
  24271   47 ;  susp ended (tra ntype=47)  (menu opti on)
  24272   "RTN","RCW ROFF",50,0 )
  24273    N RCDRSTR G
  24274   "RTN","RCW ROFF",51,0 )
  24275    S RCDRSTR G="11SUSPE NDED DATE; "
  24276   "RTN","RCW ROFF",52,0 )
  24277    S RCDRSTR G=RCDRSTRG _"90R;"  ; suspension  type
  24278   "RTN","RCW ROFF",53,0 )
  24279    S RCDRSTR G=RCDRSTRG _"S RCX=$$ SUSTP^RCWR OFF(X);"
  24280   "RTN","RCW ROFF",54,0 )
  24281    S RCDRSTR G=RCDRSTRG _"5.02//// ^S X=RCX;"   ;brief c omment
  24282   "RTN","RCW ROFF",55,0 )
  24283    S RCDRSTR G=RCDRSTRG _"K RCX;"
  24284   "RTN","RCW ROFF",56,0 )
  24285    D MAIN("4 7^Suspensi on",RCDRST RG)
  24286   "RTN","RCW ROFF",57,0 )
  24287    Q
  24288   "RTN","RCW ROFF",58,0 )
  24289    ;
  24290   "RTN","RCW ROFF",59,0 )
  24291   SUSTP(X) ;  suspensio n types fo r brief co mment in * 309
  24292   "RTN","RCW ROFF",60,0 )
  24293    ; input-c ode betwee n 0 to 11
  24294   "RTN","RCW ROFF",61,0 )
  24295    ; output- text
  24296   "RTN","RCW ROFF",62,0 )
  24297    N IBX
  24298   "RTN","RCW ROFF",63,0 )
  24299    S IBX=$P( $T(SUSTX+X ),";;",2)
  24300   "RTN","RCW ROFF",64,0 )
  24301    Q IBX
  24302   "RTN","RCW ROFF",65,0 )
  24303    ;
  24304   "RTN","RCW ROFF",66,0 )
  24305   SUSTX ;;NO T CO-PAY S USPENSION
  24306   "RTN","RCW ROFF",67,0 )
  24307    ;;INITIAL  CO-PAY WA IVER
  24308   "RTN","RCW ROFF",68,0 )
  24309    ;;APPEAL  CO-PAY WAI VER
  24310   "RTN","RCW ROFF",69,0 )
  24311    ;;ADMINIS TRATIVE SU SPENSION
  24312   "RTN","RCW ROFF",70,0 )
  24313    ;;COMPROM ISE
  24314   "RTN","RCW ROFF",71,0 )
  24315    ;;TERMINA TION
  24316   "RTN","RCW ROFF",72,0 )
  24317    ;;BANKRUP TCY CHAP 7
  24318   "RTN","RCW ROFF",73,0 )
  24319    ;;BANKRUP TCY CHAP 1 3
  24320   "RTN","RCW ROFF",74,0 )
  24321    ;;BANKRUP TCY OTHER
  24322   "RTN","RCW ROFF",75,0 )
  24323    ;;PROBATE
  24324   "RTN","RCW ROFF",76,0 )
  24325    ;;CHOICE
  24326   "RTN","RCW ROFF",77,0 )
  24327    ;;DISPUTE
  24328   "RTN","RCW ROFF",78,0 )
  24329    ;
  24330   "RTN","RCW ROFF",79,0 )
  24331    ;
  24332   "RTN","RCW ROFF",80,0 )
  24333   MAIN(RCTRT YPE,RCDRST RG) ;  mai n subrouti ne to proc ess a waiv er, termin ation, sus pended tra nsaction
  24334   "RTN","RCW ROFF",81,0 )
  24335    ;  rctrty pe = trans action typ e^descript ion, examp le 10^waiv er
  24336   "RTN","RCW ROFF",82,0 )
  24337    ;  rcdrst rg = dr st ring used  when calli ng die
  24338   "RTN","RCW ROFF",83,0 )
  24339    I '$G(GOT BILL) N RC BILLDA  ;P RCA*4.5*31 5 Pass in  RCBILLDA
  24340   "RTN","RCW ROFF",84,0 )
  24341    N BALANCE ,DR,RCTRAN DA,Y
  24342   "RTN","RCW ROFF",85,0 )
  24343    F  D  Q:R CBILLDA<1! ($G(GOTBIL L))
  24344   "RTN","RCW ROFF",86,0 )
  24345    .   K RCT RANDA  ;do  not leave  around in  for loop
  24346   "RTN","RCW ROFF",87,0 )
  24347    .   ;  se lect a bil l
  24348   "RTN","RCW ROFF",88,0 )
  24349    .   I '$G (GOTBILL)  S RCBILLDA =$$GETABIL L^RCBEUBIL  I RCBILLD A<1 Q  ;PR CA*4.5*315
  24350   "RTN","RCW ROFF",89,0 )
  24351    .   I $D( ^PRCA(430, "TCSP",RCB ILLDA)) W  !,"BILL HA S BEEN REF ERRED TO C ROSS-SERVI CING.",!," NO TRANSAC TIONS ARE  ALLOWED."  D  Q  ;prc a*4.5*301
  24352   "RTN","RCW ROFF",90,0 )
  24353    . .  I +R CTRTYPE=10 !(+RCTRTYP E=47)!(+RC TRTYPE=9)! (+RCTRTYPE =8) W !,"* * THE RECA LL PROCESS  MUST BE U TILIZED PR IOR TO PER FORMING TH IS FUNCTIO N **"   ;p rca*4.5*30 1  
  24354   "RTN","RCW ROFF",91,0 )
  24355    .   ;  ch eck to see  if bill h as been re ferred to  rc/doj (6; 4 = referr al date)
  24356   "RTN","RCW ROFF",92,0 )
  24357    .   I $P( RCTRTYPE," ^",2)["RC/ DOJ",$P($G (^PRCA(430 ,RCBILLDA, 6)),"^",4) ="" W !,"T HIS ACCOUN T IS NOT R EFERRED TO  RC/DOJ."  Q
  24358   "RTN","RCW ROFF",93,0 )
  24359    .   ;  lo ck the bil l
  24360   "RTN","RCW ROFF",94,0 )
  24361    .   L +^P RCA(430,RC BILLDA):5  I '$T W !, "ANOTHER U SER IS CUR RENTLY WOR KING WITH  THIS BILL. " Q
  24362   "RTN","RCW ROFF",95,0 )
  24363    .   D SHO WBILL^RCWR OFF1(RCBIL LDA)
  24364   "RTN","RCW ROFF",96,0 )
  24365    .   I '$G (^PRCA(430 ,RCBILLDA, 7)) W !,"T HIS BILL H AS NO PRIN CIPAL BALA NCE." D UN LOCK Q
  24366   "RTN","RCW ROFF",97,0 )
  24367    .   ;  as k to enter  transacti on
  24368   "RTN","RCW ROFF",98,0 )
  24369    .   S Y=$ $ASKOK($P( RCTRTYPE," ^",2))           ; pr ca*4.5*315  changes
  24370   "RTN","RCW ROFF",99,0 )
  24371    .   I Y'= 1 D  Q                                 ; us er said No , or no re sponse, or  ^/timeout
  24372   "RTN","RCW ROFF",100, 0)
  24373    . .   D U NLOCK                                  ; un lock bill  and transa ction
  24374   "RTN","RCW ROFF",101, 0)
  24375    . .   I Y <0,'$G(GOT BILL) S RC BILLDA=0         ; ^  or timeout , get out  of this lo op
  24376   "RTN","RCW ROFF",102, 0)
  24377    . .   I Y <0,$G(GOTB ILL) S RCD PGQ=1            ; ^  or timeout , set spec ial variab le - see R CDPAPL1
  24378   "RTN","RCW ROFF",103, 0)
  24379    . .   Q
  24380   "RTN","RCW ROFF",104, 0)
  24381    .   ;
  24382   "RTN","RCW ROFF",105, 0)
  24383    .   ;  ad d a new tr ansaction  to file 43 3
  24384   "RTN","RCW ROFF",106, 0)
  24385    .   S RCT RANDA=$$AD D433^RCBEU TRA(RCBILL DA,$P(RCTR TYPE,"^"))  I 'RCTRAN DA W !,$P( RCTRANDA," ^",2) D UN LOCK Q
  24386   "RTN","RCW ROFF",107, 0)
  24387    .   W !,"   Transact ion number  ",RCTRAND A," added  ..."
  24388   "RTN","RCW ROFF",108, 0)
  24389    .   ;
  24390   "RTN","RCW ROFF",109, 0)
  24391    .   ;  se t up dr st ring for d ie call
  24392   "RTN","RCW ROFF",110, 0)
  24393    .   S DR= RCDRSTRG_" 41;"  ;com ment
  24394   "RTN","RCW ROFF",111, 0)
  24395    .   ;  bi ll amount  moved to t ransaction  amount
  24396   "RTN","RCW ROFF",112, 0)
  24397    .   S BAL ANCE=$P($G (^PRCA(430 ,RCBILLDA, 7)),"^",1, 5)
  24398   "RTN","RCW ROFF",113, 0)
  24399    .   S DR= DR_"15//// "_($P(BALA NCE,"^")+$ P(BALANCE, "^",2)+$P( BALANCE,"^ ",3)+$P(BA LANCE,"^", 4)+$P(BALA NCE,"^",5) )_";"
  24400   "RTN","RCW ROFF",114, 0)
  24401    .   I $P( BALANCE,"^ ",1) S DR= DR_"81//// "_+$P(BALA NCE,"^",1) _";"   ;pr incipal
  24402   "RTN","RCW ROFF",115, 0)
  24403    .   I $P( BALANCE,"^ ",2) S DR= DR_"82//// "_+$P(BALA NCE,"^",2) _";"   ;in terest
  24404   "RTN","RCW ROFF",116, 0)
  24405    .   I $P( BALANCE,"^ ",3) S DR= DR_"83//// "_+$P(BALA NCE,"^",3) _";"   ;ad min
  24406   "RTN","RCW ROFF",117, 0)
  24407    .   I $P( BALANCE,"^ ",4) S DR= DR_"84//// "_+$P(BALA NCE,"^",4) _";"   ;ma rshal fee
  24408   "RTN","RCW ROFF",118, 0)
  24409    .   I $P( BALANCE,"^ ",5) S DR= DR_"85//// "_+$P(BALA NCE,"^",5) _";"   ;co urt cost
  24410   "RTN","RCW ROFF",119, 0)
  24411    .   ;
  24412   "RTN","RCW ROFF",120, 0)
  24413    .   ;  ed it the fie lds
  24414   "RTN","RCW ROFF",121, 0)
  24415    .   S Y=$ $EDIT433^R CBEUTRA(RC TRANDA,DR)
  24416   "RTN","RCW ROFF",122, 0)
  24417    .   I 'Y  W !,$P(Y," ^",2) D DE L433^RCBEU TRA(RCTRAN DA,"",0),U NLOCK Q
  24418   "RTN","RCW ROFF",123, 0)
  24419    .   ;  se t the bill  and trans action as  RC/DOJ
  24420   "RTN","RCW ROFF",124, 0)
  24421    .   I $P( RCTRTYPE," ^",2)["RC/ DOJ" D SET RCDOJ^RCBE UBIL(RCBIL LDA,RCTRAN DA,"RC")
  24422   "RTN","RCW ROFF",125, 0)
  24423    .   ;  ch ange the s tatus of t he bill
  24424   "RTN","RCW ROFF",126, 0)
  24425    .   I $P( RCTRTYPE," ^")'=47 D  CHGSTAT^RC BEUBIL(RCB ILLDA,23)   ;write of f
  24426   "RTN","RCW ROFF",127, 0)
  24427    .   I $P( RCTRTYPE," ^")=47 D C HGSTAT^RCB EUBIL(RCBI LLDA,40)    ;suspende d
  24428   "RTN","RCW ROFF",128, 0)
  24429    .   ;  ma rk transac tion as pr ocessed
  24430   "RTN","RCW ROFF",129, 0)
  24431    .   D PRO CESS^RCBEU TRA(RCTRAN DA)
  24432   "RTN","RCW ROFF",130, 0)
  24433    .   ;
  24434   "RTN","RCW ROFF",131, 0)
  24435    .   ;  cr eate fms w rite off d ocument, i f not accr ued and no t suspende d (47) tra nsaction
  24436   "RTN","RCW ROFF",132, 0)
  24437    .   I '$$ ACCK^PRCAA CC(RCBILLD A),$P($G(^ PRCA(433,R CTRANDA,1) ),"^",2)'= 47 D FMSDO C(RCTRANDA )
  24438   "RTN","RCW ROFF",133, 0)
  24439    .   ;
  24440   "RTN","RCW ROFF",134, 0)
  24441    .   W !,"   * * * *  * ",$P(RCT RTYPE,"^", 2)," has b een PROCES SED! * * *  * *"
  24442   "RTN","RCW ROFF",135, 0)
  24443    .   I '$G (REFMS)&(D T>$$LDATE^ RCRJR(DT))  S Y=$E($$ FPS^RCAMFN 01(DT,1),1 ,5)_"01" D  DD^%DT W  !!,"   * *  * * Trans mission wi ll be held  until "_Y _" * * * * "
  24444   "RTN","RCW ROFF",136, 0)
  24445    .   D UNL OCK
  24446   "RTN","RCW ROFF",137, 0)
  24447    I $G(GOTB ILL),'$G(R CDPGQ) D W AIT^VALM1        ;PRC A*4.5*315
  24448   "RTN","RCW ROFF",138, 0)
  24449    Q
  24450   "RTN","RCW ROFF",139, 0)
  24451    ;
  24452   "RTN","RCW ROFF",140, 0)
  24453    ;
  24454   "RTN","RCW ROFF",141, 0)
  24455   FMSDOC(RCT RANDA) ;   create fms  write off  document
  24456   "RTN","RCW ROFF",142, 0)
  24457    N Y
  24458   "RTN","RCW ROFF",143, 0)
  24459    W !!,"Cre ating FMS  Write-off  document . .. "
  24460   "RTN","RCW ROFF",144, 0)
  24461    S Y=$$BUI LDWR^RCXFM SW1(RCTRAN DA)
  24462   "RTN","RCW ROFF",145, 0)
  24463    I Y W $P( Y,"^",2),"  created."
  24464   "RTN","RCW ROFF",146, 0)
  24465    E  W "ERR OR: ",$P(Y ,"^",2)
  24466   "RTN","RCW ROFF",147, 0)
  24467    Q
  24468   "RTN","RCW ROFF",148, 0)
  24469    ;
  24470   "RTN","RCW ROFF",149, 0)
  24471    ;
  24472   "RTN","RCW ROFF",150, 0)
  24473   UNLOCK ;   unlock bil l and tran saction
  24474   "RTN","RCW ROFF",151, 0)
  24475    L -^PRCA( 430,RCBILL DA)
  24476   "RTN","RCW ROFF",152, 0)
  24477    I $G(RCTR ANDA) L -^ PRCA(433,R CTRANDA)
  24478   "RTN","RCW ROFF",153, 0)
  24479    Q
  24480   "RTN","RCW ROFF",154, 0)
  24481    ;
  24482   "RTN","RCW ROFF",155, 0)
  24483    ;
  24484   "RTN","RCW ROFF",156, 0)
  24485   ASKOK(TRAN TYPE) ;  a sk record  transactio n
  24486   "RTN","RCW ROFF",157, 0)
  24487    N DIR,DIQ 2,DIRUT,DT OUT,DUOUT, X,Y
  24488   "RTN","RCW ROFF",158, 0)
  24489    S DIR(0)= "YO",DIR(" B")="NO"
  24490   "RTN","RCW ROFF",159, 0)
  24491    S DIR("A" )="  Are y ou sure yo u want to  record thi s bill as  a "
  24492   "RTN","RCW ROFF",160, 0)
  24493    I $L(TRAN TYPE)<20 S  DIR("A")= DIR("A")_T RANTYPE
  24494   "RTN","RCW ROFF",161, 0)
  24495    E  S DIR( "A",1)=DIR ("A"),DIR( "A")="  "_ TRANTYPE
  24496   "RTN","RCW ROFF",162, 0)
  24497    W ! D ^DI R
  24498   "RTN","RCW ROFF",163, 0)
  24499    I $G(DTOU T)!($G(DUO UT)) S Y=- 1
  24500   "RTN","RCW ROFF",164, 0)
  24501    Q Y
  24502   "RTN","RCX FMSPR")
  24503   0^49^B3766 0808^B2761 3579
  24504   "RTN","RCX FMSPR",1,0 )
  24505   RCXFMSPR ; WISC/RFJ-p rint reven ue source  codes ;8/3 1/10 11:34 am
  24506   "RTN","RCX FMSPR",2,0 )
  24507    ;;4.5;Acc ounts Rece ivable;**9 0,96,101,1 56,170,203 ,273,310,3 15**;Mar 2 0, 1995;Bu ild 55
  24508   "RTN","RCX FMSPR",3,0 )
  24509    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  24510   "RTN","RCX FMSPR",4,0 )
  24511    W !,"This  option wi ll print o ut a list  of the rev enue sourc e codes se nt from"
  24512   "RTN","RCX FMSPR",5,0 )
  24513    W !,"the  VISTA syst em to FMS. "
  24514   "RTN","RCX FMSPR",6,0 )
  24515    ;
  24516   "RTN","RCX FMSPR",7,0 )
  24517    ;  select  device
  24518   "RTN","RCX FMSPR",8,0 )
  24519    W ! S %ZI S="Q" D ^% ZIS Q:POP
  24520   "RTN","RCX FMSPR",9,0 )
  24521    I $D(IO(" Q")) D  D  ^%ZTLOAD K  IO("Q"),Z TSK Q
  24522   "RTN","RCX FMSPR",10, 0)
  24523    .   S ZTD ESC="Reven ue Source  Code Repor t",ZTRTN=" DQ^RCXFMSP R"
  24524   "RTN","RCX FMSPR",11, 0)
  24525    .   S ZTS AVE("ZTREQ ")="@"
  24526   "RTN","RCX FMSPR",12, 0)
  24527    W !!,"<*>  please wa it <*>"
  24528   "RTN","RCX FMSPR",13, 0)
  24529    ;
  24530   "RTN","RCX FMSPR",14, 0)
  24531   DQ ;  queu e starts h ere
  24532   "RTN","RCX FMSPR",15, 0)
  24533    N %,%I,BI NARY,COL2D ESC,COL3DE SC,COLUMN1 ,COLUMN2,C OLUMN3,COL UMN4
  24534   "RTN","RCX FMSPR",16, 0)
  24535    N DECIMAL ,DESCRIP,N OW,PAGE,RC STFLAG,SCR EEN,X,Y
  24536   "RTN","RCX FMSPR",17, 0)
  24537    D NOW^%DT C S Y=% D  DD^%DT S N OW=Y
  24538   "RTN","RCX FMSPR",18, 0)
  24539    S PAGE=1, SCREEN=0 I  '$D(ZTQUE UED),IO=IO (0),$E(IOS T)="C" S S CREEN=1
  24540   "RTN","RCX FMSPR",19, 0)
  24541    U IO D H
  24542   "RTN","RCX FMSPR",20, 0)
  24543    ;
  24544   "RTN","RCX FMSPR",21, 0)
  24545    S COLUMN1 ="A",COLUM N2="R",COL UMN3="R",C OLUMN4="V" ,DESCRIP=" Miscellane ous"
  24546   "RTN","RCX FMSPR",22, 0)
  24547    D WRITEIT
  24548   "RTN","RCX FMSPR",23, 0)
  24549    ;
  24550   "RTN","RCX FMSPR",24, 0)
  24551    ;  for no w, column  1 is alway s 8 and co lumn 4 is  always Z
  24552   "RTN","RCX FMSPR",25, 0)
  24553    S COLUMN1 =8,COLUMN4 ="Z"
  24554   "RTN","RCX FMSPR",26, 0)
  24555    F COLUMN2 =1:1:9,"A" ,"B","C"," D","E","F" ,"G","H"," I","J","K" ,"L","M"," Q","R","S" ,"T" D  Q: $G(RCSTFLA G)
  24556   "RTN","RCX FMSPR",27, 0)
  24557    .   S COL 2DESC=$P($ T(@("A"_CO LUMN2)),"; ",3)
  24558   "RTN","RCX FMSPR",28, 0)
  24559    .   ;
  24560   "RTN","RCX FMSPR",29, 0)
  24561    .   S COL UMN3=$S(CO LUMN2=5:"* ",1:"Z")
  24562   "RTN","RCX FMSPR",30, 0)
  24563    .   S DES CRIP=COL2D ESC D WRIT EIT
  24564   "RTN","RCX FMSPR",31, 0)
  24565    .   ;
  24566   "RTN","RCX FMSPR",32, 0)
  24567    .   I $G( RCSTFLAG)  Q
  24568   "RTN","RCX FMSPR",33, 0)
  24569    .   ;
  24570   "RTN","RCX FMSPR",34, 0)
  24571    .   ;  sh ow hsif -  disabled b y patch 20 3
  24572   "RTN","RCX FMSPR",35, 0)
  24573    .   ;I CO LUMN2="B"! (COLUMN2=" C") S DESC RIP=DESCRI P_" HSIF", COLUMN3=1  D WRITEIT
  24574   "RTN","RCX FMSPR",36, 0)
  24575    ;
  24576   "RTN","RCX FMSPR",37, 0)
  24577    I $G(RCST FLAG) D Q  Q
  24578   "RTN","RCX FMSPR",38, 0)
  24579    ;
  24580   "RTN","RCX FMSPR",39, 0)
  24581    ;  print  reimbursab le health  insurance  rsc's
  24582   "RTN","RCX FMSPR",40, 0)
  24583    S COLUMN2 =5
  24584   "RTN","RCX FMSPR",41, 0)
  24585    W !!?6,"F or REIMBUR SABLE HEAL TH INSURAN CE [85*Z]: "
  24586   "RTN","RCX FMSPR",42, 0)
  24587    F DECIMAL =0:1:31 D   Q:$G(RCST FLAG)
  24588   "RTN","RCX FMSPR",43, 0)
  24589    .   I DEC IMAL<10 S  COLUMN3=DE CIMAL
  24590   "RTN","RCX FMSPR",44, 0)
  24591    .   E  S  COLUMN3=$C (65+DECIMA L-10)
  24592   "RTN","RCX FMSPR",45, 0)
  24593    .   ;
  24594   "RTN","RCX FMSPR",46, 0)
  24595    .   ;  co nvert deci mal to bin ary (ex: 1 0011) so i t can be
  24596   "RTN","RCX FMSPR",47, 0)
  24597    .   ;  pa rsed in rs c to get t he descrip tion
  24598   "RTN","RCX FMSPR",48, 0)
  24599    .   S BIN ARY=$$CONV ERT(DECIMA L)
  24600   "RTN","RCX FMSPR",49, 0)
  24601    .   S COL 3DESC=$P($ T(@("B"_$E (BINARY,1, 2))),";",3 )
  24602   "RTN","RCX FMSPR",50, 0)
  24603    .   S COL 3DESC=COL3 DESC_", "_ $P($T(@("C "_$E(BINAR Y,3))),";" ,3)
  24604   "RTN","RCX FMSPR",51, 0)
  24605    .   S COL 3DESC=COL3 DESC_", "_ $P($T(@("D "_$E(BINAR Y,4))),";" ,3)
  24606   "RTN","RCX FMSPR",52, 0)
  24607    .   S COL 3DESC=COL3 DESC_", "_ $P($T(@("E "_$E(BINAR Y,5))),";" ,3)
  24608   "RTN","RCX FMSPR",53, 0)
  24609    .   S DES CRIP=COL3D ESC
  24610   "RTN","RCX FMSPR",54, 0)
  24611    .   D WRI TEIT
  24612   "RTN","RCX FMSPR",55, 0)
  24613    ;
  24614   "RTN","RCX FMSPR",56, 0)
  24615    ;  print  fee basis  reimbursab le health  insurance  rsc's (PRC A*4.5*310/ DRF)
  24616   "RTN","RCX FMSPR",57, 0)
  24617    S COLUMN2 ="F"
  24618   "RTN","RCX FMSPR",58, 0)
  24619    W !!?6,"F or FEE REI MBURSABLE  HEALTH INS URANCE [8F *Z]:"
  24620   "RTN","RCX FMSPR",59, 0)
  24621    F DECIMAL =1:1:2 D   Q:$G(RCSTF LAG)
  24622   "RTN","RCX FMSPR",60, 0)
  24623    .   S DES CRIP="FEE  BASIS, NSC  VET, MT C AT A, "_$S (DECIMAL=1 :"INPATIEN T",DECIMAL =2:"OUTPAT IENT",1:"" )
  24624   "RTN","RCX FMSPR",61, 0)
  24625    .   S COL UMN3=DECIM AL
  24626   "RTN","RCX FMSPR",62, 0)
  24627    .   D WRI TEIT
  24628   "RTN","RCX FMSPR",63, 0)
  24629    ;
  24630   "RTN","RCX FMSPR",64, 0)
  24631    ;  print  EMERGENCY/ HUMANITARI AN REIMB.    PRCA*4.5 *315
  24632   "RTN","RCX FMSPR",65, 0)
  24633    ;  8VZZ;H UMAN 3RD-P RTY OUTPAT IENT
  24634   "RTN","RCX FMSPR",66, 0)
  24635    ;  8UZZ;H UMAN 3RD-P RTY INPATI ENT
  24636   "RTN","RCX FMSPR",67, 0)
  24637    S COLUMN3 ="Z"
  24638   "RTN","RCX FMSPR",68, 0)
  24639    W !!?6,"F or EMERGEN CY/HUMANIT ARIAN REIM BURSABLE H EALTH INSU RANCE [8*Z Z]:"
  24640   "RTN","RCX FMSPR",69, 0)
  24641    F DECIMAL ="U","V" D   Q:$G(RCS TFLAG)
  24642   "RTN","RCX FMSPR",70, 0)
  24643    . S DESCR IP="EMERGE NCY/HUMANI TARIAN REI MB. INS.,   "_$S(DECI MAL="U":"I NPATIENT", DECIMAL="V ":"OUTPATI ENT",1:"")
  24644   "RTN","RCX FMSPR",71, 0)
  24645    . S COLUM N2=DECIMAL
  24646   "RTN","RCX FMSPR",72, 0)
  24647    . D WRITE IT
  24648   "RTN","RCX FMSPR",73, 0)
  24649    ;
  24650   "RTN","RCX FMSPR",74, 0)
  24651    ;  print  INELIGIBLE  HOSP. REI MB.   PRCA *4.5*315
  24652   "RTN","RCX FMSPR",75, 0)
  24653    ;  841Z;I NELI 3RD-P ARTY INPAT IENT
  24654   "RTN","RCX FMSPR",76, 0)
  24655    ;  842Z;I NELI 3RD-P ARTY OUTPA TIENT 
  24656   "RTN","RCX FMSPR",77, 0)
  24657    S COLUMN2 ="4"
  24658   "RTN","RCX FMSPR",78, 0)
  24659    W !!?6,"F or INELIGI BLE HOSPIT AL REIMBUR SABLE HEAL TH INSURAN CE [84*Z]: "
  24660   "RTN","RCX FMSPR",79, 0)
  24661    F DECIMAL =1,2 D  Q: $G(RCSTFLA G)
  24662   "RTN","RCX FMSPR",80, 0)
  24663    . S DESCR IP="INELIG IBLE HOSP.  REIMB. IN S., "_$S(D ECIMAL=1:" INPATIENT" ,DECIMAL=2 :"OUTPATIE NT",1:"")
  24664   "RTN","RCX FMSPR",81, 0)
  24665    . S COLUM N3=DECIMAL
  24666   "RTN","RCX FMSPR",82, 0)
  24667    . D WRITE IT
  24668   "RTN","RCX FMSPR",83, 0)
  24669   Q D ^%ZISC
  24670   "RTN","RCX FMSPR",84, 0)
  24671    Q
  24672   "RTN","RCX FMSPR",85, 0)
  24673    ;
  24674   "RTN","RCX FMSPR",86, 0)
  24675    ;
  24676   "RTN","RCX FMSPR",87, 0)
  24677   GETDESC(RS C) ;  retu rn the des cription f or the rev enue sourc e code
  24678   "RTN","RCX FMSPR",88, 0)
  24679    N BINARY, COL3DESC,C OLUMN2,COL UMN3,DESC
  24680   "RTN","RCX FMSPR",89, 0)
  24681    ;new reso urce codes  for ineli gible hosp  reimb. an d emergenc y/humanita rian reimb .  PRCA*4. 5*315
  24682   "RTN","RCX FMSPR",90, 0)
  24683    I RSC="84 1Z" Q "Ine ligible Ho sp. Reimb.  Ins., Inp atient"
  24684   "RTN","RCX FMSPR",91, 0)
  24685    I RSC="84 2Z" Q "Ine ligible Ho sp. Reimb.  Ins., Out patient"
  24686   "RTN","RCX FMSPR",92, 0)
  24687    I RSC="8U ZZ" Q "Eme rgency/Hum anitarian  Reimb. Ins ., Inpatie nt"
  24688   "RTN","RCX FMSPR",93, 0)
  24689    I RSC="8V ZZ" Q "Eme rgency/Hum anitarian  Reimb. Ins ., Outpati ent"
  24690   "RTN","RCX FMSPR",94, 0)
  24691    I RSC="AR RV" Q "Mis cellaneous "
  24692   "RTN","RCX FMSPR",95, 0)
  24693    I RSC=804 6 Q "Admin istrative"
  24694   "RTN","RCX FMSPR",96, 0)
  24695    I RSC=804 7 Q "Inter est"
  24696   "RTN","RCX FMSPR",97, 0)
  24697    I RSC=804 8 Q "Marsh al Fee and  Court Cos t"
  24698   "RTN","RCX FMSPR",98, 0)
  24699    S DESC="U NKNOWN"
  24700   "RTN","RCX FMSPR",99, 0)
  24701    S COLUMN2 =$E(RSC,2)
  24702   "RTN","RCX FMSPR",100 ,0)
  24703    I "123456 789ABCDEFG HIJKLMQRST "[COLUMN2  S DESC=$P( $T(@("A"_C OLUMN2))," ;",3)
  24704   "RTN","RCX FMSPR",101 ,0)
  24705    ; HSIF re ference di sabled by  patch 203
  24706   "RTN","RCX FMSPR",102 ,0)
  24707    ; I RSC=" 8B1Z"!(RSC ="8C1Z") S  DESC=DESC _" (HSIF)"
  24708   "RTN","RCX FMSPR",103 ,0)
  24709    I COLUMN2 '=5 Q DESC
  24710   "RTN","RCX FMSPR",104 ,0)
  24711    ;
  24712   "RTN","RCX FMSPR",105 ,0)
  24713    S COLUMN3 =$E(RSC,3)
  24714   "RTN","RCX FMSPR",106 ,0)
  24715    ;  conver t alpha le tters to d ecimal
  24716   "RTN","RCX FMSPR",107 ,0)
  24717    I "012345 6789"'[COL UMN3 S COL UMN3=$A(CO LUMN3)-55
  24718   "RTN","RCX FMSPR",108 ,0)
  24719    S BINARY= $$CONVERT( COLUMN3)
  24720   "RTN","RCX FMSPR",109 ,0)
  24721    S COL3DES C=$P($T(@( "B"_$E(BIN ARY,1,2))) ,";",3)
  24722   "RTN","RCX FMSPR",110 ,0)
  24723    S COL3DES C=COL3DESC _", "_$P($ T(@("C"_$E (BINARY,3) )),";",3)
  24724   "RTN","RCX FMSPR",111 ,0)
  24725    S COL3DES C=COL3DESC _", "_$P($ T(@("D"_$E (BINARY,4) )),";",3)
  24726   "RTN","RCX FMSPR",112 ,0)
  24727    S COL3DES C=COL3DESC _", "_$P($ T(@("E"_$E (BINARY,5) )),";",3)
  24728   "RTN","RCX FMSPR",113 ,0)
  24729    Q "RHI, " _COL3DESC
  24730   "RTN","RCX FMSPR",114 ,0)
  24731    ;
  24732   "RTN","RCX FMSPR",115 ,0)
  24733    ;
  24734   "RTN","RCX FMSPR",116 ,0)
  24735   CONVERT(DE CIMAL) ;   convert de cimal numb er to bina ry (5 digi ts)
  24736   "RTN","RCX FMSPR",117 ,0)
  24737    N Y
  24738   "RTN","RCX FMSPR",118 ,0)
  24739    S Y=""
  24740   "RTN","RCX FMSPR",119 ,0)
  24741    F  S Y=$E ("01234567 89ABCDEF", DECIMAL#2+ 1)_Y,DECIM AL=DECIMAL \2 Q:DECIM AL<1
  24742   "RTN","RCX FMSPR",120 ,0)
  24743    S Y=$E("0 0000",0,5- $L(Y))_Y
  24744   "RTN","RCX FMSPR",121 ,0)
  24745    Q Y
  24746   "RTN","RCX FMSPR",122 ,0)
  24747    ;
  24748   "RTN","RCX FMSPR",123 ,0)
  24749    ;
  24750   "RTN","RCX FMSPR",124 ,0)
  24751   WRITEIT ;   display t he rsc
  24752   "RTN","RCX FMSPR",125 ,0)
  24753    W !,COLUM N1,COLUMN2 ,COLUMN3,C OLUMN4,?6, DESCRIP
  24754   "RTN","RCX FMSPR",126 ,0)
  24755    I $Y>(IOS L-5) D:SCR EEN PAUSE  Q:$G(RCSTF LAG)  D H
  24756   "RTN","RCX FMSPR",127 ,0)
  24757    Q
  24758   "RTN","RCX FMSPR",128 ,0)
  24759    ;
  24760   "RTN","RCX FMSPR",129 ,0)
  24761    ;
  24762   "RTN","RCX FMSPR",130 ,0)
  24763   PAUSE ;  p ause at en d of page
  24764   "RTN","RCX FMSPR",131 ,0)
  24765    N X U IO( 0) W !,"Pr ess RETURN  to contin ue, '^' to  exit:" R  X:DTIME S: '$T X="^"  S:X["^" RC STFLAG=1 U  IO
  24766   "RTN","RCX FMSPR",132 ,0)
  24767    Q
  24768   "RTN","RCX FMSPR",133 ,0)
  24769    ;
  24770   "RTN","RCX FMSPR",134 ,0)
  24771    ;
  24772   "RTN","RCX FMSPR",135 ,0)
  24773   H ;  heade r
  24774   "RTN","RCX FMSPR",136 ,0)
  24775    S %=NOW_"   PAGE "_P AGE,PAGE=P AGE+1 I PA GE'=2!(SCR EEN) W @IO F
  24776   "RTN","RCX FMSPR",137 ,0)
  24777    W $C(13), "REVENUE S OURCE CODE  REPORT (V ISTA TO FM S)",?(80-$ L(%)),%
  24778   "RTN","RCX FMSPR",138 ,0)
  24779    W !,"RSC" ,?6,"Descr iption"
  24780   "RTN","RCX FMSPR",139 ,0)
  24781    S %="",$P (%,"-",81) =""
  24782   "RTN","RCX FMSPR",140 ,0)
  24783    W !,%
  24784   "RTN","RCX FMSPR",141 ,0)
  24785    Q
  24786   "RTN","RCX FMSPR",142 ,0)
  24787    ;
  24788   "RTN","RCX FMSPR",143 ,0)
  24789    ;
  24790   "RTN","RCX FMSPR",144 ,0)
  24791    ;  this i s a listin g of all c olumn2 val ues with a  descripti on
  24792   "RTN","RCX FMSPR",145 ,0)
  24793   A1 ;;Hospi tal Care ( NSC)
  24794   "RTN","RCX FMSPR",146 ,0)
  24795   A2 ;;Outpa tient Care  (NSC)
  24796   "RTN","RCX FMSPR",147 ,0)
  24797   A3 ;;Nursi ng Home Ca re (NSC)
  24798   "RTN","RCX FMSPR",148 ,0)
  24799   A4 ;;Ineli gible Hosp italizatio n
  24800   "RTN","RCX FMSPR",149 ,0)
  24801   A5 ;;Reimb ursable He alth Insur ance
  24802   "RTN","RCX FMSPR",150 ,0)
  24803   A6 ;;Tort  Feasor
  24804   "RTN","RCX FMSPR",151 ,0)
  24805   A7 ;;Workm ans Compen sation (No n-Federal)
  24806   "RTN","RCX FMSPR",152 ,0)
  24807   A8 ;;C (Me ans Test)
  24808   "RTN","RCX FMSPR",153 ,0)
  24809   A9 ;;Emerg ency/Human itarian
  24810   "RTN","RCX FMSPR",154 ,0)
  24811   AA ;;No Fa ult Auto A ccident
  24812   "RTN","RCX FMSPR",155 ,0)
  24813   AB ;;Pharm acy Co-Pay  (SC Vet)
  24814   "RTN","RCX FMSPR",156 ,0)
  24815   AC ;;Pharm acy Co-Pay  (NSC Vet)
  24816   "RTN","RCX FMSPR",157 ,0)
  24817   AD ;;Nursi ng Home Ca re Per Die m
  24818   "RTN","RCX FMSPR",158 ,0)
  24819   AE ;;Hospi tal Care P er Diem
  24820   "RTN","RCX FMSPR",159 ,0)
  24821   AF ;;Medic are
  24822   "RTN","RCX FMSPR",160 ,0)
  24823   AG ;;Adult  Day Healt h Care (LT C)
  24824   "RTN","RCX FMSPR",161 ,0)
  24825   AH ;;Domic iliary (LT C)
  24826   "RTN","RCX FMSPR",162 ,0)
  24827   AI ;;Respi te Care-In stitutiona l (LTC)
  24828   "RTN","RCX FMSPR",163 ,0)
  24829   AJ ;;Respi te Care-No n-Institut ional (LTC )
  24830   "RTN","RCX FMSPR",164 ,0)
  24831   AK ;;Geria tric Eval- Institutio nal (LTC)
  24832   "RTN","RCX FMSPR",165 ,0)
  24833   AL ;;Geria tric Eval- Non-Instit utional (L TC)
  24834   "RTN","RCX FMSPR",166 ,0)
  24835   AM ;;Nursi ng Home Ca re-Long Te rm Care (L TC)
  24836   "RTN","RCX FMSPR",167 ,0)
  24837   AQ ;;Pharm acy No Fau lt Auto Ac c
  24838   "RTN","RCX FMSPR",168 ,0)
  24839   AR ;;Pharm acy Reimbu rs Health  Ins
  24840   "RTN","RCX FMSPR",169 ,0)
  24841   AS ;;Pharm acy Tort F easor
  24842   "RTN","RCX FMSPR",170 ,0)
  24843   AT ;;Pharm acy Workma n's Comp
  24844   "RTN","RCX FMSPR",171 ,0)
  24845    ;
  24846   "RTN","RCX FMSPR",172 ,0)
  24847    ;
  24848   "RTN","RCX FMSPR",173 ,0)
  24849    ;  this i s a listin g for the  type of ca re, first  2 binary d igits
  24850   "RTN","RCX FMSPR",174 ,0)
  24851    ;  if col umn2 is re imbursable  health in surance
  24852   "RTN","RCX FMSPR",175 ,0)
  24853   B00 ;;Inpa tient (Hos p)
  24854   "RTN","RCX FMSPR",176 ,0)
  24855   B01 ;;Outp atient
  24856   "RTN","RCX FMSPR",177 ,0)
  24857   B10 ;;Nurs ing Home
  24858   "RTN","RCX FMSPR",178 ,0)
  24859   B11 ;;Othe r
  24860   "RTN","RCX FMSPR",179 ,0)
  24861    ;
  24862   "RTN","RCX FMSPR",180 ,0)
  24863    ;
  24864   "RTN","RCX FMSPR",181 ,0)
  24865    ;  this i s a listin g for the  service co nnected, b inary digi t 3
  24866   "RTN","RCX FMSPR",182 ,0)
  24867   C0 ;;SC fo r NSC
  24868   "RTN","RCX FMSPR",183 ,0)
  24869   C1 ;;NSC V et
  24870   "RTN","RCX FMSPR",184 ,0)
  24871    ;
  24872   "RTN","RCX FMSPR",185 ,0)
  24873    ;
  24874   "RTN","RCX FMSPR",186 ,0)
  24875    ;  this i s a listin g for mean s test, bi nary digit  4
  24876   "RTN","RCX FMSPR",187 ,0)
  24877   D0 ;;MT Ca t A
  24878   "RTN","RCX FMSPR",188 ,0)
  24879   D1 ;;MT Ca t C
  24880   "RTN","RCX FMSPR",189 ,0)
  24881    ;
  24882   "RTN","RCX FMSPR",190 ,0)
  24883    ;
  24884   "RTN","RCX FMSPR",191 ,0)
  24885    ;  this i s a listin g for age  group, bin ary digit  5
  24886   "RTN","RCX FMSPR",192 ,0)
  24887   E0 ;;Age < 65
  24888   "RTN","RCX FMSPR",193 ,0)
  24889   E1 ;;Age 6 5+
  24890   "RTN","RCX FMSUF")
  24891   0^24^B3876 3717^B3745 0700
  24892   "RTN","RCX FMSUF",1,0 )
  24893   RCXFMSUF ; WISC/RFJ-c alculate f ms fund co de for a b ill ;10/20 /10 10:37a m
  24894   "RTN","RCX FMSUF",2,0 )
  24895    ;;4.5;Acc ounts Rece ivable;**9 0,101,135, 157,160,16 5,170,203, 207,173,21 1,192,220, 235,273,31 0,315**;Ma r 20, 1995 ;Build 55
  24896   "RTN","RCX FMSUF",3,0 )
  24897    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  24898   "RTN","RCX FMSUF",4,0 )
  24899    Q
  24900   "RTN","RCX FMSUF",5,0 )
  24901    ;
  24902   "RTN","RCX FMSUF",6,0 )
  24903    ;
  24904   "RTN","RCX FMSUF",7,0 )
  24905   GETFUNDO(T YPE) ;  re turn the f und for ot her type a ssociated  collection s
  24906   "RTN","RCX FMSUF",8,0 )
  24907    ;  type c an equal:
  24908   "RTN","RCX FMSUF",9,0 )
  24909    ;  I for  interest          A f or admin
  24910   "RTN","RCX FMSUF",10, 0)
  24911    ;  M for  marshall f ee     C f or court c ost
  24912   "RTN","RCX FMSUF",11, 0)
  24913    I TYPE="I " Q "1435"
  24914   "RTN","RCX FMSUF",12, 0)
  24915    I TYPE="A " Q "3220"
  24916   "RTN","RCX FMSUF",13, 0)
  24917    I TYPE="M " Q "0869"
  24918   "RTN","RCX FMSUF",14, 0)
  24919    I TYPE="C " Q "0869"
  24920   "RTN","RCX FMSUF",15, 0)
  24921    Q ""
  24922   "RTN","RCX FMSUF",16, 0)
  24923    ;
  24924   "RTN","RCX FMSUF",17, 0)
  24925    ;
  24926   "RTN","RCX FMSUF",18, 0)
  24927   GETFUNDB(B ILLDA,DONT STOR,RCEFT ) ;  retur n a bills  fms fund c ode
  24928   "RTN","RCX FMSUF",19, 0)
  24929    ;  pass D ONTSTOR eq ual 1 to p revent sto ring the f und code
  24930   "RTN","RCX FMSUF",20, 0)
  24931    ;  cannot  rely on d ata in the  fund fiel d since it  may refer ence the
  24932   "RTN","RCX FMSUF",21, 0)
  24933    ;  old fu nds S FUND =$P($G(^PR CA(430,BIL LDA,11))," ^",17).  s ince there
  24934   "RTN","RCX FMSUF",22, 0)
  24935    ;  are re ports whic h use 11;1 7, set it  for a bill  once its  computed
  24936   "RTN","RCX FMSUF",23, 0)
  24937    ;  until  all refere nces to th e fund are  eliminate d.
  24938   "RTN","RCX FMSUF",24, 0)
  24939    ;  rceft  = 1 if pro cessing an  EFT depos it
  24940   "RTN","RCX FMSUF",25, 0)
  24941    ;
  24942   "RTN","RCX FMSUF",26, 0)
  24943    N ACTDATE ,CATEGDA,F UND,NEWFUN D
  24944   "RTN","RCX FMSUF",27, 0)
  24945    ;
  24946   "RTN","RCX FMSUF",28, 0)
  24947    ;  calcul ate a bill s fund
  24948   "RTN","RCX FMSUF",29, 0)
  24949    I $G(RCEF T)=1 S FUN D="5287"_$ S(DT<30309 26:"",DT'< 3030926&(D T<$$ADDPTE DT^PRCAACC ()):".4",1 :"04") Q F UND
  24950   "RTN","RCX FMSUF",30, 0)
  24951    S CATEGDA =+$P($G(^P RCA(430,BI LLDA,0))," ^",2)
  24952   "RTN","RCX FMSUF",31, 0)
  24953    I CATEGDA >47 Q ""
  24954   "RTN","RCX FMSUF",32, 0)
  24955    ;
  24956   "RTN","RCX FMSUF",33, 0)
  24957    ;  piece  5 is new f und, remov e spaces
  24958   "RTN","RCX FMSUF",34, 0)
  24959    S FUND=$P ($TR($T(@C ATEGDA),"  "),";",5)
  24960   "RTN","RCX FMSUF",35, 0)
  24961    ;
  24962   "RTN","RCX FMSUF",36, 0)
  24963    ;  set fu nd 528711  for 3rd pa rty RX bil ls after 4 /27/2011
  24964   "RTN","RCX FMSUF",37, 0)
  24965    I $$TYP^I BRFN(BILLD A)="PH" D
  24966   "RTN","RCX FMSUF",38, 0)
  24967    . I (CATE GDA=6)!(CA TEGDA=7)!( CATEGDA=9) !(CATEGDA= 10),$$CHEC KRXS(BILLD A) S FUND= 528711
  24968   "RTN","RCX FMSUF",39, 0)
  24969    ;
  24970   "RTN","RCX FMSUF",40, 0)
  24971    ;  if cat egory is v endor(17),  ex-employ ee(15), cu rrent empl oyee(16)
  24972   "RTN","RCX FMSUF",41, 0)
  24973    ;  federa l agency r efund(13),  federal a gency reim b(14), mil itary(12)
  24974   "RTN","RCX FMSUF",42, 0)
  24975    ;  set th e fund to  what is st ored in th e file.  T his was en tered
  24976   "RTN","RCX FMSUF",43, 0)
  24977    ;  by the  user duri ng the aud it process .  If fund  is in the  file
  24978   "RTN","RCX FMSUF",44, 0)
  24979    ;  alread y, do not  need to st ore it aga in.
  24980   "RTN","RCX FMSUF",45, 0)
  24981    ;  if cat egory is n ursing hom e proceeds  (40), par king fees  (41),
  24982   "RTN","RCX FMSUF",46, 0)
  24983    ;  cwt pr oceeds (42 ), comp &  pen procee ds (43), e nhanced us e lease
  24984   "RTN","RCX FMSUF",47, 0)
  24985    ;  procee ds (44), s et the fun d to what  is stored  in the fil e.
  24986   "RTN","RCX FMSUF",48, 0)
  24987    ;  This w as generat ed by the  software a t the time  of bill e nter.
  24988   "RTN","RCX FMSUF",49, 0)
  24989    I CATEGDA =17!(CATEG DA=15)!(CA TEGDA=16)! (CATEGDA=1 3)!(CATEGD A=14)!(CAT EGDA=12)!( CATEGDA=40 )!(CATEGDA =41)!(CATE GDA=42)!(C ATEGDA=43) !(CATEGDA= 44) D
  24990   "RTN","RCX FMSUF",50, 0)
  24991    .   I $P( $G(^PRCA(4 30,BILLDA, 11)),"^",1 7)'="" S F UND=$P(^(1 1),"^",17) ,DONTSTOR= 1
  24992   "RTN","RCX FMSUF",51, 0)
  24993    ;
  24994   "RTN","RCX FMSUF",52, 0)
  24995    ;  public  law state s that bil ls in the  category i neligible  (1),
  24996   "RTN","RCX FMSUF",53, 0)
  24997    ;  emerg/ human (2),  torts (10 ), or medi care (21)  which are  older 
  24998   "RTN","RCX FMSUF",54, 0)
  24999    ;  than o ct 1, 1992  should be  reported  under fund  3220.
  25000   "RTN","RCX FMSUF",55, 0)
  25001    I CATEGDA =1!(CATEGD A=2)!(CATE GDA=10)!(C ATEGDA=21)  D
  25002   "RTN","RCX FMSUF",56, 0)
  25003    .   S ACT DATE=$P($G (^PRCA(430 ,BILLDA,6) ),"^",21)
  25004   "RTN","RCX FMSUF",57, 0)
  25005    .   I ACT DATE,ACTDA TE<2921001  S FUND=32 20 Q
  25006   "RTN","RCX FMSUF",58, 0)
  25007    .   ;
  25008   "RTN","RCX FMSUF",59, 0)
  25009    .   ;  pa tch157 cha nges ineli gibles.  a n ineligib le activat ed before
  25010   "RTN","RCX FMSUF",60, 0)
  25011    .   ;  oc t 1, 1992  or after s ep 30, 200 0 will be  recorded i n fund 016 0A1.
  25012   "RTN","RCX FMSUF",61, 0)
  25013    .   ;  ot herwise it  will be r ecorded in  fund 5287 .3 if befo re 3040928
  25014   "RTN","RCX FMSUF",62, 0)
  25015    .   ; if  3040928 or  after,  f und should  be 528703
  25016   "RTN","RCX FMSUF",63, 0)
  25017    .   I CAT EGDA=1,ACT DATE,ACTDA TE<3001001  S FUND=$S (DT<$$ADDP TEDT^PRCAA CC():"5287 .3",1:5287 03)
  25018   "RTN","RCX FMSUF",64, 0)
  25019    ;
  25020   "RTN","RCX FMSUF",65, 0)
  25021    ;  set th e fund for  the bill
  25022   "RTN","RCX FMSUF",66, 0)
  25023    ; PRCA*4. 5*310/DRF  Add Non-VA  fund 5287 13
  25024   "RTN","RCX FMSUF",67, 0)
  25025    I $G(DONT STOR)'=1 D  STORE^RCX FMSUR(BILL DA,"",FUND )
  25026   "RTN","RCX FMSUF",68, 0)
  25027    ; 
  25028   "RTN","RCX FMSUF",69, 0)
  25029    I FUND>52 8704,FUND< 528709!(FU ND=528710) !(FUND=528 711) Q FUN D
  25030   "RTN","RCX FMSUF",70, 0)
  25031    I FUND=52 8713 Q FUN D
  25032   "RTN","RCX FMSUF",71, 0)
  25033    ;
  25034   "RTN","RCX FMSUF",72, 0)
  25035    I $G(REPR ODT),REPRO DT<3030926 ,$E(FUND,1 ,4)=5287 Q  5287
  25036   "RTN","RCX FMSUF",73, 0)
  25037    I $G(REPR ODT),REPRO DT<3031001 ,$E(FUND,1 ,4)=5287,$ G(REFMS) Q  5287
  25038   "RTN","RCX FMSUF",74, 0)
  25039    I DT<3030 926,$E(FUN D,1,4)=528 7 Q 5287 ;  Effective  date
  25040   "RTN","RCX FMSUF",75, 0)
  25041    I $G(REPR ODT),REPRO DT<$$ADDPT EDT^PRCAAC C(),FUND=5 28709 Q 40 32 ;Effect ive date-5 28709
  25042   "RTN","RCX FMSUF",76, 0)
  25043    I $G(REPR ODT),REPRO DT<3041001 ,FUND=5287 09,$G(REFM S) Q 4032  ;Resubmitt ed documen ts not hel d
  25044   "RTN","RCX FMSUF",77, 0)
  25045    I $G(DATE END),$E(DA TEEND,2,5) <"0410",FU ND=528709  Q 4032
  25046   "RTN","RCX FMSUF",78, 0)
  25047    I DT<$$AD DPTEDT^PRC AACC(),FUN D=528709 Q  4032
  25048   "RTN","RCX FMSUF",79, 0)
  25049    I $G(REPR ODT),REPRO DT<$$ADDPT EDT^PRCAAC C(),FUND=5 28701 Q 52 87.1 ;Effe ctive date -528701
  25050   "RTN","RCX FMSUF",80, 0)
  25051    I $G(REPR ODT),REPRO DT<3041001 ,FUND=5287 01,$G(REFM S) Q 5287. 1 ;Resubmi tted docum ents not h eld
  25052   "RTN","RCX FMSUF",81, 0)
  25053    I $G(DATE END),$E(DA TEEND,2,5) <"0410",FU ND=528701  Q 5287.1
  25054   "RTN","RCX FMSUF",82, 0)
  25055    I DT<$$AD DPTEDT^PRC AACC(),FUN D=528701 Q  5287.1
  25056   "RTN","RCX FMSUF",83, 0)
  25057    I $G(REPR ODT),REPRO DT<$$ADDPT EDT^PRCAAC C(),FUND=5 28703 Q 52 87.3 ;Effe ctive date -528703
  25058   "RTN","RCX FMSUF",84, 0)
  25059    I $G(REPR ODT),REPRO DT<3041001 ,FUND=5287 03,$G(REFM S) Q 5287. 3 ;Resubmi tted docum ents not h eld
  25060   "RTN","RCX FMSUF",85, 0)
  25061    I $G(DATE END),$E(DA TEEND,2,5) <"0410",FU ND=528703  Q 5287.3
  25062   "RTN","RCX FMSUF",86, 0)
  25063    I DT<$$AD DPTEDT^PRC AACC(),FUN D=528703 Q  5287.3
  25064   "RTN","RCX FMSUF",87, 0)
  25065    I $G(REPR ODT),REPRO DT<$$ADDPT EDT^PRCAAC C(),FUND=5 28704 Q 52 87.4 ;Effe ctive date -528704
  25066   "RTN","RCX FMSUF",88, 0)
  25067    I $G(REPR ODT),REPRO DT<3041001 ,FUND=5287 04,$G(REFM S) Q 5287. 4 ;Resubmi tted docum ents not h eld
  25068   "RTN","RCX FMSUF",89, 0)
  25069    I $G(DATE END),$E(DA TEEND,2,5) <"0410",FU ND=528704  Q 5287.4
  25070   "RTN","RCX FMSUF",90, 0)
  25071    I DT<$$AD DPTEDT^PRC AACC(),FUN D=528704 Q  5287.4
  25072   "RTN","RCX FMSUF",91, 0)
  25073    Q FUND
  25074   "RTN","RCX FMSUF",92, 0)
  25075    ;
  25076   "RTN","RCX FMSUF",93, 0)
  25077   CHECKRXS(B ILLDA) ; r eturns tru e (1) if b ill has an y scripts  on or afte r 4/27/11
  25078   "RTN","RCX FMSUF",94, 0)
  25079    N RXNUM,N EWFUND,FIL LDT,ARRXS
  25080   "RTN","RCX FMSUF",95, 0)
  25081    S NEWFUND =0
  25082   "RTN","RCX FMSUF",96, 0)
  25083    D SET^IBC SC5A(BILLD A,.ARRXS,)
  25084   "RTN","RCX FMSUF",97, 0)
  25085    S RXNUM=0 ,FILLDT=""
  25086   "RTN","RCX FMSUF",98, 0)
  25087    F  S RXNU M=$O(ARRXS (RXNUM)) Q :RXNUM'>0! (NEWFUND)   D
  25088   "RTN","RCX FMSUF",99, 0)
  25089    .  S FILL DT=$O(ARRX S(RXNUM,0) )
  25090   "RTN","RCX FMSUF",100 ,0)
  25091    .  I FILL DT'<311042 7 S NEWFUN D=1
  25092   "RTN","RCX FMSUF",101 ,0)
  25093    Q NEWFUND
  25094   "RTN","RCX FMSUF",102 ,0)
  25095    ;
  25096   "RTN","RCX FMSUF",103 ,0)
  25097    ;  this i s a listin g of all c ategories  and associ ated funds
  25098   "RTN","RCX FMSUF",104 ,0)
  25099    ;  the la bel is fro m the inte rnal entry  number in  the categ ory
  25100   "RTN","RCX FMSUF",105 ,0)
  25101    ;  file 4 30.2.  pie ce 3 is a  descriptio n, piece 4  is the ol d fund,
  25102   "RTN","RCX FMSUF",106 ,0)
  25103    ;  piece  5 is the n ew fund
  25104   "RTN","RCX FMSUF",107 ,0)
  25105    ;  PRCA*4 .5*310/DRF  Added 45  - FEE REIM B INS to r outine.
  25106   "RTN","RCX FMSUF",108 ,0)
  25107   0 ;;no fun d                         ;        ;    
  25108   "RTN","RCX FMSUF",109 ,0)
  25109   1 ;;INELIG IBLE HOSP.                ;3220    ;0160A1
  25110   "RTN","RCX FMSUF",110 ,0)
  25111   2 ;;EMERGE NCY/HUMANI TARIAN         ;0160A 1 ;528703
  25112   "RTN","RCX FMSUF",111 ,0)
  25113   3 ;;NURSIN G HOME CAR E(NSC)         ;2431    ;528703
  25114   "RTN","RCX FMSUF",112 ,0)
  25115   4 ;;OUTPAT IENT CARE( NSC)           ;2431    ;528703
  25116   "RTN","RCX FMSUF",113 ,0)
  25117   5 ;;HOSPIT AL CARE (N SC)            ;2431    ;528703
  25118   "RTN","RCX FMSUF",114 ,0)
  25119   6 ;;WORKMA N'S COMP.                 ;5014    ;528704
  25120   "RTN","RCX FMSUF",115 ,0)
  25121   7 ;;NO-FAU LT AUTO AC C.             ;5014    ;528704
  25122   "RTN","RCX FMSUF",116 ,0)
  25123   8 ;;CRIME  OF PER.VIO .              ;5014    ;528704
  25124   "RTN","RCX FMSUF",117 ,0)
  25125   9 ;;REIMBU RS.HEALTH  INS.           ;5014    ;528704
  25126   "RTN","RCX FMSUF",118 ,0)
  25127   10 ;;TORT  FEASOR                     ;0160 A1 ;528704
  25128   "RTN","RCX FMSUF",119 ,0)
  25129   11 ;;no en try                        ;        ;
  25130   "RTN","RCX FMSUF",120 ,0)
  25131   12 ;;MILIT ARY                        ;0160 A1 ;0160A1
  25132   "RTN","RCX FMSUF",121 ,0)
  25133   13 ;;FEDER AL AGENCIE S-REFUND        ;0160 A1 ;0160A1
  25134   "RTN","RCX FMSUF",122 ,0)
  25135   14 ;;FEDER AL AGENCIE S-REIMB.        ;0160 A1 ;0160A1
  25136   "RTN","RCX FMSUF",123 ,0)
  25137   15 ;;EX-EM PLOYEE                     ;0160 A1 ;0160A1
  25138   "RTN","RCX FMSUF",124 ,0)
  25139   16 ;;CURRE NT EMP.                    ;0160 A1 ;0160A1
  25140   "RTN","RCX FMSUF",125 ,0)
  25141   17 ;;VENDO R                          ;0160 A1 ;0160A1
  25142   "RTN","RCX FMSUF",126 ,0)
  25143   18 ;;C (ME ANS TEST)                  ;2431    ;528703
  25144   "RTN","RCX FMSUF",127 ,0)
  25145   19 ;;SHARI NG AGREEME NTS             ;0160 A1 ;0160A1
  25146   "RTN","RCX FMSUF",128 ,0)
  25147   20 ;;INTER AGENCY                     ;0160 A1 ;0160A1
  25148   "RTN","RCX FMSUF",129 ,0)
  25149   21 ;;MEDIC ARE                        ;5014    ;528704
  25150   "RTN","RCX FMSUF",130 ,0)
  25151   22 ;;RX CO -PAYMENT/S C VET           ;5014    ;528701
  25152   "RTN","RCX FMSUF",131 ,0)
  25153   23 ;;RX CO -PAYMENT/N SC VET          ;5014    ;528701
  25154   "RTN","RCX FMSUF",132 ,0)
  25155   24 ;;NURSI NG HOME CA RE PER DIE M    ;2431    ;528703
  25156   "RTN","RCX FMSUF",133 ,0)
  25157   25 ;;HOSPI TAL CARE P ER DIEM         ;2431    ;528703
  25158   "RTN","RCX FMSUF",134 ,0)
  25159   26 ;;PREPA YMENT                      ;5014    ;528703
  25160   "RTN","RCX FMSUF",135 ,0)
  25161   27 ;;CHAMP VA SUBSIST ENCE            ;3220    ;3220
  25162   "RTN","RCX FMSUF",136 ,0)
  25163   28 ;;CHAMP VA THIRD P ARTY            ;3220    ;0160A1
  25164   "RTN","RCX FMSUF",137 ,0)
  25165   29 ;;CHAMP VA                         ;0160 A1 ;0160A1
  25166   "RTN","RCX FMSUF",138 ,0)
  25167   30 ;;TRICA RE                         ;0160 A1 ;0160A1
  25168   "RTN","RCX FMSUF",139 ,0)
  25169   31 ;;TRICA RE PATIENT                 ;0160 A1 ;0160A1
  25170   "RTN","RCX FMSUF",140 ,0)
  25171   32 ;;TRICA RE THIRD P ARTY            ;0160 A1 ;0160A1
  25172   "RTN","RCX FMSUF",141 ,0)
  25173   33 ;;ADULT  DAY HEALT H CARE          ;4032    ;528709
  25174   "RTN","RCX FMSUF",142 ,0)
  25175   34 ;;DOMIC ILIARY                     ;4032    ;528709
  25176   "RTN","RCX FMSUF",143 ,0)
  25177   35 ;;RESPI TE CARE-IN STITUTIONA L    ;4032    ;528709
  25178   "RTN","RCX FMSUF",144 ,0)
  25179   36 ;;RESPI TE CARE-NO N-INSTITUT IONAL;4032    ;528709
  25180   "RTN","RCX FMSUF",145 ,0)
  25181   37 ;;GERIA TRIC EVAL- INSTITUTIO NAL  ;4032    ;528709
  25182   "RTN","RCX FMSUF",146 ,0)
  25183   38 ;;GERIA TRIC EVAL- NON-INSTIT UTION;4032    ;528709
  25184   "RTN","RCX FMSUF",147 ,0)
  25185   39 ;;NURSI NG HOME CA RE-LTC          ;4032    ;528709
  25186   "RTN","RCX FMSUF",148 ,0)
  25187   40 ;;NURSI NG HOME PR OCEEDS          ;        ;528705
  25188   "RTN","RCX FMSUF",149 ,0)
  25189   41 ;;PARKI NG FEES                    ;        ;528706
  25190   "RTN","RCX FMSUF",150 ,0)
  25191   42 ;;CWT P ROCEEDS                    ;        ;528707
  25192   "RTN","RCX FMSUF",151 ,0)
  25193   43 ;;COMP  & PEN PROC EEDS            ;        ;528708
  25194   "RTN","RCX FMSUF",152 ,0)
  25195   44 ;;ENHAN CED USE LE ASE PROCEE DS   ;5358 .3 ;528710
  25196   "RTN","RCX FMSUF",153 ,0)
  25197   45 ;;FEE R EIMB INS                   ;        ;528713
  25198   "RTN","RCX FMSUF",154 ,0)
  25199   46 ;;EMERG ENCY/HUMAN ITARIAN RE IMB. ;        ;528704   ;315
  25200   "RTN","RCX FMSUF",155 ,0)
  25201   47 ;;INELI GIBLE REIM B. INS.         ;        ;0160A1   ;315
  25202   "RTN","RCX FMSUF",156 ,0)
  25203    ;    
  25204   "RTN","RCX FMSUR")
  25205   0^25^B6350 3809^B6095 0863
  25206   "RTN","RCX FMSUR",1,0 )
  25207   RCXFMSUR ; WISC/RFJ-r evenue sou rce codes  ;10/19/10  1:47pm
  25208   "RTN","RCX FMSUR",2,0 )
  25209    ;;4.5;Acc ounts Rece ivable;**9 0,101,170, 203,173,22 0,231,273, 310,315**; Mar 20, 19 95;Build 5 5
  25210   "RTN","RCX FMSUR",3,0 )
  25211    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  25212   "RTN","RCX FMSUR",4,0 )
  25213    Q
  25214   "RTN","RCX FMSUR",5,0 )
  25215    ;
  25216   "RTN","RCX FMSUR",6,0 )
  25217    ;
  25218   "RTN","RCX FMSUR",7,0 )
  25219   CALCRSC(BI LLDA,RCEFT ) ;  calcu late the r evenue sou rce code f or a bill
  25220   "RTN","RCX FMSUR",8,0 )
  25221    ;  rceft  = 1 if pro cessing an  EFT depos it
  25222   "RTN","RCX FMSUR",9,0 )
  25223    ;  return s the 4 co lumn (char acter) rsc
  25224   "RTN","RCX FMSUR",10, 0)
  25225    N CATEGDA ,COLUMN1,C OLUMN2,COL UMN3,COLUM N4,RSC
  25226   "RTN","RCX FMSUR",11, 0)
  25227    ;  if rsc  already c alculated,  return it
  25228   "RTN","RCX FMSUR",12, 0)
  25229    I $G(RCEF T)=1 S RSC ="8NZZ" Q  RSC
  25230   "RTN","RCX FMSUR",13, 0)
  25231    S RSC=$P( $G(^PRCA(4 30,BILLDA, 11)),"^",2 3)
  25232   "RTN","RCX FMSUR",14, 0)
  25233    I $L(RSC) =4,RSC'="A RRV" Q RSC
  25234   "RTN","RCX FMSUR",15, 0)
  25235    ;
  25236   "RTN","RCX FMSUR",16, 0)
  25237    ;  calcul ate it and  store it
  25238   "RTN","RCX FMSUR",17, 0)
  25239    S CATEGDA =+$P($G(^P RCA(430,BI LLDA,0))," ^",2)
  25240   "RTN","RCX FMSUR",18, 0)
  25241    ;
  25242   "RTN","RCX FMSUR",19, 0)
  25243    ;  if pre payment, s end ARRV
  25244   "RTN","RCX FMSUR",20, 0)
  25245    I CATEGDA =26 D STOR E(BILLDA," ARRV") Q " ARRV"
  25246   "RTN","RCX FMSUR",21, 0)
  25247    ;
  25248   "RTN","RCX FMSUR",22, 0)
  25249    S COLUMN1 =$$COLUMN1
  25250   "RTN","RCX FMSUR",23, 0)
  25251    ;
  25252   "RTN","RCX FMSUR",24, 0)
  25253    ; check f or 3rd par ty RX bill s after 4/ 27/2011 fo r col 2
  25254   "RTN","RCX FMSUR",25, 0)
  25255    N RX3P S  RX3P=0
  25256   "RTN","RCX FMSUR",26, 0)
  25257    I ("PH"=$ $TYP^IBRFN (BILLDA))  D
  25258   "RTN","RCX FMSUR",27, 0)
  25259    .  S RX3P =$$CHECKRX S^RCXFMSUF (BILLDA)
  25260   "RTN","RCX FMSUR",28, 0)
  25261    ;
  25262   "RTN","RCX FMSUR",29, 0)
  25263    S COLUMN2 =$$COLUMN2
  25264   "RTN","RCX FMSUR",30, 0)
  25265    ;
  25266   "RTN","RCX FMSUR",31, 0)
  25267    ;  if col umn2 canno t be deter mined, ret urn the rs c of ARRV
  25268   "RTN","RCX FMSUR",32, 0)
  25269    I COLUMN2 ="" D STOR E(BILLDA," ARRV") Q " ARRV"
  25270   "RTN","RCX FMSUR",33, 0)
  25271    ;
  25272   "RTN","RCX FMSUR",34, 0)
  25273    ;  if col umn2 is no t a 5 for  reimbursab le health  insurance,  or catego ry not 45  (FEE REIMB  INS)
  25274   "RTN","RCX FMSUR",35, 0)
  25275    ;  return  ZZ in col umns 3 and  4
  25276   "RTN","RCX FMSUR",36, 0)
  25277    I COLUMN2 '=5,CATEGD A'=45 D ST ORE(BILLDA ,COLUMN1_C OLUMN2_"ZZ ") Q COLUM N1_COLUMN2 _"ZZ"
  25278   "RTN","RCX FMSUR",37, 0)
  25279    ;
  25280   "RTN","RCX FMSUR",38, 0)
  25281    ;  for re imbursable  health in surance, c ompute col umns 3 and  4
  25282   "RTN","RCX FMSUR",39, 0)
  25283    S COLUMN3 =$$COLUMN3
  25284   "RTN","RCX FMSUR",40, 0)
  25285    S COLUMN4 =$$COLUMN4
  25286   "RTN","RCX FMSUR",41, 0)
  25287    ;
  25288   "RTN","RCX FMSUR",42, 0)
  25289    D STORE(B ILLDA,COLU MN1_COLUMN 2_COLUMN3_ COLUMN4)
  25290   "RTN","RCX FMSUR",43, 0)
  25291    Q COLUMN1 _COLUMN2_C OLUMN3_COL UMN4
  25292   "RTN","RCX FMSUR",44, 0)
  25293    ;
  25294   "RTN","RCX FMSUR",45, 0)
  25295    ;
  25296   "RTN","RCX FMSUR",46, 0)
  25297   STORE(DA,R SC,FUND) ;   store th e revenue  source cod e  or fund  in the fi le
  25298   "RTN","RCX FMSUR",47, 0)
  25299    I $G(^PRC A(430,DA,0 ))="" Q
  25300   "RTN","RCX FMSUR",48, 0)
  25301    N D,D0,DI ,DIC,DIE,D Q,DR,X,Y
  25302   "RTN","RCX FMSUR",49, 0)
  25303    S DR=""
  25304   "RTN","RCX FMSUR",50, 0)
  25305    I $G(RSC) '="" S DR= "255.1//// "_RSC_";"
  25306   "RTN","RCX FMSUR",51, 0)
  25307    I $G(FUND )'="" S DR =DR_"203// //"_FUND_" ;"
  25308   "RTN","RCX FMSUR",52, 0)
  25309    S (DIC,DI E)="^PRCA( 430,"
  25310   "RTN","RCX FMSUR",53, 0)
  25311    D ^DIE
  25312   "RTN","RCX FMSUR",54, 0)
  25313    Q
  25314   "RTN","RCX FMSUR",55, 0)
  25315    ;
  25316   "RTN","RCX FMSUR",56, 0)
  25317    ;
  25318   "RTN","RCX FMSUR",57, 0)
  25319   COLUMN1()  ;  return  column 1 n umber
  25320   "RTN","RCX FMSUR",58, 0)
  25321    Q 8
  25322   "RTN","RCX FMSUR",59, 0)
  25323    ;
  25324   "RTN","RCX FMSUR",60, 0)
  25325    ;
  25326   "RTN","RCX FMSUR",61, 0)
  25327   COLUMN2()  ;  return  column 2 n umber
  25328   "RTN","RCX FMSUR",62, 0)
  25329    I CATEGDA =5 Q 1      ; hospita l care (ns c)
  25330   "RTN","RCX FMSUR",63, 0)
  25331    I CATEGDA =4 Q 2      ; outpati ent care ( nsc)
  25332   "RTN","RCX FMSUR",64, 0)
  25333    I CATEGDA =3 Q 3      ; nursing  home care  (nsc)
  25334   "RTN","RCX FMSUR",65, 0)
  25335    I CATEGDA =1 Q 4      ; ineligi ble hospit al
  25336   "RTN","RCX FMSUR",66, 0)
  25337    I CATEGDA =9&$G(RX3P ) Q "R"     ; pharmac y reimburs able healt h insuranc e
  25338   "RTN","RCX FMSUR",67, 0)
  25339    I CATEGDA =9 Q 5      ; reimbur sable heal th insuran ce
  25340   "RTN","RCX FMSUR",68, 0)
  25341    I CATEGDA =10&$G(RX3 P) Q "S"      ; pharm acy tort f easor
  25342   "RTN","RCX FMSUR",69, 0)
  25343    I CATEGDA =10 Q 6     ; tort fe asor
  25344   "RTN","RCX FMSUR",70, 0)
  25345    I CATEGDA =6&$G(RX3P ) Q "T"      ;pharmac y workman' s comp
  25346   "RTN","RCX FMSUR",71, 0)
  25347    I CATEGDA =6 Q 7      ; workman s comp
  25348   "RTN","RCX FMSUR",72, 0)
  25349    I CATEGDA =18 Q 8     ; c (mean s test)
  25350   "RTN","RCX FMSUR",73, 0)
  25351    I CATEGDA =2 Q 9      ; emergen cy/humanit arian
  25352   "RTN","RCX FMSUR",74, 0)
  25353    I CATEGDA =7&$G(RX3P ) Q "Q"      ;pharmac y no fault  auto acc
  25354   "RTN","RCX FMSUR",75, 0)
  25355    I CATEGDA =7 Q "A"    ; no faul t auto acc ident
  25356   "RTN","RCX FMSUR",76, 0)
  25357    I CATEGDA =22 Q "B"   ; rx copa y/sc vet
  25358   "RTN","RCX FMSUR",77, 0)
  25359    I CATEGDA =23 Q "C"   ; rx copa y/nsc vet
  25360   "RTN","RCX FMSUR",78, 0)
  25361    I CATEGDA =24 Q "D"   ; nursing  home care  per diem
  25362   "RTN","RCX FMSUR",79, 0)
  25363    I CATEGDA =25 Q "E"   ; hospita l care per  diem
  25364   "RTN","RCX FMSUR",80, 0)
  25365    I CATEGDA =21 Q "F"   ; medicar e
  25366   "RTN","RCX FMSUR",81, 0)
  25367    I CATEGDA =33 Q "G"   ; adult d ay health  care
  25368   "RTN","RCX FMSUR",82, 0)
  25369    I CATEGDA =34 Q "H"   ; domicil iary
  25370   "RTN","RCX FMSUR",83, 0)
  25371    I CATEGDA =35 Q "I"   ; respite  care - in stitutiona l
  25372   "RTN","RCX FMSUR",84, 0)
  25373    I CATEGDA =36 Q "J"   ; respite  care - no n-institut ional
  25374   "RTN","RCX FMSUR",85, 0)
  25375    I CATEGDA =37 Q "K"   ; geriatr ic evaluat ion - inst itutional
  25376   "RTN","RCX FMSUR",86, 0)
  25377    I CATEGDA =38 Q "L"   ; geriatr ic evaluat ion - non- institutio nal
  25378   "RTN","RCX FMSUR",87, 0)
  25379    I CATEGDA =39 Q "M"   ; nursing  home care  - ltc
  25380   "RTN","RCX FMSUR",88, 0)
  25381    I CATEGDA =45 Q "F"   ; Fee Bas is
  25382   "RTN","RCX FMSUR",89, 0)
  25383    I CATEGDA =46 D  Q C OLUMN2
  25384   "RTN","RCX FMSUR",90, 0)
  25385    . N COL
  25386   "RTN","RCX FMSUR",91, 0)
  25387    . D DIQ39 9(BILLDA)
  25388   "RTN","RCX FMSUR",92, 0)
  25389    . S COL=$ G(IBCNDATA (399,BILLD A,.05,"I") )
  25390   "RTN","RCX FMSUR",93, 0)
  25391    . S COLUM N2=$S(COL= 1:"U",COL= 2:"U",COL= 3:"V",1:"V ")
  25392   "RTN","RCX FMSUR",94, 0)
  25393    Q ""
  25394   "RTN","RCX FMSUR",95, 0)
  25395    ;
  25396   "RTN","RCX FMSUR",96, 0)
  25397    ;
  25398   "RTN","RCX FMSUR",97, 0)
  25399   COLUMN3()  ;  return  the column  3 number
  25400   "RTN","RCX FMSUR",98, 0)
  25401    N AGE,DEC IMAL,DFN,I BCNDATA,TY PEAGE,TYPE CARE,TYPEM EAN,TYPESE RV,VA,VADM ,VAERR
  25402   "RTN","RCX FMSUR",99, 0)
  25403    ;
  25404   "RTN","RCX FMSUR",100 ,0)
  25405    D DIQ399( BILLDA)
  25406   "RTN","RCX FMSUR",101 ,0)
  25407    ;
  25408   "RTN","RCX FMSUR",102 ,0)
  25409    ;  PRCA*4 .5*310/DRF
  25410   "RTN","RCX FMSUR",103 ,0)
  25411    ;  for Fe e Basis, c olumn3 = 1  (inpatien t) or 2 (o utpatient)
  25412   "RTN","RCX FMSUR",104 ,0)
  25413    I CATEGDA =45 S COLU MN3=$S($G( IBCNDATA(3 99,BILLDA, .05,"I"))= 1:1,$G(IBC NDATA(399, BILLDA,.05 ,"I"))=2:2 ,1:2) Q CO LUMN3
  25414   "RTN","RCX FMSUR",105 ,0)
  25415    ;
  25416   "RTN","RCX FMSUR",106 ,0)
  25417    D TYPECAR E
  25418   "RTN","RCX FMSUR",107 ,0)
  25419    ;
  25420   "RTN","RCX FMSUR",108 ,0)
  25421    ;  comput e service  connected  at time of  care (1 d igit binar y)
  25422   "RTN","RCX FMSUR",109 ,0)
  25423    ;  type o f service  connected  is set as  follows:
  25424   "RTN","RCX FMSUR",110 ,0)
  25425    ;         0 = SC Vet                     1  = NSC Vet
  25426   "RTN","RCX FMSUR",111 ,0)
  25427    S TYPESER V=1
  25428   "RTN","RCX FMSUR",112 ,0)
  25429    ;  servic e connecte d at time  of care (. 18) = yes  (1)
  25430   "RTN","RCX FMSUR",113 ,0)
  25431    I $G(IBCN DATA(399,B ILLDA,.18, "I"))=1 S  TYPESERV=0
  25432   "RTN","RCX FMSUR",114 ,0)
  25433    ;
  25434   "RTN","RCX FMSUR",115 ,0)
  25435    S DFN=$P( $G(^PRCA(4 30,BILLDA, 0)),"^",7)
  25436   "RTN","RCX FMSUR",116 ,0)
  25437    D DEM^VAD PT
  25438   "RTN","RCX FMSUR",117 ,0)
  25439    ;
  25440   "RTN","RCX FMSUR",118 ,0)
  25441    ;  comput e means te st at time  of care ( 1 digit bi nary)
  25442   "RTN","RCX FMSUR",119 ,0)
  25443    ;  type o f means te st is set  as follows :
  25444   "RTN","RCX FMSUR",120 ,0)
  25445    ;         0 = Cat A                      1  = Cat C
  25446   "RTN","RCX FMSUR",121 ,0)
  25447    S TYPEMEA N=0
  25448   "RTN","RCX FMSUR",122 ,0)
  25449    I $$BIL^D GMTUB(DFN, $G(IBCNDAT A(399,BILL DA,151,"I" )))=1 S TY PEMEAN=1
  25450   "RTN","RCX FMSUR",123 ,0)
  25451    ;
  25452   "RTN","RCX FMSUR",124 ,0)
  25453    ;  comput e patient  age at tim e of care  (1 digit b inary)
  25454   "RTN","RCX FMSUR",125 ,0)
  25455    ;  type o f age is s et as foll ows:
  25456   "RTN","RCX FMSUR",126 ,0)
  25457    ;         0 = under  65                  1  = 65 and  older
  25458   "RTN","RCX FMSUR",127 ,0)
  25459    S AGE=$$F MDIFF^XLFD T($G(IBCND ATA(399,BI LLDA,151," I")),$P($G (VADM(3)), "^"))\365. 25
  25460   "RTN","RCX FMSUR",128 ,0)
  25461    S TYPEAGE =1
  25462   "RTN","RCX FMSUR",129 ,0)
  25463    I AGE<65  S TYPEAGE= 0
  25464   "RTN","RCX FMSUR",130 ,0)
  25465    ;
  25466   "RTN","RCX FMSUR",131 ,0)
  25467    ;  conver t to decim al  typeca re  typese rv  typeme an  typeag e
  25468   "RTN","RCX FMSUR",132 ,0)
  25469    ;              binar y=  1   1          1          1          1
  25470   "RTN","RCX FMSUR",133 ,0)
  25471    ;             decima l= 16 + 8      +   4      +   2      +   1
  25472   "RTN","RCX FMSUR",134 ,0)
  25473    S DECIMAL =$S(TYPECA RE="11":24 ,TYPECARE= "10":16,TY PECARE="01 ":8,1:0)
  25474   "RTN","RCX FMSUR",135 ,0)
  25475    I TYPESER V S DECIMA L=DECIMAL+ 4
  25476   "RTN","RCX FMSUR",136 ,0)
  25477    I TYPEMEA N S DECIMA L=DECIMAL+ 2
  25478   "RTN","RCX FMSUR",137 ,0)
  25479    I TYPEAGE  S DECIMAL =DECIMAL+1
  25480   "RTN","RCX FMSUR",138 ,0)
  25481    I DECIMAL <10 Q DECI MAL
  25482   "RTN","RCX FMSUR",139 ,0)
  25483    Q $C(65+D ECIMAL-10)
  25484   "RTN","RCX FMSUR",140 ,0)
  25485    ;
  25486   "RTN","RCX FMSUR",141 ,0)
  25487    ;
  25488   "RTN","RCX FMSUR",142 ,0)
  25489   COLUMN4()  ;  return  the column  4 number  (reserved  for future  expansion )
  25490   "RTN","RCX FMSUR",143 ,0)
  25491    Q "Z"
  25492   "RTN","RCX FMSUR",144 ,0)
  25493    ;
  25494   "RTN","RCX FMSUR",145 ,0)
  25495    ;
  25496   "RTN","RCX FMSUR",146 ,0)
  25497   DIQ399(DA)   ;  get d ata from f ile 399
  25498   "RTN","RCX FMSUR",147 ,0)
  25499    N D0,DIC, DIQ,DIQ2,D R
  25500   "RTN","RCX FMSUR",148 ,0)
  25501    K IBCNDAT A
  25502   "RTN","RCX FMSUR",149 ,0)
  25503    S DIQ(0)= "IE",DIC=" ^DGCR(399, ",DIQ="IBC NDATA",DR= ".04;.05;. 18;151;" D  EN^DIQ1
  25504   "RTN","RCX FMSUR",150 ,0)
  25505    Q
  25506   "RTN","RCX FMSUR",151 ,0)
  25507    ;
  25508   "RTN","RCX FMSUR",152 ,0)
  25509    ;
  25510   "RTN","RCX FMSUR",153 ,0)
  25511   TYPECARE ;   compute  type of ca re (2 digi t binary)
  25512   "RTN","RCX FMSUR",154 ,0)
  25513    ;  type o f care is  set as fol lows:
  25514   "RTN","RCX FMSUR",155 ,0)
  25515    ;      00  = inpatie nt (hospit al)    01  = outpatie nt
  25516   "RTN","RCX FMSUR",156 ,0)
  25517    ;      10  = nursing  home             11  = other
  25518   "RTN","RCX FMSUR",157 ,0)
  25519    ;  defaul t is other  if it can not be com puted
  25520   "RTN","RCX FMSUR",158 ,0)
  25521    S TYPECAR E="11"
  25522   "RTN","RCX FMSUR",159 ,0)
  25523    ;  bill c lassificat ion (.05)  = outpatie nt (3) or  human.emer g(opt) (4)
  25524   "RTN","RCX FMSUR",160 ,0)
  25525    I $G(IBCN DATA(399,B ILLDA,.05, "I"))=3!($ G(IBCNDATA (399,BILLD A,.05,"I") )=4) S TYP ECARE="01"  Q
  25526   "RTN","RCX FMSUR",161 ,0)
  25527    ;  locati on of care  (.04) = h ospital in pt or outp t (1)
  25528   "RTN","RCX FMSUR",162 ,0)
  25529    I $G(IBCN DATA(399,B ILLDA,.04, "I"))=1 S  TYPECARE=" 00" Q
  25530   "RTN","RCX FMSUR",163 ,0)
  25531    ;  locati on of care  (.04) = s killed nur sing (nhcu ) (2)
  25532   "RTN","RCX FMSUR",164 ,0)
  25533    I $G(IBCN DATA(399,B ILLDA,.04, "I"))=2 S  TYPECARE=" 10"
  25534   "RTN","RCX FMSUR",165 ,0)
  25535    Q
  25536   "RTN","RCX FMSUR",166 ,0)
  25537    ;
  25538   "RTN","RCX FMSUR",167 ,0)
  25539    ;
  25540   "RTN","RCX FMSUR",168 ,0)
  25541   ADDEDIT ;   enter/edi t revenue  source cod es for fun d 0160A1 b ills.  The se
  25542   "RTN","RCX FMSUR",169 ,0)
  25543    ;  bills  have the r sc entered  by the us er.  The u ser can se lect
  25544   "RTN","RCX FMSUR",170 ,0)
  25545    ;  from r scs in fil e 347.3
  25546   "RTN","RCX FMSUR",171 ,0)
  25547    W !!,"Thi s option s hould be u sed with C AUTION.  T his option  will allo w the"
  25548   "RTN","RCX FMSUR",172 ,0)
  25549    W !,"user  owning th e PRCASVC  supervisor  security  key, to ad d or edit  the"
  25550   "RTN","RCX FMSUR",173 ,0)
  25551    W !,"Reve nue Source  Codes sel ectable fo r non MCCF  bills.  I f an inval id"
  25552   "RTN","RCX FMSUR",174 ,0)
  25553    W !,"Reve nue Source  Code is e ntered or  changed, a ll code sh eets sent  to"
  25554   "RTN","RCX FMSUR",175 ,0)
  25555    W !,"FMS  referencin g the inva lid Revenu e Source C ode will r eject.  Be "
  25556   "RTN","RCX FMSUR",176 ,0)
  25557    W !,"caut ious when  entering n ew Revenue  Source Co des or edi ting exist ing"
  25558   "RTN","RCX FMSUR",177 ,0)
  25559    W !,"Reve nue Source  Codes.  N ew Revenue  Source Co des should  only be a dded"
  25560   "RTN","RCX FMSUR",178 ,0)
  25561    W !,"afte r they hav e been add ed in FMS. "
  25562   "RTN","RCX FMSUR",179 ,0)
  25563    ;
  25564   "RTN","RCX FMSUR",180 ,0)
  25565    I '$D(^XU SEC("PRCAS VC",DUZ))  W !!,"You  are not an  owner of  the PRCASV C security  key." Q
  25566   "RTN","RCX FMSUR",181 ,0)
  25567    ;
  25568   "RTN","RCX FMSUR",182 ,0)
  25569    N %,%Y,C, D,D0,DA,DI ,DIC,DIE,D LAYGO,DQ,D R,RCRJFLAG ,X,X1,X2,X 3,Y
  25570   "RTN","RCX FMSUR",183 ,0)
  25571    ;
  25572   "RTN","RCX FMSUR",184 ,0)
  25573    F  D  Q:$ G(RCRJFLAG )
  25574   "RTN","RCX FMSUR",185 ,0)
  25575    . S (DIC, DIE)="^RC( 347.3,",DI C(0)="QEL" ,DLAYGO=34 7.3
  25576   "RTN","RCX FMSUR",186 ,0)
  25577    . R !!,"S elect REVE NUE SOURCE  CODE: ",X :DTIME
  25578   "RTN","RCX FMSUR",187 ,0)
  25579    . S X1=X, X=$$UPPER^ VALM1(X)
  25580   "RTN","RCX FMSUR",188 ,0)
  25581    . I $E(X) ="?",X?."? " D ^DIC Q :Y<1
  25582   "RTN","RCX FMSUR",189 ,0)
  25583    . I X=""! ($E(X)=U)  S RCRJFLAG =1 Q
  25584   "RTN","RCX FMSUR",190 ,0)
  25585    . I $D(^R C(347.3,"B ",X)) S Y= +$O(^(X,0) ) W "   ", X,"  ",$P( $G(^RC(347 .3,Y,0)),U ,2) W:$P(^ (0),U,3) "   INACTIVE " D UPD Q 
  25586   "RTN","RCX FMSUR",191 ,0)
  25587    . S X2=$L (X1),X3=$C ($A($E(X1, X2))-1),X3 =$E(X1,1,X 2-1)_X3,X3 =$O(^RC(34 7.3,"C",X3 )) I $E(X3 ,1,X2)=X1  S X=X1
  25588   "RTN","RCX FMSUR",192 ,0)
  25589    . S D="C"  D IX^DIC  Q:Y<1  D U PD Q
  25590   "RTN","RCX FMSUR",193 ,0)
  25591    Q
  25592   "RTN","RCX FMSUR",194 ,0)
  25593   UPD S DIE= "^RC(347.3 ,",DA=+Y,D R=".02;.03 " D ^DIE
  25594   "RTN","RCX FMSUR",195 ,0)
  25595    Q
  25596   "RTN","RCX FMSUR",196 ,0)
  25597    ;
  25598   "RTN","RCX FMSUR",197 ,0)
  25599    ;
  25600   "RTN","RCX FMSUR",198 ,0)
  25601   RSC ;reven ue code (# 430/255)
  25602   "RTN","RCX FMSUR",199 ,0)
  25603    I $P($G(^ RC(347.3,X ,0)),"^",3 ) D EN^DDI OL("THIS R EVENUE SOU RCE CODE I S INACTIVE .") K X Q
  25604   "RTN","RCX FMSUR",200 ,0)
  25605    S X=$P(^R C(347.3,X, 0),"^")
  25606   "RTN","RCX FMSUR",201 ,0)
  25607    Q
  25608   "RTN","RCX FMSUR",202 ,0)
  25609    ;
  25610   "RTN","RCX FMSUR",203 ,0)
  25611   SHOW ;  sh ow/calcula te revenue  source co de for a s elected bi ll
  25612   "RTN","RCX FMSUR",204 ,0)
  25613    W !!,"Thi s option w ill show t he calcula ted Revenu e Source C ode for a  selected"
  25614   "RTN","RCX FMSUR",205 ,0)
  25615    W !,"bill .  The Rev enue Sourc e Code is  only calcu lated for  accrued bi lls in"
  25616   "RTN","RCX FMSUR",206 ,0)
  25617    I DT'<$$A DDPTEDT^PR CAACC() W  !,"funds 5 28701,5287 03,528704, 528709/403 2,528711,5 28713"
  25618   "RTN","RCX FMSUR",207 ,0)
  25619    I DT<$$AD DPTEDT^PRC AACC() W ! ,"funds 52 87.1,5287. 3,5287.4,4 032"
  25620   "RTN","RCX FMSUR",208 ,0)
  25621    ;
  25622   "RTN","RCX FMSUR",209 ,0)
  25623    N %,%Y,BI LLDA,C,DIC ,FUND,I,RC RJFLAG,RSC ,X,Y
  25624   "RTN","RCX FMSUR",210 ,0)
  25625    ;
  25626   "RTN","RCX FMSUR",211 ,0)
  25627    F  D  Q:$ G(RCRJFLAG )
  25628   "RTN","RCX FMSUR",212 ,0)
  25629    .   S DIC ="^PRCA(43 0,",DIC(0) ="QEAM"
  25630   "RTN","RCX FMSUR",213 ,0)
  25631    .   W ! D  ^DIC
  25632   "RTN","RCX FMSUR",214 ,0)
  25633    .   I Y<1  S RCRJFLA G=1 Q
  25634   "RTN","RCX FMSUR",215 ,0)
  25635    .   S BIL LDA=+Y
  25636   "RTN","RCX FMSUR",216 ,0)
  25637    .   S FUN D=$$GETFUN DB^RCXFMSU F(BILLDA,1 )
  25638   "RTN","RCX FMSUR",217 ,0)
  25639    .   W !!, "        B ill Number : ",$P($G( ^PRCA(430, BILLDA,0)) ,"^")
  25640   "RTN","RCX FMSUR",218 ,0)
  25641    .   W !,"                 Fund:  ",FUND
  25642   "RTN","RCX FMSUR",219 ,0)
  25643    .   I '$$ PTACCT^PRC AACC(FUND) ,FUND'=403 2 D  Q
  25644   "RTN","RCX FMSUR",220 ,0)
  25645    .   .   W  !,"  The  Revenue So urce Code  cannot be  calculated  for non-a ccrued bil ls."
  25646   "RTN","RCX FMSUR",221 ,0)
  25647    .   .   W  !,"  The  Revenue So urce Code  for non-ac crued bill s are inpu t by the u ser."
  25648   "RTN","RCX FMSUR",222 ,0)
  25649    .   .   W  !,"  The  Revenue So urce Code  is current ly entered  as: "
  25650   "RTN","RCX FMSUR",223 ,0)
  25651    .   .   S  RSC=$P($G (^PRCA(430 ,BILLDA,11 )),"^",6)
  25652   "RTN","RCX FMSUR",224 ,0)
  25653    .   .   W  $S(RSC="" :"<not ent ered>",1:R SC)
  25654   "RTN","RCX FMSUR",225 ,0)
  25655    .   ;
  25656   "RTN","RCX FMSUR",226 ,0)
  25657    .   S RSC =$$CALCRSC (BILLDA)
  25658   "RTN","RCX FMSUR",227 ,0)
  25659    .   W !," Revenue So urce Code:  ",RSC
  25660   "RTN","RCX FMSUR",228 ,0)
  25661    Q
  25662   "RTN","RCX FMSUV")
  25663   0^38^B1583 9120^B1386 8854
  25664   "RTN","RCX FMSUV",1,0 )
  25665   RCXFMSUV ; WISC/RFJ-f ms vendor  id ;9/17/9 8  11:42 A M
  25666   "RTN","RCX FMSUV",2,0 )
  25667    ;;4.5;Acc ounts Rece ivable;**9 0,119,98,1 65,192,220 ,315**;Mar  20, 1995; Build 55
  25668   "RTN","RCX FMSUV",3,0 )
  25669    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  25670   "RTN","RCX FMSUV",4,0 )
  25671    Q
  25672   "RTN","RCX FMSUV",5,0 )
  25673    ;
  25674   "RTN","RCX FMSUV",6,0 )
  25675    ;
  25676   "RTN","RCX FMSUV",7,0 )
  25677   VENDORID(B ILLDA) ;   return the  vendorid  for a bill  (used on  a BD docum ent)
  25678   "RTN","RCX FMSUV",8,0 )
  25679    ;  return s null if  vendor id  is not req uired
  25680   "RTN","RCX FMSUV",9,0 )
  25681    ;  return s UNKNOWN  if vendor  id is requ ired but c ould not b e determin ed
  25682   "RTN","RCX FMSUV",10, 0)
  25683    N ACCRUAL ,CATEGORY, DEBTOR,RSC ,VENDORID, VENDOR,DIR ,VENFLAG
  25684   "RTN","RCX FMSUV",11, 0)
  25685    ;
  25686   "RTN","RCX FMSUV",12, 0)
  25687    ;  accrue d bills ge t sent to  mccf 5287  fund, no v endor id
  25688   "RTN","RCX FMSUV",13, 0)
  25689    S ACCRUAL =$$ACCK^PR CAACC(BILL DA)
  25690   "RTN","RCX FMSUV",14, 0)
  25691    ;
  25692   "RTN","RCX FMSUV",15, 0)
  25693    ;  if not  a categor y, cannot  determine  vendor id
  25694   "RTN","RCX FMSUV",16, 0)
  25695    S CATEGOR Y=$P($G(^P RCA(430,BI LLDA,0))," ^",2)
  25696   "RTN","RCX FMSUV",17, 0)
  25697    I 'CATEGO RY Q ""
  25698   "RTN","RCX FMSUV",18, 0)
  25699    I ACCRUAL  Q "" ;
  25700   "RTN","RCX FMSUV",19, 0)
  25701    ;
  25702   "RTN","RCX FMSUV",20, 0)
  25703    ;
  25704   "RTN","RCX FMSUV",21, 0)
  25705    ;  if ven dor(17) or  military( 12) or fed eral agenc ies refund (13)
  25706   "RTN","RCX FMSUV",22, 0)
  25707    ;  or fed eral agenc ies-reimb( 14) or int eragency(2 0)
  25708   "RTN","RCX FMSUV",23, 0)
  25709    ;  sharin g agreemen ts(19),nur sing Home  Proceeds ( 40)
  25710   "RTN","RCX FMSUV",24, 0)
  25711    ;  parkin g fees (41 ), cwt pro ceeds (42) , comp & p en proceed s (43)
  25712   "RTN","RCX FMSUV",25, 0)
  25713    ;  Enhanc ed Use Lea se Proceed s (44), th en get ven dor id
  25714   "RTN","RCX FMSUV",26, 0)
  25715    S VENFLAG =$S(CATEGO RY=17:2,CA TEGORY=12: 1,CATEGORY =13:1,CATE GORY=14:1, CATEGORY=2 0:1,CATEGO RY=19:1,CA TEGORY=40: 2,CATEGORY =41:2,CATE GORY=42:2, CATEGORY=4 3:2,CATEGO RY=44:2,CA TEGORY=47: 1,1:0)
  25716   "RTN","RCX FMSUV",27, 0)
  25717    I VENFLAG  D  Q VEND ORID
  25718   "RTN","RCX FMSUV",28, 0)
  25719       .S DEB TOR=+$P($G (^PRCA(430 ,BILLDA,0) ),"^",9),V ENDOR=$P($ G(^RCD(340 ,DEBTOR,0) ),U)
  25720   "RTN","RCX FMSUV",29, 0)
  25721       .I VEN DOR="" S V ENDORID="U NKNOWN" Q
  25722   "RTN","RCX FMSUV",30, 0)
  25723       .I VEN FLAG=2,VEN DOR["VA("  S VENDORID ="PERSONOT H" D STORE (BILLDA,"P ERSONOTH")  Q
  25724   "RTN","RCX FMSUV",31, 0)
  25725       .I VEN DOR["PRC("  D  Q
  25726   "RTN","RCX FMSUV",32, 0)
  25727          ..S  VENDORID= $$VEN^PRCH UTL(+VENDO R)
  25728   "RTN","RCX FMSUV",33, 0)
  25729          ..I  VENDORID' ="" D STOR E(BILLDA,V ENDORID) Q
  25730   "RTN","RCX FMSUV",34, 0)
  25731          ..I  VENFLAG=2  D  Q
  25732   "RTN","RCX FMSUV",35, 0)
  25733            . ..S DIR(0) ="Y",DIR(" A")="Can t his bill b e offset b y FMS "
  25734   "RTN","RCX FMSUV",36, 0)
  25735            . ..S DIR("B ")="YES" D  ^DIR
  25736   "RTN","RCX FMSUV",37, 0)
  25737            . ..S VENDOR ID=$S(Y=0: "PERSONOTH ",1:"UNKNO WN")
  25738   "RTN","RCX FMSUV",38, 0)
  25739            . ..D:VENDOR ID="PERSON OTH" STORE (BILLDA,"P ERSONOTH")
  25740   "RTN","RCX FMSUV",39, 0)
  25741            . ..Q
  25742   "RTN","RCX FMSUV",40, 0)
  25743          ..S  VENDORID= "UNKNOWN"
  25744   "RTN","RCX FMSUV",41, 0)
  25745          ..Q
  25746   "RTN","RCX FMSUV",42, 0)
  25747       .S VEN DOR=$P(^RC D(340,+DEB TOR,0),U,6 )
  25748   "RTN","RCX FMSUV",43, 0)
  25749       .I VEN DOR'="" S  VENDORID=$ $VEN^PRCHU TL(VENDOR)  D  Q
  25750   "RTN","RCX FMSUV",44, 0)
  25751          ..I  VENDORID= "" S VENDO RID="UNKNO WN" Q
  25752   "RTN","RCX FMSUV",45, 0)
  25753          ..D  STORE(BIL LDA,VENDOR ID)
  25754   "RTN","RCX FMSUV",46, 0)
  25755          ..Q
  25756   "RTN","RCX FMSUV",47, 0)
  25757       .I '$D (^XUSEC("P RCA VENDOR ",DUZ)) S  VENDORID=" LINK" Q
  25758   "RTN","RCX FMSUV",48, 0)
  25759       .W !!, "DEBTOR MU ST BE LINK ED TO VEND OR FILE"
  25760   "RTN","RCX FMSUV",49, 0)
  25761       .S VEN DOR=$$VENS EL^PRCHUTL ()
  25762   "RTN","RCX FMSUV",50, 0)
  25763       .I VEN DOR<0 S VE NDORID="LI NK" Q
  25764   "RTN","RCX FMSUV",51, 0)
  25765       .S VEN DORID=$$VE N^PRCHUTL( VENDOR)
  25766   "RTN","RCX FMSUV",52, 0)
  25767       .I VEN DORID="" S  VENDORID= "UNKNOWN"  Q
  25768   "RTN","RCX FMSUV",53, 0)
  25769       .D STO RE(BILLDA, VENDORID), STOREL(+DE BTOR,VENDO R)
  25770   "RTN","RCX FMSUV",54, 0)
  25771       .Q
  25772   "RTN","RCX FMSUV",55, 0)
  25773    ;
  25774   "RTN","RCX FMSUV",56, 0)
  25775    ;  for in eligible s end INELIG
  25776   "RTN","RCX FMSUV",57, 0)
  25777    I CATEGOR Y=1 D STOR E(BILLDA," INELIG") Q  "INELIG"
  25778   "RTN","RCX FMSUV",58, 0)
  25779    ;  for ex -employee  send XEMPL
  25780   "RTN","RCX FMSUV",59, 0)
  25781    I CATEGOR Y=15 D STO RE(BILLDA, "XEMPL") Q  "XEMPL"
  25782   "RTN","RCX FMSUV",60, 0)
  25783    ;  for cu rrent empl oyee send  CUREMPL
  25784   "RTN","RCX FMSUV",61, 0)
  25785    I CATEGOR Y=16 D STO RE(BILLDA, "CUREMPL")  Q "CUREMP L"
  25786   "RTN","RCX FMSUV",62, 0)
  25787    ;
  25788   "RTN","RCX FMSUV",63, 0)
  25789    ;
  25790   "RTN","RCX FMSUV",64, 0)
  25791    ;  for IN ELIGIBLE H OSP. REIMB
  25792   "RTN","RCX FMSUV",65, 0)
  25793    ;  841Z;I NELI  3RD- PARTY INPA TIENT
  25794   "RTN","RCX FMSUV",66, 0)
  25795    ;  842Z;I NELI  3RD- PARTY OUTP ATIENT 
  25796   "RTN","RCX FMSUV",67, 0)
  25797    I CATEGOR Y=47 D   Q  VENDORID
  25798   "RTN","RCX FMSUV",68, 0)
  25799    . S RSC=$ P($G(^PRCA (430,BILLD A,11)),"^" ,6)
  25800   "RTN","RCX FMSUV",69, 0)
  25801    . I RSC'= "" D  Q
  25802   "RTN","RCX FMSUV",70, 0)
  25803    ..I RSC=" 841Z" S VE NDORID="IN E3PINP"
  25804   "RTN","RCX FMSUV",71, 0)
  25805    ..I RSC=" 842Z" S VE NDORID="IN E3POUT"
  25806   "RTN","RCX FMSUV",72, 0)
  25807    . D STORE (BILLDA,VE NDORID)
  25808   "RTN","RCX FMSUV",73, 0)
  25809    ;
  25810   "RTN","RCX FMSUV",74, 0)
  25811    ;  champv a subsiten ce(27), ch ampva thir d party(28 )
  25812   "RTN","RCX FMSUV",75, 0)
  25813    I CATEGOR Y=27 D STO RE(BILLDA, "CHMPVA1ST ") Q "CHMP VA1ST"
  25814   "RTN","RCX FMSUV",76, 0)
  25815    I CATEGOR Y=28 D STO RE(BILLDA, "CHMPVA3RD ") Q "CHMP VA3RD"
  25816   "RTN","RCX FMSUV",77, 0)
  25817    ;  champv a(29) does  not get s ent to FMS , code com mented out
  25818   "RTN","RCX FMSUV",78, 0)
  25819    ;I CATEGO RY=29 Q ""
  25820   "RTN","RCX FMSUV",79, 0)
  25821    ;
  25822   "RTN","RCX FMSUV",80, 0)
  25823    ;  tricar e(30), tri care patie nt(31), tr icare thir d party(32 )
  25824   "RTN","RCX FMSUV",81, 0)
  25825    ;  test f or tricare  by lookin g at the r evenue sou rce code
  25826   "RTN","RCX FMSUV",82, 0)
  25827    S RSC=$P( $G(^PRCA(4 30,BILLDA, 11)),"^",6 )
  25828   "RTN","RCX FMSUV",83, 0)
  25829    I RSC>802 7,RSC<8031  D  D STOR E(BILLDA,V ENDORID) Q  VENDORID
  25830   "RTN","RCX FMSUV",84, 0)
  25831       .S VEN DORID=$S(R SC=8028:"T RIINPAT",R SC=8029:"T RIOUTPAT", 1:"TRIOTH" )
  25832   "RTN","RCX FMSUV",85, 0)
  25833       .Q
  25834   "RTN","RCX FMSUV",86, 0)
  25835    I CATEGOR Y>29,CATEG ORY<33 D   D STORE(BI LLDA,VENDO RID) Q VEN DORID
  25836   "RTN","RCX FMSUV",87, 0)
  25837       .S VEN DORID=$S(C ATEGORY=30 :"TRICAROT H",CATEGOR Y=31:"TRIC AROPT",1:" TRICARINP" )
  25838   "RTN","RCX FMSUV",88, 0)
  25839       .Q
  25840   "RTN","RCX FMSUV",89, 0)
  25841    ;  vendor  id not kn own, proce ss should  never reac h this lin e of code
  25842   "RTN","RCX FMSUV",90, 0)
  25843    Q "UNKNOW N"
  25844   "RTN","RCX FMSUV",91, 0)
  25845    ;
  25846   "RTN","RCX FMSUV",92, 0)
  25847    ;
  25848   "RTN","RCX FMSUV",93, 0)
  25849   LINKASK ;E NTRY POINT  FOR MENU  OPTION TO  STORE LINK
  25850   "RTN","RCX FMSUV",94, 0)
  25851    N DIC,Y
  25852   "RTN","RCX FMSUV",95, 0)
  25853    S DIC=340 ,DIC(0)="A EQM",DIC(" A")="Enter  Debtor to  be linked  to Vendor  File: ",D IC("S")="I  $P(^RCD(3 40,+Y,0),U )'[""PRC(" "" D ^DIC  Q:Y<0  S D EBTOR=+Y
  25854   "RTN","RCX FMSUV",96, 0)
  25855   LINK ;LINK S DEBTOR T O VENDOR F ILE
  25856   "RTN","RCX FMSUV",97, 0)
  25857    S VENDOR= $$VENSEL^P RCHUTL() I  VENDOR<0  S VENDOR=" LINK" Q
  25858   "RTN","RCX FMSUV",98, 0)
  25859    D STOREL( DEBTOR,VEN DOR) Q
  25860   "RTN","RCX FMSUV",99, 0)
  25861    ;
  25862   "RTN","RCX FMSUV",100 ,0)
  25863    ;
  25864   "RTN","RCX FMSUV",101 ,0)
  25865   STOREL(DA, VENDOR) ;   store the  link from  the debto r file to  the vendor  file
  25866   "RTN","RCX FMSUV",102 ,0)
  25867    N D,D0,DI ,DIC,DIE,D Q,DR,X,Y
  25868   "RTN","RCX FMSUV",103 ,0)
  25869    S DR=".06 ////"_VEND OR_";"
  25870   "RTN","RCX FMSUV",104 ,0)
  25871    S (DIC,DI E)="^RCD(3 40,"
  25872   "RTN","RCX FMSUV",105 ,0)
  25873    D ^DIE
  25874   "RTN","RCX FMSUV",106 ,0)
  25875    Q
  25876   "RTN","RCX FMSUV",107 ,0)
  25877    ;
  25878   "RTN","RCX FMSUV",108 ,0)
  25879    ;
  25880   "RTN","RCX FMSUV",109 ,0)
  25881   STORE(DA,V ENDORID) ; STORES THE  VENDOR ID  WITH THE  BILL
  25882   "RTN","RCX FMSUV",110 ,0)
  25883    I $G(^PRC A(430,DA,0 ))="" Q
  25884   "RTN","RCX FMSUV",111 ,0)
  25885    N D0,DI,D IC,DIE,DQ, DR,X,Y,D
  25886   "RTN","RCX FMSUV",112 ,0)
  25887    S DR="265 ////"_VEND ORID_";"
  25888   "RTN","RCX FMSUV",113 ,0)
  25889    S (DIC,DI E)="^PRCA( 430,"
  25890   "RTN","RCX FMSUV",114 ,0)
  25891    D ^DIE
  25892   "RTN","RCX FMSUV",115 ,0)
  25893    Q
  25894   "UP",430,4 30.0171,-1 )
  25895   430^17
  25896   "UP",430,4 30.0171,0)
  25897   430.0171
  25898   "VER")
  25899   8.0^22.2
  25900   "^DD",343, 343,0)
  25901   FIELD^^2^3
  25902   "^DD",343, 343,0,"DT" )
  25903   2931013
  25904   "^DD",343, 343,0,"ID" ,2)
  25905   W:$D(^(2))  "   ",$P( ^(2),U,1)
  25906   "^DD",343, 343,0,"IX" ,"B",343,. 01)
  25907  
  25908   "^DD",343, 343,0,"NM" ,"AR FORM  LETTER")
  25909  
  25910   "^DD",343, 343,0,"VRP K")
  25911   PRCA
  25912   "^DD",343, 343,.01,0)
  25913   NAME^RFI^^ 0;1^K:$L(X )>30!($L(X )<3)!'(X'? 1P.E) X
  25914   "^DD",343, 343,.01,1, 0)
  25915   ^.1
  25916   "^DD",343, 343,.01,1, 1,0)
  25917   343^B
  25918   "^DD",343, 343,.01,1, 1,1)
  25919   S ^RC(343, "B",$E(X,1 ,30),DA)=" "
  25920   "^DD",343, 343,.01,1, 1,2)
  25921   K ^RC(343, "B",$E(X,1 ,30),DA)
  25922   "^DD",343, 343,.01,1, 1,3)
  25923   Needed to  Look-up AR  FORM LETT ERS by nam e.
  25924   "^DD",343, 343,.01,1, 1,"%D",0)
  25925   ^^3^3^2930 609^
  25926   "^DD",343, 343,.01,1, 1,"%D",1,0 )
  25927   This cross  reference  is used t o look-up  follow-up  letters by  name
  25928   "^DD",343, 343,.01,1, 1,"%D",2,0 )
  25929   for users  and also w hen printi ng follow- up letters  for patie nt
  25930   "^DD",343, 343,.01,1, 1,"%D",3,0 )
  25931   statements  and bills .
  25932   "^DD",343, 343,.01,3)
  25933   Answer mus t be 3-30  characters  in length .
  25934   "^DD",343, 343,.01,21 ,0)
  25935   ^^8^8^2930 604^^
  25936   "^DD",343, 343,.01,21 ,1,0)
  25937   The AR for m letter n ame identi fies the F orm Letter  number.   Follow-up
  25938   "^DD",343, 343,.01,21 ,2,0)
  25939   letters ar e sent to  debtor's b ased on th e bill(s)  existing f or the
  25940   "^DD",343, 343,.01,21 ,3,0)
  25941   debtor.  W hen a cert ain bill i s to be ge nerated, t he AR pack age will
  25942   "^DD",343, 343,.01,21 ,4,0)
  25943   print the  appropriat e letter t o be attac hed to the  bill.
  25944   "^DD",343, 343,.01,21 ,5,0)
  25945    
  25946   "^DD",343, 343,.01,21 ,6,0)
  25947   The name o f the lett er SHOULD  NEVER be e dited as t he AR pack age looks
  25948   "^DD",343, 343,.01,21 ,7,0)
  25949   for letter s based on  the name.   If the n ame is cha nged, then  this will
  25950   "^DD",343, 343,.01,21 ,8,0)
  25951   cause the  letter not  to be gen erated.
  25952   "^DD",343, 343,.01,"D T")
  25953   2940321
  25954   "^DD",343, 343,1,0)
  25955   MAIN FORM  BODY^343.0 1^^1;0
  25956   "^DD",343, 343,1,21,0 )
  25957   ^^3^3^2931 116^^^^
  25958   "^DD",343, 343,1,21,1 ,0)
  25959   The Main B ody of the  letter is  stored as  a word-pr ocessing f ield so th at
  25960   "^DD",343, 343,1,21,2 ,0)
  25961   it can be  edited by  the user.   All lette rs have a  'header' a nd 'traile r'
  25962   "^DD",343, 343,1,21,3 ,0)
  25963   that follo w the main  body that  is not ed itable.
  25964   "^DD",343, 343,2,0)
  25965   DESCRIPTIO N^RF^^2;1^ K:$L(X)>65 !($L(X)<3)  X
  25966   "^DD",343, 343,2,3)
  25967   Answer mus t be 3-65  characters  in length .
  25968   "^DD",343, 343,2,21,0 )
  25969   ^^2^2^2930 609^^
  25970   "^DD",343, 343,2,21,1 ,0)
  25971   The descri ption of t he letter  gives a br ief over-v iew of the  purpose
  25972   "^DD",343, 343,2,21,2 ,0)
  25973   of the let ter and th e conditio ns that le tter shoul d be print ed.
  25974   "^DD",343, 343,2,"DT" )
  25975   2930518
  25976   "^DD",343, 343.01,0)
  25977   MAIN FORM  BODY SUB-F IELD^^.01^ 1
  25978   "^DD",343, 343.01,0," DT")
  25979   2931013
  25980   "^DD",343, 343.01,0," NM","MAIN  FORM BODY" )
  25981  
  25982   "^DD",343, 343.01,0," UP")
  25983   343
  25984   "^DD",343, 343.01,.01 ,0)
  25985   MAIN FORM  BODY^W^^0; 1^Q
  25986   "^DD",343, 343.01,.01 ,21,0)
  25987   ^^3^3^2931 116^^^
  25988   "^DD",343, 343.01,.01 ,21,1,0)
  25989   The Main B ody of the  letter is  stored as  a word-pr ocessing f ield so th at
  25990   "^DD",343, 343.01,.01 ,21,2,0)
  25991   it can be  edited by  the user.   All lette rs have a  "header" a nd "traile r"
  25992   "^DD",343, 343.01,.01 ,21,3,0)
  25993   that follo w the main  body that  is not ed itable.
  25994   "^DD",343, 343.01,.01 ,"DT")
  25995   2931013
  25996   "^DD",430, 430,156,0)
  25997   ORIGINAL D ATE REFERR ED TO TCSP ^D^^21;1^S  %DT="EX"  D ^%DT S X =Y K:X<1 X
  25998   "^DD",430, 430,156,3)
  25999   Type the o riginal da te that th e debt was  referred  to Cross-S ervicing.
  26000   "^DD",430, 430,156,21 ,0)
  26001   ^^8^8^3171 204^
  26002   "^DD",430, 430,156,21 ,1,0)
  26003   The origin al date th at the deb t was refe rred to Cr oss-Servic ing. This 
  26004   "^DD",430, 430,156,21 ,2,0)
  26005   field is o nly set on ce, when t he debt is  first ref erred to 
  26006   "^DD",430, 430,156,21 ,3,0)
  26007   Cross-Serv icing. Sin ce this fi eld was ad ded after  Cross-Serv icing 
  26008   "^DD",430, 430,156,21 ,4,0)
  26009   originated , it may n ot be accu rate. It i s not dele ted or res et with
  26010   "^DD",430, 430,156,21 ,5,0)
  26011   subsequent  actions o n the debt . The purp ose of thi s field is  to act as  a
  26012   "^DD",430, 430,156,21 ,6,0)
  26013   flag to de termine wh ether the  account ha s ever bee n sent to
  26014   "^DD",430, 430,156,21 ,7,0)
  26015   Cross-Serv icing, reg ardless of  its curre nt status.  It should  not be us ed
  26016   "^DD",430, 430,156,21 ,8,0)
  26017   for aging  or other c omputation s.
  26018   "^DD",430, 430,156,23 ,0)
  26019   ^^5^5^3171 204^
  26020   "^DD",430, 430,156,23 ,1,0)
  26021   This date  may be set  by the or iginal ref erral to C ross-Servi cing or by  
  26022   "^DD",430, 430,156,23 ,2,0)
  26023   other Cros s-Servicin g activiti es. It sho uld not be  used as a n accurate  
  26024   "^DD",430, 430,156,23 ,3,0)
  26025   date to ag e Cross-Se rvicing bi lls. It is  designed  to be used  as an 
  26026   "^DD",430, 430,156,23 ,4,0)
  26027   indicator  of whether  the bill  has ever b een referr ed to Cros s-Servicin g
  26028   "^DD",430, 430,156,23 ,5,0)
  26029   regardless  of its cu rrent stat us.
  26030   "^DD",430, 430,156,"D T")
  26031   3171204
  26032   "^DD",430, 430,171,0)
  26033   CS ADJ TRA NS NUMBER^ 430.0171PA ^^17;0
  26034   "^DD",430, 430,171,21 ,0)
  26035   ^^3^3^3170 601^
  26036   "^DD",430, 430,171,21 ,1,0)
  26037   The transa ction numb ers in the  AR Transa ction
  26038   "^DD",430, 430,171,21 ,2,0)
  26039   file (#433 ) for tran sactions t o be inclu ded
  26040   "^DD",430, 430,171,21 ,3,0)
  26041   in a 5B re cord to be  sent to C ross-Servi cing.
  26042   "^DD",430, 430,171,"D T")
  26043   3170601
  26044   "^DD",430, 430,301,0)
  26045   RETURNED D ATE^D^^30; 1^S %DT="E X" D ^%DT  S X=Y K:Y< 1 X
  26046   "^DD",430, 430,301,1, 0)
  26047   ^.1
  26048   "^DD",430, 430,301,1, 1,0)
  26049   430^AN
  26050   "^DD",430, 430,301,1, 1,1)
  26051   S ^PRCA(43 0,"AN",$E( X,1,30),DA )=""
  26052   "^DD",430, 430,301,1, 1,2)
  26053   K ^PRCA(43 0,"AN",$E( X,1,30),DA )
  26054   "^DD",430, 430,301,1, 1,"%D",0)
  26055   ^^1^1^3170 216^
  26056   "^DD",430, 430,301,1, 1,"%D",1,0 )
  26057   Cross-serv icing Retu rned Date  Index
  26058   "^DD",430, 430,301,1, 1,"DT")
  26059   3170216
  26060   "^DD",430, 430,301,3)
  26061   Type the r eturned da te for thi s reconcil iation rec ord.
  26062   "^DD",430, 430,301,21 ,0)
  26063   ^.001^3^3^ 3170216^^^ ^
  26064   "^DD",430, 430,301,21 ,1,0)
  26065   The return ed date fi eld on the  reconcili ation
  26066   "^DD",430, 430,301,21 ,2,0)
  26067   file for r ecords ret urned by T reasury fr om
  26068   "^DD",430, 430,301,21 ,3,0)
  26069   Cross-Serv icing.
  26070   "^DD",430, 430,301,"D T")
  26071   3170216
  26072   "^DD",430, 430.0171,0 )
  26073   CS ADJ TRA NS NUMBER  SUB-FIELD^ ^1^2
  26074   "^DD",430, 430.0171,0 ,"NM","CS  ADJ TRANS  NUMBER")
  26075  
  26076   "^DD",430, 430.0171,. 01,0)
  26077   CS ADJ TRA NS NUMBER^ P433'^PRCA (433,^0;1^ Q
  26078   "^DD",430, 430.0171,. 01,1,0)
  26079   ^.1
  26080   "^DD",430, 430.0171,. 01,1,1,0)
  26081   430.0171^B
  26082   "^DD",430, 430.0171,. 01,1,1,1)
  26083   S ^PRCA(43 0,DA(1),17 ,"B",$E(X, 1,30),DA)= ""
  26084   "^DD",430, 430.0171,. 01,1,1,2)
  26085   K ^PRCA(43 0,DA(1),17 ,"B",$E(X, 1,30),DA)
  26086   "^DD",430, 430.0171,. 01,3)
  26087   Enter a tr ansaction  number for  the 5B re cord.
  26088   "^DD",430, 430.0171,. 01,21,0)
  26089   ^^3^3^3170 601^
  26090   "^DD",430, 430.0171,. 01,21,1,0)
  26091   The transa ction numb er in the  AR Transac tion
  26092   "^DD",430, 430.0171,. 01,21,2,0)
  26093   file (#433 ) for tran sactions t o be inclu ded
  26094   "^DD",430, 430.0171,. 01,21,3,0)
  26095   in a 5B re cord to be  sent to C ross-Servi cing.
  26096   "^DD",430, 430.0171,. 01,"DT")
  26097   3170601
  26098   "^DD",430. 3,430.3,0)
  26099   FIELD^^5^6
  26100   "^DD",430. 3,430.3,0, "DT")
  26101   3170810
  26102   "^DD",430. 3,430.3,0, "IX","AC", 430.3,2)
  26103  
  26104   "^DD",430. 3,430.3,0, "IX","B",4 30.3,.01)
  26105  
  26106   "^DD",430. 3,430.3,0, "IX","C",4 30.3,1)
  26107  
  26108   "^DD",430. 3,430.3,0, "NM","ACCO UNTS RECEI VABLE TRAN S.TYPE")
  26109  
  26110   "^DD",430. 3,430.3,0, "PT",349.4 ,2)
  26111  
  26112   "^DD",430. 3,430.3,0, "PT",430,8 )
  26113  
  26114   "^DD",430. 3,430.3,0, "PT",430,9 5)
  26115  
  26116   "^DD",430. 3,430.3,0, "PT",433,1 2)
  26117  
  26118   "^DD",430. 3,430.3,0, "PT",433,1 8)
  26119  
  26120   "^DD",430. 3,430.3,.0 1,0)
  26121   NAME^RF^^0 ;1^K:$L(X) >30!($L(X) <3)!'(X'?1 P.E) X
  26122   "^DD",430. 3,430.3,.0 1,.1)
  26123   TRANSACTIO N TYPE
  26124   "^DD",430. 3,430.3,.0 1,1,0)
  26125   ^.1
  26126   "^DD",430. 3,430.3,.0 1,1,1,0)
  26127   430.3^B
  26128   "^DD",430. 3,430.3,.0 1,1,1,1)
  26129   S ^PRCA(43 0.3,"B",$E (X,1,30),D A)=""
  26130   "^DD",430. 3,430.3,.0 1,1,1,2)
  26131   K ^PRCA(43 0.3,"B",$E (X,1,30),D A)
  26132   "^DD",430. 3,430.3,.0 1,1,1,3)
  26133   Needed to  look-up AR  Transacti ons by nam e
  26134   "^DD",430. 3,430.3,.0 1,1,1,"%D" ,0)
  26135   ^^2^2^2930 602^^
  26136   "^DD",430. 3,430.3,.0 1,1,1,"%D" ,1,0)
  26137   This cross -reference  is used f or sorting  and file  look-up
  26138   "^DD",430. 3,430.3,.0 1,1,1,"%D" ,2,0)
  26139   by the AR  Transactio n Type.
  26140   "^DD",430. 3,430.3,.0 1,3)
  26141   Enter Tran saction Ty pe, 3-30 c haracters.
  26142   "^DD",430. 3,430.3,.0 1,21,0)
  26143   ^^2^2^2881 007^^
  26144   "^DD",430. 3,430.3,.0 1,21,1,0)
  26145   This is th e type use d to ident ify transa ctions in  the Transa ction
  26146   "^DD",430. 3,430.3,.0 1,21,2,0)
  26147   File (No.  433).
  26148   "^DD",430. 3,430.3,.0 1,"DT")
  26149   3170227
  26150   "^DD",430. 3,430.3,1, 0)
  26151   ABBREVIATI ON^RF^^0;2 ^K:X[""""! ($A(X)=45)  X I $D(X)  K:$L(X)>2 !($L(X)<1)  X
  26152   "^DD",430. 3,430.3,1, 1,0)
  26153   ^.1
  26154   "^DD",430. 3,430.3,1, 1,1,0)
  26155   430.3^C
  26156   "^DD",430. 3,430.3,1, 1,1,1)
  26157   S ^PRCA(43 0.3,"C",$E (X,1,30),D A)=""
  26158   "^DD",430. 3,430.3,1, 1,1,2)
  26159   K ^PRCA(43 0.3,"C",$E (X,1,30),D A)
  26160   "^DD",430. 3,430.3,1, 1,1,3)
  26161   Needed to  look-up AR  Transacti on types b y abbrevia tion
  26162   "^DD",430. 3,430.3,1, 1,1,"%D",0 )
  26163   ^^2^2^2930 602^^
  26164   "^DD",430. 3,430.3,1, 1,1,"%D",1 ,0)
  26165   This cross -reference  is used f or look-up  and sorti ng
  26166   "^DD",430. 3,430.3,1, 1,1,"%D",2 ,0)
  26167   transactio n types by  Abbreviat ion.
  26168   "^DD",430. 3,430.3,1, 3)
  26169   Enter a un ique abbre viation, 1 -2 charact ers.
  26170   "^DD",430. 3,430.3,1, 21,0)
  26171   ^^2^2^2880 826^^
  26172   "^DD",430. 3,430.3,1, 21,1,0)
  26173   This is an  abbreviat ion that c an be used  to enter  or look-up
  26174   "^DD",430. 3,430.3,1, 21,2,0)
  26175   the transa ction.
  26176   "^DD",430. 3,430.3,1, "DT")
  26177   3170810
  26178   "^DD",430. 3,430.3,2, 0)
  26179   STATUS NUM BER^NJ3,0X ^^0;3^K:+X '=X!(X>999 )!(X<0)!(X ?.E1"."1N. N) X I $D( X),$O(^PRC A(430.3,"A C",X,0))>0 ,$O(^(0))' =DA K X
  26180   "^DD",430. 3,430.3,2, 1,0)
  26181   ^.1
  26182   "^DD",430. 3,430.3,2, 1,1,0)
  26183   430.3^AC^M UMPS
  26184   "^DD",430. 3,430.3,2, 1,1,1)
  26185   S ^PRCA(43 0.3,"AC",X ,DA)=""
  26186   "^DD",430. 3,430.3,2, 1,1,2)
  26187   K ^PRCA(43 0.3,"AC",X ,DA)
  26188   "^DD",430. 3,430.3,2, 1,1,3)
  26189   Needed to  look-up AR  Transacti ons by num ber
  26190   "^DD",430. 3,430.3,2, 1,1,"%D",0 )
  26191   ^^2^2^2930 602^^^^
  26192   "^DD",430. 3,430.3,2, 1,1,"%D",1 ,0)
  26193   This cross -reference  is used f or look-up  by Status  Number.
  26194   "^DD",430. 3,430.3,2, 1,1,"%D",2 ,0)
  26195    
  26196   "^DD",430. 3,430.3,2, 3)
  26197   Enter a wh ole number  between 0  and 999.
  26198   "^DD",430. 3,430.3,2, 21,0)
  26199   ^^2^2^2880 826^
  26200   "^DD",430. 3,430.3,2, 21,1,0)
  26201   This is an  internal  number whi ch the sys tem uses t o prevent
  26202   "^DD",430. 3,430.3,2, 21,2,0)
  26203   duplicate  transactio n types. T he user wi ll not see  this numb er.
  26204   "^DD",430. 3,430.3,2, "DT")
  26205   3170419
  26206   "^DD",430. 3,430.3,3, 0)
  26207   CALM CODE  TYPE^S^0:N O;1:YES;^0 ;4^Q
  26208   "^DD",430. 3,430.3,3, 3)
  26209   Enter 1 if  the Trans action Typ e needs a  CALM Code  Sheet, or  0 if it do esn't.
  26210   "^DD",430. 3,430.3,3, 21,0)
  26211   ^^2^2^2880 826^
  26212   "^DD",430. 3,430.3,3, 21,1,0)
  26213   This is a  code used  to indicat e whether  or not thi s transact ion
  26214   "^DD",430. 3,430.3,3, 21,2,0)
  26215   type needs  to genera te a CALM  code sheet .
  26216   "^DD",430. 3,430.3,3, "DT")
  26217   2880331
  26218   "^DD",430. 3,430.3,4, 0)
  26219   OLD BILL S TATUS^S^0: NO;1:YES;^ 0;5^Q
  26220   "^DD",430. 3,430.3,4, 3)
  26221   ANSWER IF  THIS TYPE  CAN BE STA TUS OF THE  'OLD BILL '
  26222   "^DD",430. 3,430.3,4, 21,0)
  26223   ^^3^3^2880 928^^^^
  26224   "^DD",430. 3,430.3,4, 21,1,0)
  26225   This field  is set to  a flag th at will no t allow th e transact ion
  26226   "^DD",430. 3,430.3,4, 21,2,0)
  26227   type to be  used with  old bills  that are  back-loade d into the
  26228   "^DD",430. 3,430.3,4, 21,3,0)
  26229   system.
  26230   "^DD",430. 3,430.3,4, "DT")
  26231   2880928
  26232   "^DD",430. 3,430.3,5, 0)
  26233   CBO EXTRAC T FLAG^S^1 :Include;0 :Do not In clude;^0;6 ^Q
  26234   "^DD",430. 3,430.3,5, 3)
  26235   Enter '1'  to include  records w ith this t ransaction  type for  the data e xtract.
  26236   "^DD",430. 3,430.3,5, 21,0)
  26237   ^^5^5^3030 722^
  26238   "^DD",430. 3,430.3,5, 21,1,0)
  26239   This field  will be u sed as a f lag to det ermine if  a record w ith
  26240   "^DD",430. 3,430.3,5, 21,2,0)
  26241   this trans action typ e should b e included  in the CB OC data ex tract.
  26242   "^DD",430. 3,430.3,5, 21,3,0)
  26243     
  26244   "^DD",430. 3,430.3,5, 21,4,0)
  26245   '1' will i nclude thi s type and  no entry  or '0' wil l not incl ude this
  26246   "^DD",430. 3,430.3,5, 21,5,0)
  26247   type.
  26248   "^DD",430. 3,430.3,5, "DT")
  26249   3031119
  26250   "^DIC",343 ,343,0)
  26251   AR FORM LE TTER^343I
  26252   "^DIC",343 ,343,0,"GL ")
  26253   ^RC(343,
  26254   "^DIC",343 ,343,"%D", 0)
  26255   ^^5^5^2941 108^^^
  26256   "^DIC",343 ,343,"%D", 1,0)
  26257   This file  holds all  the follow -up letter s that the  AR packag e supports .
  26258   "^DIC",343 ,343,"%D", 2,0)
  26259   These lett ers can ei ther be ma nually gen erated by  the user o r automati cally
  26260   "^DIC",343 ,343,"%D", 3,0)
  26261   generated  by the AR  package.
  26262   "^DIC",343 ,343,"%D", 4,0)
  26263    
  26264   "^DIC",343 ,343,"%D", 5,0)
  26265   Per VHA Di rective 10 -93-142, t his file d efinition  should not  be modifi ed.
  26266   "^DIC",343 ,"B","AR F ORM LETTER ",343)
  26267  
  26268   "^DIC",430 .3,430.3,0 )
  26269   ACCOUNTS R ECEIVABLE  TRANS.TYPE ^430.3
  26270   "^DIC",430 .3,430.3,0 ,"GL")
  26271   ^PRCA(430. 3,
  26272   "^DIC",430 .3,430.3," %D",0)
  26273   ^^5^5^2941 108^^^^
  26274   "^DIC",430 .3,430.3," %D",1,0)
  26275   This file  stores the  type cate gories use d to ident ify transa ctions in  the
  26276   "^DIC",430 .3,430.3," %D",2,0)
  26277   Transactio n File (No . 433) alo ng with fl ags that a re set to  control th eir
  26278   "^DIC",430 .3,430.3," %D",3,0)
  26279   use. DO NO T EDIT THI S FILE !
  26280   "^DIC",430 .3,430.3," %D",4,0)
  26281    
  26282   "^DIC",430 .3,430.3," %D",5,0)
  26283   Per VHA Di rective 10 -93-142, t his file d efinition  should not  be modifi ed.
  26284   "^DIC",430 .3,"B","AC COUNTS REC EIVABLE TR ANS.TYPE", 430.3)
  26285  
  26286   "BLD",1019 1,6)
  26287   17^
  26288   $END KID P RCA*4.5*31 5