7. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 2/13/2017 11:55:29 AM 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.

7.1 Files compared

# Location File Last Modified
1 CPAC.zip\Cpac billing patches.zip PRCA_4_5_310_TEST_V1.KID Tue Jan 31 16:09:16 2017 UTC
2 CPAC.zip\Cpac billing patches.zip PRCA_4_5_310_TEST_V1.KID Mon Feb 13 15:51:22 2017 UTC

7.2 Comparison summary

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

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

7.4 Active regular expressions

No regular expressions were active.

7.5 Comparison detail

  1   PRCA*4.5*3 10 TEST v1 4
  2   Extracted  from mail  message
  3   **KIDS**:P RCA*4.5*31 0^
  4  
  5   **INSTALL  NAME**
  6   PRCA*4.5*3 10
  7   "BLD",9717 ,0)
  8   PRCA*4.5*3 10^ACCOUNT S RECEIVAB LE^0^31609 29^y
  9   "BLD",9717 ,4,0)
  10   ^9.64PA^^
  11   "BLD",9717 ,6.3)
  12   14
  13   "BLD",9717 ,"ABPKG")
  14   n
  15   "BLD",9717 ,"INIT")
  16   POSTINIT^P RCAP310
  17   "BLD",9717 ,"KRN",0)
  18   ^9.67PA^77 9.2^20
  19   "BLD",9717 ,"KRN",.4, 0)
  20   .4
  21   "BLD",9717 ,"KRN",.40 1,0)
  22   .401
  23   "BLD",9717 ,"KRN",.40 2,0)
  24   .402
  25   "BLD",9717 ,"KRN",.40 3,0)
  26   .403
  27   "BLD",9717 ,"KRN",.5, 0)
  28   .5
  29   "BLD",9717 ,"KRN",.84 ,0)
  30   .84
  31   "BLD",9717 ,"KRN",3.6 ,0)
  32   3.6
  33   "BLD",9717 ,"KRN",3.8 ,0)
  34   3.8
  35   "BLD",9717 ,"KRN",9.2 ,0)
  36   9.2
  37   "BLD",9717 ,"KRN",9.8 ,0)
  38   9.8
  39   "BLD",9717 ,"KRN",9.8 ,"NM",0)
  40   ^9.68A^10^ 10
  41   "BLD",9717 ,"KRN",9.8 ,"NM",1,0)
  42   RCXFMSPR^^ 0^B2761357 9
  43   "BLD",9717 ,"KRN",9.8 ,"NM",2,0)
  44   PRCAACC^^0 ^B8690733
  45   "BLD",9717 ,"KRN",9.8 ,"NM",3,0)
  46   RCRJRBD^^0 ^B74247917
  47   "BLD",9717 ,"KRN",9.8 ,"NM",4,0)
  48   RCRJRDEP^^ 0^B6433768 4
  49   "BLD",9717 ,"KRN",9.8 ,"NM",5,0)
  50   RCXFMSUF^^ 0^B3745070 0
  51   "BLD",9717 ,"KRN",9.8 ,"NM",6,0)
  52   RCXFMSUR^^ 0^B6095086 3
  53   "BLD",9717 ,"KRN",9.8 ,"NM",7,0)
  54   RCTRAN1^^0 ^B8197752
  55   "BLD",9717 ,"KRN",9.8 ,"NM",8,0)
  56   RCRJRBDT^^ 0^B5791773 6
  57   "BLD",9717 ,"KRN",9.8 ,"NM",9,0)
  58   PRCABJV^^0 ^B30343584
  59   "BLD",9717 ,"KRN",9.8 ,"NM",10,0 )
  60   RCRJRBDR^^ 0^B7628086 7
  61   "BLD",9717 ,"KRN",9.8 ,"NM","B", "PRCAACC", 2)
  62  
  63   "BLD",9717 ,"KRN",9.8 ,"NM","B", "PRCABJV", 9)
  64  
  65   "BLD",9717 ,"KRN",9.8 ,"NM","B", "RCRJRBD", 3)
  66  
  67   "BLD",9717 ,"KRN",9.8 ,"NM","B", "RCRJRBDR" ,10)
  68  
  69   "BLD",9717 ,"KRN",9.8 ,"NM","B", "RCRJRBDT" ,8)
  70  
  71   "BLD",9717 ,"KRN",9.8 ,"NM","B", "RCRJRDEP" ,4)
  72  
  73   "BLD",9717 ,"KRN",9.8 ,"NM","B", "RCTRAN1", 7)
  74  
  75   "BLD",9717 ,"KRN",9.8 ,"NM","B", "RCXFMSPR" ,1)
  76  
  77   "BLD",9717 ,"KRN",9.8 ,"NM","B", "RCXFMSUF" ,5)
  78  
  79   "BLD",9717 ,"KRN",9.8 ,"NM","B", "RCXFMSUR" ,6)
  80  
  81   "BLD",9717 ,"KRN",19, 0)
  82   19
  83   "BLD",9717 ,"KRN",19, "NM",0)
  84   ^9.68A^^
  85   "BLD",9717 ,"KRN",19. 1,0)
  86   19.1
  87   "BLD",9717 ,"KRN",101 ,0)
  88   101
  89   "BLD",9717 ,"KRN",409 .61,0)
  90   409.61
  91   "BLD",9717 ,"KRN",771 ,0)
  92   771
  93   "BLD",9717 ,"KRN",779 .2,0)
  94   779.2
  95   "BLD",9717 ,"KRN",870 ,0)
  96   870
  97   "BLD",9717 ,"KRN",898 9.51,0)
  98   8989.51
  99   "BLD",9717 ,"KRN",898 9.52,0)
  100   8989.52
  101   "BLD",9717 ,"KRN",899 4,0)
  102   8994
  103   "BLD",9717 ,"KRN","B" ,.4,.4)
  104  
  105   "BLD",9717 ,"KRN","B" ,.401,.401 )
  106  
  107   "BLD",9717 ,"KRN","B" ,.402,.402 )
  108  
  109   "BLD",9717 ,"KRN","B" ,.403,.403 )
  110  
  111   "BLD",9717 ,"KRN","B" ,.5,.5)
  112  
  113   "BLD",9717 ,"KRN","B" ,.84,.84)
  114  
  115   "BLD",9717 ,"KRN","B" ,3.6,3.6)
  116  
  117   "BLD",9717 ,"KRN","B" ,3.8,3.8)
  118  
  119   "BLD",9717 ,"KRN","B" ,9.2,9.2)
  120  
  121   "BLD",9717 ,"KRN","B" ,9.8,9.8)
  122  
  123   "BLD",9717 ,"KRN","B" ,19,19)
  124  
  125   "BLD",9717 ,"KRN","B" ,19.1,19.1 )
  126  
  127   "BLD",9717 ,"KRN","B" ,101,101)
  128  
  129   "BLD",9717 ,"KRN","B" ,409.61,40 9.61)
  130  
  131   "BLD",9717 ,"KRN","B" ,771,771)
  132  
  133   "BLD",9717 ,"KRN","B" ,779.2,779 .2)
  134  
  135   "BLD",9717 ,"KRN","B" ,870,870)
  136  
  137   "BLD",9717 ,"KRN","B" ,8989.51,8 989.51)
  138  
  139   "BLD",9717 ,"KRN","B" ,8989.52,8 989.52)
  140  
  141   "BLD",9717 ,"KRN","B" ,8994,8994 )
  142  
  143   "BLD",9717 ,"QDEF")
  144   ^^^^^^^^^^ YES
  145   "BLD",9717 ,"QUES",0)
  146   ^9.62^^
  147   "BLD",9717 ,"REQB",0)
  148   ^9.611^3^3
  149   "BLD",9717 ,"REQB",1, 0)
  150   PRCA*4.5*2 73^1
  151   "BLD",9717 ,"REQB",2, 0)
  152   PRCA*4.5*2 82^1
  153   "BLD",9717 ,"REQB",3, 0)
  154   PRCA*4.5*1 04^1
  155   "BLD",9717 ,"REQB","B ","PRCA*4. 5*104",3)
  156  
  157   "BLD",9717 ,"REQB","B ","PRCA*4. 5*273",1)
  158  
  159   "BLD",9717 ,"REQB","B ","PRCA*4. 5*282",2)
  160  
  161   "INIT")
  162   POSTINIT^P RCAP310
  163   "MBREQ")
  164   0
  165   "PKG",142, -1)
  166   1^1
  167   "PKG",142, 0)
  168   ACCOUNTS R ECEIVABLE^ PRCA^BILL  COLLECTION S
  169   "PKG",142, 20,0)
  170   ^9.402P^1^ 1
  171   "PKG",142, 20,1,0)
  172   2^^PRCAMRG
  173   "PKG",142, 20,1,1)
  174  
  175   "PKG",142, 20,"B",2,1 )
  176  
  177   "PKG",142, 22,0)
  178   ^9.49I^1^1
  179   "PKG",142, 22,1,0)
  180   4.5^^29503 20
  181   "PKG",142, 22,1,"PAH" ,1,0)
  182   310^316092 9^101114
  183   "QUES","XP F1",0)
  184   Y
  185   "QUES","XP F1","??")
  186   ^D REP^XPD H
  187   "QUES","XP F1","A")
  188   Shall I wr ite over y our |FLAG|  File
  189   "QUES","XP F1","B")
  190   YES
  191   "QUES","XP F1","M")
  192   D XPF1^XPD IQ
  193   "QUES","XP F2",0)
  194   Y
  195   "QUES","XP F2","??")
  196   ^D DTA^XPD H
  197   "QUES","XP F2","A")
  198   Want my da ta |FLAG|  yours
  199   "QUES","XP F2","B")
  200   YES
  201   "QUES","XP F2","M")
  202   D XPF2^XPD IQ
  203   "QUES","XP I1",0)
  204   YO
  205   "QUES","XP I1","??")
  206   ^D INHIBIT ^XPDH
  207   "QUES","XP I1","A")
  208   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  209   "QUES","XP I1","B")
  210   NO
  211   "QUES","XP I1","M")
  212   D XPI1^XPD IQ
  213   "QUES","XP M1",0)
  214   PO^VA(200, :EM
  215   "QUES","XP M1","??")
  216   ^D MG^XPDH
  217   "QUES","XP M1","A")
  218   Enter the  Coordinato r for Mail  Group '|F LAG|'
  219   "QUES","XP M1","B")
  220  
  221   "QUES","XP M1","M")
  222   D XPM1^XPD IQ
  223   "QUES","XP O1",0)
  224   Y
  225   "QUES","XP O1","??")
  226   ^D MENU^XP DH
  227   "QUES","XP O1","A")
  228   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  229   "QUES","XP O1","B")
  230   NO
  231   "QUES","XP O1","M")
  232   D XPO1^XPD IQ
  233   "QUES","XP Z1",0)
  234   Y
  235   "QUES","XP Z1","??")
  236   ^D OPT^XPD H
  237   "QUES","XP Z1","A")
  238   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  239   "QUES","XP Z1","B")
  240   YES
  241   "QUES","XP Z1","M")
  242   D XPZ1^XPD IQ
  243   "QUES","XP Z2",0)
  244   Y
  245   "QUES","XP Z2","??")
  246   ^D RTN^XPD H
  247   "QUES","XP Z2","A")
  248   Want to MO VE routine s to other  CPUs
  249   "QUES","XP Z2","B")
  250   NO
  251   "QUES","XP Z2","M")
  252   D XPZ2^XPD IQ
  253   "RTN")
  254   11
  255   "RTN","PRC AACC")
  256   0^2^B86907 33^B884685 9
  257   "RTN","PRC AACC",1,0)
  258   PRCAACC ;W ASH-ISC@AL TOONA,PA/C MS-AR ACCR UAL TOTALS  ;10/19/10  1:36pm
  259   "RTN","PRC AACC",2,0)
  260    ;;4.5;Acc ounts Rece ivable;**6 0,74,90,10 1,157,203, 220,273,31 0**;Mar 20 , 1995;Bui ld 14
  261   "RTN","PRC AACC",3,0)
  262    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  263   "RTN","PRC AACC",4,0)
  264    NEW PRCAQ UE,PRCADEV ,PRCA,ZTSK
  265   "RTN","PRC AACC",5,0)
  266    S PRCA("M ESS")="Do  you wish t o queue th is report"  D QUE^PRC AQUE G:'$D (PRCAQUE)  Q
  267   "RTN","PRC AACC",6,0)
  268    I $D(IO(" Q")) S ZTR TN="DQ^PRC AACC",ZTDE SC="AR Acc rual Total s" D ^%ZTL OAD G Q
  269   "RTN","PRC AACC",7,0)
  270   DQ ;
  271   "RTN","PRC AACC",8,0)
  272    U IO
  273   "RTN","PRC AACC",9,0)
  274    NEW BILLN ,COM,TOT,S TAT,X,Y
  275   "RTN","PRC AACC",10,0 )
  276    S BILLN=0
  277   "RTN","PRC AACC",11,0 )
  278    D COM G:$ O(COM("")) ="" RPT
  279   "RTN","PRC AACC",12,0 )
  280    F STAT=42 ,16 F  S B ILLN=$O(^P RCA(430,"A C",STAT,BI LLN)) Q:'B ILLN  I $$ ACCK(BILLN ) D
  281   "RTN","PRC AACC",13,0 )
  282    .S X=("," _$P(^PRCA( 430,BILLN, 0),"^",2)_ ",")
  283   "RTN","PRC AACC",14,0 )
  284    .S TOT(X) =$G(TOT(X) )+$G(^PRCA (430,BILLN ,7))
  285   "RTN","PRC AACC",15,0 )
  286    .QUIT
  287   "RTN","PRC AACC",16,0 )
  288   RPT D NOW^ %DTC W @IO F,!!,?23," Accrual To tals Repor t",!?20,"A s of: " S  Y=% X ^DD( "DD") W Y, !
  289   "RTN","PRC AACC",17,0 )
  290    S X="",$P (X,"=",80) ="" W X
  291   "RTN","PRC AACC",18,0 )
  292    W:$O(COM( ""))="" !! ,"WARNING:  Accruals  are *NOT*  set-up cor rectly.",! ,"No RX ac crual comm on numberi ng series  are set-up  in AR Bil l Number F ile!",!!
  293   "RTN","PRC AACC",19,0 )
  294    S TOT=$G( TOT(",22," ))+$G(TOT( ",23,")) I  TOT W !!! ,"RX CO-PA YMENT  Acc rual Amoun t: $",$FN( TOT,",",2)
  295   "RTN","PRC AACC",20,0 )
  296    I $G(TOT( ",18,"))>0  W !!!,"C  (MEANS TES T)  Accrua l Amount:  $",$FN(TOT (",18,")," ,",2)
  297   "RTN","PRC AACC",21,0 )
  298    W !!!!,"I ncludes Co mmon Numbe ring Serie s:",! S CO M="" F  S  COM=$O(COM (COM)) Q:C OM=""  W ! ,COM,?20,C OM(COM)
  299   "RTN","PRC AACC",22,0 )
  300   Q D ^%ZISC  S IOP=IO( 0) D ^%ZIS  K IOP,IO( "Q") Q
  301   "RTN","PRC AACC",23,0 )
  302   ACCK(BN) ; Check BILL N to see i f Accrual
  303   "RTN","PRC AACC",24,0 )
  304    N ACC,ACT DATE,CAT,F UND,DB
  305   "RTN","PRC AACC",25,0 )
  306    S CAT=+$P (^PRCA(430 ,BN,0),"^" ,2)
  307   "RTN","PRC AACC",26,0 )
  308    ;  field  12, ACCRUE D ? where  0=no 1=yes , 2=could  be either
  309   "RTN","PRC AACC",27,0 )
  310    S ACC=+$P ($G(^PRCA( 430.2,CAT, 0)),"^",9)
  311   "RTN","PRC AACC",28,0 )
  312    ;  it cou ld be eith er accrued  or non-ac crued
  313   "RTN","PRC AACC",29,0 )
  314    I ACC=2 D
  315   "RTN","PRC AACC",30,0 )
  316    .   S FUN D=$P($G(^P RCA(430,BN ,11)),"^", 17)
  317   "RTN","PRC AACC",31,0 )
  318    .   S ACC =$S(FUND=5 014:1,FUND =2431:1,1: 0)
  319   "RTN","PRC AACC",32,0 )
  320    .   I $E( FUND,1,4)= 5287 S ACC =$$PTACCT( FUND)
  321   "RTN","PRC AACC",33,0 )
  322    .   ;  sp ecial case  with Work man's Comp
  323   "RTN","PRC AACC",34,0 )
  324    .   I ACC =0,CAT=6,F UND="" D
  325   "RTN","PRC AACC",35,0 )
  326    .   .   S  DB=$P($G( ^RCD(340,+ $P($G(^PRC A(430,BN,0 )),U,9),0) ),U)
  327   "RTN","PRC AACC",36,0 )
  328    .   .   I  DB[";DPT" !($P($G(^P RCA(430,BN ,0)),U,7)' ="") S ACC =1
  329   "RTN","PRC AACC",37,0 )
  330    ;
  331   "RTN","PRC AACC",38,0 )
  332    ;  public  law state s that bil ls in the  category i neligible  (1),
  333   "RTN","PRC AACC",39,0 )
  334    ;  emerg/ human (2),  torts (10 ), or medi care (21)  which are  older 
  335   "RTN","PRC AACC",40,0 )
  336    ;  than o ct 1, 1992  should be  treated a s non-accr ued.
  337   "RTN","PRC AACC",41,0 )
  338    I CAT=1!( CAT=2)!(CA T=10)!(CAT =21) D
  339   "RTN","PRC AACC",42,0 )
  340    .   S ACT DATE=$P($G (^PRCA(430 ,BN,6)),"^ ",21) I 'A CTDATE S A CTDATE=DT
  341   "RTN","PRC AACC",43,0 )
  342    .   I ACT DATE<29210 01 S ACC=0
  343   "RTN","PRC AACC",44,0 )
  344    .   ;
  345   "RTN","PRC AACC",45,0 )
  346    .   ;  pa tch157 cha nges ineli gibles.  a n ineligib le created  before
  347   "RTN","PRC AACC",46,0 )
  348    .   ;  oc t 1, 1992  or after s ep 30, 200 0 will be  non-accrue d.
  349   "RTN","PRC AACC",47,0 )
  350    .   ;  ot herwise it  will be a ccrued.
  351   "RTN","PRC AACC",48,0 )
  352    .   I CAT =1,ACTDATE >3000930 S  ACC=0
  353   "RTN","PRC AACC",49,0 )
  354    ;
  355   "RTN","PRC AACC",50,0 )
  356    Q ACC
  357   "RTN","PRC AACC",51,0 )
  358   COM ;Find  Accrual co mmon numbe ring serie s
  359   "RTN","PRC AACC",52,0 )
  360    S COM=0
  361   "RTN","PRC AACC",53,0 )
  362    F  S COM= $O(^PRCA(4 30.4,COM))  Q:'COM  I  $P(^PRCA( 430.4,COM, 0),"^",6)  S COM($P(^ PRCA(430.4 ,COM,0),"^ "))=$P($G( ^DIC(49,$P (^(0),"^", 5),0)),"^" ,1)
  363   "RTN","PRC AACC",54,0 )
  364    Q
  365   "RTN","PRC AACC",55,0 )
  366   PTACCT(FUN D) ;Determ ines wheth er Point A ccounts ar e accrued
  367   "RTN","PRC AACC",56,0 )
  368    ;returns  1 for accr ued funds  528701,528 702,528703 ,528704,52 8709,52871 1
  369   "RTN","PRC AACC",57,0 )
  370    ;returns  0 for any  other fund
  371   "RTN","PRC AACC",58,0 )
  372    ;PRCA*4.5 *310/DRF A dded 52871 3 to accru ed funds
  373   "RTN","PRC AACC",59,0 )
  374    I FUND'[5 287 Q 0
  375   "RTN","PRC AACC",60,0 )
  376    S X=$E(FU ND,5,6),X= $S(X="09"! (X="11")!( X="13"):1, X<"05":1,1 :0)
  377   "RTN","PRC AACC",61,0 )
  378    Q X
  379   "RTN","PRC AACC",62,0 )
  380   ADDPTEDT()  ;Effectiv e date of  additional  point acc ounts 
  381   "RTN","PRC AACC",63,0 )
  382    ;       ( 528705 - 5 28708 and  528710)
  383   "RTN","PRC AACC",64,0 )
  384    ;Effectiv e date of  switch fro m 4032 to  528709
  385   "RTN","PRC AACC",65,0 )
  386    Q 3040928
  387   "RTN","PRC ABJV")
  388   0^9^B30343 584^B30084 731
  389   "RTN","PRC ABJV",1,0)
  390   PRCABJV ;W ASH-ISC@AL TOONA,PA/T JK-FILE VE RIFICATION  FOR BACKG ROUND JOB  ;4/6/95  1 0:13 AM
  391   "RTN","PRC ABJV",2,0)
  392   V ;;4.5;Ac counts Rec eivable;** 1,48,63,11 4,141,170, 176,173,19 2,220,296, 310**;Mar  20, 1995;B uild 14
  393   "RTN","PRC ABJV",3,0)
  394    ;;patch 1 92 changes  all occur rences of  CHAMPUS to  TRICARE
  395   "RTN","PRC ABJV",4,0)
  396    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  397   "RTN","PRC ABJV",5,0)
  398   EN1(FILE,X 1,X2,ERROR ) ;
  399   "RTN","PRC ABJV",6,0)
  400    ;FILE IS  THE FILE N UMBER
  401   "RTN","PRC ABJV",7,0)
  402    ;X1 AND X 2 ARE 3 PA RT VARIABL ES SEPARAT ED BY SEMI -COLONS WI TH
  403   "RTN","PRC ABJV",8,0)
  404    ;THE FORM AT (X-REF  INDEX;NODE ;PIECE)
  405   "RTN","PRC ABJV",9,0)
  406    ;AN ERROR  ARRAY IS  SET IF VAL IDATION FA ILS
  407   "RTN","PRC ABJV",10,0 )
  408    NEW LT,CN T,I,I1,I2, I3,REC,IND ,ND,PC,DAT A,J,LN,FIL ENT
  409   "RTN","PRC ABJV",11,0 )
  410    S LT=$S(F ILE[430.3: "TRANST",F ILE[430.2: "CAT",1:"E VENT"),CNT =0
  411   "RTN","PRC ABJV",12,0 )
  412    F I=1,2 S  J=@("X"_I ),IND(I)=$ P(J,";"),N D(I)=$P(J, ";",2),PC( I)=$P(J,"; ",3)
  413   "RTN","PRC ABJV",13,0 )
  414    F I1=1:1  D  Q:(DATA (0)="EOF") !(ERROR)
  415   "RTN","PRC ABJV",14,0 )
  416       .S LN= $T(@LT+I1)  F I=3:1:6  S DATA(I- 3)=$P(LN," ;",I)
  417   "RTN","PRC ABJV",15,0 )
  418       .Q:DAT A(0)="EOF"
  419   "RTN","PRC ABJV",16,0 )
  420       .G RC: FILE<430
  421   "RTN","PRC ABJV",17,0 )
  422       .I '$D (^PRCA(FIL E,"B",DATA (0))) S ER ROR=1 Q
  423   "RTN","PRC ABJV",18,0 )
  424       .S REC =$O(^PRCA( FILE,"B",D ATA(0),0))  I 'REC S  ERROR=1 Q
  425   "RTN","PRC ABJV",19,0 )
  426       .I DAT A(3)'=REC  S ERROR=1  Q
  427   "RTN","PRC ABJV",20,0 )
  428       .I $P( ^PRCA(FILE ,REC,0),U) '=DATA(0)  S ERROR=1  Q
  429   "RTN","PRC ABJV",21,0 )
  430       .G CNT :X1=""
  431   "RTN","PRC ABJV",22,0 )
  432       .F I2= 1,2 D  Q:E RROR  I I2 =1,X2="" Q
  433   "RTN","PRC ABJV",23,0 )
  434          ..I  '$D(^PRCA (FILE,IND( I2),DATA(I 2))) S ERR OR=1 G Q2
  435   "RTN","PRC ABJV",24,0 )
  436          ..;   do not c heck if ca tegory num ber is a z ero
  437   "RTN","PRC ABJV",25,0 )
  438          ..I  I2=1,DATA (1)'=0,$O( ^PRCA(FILE ,IND(I2),D ATA(I2),0) )'=REC S E RROR=1 G Q 2
  439   "RTN","PRC ABJV",26,0 )
  440          ..I  $P(^PRCA( FILE,REC,N D(I2)),U,P C(I2))'=DA TA(I2) S E RROR=1
  441   "RTN","PRC ABJV",27,0 )
  442   Q2       . .Q
  443   "RTN","PRC ABJV",28,0 )
  444   CNT    .Q: ERROR
  445   "RTN","PRC ABJV",29,0 )
  446       .S CNT =CNT+1
  447   "RTN","PRC ABJV",30,0 )
  448   Q1    .Q
  449   "RTN","PRC ABJV",31,0 )
  450   RC    .I ' $D(^RC(FIL E,"B",DATA (0))) S ER ROR=1 Q
  451   "RTN","PRC ABJV",32,0 )
  452       .S REC =$O(^RC(FI LE,"B",DAT A(0),0)) I  'REC S ER ROR=1 Q
  453   "RTN","PRC ABJV",33,0 )
  454       .I DAT A(3)'=REC  S ERROR=1  Q
  455   "RTN","PRC ABJV",34,0 )
  456       .I $P( ^RC(FILE,R EC,0),U)'= DATA(0) S  ERROR=1 Q
  457   "RTN","PRC ABJV",35,0 )
  458       .G CNT :X1=""
  459   "RTN","PRC ABJV",36,0 )
  460       .F I3= 1,2 D  Q:E RROR  I I3 =1,X2="" Q
  461   "RTN","PRC ABJV",37,0 )
  462          ..I  '$D(^RC(F ILE,IND(I3 ),DATA(I3) )) S ERROR =1 G Q3
  463   "RTN","PRC ABJV",38,0 )
  464          ..I  $O(^RC(FI LE,IND(I3) ,DATA(I3), 0))'=REC S  ERROR=1 G  Q3
  465   "RTN","PRC ABJV",39,0 )
  466          ..I  $P(^RC(FI LE,REC,ND( I3)),U,PC( I3))'=DATA (I3) S ERR OR=1
  467   "RTN","PRC ABJV",40,0 )
  468   Q3       . .Q
  469   "RTN","PRC ABJV",41,0 )
  470       .G CNT
  471   "RTN","PRC ABJV",42,0 )
  472    I FILE>42 9.99,$P(^P RCA(FILE,0 ),U,4)'=CN T S ERROR= 1 G EXIT
  473   "RTN","PRC ABJV",43,0 )
  474    G EXIT:FI LE>429.99
  475   "RTN","PRC ABJV",44,0 )
  476    I $P(^RC( FILE,0),U, 4)'=CNT S  ERROR=1
  477   "RTN","PRC ABJV",45,0 )
  478   EXIT Q:'ER ROR
  479   "RTN","PRC ABJV",46,0 )
  480    S FILENT= $S(FILE>42 9.99:$P(^P RCA(FILE,0 ),U,4),1:$ P(^RC(FILE ,0),U,4))
  481   "RTN","PRC ABJV",47,0 )
  482    S ERROR(1 )="An erro r has been  detected  in the "_$ P(^DIC(FIL E,0),U)_"  File."
  483   "RTN","PRC ABJV",48,0 )
  484    I DATA(0) ="EOF" S E RROR(2)="T here are t oo many en tries in y our file."
  485   "RTN","PRC ABJV",49,0 )
  486    I DATA(0) '="EOF" S  ERROR(2)=" The "_DATA (0)_" Entr y in your  file is mi ssing or c orrupted."
  487   "RTN","PRC ABJV",50,0 )
  488    Q
  489   "RTN","PRC ABJV",51,0 )
  490   TRANST ;
  491   "RTN","PRC ABJV",52,0 )
  492    ;;ACTIVE; 102;A;16
  493   "RTN","PRC ABJV",53,0 )
  494    ;;ADD (AM END);302;A D;37
  495   "RTN","PRC ABJV",54,0 )
  496    ;;ADMIN.C OST CHARGE ;12;AC;12
  497   "RTN","PRC ABJV",55,0 )
  498    ;;AMEND;3 03;AM;38
  499   "RTN","PRC ABJV",56,0 )
  500    ;;AMENDED  BILL;110; AB;33
  501   "RTN","PRC ABJV",57,0 )
  502    ;;ARCHIVE D;115;XX;4 9
  503   "RTN","PRC ABJV",58,0 )
  504    ;;BILL IN COMPLETE;2 01;BI;27
  505   "RTN","PRC ABJV",59,0 )
  506    ;;CANCELL ATION;111; CN;39
  507   "RTN","PRC ABJV",60,0 )
  508    ;;CANCELL ED BILL;21 0;CB;26
  509   "RTN","PRC ABJV",61,0 )
  510    ;;CASH CO LLECTION B Y RC/DOJ;7 ;CJ;7
  511   "RTN","PRC ABJV",62,0 )
  512    ;;CHARGE  SUSPENDED; 19;CS;47
  513   "RTN","PRC ABJV",63,0 )
  514    ;;COLLECT ED/CLOSED; 108;CC;22
  515   "RTN","PRC ABJV",64,0 )
  516    ;;COMMENT ;17;CM;45
  517   "RTN","PRC ABJV",65,0 )
  518    ;;DEBIT V OUCHER (SF  5515);30; DV;30
  519   "RTN","PRC ABJV",66,0 )
  520    ;;DECREAS E ADJUSTME NT;21;DA;3 5
  521   "RTN","PRC ABJV",67,0 )
  522    ;;DELETE  (AMEND);30 1;DL;36
  523   "RTN","PRC ABJV",68,0 )
  524    ;;EXEMPT  INT/ADM. C OST;14;E;1 4
  525   "RTN","PRC ABJV",69,0 )
  526    ;;IN-ACTI VE;103;IA; 17
  527   "RTN","PRC ABJV",70,0 )
  528    ;;INCOMPL ETE;101;IN ;15
  529   "RTN","PRC ABJV",71,0 )
  530    ;;INCREAS E ADJUSTME NT;1;AJ;1
  531   "RTN","PRC ABJV",72,0 )
  532    ;;INTERES T/ADM. CHA RGE;13;IC; 13
  533   "RTN","PRC ABJV",73,0 )
  534    ;;MARSHAL /COURT COS T;15;ML;24
  535   "RTN","PRC ABJV",74,0 )
  536    ;;NEW BIL L;104;N;18
  537   "RTN","PRC ABJV",75,0 )
  538    ;;OLD BIL L;106;OB;2 8
  539   "RTN","PRC ABJV",76,0 )
  540    ;;OPEN;11 2;OP;42
  541   "RTN","PRC ABJV",77,0 )
  542    ;;PAYMENT  (IN FULL) ;20;PF;34
  543   "RTN","PRC ABJV",78,0 )
  544    ;;PAYMENT  (IN PART) ;2;PP;2
  545   "RTN","PRC ABJV",79,0 )
  546    ;;PENDING  APPROVAL; 205;PA;20
  547   "RTN","PRC ABJV",80,0 )
  548    ;;PENDING  ARCHIVE;1 14;X;48
  549   "RTN","PRC ABJV",81,0 )
  550    ;;PENDING  CALM CODE ;107;PC;21
  551   "RTN","PRC ABJV",82,0 )
  552    ;;RE-ESTA BLISH;250; RW;43
  553   "RTN","PRC ABJV",83,0 )
  554    ;;REESTAB LISH TO RC /DOJ;5;RR; 5
  555   "RTN","PRC ABJV",84,0 )
  556    ;;REFER T O RC;3;RC; 3
  557   "RTN","PRC ABJV",85,0 )
  558    ;;REFER T O DOJ;4;RJ ;4
  559   "RTN","PRC ABJV",86,0 )
  560    ;;REFUND  REVIEW;113 ;PR;44
  561   "RTN","PRC ABJV",87,0 )
  562    ;;REFUNDE D;120;RF;4 1
  563   "RTN","PRC ABJV",88,0 )
  564    ;;REPAYME NT PLAN;16 ;RP;25
  565   "RTN","PRC ABJV",89,0 )
  566    ;;RETURNE D BY RC/DO J;6;RD;6
  567   "RTN","PRC ABJV",90,0 )
  568    ;;RETURNE D FOR AMEN DMENT;230; RA;32
  569   "RTN","PRC ABJV",91,0 )
  570    ;;RETURNE D FROM AR  (NEW);220; RT;31
  571   "RTN","PRC ABJV",92,0 )
  572    ;;SUSPEND ED;240;SP; 40
  573   "RTN","PRC ABJV",93,0 )
  574    ;;SUSPENS E;105;S;19
  575   "RTN","PRC ABJV",94,0 )
  576    ;;TERM.BY  COMPROMIS E;9;TC;9
  577   "RTN","PRC ABJV",95,0 )
  578    ;;TERM.BY  RC/DOJ;29 ;TJ;29
  579   "RTN","PRC ABJV",96,0 )
  580    ;;TERM.BY  FIS.OFFIC ER;8;TO;8
  581   "RTN","PRC ABJV",97,0 )
  582    ;;UNSUSPE NDED;18;US ;46
  583   "RTN","PRC ABJV",98,0 )
  584    ;;WAIVED  IN FULL;10 ;WF;10
  585   "RTN","PRC ABJV",99,0 )
  586    ;;WAIVED  IN PART;11 ;WP;11
  587   "RTN","PRC ABJV",100, 0)
  588    ;;WRITE-O FF;109;WO; 23
  589   "RTN","PRC ABJV",101, 0)
  590    ;;EOF
  591   "RTN","PRC ABJV",102, 0)
  592   CAT ;patch  192 - ISC -0502-N280 3 change C hampus to  Tricare
  593   "RTN","PRC ABJV",103, 0)
  594    ;;ADULT D AY HEALTH  CARE;40;AD ;33
  595   "RTN","PRC ABJV",104, 0)
  596    ;;C (MEAN S TEST);24 ;C;18
  597   "RTN","PRC ABJV",105, 0)
  598    ;;TRICARE ;37;T1;30
  599   "RTN","PRC ABJV",106, 0)
  600    ;;TRICARE  PATIENT;3 8;T2;31
  601   "RTN","PRC ABJV",107, 0)
  602    ;;TRICARE  THIRD PAR TY;39;T3;3 2
  603   "RTN","PRC ABJV",108, 0)
  604    ;;CHAMPVA ;36;CV;29
  605   "RTN","PRC ABJV",109, 0)
  606    ;;CHAMPVA  SUBSISTEN CE;34;CS;2 7
  607   "RTN","PRC ABJV",110, 0)
  608    ;;CHAMPVA  THIRD PAR TY;35;CT;2 8
  609   "RTN","PRC ABJV",111, 0)
  610    ;;COMP &  PEN PROCEE DS;8;CM;43
  611   "RTN","PRC ABJV",112, 0)
  612    ;;CRIME O F PER.VIO. ;27;CP;8
  613   "RTN","PRC ABJV",113, 0)
  614    ;;CURRENT  EMP.;14;C E;16
  615   "RTN","PRC ABJV",114, 0)
  616    ;;CWT PRO CEEDS;7;CW ;42
  617   "RTN","PRC ABJV",115, 0)
  618    ;;DOMICIL IARY;41;DO ;34
  619   "RTN","PRC ABJV",116, 0)
  620    ;;EMERGEN CY/HUMANIT ARIAN;25;H ;2
  621   "RTN","PRC ABJV",117, 0)
  622    ;;ENHANCE D USE LEAS E PROCEEDS ;10;EP;44
  623   "RTN","PRC ABJV",118, 0)
  624    ;;EX-EMPL OYEE;13;E; 15
  625   "RTN","PRC ABJV",119, 0)
  626    ;;FEDERAL  AGENCIES- REFUND;15; F2;13
  627   "RTN","PRC ABJV",120, 0)
  628    ;;FEDERAL  AGENCIES- REIMB.;16; F1;14
  629   "RTN","PRC ABJV",121, 0)
  630    ;;FEE REI MB INS;47; FR;45
  631   "RTN","PRC ABJV",122, 0)
  632    ;;GERIATR IC EVAL-IN STITUTIONA L;44;GE;37
  633   "RTN","PRC ABJV",123, 0)
  634    ;;GERIATR IC EVAL-NO N-INSTITUT ION;45;GN; 38
  635   "RTN","PRC ABJV",124, 0)
  636    ;;HOSPITA L CARE (NS C);1;HC;5
  637   "RTN","PRC ABJV",125, 0)
  638    ;;HOSPITA L CARE PER  DIEM;32;H P;25
  639   "RTN","PRC ABJV",126, 0)
  640    ;;INELIGI BLE HOSP.; 20;I;1
  641   "RTN","PRC ABJV",127, 0)
  642    ;;INTERAG ENCY;19;IA ;20
  643   "RTN","PRC ABJV",128, 0)
  644    ;;MEDICAR E;28;MC;21
  645   "RTN","PRC ABJV",129, 0)
  646    ;;MILITAR Y;17;M;12
  647   "RTN","PRC ABJV",130, 0)
  648    ;;NO-FAUL T AUTO ACC .;26;NA;7
  649   "RTN","PRC ABJV",131, 0)
  650    ;;NURSING  HOME CARE  PER DIEM; 31;NP;24
  651   "RTN","PRC ABJV",132, 0)
  652    ;;NURSING  HOME CARE (NSC);3;NC ;3
  653   "RTN","PRC ABJV",133, 0)
  654    ;;NURSING  HOME CARE -LTC;46;NL ;39
  655   "RTN","PRC ABJV",134, 0)
  656    ;;NURSING  HOME PROC EEDS;5;NH; 40
  657   "RTN","PRC ABJV",135, 0)
  658    ;;OUTPATI ENT CARE(N SC);2;OC;4
  659   "RTN","PRC ABJV",136, 0)
  660    ;;PARKING  FEES;6;PF ;41
  661   "RTN","PRC ABJV",137, 0)
  662    ;;PREPAYM ENT;33;PP; 26
  663   "RTN","PRC ABJV",138, 0)
  664    ;;REIMBUR S.HEALTH I NS.;21;RI; 9
  665   "RTN","PRC ABJV",139, 0)
  666    ;;RESPITE  CARE-INST ITUTIONAL; 42;RC;35
  667   "RTN","PRC ABJV",140, 0)
  668    ;;RESPITE  CARE-NON- INSTITUTIO NAL;43;RN; 36
  669   "RTN","PRC ABJV",141, 0)
  670    ;;RX CO-P AYMENT/NSC  VET;30;PN ;23
  671   "RTN","PRC ABJV",142, 0)
  672    ;;RX CO-P AYMENT/SC  VET;29;PS; 22
  673   "RTN","PRC ABJV",143, 0)
  674    ;;SHARING  AGREEMENT S;18;SA;19
  675   "RTN","PRC ABJV",144, 0)
  676    ;;TORT FE ASOR;22;TF ;10
  677   "RTN","PRC ABJV",145, 0)
  678    ;;VENDOR; 11;V;17
  679   "RTN","PRC ABJV",146, 0)
  680    ;;WORKMAN 'S COMP.;2 3;WC;6
  681   "RTN","PRC ABJV",147, 0)
  682    ;;EOF
  683   "RTN","PRC ABJV",148, 0)
  684   EVENT ;
  685   "RTN","PRC ABJV",149, 0)
  686    ;;CASH PA YMENT;6;;6
  687   "RTN","PRC ABJV",150, 0)
  688    ;;CHECK/M O PAYMENT; 4;;4
  689   "RTN","PRC ABJV",151, 0)
  690    ;;COMMENT ;1;;1
  691   "RTN","PRC ABJV",152, 0)
  692    ;;CREDIT  CARD PAYME NT;7;;7
  693   "RTN","PRC ABJV",153, 0)
  694    ;;DEPT OF  JUSTICE P AYMENT;5;; 5
  695   "RTN","PRC ABJV",154, 0)
  696    ;;REGIONA L COUNSEL  PAYMENT;3; ;3
  697   "RTN","PRC ABJV",155, 0)
  698    ;;FOLLOW- UP LETTER; 10;;10
  699   "RTN","PRC ABJV",156, 0)
  700    ;;IRS PAY MENT;11;;1 1
  701   "RTN","PRC ABJV",157, 0)
  702    ;;PATIENT  STATEMENT ;2;;2
  703   "RTN","PRC ABJV",158, 0)
  704    ;;TDA PAY MENT;8;;8
  705   "RTN","PRC ABJV",159, 0)
  706    ;;UB PRIN TED;9;;9
  707   "RTN","PRC ABJV",160, 0)
  708    ;;LOCKBOX ;12;;12
  709   "RTN","PRC ABJV",161, 0)
  710    ;;TOP PAY MENT;13;;1 3
  711   "RTN","PRC ABJV",162, 0)
  712    ;;EDI LOC KBOX;14;;1 4
  713   "RTN","PRC ABJV",163, 0)
  714    ;;ADMINIS TRATIVE OF FSET;15;;1 5
  715   "RTN","PRC ABJV",164, 0)
  716    ;;PRIVATE  COLLECTIO N AGENCY;1 6;;16
  717   "RTN","PRC ABJV",165, 0)
  718    ;;EOF
  719   "RTN","PRC AP310")
  720   0^^B126955 59^n/a
  721   "RTN","PRC AP310",1,0 )
  722   PRCAP310 ; DRF/Albany  - PRCA*4. 5*310 POST  INSTALL;0 9/10/15 2: 10pm
  723   "RTN","PRC AP310",2,0 )
  724    ;;4.5;Acc ounts Rece ivable;**3 10**;Mar 2 0, 1995;Bu ild 14
  725   "RTN","PRC AP310",3,0 )
  726    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  727   "RTN","PRC AP310",4,0 )
  728    Q
  729   "RTN","PRC AP310",5,0 )
  730    ;
  731   "RTN","PRC AP310",6,0 )
  732   POSTINIT ; Post Insta ll for PRC A*4.5*310
  733   "RTN","PRC AP310",7,0 )
  734    D BMES^XP DUTL(" >>   Starting  the Post-I nitializat ion routin e ")
  735   "RTN","PRC AP310",8,0 )
  736    ; AR CATE GORIES and  REVENUE S OURCE CODE S
  737   "RTN","PRC AP310",9,0 )
  738    D ARCAT
  739   "RTN","PRC AP310",10, 0)
  740    D REVSC
  741   "RTN","PRC AP310",11, 0)
  742    D FUND
  743   "RTN","PRC AP310",12, 0)
  744    D APPR
  745   "RTN","PRC AP310",13, 0)
  746    D BMES^XP DUTL(" >>   End of th e Post-Ini tializatio n routine  ")
  747   "RTN","PRC AP310",14, 0)
  748    Q
  749   "RTN","PRC AP310",15, 0)
  750    ;
  751   "RTN","PRC AP310",16, 0)
  752    ;
  753   "RTN","PRC AP310",17, 0)
  754   ARCAT ;AR  CATEGORY E NTRIES (43 0.2)
  755   "RTN","PRC AP310",18, 0)
  756    N DA,DIC, DIE,DIK,DI NUM,DLAYGO ,DR,RCDATA ,RCDINUM,X ,Y
  757   "RTN","PRC AP310",19, 0)
  758    D MES^XPD UTL("      -> Adding  new AR CAT EGORY entr ies to fil e 430.2 .. .")
  759   "RTN","PRC AP310",20, 0)
  760    S RCDINUM =45,(DIC,D IE)="^PRCA (430.2,",D IC(0)="L", DLAYGO=430 .2
  761   "RTN","PRC AP310",21, 0)
  762    ;  if the  entry is  in the fil e, delete  it first t o add fiel ds unedita ble
  763   "RTN","PRC AP310",22, 0)
  764    I $D(^PRC A(430.2,RC DINUM,0))  S DIK="^PR CA(430.2," ,DA=RCDINU M D ^DIK
  765   "RTN","PRC AP310",23, 0)
  766    S DINUM=R CDINUM
  767   "RTN","PRC AP310",24, 0)
  768    S X="FEE  REIMB INS"
  769   "RTN","PRC AP310",25, 0)
  770    ;  set th e field va lues
  771   "RTN","PRC AP310",26, 0)
  772    S DA=RCDI NUM,DIC("D R")=""
  773   "RTN","PRC AP310",27, 0)
  774    S DIC("DR ")=DIC("DR ")_"1///FR ;"
  775   "RTN","PRC AP310",28, 0)
  776    S DIC("DR ")=DIC("DR ")_"2///24 9;"
  777   "RTN","PRC AP310",29, 0)
  778    S DIC("DR ")=DIC("DR ")_"3///12 12;"
  779   "RTN","PRC AP310",30, 0)
  780    S DIC("DR ")=DIC("DR ")_"4///;"
  781   "RTN","PRC AP310",31, 0)
  782    S DIC("DR ")=DIC("DR ")_"5///T; "
  783   "RTN","PRC AP310",32, 0)
  784    S DIC("DR ")=DIC("DR ")_"6///47 ;"
  785   "RTN","PRC AP310",33, 0)
  786    S DIC("DR ")=DIC("DR ")_"7///2; "
  787   "RTN","PRC AP310",34, 0)
  788    S DIC("DR ")=DIC("DR ")_"12///1 ;"
  789   "RTN","PRC AP310",35, 0)
  790    S DIC("DR ")=DIC("DR ")_"9///0; "
  791   "RTN","PRC AP310",36, 0)
  792    S DIC("DR ")=DIC("DR ")_"10///0 ;"
  793   "RTN","PRC AP310",37, 0)
  794    S DIC("DR ")=DIC("DR ")_"11///0 ;"
  795   "RTN","PRC AP310",38, 0)
  796    S DIC("DR ")=DIC("DR ")_"13///2 ;"
  797   "RTN","PRC AP310",39, 0)
  798    D FILE^DI CN
  799   "RTN","PRC AP310",40, 0)
  800    D MES^XPD UTL("         AR CATE GORY compl eted.")
  801   "RTN","PRC AP310",41, 0)
  802    Q
  803   "RTN","PRC AP310",42, 0)
  804    ;
  805   "RTN","PRC AP310",43, 0)
  806    ;
  807   "RTN","PRC AP310",44, 0)
  808   REVSC ;REV ENUE SOURC E CODE ent ries in fi le #347.3
  809   "RTN","PRC AP310",45, 0)
  810    N I,RSCDA TA,DIC,Y,G BL,DA,X,DI E,DR
  811   "RTN","PRC AP310",46, 0)
  812    D MES^XPD UTL("      -> Adding  new REVENU E SOURCE C ODE entrie s to file  347.3 ..." )
  813   "RTN","PRC AP310",47, 0)
  814    S GBL="^R C(347.3,"
  815   "RTN","PRC AP310",48, 0)
  816    F I=1:1 D   Q:RSCDAT A="END"
  817   "RTN","PRC AP310",49, 0)
  818    . S RSCDA TA=$P($T(N EWRSC+I)," ;",3,99)
  819   "RTN","PRC AP310",50, 0)
  820    . Q:RSCDA TA="END"
  821   "RTN","PRC AP310",51, 0)
  822    . ; do a  lookup and  continue  if exists.
  823   "RTN","PRC AP310",52, 0)
  824    . S DIC=G BL,X=$P(RS CDATA,";")  D ^DIC
  825   "RTN","PRC AP310",53, 0)
  826    . I +Y>0  S DIK=GBL, DA=+Y D ^D IK
  827   "RTN","PRC AP310",54, 0)
  828    . ; add e ntry
  829   "RTN","PRC AP310",55, 0)
  830    . S X=$P( RSCDATA,"; ")
  831   "RTN","PRC AP310",56, 0)
  832    . S DIC(" DR")=".02/ //"_$P(RSC DATA,";",2 )_";"
  833   "RTN","PRC AP310",57, 0)
  834    . S DIC(" DR")=DIC(" DR")_".03/ //0;"
  835   "RTN","PRC AP310",58, 0)
  836    . D FILE^ DICN
  837   "RTN","PRC AP310",59, 0)
  838    . I +Y=-1  D
  839   "RTN","PRC AP310",60, 0)
  840    . . D MES ^XPDUTL("         "_$ P(RSCDATA, ";")_" fai led to add !")
  841   "RTN","PRC AP310",61, 0)
  842    D MES^XPD UTL("         REVENUE  SOURCE CO DES comple ted.")
  843   "RTN","PRC AP310",62, 0)
  844    Q
  845   "RTN","PRC AP310",63, 0)
  846    ;
  847   "RTN","PRC AP310",64, 0)
  848    ;
  849   "RTN","PRC AP310",65, 0)
  850   FUND ;PRCD  FUND entr y in 420.1 4
  851   "RTN","PRC AP310",66, 0)
  852    N DA,DIC, DIK,DLAYGO ,FUND,X,Y
  853   "RTN","PRC AP310",67, 0)
  854    D MES^XPD UTL("      -> Adding  new PRCD F UND entry  to file 42 0.14 ...")
  855   "RTN","PRC AP310",68, 0)
  856    S DIC="^P RCD(420.14 ,",DIC(0)= "L",DLAYGO =420.14,FU ND=528713
  857   "RTN","PRC AP310",69, 0)
  858    ; if the  entry is i n the file , delete i t first to  add field s uneditab le
  859   "RTN","PRC AP310",70, 0)
  860    S X=FUND  D ^DIC I + Y>0 S DA=+ Y,DIK="^PR CD(420.14, " D ^DIK
  861   "RTN","PRC AP310",71, 0)
  862    ; add ent ry
  863   "RTN","PRC AP310",72, 0)
  864    S X=FUND
  865   "RTN","PRC AP310",73, 0)
  866    S DIC("DR ")="1////M CCF-FEE-CO LL FUND-3R D PARTY;"
  867   "RTN","PRC AP310",74, 0)
  868    S DIC("DR ")=DIC("DR ")_"2///20 16;"
  869   "RTN","PRC AP310",75, 0)
  870    S DIC("DR ")=DIC("DR ")_"3///20 16;"
  871   "RTN","PRC AP310",76, 0)
  872    S DIC("DR ")=DIC("DR ")_"4.7/// NET;"
  873   "RTN","PRC AP310",77, 0)
  874    S DIC("DR ")=DIC("DR ")_"5///A; "
  875   "RTN","PRC AP310",78, 0)
  876    S DIC("DR ")=DIC("DR ")_"4.5/// N;"
  877   "RTN","PRC AP310",79, 0)
  878    D FILE^DI CN
  879   "RTN","PRC AP310",80, 0)
  880    D MES^XPD UTL("         PRCD FU ND complet ed.")
  881   "RTN","PRC AP310",81, 0)
  882    Q
  883   "RTN","PRC AP310",82, 0)
  884    ;
  885   "RTN","PRC AP310",83, 0)
  886    ;
  887   "RTN","PRC AP310",84, 0)
  888   APPR ;PRCD  FUND/APPR OPRIATION  CODE entry  in 420.3
  889   "RTN","PRC AP310",85, 0)
  890    N DA,DIC, DIE,DIK,DI NUM,DLAYGO ,DR,RCDATA ,RCDINUM,X ,Y
  891   "RTN","PRC AP310",86, 0)
  892    D MES^XPD UTL("      -> Adding  new PRCD F UND/APPROP RIATION CO DE entry t o file 420 .3 ...")
  893   "RTN","PRC AP310",87, 0)
  894    ;  instal l entries  in file 42 0.3
  895   "RTN","PRC AP310",88, 0)
  896    S FUND=52 8713,DIC=" ^PRCD(420. 3,",DIC(0) ="L",DLAYG O=420.3
  897   "RTN","PRC AP310",89, 0)
  898    ;  if the  entry is  in the fil e, delete  it first t o add fiel ds unedita ble
  899   "RTN","PRC AP310",90, 0)
  900    S X=FUND  D ^DIC I + Y>0 S DA=+ Y,DIK="^PR CD(420.3,"  D ^DIK
  901   "RTN","PRC AP310",91, 0)
  902    ;  add en try
  903   "RTN","PRC AP310",92, 0)
  904    S X=FUND
  905   "RTN","PRC AP310",93, 0)
  906    S DIC("DR ")="2////3 6_5287.13; "
  907   "RTN","PRC AP310",94, 0)
  908    S DIC("DR ")=DIC("DR ")_"4///36 _5287.13;"
  909   "RTN","PRC AP310",95, 0)
  910    S DIC("DR ")=DIC("DR ")_"6///52 8713;"
  911   "RTN","PRC AP310",96, 0)
  912    S DIC("DR ")=DIC("DR ")_"7///Y; "
  913   "RTN","PRC AP310",97, 0)
  914    D FILE^DI CN
  915   "RTN","PRC AP310",98, 0)
  916    D MES^XPD UTL("         PRCD FU ND/APPROPR IATION COD E complete d.")
  917   "RTN","PRC AP310",99, 0)
  918    Q
  919   "RTN","PRC AP310",100 ,0)
  920    ;
  921   "RTN","PRC AP310",101 ,0)
  922    ;
  923   "RTN","PRC AP310",102 ,0)
  924    ;Revenue  Source Cod es (RSC#)
  925   "RTN","PRC AP310",103 ,0)
  926   NEWRSC ;SO URCE CODE; NAME
  927   "RTN","PRC AP310",104 ,0)
  928    ;;8F1Z;FE E BASIS IN PATIENT
  929   "RTN","PRC AP310",105 ,0)
  930    ;;8F2Z;FE E BASIS OU TPATIENT
  931   "RTN","PRC AP310",106 ,0)
  932    ;;END
  933   "RTN","RCR JRBD")
  934   0^3^B74247 917^B70206 811
  935   "RTN","RCR JRBD",1,0)
  936   RCRJRBD ;W ISC/RFJ,TJ K-bad debt  extractor  and repor t ;10/18/1 0 9:00am
  937   "RTN","RCR JRBD",2,0)
  938    ;;4.5;Acc ounts Rece ivable;**1 01,139,170 ,193,203,2 15,220,138 ,239,273,2 82,310**;M ar 20, 199 5;Build 14
  939   "RTN","RCR JRBD",3,0)
  940    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  941   "RTN","RCR JRBD",4,0)
  942    ; IA 4385  for calls  to $$MRAT YPE^IBCEMU 2 and $$MR ADTACT^IBC EMU2
  943   "RTN","RCR JRBD",5,0)
  944    Q
  945   "RTN","RCR JRBD",6,0)
  946    ;
  947   "RTN","RCR JRBD",7,0)
  948    ;
  949   "RTN","RCR JRBD",8,0)
  950   START(DATE END) ;  ru n bad debt  report
  951   "RTN","RCR JRBD",9,0)
  952    ;  the DA TEEND is t he last da y of the m onth being  run
  953   "RTN","RCR JRBD",10,0 )
  954    ;  from t he routine  RCRJRCOL  which is t he data ex tractor.   The
  955   "RTN","RCR JRBD",11,0 )
  956    ;  curren t receivab le dollars  is stored  in ^TMP($ J,"RCRJRBD ",SGL)
  957   "RTN","RCR JRBD",12,0 )
  958    ;  where  SGL is the  standard  general le dger 1319,  1338, or  1339.
  959   "RTN","RCR JRBD",13,0 )
  960    ;
  961   "RTN","RCR JRBD",14,0 )
  962    N ACTDATE ,ACTUALCA, ACTUALWO,B EGDATE,BIL LDA,CATEGO RY
  963   "RTN","RCR JRBD",15,0 )
  964    N COLLECT ,CONTRACT, DR,ENDDATE ,FUND,PAY, PAYMENT,PR IN,PRINCPA L
  965   "RTN","RCR JRBD",16,0 )
  966    N RCRJFMM ,RCRJDATE, SGL,TRANDA ,TRANDATE, TRANTYPE,V ALUE,WRITE OFF
  967   "RTN","RCR JRBD",17,0 )
  968    N RCPRIN, RCTOMCCF,R CVALUE,RSC ,MRATYPE,A RACTDT
  969   "RTN","RCR JRBD",18,0 )
  970    ;
  971   "RTN","RCR JRBD",19,0 )
  972    ;  lock t he bad deb t file for  storing d ata, lock  cannot fai l
  973   "RTN","RCR JRBD",20,0 )
  974    ;  this l ock can be  used to m onitor if  the report  is runnin g
  975   "RTN","RCR JRBD",21,0 )
  976    F  L +^RC (348.1):$S ($G(DILOCK TM)>5:DILO CKTM,1:5)  Q:$T
  977   "RTN","RCR JRBD",22,0 )
  978    ;
  979   "RTN","RCR JRBD",23,0 )
  980    ;  calcul ate the ba se percent ages from  past data
  981   "RTN","RCR JRBD",24,0 )
  982    ;  exampl e:  DATEEN D=2980331   => BEGDAT E=2970300
  983   "RTN","RCR JRBD",25,0 )
  984    ;                                => ENDDAT E=2980229
  985   "RTN","RCR JRBD",26,0 )
  986    ;   add o ne day to  ending dat e to go to  next mont h
  987   "RTN","RCR JRBD",27,0 )
  988    S BEGDATE =($E(DATEE ND,1,3)-1) _$E(DATEEN D,4,5)_"00 "
  989   "RTN","RCR JRBD",28,0 )
  990    S ENDDATE =($$FMADD^ XLFDT($E(D ATEEND,1,5 )_"00",-1) )+1
  991   "RTN","RCR JRBD",29,0 )
  992    ;  loop b ills activ ated betwe en these d ates
  993   "RTN","RCR JRBD",30,0 )
  994    S ACTDATE =BEGDATE
  995   "RTN","RCR JRBD",31,0 )
  996    F  S ACTD ATE=$O(^PR CA(430,"AC TDT",ACTDA TE)) Q:'AC TDATE!(ACT DATE>ENDDA TE)  D
  997   "RTN","RCR JRBD",32,0 )
  998    . S BILLD A=0 F  S B ILLDA=$O(^ PRCA(430," ACTDT",ACT DATE,BILLD A)) Q:'BIL LDA  D
  999   "RTN","RCR JRBD",33,0 )
  1000    . . S CAT EGORY=+$P( $G(^PRCA(4 30,BILLDA, 0)),"^",2)
  1001   "RTN","RCR JRBD",34,0 )
  1002    . . ;  do  not look  at prepaym ents
  1003   "RTN","RCR JRBD",35,0 )
  1004    . . I 'CA TEGORY!(CA TEGORY=26)  Q
  1005   "RTN","RCR JRBD",36,0 )
  1006    . . ;
  1007   "RTN","RCR JRBD",37,0 )
  1008    . . ;    only look  at bills w ith a 0 pr inc
        1009   al balance
  1010   "RTN","RCR JRBD",38,0 )
  1011    . . I $P( $G(^PRCA(4 30,BILLDA, 7)),"^") Q
  1012   "RTN","RCR JRBD",39,0 )
  1013    . . ;
  1014   "RTN","RCR JRBD",40,0 )
  1015    . . ;  on ly report  fund 52870 1,03,04,11  and 4032/ 528709 bil ls
  1016   "RTN","RCR JRBD",41,0 )
  1017    . . S FUN D=$$GETFUN DB^RCXFMSU F(BILLDA,1 )
  1018   "RTN","RCR JRBD",42,0 )
  1019    . . I '$$ PTACCT^PRC AACC(FUND) ,$E(FUND,1 ,4)'=4032  Q
  1020   "RTN","RCR JRBD",43,0 )
  1021    . . ;
  1022   "RTN","RCR JRBD",44,0 )
  1023    . . ;  de termine MR A type of  bill, give n bill# an d bill act ive date
  1024   "RTN","RCR JRBD",45,0 )
  1025    . . ;  DB IA #4385 a ctivated o n 31-Mar-2 004
  1026   "RTN","RCR JRBD",46,0 )
  1027    . . S MRA TYPE=$$MRA TYPE^IBCEM U2(BILLDA, ACTDATE)
  1028   "RTN","RCR JRBD",47,0 )
  1029    . . ;
  1030   "RTN","RCR JRBD",48,0 )
  1031    . . ;  de rive stand ard genera l ledger ( SGL) from  cat/fund/M RA type
  1032   "RTN","RCR JRBD",49,0 )
  1033    . . S SGL =$$BDRSGL( CATEGORY,F UND,MRATYP E)
  1034   "RTN","RCR JRBD",50,0 )
  1035    . . ;
  1036   "RTN","RCR JRBD",51,0 )
  1037    . . ;  de termine th e original  amount of  the bill  (add incre ase
  1038   "RTN","RCR JRBD",52,0 )
  1039    . . ;  ad justments  below)
  1040   "RTN","RCR JRBD",53,0 )
  1041    . . S PRI N=$P($G(^P RCA(430,BI LLDA,0))," ^",3)
  1042   "RTN","RCR JRBD",54,0 )
  1043    . . S PAY =0
  1044   "RTN","RCR JRBD",55,0 )
  1045    . . ;
  1046   "RTN","RCR JRBD",56,0 )
  1047    . . ;  ge t the $ tr ansations  for bills
  1048   "RTN","RCR JRBD",57,0 )
  1049    . . S TRA NDA=0
  1050   "RTN","RCR JRBD",58,0 )
  1051    . . F  S  TRANDA=$O( ^PRCA(433, "C",BILLDA ,TRANDA))  Q:'TRANDA   D
  1052   "RTN","RCR JRBD",59,0 )
  1053    . . . S T RANTYPE=$P ($G(^PRCA( 433,TRANDA ,1)),"^",2 )
  1054   "RTN","RCR JRBD",60,0 )
  1055    . . . I " ^1^2^34^43 ^"'[("^"_T RANTYPE_"^ ") Q
  1056   "RTN","RCR JRBD",61,0 )
  1057    . . . S V ALUE=$$TRA NBAL^RCRJR COT(TRANDA ) I VALUE= "" Q
  1058   "RTN","RCR JRBD",62,0 )
  1059    . . . ;   increase a djustments  or re-est ablish
  1060   "RTN","RCR JRBD",63,0 )
  1061    . . . I T RANTYPE=1! (TRANTYPE= 43) S PRIN =PRIN+$P(V ALUE,"^")  Q
  1062   "RTN","RCR JRBD",64,0 )
  1063    . . . ;   payments
  1064   "RTN","RCR JRBD",65,0 )
  1065    . . . I T RANTYPE=2! (TRANTYPE= 34) S PAY= PAY+$P(VAL UE,"^") Q
  1066   "RTN","RCR JRBD",66,0 )
  1067    . . ;
  1068   "RTN","RCR JRBD",67,0 )
  1069    . . ;  pa yment cann ot be grea ter than p rinciple
  1070   "RTN","RCR JRBD",68,0 )
  1071    . . I PAY >PRIN S PA Y=PRIN
  1072   "RTN","RCR JRBD",69,0 )
  1073    . . ;
  1074   "RTN","RCR JRBD",70,0 )
  1075    . . ;  st ore the da ta
  1076   "RTN","RCR JRBD",71,0 )
  1077    . . S PRI NCPAL(SGL) =$G(PRINCP AL(SGL))+P RIN
  1078   "RTN","RCR JRBD",72,0 )
  1079    . . S PAY MENT(SGL)= $G(PAYMENT (SGL))+PAY
  1080   "RTN","RCR JRBD",73,0 )
  1081    . . ;
  1082   "RTN","RCR JRBD",74,0 )
  1083    ;
  1084   "RTN","RCR JRBD",75,0 )
  1085    ;  calcul ate the wr iteoffs fr om 2/0/98
  1086   "RTN","RCR JRBD",76,0 )
  1087    ;  2/0/98  is when f ms cleared  out actua l writeoff s and cont ract adj
  1088   "RTN","RCR JRBD",77,0 )
  1089    K ^XTMP(" PRCABDET")
  1090   "RTN","RCR JRBD",78,0 )
  1091    S ^XTMP(" PRCABDET", 0)=$$FMADD ^XLFDT(DT, 10)_"^"_DT _"^BAD DEB T REPORT A UDIT"
  1092   "RTN","RCR JRBD",79,0 )
  1093    F TRANTYP E=8,9,10,1 1,35 D
  1094   "RTN","RCR JRBD",80,0 )
  1095    . S TRAND ATE=298020 0
  1096   "RTN","RCR JRBD",81,0 )
  1097    . ;  do n ot pick up  transacti ons after  the end da te
  1098   "RTN","RCR JRBD",82,0 )
  1099    . F  S TR ANDATE=$O( ^PRCA(433, "AT",TRANT YPE,TRANDA TE)) Q:'TR ANDATE!($P (TRANDATE, ".")>DATEE ND)  D
  1100   "RTN","RCR JRBD",83,0 )
  1101    . . S TRA NDA=0 F  S  TRANDA=$O (^PRCA(433 ,"AT",TRAN TYPE,TRAND ATE,TRANDA )) Q:'TRAN DA  D
  1102   "RTN","RCR JRBD",84,0 )
  1103    . . . ;   do not loo k at decre ase adj wh ich are no t contract  adj
  1104   "RTN","RCR JRBD",85,0 )
  1105    . . . I T RANTYPE=35 ,'$P($G(^P RCA(433,TR ANDA,8))," ^",8) Q
  1106   "RTN","RCR JRBD",86,0 )
  1107    . . . ;
  1108   "RTN","RCR JRBD",87,0 )
  1109    . . . S B ILLDA=$P($ G(^PRCA(43 3,TRANDA,0 )),"^",2)
  1110   "RTN","RCR JRBD",88,0 )
  1111    . . . I ' BILLDA Q
  1112   "RTN","RCR JRBD",89,0 )
  1113    . . . S C ATEGORY=+$ P($G(^PRCA (430,BILLD A,0)),"^", 2)
  1114   "RTN","RCR JRBD",90,0 )
  1115    . . . ;   do not loo k at prepa yments
  1116   "RTN","RCR JRBD",91,0 )
  1117    . . . I ' CATEGORY!( CATEGORY=2 6) Q
  1118   "RTN","RCR JRBD",92,0 )
  1119    . . . ;
  1120   "RTN","RCR JRBD",93,0 )
  1121    . . . ;   only repor t fund 528 701,03,04, 11 and 403 2/528709 ( ltc) bills
  1122   "RTN","RCR JRBD",94,0 )
  1123    . . . S F UND=$$GETF UNDB^RCXFM SUF(BILLDA ,1)
  1124   "RTN","RCR JRBD",95,0 )
  1125    . . . I ' $$PTACCT^P RCAACC(FUN D),$E(FUND ,1,4)'=403 2 Q
  1126   "RTN","RCR JRBD",96,0 )
  1127    . . . ;
  1128   "RTN","RCR JRBD",97,0 )
  1129    . . . ;   get bill a ctive date
  1130   "RTN","RCR JRBD",98,0 )
  1131    . . . S A RACTDT=+$P ($P($G(^PR CA(430,BIL LDA,6)),"^ ",21),".")
  1132   "RTN","RCR JRBD",99,0 )
  1133    . . . ;   determine  MRA type o f bill, gi ven bill#  and bill a ctive date
  1134   "RTN","RCR JRBD",100, 0)
  1135    . . . ;   DBIA #4385  activated  on 31-Mar -2004
  1136   "RTN","RCR JRBD",101, 0)
  1137    . . . S M RATYPE=$$M RATYPE^IBC EMU2(BILLD A,ARACTDT)
  1138   "RTN","RCR JRBD",102, 0)
  1139    . . . ;
  1140   "RTN","RCR JRBD",103, 0)
  1141    . . . ; d erive stan dard gener al ledger  (SGL) from  cat/fund/ MRA type
  1142   "RTN","RCR JRBD",104, 0)
  1143    . . . S S GL=$$BDRSG L(CATEGORY ,FUND,MRAT YPE)
  1144   "RTN","RCR JRBD",105, 0)
  1145    . . . ;
  1146   "RTN","RCR JRBD",106, 0)
  1147    . . . ;   get the pr incipal tr ansaction  value
  1148   "RTN","RCR JRBD",107, 0)
  1149    . . . S R CVALUE=+$P ($$TRANBAL ^RCRJRCOT( TRANDA),"^ ")
  1150   "RTN","RCR JRBD",108, 0)
  1151    . . . ;   temp varia ble for va lue (used  below)
  1152   "RTN","RCR JRBD",109, 0)
  1153    . . . S R CPRIN=RCVA LUE
  1154   "RTN","RCR JRBD",110, 0)
  1155    . . . ;
  1156   "RTN","RCR JRBD",111, 0)
  1157    . . . ;   add actual  writeoff  amount for  fiscal ye ar
  1158   "RTN","RCR JRBD",112, 0)
  1159    . . . I T RANTYPE'=3 5 S ACTUAL WO(SGL)=$G (ACTUALWO( SGL))+RCVA LUE
  1160   "RTN","RCR JRBD",113, 0)
  1161    . . . ;   add actual  contract  adjustment s for fisc al year
  1162   "RTN","RCR JRBD",114, 0)
  1163    . . . I T RANTYPE=35  S ACTUALC A(SGL)=$G( ACTUALCA(S GL))+RCVAL UE
  1164   "RTN","RCR JRBD",115, 0)
  1165    . . . S R SC=$$CALCR SC^RCXFMSU R(BILLDA)
  1166   "RTN","RCR JRBD",116, 0)
  1167    . . . S ^ XTMP("PRCA BDET",BILL DA,CATEGOR Y,FUND,RSC ,SGL,TRAND A,TRANDATE ,TRANTYPE, RCPRIN,RCV ALUE,0,0)= ""
  1168   "RTN","RCR JRBD",117, 0)
  1169    ;
  1170   "RTN","RCR JRBD",118, 0)
  1171    ;  remove  all the e ntries fro m the bad  debt file
  1172   "RTN","RCR JRBD",119, 0)
  1173    D DELETAL L
  1174   "RTN","RCR JRBD",120, 0)
  1175    ;
  1176   "RTN","RCR JRBD",121, 0)
  1177    ;  calcul ate percen tages and  store them
  1178   "RTN","RCR JRBD",122, 0)
  1179    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
  1180   "RTN","RCR JRBD",123, 0)
  1181    . ;  coll ection %
  1182   "RTN","RCR JRBD",124, 0)
  1183    . S COLLE CT=0 I $G( PRINCPAL(S GL)) S COL LECT=$J($G (PAYMENT(S GL))/PRINC PAL(SGL)*1 00,0,2)
  1184   "RTN","RCR JRBD",125, 0)
  1185    . ;  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
  1186   "RTN","RCR JRBD",126, 0)
  1187    . ;  hist ory for po st-MRA non -Medicare  bills(SGL  133N). So,  to calcul ate the pe rcentage f or SGL 133 N, the
  1188   "RTN","RCR JRBD",127, 0)
  1189    . ;  paym ent and th e principa l for SGL  1339 are u sed in the  first yea r.
  1190   "RTN","RCR JRBD",128, 0)
  1191    . ;  over ride the c ollection  value for  SGL=133N f or the fir st year fr om MRA act ivation.
  1192   "RTN","RCR JRBD",129, 0)
  1193    . ;;  Re- evaluate t he calc. o f the perc entage for  133N as w ell as 133 9.
  1194   "RTN","RCR JRBD",130, 0)
  1195    . ;;I SGL ="133N",$G (PRINCIPAL (1339)) D   ;
  1196   "RTN","RCR JRBD",131, 0)
  1197    . ;;. N X 1,X2,X,%Y
  1198   "RTN","RCR JRBD",132, 0)
  1199    . ;;. ;   X2=MRA Act ivation Da te, X1=Tod ay, X=diff  in days,  %Y=0 inval id dates
  1200   "RTN","RCR JRBD",133, 0)
  1201    . ;;. ;   DBIA #4385  activated  on 31-Mar -2004
  1202   "RTN","RCR JRBD",134, 0)
  1203    . ;;. S X 2=$$MRADTA CT^IBCEMU2 ,X1=$$DT^X LFDT D ^%D TC
  1204   "RTN","RCR JRBD",135, 0)
  1205    . ;;. I % Y,X'>364.2 5 S COLLEC T=$J($G(PA YMENT(1339 ))/PRINCPA L(1339)*10 0,0,2)
  1206   "RTN","RCR JRBD",136, 0)
  1207    . S DR=". 02////"_+C OLLECT_";"
  1208   "RTN","RCR JRBD",137, 0)
  1209    . ;
  1210   "RTN","RCR JRBD",138, 0)
  1211    . ;  curr ent month  receivable  (this is  built in t he routine
  1212   "RTN","RCR JRBD",139, 0)
  1213    . ;  RCRJ RCO1 and i s stored i n ^TMP($J, "RCRJRBD", SGL))
  1214   "RTN","RCR JRBD",140, 0)
  1215    . S DR=DR _".07////" _+$G(^TMP( $J,"RCRJRB D",SGL))_" ;"
  1216   "RTN","RCR JRBD",141, 0)
  1217    . ;
  1218   "RTN","RCR JRBD",142, 0)
  1219    . ;  calc ulate allo wance esti mate for 1 319 and 13 38
  1220   "RTN","RCR JRBD",143, 0)
  1221    . ;  .08  allowance  estimate =  (writeoff  % * curre nt receiva bles)
  1222   "RTN","RCR JRBD",144, 0)
  1223    . ;  .09  actual wri teoffs fyt d
  1224   "RTN","RCR JRBD",145, 0)
  1225    . 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
  1226   "RTN","RCR JRBD",146, 0)
  1227    . . S WRI TEOFF=100- COLLECT
  1228   "RTN","RCR JRBD",147, 0)
  1229    . . S DR= DR_".03/// /"_WRITEOF F_";"
  1230   "RTN","RCR JRBD",148, 0)
  1231    . . S DR= DR_".08/// /"_$J((WRI TEOFF/100) *$G(^TMP($ J,"RCRJRBD ",SGL)),0, 2)_";"
  1232   "RTN","RCR JRBD",149, 0)
  1233    . . S DR= DR_".09/// /"_+$G(ACT UALWO(SGL) )_";"
  1234   "RTN","RCR JRBD",150, 0)
  1235    . ;  calc ulate allo wance esti mate for 1 339
  1236   "RTN","RCR JRBD",151, 0)
  1237    . ;  .08  allowance  estimate =  (contract  % * curre nt receiva bles)
  1238   "RTN","RCR JRBD",152, 0)
  1239    . ;  .09  actual con tract adju stments fy td
  1240   "RTN","RCR JRBD",153, 0)
  1241    . I SGL=1 339!(SGL=1 339.1)!(SG L="133N")! (SGL="133N .2")!(SGL= "133N.3")  D
  1242   "RTN","RCR JRBD",154, 0)
  1243    . . S CON TRACT=100- COLLECT
  1244   "RTN","RCR JRBD",155, 0)
  1245    . . S DR= DR_".04/// /"_CONTRAC T_";"
  1246   "RTN","RCR JRBD",156, 0)
  1247    . . S DR= DR_".08/// /"_$J((CON TRACT/100) *$G(^TMP($ J,"RCRJRBD ",SGL)),0, 2)_";"
  1248   "RTN","RCR JRBD",157, 0)
  1249    . . S DR= DR_".09/// /"_+$G(ACT UALCA(SGL) )_";"
  1250   "RTN","RCR JRBD",158, 0)
  1251    . ;
  1252   "RTN","RCR JRBD",159, 0)
  1253    . ;  set  changed lo cally flag  to no
  1254   "RTN","RCR JRBD",160, 0)
  1255    . S DR=DR _".1////0; "
  1256   "RTN","RCR JRBD",161, 0)
  1257    . D STORE (SGL,DR)
  1258   "RTN","RCR JRBD",162, 0)
  1259    ;
  1260   "RTN","RCR JRBD",163, 0)
  1261    L -^RC(34 8.1)
  1262   "RTN","RCR JRBD",164, 0)
  1263    ;
  1264   "RTN","RCR JRBD",165, 0)
  1265    ;   ;  pu t the repo rt in a ma il message  (rcrjfmm= 1)
  1266   "RTN","RCR JRBD",166, 0)
  1267    ;   S RCR JFMM=1
  1268   "RTN","RCR JRBD",167, 0)
  1269    ;   S RCR JDATE=DATE END
  1270   "RTN","RCR JRBD",168, 0)
  1271    ;   D DQ^ RCRJRBDR
  1272   "RTN","RCR JRBD",169, 0)
  1273    ;
  1274   "RTN","RCR JRBD",170, 0)
  1275    ;  transm it the all owances to  FMS, and  then gener ate the re port.
  1276   "RTN","RCR JRBD",171, 0)
  1277    D BADDEBT ^RCXFMSSV( DATEEND)
  1278   "RTN","RCR JRBD",172, 0)
  1279    Q
  1280   "RTN","RCR JRBD",173, 0)
  1281    ;
  1282   "RTN","RCR JRBD",174, 0)
  1283    ;
  1284   "RTN","RCR JRBD",175, 0)
  1285   STORE(SGL, DR) ;  sto re data fo r Standard  Ledger Ac count
  1286   "RTN","RCR JRBD",176, 0)
  1287    N D0,DA,D D,DI,DIC,D IE,DINUM,D O,DQ,X,Y
  1288   "RTN","RCR JRBD",177, 0)
  1289    S DIC="^R C(348.1,", DIC(0)="L" ,X=SGL,DIC ("DR")=DR
  1290   "RTN","RCR JRBD",178, 0)
  1291    D FILE^DI CN
  1292   "RTN","RCR JRBD",179, 0)
  1293    Q
  1294   "RTN","RCR JRBD",180, 0)
  1295    ;
  1296   "RTN","RCR JRBD",181, 0)
  1297    ;
  1298   "RTN","RCR JRBD",182, 0)
  1299   DELETALL ;   delete a ll the ent ries from  the bad de bt file
  1300   "RTN","RCR JRBD",183, 0)
  1301    N %,DA,DI C,DIK,X,Y
  1302   "RTN","RCR JRBD",184, 0)
  1303    S DIK="^R C(348.1,"
  1304   "RTN","RCR JRBD",185, 0)
  1305    S DA=0 F   S DA=$O(^ RC(348.1,D A)) Q:'DA   D ^DIK
  1306   "RTN","RCR JRBD",186, 0)
  1307    Q
  1308   "RTN","RCR JRBD",187, 0)
  1309    ;
  1310   "RTN","RCR JRBD",188, 0)
  1311    ;
  1312   "RTN","RCR JRBD",189, 0)
  1313   WD3() ;  r eturn the  third work  day of th e month
  1314   "RTN","RCR JRBD",190, 0)
  1315    N J,P,V,X
  1316   "RTN","RCR JRBD",191, 0)
  1317    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
  1318   "RTN","RCR JRBD",192, 0)
  1319    S X=+$E(P ,6,7)
  1320   "RTN","RCR JRBD",193, 0)
  1321    Q X
  1322   "RTN","RCR JRBD",194, 0)
  1323    ;
  1324   "RTN","RCR JRBD",195, 0)
  1325    ;
  1326   "RTN","RCR JRBD",196, 0)
  1327   PREVMONT(F ORDATE) ;  return the  previous  month's da te
  1328   "RTN","RCR JRBD",197, 0)
  1329    N PREVDAT E
  1330   "RTN","RCR JRBD",198, 0)
  1331    S PREVDAT E=$E(FORDA TE,1,5)-1
  1332   "RTN","RCR JRBD",199, 0)
  1333    I $E(PREV DATE,4,5)= "00" S PRE VDATE=($E( PREVDATE,1 ,3)-1)_12
  1334   "RTN","RCR JRBD",200, 0)
  1335    Q PREVDAT E_"00"
  1336   "RTN","RCR JRBD",201, 0)
  1337    ;
  1338   "RTN","RCR JRBD",202, 0)
  1339    ; derive  standard g eneral led ger (SGL)  from categ ory and fu nd
  1340   "RTN","RCR JRBD",203, 0)
  1341   SGL(CATEGO RY,FUND) ;
  1342   "RTN","RCR JRBD",204, 0)
  1343    I $G(FUND )=528709 Q  1319.2 ;n ew long te rm care fu nd
  1344   "RTN","RCR JRBD",205, 0)
  1345    I $E($G(F UND),1,4)= 4032 Q 131 9.2 ; brea kout long  term care  as a subse t
  1346   "RTN","RCR JRBD",206, 0)
  1347    I $G(FUND )=528711&( CAT=6)!(CA T=7) Q 131 9.5  ; bre akout phar macy
  1348   "RTN","RCR JRBD",207, 0)
  1349    I $G(FUND )=528711&( CAT=9) Q " 133N.2"  ;  pharmacy  reimburs h ealth ins
  1350   "RTN","RCR JRBD",208, 0)
  1351    I $G(FUND )=528711&( CAT=10) Q  1338.2  ;  pharmacy t ort feasor
  1352   "RTN","RCR JRBD",209, 0)
  1353    I CATEGOR Y=8 Q 1339    ; crime  or per. v io.
  1354   "RTN","RCR JRBD",210, 0)
  1355    I CATEGOR Y=9 Q 1339    ; reimb ursable he alth insur ance
  1356   "RTN","RCR JRBD",211, 0)
  1357    I CATEGOR Y=10 Q 133 8  ; tort  feasor
  1358   "RTN","RCR JRBD",212, 0)
  1359    I CATEGOR Y=21 Q 133 9  ; medic are
  1360   "RTN","RCR JRBD",213, 0)
  1361    I CATEGOR Y=45 Q 133 9.1  ; Fee  Basis
  1362   "RTN","RCR JRBD",214, 0)
  1363    Q 1319
  1364   "RTN","RCR JRBD",215, 0)
  1365    ;
  1366   "RTN","RCR JRBD",216, 0)
  1367    ;
  1368   "RTN","RCR JRBD",217, 0)
  1369   BDRSGL(CAT ,FUND,MRAT YPE) ; Cal culate SGL s for the  BDR proces s
  1370   "RTN","RCR JRBD",218, 0)
  1371    ;PRCA*4.5 *310/DRF A dded fund  528713, No n-VA Reimb ursable In surance
  1372   "RTN","RCR JRBD",219, 0)
  1373    ;
  1374   "RTN","RCR JRBD",220, 0)
  1375    ; This AP I will be  used by bo th the ARD C (routine  RCRJRCOC)
  1376   "RTN","RCR JRBD",221, 0)
  1377    ; and the  BDR estim ate calcul ator to as sociate re ceivables
  1378   "RTN","RCR JRBD",222, 0)
  1379    ; with th e correct  standard g eneral led ger accoun t (SGL).
  1380   "RTN","RCR JRBD",223, 0)
  1381    ; The fol lowing tab le will be  implement ed:
  1382   "RTN","RCR JRBD",224, 0)
  1383    ;
  1384   "RTN","RCR JRBD",225, 0)
  1385    ; Receiva ble Type ( Category)         Fun d      SGL
  1386   "RTN","RCR JRBD",226, 0)
  1387    ;======== ========== ========== ========== ========== ==
  1388   "RTN","RCR JRBD",227, 0)
  1389    ; Medical  Care Co-p ayments                   528703     1319
  1390   "RTN","RCR JRBD",228, 0)
  1391    ;  (plus  Inelig, Em erg./Hum.  rec.)
  1392   "RTN","RCR JRBD",229, 0)
  1393    ; Long Te rm Care Co -payments                 528709     1319.2
  1394   "RTN","RCR JRBD",230, 0)
  1395    ; Medicat ion Co-pay ments                     528701     1319.3
  1396   "RTN","RCR JRBD",231, 0)
  1397    ; Crimes  of Persona l Violence  (8),          528704     1319.4
  1398   "RTN","RCR JRBD",232, 0)
  1399    ;  Medica re (21), N o-Fault Au to
  1400   "RTN","RCR JRBD",233, 0)
  1401    ;  (7), W orkman's C omp (6)
  1402   "RTN","RCR JRBD",234, 0)
  1403    ; Tort Fe asor (10)                            528704     1338
  1404   "RTN","RCR JRBD",235, 0)
  1405    ; RHI (9) , pre-MRA                            528704     1339
  1406   "RTN","RCR JRBD",236, 0)
  1407    ; RHI (9) , post-MRA , MRA rec.                528704     133H
  1408   "RTN","RCR JRBD",237, 0)
  1409    ; RHI (9) , post-MRA , non-MRA  rec.           528704     133N
  1410   "RTN","RCR JRBD",238, 0)
  1411    ; Non-VA  RHI Tort F easor                     528713     1338.3
  1412   "RTN","RCR JRBD",239, 0)
  1413    ; Non-VA  RHI (45),  pre-MRA                   528713     1339.1
  1414   "RTN","RCR JRBD",240, 0)
  1415    ; Non-VA  RHI (45),  post-MRA,  MRA rec.       528713     133H.2
  1416   "RTN","RCR JRBD",241, 0)
  1417    ; Non-VA  RHI (45),  post-MRA,  non-MRA re c.  528713     133N.3
  1418   "RTN","RCR JRBD",242, 0)
  1419    ; Crimes  of Persona l Violence  (8),          528713     1319.6
  1420   "RTN","RCR JRBD",243, 0)
  1421    ;  Medica re (21), N o-Fault Au to
  1422   "RTN","RCR JRBD",244, 0)
  1423    ;  (7), W orkman's C omp (6)
  1424   "RTN","RCR JRBD",245, 0)
  1425    ; Pharmac y No Fault  Auto(7),                 528711     1319.5
  1426   "RTN","RCR JRBD",246, 0)
  1427    ; Pharmac y Workman' s Comp(6)
  1428   "RTN","RCR JRBD",247, 0)
  1429    ; Pharmac y RHI, non  MRA (9)                  528711     133N.2
  1430   "RTN","RCR JRBD",248, 0)
  1431    ; Pharmac y Tort Fea sor (10)                  528711     1338.2
  1432   "RTN","RCR JRBD",249, 0)
  1433    ;
  1434   "RTN","RCR JRBD",250, 0)
  1435    ;  Input:   CAT  --   Pointer t o the rece ivable cat egory in f ile 430.2
  1436   "RTN","RCR JRBD",251, 0)
  1437    ;          FUND  --   Receivabl e fund cal culated by  routine R CXFMSUF
  1438   "RTN","RCR JRBD",252, 0)
  1439    ;      MR ATYPE  --   Indicator  of an MRA  (2) or no n-MRA (3)  receivable
  1440   "RTN","RCR JRBD",253, 0)
  1441    ;
  1442   "RTN","RCR JRBD",254, 0)
  1443    ;
  1444   "RTN","RCR JRBD",255, 0)
  1445    I $G(FUND )=528709 Q  1319.2
  1446   "RTN","RCR JRBD",256, 0)
  1447    I $E($G(F UND),1,4)= 4032 Q 131 9.2
  1448   "RTN","RCR JRBD",257, 0)
  1449    I $G(FUND )=528701 Q  1319.3
  1450   "RTN","RCR JRBD",258, 0)
  1451    I $G(FUND )=528711&( (CAT=6)!(C AT=7)) Q 1 319.5
  1452   "RTN","RCR JRBD",259, 0)
  1453    I $G(FUND )=528711&( CAT=9) Q " 133N.2"
  1454   "RTN","RCR JRBD",260, 0)
  1455    I $G(FUND )=528711&( CAT=10) Q  1338.2
  1456   "RTN","RCR JRBD",261, 0)
  1457    I $G(FUND )=528713&( CAT=10) Q  1338.3
  1458   "RTN","RCR JRBD",262, 0)
  1459    I $G(FUND )=528713&( CAT=8!(CAT =21)!(CAT= 6)!(CAT=7) ) Q 1319.6
  1460   "RTN","RCR JRBD",263, 0)
  1461    I CAT=8!( CAT=21)!(C AT=7)!(CAT =6) Q 1319 .4
  1462   "RTN","RCR JRBD",264, 0)
  1463    I CAT=10  Q 1338
  1464   "RTN","RCR JRBD",265, 0)
  1465    I CAT=9 Q  $S(MRATYP E=2:"133H" ,MRATYPE=3 :"133N",1: 1339)
  1466   "RTN","RCR JRBD",266, 0)
  1467    I CAT=45  Q $S(MRATY PE=2:"133H .2",MRATYP E=3:"133N. 3",1:1339. 1)
  1468   "RTN","RCR JRBD",267, 0)
  1469    Q 1319
  1470   "RTN","RCR JRBDR")
  1471   0^10^B7628 0867^B7582 6184
  1472   "RTN","RCR JRBDR",1,0 )
  1473   RCRJRBDR ; WISC/RFJ,T JK-bad deb t report g enerator ; 1 Feb 98
  1474   "RTN","RCR JRBDR",2,0 )
  1475    ;;4.5;Acc ounts Rece ivable;**1 01,139,170 ,191,203,2 15,220,138 ,239,310** ;Mar 20, 1 995;Build  14
  1476   "RTN","RCR JRBDR",3,0 )
  1477    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  1478   "RTN","RCR JRBDR",4,0 )
  1479    Q
  1480   "RTN","RCR JRBDR",5,0 )
  1481    ;
  1482   "RTN","RCR JRBDR",6,0 )
  1483    ;
  1484   "RTN","RCR JRBDR",7,0 )
  1485   PRINT ;  p rint repor t on print er, called  from menu  option
  1486   "RTN","RCR JRBDR",8,0 )
  1487    N RCRJDAT E
  1488   "RTN","RCR JRBDR",9,0 )
  1489    W !!,"Thi s option w ill print  the Bad De bt Report.   The Bad  Debt allow ance"
  1490   "RTN","RCR JRBDR",10, 0)
  1491    W !,"esti mates are  computed b y the AR D ata Collec tor at the  end of th e"
  1492   "RTN","RCR JRBDR",11, 0)
  1493    W !,"acco unting mon th, and se nt to FMS  at that ti me.  The a llowance"
  1494   "RTN","RCR JRBDR",12, 0)
  1495    W !,"esti mate is no  longer ed itable pri or to tran smission t o FMS.",!
  1496   "RTN","RCR JRBDR",13, 0)
  1497    N %ZIS,PO P,ZTRTN,ZT DESC S %ZI S="QM" D ^ %ZIS Q:POP
  1498   "RTN","RCR JRBDR",14, 0)
  1499    I $D(IO(" Q")) D  Q
  1500   "RTN","RCR JRBDR",15, 0)
  1501    . S ZTRTN ="DQ^RCRJR BDR",ZTDES C="Bad Deb t Report"
  1502   "RTN","RCR JRBDR",16, 0)
  1503    . D ^%ZTL OAD
  1504   "RTN","RCR JRBDR",17, 0)
  1505    ;
  1506   "RTN","RCR JRBDR",18, 0)
  1507    W !,"plea se wait"
  1508   "RTN","RCR JRBDR",19, 0)
  1509    D DQ
  1510   "RTN","RCR JRBDR",20, 0)
  1511    Q
  1512   "RTN","RCR JRBDR",21, 0)
  1513    ;
  1514   "RTN","RCR JRBDR",22, 0)
  1515    ;
  1516   "RTN","RCR JRBDR",23, 0)
  1517   DQ ;  gene rate the r eport
  1518   "RTN","RCR JRBDR",24, 0)
  1519    ;  rcrjfm m = flag t o put in m ail messag e (if $g(r crjfmm)) ( optional)
  1520   "RTN","RCR JRBDR",25, 0)
  1521    ;  rcrjda te = date  month and  year for r eport (opt ional)
  1522   "RTN","RCR JRBDR",26, 0)
  1523    ;  rcrjfx sv = fms d ocument id  number if  sent to f ms (option al)
  1524   "RTN","RCR JRBDR",27, 0)
  1525    ;              (newe d and set  by rcxfmss v, label Q )
  1526   "RTN","RCR JRBDR",28, 0)
  1527    ;
  1528   "RTN","RCR JRBDR",29, 0)
  1529    N %,%I,CH ANGED,DATA ,DATA1319, DATA1338,D ATA1339,DA TALTC,DATE REPT,ENDDA TE,X
  1530   "RTN","RCR JRBDR",30, 0)
  1531    N LINE,RC RJFLAG,SCR EEN,SPACE, Y,DATA133N
  1532   "RTN","RCR JRBDR",31, 0)
  1533    ;
  1534   "RTN","RCR JRBDR",32, 0)
  1535    K ^TMP($J ,"RCRJRCOR MM")
  1536   "RTN","RCR JRBDR",33, 0)
  1537    S SPACE=" ",$P(SPACE ," ",81)=" "
  1538   "RTN","RCR JRBDR",34, 0)
  1539    ;  the da te of the  report is  for previo us month i f the DT i s before t he EOAM da te of the  current mo nth,  it i s for the  current mo nth if the  date is a fter the E OAM cut-of f date.
  1540   "RTN","RCR JRBDR",35, 0)
  1541    I $G(RCRJ DATE) S RC RJDATE=$E( $$LDATE^RC RJR(RCRJDA TE),1,5)_" 00"
  1542   "RTN","RCR JRBDR",36, 0)
  1543    I '$G(RCR JDATE) D
  1544   "RTN","RCR JRBDR",37, 0)
  1545    .I $E(DT, 6,7)'>$E($ $LDATE^RCR JR(DT),6,7 ) S RCRJDA TE=$$PREVM ONT^RCRJRB D(DT)
  1546   "RTN","RCR JRBDR",38, 0)
  1547    .I $E(DT, 6,7)>$E($$ LDATE^RCRJ R(DT),6,7)  S RCRJDAT E=$E($$LDA TE^RCRJR(D T),1,5)_"0 0"
  1548   "RTN","RCR JRBDR",39, 0)
  1549    S Y=$E(RC RJDATE,1,5 )_"00" D D D^%DT S DA TEREPT=Y
  1550   "RTN","RCR JRBDR",40, 0)
  1551    S LINE=0
  1552   "RTN","RCR JRBDR",41, 0)
  1553    ;
  1554   "RTN","RCR JRBDR",42, 0)
  1555    ;  jump t o RCRJRBDT  to genera te the new  Bad Debt  Report,
  1556   "RTN","RCR JRBDR",43, 0)
  1557    ;  in ord er to save  the code  for the ol der report .
  1558   "RTN","RCR JRBDR",44, 0)
  1559    D BDR^RCR JRBDT G MA IL
  1560   "RTN","RCR JRBDR",45, 0)
  1561    ;
  1562   "RTN","RCR JRBDR",46, 0)
  1563    D SETLINE (" ")
  1564   "RTN","RCR JRBDR",47, 0)
  1565    D SETLINE ($E(SPACE, 1,32)_"Bad  Debt Repo rt")
  1566   "RTN","RCR JRBDR",48, 0)
  1567    D SETLINE ($E(SPACE, 1,13)_"All owance for  Bad Debt  and Contra ct Adjustm ent Report ")
  1568   "RTN","RCR JRBDR",49, 0)
  1569    D SETLINE ($E(SPACE, 1,27)_"for  the month  of "_DATE REPT)
  1570   "RTN","RCR JRBDR",50, 0)
  1571    I $D(RCRJ FXSV) D
  1572   "RTN","RCR JRBDR",51, 0)
  1573    . D SETLI NE(" ")
  1574   "RTN","RCR JRBDR",52, 0)
  1575    . I $E(RC RJFXSV,1,2 )="SV" D S ETLINE($E( SPACE,1,13 )_"***** R eport sent  to FMS, d oc id: "_R CRJFXSV_"  *****") Q
  1576   "RTN","RCR JRBDR",53, 0)
  1577    . ;  repo rt errored  out or di d not get  generated  to fms
  1578   "RTN","RCR JRBDR",54, 0)
  1579    . D SETLI NE($E(SPAC E,1,10)_"* **** NOTIC E:  Report  was NOT s ent to FMS , the mess age is *** **")
  1580   "RTN","RCR JRBDR",55, 0)
  1581    . D SETLI NE($E(SPAC E,1,10)_"* **** "_RCR JFXSV_" ** ***")
  1582   "RTN","RCR JRBDR",56, 0)
  1583    ;
  1584   "RTN","RCR JRBDR",57, 0)
  1585    ;  show m ccf
  1586   "RTN","RCR JRBDR",58, 0)
  1587    ; Add 528 713 PRCA*4 .5*310/DRF
  1588   "RTN","RCR JRBDR",59, 0)
  1589    D SETLINE (" ")
  1590   "RTN","RCR JRBDR",60, 0)
  1591    D SETLINE ($E(SPACE, 1,26)_"Med ical Care  Collection  Fund")
  1592   "RTN","RCR JRBDR",61, 0)
  1593    I $E($G(R CRJDATE),2 ,5)'<"0410 " D SETLIN E($E(SPACE ,1,26)_" F unds 52870 1, 528703,  528704 &  528713")
  1594   "RTN","RCR JRBDR",62, 0)
  1595    I $E($G(R CRJDATE),2 ,5)<"0410"  D SETLINE ($E(SPACE, 1,26)_" Fu nds 5287.1 , 5287.3,  & 5287.4")
  1596   "RTN","RCR JRBDR",63, 0)
  1597    D SETLINE ($E(SPACE, 1,26)_"--- ---------- ---------- -----")
  1598   "RTN","RCR JRBDR",64, 0)
  1599    D SETLINE (" ")
  1600   "RTN","RCR JRBDR",65, 0)
  1601    D SETLINE ("Calculat ed            "_$J("              ",14)_$J( " Third Pa rty",14)_$ J(" Third  Party",14) )
  1602   "RTN","RCR JRBDR",66, 0)
  1603    D SETLINE ("Percenta ges           "_$J("  First Part y",14)_$J( "    Cont  Adj",14)_$ J("    Con t Adj",14) _$J("Tort  Feasors",1 4))
  1604   "RTN","RCR JRBDR",67, 0)
  1605    D SETLINE ("For                    "_$J("     SGL 131 9",14)_$J( "    SGL 1 339",14)_$ J("    SGL  133N",14) _$J("    S GL 1338",1 4))
  1606   "RTN","RCR JRBDR",68, 0)
  1607    D SETLINE ("-------- ---------- ---"_$J("- ---------- -",14)_$J( "--------- ---",14)_$ J("------- -----",14) _$J("----- -------",1 4))
  1608   "RTN","RCR JRBDR",69, 0)
  1609    S DATA131 9=$G(^RC(3 48.1,+$O(^ RC(348.1," B",1319,0) ),0))
  1610   "RTN","RCR JRBDR",70, 0)
  1611    S DATA133 8=$G(^RC(3 48.1,+$O(^ RC(348.1," B",1338,0) ),0))
  1612   "RTN","RCR JRBDR",71, 0)
  1613    S DATA133 9=$G(^RC(3 48.1,+$O(^ RC(348.1," B",1339,0) ),0))
  1614   "RTN","RCR JRBDR",72, 0)
  1615    S DATA133 N=$G(^RC(3 48.1,+$O(^ RC(348.1," B","133N", 0)),0))
  1616   "RTN","RCR JRBDR",73, 0)
  1617    D SETLINE ("Collecti on           %"_$J($P (DATA1319, "^",2),14, 2)_$J($P(D ATA1339,"^ ",2),14,2) _$J($P(DAT A133N,"^", 2),14,2)_$ J($P(DATA1 338,"^",2) ,14,2))
  1618   "RTN","RCR JRBDR",74, 0)
  1619    D SETLINE ("Write-Of f            %"_$J($P (DATA1319, "^",3),14, 2)_$J($P(D ATA1339,"^ ",3),14,2) _$J($P(DAT A133N,"^", 3),14,2)_$ J($P(DATA1 338,"^",3) ,14,2))
  1620   "RTN","RCR JRBDR",75, 0)
  1621    D SETLINE ("Contract  Adjustmen t %"_$J($P (DATA1319, "^",4),14, 2)_$J($P(D ATA1339,"^ ",4),14,2) _$J($P(DAT A133N,"^", 4),14,2)_$ J($P(DATA1 338,"^",4) ,14,2))
  1622   "RTN","RCR JRBDR",76, 0)
  1623    D SETLINE ("-------- ---------- ---"_$J("- ---------- -",14)_$J( "--------- ---",14)_$ J("------- -----",14) _$J("----- -------",1 4))
  1624   "RTN","RCR JRBDR",77, 0)
  1625    D SETLINE ("TOTAL                 %"_$J(10 0,14,2)_$J (100,14,2) _$J(100,14 ,2)_$J(100 ,14,2))
  1626   "RTN","RCR JRBDR",78, 0)
  1627    D SETLINE (" ")
  1628   "RTN","RCR JRBDR",79, 0)
  1629    ;
  1630   "RTN","RCR JRBDR",80, 0)
  1631    S DATALTC =$G(^RC(34 8.1,+$O(^R C(348.1,"B ",1319.2,0 )),0))
  1632   "RTN","RCR JRBDR",81, 0)
  1633    I $E($G(R CRJDATE),2 ,5)'<"0410 " D SETLIN E($E(SPACE ,1,26)_"   Extended ( LTC) Care  Fund 52870 9")
  1634   "RTN","RCR JRBDR",82, 0)
  1635    I $E($G(R CRJDATE),2 ,5)<"0410"  D SETLINE ($E(SPACE, 1,26)_"  E xtended (L TC) Care F und 4032")
  1636   "RTN","RCR JRBDR",83, 0)
  1637    D SETLINE ($E(SPACE, 1,26)_"--- ---------- ---------- ---------- ")
  1638   "RTN","RCR JRBDR",84, 0)
  1639    D SETLINE (" ")
  1640   "RTN","RCR JRBDR",85, 0)
  1641    I $E($G(R CRJDATE),2 ,5)'<"0410 " D SETLIN E("Calcula ted            "_$J("    Fund 52 8709",18))
  1642   "RTN","RCR JRBDR",86, 0)
  1643    I $E($G(R CRJDATE),2 ,5)<"0410"  D SETLINE ("Calculat ed            "_$J("    Fund 403 2",18))
  1644   "RTN","RCR JRBDR",87, 0)
  1645    D SETLINE ("Percenta ges           "_$J("  First Part y",18))
  1646   "RTN","RCR JRBDR",88, 0)
  1647    D SETLINE ("For                    "_$J("     SGL 131 9",18))
  1648   "RTN","RCR JRBDR",89, 0)
  1649    D SETLINE ("-------- ---------- ---"_$J("- ---------- -",18))
  1650   "RTN","RCR JRBDR",90, 0)
  1651    D SETLINE ("Collecti on           %"_$J($P (DATALTC," ^",2),18,2 ))
  1652   "RTN","RCR JRBDR",91, 0)
  1653    D SETLINE ("Write-Of f            %"_$J($P (DATALTC," ^",3),18,2 ))
  1654   "RTN","RCR JRBDR",92, 0)
  1655    D SETLINE ("Contract  Adjustmen t %"_$J($P (DATALTC," ^",4),18,2 ))
  1656   "RTN","RCR JRBDR",93, 0)
  1657    D SETLINE ("-------- ---------- ---"_$J("- ---------- -",18))
  1658   "RTN","RCR JRBDR",94, 0)
  1659    D SETLINE ("TOTAL                 %"_$J(10 0,18,2))
  1660   "RTN","RCR JRBDR",95, 0)
  1661    D SETLINE (" ")
  1662   "RTN","RCR JRBDR",96, 0)
  1663    ;
  1664   "RTN","RCR JRBDR",97, 0)
  1665    ;  show t otals
  1666   "RTN","RCR JRBDR",98, 0)
  1667    ;  1319 m ccf allowa nce
  1668   "RTN","RCR JRBDR",99, 0)
  1669    D SETLINE ("Allowanc e for Bad  Debt - Fir st Party ( SGL 1319 M CCF):")
  1670   "RTN","RCR JRBDR",100 ,0)
  1671    D SETLINE ("-------- ---------- ---------- ---------- ---------- ----")
  1672   "RTN","RCR JRBDR",101 ,0)
  1673    S CHANGED ="  " I $P (DATA1319, "^",10) S  CHANGED="* *"
  1674   "RTN","RCR JRBDR",102 ,0)
  1675    D SETLINE ($E("Allow ance Estim ate for "_ DATEREPT_S PACE,1,35) _":"_$J($P (DATA1319, "^",8),16, 2)_" "_CHA NGED_" (No rmally Cre dit Value) ")
  1676   "RTN","RCR JRBDR",103 ,0)
  1677    D SETLINE ($E("Bad D ebt Write- Off (Plus)   "_SPACE, 1,35)_":"_ $J($P(DATA 1319,"^",9 ),16,2)_"     (Normal ly Debit V alue )")
  1678   "RTN","RCR JRBDR",104 ,0)
  1679    D SETLINE ("-------- ---------- ---------- ---------- ---------- ----")
  1680   "RTN","RCR JRBDR",105 ,0)
  1681    D SETLINE ($E("Trans mitted Amo unt to FMS  for Month "_SPACE,1, 35)_":"_$J ($P(DATA13 19,"^",8)+ $P(DATA131 9,"^",9),1 6,2)_" "_C HANGED_" ( Normally C redit Valu e)")
  1682   "RTN","RCR JRBDR",106 ,0)
  1683    I $P(DATA 1319,"^",1 0) D SETLI NE($E(SPAC E,1,53)_"* *  Changed  Locally")
  1684   "RTN","RCR JRBDR",107 ,0)
  1685    D SETLINE (" ")
  1686   "RTN","RCR JRBDR",108 ,0)
  1687    ;
  1688   "RTN","RCR JRBDR",109 ,0)
  1689    ;  1319 l tc allowan ce
  1690   "RTN","RCR JRBDR",110 ,0)
  1691    D SETLINE ("Allowanc e for Bad  Debt - Fir st Party ( SGL 1319 L TC 528709) :")
  1692   "RTN","RCR JRBDR",111 ,0)
  1693    D SETLINE ("-------- ---------- ---------- ---------- ---------- ----")
  1694   "RTN","RCR JRBDR",112 ,0)
  1695    S CHANGED ="  " I $P (DATALTC," ^",10) S C HANGED="** "
  1696   "RTN","RCR JRBDR",113 ,0)
  1697    D SETLINE ($E("Allow ance Estim ate for "_ DATEREPT_S PACE,1,35) _":"_$J($P (DATALTC," ^",8),16,2 )_" "_CHAN GED_" (Nor mally Cred it Value)" )
  1698   "RTN","RCR JRBDR",114 ,0)
  1699    D SETLINE ($E("Bad D ebt Write- Off (Plus)   "_SPACE, 1,35)_":"_ $J($P(DATA LTC,"^",9) ,16,2)_"     (Normall y Debit Va lue )")
  1700   "RTN","RCR JRBDR",115 ,0)
  1701    D SETLINE ("-------- ---------- ---------- ---------- ---------- ----")
  1702   "RTN","RCR JRBDR",116 ,0)
  1703    D SETLINE ($E("Trans mitted Amo unt to FMS  for Month "_SPACE,1, 35)_":"_$J ($P(DATALT C,"^",8)+$ P(DATALTC, "^",9),16, 2)_" "_CHA NGED_" (No rmally Cre dit Value) ")
  1704   "RTN","RCR JRBDR",117 ,0)
  1705    I $P(DATA LTC,"^",10 ) D SETLIN E($E(SPACE ,1,53)_"**   Changed  Locally")
  1706   "RTN","RCR JRBDR",118 ,0)
  1707    D SETLINE (" ")
  1708   "RTN","RCR JRBDR",119 ,0)
  1709    ;
  1710   "RTN","RCR JRBDR",120 ,0)
  1711    ;  1339 a llowance
  1712   "RTN","RCR JRBDR",121 ,0)
  1713    D SETLINE ("Allowanc e for Cont ract Adj -  Third Par ty (SGL 13 39):")
  1714   "RTN","RCR JRBDR",122 ,0)
  1715    D SETLINE ("-------- ---------- ---------- ---------- ---------- ----")
  1716   "RTN","RCR JRBDR",123 ,0)
  1717    S CHANGED ="  " I $P (DATA1339, "^",10) S  CHANGED="* *"
  1718   "RTN","RCR JRBDR",124 ,0)
  1719    D SETLINE ($E("Allow ance Estim ate for "_ DATEREPT_S PACE,1,35) _":"_$J($P (DATA1339, "^",8),16, 2)_" "_CHA NGED_" (No rmally Cre dit Value) ")
  1720   "RTN","RCR JRBDR",125 ,0)
  1721    D SETLINE ($E("Bad D ebt Contra ct Adj (Pl us)  "_SPA CE,1,35)_" :"_$J($P(D ATA1339,"^ ",9),16,2) _"    (Nor mally Debi t Value )" )
  1722   "RTN","RCR JRBDR",126 ,0)
  1723    D SETLINE ("-------- ---------- ---------- ---------- ---------- ----")
  1724   "RTN","RCR JRBDR",127 ,0)
  1725    D SETLINE ($E("Trans mitted Amo unt to FMS  for Month "_SPACE,1, 35)_":"_$J ($P(DATA13 39,"^",8)+ $P(DATA133 9,"^",9),1 6,2)_" "_C HANGED_" ( Normally C redit Valu e)")
  1726   "RTN","RCR JRBDR",128 ,0)
  1727    I $P(DATA 1339,"^",1 0) D SETLI NE($E(SPAC E,1,53)_"* *  Changed  Locally")
  1728   "RTN","RCR JRBDR",129 ,0)
  1729    D SETLINE (" ")
  1730   "RTN","RCR JRBDR",130 ,0)
  1731    ;
  1732   "RTN","RCR JRBDR",131 ,0)
  1733    ;  133N a llowance -  Post-MRA  non-Medica re
  1734   "RTN","RCR JRBDR",132 ,0)
  1735    D SETLINE ("Allowanc e for Cont ract Adj -  Third Par ty (SGL 13 3N):")
  1736   "RTN","RCR JRBDR",133 ,0)
  1737    D SETLINE ("-------- ---------- ---------- ---------- ---------- ----")
  1738   "RTN","RCR JRBDR",134 ,0)
  1739    S CHANGED ="  " I $P (DATA133N, "^",10) S  CHANGED="* *"
  1740   "RTN","RCR JRBDR",135 ,0)
  1741    D SETLINE ($E("Allow ance Estim ate for "_ DATEREPT_S PACE,1,35) _":"_$J($P (DATA133N, "^",8),16, 2)_" "_CHA NGED_" (No rmally Cre dit Value) ")
  1742   "RTN","RCR JRBDR",136 ,0)
  1743    D SETLINE ($E("Bad D ebt Contra ct Adj (Pl us)  "_SPA CE,1,35)_" :"_$J($P(D ATA133N,"^ ",9),16,2) _"    (Nor mally Debi t Value )" )
  1744   "RTN","RCR JRBDR",137 ,0)
  1745    D SETLINE ("-------- ---------- ---------- ---------- ---------- ----")
  1746   "RTN","RCR JRBDR",138 ,0)
  1747    D SETLINE ($E("Trans mitted Amo unt to FMS  for Month "_SPACE,1, 35)_":"_$J ($P(DATA13 3N,"^",8)+ $P(DATA133 N,"^",9),1 6,2)_" "_C HANGED_" ( Normally C redit Valu e)")
  1748   "RTN","RCR JRBDR",139 ,0)
  1749    I $P(DATA 133N,"^",1 0) D SETLI NE($E(SPAC E,1,53)_"* *  Changed  Locally")
  1750   "RTN","RCR JRBDR",140 ,0)
  1751    D SETLINE (" ")
  1752   "RTN","RCR JRBDR",141 ,0)
  1753    ;
  1754   "RTN","RCR JRBDR",142 ,0)
  1755    ;  1338 a llowance
  1756   "RTN","RCR JRBDR",143 ,0)
  1757    D SETLINE ("Allowanc e for Bad  Debt - Tor t Feasors  (SGL 1338) :")
  1758   "RTN","RCR JRBDR",144 ,0)
  1759    D SETLINE ("-------- ---------- ---------- ---------- ---------- ----")
  1760   "RTN","RCR JRBDR",145 ,0)
  1761    S CHANGED ="  " I $P (DATA1338, "^",10) S  CHANGED="* *"
  1762   "RTN","RCR JRBDR",146 ,0)
  1763    D SETLINE ($E("Allow ance Estim ate for "_ DATEREPT_S PACE,1,35) _":"_$J($P (DATA1338, "^",8),16, 2)_" "_CHA NGED_" (No rmally Cre dit Value) ")
  1764   "RTN","RCR JRBDR",147 ,0)
  1765    D SETLINE ($E("Bad D ebt Write- Off (Plus)   "_SPACE, 1,35)_":"_ $J($P(DATA 1338,"^",9 ),16,2)_"     (Normal ly Debit V alue )")
  1766   "RTN","RCR JRBDR",148 ,0)
  1767    D SETLINE ("-------- ---------- ---------- ---------- ---------- ----")
  1768   "RTN","RCR JRBDR",149 ,0)
  1769    D SETLINE ($E("Trans mitted Amo unt to FMS  for Month "_SPACE,1, 35)_":"_$J ($P(DATA13 38,"^",8)+ $P(DATA133 8,"^",9),1 6,2)_" "_C HANGED_" ( Normally C redit Valu e)")
  1770   "RTN","RCR JRBDR",150 ,0)
  1771    I $P(DATA 1338,"^",1 0) D SETLI NE($E(SPAC E,1,53)_"* *  Changed  Locally")
  1772   "RTN","RCR JRBDR",151 ,0)
  1773    D SETLINE (" ")
  1774   "RTN","RCR JRBDR",152 ,0)
  1775    D SETLINE ("Report F ootnotes:" )
  1776   "RTN","RCR JRBDR",153 ,0)
  1777    D SETLINE ("-------- ---------" )
  1778   "RTN","RCR JRBDR",154 ,0)
  1779    ;
  1780   "RTN","RCR JRBDR",155 ,0)
  1781    D ENDOFRE P^RCRJRBDT
  1782   "RTN","RCR JRBDR",156 ,0)
  1783    ;
  1784   "RTN","RCR JRBDR",157 ,0)
  1785   MAIL ;  pu t report i n mailman
  1786   "RTN","RCR JRBDR",158 ,0)
  1787    I $G(RCRJ FMM) D  D  Q Q
  1788   "RTN","RCR JRBDR",159 ,0)
  1789    . N XMY
  1790   "RTN","RCR JRBDR",160 ,0)
  1791    . S XMY(" G.RC AR DA TA COLLECT OR")=""
  1792   "RTN","RCR JRBDR",161 ,0)
  1793    . S %=$$S ENDMSG^RCR JRCOR("BAD  DEBT REPO RT",.XMY)
  1794   "RTN","RCR JRBDR",162 ,0)
  1795    ;
  1796   "RTN","RCR JRBDR",163 ,0)
  1797    ;  print  report
  1798   "RTN","RCR JRBDR",164 ,0)
  1799    S SCREEN= 0 I '$D(ZT QUEUED),IO =IO(0),$E( IOST)="C"  S SCREEN=1
  1800   "RTN","RCR JRBDR",165 ,0)
  1801    U IO I SC REEN W @IO F
  1802   "RTN","RCR JRBDR",166 ,0)
  1803    S LINE=1  F  S LINE= $O(^TMP($J ,"RCRJRCOR MM",LINE))  Q:'LINE!( $G(RCRJFLA G))  D
  1804   "RTN","RCR JRBDR",167 ,0)
  1805    . I $Y>(I OSL-5) D:S CREEN PAUS E^RCRJRTR1  Q:$G(RCRJ FLAG)  W @ IOF F %=2: 1:5 W !,^T MP($J,"RCR JRCORMM",% )
  1806   "RTN","RCR JRBDR",168 ,0)
  1807    . W !,^TM P($J,"RCRJ RCORMM",LI NE)
  1808   "RTN","RCR JRBDR",169 ,0)
  1809    I '$G(RCR JFLAG),SCR EEN R !!," <end of re port, pres s return t o continue >",X:DTIME
  1810   "RTN","RCR JRBDR",170 ,0)
  1811    D ^%ZISC
  1812   "RTN","RCR JRBDR",171 ,0)
  1813    ;
  1814   "RTN","RCR JRBDR",172 ,0)
  1815   Q K ^TMP($ J,"RCRJRCO RMM")
  1816   "RTN","RCR JRBDR",173 ,0)
  1817    Q
  1818   "RTN","RCR JRBDR",174 ,0)
  1819    ;
  1820   "RTN","RCR JRBDR",175 ,0)
  1821    ;
  1822   "RTN","RCR JRBDR",176 ,0)
  1823   SETLINE(DA TA) ;  bui ld the lin e for the  report
  1824   "RTN","RCR JRBDR",177 ,0)
  1825    S LINE=LI NE+1,^TMP( $J,"RCRJRC ORMM",LINE )=DATA
  1826   "RTN","RCR JRBDR",178 ,0)
  1827    Q
  1828   "RTN","RCR JRBDT")
  1829   0^8^B57917 736^B55944 684
  1830   "RTN","RCR JRBDT",1,0 )
  1831   RCRJRBDT ; WISC/RFJ-b ad debt re transmit ; 9/2/10 8:4 7am
  1832   "RTN","RCR JRBDT",2,0 )
  1833    ;;4.5;Acc ounts Rece ivable;**1 01,170,191 ,138,239,2 73,310**;M ar 20, 199 5;Build 14
  1834   "RTN","RCR JRBDT",3,0 )
  1835    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  1836   "RTN","RCR JRBDT",4,0 )
  1837    ;
  1838   "RTN","RCR JRBDT",5,0 )
  1839    ;
  1840   "RTN","RCR JRBDT",6,0 )
  1841    ; - deact ivate this  option wi th patch P RCA*4.5*23 9
  1842   "RTN","RCR JRBDT",7,0 )
  1843    W !!,"Thi s option m ay no long er be used  to retran smit the B ad Debt"
  1844   "RTN","RCR JRBDT",8,0 )
  1845    W !,"allo wance esti mates to F MS."
  1846   "RTN","RCR JRBDT",9,0 )
  1847    W !!,"Ple ase use th e option ' Monthly ND B, SV and  WR Regener ate' to"
  1848   "RTN","RCR JRBDT",10, 0)
  1849    W !,"reca lculate th e allowanc e estimate s and tran smit them  to FMS.",! !
  1850   "RTN","RCR JRBDT",11, 0)
  1851    ;
  1852   "RTN","RCR JRBDT",12, 0)
  1853    S DIR(0)= "E" D ^DIR  K DIR,DIR UT,DUOUT,D TOUT,DIROU T,X,Y
  1854   "RTN","RCR JRBDT",13, 0)
  1855    ;
  1856   "RTN","RCR JRBDT",14, 0)
  1857    Q
  1858   "RTN","RCR JRBDT",15, 0)
  1859    ;
  1860   "RTN","RCR JRBDT",16, 0)
  1861    ;
  1862   "RTN","RCR JRBDT",17, 0)
  1863    N DA347,D ATEMOYR,FM SDOCNO,GEC SDATA,RCRJ FSV
  1864   "RTN","RCR JRBDT",18, 0)
  1865    ;  the da te of the  report is  for previo us month i f the DT i s before t he EOAM da te of the  current mo nth,  it i s for the  current mo nth if the  date is a fter the E OAM cut-of f date.
  1866   "RTN","RCR JRBDT",19, 0)
  1867    I $E(DT,6 ,7)'>$E($$ LDATE^RCRJ R(DT),6,7)  S DATEMOY R=$$PREVMO NT^RCRJRBD (DT)
  1868   "RTN","RCR JRBDT",20, 0)
  1869    I $E(DT,6 ,7)>$E($$L DATE^RCRJR (DT),6,7)  S DATEMOYR =$E($$LDAT E^RCRJR(DT ),1,5)_"00 "
  1870   "RTN","RCR JRBDT",21, 0)
  1871    ;S DATEMO YR=$$PREVM ONT^RCRJRB D(DT)
  1872   "RTN","RCR JRBDT",22, 0)
  1873    W !!,"Thi s option w ill retran smit the B ad Debt do cuments to  FMS (SV23 , SV27, SV 2B)."
  1874   "RTN","RCR JRBDT",23, 0)
  1875    ;
  1876   "RTN","RCR JRBDT",24, 0)
  1877    ;I +$E(DT ,6,7)<$$WD 3^RCRJRBD  D  Q
  1878   "RTN","RCR JRBDT",25, 0)
  1879    I $E(DT,6 ,7)<$E($$L DATE^RCRJR (DT),6,7)! ($E(DT,6,7 )'<$E($$LD AY^RCRJR(D T),6,7)) D   Q
  1880   "RTN","RCR JRBDT",26, 0)
  1881    .  W !,"T he FMS doc uments wil l be autom atically s ent to FMS  on the se cond to la st ",!,"wo rkday of t his month. "
  1882   "RTN","RCR JRBDT",27, 0)
  1883    ;  try an d find SV  document t o see if i ts accepte d
  1884   "RTN","RCR JRBDT",28, 0)
  1885    S FMSDOCN O=""
  1886   "RTN","RCR JRBDT",29, 0)
  1887    K GECSDAT A
  1888   "RTN","RCR JRBDT",30, 0)
  1889    S DA347=$ O(^RC(347, "D","SV-"_ $E(DATEMOY R,1,5)_"01 ",0))
  1890   "RTN","RCR JRBDT",31, 0)
  1891    I DA347 S  FMSDOCNO= $P($G(^RC( 347,DA347, 0)),"^",9)
  1892   "RTN","RCR JRBDT",32, 0)
  1893    ;  if the re is an e ntry, find  the code  sheet in g cs to rebu ild
  1894   "RTN","RCR JRBDT",33, 0)
  1895    ;  gecsda ta will be  the ien f or file 21 00.1
  1896   "RTN","RCR JRBDT",34, 0)
  1897    I FMSDOCN O'="" D DA TA^GECSSGE T(FMSDOCNO ,0)
  1898   "RTN","RCR JRBDT",35, 0)
  1899    I $G(GECS DATA) D
  1900   "RTN","RCR JRBDT",36, 0)
  1901    .   W !!, "The SV do cument has  been tran smitted to  fms, docu ment numbe r: "_FMSDO CNO
  1902   "RTN","RCR JRBDT",37, 0)
  1903    .   I $E( $G(GECSDAT A(2100.1,G ECSDATA,3, "E")))="A"  D  Q
  1904   "RTN","RCR JRBDT",38, 0)
  1905    .   .   W  !,"The SV  document  has been A CCEPTED in  FMS and w ill not be  resent."
  1906   "RTN","RCR JRBDT",39, 0)
  1907    .   .   S  RCRJFSV=1
  1908   "RTN","RCR JRBDT",40, 0)
  1909    .   W !," The SV doc ument has  NOT been A CCEPTED an d will be  RETRANSMIT TED."
  1910   "RTN","RCR JRBDT",41, 0)
  1911    I $G(RCRJ FSV) Q
  1912   "RTN","RCR JRBDT",42, 0)
  1913    ;
  1914   "RTN","RCR JRBDT",43, 0)
  1915    I $$ASKOK AY(DATEMOY R)'=1 Q
  1916   "RTN","RCR JRBDT",44, 0)
  1917    ;
  1918   "RTN","RCR JRBDT",45, 0)
  1919    ;  make s ure this c ode is not  executed.
  1920   "RTN","RCR JRBDT",46, 0)
  1921    ;W !!,"Re -sending t he documen ts to FMS  ..."
  1922   "RTN","RCR JRBDT",47, 0)
  1923    ;D BADDEB T^RCXFMSSV
  1924   "RTN","RCR JRBDT",48, 0)
  1925    ;W " Done .",!,"The  Bad Debt R eport will  be sent t o the G.FM S mail gro up."
  1926   "RTN","RCR JRBDT",49, 0)
  1927    Q
  1928   "RTN","RCR JRBDT",50, 0)
  1929    ;
  1930   "RTN","RCR JRBDT",51, 0)
  1931    ;
  1932   "RTN","RCR JRBDT",52, 0)
  1933   ASKOKAY(DA TEMOYR) ;   ask if it s okay
  1934   "RTN","RCR JRBDT",53, 0)
  1935    ;  1 is y es, otherw ise no
  1936   "RTN","RCR JRBDT",54, 0)
  1937    N DIR,DIQ 2,DTOUT,DU OUT,X,Y
  1938   "RTN","RCR JRBDT",55, 0)
  1939    S Y=DATEM OYR D DD^% DT
  1940   "RTN","RCR JRBDT",56, 0)
  1941    S DIR(0)= "YO",DIR(" B")="NO"
  1942   "RTN","RCR JRBDT",57, 0)
  1943    S DIR("A" )="  Are y ou SURE yo u want to  resend the  Bad Debt  Report for  "_Y
  1944   "RTN","RCR JRBDT",58, 0)
  1945    W ! D ^DI R
  1946   "RTN","RCR JRBDT",59, 0)
  1947    I $G(DTOU T)!($G(DUO UT)) S Y=- 1
  1948   "RTN","RCR JRBDT",60, 0)
  1949    Q Y
  1950   "RTN","RCR JRBDT",61, 0)
  1951    ;
  1952   "RTN","RCR JRBDT",62, 0)
  1953    ;
  1954   "RTN","RCR JRBDT",63, 0)
  1955   ENDOFREP ;   print en d of bad d ebt report  footnotes
  1956   "RTN","RCR JRBDT",64, 0)
  1957    ;  called  from rcrj rbdr
  1958   "RTN","RCR JRBDT",65, 0)
  1959    ;
  1960   "RTN","RCR JRBDT",66, 0)
  1961    ;  print  footnote
  1962   "RTN","RCR JRBDT",67, 0)
  1963    S Y=RCRJD ATE D DD^% DT S ENDDA TE=Y
  1964   "RTN","RCR JRBDT",68, 0)
  1965    F %=1:1 S  DATA=$P($ T(FOOTNOTE +%),";",3, 99) Q:DATA =""  D
  1966   "RTN","RCR JRBDT",69, 0)
  1967    .   I DAT A["DATEREP T" S DATA= $P(DATA,"D ATEREPT")_ DATEREPT_$ P(DATA,"DA TEREPT",2)
  1968   "RTN","RCR JRBDT",70, 0)
  1969    .   I DAT A["ENDDATE " S DATA=$ P(DATA,"EN DDATE")_EN DDATE_$P(D ATA,"ENDDA TE",2)
  1970   "RTN","RCR JRBDT",71, 0)
  1971    .   D SET LINE^RCRJR BDR(DATA)
  1972   "RTN","RCR JRBDT",72, 0)
  1973    Q
  1974   "RTN","RCR JRBDT",73, 0)
  1975    ;
  1976   "RTN","RCR JRBDT",74, 0)
  1977    ;
  1978   "RTN","RCR JRBDT",75, 0)
  1979   FOOTNOTE ;   report f ootnotes ( from rcrjr bdr)
  1980   "RTN","RCR JRBDT",76, 0)
  1981    ;;(1) Cal culated Pe rcentages  and the Al lowance fo r Contract  Adj - Thi rd Party
  1982   "RTN","RCR JRBDT",77, 0)
  1983    ;;    for  SGL 1339  are based  on bills c reated pri or to the  activation  of the
  1984   "RTN","RCR JRBDT",78, 0)
  1985    ;;    Med icare Remi ttance Adv ice softwa re.  Over  time, ther e will no  longer be
  1986   "RTN","RCR JRBDT",79, 0)
  1987    ;;    any  bills in  this categ ory.
  1988   "RTN","RCR JRBDT",80, 0)
  1989    ;; 
  1990   "RTN","RCR JRBDT",81, 0)
  1991    ;;(2) Cal culated Pe rcentages  and the Al lowance fo r Contract  Adj - Thi rd Party
  1992   "RTN","RCR JRBDT",82, 0)
  1993    ;;    for  SGL 133N  are based  on non-Med icare WNR  bills crea ted after  the
  1994   "RTN","RCR JRBDT",83, 0)
  1995    ;;    act ivation of  the Medic are Remitt ance Advic e software .
  1996   "RTN","RCR JRBDT",84, 0)
  1997    ;; 
  1998   "RTN","RCR JRBDT",85, 0)
  1999    ;;(3) The  "Allowanc e Estimate  for DATER EPT" is th e dollar v alue estim ated
  2000   "RTN","RCR JRBDT",86, 0)
  2001    ;;    as  the Allowa nce for Ba d Debt or  Contract A djustment  for the mo nth.
  2002   "RTN","RCR JRBDT",87, 0)
  2003    ;; 
  2004   "RTN","RCR JRBDT",88, 0)
  2005    ;;(4) The  "Bad Debt  Write-Off  (Plus)" i s the actu al write-o ffs or con tract
  2006   "RTN","RCR JRBDT",89, 0)
  2007    ;;    adj ustments a ccomplishe d from FEB  1,1998 th ru ENDDATE .
  2008   "RTN","RCR JRBDT",90, 0)
  2009    ;; 
  2010   "RTN","RCR JRBDT",91, 0)
  2011    ;;(5) The  "Transmit ted Amount  to FMS fo r Month" i s the sum  of (3) and  (4).
  2012   "RTN","RCR JRBDT",92, 0)
  2013    ;;    The  transmitt ed dollar  value is n ormally a  credit val ue.
  2014   "RTN","RCR JRBDT",93, 0)
  2015    ;; 
  2016   "RTN","RCR JRBDT",94, 0)
  2017    ;;(6) Fac ilities ar e responsi ble for re porting mo nthly accr ued unbill ed
  2018   "RTN","RCR JRBDT",95, 0)
  2019    ;;    amo unts.  Whe n such amo unts are i dentified  and report ed, a port ion of
  2020   "RTN","RCR JRBDT",96, 0)
  2021    ;;    tho se dollars  should be  reported  as uncolle ctable.  T he estimat ed
  2022   "RTN","RCR JRBDT",97, 0)
  2023    ;;    unc ollectable  value of  the unbill ed amounts  should be  included  as part
  2024   "RTN","RCR JRBDT",98, 0)
  2025    ;;    of  the facili ty's month ly allowan ce for bad  debt or c ontract ad justments.
  2026   "RTN","RCR JRBDT",99, 0)
  2027    ;;    The  AR Overri de Option  should be  used to ad just the v alue provi ded to
  2028   "RTN","RCR JRBDT",100 ,0)
  2029    ;;    rep ort the es timated un collectabl e accrued  unbilled a mounts for  the
  2030   "RTN","RCR JRBDT",101 ,0)
  2031    ;;    mon th.  Facil ities may  wish to co nsider usi ng the all owance per centages
  2032   "RTN","RCR JRBDT",102 ,0)
  2033    ;;    pro vided with  this repo rt, if no  other mean s of deter mining the
  2034   "RTN","RCR JRBDT",103 ,0)
  2035    ;;    est imated all owance for  the accru ed unbille d amount i s acceptab le.
  2036   "RTN","RCR JRBDT",104 ,0)
  2037    ;; 
  2038   "RTN","RCR JRBDT",105 ,0)
  2039    ;;(7) Onl y members  in the fac ility's lo cal RC AR  DATA COLLE CTOR mail  group
  2040   "RTN","RCR JRBDT",106 ,0)
  2041    ;;    wil l receive  this repor t.
  2042   "RTN","RCR JRBDT",107 ,0)
  2043    ;
  2044   "RTN","RCR JRBDT",108 ,0)
  2045    ;
  2046   "RTN","RCR JRBDT",109 ,0)
  2047    ;
  2048   "RTN","RCR JRBDT",110 ,0)
  2049   BDR ; Comp ile new Ba d Debt Rep ort.
  2050   "RTN","RCR JRBDT",111 ,0)
  2051    ;   This  code will  be used to  compile t he new Bad  Debt Repo rt.
  2052   "RTN","RCR JRBDT",112 ,0)
  2053    ;   This  routine is  invokved  by routine  RCRJRBDR  when the B ad
  2054   "RTN","RCR JRBDT",113 ,0)
  2055    ;   Debt  Report nee ds to be p rinted.
  2056   "RTN","RCR JRBDT",114 ,0)
  2057    ;
  2058   "RTN","RCR JRBDT",115 ,0)
  2059    ;     Var iable inpu t:  LINE   --  set to  0
  2060   "RTN","RCR JRBDT",116 ,0)
  2061    ;                       SPACE   --  set to  81 space  characters
  2062   "RTN","RCR JRBDT",117 ,0)
  2063    ;                    DATEREPT   --  format ted month  and year
  2064   "RTN","RCR JRBDT",118 ,0)
  2065    ;
  2066   "RTN","RCR JRBDT",119 ,0)
  2067    N RCARR,R CX,RCD,RCD ATA,RCREC, X
  2068   "RTN","RCR JRBDT",120 ,0)
  2069    D SETLINE (" ")
  2070   "RTN","RCR JRBDT",121 ,0)
  2071    D SETLINE ($E(SPACE, 1,32)_"Bad  Debt Repo rt")
  2072   "RTN","RCR JRBDT",122 ,0)
  2073    D SETLINE ($E(SPACE, 1,13)_"All owance for  Bad Debt  and Contra ct Adjustm ent Report ")
  2074   "RTN","RCR JRBDT",123 ,0)
  2075    D SETLINE ($E(SPACE, 1,27)_"for  the month  of "_DATE REPT)
  2076   "RTN","RCR JRBDT",124 ,0)
  2077    I $D(RCRJ FXSV) D
  2078   "RTN","RCR JRBDT",125 ,0)
  2079    . D SETLI NE(" ")
  2080   "RTN","RCR JRBDT",126 ,0)
  2081    . I $E(RC RJFXSV,1,2 )="SV" D S ETLINE($E( SPACE,1,13 )_"***** R eport sent  to FMS, d oc id: "_R CRJFXSV_"  *****") Q
  2082   "RTN","RCR JRBDT",127 ,0)
  2083    . ;  repo rt errored  out or di d not get  generated  to fms
  2084   "RTN","RCR JRBDT",128 ,0)
  2085    . D SETLI NE($E(SPAC E,1,10)_"* **** NOTIC E:  Report  was NOT s ent to FMS , the mess age is *** **")
  2086   "RTN","RCR JRBDT",129 ,0)
  2087    . D SETLI NE($E(SPAC E,1,10)_"* **** "_RCR JFXSV_" ** ***")
  2088   "RTN","RCR JRBDT",130 ,0)
  2089    ;
  2090   "RTN","RCR JRBDT",131 ,0)
  2091    ;  show m ccf
  2092   "RTN","RCR JRBDT",132 ,0)
  2093    ; PRCA*4. 5*310/DRF  - add fee  basis fund  (528713)  to report
  2094   "RTN","RCR JRBDT",133 ,0)
  2095    D SETLINE (" ")
  2096   "RTN","RCR JRBDT",134 ,0)
  2097    D SETLINE ($E(SPACE, 1,26)_"Med ical Care  Collection  Fund")
  2098   "RTN","RCR JRBDT",135 ,0)
  2099    D SETLINE ($E(SPACE, 1,20)_" Fu nds 528701 ; 528703;  528704; 52 8709; 5287 11; and 52 8713")
  2100   "RTN","RCR JRBDT",136 ,0)
  2101    D SETLINE ($E(SPACE, 1,26)_"--- ---------- ---------- -----")
  2102   "RTN","RCR JRBDT",137 ,0)
  2103    D SETLINE (" ")
  2104   "RTN","RCR JRBDT",138 ,0)
  2105    D SETLINE (" ")
  2106   "RTN","RCR JRBDT",139 ,0)
  2107    D SETLINE ($E(SPACE, 1,57)_"Con tract            EOM" )
  2108   "RTN","RCR JRBDT",140 ,0)
  2109    D SETLINE ("FUND - S GL Account      Colle ction%      Write-Off %     Adju stment%      Allowanc e")
  2110   "RTN","RCR JRBDT",141 ,0)
  2111    D SETLINE (" ")
  2112   "RTN","RCR JRBDT",142 ,0)
  2113    ;
  2114   "RTN","RCR JRBDT",143 ,0)
  2115    ; List th e fund/SGL s as:
  2116   "RTN","RCR JRBDT",144 ,0)
  2117    ;   Order      SGL i n file       Fund - S GL on repo rt
  2118   "RTN","RCR JRBDT",145 ,0)
  2119    ;   ===== ========== ========== ========== ========== ==
  2120   "RTN","RCR JRBDT",146 ,0)
  2121    ;     1              1319.3              5 28701 - 13 19
  2122   "RTN","RCR JRBDT",147 ,0)
  2123    ;     2                1319              5 28703 - 13 19
  2124   "RTN","RCR JRBDT",148 ,0)
  2125    ;     3              1319.4              5 28704 - 13 19
  2126   "RTN","RCR JRBDT",149 ,0)
  2127    ;     4                1339              5 28704 - 13 39
  2128   "RTN","RCR JRBDT",150 ,0)
  2129    ;     5                133N              5 28704 - 13 3N
  2130   "RTN","RCR JRBDT",151 ,0)
  2131    ;     6                1338              5 28704 - 13 38
  2132   "RTN","RCR JRBDT",152 ,0)
  2133    ;     7              1319.2              5 28709 - 13 19
  2134   "RTN","RCR JRBDT",153 ,0)
  2135    ;     8              1319.5              5 28711 - 13 19
  2136   "RTN","RCR JRBDT",154 ,0)
  2137    ;     9              133N.2              5 28711 - 13 3N
  2138   "RTN","RCR JRBDT",155 ,0)
  2139    ;    10              1338.2              5 28711 - 13 38
  2140   "RTN","RCR JRBDT",156 ,0)
  2141    ;    11              1319.6              5 28713 - 13 19
  2142   "RTN","RCR JRBDT",157 ,0)
  2143    ;    12              1339.1              5 28713 - 13 39
  2144   "RTN","RCR JRBDT",158 ,0)
  2145    ;    13              133N.3              5 28713 - 13 3N
  2146   "RTN","RCR JRBDT",159 ,0)
  2147    ;    14              1338.3              5 28713 - 13 38
  2148   "RTN","RCR JRBDT",160 ,0)
  2149    ;
  2150   "RTN","RCR JRBDT",161 ,0)
  2151    S RCARR(1 )="1319.3^ 528701 - 1 319"
  2152   "RTN","RCR JRBDT",162 ,0)
  2153    S RCARR(2 )="1319^52 8703 - 131 9"
  2154   "RTN","RCR JRBDT",163 ,0)
  2155    S RCARR(3 )="1319.4^ 528704 - 1 319"
  2156   "RTN","RCR JRBDT",164 ,0)
  2157    S RCARR(4 )="1339^52 8704 - 133 9"
  2158   "RTN","RCR JRBDT",165 ,0)
  2159    S RCARR(5 )="133N^52 8704 - 133 N"
  2160   "RTN","RCR JRBDT",166 ,0)
  2161    S RCARR(6 )="1338^52 8704 - 133 8"
  2162   "RTN","RCR JRBDT",167 ,0)
  2163    S RCARR(7 )="1319.2^ 528709 - 1 319"
  2164   "RTN","RCR JRBDT",168 ,0)
  2165    S RCARR(8 )="1319.5^ 528711 - 1 319"
  2166   "RTN","RCR JRBDT",169 ,0)
  2167    S RCARR(9 )="133N.2^ 528711 - 1 33N"
  2168   "RTN","RCR JRBDT",170 ,0)
  2169    S RCARR(1 0)="1338.2 ^528711 -  1338"
  2170   "RTN","RCR JRBDT",171 ,0)
  2171    S RCARR(1 1)="1319.6 ^528713 -  1319"
  2172   "RTN","RCR JRBDT",172 ,0)
  2173    S RCARR(1 2)="1339.1 ^528713 -  1339"
  2174   "RTN","RCR JRBDT",173 ,0)
  2175    S RCARR(1 3)="133N.3 ^528713 -  133N"
  2176   "RTN","RCR JRBDT",174 ,0)
  2177    S RCARR(1 4)="1338.3 ^528713 -  1338"
  2178   "RTN","RCR JRBDT",175 ,0)
  2179    ;
  2180   "RTN","RCR JRBDT",176 ,0)
  2181    S RCX=""  F  S RCX=$ O(RCARR(RC X)) Q:RCX= ""  S RCD= RCARR(RCX)  D
  2182   "RTN","RCR JRBDT",177 ,0)
  2183    .S RCDATA =$G(^RC(34 8.1,+$O(^R C(348.1,"B ",$P(RCD," ^"),0)),0) )
  2184   "RTN","RCR JRBDT",178 ,0)
  2185    .Q:RCDATA =""
  2186   "RTN","RCR JRBDT",179 ,0)
  2187    .S RCREC= $P(RCD,"^" ,2)_$J($P( RCDATA,"^" ,2),21,2)
  2188   "RTN","RCR JRBDT",180 ,0)
  2189    .S RCREC= RCREC_$J($ P(RCDATA," ^",3),15,2 )
  2190   "RTN","RCR JRBDT",181 ,0)
  2191    .S RCREC= RCREC_$J($ P(RCDATA," ^",4),16,2 )
  2192   "RTN","RCR JRBDT",182 ,0)
  2193    .S X=+$P( RCDATA,"^" ,8)
  2194   "RTN","RCR JRBDT",183 ,0)
  2195    .S X=$FN( X,",")_$S( X[".":"",1 :".")_$E(" 00",$L($P( X,".",2))+ 1,2)
  2196   "RTN","RCR JRBDT",184 ,0)
  2197    .S RCREC= RCREC_$J(X ,14)
  2198   "RTN","RCR JRBDT",185 ,0)
  2199    .D SETLIN E(RCREC)
  2200   "RTN","RCR JRBDT",186 ,0)
  2201    ;
  2202   "RTN","RCR JRBDT",187 ,0)
  2203    D SETLINE (" ")
  2204   "RTN","RCR JRBDT",188 ,0)
  2205    D SETLINE (" ")
  2206   "RTN","RCR JRBDT",189 ,0)
  2207    D SETLINE ("SGL Defi nitions")
  2208   "RTN","RCR JRBDT",190 ,0)
  2209    D SETLINE (" ")
  2210   "RTN","RCR JRBDT",191 ,0)
  2211    D SETLINE ("1319 - A llowance f or Bad Deb t")
  2212   "RTN","RCR JRBDT",192 ,0)
  2213    D SETLINE ("1338 - A llowance f or Tort Fe asors")
  2214   "RTN","RCR JRBDT",193 ,0)
  2215    D SETLINE ("1339 - A llowance f or Contrac t Adjustme nts pre-MR A (Medicar e Remittan ce Advice) ")
  2216   "RTN","RCR JRBDT",194 ,0)
  2217    D SETLINE ("133N - A llowance f or Contrac t Adjustme nts post-M RA")
  2218   "RTN","RCR JRBDT",195 ,0)
  2219    D SETLINE (" ")
  2220   "RTN","RCR JRBDT",196 ,0)
  2221    D SETLINE (" ")
  2222   "RTN","RCR JRBDT",197 ,0)
  2223    D SETLINE ("Only mem bers in th e facility 's local R C AR DATA  COLLECTOR  mail group ")
  2224   "RTN","RCR JRBDT",198 ,0)
  2225    D SETLINE ("will rec eive this  report.")
  2226   "RTN","RCR JRBDT",199 ,0)
  2227    Q
  2228   "RTN","RCR JRBDT",200 ,0)
  2229    ;
  2230   "RTN","RCR JRBDT",201 ,0)
  2231   SETLINE(DA TA) ;  bui ld the lin e for the  report
  2232   "RTN","RCR JRBDT",202 ,0)
  2233    S LINE=LI NE+1,^TMP( $J,"RCRJRC ORMM",LINE )=DATA
  2234   "RTN","RCR JRBDT",203 ,0)
  2235    Q
  2236   "RTN","RCR JRDEP")
  2237   0^4^B64337 684^B57617 465
  2238   "RTN","RCR JRDEP",1,0 )
  2239   RCRJRDEP ; WISC/RFJ-D eposit Rec onciliatio n Report ; 9/7/10 8:1 9am
  2240   "RTN","RCR JRDEP",2,0 )
  2241    ;;4.5;Acc ounts Rece ivable;**1 01,114,203 ,220,273,3 10**;Mar 2 0, 1995;Bu ild 14
  2242   "RTN","RCR JRDEP",3,0 )
  2243    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  2244   "RTN","RCR JRDEP",4,0 )
  2245    ;
  2246   "RTN","RCR JRDEP",5,0 )
  2247    W !!,"Thi s option w ill print  the Deposi t Reconcil iation Rep ort.  The  report wil l"
  2248   "RTN","RCR JRDEP",6,0 )
  2249    W !,"disp lay the da ta on the  code sheet s sent to  FMS on the  CR docume nt.  Only"
  2250   "RTN","RCR JRDEP",7,0 )
  2251    W !,"depo sits proce ssed after  patch PRC A*4.5*90 w as install ed can be  displayed. "
  2252   "RTN","RCR JRDEP",8,0 )
  2253    W !,"Sele ct the sta rting and  ending FMS  Document  Number wit hout the s tation"
  2254   "RTN","RCR JRDEP",9,0 )
  2255    W !,"numb er, exampl e: K8A0346 ."
  2256   "RTN","RCR JRDEP",10, 0)
  2257    ;
  2258   "RTN","RCR JRDEP",11, 0)
  2259    N DEFAULT ,RCRJEND,R CRJFXIT,RC RJSTRT,RCR JSUMM,X
  2260   "RTN","RCR JRDEP",12, 0)
  2261    ;
  2262   "RTN","RCR JRDEP",13, 0)
  2263    F  D  Q:$ G(RCRJFXIT )
  2264   "RTN","RCR JRDEP",14, 0)
  2265    . R !!,"S TART WITH  CR DOCUMEN T: FIRST//  ",X:DTIME
  2266   "RTN","RCR JRDEP",15, 0)
  2267    . I X["^"  S RCRJFXI T=2 Q
  2268   "RTN","RCR JRDEP",16, 0)
  2269    . I $L(X) ,$L(X)'=7  W !?5,"The  CR DOCUME NT should  be 7 chara cters in l ength (exa mple: K8A0 804)." Q
  2270   "RTN","RCR JRDEP",17, 0)
  2271    . S RCRJS TRT=$TR(X, "abcdefghi jklmnopqrs tuvwxyz"," ABCDEFGHIJ KLMNOPQRST UVWXYZ")
  2272   "RTN","RCR JRDEP",18, 0)
  2273    . ;
  2274   "RTN","RCR JRDEP",19, 0)
  2275    . S DEFAU LT=$S(RCRJ STRT="":"  LAST",1:RC RJSTRT)
  2276   "RTN","RCR JRDEP",20, 0)
  2277    . W !,"   END WITH C R DOCUMENT : ",DEFAUL T,"// " R  X:DTIME
  2278   "RTN","RCR JRDEP",21, 0)
  2279    . I X["^"  S RCRJFXI T=2 Q
  2280   "RTN","RCR JRDEP",22, 0)
  2281    . S RCRJE ND=$TR(X," abcdefghij klmnopqrst uvwxyz","A BCDEFGHIJK LMNOPQRSTU VWXYZ")
  2282   "RTN","RCR JRDEP",23, 0)
  2283    . I X="LA ST" S (RCR JEND,X)="z zzzzzz"
  2284   "RTN","RCR JRDEP",24, 0)
  2285    . I $L(X) ,$L(X)'=7  W !?5,"The  CR DOCUME NT should  be 7 chara cters in l ength (exa mple: K8A0 804)." Q
  2286   "RTN","RCR JRDEP",25, 0)
  2287    . I X=""  S RCRJEND= $S(DEFAULT =" LAST":" zzzzzzz",1 :DEFAULT)
  2288   "RTN","RCR JRDEP",26, 0)
  2289    . I RCRJE ND'=RCRJST RT,RCRJEND ']RCRJSTRT  W !?5,"Th e END CR D OCUMENT sh ould be af ter (in se quence) th e start do cument." Q
  2290   "RTN","RCR JRDEP",27, 0)
  2291    . S RCRJF XIT=1
  2292   "RTN","RCR JRDEP",28, 0)
  2293    I RCRJFXI T=2 Q
  2294   "RTN","RCR JRDEP",29, 0)
  2295    ;
  2296   "RTN","RCR JRDEP",30, 0)
  2297    S RCRJSUM M=$$SUMMAR Y^RCRJRTRA  I 'RCRJSU MM Q
  2298   "RTN","RCR JRDEP",31, 0)
  2299    ;
  2300   "RTN","RCR JRDEP",32, 0)
  2301    ;  select  device
  2302   "RTN","RCR JRDEP",33, 0)
  2303    W ! S %ZI S="Q" D ^% ZIS Q:POP
  2304   "RTN","RCR JRDEP",34, 0)
  2305    I $D(IO(" Q")) D  D  ^%ZTLOAD K  IO("Q"),Z TSK Q
  2306   "RTN","RCR JRDEP",35, 0)
  2307    . S ZTDES C="Deposit  Reconcili ation Repo rt",ZTRTN= "DQ^RCRJRD EP"
  2308   "RTN","RCR JRDEP",36, 0)
  2309    . S ZTSAV E("RCRJ*") ="",ZTSAVE ("ZTREQ")= "@"
  2310   "RTN","RCR JRDEP",37, 0)
  2311    W !!,"<*>  please wa it <*>"
  2312   "RTN","RCR JRDEP",38, 0)
  2313    ;
  2314   "RTN","RCR JRDEP",39, 0)
  2315   DQ ;  repo rt (queue)  starts he re
  2316   "RTN","RCR JRDEP",40, 0)
  2317    N %,%H,%I ,CHAMPVA,D A,DEPOSDA, DIQ2,DOCTO TAL,FEE,FM SDOCID,FUN D,FUNDTOTL ,GECSDATA, LINEDA,LIN EDATA,NOW, PAGE,RCDAT A,RCRJLAST ,RCRJLINE, RCRJFLAG,R ECEIPDA,RS C,RSCTOTL, SCREEN,SIT E,TOTAL,X, Y
  2318   "RTN","RCR JRDEP",41, 0)
  2319    K ^TMP($J ,"RCRJRDEP ")
  2320   "RTN","RCR JRDEP",42, 0)
  2321    ;
  2322   "RTN","RCR JRDEP",43, 0)
  2323    ;  build  list of fm s document s
  2324   "RTN","RCR JRDEP",44, 0)
  2325    S SITE=$$ SITE^RCMSI TE
  2326   "RTN","RCR JRDEP",45, 0)
  2327    S RCRJLAS T="CR-"_SI TE_RCRJEND _" "
  2328   "RTN","RCR JRDEP",46, 0)
  2329    ;
  2330   "RTN","RCR JRDEP",47, 0)
  2331    ;  the fm s document  was previ ously stor ed in the  deposit fi le 344.1
  2332   "RTN","RCR JRDEP",48, 0)
  2333    ;  this c ode can be  removed l ater on
  2334   "RTN","RCR JRDEP",49, 0)
  2335    ;  this i s the star ting docum ent, use 3 1 to start  with sele ct doc fir st
  2336   "RTN","RCR JRDEP",50, 0)
  2337    S FMSDOCI D="CR-"_SI TE_RCRJSTR T_$C(31)
  2338   "RTN","RCR JRDEP",51, 0)
  2339    F  S FMSD OCID=$O(^R CY(344.1," ADOC",FMSD OCID)) Q:F MSDOCID="" !(FMSDOCID ]RCRJLAST)   D
  2340   "RTN","RCR JRDEP",52, 0)
  2341    . S DEPOS DA=+$O(^RC Y(344.1,"A DOC",FMSDO CID,0))
  2342   "RTN","RCR JRDEP",53, 0)
  2343    . ;  comp ute deposi t (all rec eipts) tot al for com parison
  2344   "RTN","RCR JRDEP",54, 0)
  2345    . S TOTAL =0,CHAMPVA =0,FEE=0
  2346   "RTN","RCR JRDEP",55, 0)
  2347    . S RECEI PDA=0 F  S  RECEIPDA= $O(^RCY(34 4,"AD",DEP OSDA,RECEI PDA)) Q:'R ECEIPDA  D
  2348   "RTN","RCR JRDEP",56, 0)
  2349    . . S DA= 0 F  S DA= $O(^RCY(34 4,RECEIPDA ,1,DA)) Q: 'DA  S TOT AL=TOTAL+$ P(^(DA,0), "^",5)
  2350   "RTN","RCR JRDEP",57, 0)
  2351    . . S CHA MPVA=CHAMP VA+$$CHAMP VA(RECEIPD A)
  2352   "RTN","RCR JRDEP",58, 0)
  2353    . . S FEE =FEE+$$FEE (RECEIPDA)
  2354   "RTN","RCR JRDEP",59, 0)
  2355    . ;  tmp= deposit ^  depositda  ^ depositd ate ^ ^ ^  ^ depositt otal ^ cha mpvatotal  ^ feetotal
  2356   "RTN","RCR JRDEP",60, 0)
  2357    . S ^TMP( $J,"RCRJRD EP",FMSDOC ID)=$P($G( ^RCY(344.1 ,DEPOSDA,0 )),"^")_"^ "_DEPOSDA_ "^"_$P($G( ^RCY(344.1 ,DEPOSDA,0 )),"^",9)_ "^^^^"_TOT AL_"^"_CHA MPVA_"^"_F EE
  2358   "RTN","RCR JRDEP",61, 0)
  2359    ;
  2360   "RTN","RCR JRDEP",62, 0)
  2361    ;  the fm s document  is now st ored in th e receipt  file 344
  2362   "RTN","RCR JRDEP",63, 0)
  2363    S FMSDOCI D="CR-"_SI TE_RCRJSTR T_$C(31)
  2364   "RTN","RCR JRDEP",64, 0)
  2365    F  S FMSD OCID=$O(^R CY(344,"AD OC",FMSDOC ID)) Q:FMS DOCID=""!( FMSDOCID]R CRJLAST)   D
  2366   "RTN","RCR JRDEP",65, 0)
  2367    . S RECEI PDA=+$O(^R CY(344,"AD OC",FMSDOC ID,0))
  2368   "RTN","RCR JRDEP",66, 0)
  2369    . ;  comp ute deposi t (all rec eipts) tot al for com parison
  2370   "RTN","RCR JRDEP",67, 0)
  2371    . S TOTAL =0
  2372   "RTN","RCR JRDEP",68, 0)
  2373    . ;  use  the paymen t amount t o pick up  suspense d eposits
  2374   "RTN","RCR JRDEP",69, 0)
  2375    . S DA=0  F  S DA=$O (^RCY(344, RECEIPDA,1 ,DA)) Q:'D A  S TOTAL =TOTAL+$P( ^(DA,0),"^ ",4)
  2376   "RTN","RCR JRDEP",70, 0)
  2377    . S CHAMP VA=$$CHAMP VA(RECEIPD A)
  2378   "RTN","RCR JRDEP",71, 0)
  2379    . S FEE=$ $FEE(RECEI PDA)
  2380   "RTN","RCR JRDEP",72, 0)
  2381    . S DEPOS DA=+$P($G( ^RCY(344,R ECEIPDA,0) ),"^",6)
  2382   "RTN","RCR JRDEP",73, 0)
  2383    . ;  tmp= deposit ^  depositda  ^ depositd ate ^ rece ipt ^recei ptda ^ rec eipt date  ^ receiptt otal ^ cha mpvatotal  ^ feetotal
  2384   "RTN","RCR JRDEP",74, 0)
  2385    . S ^TMP( $J,"RCRJRD EP",FMSDOC ID)=$P($G( ^RCY(344.1 ,DEPOSDA,0 )),"^")_"^ "_DEPOSDA_ "^"_$P($G( ^RCY(344.1 ,DEPOSDA,0 )),"^",11) _"^"_$P($G (^RCY(344, RECEIPDA,0 )),"^")_"^ "_RECEIPDA _"^"_$P($G (^RCY(344, RECEIPDA,0 )),"^",8)_ "^"_TOTAL_ "^"_CHAMPV A_"^"_FEE
  2386   "RTN","RCR JRDEP",75, 0)
  2387    ;
  2388   "RTN","RCR JRDEP",76, 0)
  2389    ;  print  report
  2390   "RTN","RCR JRDEP",77, 0)
  2391    S SCREEN= 0 I '$D(ZT QUEUED),IO =IO(0),$E( IOST)="C"  S SCREEN=1
  2392   "RTN","RCR JRDEP",78, 0)
  2393    S RCRJLIN E="",$P(RC RJLINE,"-" ,81)=""
  2394   "RTN","RCR JRDEP",79, 0)
  2395    D NOW^%DT C S Y=% D  DD^%DT S N OW=Y,PAGE= 1
  2396   "RTN","RCR JRDEP",80, 0)
  2397    U IO I $G (RCRJSUMM) '=1 D H
  2398   "RTN","RCR JRDEP",81, 0)
  2399    ;
  2400   "RTN","RCR JRDEP",82, 0)
  2401    S FMSDOCI D="" F  S  FMSDOCID=$ O(^TMP($J, "RCRJRDEP" ,FMSDOCID) ) Q:FMSDOC ID=""!($G( RCRJFLAG))   D
  2402   "RTN","RCR JRDEP",83, 0)
  2403    . S RCDAT A=^TMP($J, "RCRJRDEP" ,FMSDOCID)
  2404   "RTN","RCR JRDEP",84, 0)
  2405    . K GECSD ATA
  2406   "RTN","RCR JRDEP",85, 0)
  2407    . D DATA^ GECSSGET(F MSDOCID,1)
  2408   "RTN","RCR JRDEP",86, 0)
  2409    . I $G(RC RJSUMM)'=1  D  Q:$G(R CRJFLAG)
  2410   "RTN","RCR JRDEP",87, 0)
  2411    . . I $Y> (IOSL-7) D :SCREEN PA USE^RCRJRT R1 Q:$G(RC RJFLAG)  D  H
  2412   "RTN","RCR JRDEP",88, 0)
  2413    . . S Y=$ P($P(RCDAT A,"^",3)," .") I Y D  DD^%DT
  2414   "RTN","RCR JRDEP",89, 0)
  2415    . . W !," FMS DOCUME NT: ",FMSD OCID,?34," DEPOSIT TI CKET: ",$P (RCDATA,"^ "),?62,"DA TE: ",Y
  2416   "RTN","RCR JRDEP",90, 0)
  2417    . . I $P( RCDATA,"^" ,4)'="" W  !?41,"RECE IPT: ",$P( RCDATA,"^" ,4) S Y=$P ($P(RCDATA ,"^",6),". ") I Y D D D^%DT W ?6 2,"DATE: " ,Y
  2418   "RTN","RCR JRDEP",91, 0)
  2419    . . D H1
  2420   "RTN","RCR JRDEP",92, 0)
  2421    . S DOCTO TAL=0
  2422   "RTN","RCR JRDEP",93, 0)
  2423    . I $D(GE CSDATA) S  LINEDA=0 F   S LINEDA =$O(GECSDA TA(2100.1, GECSDATA,1 0,LINEDA))  Q:'LINEDA !($G(RCRJF LAG))  D
  2424   "RTN","RCR JRDEP",94, 0)
  2425    . . S LIN EDATA=GECS DATA(2100. 1,GECSDATA ,10,LINEDA )
  2426   "RTN","RCR JRDEP",95, 0)
  2427    . . I $E( LINEDATA,1 ,4)="CR2^"  S DOCTOTA L=$P(LINED ATA,"^",15 )
  2428   "RTN","RCR JRDEP",96, 0)
  2429    . . I $E( LINEDATA,1 ,9)'="LIN^ ~CRA^" Q
  2430   "RTN","RCR JRDEP",97, 0)
  2431    . . I $G( RCRJSUMM)' =1 D
  2432   "RTN","RCR JRDEP",98, 0)
  2433    . . . I $ Y>(IOSL-4)  D:SCREEN  PAUSE^RCRJ RTR1 Q:$G( RCRJFLAG)   D H,H1
  2434   "RTN","RCR JRDEP",99, 0)
  2435    . . . W ! ?1,$P(LINE DATA,"^",3 ),?6,$P(LI NEDATA,"^" ,4),?11,$P (LINEDATA, "^",6),?19 ,$P(LINEDA TA,"^",10)
  2436   "RTN","RCR JRDEP",100 ,0)
  2437    . . . W ? 30,$J($P(L INEDATA,"^ ",18),8),? 40,$E($P(L INEDATA,"^ ",25),4,10 ),?50,$J($ P(LINEDATA ,"^",20),1 0,2),?64,$ J($P(LINED ATA,"^",23 ),9)
  2438   "RTN","RCR JRDEP",101 ,0)
  2439    . . ;  to tals by fu nd
  2440   "RTN","RCR JRDEP",102 ,0)
  2441    . . S FUN D=$P(LINED ATA,"^",6)
  2442   "RTN","RCR JRDEP",103 ,0)
  2443    . . I FUN D="" S FUN D="0160"
  2444   "RTN","RCR JRDEP",104 ,0)
  2445    . . S FUN DTOTL(FUND )=$G(FUNDT OTL(FUND)) +$P(LINEDA TA,"^",20)
  2446   "RTN","RCR JRDEP",105 ,0)
  2447    . . ;  to tals by rs c for the  accrued 52 87 funds ( 01,03,04,0 9,11)
  2448   "RTN","RCR JRDEP",106 ,0)
  2449    . . S RSC =$P(LINEDA TA,"^",10)
  2450   "RTN","RCR JRDEP",107 ,0)
  2451    . . I RSC '="",($$PT ACCT^PRCAA CC(FUND)!( FUND=4032) ) S RSCTOT L(RSC)=$G( RSCTOTL(RS C))+$P(LIN EDATA,"^", 20)
  2452   "RTN","RCR JRDEP",108 ,0)
  2453    . I $G(RC RJSUMM)=1  Q
  2454   "RTN","RCR JRDEP",109 ,0)
  2455    . I $G(RC RJFLAG) Q
  2456   "RTN","RCR JRDEP",110 ,0)
  2457    . I $Y>(I OSL-6) D:S CREEN PAUS E^RCRJRTR1  Q:$G(RCRJ FLAG)  D H
  2458   "RTN","RCR JRDEP",111 ,0)
  2459    . W !?23, "LINE TOTA L/DOCUMENT  TOTAL: ", $J(DOCTOTA L,10,2)
  2460   "RTN","RCR JRDEP",112 ,0)
  2461    . ;  comp ute receip t total fo r comparis on
  2462   "RTN","RCR JRDEP",113 ,0)
  2463    . S TOTAL =$P(RCDATA ,"^",7)
  2464   "RTN","RCR JRDEP",114 ,0)
  2465    . S CHAMP VA=$P(RCDA TA,"^",8)
  2466   "RTN","RCR JRDEP",115 ,0)
  2467    . S FEE=$ P(RCDATA," ^",9)
  2468   "RTN","RCR JRDEP",116 ,0)
  2469    . I CHAMP VA W !?35, "CHAMPVA T OTAL: ",$J (CHAMPVA,1 0,2)
  2470   "RTN","RCR JRDEP",117 ,0)
  2471    . I FEE W  !?35,"NON -VA  TOTAL : ",$J(FEE ,10,2)
  2472   "RTN","RCR JRDEP",118 ,0)
  2473    . W !?35, "DEPOSIT T OTAL: ",$J (TOTAL,10, 2)
  2474   "RTN","RCR JRDEP",119 ,0)
  2475    . I (DOCT OTAL+CHAMP VA+FEE)'=T OTAL W !,"  WARNING:  TOTALS DO  NOT MATCH,  CHECK THE  DEPOSIT:  ********** "
  2476   "RTN","RCR JRDEP",120 ,0)
  2477    . W !
  2478   "RTN","RCR JRDEP",121 ,0)
  2479    ;
  2480   "RTN","RCR JRDEP",122 ,0)
  2481    I $G(RCRJ FLAG) D Q  Q
  2482   "RTN","RCR JRDEP",123 ,0)
  2483    I $G(RCRJ SUMM)'=1 D :SCREEN PA USE^RCRJRT R1 I $G(RC RJFLAG) D  Q Q
  2484   "RTN","RCR JRDEP",124 ,0)
  2485    D H
  2486   "RTN","RCR JRDEP",125 ,0)
  2487    ;  print  totals by  fund/rsc
  2488   "RTN","RCR JRDEP",126 ,0)
  2489    W !!,"TOT AL DEPOSIT S BY FUND: "
  2490   "RTN","RCR JRDEP",127 ,0)
  2491    S FUND=""  F  S FUND =$O(FUNDTO TL(FUND))  Q:FUND=""! ($G(RCRJFL AG))  D
  2492   "RTN","RCR JRDEP",128 ,0)
  2493    .  I $Y>( IOSL-4) D: SCREEN PAU SE^RCRJRTR 1 Q:$G(RCR JFLAG)  D  H W !!,"TO TAL DEPOSI TS BY FUND :"
  2494   "RTN","RCR JRDEP",129 ,0)
  2495    .  W !?5, "FUND: ",F UND,?20,$J (FUNDTOTL( FUND),10,2 )
  2496   "RTN","RCR JRDEP",130 ,0)
  2497    I $G(RCRJ FLAG) D Q  Q
  2498   "RTN","RCR JRDEP",131 ,0)
  2499    I DT<$$AD DPTEDT^PRC AACC() W ! !,"TOTAL D EPOSITS BY  REVENUE S OURCE CODE  FOR THE S ERIES OF F UNDS 5287. 1,5287.3,5 287.4:"
  2500   "RTN","RCR JRDEP",132 ,0)
  2501    I DT'<$$A DDPTEDT^PR CAACC() W  !!,"TOTAL  DEPOSITS B Y REVENUE  SOURCE COD E FOR THE  SERIES OF  FUNDS 5287 01,528703, 528704,528 711:"
  2502   "RTN","RCR JRDEP",133 ,0)
  2503    S RSC=""  F  S RSC=$ O(RSCTOTL( RSC)) Q:RS C=""  D  Q :$G(RCRJFL AG)
  2504   "RTN","RCR JRDEP",134 ,0)
  2505    . I $Y>(I OSL-4) D:S CREEN PAUS E^RCRJRTR1  Q:$G(RCRJ FLAG)  D H  W !!,"TOT AL DEPOSIT S BY REVEN UE SOURCE  CODE FOR T HE SERIES  OF ACCRUED  5287 FUND S "_$S(DT< $$ADDPTEDT ^PRCAACC() :"(.1,.3,. 4,.9):",1: "(01,03,04 ,09,11):")
  2506   "RTN","RCR JRDEP",135 ,0)
  2507    . W !?5," RSC: ",RSC ,?17,$$GET DESC^RCXFM SPR(RSC),? 70,$J(RSCT OTL(RSC),1 0,2)
  2508   "RTN","RCR JRDEP",136 ,0)
  2509    I $G(RCRJ FLAG) D Q  Q
  2510   "RTN","RCR JRDEP",137 ,0)
  2511    I SCREEN  R !,"Press  RETURN to  continue: ",X:DTIME
  2512   "RTN","RCR JRDEP",138 ,0)
  2513    ;
  2514   "RTN","RCR JRDEP",139 ,0)
  2515   Q D ^%ZISC
  2516   "RTN","RCR JRDEP",140 ,0)
  2517    K ^TMP($J ,"RCRJRDEP ")
  2518   "RTN","RCR JRDEP",141 ,0)
  2519    Q
  2520   "RTN","RCR JRDEP",142 ,0)
  2521    ;
  2522   "RTN","RCR JRDEP",143 ,0)
  2523    ;
  2524   "RTN","RCR JRDEP",144 ,0)
  2525   H ;  repor t heading
  2526   "RTN","RCR JRDEP",145 ,0)
  2527    I PAGE'=1 !(SCREEN)  W @IOF
  2528   "RTN","RCR JRDEP",146 ,0)
  2529    S %=NOW_"   PAGE "_P AGE,PAGE=P AGE+1
  2530   "RTN","RCR JRDEP",147 ,0)
  2531    W $C(13), "DEPOSIT R ECONCILIAT ION REPORT ",?(80-$L( %)),%
  2532   "RTN","RCR JRDEP",148 ,0)
  2533    W !,"  ST ART WITH D EPOSIT: ", $S(RCRJSTR T="":"**FI RST**",1:R CRJSTRT),"   END WITH  DEPOSIT:  ",$S(RCRJE ND="zzzzzz z":"**LAST **",1:RCRJ END),?65,$ J("TYPE: " _$S(RCRJSU MM=1:"SUMM ARY",1:"DE TAILED"),1 5)
  2534   "RTN","RCR JRDEP",149 ,0)
  2535    W !,RCRJL INE
  2536   "RTN","RCR JRDEP",150 ,0)
  2537    Q
  2538   "RTN","RCR JRDEP",151 ,0)
  2539    ;
  2540   "RTN","RCR JRDEP",152 ,0)
  2541    ;
  2542   "RTN","RCR JRDEP",153 ,0)
  2543   H1 ;  prin t line hea ding
  2544   "RTN","RCR JRDEP",154 ,0)
  2545    W !,"LINE ",?5,"BFY" ,?11,"FUND ",?20,"RSC ",?30,"PRO VIDER",?43 ,"BILL",?5 4,"AMOUNT" ,?64,"TRAN  TYPE"
  2546   "RTN","RCR JRDEP",155 ,0)
  2547    Q
  2548   "RTN","RCR JRDEP",156 ,0)
  2549    ;
  2550   "RTN","RCR JRDEP",157 ,0)
  2551    ;
  2552   "RTN","RCR JRDEP",158 ,0)
  2553   CHAMPVA(RE CEIPDA) ;   return do llars for  champva
  2554   "RTN","RCR JRDEP",159 ,0)
  2555    N %,CATEG ORY,RECEIP T,TOTAL,TR AN3,TRANDA
  2556   "RTN","RCR JRDEP",160 ,0)
  2557    S RECEIPT =$P($G(^RC Y(344,RECE IPDA,0))," ^")
  2558   "RTN","RCR JRDEP",161 ,0)
  2559    I RECEIPT ="" Q 0
  2560   "RTN","RCR JRDEP",162 ,0)
  2561    ;
  2562   "RTN","RCR JRDEP",163 ,0)
  2563    S TOTAL=0
  2564   "RTN","RCR JRDEP",164 ,0)
  2565    S TRANDA= 0 F  S TRA NDA=$O(^PR CA(433,"AF ",RECEIPT, TRANDA)) Q :'TRANDA   D
  2566   "RTN","RCR JRDEP",165 ,0)
  2567    . S CATEG ORY=$P($G( ^PRCA(430, +$P($G(^PR CA(433,TRA NDA,0)),"^ ",2),0))," ^",2)
  2568   "RTN","RCR JRDEP",166 ,0)
  2569    . I CATEG ORY'=29 Q
  2570   "RTN","RCR JRDEP",167 ,0)
  2571    . S TRAN3 =$G(^PRCA( 433,TRANDA ,3))
  2572   "RTN","RCR JRDEP",168 ,0)
  2573    . F %=1:1 :5 S TOTAL =TOTAL+$P( TRAN3,"^", %)
  2574   "RTN","RCR JRDEP",169 ,0)
  2575    Q TOTAL
  2576   "RTN","RCR JRDEP",170 ,0)
  2577    ;
  2578   "RTN","RCR JRDEP",171 ,0)
  2579    ;
  2580   "RTN","RCR JRDEP",172 ,0)
  2581   FEE(RECEIP DA) ;  ret urn dollar s for Fee  Basis PRCA *4.5*310/D RF 12/9/20 15
  2582   "RTN","RCR JRDEP",173 ,0)
  2583    N %,CATEG ORY,RECEIP T,TOTAL,TR AN3,TRANDA
  2584   "RTN","RCR JRDEP",174 ,0)
  2585    S RECEIPT =$P($G(^RC Y(344,RECE IPDA,0))," ^")
  2586   "RTN","RCR JRDEP",175 ,0)
  2587    I RECEIPT ="" Q 0
  2588   "RTN","RCR JRDEP",176 ,0)
  2589    S TOTAL=0
  2590   "RTN","RCR JRDEP",177 ,0)
  2591    S TRANDA= 0 F  S TRA NDA=$O(^PR CA(433,"AF ",RECEIPT, TRANDA)) Q :'TRANDA   D
  2592   "RTN","RCR JRDEP",178 ,0)
  2593    . S CATEG ORY=$P($G( ^PRCA(430, +$P($G(^PR CA(433,TRA NDA,0)),"^ ",2),0))," ^",2)
  2594   "RTN","RCR JRDEP",179 ,0)
  2595    . I CATEG ORY'=45 Q
  2596   "RTN","RCR JRDEP",180 ,0)
  2597    . S TRAN3 =$G(^PRCA( 433,TRANDA ,3))
  2598   "RTN","RCR JRDEP",181 ,0)
  2599    . F %=1:1 :5 S TOTAL =TOTAL+$P( TRAN3,"^", %)
  2600   "RTN","RCR JRDEP",182 ,0)
  2601    Q TOTAL
  2602   "RTN","RCT RAN1")
  2603   0^7^B81977 52^B735470 1
  2604   "RTN","RCT RAN1",1,0)
  2605   RCTRAN1 ;W ASH-ISC@AL TOONA,PA/L DB-Transac tion Histo ry Report  ;11/14/94   5:25 PM
  2606   "RTN","RCT RAN1",2,0)
  2607    ;;4.5;Acc ounts Rece ivable;**1 04,310**;M ar 20, 199 5;Build 14
  2608   "RTN","RCT RAN1",3,0)
  2609    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  2610   "RTN","RCT RAN1",4,0)
  2611    ;
  2612   "RTN","RCT RAN1",5,0)
  2613    ;Subrouti nes Called  by RCTRAN
  2614   "RTN","RCT RAN1",6,0)
  2615    ;
  2616   "RTN","RCT RAN1",7,0)
  2617   TRANS ;Fin d transact ions of se lected typ e for sele cted date  range
  2618   "RTN","RCT RAN1",8,0)
  2619    S CAT("X" )=CAT D DT ^DICRW
  2620   "RTN","RCT RAN1",9,0)
  2621    S BDATE(1 )=BDATE,BD ATE=(BDATE -1)+.99999 9999
  2622   "RTN","RCT RAN1",10,0 )
  2623    S EDATE(1 )=EDATE,ED ATE=$S('ED ATE:999999 9,1:EDATE+ .99999999)
  2624   "RTN","RCT RAN1",11,0 )
  2625    S RCX=0 F   S RCX=$O (^PRCA(433 ,RCX)) Q:' RCX  I $D( ^PRCA(433, RCX,0)),+$ G(^(1)) D
  2626   "RTN","RCT RAN1",12,0 )
  2627    .S NODE0= ^(0),NODE1 =^(1),NODE 2=$G(^(2)) ,NODE3=$G( ^(3))
  2628   "RTN","RCT RAN1",13,0 )
  2629    .S TDAT=$ S($P(NODE1 ,"^",9):$P (NODE1,"^" ,9),1:+NOD E1)
  2630   "RTN","RCT RAN1",14,0 )
  2631    .S BILL=$ P(NODE0,"^ ",2) Q:'BI LL
  2632   "RTN","RCT RAN1",15,0 )
  2633    .S CAT=$P ($G(^PRCA( 430,+BILL, 0)),"^",2)  Q:'CAT
  2634   "RTN","RCT RAN1",16,0 )
  2635    .I ($D(TY P(+$P(NODE 1,"^",2))) !'TYP),($D (CAT(+CAT) )!'CAT("X" )),TDAT>BD ATE,TDAT<E DATE D
  2636   "RTN","RCT RAN1",17,0 )
  2637    ..S APP=$ P($G(^PRCA (430,+BILL ,11)),"^", 17)
  2638   "RTN","RCT RAN1",18,0 )
  2639    ..I APP=" ",",5,4,3, 18,25,"[(" ,"_CAT_"," ) S APP="2 431"
  2640   "RTN","RCT RAN1",19,0 )
  2641    ..I APP=" ",",9,6,7, 8,21,22,23 ,26,45,"[( ","_CAT_", ") S APP=" 5014"  ;PR CA*4.5*310 /DRF added  category  47 for FEE  REIMB INS
  2642   "RTN","RCT RAN1",20,0 )
  2643    ..I APP=" ",",14,12, 19,20,1,10 ,2,"[(","_ CAT_",") S  APP="0160 "
  2644   "RTN","RCT RAN1",21,0 )
  2645    ..I CAT=2 6 S APP="5 014"
  2646   "RTN","RCT RAN1",22,0 )
  2647    ..I APP=" " S APP="N O FUND W/B ILL"
  2648   "RTN","RCT RAN1",23,0 )
  2649    ..S BILL= $P($G(^PRC A(430,+BIL L,0)),"^")
  2650   "RTN","RCT RAN1",24,0 )
  2651    ..I ",12, 13,14,"[(" ,"_TYP_"," ) D  Q
  2652   "RTN","RCT RAN1",25,0 )
  2653    ...F I=5: 1:8 S AMT= $P(NODE2," ^",I) I AM T S APP=$S (I=8:1435, I=7:3220,1 :"0869") D  SET
  2654   "RTN","RCT RAN1",26,0 )
  2655    ..I ",2,3 4,"[(","_T YP_",") D   Q
  2656   "RTN","RCT RAN1",27,0 )
  2657    ...F I=1: 1:5 I $P(N ODE3,"^",I ) S AMT=+$ P(NODE3,"^ ",I),APP=$ S(I=1:APP, I=2:1435,I =3:3220,1: "0869") D  SET
  2658   "RTN","RCT RAN1",28,0 )
  2659    ..S AMT=+ $P(NODE1," ^",5)
  2660   "RTN","RCT RAN1",29,0 )
  2661    ..D SET
  2662   "RTN","RCT RAN1",30,0 )
  2663    Q
  2664   "RTN","RCT RAN1",31,0 )
  2665    ;
  2666   "RTN","RCT RAN1",32,0 )
  2667   SET S ^TMP ($J,+$P(NO DE1,"^",2) ,+CAT,APP, TDAT,RCX)= AMT_"^"_BI LL_"^"_$P( NODE0,"^", 9)
  2668   "RTN","RCT RAN1",33,0 )
  2669    Q
  2670   "RTN","RCT RAN1",34,0 )
  2671    ;
  2672   "RTN","RCT RAN1",35,0 )
  2673   SUB ;Sub-t otal categ ories
  2674   "RTN","RCT RAN1",36,0 )
  2675    I RCX'=45  S:AMT(X11 )<0 AMT(X1 1)=-AMT(X1 1) W !?64, "--------- --",!?64,$ J(AMT(X11) ,11,2),!
  2676   "RTN","RCT RAN1",37,0 )
  2677    Q
  2678   "RTN","RCT RAN1",38,0 )
  2679    ;
  2680   "RTN","RCT RAN1",39,0 )
  2681   KEY ;Key t o category  abbreviat ions
  2682   "RTN","RCT RAN1",40,0 )
  2683    W !!?30," CATEGORY A BBREVIATIO NS",!!
  2684   "RTN","RCT RAN1",41,0 )
  2685    W !,"C  -   C (MEANS  TEST), CE  - CURRENT  EMPLOYEE,  CP - CRIM E OF PER.  VIO."
  2686   "RTN","RCT RAN1",42,0 )
  2687    W !,"E  -   EX-EMPLO YEE"
  2688   "RTN","RCT RAN1",43,0 )
  2689    W !,"F1 -   FEDERAL  AGENGIES-R EIMB., F2  - FEDERAL  AGENCIES-R EFUND"
  2690   "RTN","RCT RAN1",44,0 )
  2691    W !,"FR -   FEE BASI S REIMBURS ABLE HEALT H INSURANC E"  ;PRCA* 4.5*310/DR F - Added  FEE REIMB  INS
  2692   "RTN","RCT RAN1",45,0 )
  2693    W !,"H  -   EMERGENC Y HUMANITA RIAN"
  2694   "RTN","RCT RAN1",46,0 )
  2695    W !,"I  -   INELIGIB LE HOSP.,  IA - INTER AGENCY, M  - MILITARY , MC - MED ICARN"
  2696   "RTN","RCT RAN1",47,0 )
  2697    W !,"NA -   NO-FAULT  AUTO ACC. "
  2698   "RTN","RCT RAN1",48,0 )
  2699    W !,"PN -   RX CO-PA Y NSC, PS  - RX CO-PA Y SC, PP -  PREPAY"
  2700   "RTN","RCT RAN1",49,0 )
  2701    W !,"RI -   REIMBURS IBLE HEALT H INSURANC E"
  2702   "RTN","RCT RAN1",50,0 )
  2703    W !,"SA -   SHARING  AGREEMENTS , TF - TOR T FEASOR,  V - VENDOR , WC - WOR KMAN'S COM P."
  2704   "RTN","RCT RAN1",51,0 )
  2705    Q
  2706   "RTN","RCT RAN1",52,0 )
  2707   HDR ;;Head ing
  2708   "RTN","RCT RAN1",53,0 )
  2709    S PG=PG+1
  2710   "RTN","RCT RAN1",54,0 )
  2711    W !?30,"H ISTORY OF  TRANSACTIO NS",?70,"P AGE ",?75, PG
  2712   "RTN","RCT RAN1",55,0 )
  2713    W !,LINE
  2714   "RTN","RCT RAN1",56,0 )
  2715    W !,"Date ",?12,"Tra ns.",?37," Cat",?44," Bill#",?57 ,"Trans#", ?66,"Amoun t",?75,"BY "
  2716   "RTN","RCT RAN1",57,0 )
  2717    W !,LINE
  2718   "RTN","RCT RAN1",58,0 )
  2719    S LN=0
  2720   "RTN","RCT RAN1",59,0 )
  2721    Q
  2722   "RTN","RCX FMSPR")
  2723   0^1^B27613 579^B25382 600
  2724   "RTN","RCX FMSPR",1,0 )
  2725   RCXFMSPR ; WISC/RFJ-p rint reven ue source  codes ;8/3 1/10 11:34 am
  2726   "RTN","RCX FMSPR",2,0 )
  2727    ;;4.5;Acc ounts Rece ivable;**9 0,96,101,1 56,170,203 ,273,310** ;Mar 20, 1 995;Build  14
  2728   "RTN","RCX FMSPR",3,0 )
  2729    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  2730   "RTN","RCX FMSPR",4,0 )
  2731    W !,"This  option wi ll print o ut a list  of the rev enue sourc e codes se nt from"
  2732   "RTN","RCX FMSPR",5,0 )
  2733    W !,"the  VISTA syst em to FMS. "
  2734   "RTN","RCX FMSPR",6,0 )
  2735    ;
  2736   "RTN","RCX FMSPR",7,0 )
  2737    ;  select  device
  2738   "RTN","RCX FMSPR",8,0 )
  2739    W ! S %ZI S="Q" D ^% ZIS Q:POP
  2740   "RTN","RCX FMSPR",9,0 )
  2741    I $D(IO(" Q")) D  D  ^%ZTLOAD K  IO("Q"),Z TSK Q
  2742   "RTN","RCX FMSPR",10, 0)
  2743    .   S ZTD ESC="Reven ue Source  Code Repor t",ZTRTN=" DQ^RCXFMSP R"
  2744   "RTN","RCX FMSPR",11, 0)
  2745    .   S ZTS AVE("ZTREQ ")="@"
  2746   "RTN","RCX FMSPR",12, 0)
  2747    W !!,"<*>  please wa it <*>"
  2748   "RTN","RCX FMSPR",13, 0)
  2749    ;
  2750   "RTN","RCX FMSPR",14, 0)
  2751   DQ ;  queu e starts h ere
  2752   "RTN","RCX FMSPR",15, 0)
  2753    N %,%I,BI NARY,COL2D ESC,COL3DE SC,COLUMN1 ,COLUMN2,C OLUMN3,COL UMN4
  2754   "RTN","RCX FMSPR",16, 0)
  2755    N DECIMAL ,DESCRIP,N OW,PAGE,RC STFLAG,SCR EEN,X,Y
  2756   "RTN","RCX FMSPR",17, 0)
  2757    D NOW^%DT C S Y=% D  DD^%DT S N OW=Y
  2758   "RTN","RCX FMSPR",18, 0)
  2759    S PAGE=1, SCREEN=0 I  '$D(ZTQUE UED),IO=IO (0),$E(IOS T)="C" S S CREEN=1
  2760   "RTN","RCX FMSPR",19, 0)
  2761    U IO D H
  2762   "RTN","RCX FMSPR",20, 0)
  2763    ;
  2764   "RTN","RCX FMSPR",21, 0)
  2765    S COLUMN1 ="A",COLUM N2="R",COL UMN3="R",C OLUMN4="V" ,DESCRIP=" Miscellane ous"
  2766   "RTN","RCX FMSPR",22, 0)
  2767    D WRITEIT
  2768   "RTN","RCX FMSPR",23, 0)
  2769    ;
  2770   "RTN","RCX FMSPR",24, 0)
  2771    ;  for no w, column  1 is alway s 8 and co lumn 4 is  always Z
  2772   "RTN","RCX FMSPR",25, 0)
  2773    S COLUMN1 =8,COLUMN4 ="Z"
  2774   "RTN","RCX FMSPR",26, 0)
  2775    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)
  2776   "RTN","RCX FMSPR",27, 0)
  2777    .   S COL 2DESC=$P($ T(@("A"_CO LUMN2)),"; ",3)
  2778   "RTN","RCX FMSPR",28, 0)
  2779    .   ;
  2780   "RTN","RCX FMSPR",29, 0)
  2781    .   S COL UMN3=$S(CO LUMN2=5:"* ",1:"Z")
  2782   "RTN","RCX FMSPR",30, 0)
  2783    .   S DES CRIP=COL2D ESC D WRIT EIT
  2784   "RTN","RCX FMSPR",31, 0)
  2785    .   ;
  2786   "RTN","RCX FMSPR",32, 0)
  2787    .   I $G( RCSTFLAG)  Q
  2788   "RTN","RCX FMSPR",33, 0)
  2789    .   ;
  2790   "RTN","RCX FMSPR",34, 0)
  2791    .   ;  sh ow hsif -  disabled b y patch 20 3
  2792   "RTN","RCX FMSPR",35, 0)
  2793    .   ;I CO LUMN2="B"! (COLUMN2=" C") S DESC RIP=DESCRI P_" HSIF", COLUMN3=1  D WRITEIT
  2794   "RTN","RCX FMSPR",36, 0)
  2795    ;
  2796   "RTN","RCX FMSPR",37, 0)
  2797    I $G(RCST FLAG) D Q  Q
  2798   "RTN","RCX FMSPR",38, 0)
  2799    ;
  2800   "RTN","RCX FMSPR",39, 0)
  2801    ;  print  reimbursab le health  insurance  rsc's
  2802   "RTN","RCX FMSPR",40, 0)
  2803    S COLUMN2 =5
  2804   "RTN","RCX FMSPR",41, 0)
  2805    W !!?6,"F or REIMBUR SABLE HEAL TH INSURAN CE [85*Z]: "
  2806   "RTN","RCX FMSPR",42, 0)
  2807    F DECIMAL =0:1:31 D   Q:$G(RCST FLAG)
  2808   "RTN","RCX FMSPR",43, 0)
  2809    .   I DEC IMAL<10 S  COLUMN3=DE CIMAL
  2810   "RTN","RCX FMSPR",44, 0)
  2811    .   E  S  COLUMN3=$C (65+DECIMA L-10)
  2812   "RTN","RCX FMSPR",45, 0)
  2813    .   ;
  2814   "RTN","RCX FMSPR",46, 0)
  2815    .   ;  co nvert deci mal to bin ary (ex: 1 0011) so i t can be
  2816   "RTN","RCX FMSPR",47, 0)
  2817    .   ;  pa rsed in rs c to get t he descrip tion
  2818   "RTN","RCX FMSPR",48, 0)
  2819    .   S BIN ARY=$$CONV ERT(DECIMA L)
  2820   "RTN","RCX FMSPR",49, 0)
  2821    .   S COL 3DESC=$P($ T(@("B"_$E (BINARY,1, 2))),";",3 )
  2822   "RTN","RCX FMSPR",50, 0)
  2823    .   S COL 3DESC=COL3 DESC_", "_ $P($T(@("C "_$E(BINAR Y,3))),";" ,3)
  2824   "RTN","RCX FMSPR",51, 0)
  2825    .   S COL 3DESC=COL3 DESC_", "_ $P($T(@("D "_$E(BINAR Y,4))),";" ,3)
  2826   "RTN","RCX FMSPR",52, 0)
  2827    .   S COL 3DESC=COL3 DESC_", "_ $P($T(@("E "_$E(BINAR Y,5))),";" ,3)
  2828   "RTN","RCX FMSPR",53, 0)
  2829    .   S DES CRIP=COL3D ESC
  2830   "RTN","RCX FMSPR",54, 0)
  2831    .   D WRI TEIT
  2832   "RTN","RCX FMSPR",55, 0)
  2833    ;
  2834   "RTN","RCX FMSPR",56, 0)
  2835    ;  print  fee basis  reimbursab le health  insurance  rsc's (PRC A*4.5*310/ DRF)
  2836   "RTN","RCX FMSPR",57, 0)
  2837    S COLUMN2 ="F"
  2838   "RTN","RCX FMSPR",58, 0)
  2839    W !!?6,"F or FEE REI MBURSABLE  HEALTH INS URANCE [8F *Z]:"
  2840   "RTN","RCX FMSPR",59, 0)
  2841    F DECIMAL =1:1:2 D   Q:$G(RCSTF LAG)
  2842   "RTN","RCX FMSPR",60, 0)
  2843    .   S DES CRIP="FEE  BASIS, NSC  VET, MT C AT A, "_$S (DECIMAL=1 :"INPATIEN T",DECIMAL =2:"OUTPAT IENT",1:"" )
  2844   "RTN","RCX FMSPR",61, 0)
  2845    .   S COL UMN3=DECIM AL
  2846   "RTN","RCX FMSPR",62, 0)
  2847    .   D WRI TEIT
  2848   "RTN","RCX FMSPR",63, 0)
  2849   Q D ^%ZISC
  2850   "RTN","RCX FMSPR",64, 0)
  2851    Q
  2852   "RTN","RCX FMSPR",65, 0)
  2853    ;
  2854   "RTN","RCX FMSPR",66, 0)
  2855    ;
  2856   "RTN","RCX FMSPR",67, 0)
  2857   GETDESC(RS C) ;  retu rn the des cription f or the rev enue sourc e code
  2858   "RTN","RCX FMSPR",68, 0)
  2859    N BINARY, COL3DESC,C OLUMN2,COL UMN3,DESC
  2860   "RTN","RCX FMSPR",69, 0)
  2861    I RSC="AR RV" Q "Mis cellaneous "
  2862   "RTN","RCX FMSPR",70, 0)
  2863    I RSC=804 6 Q "Admin istrative"
  2864   "RTN","RCX FMSPR",71, 0)
  2865    I RSC=804 7 Q "Inter est"
  2866   "RTN","RCX FMSPR",72, 0)
  2867    I RSC=804 8 Q "Marsh al Fee and  Court Cos t"
  2868   "RTN","RCX FMSPR",73, 0)
  2869    S DESC="U NKNOWN"
  2870   "RTN","RCX FMSPR",74, 0)
  2871    S COLUMN2 =$E(RSC,2)
  2872   "RTN","RCX FMSPR",75, 0)
  2873    I "123456 789ABCDEFG HIJKLMQRST "[COLUMN2  S DESC=$P( $T(@("A"_C OLUMN2))," ;",3)
  2874   "RTN","RCX FMSPR",76, 0)
  2875    ; HSIF re ference di sabled by  patch 203
  2876   "RTN","RCX FMSPR",77, 0)
  2877    ; I RSC=" 8B1Z"!(RSC ="8C1Z") S  DESC=DESC _" (HSIF)"
  2878   "RTN","RCX FMSPR",78, 0)
  2879    I COLUMN2 '=5 Q DESC
  2880   "RTN","RCX FMSPR",79, 0)
  2881    ;
  2882   "RTN","RCX FMSPR",80, 0)
  2883    S COLUMN3 =$E(RSC,3)
  2884   "RTN","RCX FMSPR",81, 0)
  2885    ;  conver t alpha le tters to d ecimal
  2886   "RTN","RCX FMSPR",82, 0)
  2887    I "012345 6789"'[COL UMN3 S COL UMN3=$A(CO LUMN3)-55
  2888   "RTN","RCX FMSPR",83, 0)
  2889    S BINARY= $$CONVERT( COLUMN3)
  2890   "RTN","RCX FMSPR",84, 0)
  2891    S COL3DES C=$P($T(@( "B"_$E(BIN ARY,1,2))) ,";",3)
  2892   "RTN","RCX FMSPR",85, 0)
  2893    S COL3DES C=COL3DESC _", "_$P($ T(@("C"_$E (BINARY,3) )),";",3)
  2894   "RTN","RCX FMSPR",86, 0)
  2895    S COL3DES C=COL3DESC _", "_$P($ T(@("D"_$E (BINARY,4) )),";",3)
  2896   "RTN","RCX FMSPR",87, 0)
  2897    S COL3DES C=COL3DESC _", "_$P($ T(@("E"_$E (BINARY,5) )),";",3)
  2898   "RTN","RCX FMSPR",88, 0)
  2899    Q "RHI, " _COL3DESC
  2900   "RTN","RCX FMSPR",89, 0)
  2901    ;
  2902   "RTN","RCX FMSPR",90, 0)
  2903    ;
  2904   "RTN","RCX FMSPR",91, 0)
  2905   CONVERT(DE CIMAL) ;   convert de cimal numb er to bina ry (5 digi ts)
  2906   "RTN","RCX FMSPR",92, 0)
  2907    N Y
  2908   "RTN","RCX FMSPR",93, 0)
  2909    S Y=""
  2910   "RTN","RCX FMSPR",94, 0)
  2911    F  S Y=$E ("01234567 89ABCDEF", DECIMAL#2+ 1)_Y,DECIM AL=DECIMAL \2 Q:DECIM AL<1
  2912   "RTN","RCX FMSPR",95, 0)
  2913    S Y=$E("0 0000",0,5- $L(Y))_Y
  2914   "RTN","RCX FMSPR",96, 0)
  2915    Q Y
  2916   "RTN","RCX FMSPR",97, 0)
  2917    ;
  2918   "RTN","RCX FMSPR",98, 0)
  2919    ;
  2920   "RTN","RCX FMSPR",99, 0)
  2921   WRITEIT ;   display t he rsc
  2922   "RTN","RCX FMSPR",100 ,0)
  2923    W !,COLUM N1,COLUMN2 ,COLUMN3,C OLUMN4,?6, DESCRIP
  2924   "RTN","RCX FMSPR",101 ,0)
  2925    I $Y>(IOS L-5) D:SCR EEN PAUSE  Q:$G(RCSTF LAG)  D H
  2926   "RTN","RCX FMSPR",102 ,0)
  2927    Q
  2928   "RTN","RCX FMSPR",103 ,0)
  2929    ;
  2930   "RTN","RCX FMSPR",104 ,0)
  2931    ;
  2932   "RTN","RCX FMSPR",105 ,0)
  2933   PAUSE ;  p ause at en d of page
  2934   "RTN","RCX FMSPR",106 ,0)
  2935    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
  2936   "RTN","RCX FMSPR",107 ,0)
  2937    Q
  2938   "RTN","RCX FMSPR",108 ,0)
  2939    ;
  2940   "RTN","RCX FMSPR",109 ,0)
  2941    ;
  2942   "RTN","RCX FMSPR",110 ,0)
  2943   H ;  heade r
  2944   "RTN","RCX FMSPR",111 ,0)
  2945    S %=NOW_"   PAGE "_P AGE,PAGE=P AGE+1 I PA GE'=2!(SCR EEN) W @IO F
  2946   "RTN","RCX FMSPR",112 ,0)
  2947    W $C(13), "REVENUE S OURCE CODE  REPORT (V ISTA TO FM S)",?(80-$ L(%)),%
  2948   "RTN","RCX FMSPR",113 ,0)
  2949    W !,"RSC" ,?6,"Descr iption"
  2950   "RTN","RCX FMSPR",114 ,0)
  2951    S %="",$P (%,"-",81) =""
  2952   "RTN","RCX FMSPR",115 ,0)
  2953    W !,%
  2954   "RTN","RCX FMSPR",116 ,0)
  2955    Q
  2956   "RTN","RCX FMSPR",117 ,0)
  2957    ;
  2958   "RTN","RCX FMSPR",118 ,0)
  2959    ;
  2960   "RTN","RCX FMSPR",119 ,0)
  2961    ;  this i s a listin g of all c olumn2 val ues with a  descripti on
  2962   "RTN","RCX FMSPR",120 ,0)
  2963   A1 ;;Hospi tal Care ( NSC)
  2964   "RTN","RCX FMSPR",121 ,0)
  2965   A2 ;;Outpa tient Care  (NSC)
  2966   "RTN","RCX FMSPR",122 ,0)
  2967   A3 ;;Nursi ng Home Ca re (NSC)
  2968   "RTN","RCX FMSPR",123 ,0)
  2969   A4 ;;Ineli gible Hosp italizatio n
  2970   "RTN","RCX FMSPR",124 ,0)
  2971   A5 ;;Reimb ursable He alth Insur ance
  2972   "RTN","RCX FMSPR",125 ,0)
  2973   A6 ;;Tort  Feasor
  2974   "RTN","RCX FMSPR",126 ,0)
  2975   A7 ;;Workm ans Compen sation (No n-Federal)
  2976   "RTN","RCX FMSPR",127 ,0)
  2977   A8 ;;C (Me ans Test)
  2978   "RTN","RCX FMSPR",128 ,0)
  2979   A9 ;;Emerg ency/Human itarian
  2980   "RTN","RCX FMSPR",129 ,0)
  2981   AA ;;No Fa ult Auto A ccident
  2982   "RTN","RCX FMSPR",130 ,0)
  2983   AB ;;Pharm acy Co-Pay  (SC Vet)
  2984   "RTN","RCX FMSPR",131 ,0)
  2985   AC ;;Pharm acy Co-Pay  (NSC Vet)
  2986   "RTN","RCX FMSPR",132 ,0)
  2987   AD ;;Nursi ng Home Ca re Per Die m
  2988   "RTN","RCX FMSPR",133 ,0)
  2989   AE ;;Hospi tal Care P er Diem
  2990   "RTN","RCX FMSPR",134 ,0)
  2991   AF ;;Medic are
  2992   "RTN","RCX FMSPR",135 ,0)
  2993   AG ;;Adult  Day Healt h Care (LT C)
  2994   "RTN","RCX FMSPR",136 ,0)
  2995   AH ;;Domic iliary (LT C)
  2996   "RTN","RCX FMSPR",137 ,0)
  2997   AI ;;Respi te Care-In stitutiona l (LTC)
  2998   "RTN","RCX FMSPR",138 ,0)
  2999   AJ ;;Respi te Care-No n-Institut ional (LTC )
  3000   "RTN","RCX FMSPR",139 ,0)
  3001   AK ;;Geria tric Eval- Institutio nal (LTC)
  3002   "RTN","RCX FMSPR",140 ,0)
  3003   AL ;;Geria tric Eval- Non-Instit utional (L TC)
  3004   "RTN","RCX FMSPR",141 ,0)
  3005   AM ;;Nursi ng Home Ca re-Long Te rm Care (L TC)
  3006   "RTN","RCX FMSPR",142 ,0)
  3007   AQ ;;Pharm acy No Fau lt Auto Ac c
  3008   "RTN","RCX FMSPR",143 ,0)
  3009   AR ;;Pharm acy Reimbu rs Health  Ins
  3010   "RTN","RCX FMSPR",144 ,0)
  3011   AS ;;Pharm acy Tort F easor
  3012   "RTN","RCX FMSPR",145 ,0)
  3013   AT ;;Pharm acy Workma n's Comp
  3014   "RTN","RCX FMSPR",146 ,0)
  3015    ;
  3016   "RTN","RCX FMSPR",147 ,0)
  3017    ;
  3018   "RTN","RCX FMSPR",148 ,0)
  3019    ;  this i s a listin g for the  type of ca re, first  2 binary d igits
  3020   "RTN","RCX FMSPR",149 ,0)
  3021    ;  if col umn2 is re imbursable  health in surance
  3022   "RTN","RCX FMSPR",150 ,0)
  3023   B00 ;;Inpa tient (Hos p)
  3024   "RTN","RCX FMSPR",151 ,0)
  3025   B01 ;;Outp atient
  3026   "RTN","RCX FMSPR",152 ,0)
  3027   B10 ;;Nurs ing Home
  3028   "RTN","RCX FMSPR",153 ,0)
  3029   B11 ;;Othe r
  3030   "RTN","RCX FMSPR",154 ,0)
  3031    ;
  3032   "RTN","RCX FMSPR",155 ,0)
  3033    ;
  3034   "RTN","RCX FMSPR",156 ,0)
  3035    ;  this i s a listin g for the  service co nnected, b inary digi t 3
  3036   "RTN","RCX FMSPR",157 ,0)
  3037   C0 ;;SC fo r NSC
  3038   "RTN","RCX FMSPR",158 ,0)
  3039   C1 ;;NSC V et
  3040   "RTN","RCX FMSPR",159 ,0)
  3041    ;
  3042   "RTN","RCX FMSPR",160 ,0)
  3043    ;
  3044   "RTN","RCX FMSPR",161 ,0)
  3045    ;  this i s a listin g for mean s test, bi nary digit  4
  3046   "RTN","RCX FMSPR",162 ,0)
  3047   D0 ;;MT Ca t A
  3048   "RTN","RCX FMSPR",163 ,0)
  3049   D1 ;;MT Ca t C
  3050   "RTN","RCX FMSPR",164 ,0)
  3051    ;
  3052   "RTN","RCX FMSPR",165 ,0)
  3053    ;
  3054   "RTN","RCX FMSPR",166 ,0)
  3055    ;  this i s a listin g for age  group, bin ary digit  5
  3056   "RTN","RCX FMSPR",167 ,0)
  3057   E0 ;;Age < 65
  3058   "RTN","RCX FMSPR",168 ,0)
  3059   E1 ;;Age 6 5+
  3060   "RTN","RCX FMSUF")
  3061   0^5^B37450 700^B36597 164
  3062   "RTN","RCX FMSUF",1,0 )
  3063   RCXFMSUF ; WISC/RFJ-c alculate f ms fund co de for a b ill ;10/20 /10 10:37a m
  3064   "RTN","RCX FMSUF",2,0 )
  3065    ;;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**;Mar 20 , 1995;Bui ld 14
  3066   "RTN","RCX FMSUF",3,0 )
  3067    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  3068   "RTN","RCX FMSUF",4,0 )
  3069    Q
  3070   "RTN","RCX FMSUF",5,0 )
  3071    ;
  3072   "RTN","RCX FMSUF",6,0 )
  3073    ;
  3074   "RTN","RCX FMSUF",7,0 )
  3075   GETFUNDO(T YPE) ;  re turn the f und for ot her type a ssociated  collection s
  3076   "RTN","RCX FMSUF",8,0 )
  3077    ;  type c an equal:
  3078   "RTN","RCX FMSUF",9,0 )
  3079    ;  I for  interest          A f or admin
  3080   "RTN","RCX FMSUF",10, 0)
  3081    ;  M for  marshall f ee     C f or court c ost
  3082   "RTN","RCX FMSUF",11, 0)
  3083    I TYPE="I " Q "1435"
  3084   "RTN","RCX FMSUF",12, 0)
  3085    I TYPE="A " Q "3220"
  3086   "RTN","RCX FMSUF",13, 0)
  3087    I TYPE="M " Q "0869"
  3088   "RTN","RCX FMSUF",14, 0)
  3089    I TYPE="C " Q "0869"
  3090   "RTN","RCX FMSUF",15, 0)
  3091    Q ""
  3092   "RTN","RCX FMSUF",16, 0)
  3093    ;
  3094   "RTN","RCX FMSUF",17, 0)
  3095    ;
  3096   "RTN","RCX FMSUF",18, 0)
  3097   GETFUNDB(B ILLDA,DONT STOR,RCEFT ) ;  retur n a bills  fms fund c ode
  3098   "RTN","RCX FMSUF",19, 0)
  3099    ;  pass D ONTSTOR eq ual 1 to p revent sto ring the f und code
  3100   "RTN","RCX FMSUF",20, 0)
  3101    ;  cannot  rely on d ata in the  fund fiel d since it  may refer ence the
  3102   "RTN","RCX FMSUF",21, 0)
  3103    ;  old fu nds S FUND =$P($G(^PR CA(430,BIL LDA,11))," ^",17).  s ince there
  3104   "RTN","RCX FMSUF",22, 0)
  3105    ;  are re ports whic h use 11;1 7, set it  for a bill  once its  computed
  3106   "RTN","RCX FMSUF",23, 0)
  3107    ;  until  all refere nces to th e fund are  eliminate d.
  3108   "RTN","RCX FMSUF",24, 0)
  3109    ;  rceft  = 1 if pro cessing an  EFT depos it
  3110   "RTN","RCX FMSUF",25, 0)
  3111    ;
  3112   "RTN","RCX FMSUF",26, 0)
  3113    N ACTDATE ,CATEGDA,F UND,NEWFUN D
  3114   "RTN","RCX FMSUF",27, 0)
  3115    ;
  3116   "RTN","RCX FMSUF",28, 0)
  3117    ;  calcul ate a bill s fund
  3118   "RTN","RCX FMSUF",29, 0)
  3119    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
  3120   "RTN","RCX FMSUF",30, 0)
  3121    S CATEGDA =+$P($G(^P RCA(430,BI LLDA,0))," ^",2)
  3122   "RTN","RCX FMSUF",31, 0)
  3123    I CATEGDA >45 Q ""
  3124   "RTN","RCX FMSUF",32, 0)
  3125    ;
  3126   "RTN","RCX FMSUF",33, 0)
  3127    ;  piece  5 is new f und, remov e spaces
  3128   "RTN","RCX FMSUF",34, 0)
  3129    S FUND=$P ($TR($T(@C ATEGDA),"  "),";",5)
  3130   "RTN","RCX FMSUF",35, 0)
  3131    ;
  3132   "RTN","RCX FMSUF",36, 0)
  3133    ;  set fu nd 528711  for 3rd pa rty RX bil ls after 4 /27/2011
  3134   "RTN","RCX FMSUF",37, 0)
  3135    I $$TYP^I BRFN(BILLD A)="PH" D
  3136   "RTN","RCX FMSUF",38, 0)
  3137    . I (CATE GDA=6)!(CA TEGDA=7)!( CATEGDA=9) !(CATEGDA= 10),$$CHEC KRXS(BILLD A) S FUND= 528711
  3138   "RTN","RCX FMSUF",39, 0)
  3139    ;
  3140   "RTN","RCX FMSUF",40, 0)
  3141    ;  if cat egory is v endor(17),  ex-employ ee(15), cu rrent empl oyee(16)
  3142   "RTN","RCX FMSUF",41, 0)
  3143    ;  federa l agency r efund(13),  federal a gency reim b(14), mil itary(12)
  3144   "RTN","RCX FMSUF",42, 0)
  3145    ;  set th e fund to  what is st ored in th e file.  T his was en tered
  3146   "RTN","RCX FMSUF",43, 0)
  3147    ;  by the  user duri ng the aud it process .  If fund  is in the  file
  3148   "RTN","RCX FMSUF",44, 0)
  3149    ;  alread y, do not  need to st ore it aga in.
  3150   "RTN","RCX FMSUF",45, 0)
  3151    ;  if cat egory is n ursing hom e proceeds  (40), par king fees  (41),
  3152   "RTN","RCX FMSUF",46, 0)
  3153    ;  cwt pr oceeds (42 ), comp &  pen procee ds (43), e nhanced us e lease
  3154   "RTN","RCX FMSUF",47, 0)
  3155    ;  procee ds (44), s et the fun d to what  is stored  in the fil e.
  3156   "RTN","RCX FMSUF",48, 0)
  3157    ;  This w as generat ed by the  software a t the time  of bill e nter.
  3158   "RTN","RCX FMSUF",49, 0)
  3159    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
  3160   "RTN","RCX FMSUF",50, 0)
  3161    .   I $P( $G(^PRCA(4 30,BILLDA, 11)),"^",1 7)'="" S F UND=$P(^(1 1),"^",17) ,DONTSTOR= 1
  3162   "RTN","RCX FMSUF",51, 0)
  3163    ;
  3164   "RTN","RCX FMSUF",52, 0)
  3165    ;  public  law state s that bil ls in the  category i neligible  (1),
  3166   "RTN","RCX FMSUF",53, 0)
  3167    ;  emerg/ human (2),  torts (10 ), or medi care (21)  which are  older 
  3168   "RTN","RCX FMSUF",54, 0)
  3169    ;  than o ct 1, 1992  should be  reported  under fund  3220.
  3170   "RTN","RCX FMSUF",55, 0)
  3171    I CATEGDA =1!(CATEGD A=2)!(CATE GDA=10)!(C ATEGDA=21)  D
  3172   "RTN","RCX FMSUF",56, 0)
  3173    .   S ACT DATE=$P($G (^PRCA(430 ,BILLDA,6) ),"^",21)
  3174   "RTN","RCX FMSUF",57, 0)
  3175    .   I ACT DATE,ACTDA TE<2921001  S FUND=32 20 Q
  3176   "RTN","RCX FMSUF",58, 0)
  3177    .   ;
  3178   "RTN","RCX FMSUF",59, 0)
  3179    .   ;  pa tch157 cha nges ineli gibles.  a n ineligib le activat ed before
  3180   "RTN","RCX FMSUF",60, 0)
  3181    .   ;  oc t 1, 1992  or after s ep 30, 200 0 will be  recorded i n fund 016 0A1.
  3182   "RTN","RCX FMSUF",61, 0)
  3183    .   ;  ot herwise it  will be r ecorded in  fund 5287 .3 if befo re 3040928
  3184   "RTN","RCX FMSUF",62, 0)
  3185    .   ; if  3040928 or  after,  f und should  be 528703
  3186   "RTN","RCX FMSUF",63, 0)
  3187    .   I CAT EGDA=1,ACT DATE,ACTDA TE<3001001  S FUND=$S (DT<$$ADDP TEDT^PRCAA CC():"5287 .3",1:5287 03)
  3188   "RTN","RCX FMSUF",64, 0)
  3189    ;
  3190   "RTN","RCX FMSUF",65, 0)
  3191    ;  set th e fund for  the bill
  3192   "RTN","RCX FMSUF",66, 0)
  3193    ; PRCA*4. 5*310/DRF  Add Non-VA  fund 5287 13
  3194   "RTN","RCX FMSUF",67, 0)
  3195    I $G(DONT STOR)'=1 D  STORE^RCX FMSUR(BILL DA,"",FUND )
  3196   "RTN","RCX FMSUF",68, 0)
  3197    ; 
  3198   "RTN","RCX FMSUF",69, 0)
  3199    I FUND>52 8704,FUND< 528709!(FU ND=528710) !(FUND=528 711) Q FUN D
  3200   "RTN","RCX FMSUF",70, 0)
  3201    I FUND=52 8713 Q FUN D
  3202   "RTN","RCX FMSUF",71, 0)
  3203    ;
  3204   "RTN","RCX FMSUF",72, 0)
  3205    I $G(REPR ODT),REPRO DT<3030926 ,$E(FUND,1 ,4)=5287 Q  5287
  3206   "RTN","RCX FMSUF",73, 0)
  3207    I $G(REPR ODT),REPRO DT<3031001 ,$E(FUND,1 ,4)=5287,$ G(REFMS) Q  5287
  3208   "RTN","RCX FMSUF",74, 0)
  3209    I DT<3030 926,$E(FUN D,1,4)=528 7 Q 5287 ;  Effective  date
  3210   "RTN","RCX FMSUF",75, 0)
  3211    I $G(REPR ODT),REPRO DT<$$ADDPT EDT^PRCAAC C(),FUND=5 28709 Q 40 32 ;Effect ive date-5 28709
  3212   "RTN","RCX FMSUF",76, 0)
  3213    I $G(REPR ODT),REPRO DT<3041001 ,FUND=5287 09,$G(REFM S) Q 4032  ;Resubmitt ed documen ts not hel d
  3214   "RTN","RCX FMSUF",77, 0)
  3215    I $G(DATE END),$E(DA TEEND,2,5) <"0410",FU ND=528709  Q 4032
  3216   "RTN","RCX FMSUF",78, 0)
  3217    I DT<$$AD DPTEDT^PRC AACC(),FUN D=528709 Q  4032
  3218   "RTN","RCX FMSUF",79, 0)
  3219    I $G(REPR ODT),REPRO DT<$$ADDPT EDT^PRCAAC C(),FUND=5 28701 Q 52 87.1 ;Effe ctive date -528701
  3220   "RTN","RCX FMSUF",80, 0)
  3221    I $G(REPR ODT),REPRO DT<3041001 ,FUND=5287 01,$G(REFM S) Q 5287. 1 ;Resubmi tted docum ents not h eld
  3222   "RTN","RCX FMSUF",81, 0)
  3223    I $G(DATE END),$E(DA TEEND,2,5) <"0410",FU ND=528701  Q 5287.1
  3224   "RTN","RCX FMSUF",82, 0)
  3225    I DT<$$AD DPTEDT^PRC AACC(),FUN D=528701 Q  5287.1
  3226   "RTN","RCX FMSUF",83, 0)
  3227    I $G(REPR ODT),REPRO DT<$$ADDPT EDT^PRCAAC C(),FUND=5 28703 Q 52 87.3 ;Effe ctive date -528703
  3228   "RTN","RCX FMSUF",84, 0)
  3229    I $G(REPR ODT),REPRO DT<3041001 ,FUND=5287 03,$G(REFM S) Q 5287. 3 ;Resubmi tted docum ents not h eld
  3230   "RTN","RCX FMSUF",85, 0)
  3231    I $G(DATE END),$E(DA TEEND,2,5) <"0410",FU ND=528703  Q 5287.3
  3232   "RTN","RCX FMSUF",86, 0)
  3233    I DT<$$AD DPTEDT^PRC AACC(),FUN D=528703 Q  5287.3
  3234   "RTN","RCX FMSUF",87, 0)
  3235    I $G(REPR ODT),REPRO DT<$$ADDPT EDT^PRCAAC C(),FUND=5 28704 Q 52 87.4 ;Effe ctive date -528704
  3236   "RTN","RCX FMSUF",88, 0)
  3237    I $G(REPR ODT),REPRO DT<3041001 ,FUND=5287 04,$G(REFM S) Q 5287. 4 ;Resubmi tted docum ents not h eld
  3238   "RTN","RCX FMSUF",89, 0)
  3239    I $G(DATE END),$E(DA TEEND,2,5) <"0410",FU ND=528704  Q 5287.4
  3240   "RTN","RCX FMSUF",90, 0)
  3241    I DT<$$AD DPTEDT^PRC AACC(),FUN D=528704 Q  5287.4
  3242   "RTN","RCX FMSUF",91, 0)
  3243    Q FUND
  3244   "RTN","RCX FMSUF",92, 0)
  3245    ;
  3246   "RTN","RCX FMSUF",93, 0)
  3247   CHECKRXS(B ILLDA) ; r eturns tru e (1) if b ill has an y scripts  on or afte r 4/27/11
  3248   "RTN","RCX FMSUF",94, 0)
  3249    N RXNUM,N EWFUND,FIL LDT,ARRXS
  3250   "RTN","RCX FMSUF",95, 0)
  3251    S NEWFUND =0
  3252   "RTN","RCX FMSUF",96, 0)
  3253    D SET^IBC SC5A(BILLD A,.ARRXS,)
  3254   "RTN","RCX FMSUF",97, 0)
  3255    S RXNUM=0 ,FILLDT=""
  3256   "RTN","RCX FMSUF",98, 0)
  3257    F  S RXNU M=$O(ARRXS (RXNUM)) Q :RXNUM'>0! (NEWFUND)   D
  3258   "RTN","RCX FMSUF",99, 0)
  3259    .  S FILL DT=$O(ARRX S(RXNUM,0) )
  3260   "RTN","RCX FMSUF",100 ,0)
  3261    .  I FILL DT'<311042 7 S NEWFUN D=1
  3262   "RTN","RCX FMSUF",101 ,0)
  3263    Q NEWFUND
  3264   "RTN","RCX FMSUF",102 ,0)
  3265    ;
  3266   "RTN","RCX FMSUF",103 ,0)
  3267    ;  this i s a listin g of all c ategories  and associ ated funds
  3268   "RTN","RCX FMSUF",104 ,0)
  3269    ;  the la bel is fro m the inte rnal entry  number in  the categ ory
  3270   "RTN","RCX FMSUF",105 ,0)
  3271    ;  file 4 30.2.  pie ce 3 is a  descriptio n, piece 4  is the ol d fund,
  3272   "RTN","RCX FMSUF",106 ,0)
  3273    ;  piece  5 is the n ew fund
  3274   "RTN","RCX FMSUF",107 ,0)
  3275    ;  PRCA*4 .5*310/DRF  Added 45  - FEE REIM B INS to r outine.
  3276   "RTN","RCX FMSUF",108 ,0)
  3277   0 ;;no fun d                         ;        ;    
  3278   "RTN","RCX FMSUF",109 ,0)
  3279   1 ;;INELIG IBLE HOSP.                ;3220    ;0160A1
  3280   "RTN","RCX FMSUF",110 ,0)
  3281   2 ;;EMERGE NCY/HUMANI TARIAN         ;0160A 1 ;528703
  3282   "RTN","RCX FMSUF",111 ,0)
  3283   3 ;;NURSIN G HOME CAR E(NSC)         ;2431    ;528703
  3284   "RTN","RCX FMSUF",112 ,0)
  3285   4 ;;OUTPAT IENT CARE( NSC)           ;2431    ;528703
  3286   "RTN","RCX FMSUF",113 ,0)
  3287   5 ;;HOSPIT AL CARE (N SC)            ;2431    ;528703
  3288   "RTN","RCX FMSUF",114 ,0)
  3289   6 ;;WORKMA N'S COMP.                 ;5014    ;528704
  3290   "RTN","RCX FMSUF",115 ,0)
  3291   7 ;;NO-FAU LT AUTO AC C.             ;5014    ;528704
  3292   "RTN","RCX FMSUF",116 ,0)
  3293   8 ;;CRIME  OF PER.VIO .              ;5014    ;528704
  3294   "RTN","RCX FMSUF",117 ,0)
  3295   9 ;;REIMBU RS.HEALTH  INS.           ;5014    ;528704
  3296   "RTN","RCX FMSUF",118 ,0)
  3297   10 ;;TORT  FEASOR                     ;0160 A1 ;528704
  3298   "RTN","RCX FMSUF",119 ,0)
  3299   11 ;;no en try                        ;        ;
  3300   "RTN","RCX FMSUF",120 ,0)
  3301   12 ;;MILIT ARY                        ;0160 A1 ;0160A1
  3302   "RTN","RCX FMSUF",121 ,0)
  3303   13 ;;FEDER AL AGENCIE S-REFUND        ;0160 A1 ;0160A1
  3304   "RTN","RCX FMSUF",122 ,0)
  3305   14 ;;FEDER AL AGENCIE S-REIMB.        ;0160 A1 ;0160A1
  3306   "RTN","RCX FMSUF",123 ,0)
  3307   15 ;;EX-EM PLOYEE                     ;0160 A1 ;0160A1
  3308   "RTN","RCX FMSUF",124 ,0)
  3309   16 ;;CURRE NT EMP.                    ;0160 A1 ;0160A1
  3310   "RTN","RCX FMSUF",125 ,0)
  3311   17 ;;VENDO R                          ;0160 A1 ;0160A1
  3312   "RTN","RCX FMSUF",126 ,0)
  3313   18 ;;C (ME ANS TEST)                  ;2431    ;528703
  3314   "RTN","RCX FMSUF",127 ,0)
  3315   19 ;;SHARI NG AGREEME NTS             ;0160 A1 ;0160A1
  3316   "RTN","RCX FMSUF",128 ,0)
  3317   20 ;;INTER AGENCY                     ;0160 A1 ;0160A1
  3318   "RTN","RCX FMSUF",129 ,0)
  3319   21 ;;MEDIC ARE                        ;5014    ;528704
  3320   "RTN","RCX FMSUF",130 ,0)
  3321   22 ;;RX CO -PAYMENT/S C VET           ;5014    ;528701
  3322   "RTN","RCX FMSUF",131 ,0)
  3323   23 ;;RX CO -PAYMENT/N SC VET          ;5014    ;528701
  3324   "RTN","RCX FMSUF",132 ,0)
  3325   24 ;;NURSI NG HOME CA RE PER DIE M    ;2431    ;528703
  3326   "RTN","RCX FMSUF",133 ,0)
  3327   25 ;;HOSPI TAL CARE P ER DIEM         ;2431    ;528703
  3328   "RTN","RCX FMSUF",134 ,0)
  3329   26 ;;PREPA YMENT                      ;5014    ;528703
  3330   "RTN","RCX FMSUF",135 ,0)
  3331   27 ;;CHAMP VA SUBSIST ENCE            ;3220    ;3220
  3332   "RTN","RCX FMSUF",136 ,0)
  3333   28 ;;CHAMP VA THIRD P ARTY            ;3220    ;0160A1
  3334   "RTN","RCX FMSUF",137 ,0)
  3335   29 ;;CHAMP VA                         ;0160 A1 ;0160A1
  3336   "RTN","RCX FMSUF",138 ,0)
  3337   30 ;;TRICA RE                         ;0160 A1 ;0160A1
  3338   "RTN","RCX FMSUF",139 ,0)
  3339   31 ;;TRICA RE PATIENT                 ;0160 A1 ;0160A1
  3340   "RTN","RCX FMSUF",140 ,0)
  3341   32 ;;TRICA RE THIRD P ARTY            ;0160 A1 ;0160A1
  3342   "RTN","RCX FMSUF",141 ,0)
  3343   33 ;;ADULT  DAY HEALT H CARE          ;4032    ;528709
  3344   "RTN","RCX FMSUF",142 ,0)
  3345   34 ;;DOMIC ILIARY                     ;4032    ;528709
  3346   "RTN","RCX FMSUF",143 ,0)
  3347   35 ;;RESPI TE CARE-IN STITUTIONA L    ;4032    ;528709
  3348   "RTN","RCX FMSUF",144 ,0)
  3349   36 ;;RESPI TE CARE-NO N-INSTITUT IONAL;4032    ;528709
  3350   "RTN","RCX FMSUF",145 ,0)
  3351   37 ;;GERIA TRIC EVAL- INSTITUTIO NAL  ;4032    ;528709
  3352   "RTN","RCX FMSUF",146 ,0)
  3353   38 ;;GERIA TRIC EVAL- NON-INSTIT UTION;4032    ;528709
  3354   "RTN","RCX FMSUF",147 ,0)
  3355   39 ;;NURSI NG HOME CA RE-LTC          ;4032    ;528709
  3356   "RTN","RCX FMSUF",148 ,0)
  3357   40 ;;NURSI NG HOME PR OCEEDS          ;        ;528705
  3358   "RTN","RCX FMSUF",149 ,0)
  3359   41 ;;PARKI NG FEES                    ;        ;528706
  3360   "RTN","RCX FMSUF",150 ,0)
  3361   42 ;;CWT P ROCEEDS                    ;        ;528707
  3362   "RTN","RCX FMSUF",151 ,0)
  3363   43 ;;COMP  & PEN PROC EEDS            ;        ;528708
  3364   "RTN","RCX FMSUF",152 ,0)
  3365   44 ;;ENHAN CED USE LE ASE PROCEE DS   ;5358 .3 ;528710
  3366   "RTN","RCX FMSUF",153 ,0)
  3367   45 ;;FEE R EIMB INS                   ;        ;528713
  3368   "RTN","RCX FMSUF",154 ,0)
  3369    ;
  3370   "RTN","RCX FMSUF",155 ,0)
  3371    ;    
  3372   "RTN","RCX FMSUR")
  3373   0^6^B60950 863^B58588 015
  3374   "RTN","RCX FMSUR",1,0 )
  3375   RCXFMSUR ; WISC/RFJ-r evenue sou rce codes  ;10/19/10  1:47pm
  3376   "RTN","RCX FMSUR",2,0 )
  3377    ;;4.5;Acc ounts Rece ivable;**9 0,101,170, 203,173,22 0,231,273, 310**;Mar  20, 1995;B uild 14
  3378   "RTN","RCX FMSUR",3,0 )
  3379    ;Per VA D irective 6 402,this r outine sho uld not be  modified.
  3380   "RTN","RCX FMSUR",4,0 )
  3381    Q
  3382   "RTN","RCX FMSUR",5,0 )
  3383    ;
  3384   "RTN","RCX FMSUR",6,0 )
  3385    ;
  3386   "RTN","RCX FMSUR",7,0 )
  3387   CALCRSC(BI LLDA,RCEFT ) ;  calcu late the r evenue sou rce code f or a bill
  3388   "RTN","RCX FMSUR",8,0 )
  3389    ;  rceft  = 1 if pro cessing an  EFT depos it
  3390   "RTN","RCX FMSUR",9,0 )
  3391    ;  return s the 4 co lumn (char acter) rsc
  3392   "RTN","RCX FMSUR",10, 0)
  3393    N CATEGDA ,COLUMN1,C OLUMN2,COL UMN3,COLUM N4,RSC
  3394   "RTN","RCX FMSUR",11, 0)
  3395    ;  if rsc  already c alculated,  return it
  3396   "RTN","RCX FMSUR",12, 0)
  3397    I $G(RCEF T)=1 S RSC ="8NZZ" Q  RSC
  3398   "RTN","RCX FMSUR",13, 0)
  3399    S RSC=$P( $G(^PRCA(4 30,BILLDA, 11)),"^",2 3)
  3400   "RTN","RCX FMSUR",14, 0)
  3401    I $L(RSC) =4,RSC'="A RRV" Q RSC
  3402   "RTN","RCX FMSUR",15, 0)
  3403    ;
  3404   "RTN","RCX FMSUR",16, 0)
  3405    ;  calcul ate it and  store it
  3406   "RTN","RCX FMSUR",17, 0)
  3407    S CATEGDA =+$P($G(^P RCA(430,BI LLDA,0))," ^",2)
  3408   "RTN","RCX FMSUR",18, 0)
  3409    ;
  3410   "RTN","RCX FMSUR",19, 0)
  3411    ;  if pre payment, s end ARRV
  3412   "RTN","RCX FMSUR",20, 0)
  3413    I CATEGDA =26 D STOR E(BILLDA," ARRV") Q " ARRV"
  3414   "RTN","RCX FMSUR",21, 0)
  3415    ;
  3416   "RTN","RCX FMSUR",22, 0)
  3417    S COLUMN1 =$$COLUMN1
  3418   "RTN","RCX FMSUR",23, 0)
  3419    ;
  3420   "RTN","RCX FMSUR",24, 0)
  3421    ; check f or 3rd par ty RX bill s after 4/ 27/2011 fo r col 2
  3422   "RTN","RCX FMSUR",25, 0)
  3423    N RX3P S  RX3P=0
  3424   "RTN","RCX FMSUR",26, 0)
  3425    I ("PH"=$ $TYP^IBRFN (BILLDA))  D
  3426   "RTN","RCX FMSUR",27, 0)
  3427    .  S RX3P =$$CHECKRX S^RCXFMSUF (BILLDA)
  3428   "RTN","RCX FMSUR",28, 0)
  3429    ;
  3430   "RTN","RCX FMSUR",29, 0)
  3431    S COLUMN2 =$$COLUMN2
  3432   "RTN","RCX FMSUR",30, 0)
  3433    ;
  3434   "RTN","RCX FMSUR",31, 0)
  3435    ;  if col umn2 canno t be deter mined, ret urn the rs c of ARRV
  3436   "RTN","RCX FMSUR",32, 0)
  3437    I COLUMN2 ="" D STOR E(BILLDA," ARRV") Q " ARRV"
  3438   "RTN","RCX FMSUR",33, 0)
  3439    ;
  3440   "RTN","RCX FMSUR",34, 0)
  3441    ;  if col umn2 is no t a 5 for  reimbursab le health  insurance,  or catego ry not 45  (FEE REIMB  INS)
  3442   "RTN","RCX FMSUR",35, 0)
  3443    ;  return  ZZ in col umns 3 and  4
  3444   "RTN","RCX FMSUR",36, 0)
  3445    I COLUMN2 '=5,CATEGD A'=45 D ST ORE(BILLDA ,COLUMN1_C OLUMN2_"ZZ ") Q COLUM N1_COLUMN2 _"ZZ"
  3446   "RTN","RCX FMSUR",37, 0)
  3447    ;
  3448   "RTN","RCX FMSUR",38, 0)
  3449    ;  for re imbursable  health in surance, c ompute col umns 3 and  4
  3450   "RTN","RCX FMSUR",39, 0)
  3451    S COLUMN3 =$$COLUMN3
  3452   "RTN","RCX FMSUR",40, 0)
  3453    S COLUMN4 =$$COLUMN4
  3454   "RTN","RCX FMSUR",41, 0)
  3455    ;
  3456   "RTN","RCX FMSUR",42, 0)
  3457    D STORE(B ILLDA,COLU MN1_COLUMN 2_COLUMN3_ COLUMN4)
  3458   "RTN","RCX FMSUR",43, 0)
  3459    Q COLUMN1 _COLUMN2_C OLUMN3_COL UMN4
  3460   "RTN","RCX FMSUR",44, 0)
  3461    ;
  3462   "RTN","RCX FMSUR",45, 0)
  3463    ;
  3464   "RTN","RCX FMSUR",46, 0)
  3465   STORE(DA,R SC,FUND) ;   store th e revenue  source cod e  or fund  in the fi le
  3466   "RTN","RCX FMSUR",47, 0)
  3467    I $G(^PRC A(430,DA,0 ))="" Q
  3468   "RTN","RCX FMSUR",48, 0)
  3469    N D,D0,DI ,DIC,DIE,D Q,DR,X,Y
  3470   "RTN","RCX FMSUR",49, 0)
  3471    S DR=""
  3472   "RTN","RCX FMSUR",50, 0)
  3473    I $G(RSC) '="" S DR= "255.1//// "_RSC_";"
  3474   "RTN","RCX FMSUR",51, 0)
  3475    I $G(FUND )'="" S DR =DR_"203// //"_FUND_" ;"
  3476   "RTN","RCX FMSUR",52, 0)
  3477    S (DIC,DI E)="^PRCA( 430,"
  3478   "RTN","RCX FMSUR",53, 0)
  3479    D ^DIE
  3480   "RTN","RCX FMSUR",54, 0)
  3481    Q
  3482   "RTN","RCX FMSUR",55, 0)
  3483    ;
  3484   "RTN","RCX FMSUR",56, 0)
  3485    ;
  3486   "RTN","RCX FMSUR",57, 0)
  3487   COLUMN1()  ;  return  column 1 n umber
  3488   "RTN","RCX FMSUR",58, 0)
  3489    Q 8
  3490   "RTN","RCX FMSUR",59, 0)
  3491    ;
  3492   "RTN","RCX FMSUR",60, 0)
  3493    ;
  3494   "RTN","RCX FMSUR",61, 0)
  3495   COLUMN2()  ;  return  column 2 n umber
  3496   "RTN","RCX FMSUR",62, 0)
  3497    I CATEGDA =5 Q 1      ; hospita l care (ns c)
  3498   "RTN","RCX FMSUR",63, 0)
  3499    I CATEGDA =4 Q 2      ; outpati ent care ( nsc)
  3500   "RTN","RCX FMSUR",64, 0)
  3501    I CATEGDA =3 Q 3      ; nursing  home care  (nsc)
  3502   "RTN","RCX FMSUR",65, 0)
  3503    I CATEGDA =1 Q 4      ; ineligi ble hospit al
  3504   "RTN","RCX FMSUR",66, 0)
  3505    I CATEGDA =9&$G(RX3P ) Q "R"     ; pharmac y reimburs able healt h insuranc e
  3506   "RTN","RCX FMSUR",67, 0)
  3507    I CATEGDA =9 Q 5      ; reimbur sable heal th insuran ce
  3508   "RTN","RCX FMSUR",68, 0)
  3509    I CATEGDA =10&$G(RX3 P) Q "S"      ; pharm acy tort f easor
  3510   "RTN","RCX FMSUR",69, 0)
  3511    I CATEGDA =10 Q 6     ; tort fe asor
  3512   "RTN","RCX FMSUR",70, 0)
  3513    I CATEGDA =6&$G(RX3P ) Q "T"      ;pharmac y workman' s comp
  3514   "RTN","RCX FMSUR",71, 0)
  3515    I CATEGDA =6 Q 7      ; workman s comp
  3516   "RTN","RCX FMSUR",72, 0)
  3517    I CATEGDA =18 Q 8     ; c (mean s test)
  3518   "RTN","RCX FMSUR",73, 0)
  3519    I CATEGDA =2 Q 9      ; emergen cy/humanit arian
  3520   "RTN","RCX FMSUR",74, 0)
  3521    I CATEGDA =7&$G(RX3P ) Q "Q"      ;pharmac y no fault  auto acc
  3522   "RTN","RCX FMSUR",75, 0)
  3523    I CATEGDA =7 Q "A"    ; no faul t auto acc ident
  3524   "RTN","RCX FMSUR",76, 0)
  3525    I CATEGDA =22 Q "B"   ; rx copa y/sc vet
  3526   "RTN","RCX FMSUR",77, 0)
  3527    I CATEGDA =23 Q "C"   ; rx copa y/nsc vet
  3528   "RTN","RCX FMSUR",78, 0)
  3529    I CATEGDA =24 Q "D"   ; nursing  home care  per diem
  3530   "RTN","RCX FMSUR",79, 0)
  3531    I CATEGDA =25 Q "E"   ; hospita l care per  diem
  3532   "RTN","RCX FMSUR",80, 0)
  3533    I CATEGDA =21 Q "F"   ; medicar e
  3534   "RTN","RCX FMSUR",81, 0)
  3535    I CATEGDA =33 Q "G"   ; adult d ay health  care
  3536   "RTN","RCX FMSUR",82, 0)
  3537    I CATEGDA =34 Q "H"   ; domicil iary
  3538   "RTN","RCX FMSUR",83, 0)
  3539    I CATEGDA =35 Q "I"   ; respite  care - in stitutiona l
  3540   "RTN","RCX FMSUR",84, 0)
  3541    I CATEGDA =36 Q "J"   ; respite  care - no n-institut ional
  3542   "RTN","RCX FMSUR",85, 0)
  3543    I CATEGDA =37 Q "K"   ; geriatr ic evaluat ion - inst itutional
  3544   "RTN","RCX FMSUR",86, 0)
  3545    I CATEGDA =38 Q "L"   ; geriatr ic evaluat ion - non- institutio nal
  3546   "RTN","RCX FMSUR",87, 0)
  3547    I CATEGDA =39 Q "M"   ; nursing  home care  - ltc
  3548   "RTN","RCX FMSUR",88, 0)
  3549    I CATEGDA =45 Q "F"   ; Fee Bas is
  3550   "RTN","RCX FMSUR",89, 0)
  3551    Q ""
  3552   "RTN","RCX FMSUR",90, 0)
  3553    ;
  3554   "RTN","RCX FMSUR",91, 0)
  3555    ;
  3556   "RTN","RCX FMSUR",92, 0)
  3557   COLUMN3()  ;  return  the column  3 number
  3558   "RTN","RCX FMSUR",93, 0)
  3559    N AGE,DEC IMAL,DFN,I BCNDATA,TY PEAGE,TYPE CARE,TYPEM EAN,TYPESE RV,VA,VADM ,VAERR
  3560   "RTN","RCX FMSUR",94, 0)
  3561    D DIQ399( BILLDA)
  3562   "RTN","RCX FMSUR",95, 0)
  3563    ;
  3564   "RTN","RCX FMSUR",96, 0)
  3565    ;  PRCA*4 .5*310/DRF
  3566   "RTN","RCX FMSUR",97, 0)
  3567    ;  for Fe e Basis, c olumn3 = 1  (inpatien t) or 2 (o utpatient)
  3568   "RTN","RCX FMSUR",98, 0)
  3569    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
  3570   "RTN","RCX FMSUR",99, 0)
  3571    ;
  3572   "RTN","RCX FMSUR",100 ,0)
  3573    D TYPECAR E
  3574   "RTN","RCX FMSUR",101 ,0)
  3575    ;
  3576   "RTN","RCX FMSUR",102 ,0)
  3577    ;  comput e service  connected  at time of  care (1 d igit binar y)
  3578   "RTN","RCX FMSUR",103 ,0)
  3579    ;  type o f service  connected  is set as  follows:
  3580   "RTN","RCX FMSUR",104 ,0)
  3581    ;         0 = SC Vet                     1  = NSC Vet
  3582   "RTN","RCX FMSUR",105 ,0)
  3583    S TYPESER V=1
  3584   "RTN","RCX FMSUR",106 ,0)
  3585    ;  servic e connecte d at time  of care (. 18) = yes  (1)
  3586   "RTN","RCX FMSUR",107 ,0)
  3587    I $G(IBCN DATA(399,B ILLDA,.18, "I"))=1 S  TYPESERV=0
  3588   "RTN","RCX FMSUR",108 ,0)
  3589    ;
  3590   "RTN","RCX FMSUR",109 ,0)
  3591    S DFN=$P( $G(^PRCA(4 30,BILLDA, 0)),"^",7)
  3592   "RTN","RCX FMSUR",110 ,0)
  3593    D DEM^VAD PT
  3594   "RTN","RCX FMSUR",111 ,0)
  3595    ;
  3596   "RTN","RCX FMSUR",112 ,0)
  3597    ;  comput e means te st at time  of care ( 1 digit bi nary)
  3598   "RTN","RCX FMSUR",113 ,0)
  3599    ;  type o f means te st is set  as follows :
  3600   "RTN","RCX FMSUR",114 ,0)
  3601    ;         0 = Cat A                      1  = Cat C
  3602   "RTN","RCX FMSUR",115 ,0)
  3603    S TYPEMEA N=0
  3604   "RTN","RCX FMSUR",116 ,0)
  3605    I $$BIL^D GMTUB(DFN, $G(IBCNDAT A(399,BILL DA,151,"I" )))=1 S TY PEMEAN=1
  3606   "RTN","RCX FMSUR",117 ,0)
  3607    ;
  3608   "RTN","RCX FMSUR",118 ,0)
  3609    ;  comput e patient  age at tim e of care  (1 digit b inary)
  3610   "RTN","RCX FMSUR",119 ,0)
  3611    ;  type o f age is s et as foll ows:
  3612   "RTN","RCX FMSUR",120 ,0)
  3613    ;         0 = under  65                  1  = 65 and  older
  3614   "RTN","RCX FMSUR",121 ,0)
  3615    S AGE=$$F MDIFF^XLFD T($G(IBCND ATA(399,BI LLDA,151," I")),$P($G (VADM(3)), "^"))\365. 25
  3616   "RTN","RCX FMSUR",122 ,0)
  3617    S TYPEAGE =1
  3618   "RTN","RCX FMSUR",123 ,0)
  3619    I AGE<65  S TYPEAGE= 0
  3620   "RTN","RCX FMSUR",124 ,0)
  3621    ;
  3622   "RTN","RCX FMSUR",125 ,0)
  3623    ;  conver t to decim al  typeca re  typese rv  typeme an  typeag e
  3624   "RTN","RCX FMSUR",126 ,0)
  3625    ;              binar y=  1   1          1          1          1
  3626   "RTN","RCX FMSUR",127 ,0)
  3627    ;             decima l= 16 + 8      +   4      +   2      +   1
  3628   "RTN","RCX FMSUR",128 ,0)
  3629    S DECIMAL =$S(TYPECA RE="11":24 ,TYPECARE= "10":16,TY PECARE="01 ":8,1:0)
  3630   "RTN","RCX FMSUR",129 ,0)
  3631    I TYPESER V S DECIMA L=DECIMAL+ 4
  3632   "RTN","RCX FMSUR",130 ,0)
  3633    I TYPEMEA N S DECIMA L=DECIMAL+ 2
  3634   "RTN","RCX FMSUR",131 ,0)
  3635    I TYPEAGE  S DECIMAL =DECIMAL+1
  3636   "RTN","RCX FMSUR",132 ,0)
  3637    I DECIMAL <10 Q DECI MAL
  3638   "RTN","RCX FMSUR",133 ,0)
  3639    Q $C(65+D ECIMAL-10)
  3640   "RTN","RCX FMSUR",134 ,0)
  3641    ;
  3642   "RTN","RCX FMSUR",135 ,0)
  3643    ;
  3644   "RTN","RCX FMSUR",136 ,0)
  3645   COLUMN4()  ;  return  the column  4 number  (reserved  for future  expansion )
  3646   "RTN","RCX FMSUR",137 ,0)
  3647    Q "Z"
  3648   "RTN","RCX FMSUR",138 ,0)
  3649    ;
  3650   "RTN","RCX FMSUR",139 ,0)
  3651    ;
  3652   "RTN","RCX FMSUR",140 ,0)
  3653   DIQ399(DA)   ;  get d ata from f ile 399
  3654   "RTN","RCX FMSUR",141 ,0)
  3655    N D0,DIC, DIQ,DIQ2,D R
  3656   "RTN","RCX FMSUR",142 ,0)
  3657    K IBCNDAT A
  3658   "RTN","RCX FMSUR",143 ,0)
  3659    S DIQ(0)= "IE",DIC=" ^DGCR(399, ",DIQ="IBC NDATA",DR= ".04;.05;. 18;151;" D  EN^DIQ1
  3660   "RTN","RCX FMSUR",144 ,0)
  3661    Q
  3662   "RTN","RCX FMSUR",145 ,0)
  3663    ;
  3664   "RTN","RCX FMSUR",146 ,0)
  3665    ;
  3666   "RTN","RCX FMSUR",147 ,0)
  3667   TYPECARE ;   compute  type of ca re (2 digi t binary)
  3668   "RTN","RCX FMSUR",148 ,0)
  3669    ;  type o f care is  set as fol lows:
  3670   "RTN","RCX FMSUR",149 ,0)
  3671    ;      00  = inpatie nt (hospit al)    01  = outpatie nt
  3672   "RTN","RCX FMSUR",150 ,0)
  3673    ;      10  = nursing  home             11  = other
  3674   "RTN","RCX FMSUR",151 ,0)
  3675    ;  defaul t is other  if it can not be com puted
  3676   "RTN","RCX FMSUR",152 ,0)
  3677    S TYPECAR E="11"
  3678   "RTN","RCX FMSUR",153 ,0)
  3679    ;  bill c lassificat ion (.05)  = outpatie nt (3) or  human.emer g(opt) (4)
  3680   "RTN","RCX FMSUR",154 ,0)
  3681    I $G(IBCN DATA(399,B ILLDA,.05, "I"))=3!($ G(IBCNDATA (399,BILLD A,.05,"I") )=4) S TYP ECARE="01"  Q
  3682   "RTN","RCX FMSUR",155 ,0)
  3683    ;  locati on of care  (.04) = h ospital in pt or outp t (1)
  3684   "RTN","RCX FMSUR",156 ,0)
  3685    I $G(IBCN DATA(399,B ILLDA,.04, "I"))=1 S  TYPECARE=" 00" Q
  3686   "RTN","RCX FMSUR",157 ,0)
  3687    ;  locati on of care  (.04) = s killed nur sing (nhcu ) (2)
  3688   "RTN","RCX FMSUR",158 ,0)
  3689    I $G(IBCN DATA(399,B ILLDA,.04, "I"))=2 S  TYPECARE=" 10"
  3690   "RTN","RCX FMSUR",159 ,0)
  3691    Q
  3692   "RTN","RCX FMSUR",160 ,0)
  3693    ;
  3694   "RTN","RCX FMSUR",161 ,0)
  3695    ;
  3696   "RTN","RCX FMSUR",162 ,0)
  3697   ADDEDIT ;   enter/edi t revenue  source cod es for fun d 0160A1 b ills.  The se
  3698   "RTN","RCX FMSUR",163 ,0)
  3699    ;  bills  have the r sc entered  by the us er.  The u ser can se lect
  3700   "RTN","RCX FMSUR",164 ,0)
  3701    ;  from r scs in fil e 347.3
  3702   "RTN","RCX FMSUR",165 ,0)
  3703    W !!,"Thi s option s hould be u sed with C AUTION.  T his option  will allo w the"
  3704   "RTN","RCX FMSUR",166 ,0)
  3705    W !,"user  owning th e PRCASVC  supervisor  security  key, to ad d or edit  the"
  3706   "RTN","RCX FMSUR",167 ,0)
  3707    W !,"Reve nue Source  Codes sel ectable fo r non MCCF  bills.  I f an inval id"
  3708   "RTN","RCX FMSUR",168 ,0)
  3709    W !,"Reve nue Source  Code is e ntered or  changed, a ll code sh eets sent  to"
  3710   "RTN","RCX FMSUR",169 ,0)
  3711    W !,"FMS  referencin g the inva lid Revenu e Source C ode will r eject.  Be "
  3712   "RTN","RCX FMSUR",170 ,0)
  3713    W !,"caut ious when  entering n ew Revenue  Source Co des or edi ting exist ing"
  3714   "RTN","RCX FMSUR",171 ,0)
  3715    W !,"Reve nue Source  Codes.  N ew Revenue  Source Co des should  only be a dded"
  3716   "RTN","RCX FMSUR",172 ,0)
  3717    W !,"afte r they hav e been add ed in FMS. "
  3718   "RTN","RCX FMSUR",173 ,0)
  3719    ;
  3720   "RTN","RCX FMSUR",174 ,0)
  3721    I '$D(^XU SEC("PRCAS VC",DUZ))  W !!,"You  are not an  owner of  the PRCASV C security  key." Q
  3722   "RTN","RCX FMSUR",175 ,0)
  3723    ;
  3724   "RTN","RCX FMSUR",176 ,0)
  3725    N %,%Y,C, D,D0,DA,DI ,DIC,DIE,D LAYGO,DQ,D R,RCRJFLAG ,X,X1,X2,X 3,Y
  3726   "RTN","RCX FMSUR",177 ,0)
  3727    ;
  3728   "RTN","RCX FMSUR",178 ,0)
  3729    F  D  Q:$ G(RCRJFLAG )
  3730   "RTN","RCX FMSUR",179 ,0)
  3731    . S (DIC, DIE)="^RC( 347.3,",DI C(0)="QEL" ,DLAYGO=34 7.3
  3732   "RTN","RCX FMSUR",180 ,0)
  3733    . R !!,"S elect REVE NUE SOURCE  CODE: ",X :DTIME
  3734   "RTN","RCX FMSUR",181 ,0)
  3735    . S X1=X, X=$$UPPER^ VALM1(X)
  3736   "RTN","RCX FMSUR",182 ,0)
  3737    . I $E(X) ="?",X?."? " D ^DIC Q :Y<1
  3738   "RTN","RCX FMSUR",183 ,0)
  3739    . I X=""! ($E(X)=U)  S RCRJFLAG =1 Q
  3740   "RTN","RCX FMSUR",184 ,0)
  3741    . 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 
  3742   "RTN","RCX FMSUR",185 ,0)
  3743    . 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
  3744   "RTN","RCX FMSUR",186 ,0)
  3745    . S D="C"  D IX^DIC  Q:Y<1  D U PD Q
  3746   "RTN","RCX FMSUR",187 ,0)
  3747    Q
  3748   "RTN","RCX FMSUR",188 ,0)
  3749   UPD S DIE= "^RC(347.3 ,",DA=+Y,D R=".02;.03 " D ^DIE
  3750   "RTN","RCX FMSUR",189 ,0)
  3751    Q
  3752   "RTN","RCX FMSUR",190 ,0)
  3753    ;
  3754   "RTN","RCX FMSUR",191 ,0)
  3755    ;
  3756   "RTN","RCX FMSUR",192 ,0)
  3757   RSC ;reven ue code (# 430/255)
  3758   "RTN","RCX FMSUR",193 ,0)
  3759    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
  3760   "RTN","RCX FMSUR",194 ,0)
  3761    S X=$P(^R C(347.3,X, 0),"^")
  3762   "RTN","RCX FMSUR",195 ,0)
  3763    Q
  3764   "RTN","RCX FMSUR",196 ,0)
  3765    ;
  3766   "RTN","RCX FMSUR",197 ,0)
  3767   SHOW ;  sh ow/calcula te revenue  source co de for a s elected bi ll
  3768   "RTN","RCX FMSUR",198 ,0)
  3769    W !!,"Thi s option w ill show t he calcula ted Revenu e Source C ode for a  selected"
  3770   "RTN","RCX FMSUR",199 ,0)
  3771    W !,"bill .  The Rev enue Sourc e Code is  only calcu lated for  accrued bi lls in"
  3772   "RTN","RCX FMSUR",200 ,0)
  3773    I DT'<$$A DDPTEDT^PR CAACC() W  !,"funds 5 28701,5287 03,528704, 528709/403 2,528711,5 28713"
  3774   "RTN","RCX FMSUR",201 ,0)
  3775    I DT<$$AD DPTEDT^PRC AACC() W ! ,"funds 52 87.1,5287. 3,5287.4,4 032"
  3776   "RTN","RCX FMSUR",202 ,0)
  3777    ;
  3778   "RTN","RCX FMSUR",203 ,0)
  3779    N %,%Y,BI LLDA,C,DIC ,FUND,I,RC RJFLAG,RSC ,X,Y
  3780   "RTN","RCX FMSUR",204 ,0)
  3781    ;
  3782   "RTN","RCX FMSUR",205 ,0)
  3783    F  D  Q:$ G(RCRJFLAG )
  3784   "RTN","RCX FMSUR",206 ,0)
  3785    .   S DIC ="^PRCA(43 0,",DIC(0) ="QEAM"
  3786   "RTN","RCX FMSUR",207 ,0)
  3787    .   W ! D  ^DIC
  3788   "RTN","RCX FMSUR",208 ,0)
  3789    .   I Y<1  S RCRJFLA G=1 Q
  3790   "RTN","RCX FMSUR",209 ,0)
  3791    .   S BIL LDA=+Y
  3792   "RTN","RCX FMSUR",210 ,0)
  3793    .   S FUN D=$$GETFUN DB^RCXFMSU F(BILLDA,1 )
  3794   "RTN","RCX FMSUR",211 ,0)
  3795    .   W !!, "        B ill Number : ",$P($G( ^PRCA(430, BILLDA,0)) ,"^")
  3796   "RTN","RCX FMSUR",212 ,0)
  3797    .   W !,"                 Fund:  ",FUND
  3798   "RTN","RCX FMSUR",213 ,0)
  3799    .   I '$$ PTACCT^PRC AACC(FUND) ,FUND'=403 2 D  Q
  3800   "RTN","RCX FMSUR",214 ,0)
  3801    .   .   W  !,"  The  Revenue So urce Code  cannot be  calculated  for non-a ccrued bil ls."
  3802   "RTN","RCX FMSUR",215 ,0)
  3803    .   .   W  !,"  The  Revenue So urce Code  for non-ac crued bill s are inpu t by the u ser."
  3804   "RTN","RCX FMSUR",216 ,0)
  3805    .   .   W  !,"  The  Revenue So urce Code  is current ly entered  as: "
  3806   "RTN","RCX FMSUR",217 ,0)
  3807    .   .   S  RSC=$P($G (^PRCA(430 ,BILLDA,11 )),"^",6)
  3808   "RTN","RCX FMSUR",218 ,0)
  3809    .   .   W  $S(RSC="" :"<not ent ered>",1:R SC)
  3810   "RTN","RCX FMSUR",219 ,0)
  3811    .   ;
  3812   "RTN","RCX FMSUR",220 ,0)
  3813    .   S RSC =$$CALCRSC (BILLDA)
  3814   "RTN","RCX FMSUR",221 ,0)
  3815    .   W !," Revenue So urce Code:  ",RSC
  3816   "RTN","RCX FMSUR",222 ,0)
  3817    Q
  3818   "VER")
  3819   8.0^22.0
  3820   "BLD",9717 ,6)
  3821   14^
  3822   **END**
  3823   **END**
  3824  
  3825