RCRFRPT ;EDE/YMG - MULTIPLE REFERRAL PROGRAMS REPORT; 11/02/2022
;;4.5;Accounts Receivable;**412**;Mar 20, 1995;Build 13
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
EN ; entry point
N DAY,POP,ZTDESC,ZTRTN,ZTSAVE,ZTSK,%ZIS
K ^TMP("RCRFRPT",$J)
W !!,"Multiple Referral Programs Report",!
S DAY=$E(DT,6,7)
I (DAY>19)!(DAY<8) D Q
.W !,"WARNING:"
.W !," This report is disabled from the 20th of current month through the 7th of"
.W !," the next month to ensure that the DMC Master File updates have occurred.",!
.D PAUSE^RCRPRPU
.Q
D EXCMSG^RCTCSJR ; Excel display message
; ask for device
K IOP,IO("Q")
S %ZIS="MQ",%ZIS("B")="",POP=0 D ^%ZIS Q:POP
I $D(IO("Q")) D Q ; queued report
.S ZTDESC="Multiple Referral Programs Report",ZTRTN="COMPILE^RCRFRPT"
.S ZTSAVE("ZTREQ")="@"
.D ^%ZTLOAD,HOME^%ZIS
.I $G(ZTSK) W !!,"Report compilation has started with task# ",ZTSK,".",! D PAUSE^RCRPRPU
.Q
D COMPILE
Q
;
COMPILE ; compile report
N AAFLG,BILLNO,DBTR,DEATHDT,DEBTOR,DFN,DMCDT,DMCFLG,HBFLG,HRFSFLG,IENS,INCLUDE,LTRDT1,LTRDT2,LTRDT3,N0,N6,PENFLG,PNAME,PREPDT,PTDONE,RCBAL,RCBILL,RCCAT,RCSTAT
N SC,SCFLG,SSN,TCSPDT,TCSPFLG,TOPDT,TOPFLG,VADM,VAEL,VAMB,Z
S DBTR=0 F S DBTR=$O(^RCD(340,"B",DBTR)) Q:'DBTR D
.I $P(DBTR,";",2)'["DPT(" Q ; debtor is not a patient
.S DEBTOR=$O(^RCD(340,"B",DBTR,"")) Q:'DEBTOR
.I $P($G(^RCD(340,DEBTOR,3)),U,10) Q ; DMC site deletion flag is set
.I $P($G(^RCD(340,DEBTOR,6)),U,2) Q ; TOP referral is stopped
.S DFN=$P(DBTR,";") D DEM^VADPT
.S PNAME=VADM(1) ; patient name
.S SSN=$P(VADM(2),U) ; patient SSN
.S DEATHDT=+$P(VADM(6),U) I DEATHDT Q ; date of death
.D MB^VADPT S AAFLG=$P(VAMB(1),U),HBFLG=$P(VAMB(2),U),PENFLG=$P(VAMB(4),U) ; A&A, Housebound, and pension flags
.S SC=0 D ELIG^VADPT S SCFLG=$P(VAEL(3),U) I SCFLG S SC=$P(VAEL(3),U,2) ; service connected %
.S HRFSFLG=$$CHKHRFS^RCHRFSUT(DFN,DT,DT) I HRFSFLG Q ; was there an active HRFS flag for this patient (1/0)
.S PTDONE=0
.S RCBILL=0 F S RCBILL=$O(^PRCA(430,"C",DEBTOR,RCBILL)) Q:'RCBILL D
..S (DMCFLG,TCSPFLG,TOPFLG)=0
..S DMCDT=+$G(^PRCA(430,RCBILL,12)) S:DMCDT DMCFLG=1 ; DMC referral date; if 0, then bill is not at DMC
..S IENS=RCBILL_","
..S RCSTAT=$$GET1^DIQ(430,IENS,8) I "^ACTIVE^SUSPENDED^CANCELLATION^COLLECTED/CLOSED^"'[(U_RCSTAT_U) Q ; incorect bill status
..S TOPDT=+$G(^PRCA(430,RCBILL,14)) S:TOPDT TOPFLG=1 ; TOP referral date
..S TCSPDT=0,Z=$G(^PRCA(430,RCBILL,15)) I '$P(Z,U,2),'$P(Z,U,7) S TCSPDT=+$P(Z,U) ; TCSP referral date, get if neither recall of stop referral flag is set
..S:TCSPDT TCSPFLG=1
..S INCLUDE=$S(TOPFLG=TCSPFLG:TOPFLG,1:DMCFLG) ; debt at 2 or more referral programs
..I AAFLG!HBFLG!PENFLG S INCLUDE=TOPFLG!TCSPFLG ; debt at treasury when debtor has A&A, housebound, or pension
..I 'INCLUDE Q
..S N0=^PRCA(430,RCBILL,0),BILLNO=$P(N0,U),PREPDT=+$P(N0,U,10) ; Bill # and Bill Prepared Date
..S RCBAL=$$BALANCE^RCRPRPU(RCBILL) ; current bill balance
..S RCCAT=$$GET1^DIQ(430,IENS,2) ; AR category
..S N6=$G(^PRCA(430,RCBILL,6)),LTRDT1=$P(N6,U),LTRDT2=$P(N6,U,2),LTRDT3=$P(N6,U,3)
..I 'PTDONE S ^TMP("RCRFRPT",$J,PNAME,DFN)=SSN_U_$S(SCFLG:SC,1:"No")_U_AAFLG_U_PENFLG_U_HBFLG,PTDONE=1
..S ^TMP("RCRFRPT",$J,PNAME,DFN,BILLNO)=RCCAT_U_RCSTAT_U_RCBAL_U_PREPDT_U_LTRDT1_U_LTRDT2_U_LTRDT3_U_TCSPDT_U_DMCDT_U_TOPDT
..Q
.Q
D PRINT
K ^TMP("RCRFRPT",$J)
I '$D(ZTQUEUED) D ^%ZISC
Q
;
PRINT ; print report
N BDATA,BILLNO,DFN,EXTDT,PDATA,PNAME,SC,Z,Z1
U IO
S EXTDT=$$FMTE^XLFDT(DT)
W !,"Multiple Referral Programs Report^",EXTDT
W !!,"This report includes debts at multiple referral programs along with debts at treasury where the veteran has Aid and Attendance, Housebound or Pension benefits."
W !!,"Name^SSN^Bill #^AR Category^Bill Status^Bill Balance^Bill Prepared Date^Letter 1^Letter 2^Letter 3^TCSP Referral Date^DMC Referral Date^TOP Referral Date^SC %^A&A^VA Pension^Housebound Benefits"
I '$D(^TMP("RCRFRPT",$J)) W !!,"No records found." Q
S PNAME="" F S PNAME=$O(^TMP("RCRFRPT",$J,PNAME)) Q:PNAME="" D
.S DFN=0 F S DFN=$O(^TMP("RCRFRPT",$J,PNAME,DFN)) Q:'DFN D
..S PDATA=^TMP("RCRFRPT",$J,PNAME,DFN)
..S BILLNO="" F S BILLNO=$O(^TMP("RCRFRPT",$J,PNAME,DFN,BILLNO)) Q:BILLNO="" D
...S BDATA=^TMP("RCRFRPT",$J,PNAME,DFN,BILLNO)
...W !,PNAME,U,$P(PDATA,U),U,BILLNO,U,$P(BDATA,U),U,$P(BDATA,U,2),U,$P(BDATA,U,3),U
...F Z=4:1:10 S Z1=$P(BDATA,U,Z) W $S('Z1:"N/A",1:$$FMTE^XLFDT(Z1,"2DZ")),U
...S SC=$P(PDATA,U,2) I SC'="No" S SC=SC_"%"
...W SC,U,$S($P(PDATA,U,3):"Yes",1:"No"),U,$S($P(PDATA,U,4):"Yes",1:"No"),U,$S($P(PDATA,U,5):"Yes",1:"No")
...Q
..Q
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRFRPT 4702 printed Aug 26, 2025@22:03:51 Page 2
RCRFRPT ;EDE/YMG - MULTIPLE REFERRAL PROGRAMS REPORT; 11/02/2022
+1 ;;4.5;Accounts Receivable;**412**;Mar 20, 1995;Build 13
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
EN ; entry point
+1 NEW DAY,POP,ZTDESC,ZTRTN,ZTSAVE,ZTSK,%ZIS
+2 KILL ^TMP("RCRFRPT",$JOB)
+3 WRITE !!,"Multiple Referral Programs Report",!
+4 SET DAY=$EXTRACT(DT,6,7)
+5 IF (DAY>19)!(DAY<8)
Begin DoDot:1
+6 WRITE !,"WARNING:"
+7 WRITE !," This report is disabled from the 20th of current month through the 7th of"
+8 WRITE !," the next month to ensure that the DMC Master File updates have occurred.",!
+9 DO PAUSE^RCRPRPU
+10 QUIT
End DoDot:1
QUIT
+11 ; Excel display message
DO EXCMSG^RCTCSJR
+12 ; ask for device
+13 KILL IOP,IO("Q")
+14 SET %ZIS="MQ"
SET %ZIS("B")=""
SET POP=0
DO ^%ZIS
if POP
QUIT
+15 ; queued report
IF $DATA(IO("Q"))
Begin DoDot:1
+16 SET ZTDESC="Multiple Referral Programs Report"
SET ZTRTN="COMPILE^RCRFRPT"
+17 SET ZTSAVE("ZTREQ")="@"
+18 DO ^%ZTLOAD
DO HOME^%ZIS
+19 IF $GET(ZTSK)
WRITE !!,"Report compilation has started with task# ",ZTSK,".",!
DO PAUSE^RCRPRPU
+20 QUIT
End DoDot:1
QUIT
+21 DO COMPILE
+22 QUIT
+23 ;
COMPILE ; compile report
+1 NEW AAFLG,BILLNO,DBTR,DEATHDT,DEBTOR,DFN,DMCDT,DMCFLG,HBFLG,HRFSFLG,IENS,INCLUDE,LTRDT1,LTRDT2,LTRDT3,N0,N6,PENFLG,PNAME,PREPDT,PTDONE,RCBAL,RCBILL,RCCAT,RCSTAT
+2 NEW SC,SCFLG,SSN,TCSPDT,TCSPFLG,TOPDT,TOPFLG,VADM,VAEL,VAMB,Z
+3 SET DBTR=0
FOR
SET DBTR=$ORDER(^RCD(340,"B",DBTR))
if 'DBTR
QUIT
Begin DoDot:1
+4 ; debtor is not a patient
IF $PIECE(DBTR,";",2)'["DPT("
QUIT
+5 SET DEBTOR=$ORDER(^RCD(340,"B",DBTR,""))
if 'DEBTOR
QUIT
+6 ; DMC site deletion flag is set
IF $PIECE($GET(^RCD(340,DEBTOR,3)),U,10)
QUIT
+7 ; TOP referral is stopped
IF $PIECE($GET(^RCD(340,DEBTOR,6)),U,2)
QUIT
+8 SET DFN=$PIECE(DBTR,";")
DO DEM^VADPT
+9 ; patient name
SET PNAME=VADM(1)
+10 ; patient SSN
SET SSN=$PIECE(VADM(2),U)
+11 ; date of death
SET DEATHDT=+$PIECE(VADM(6),U)
IF DEATHDT
QUIT
+12 ; A&A, Housebound, and pension flags
DO MB^VADPT
SET AAFLG=$PIECE(VAMB(1),U)
SET HBFLG=$PIECE(VAMB(2),U)
SET PENFLG=$PIECE(VAMB(4),U)
+13 ; service connected %
SET SC=0
DO ELIG^VADPT
SET SCFLG=$PIECE(VAEL(3),U)
IF SCFLG
SET SC=$PIECE(VAEL(3),U,2)
+14 ; was there an active HRFS flag for this patient (1/0)
SET HRFSFLG=$$CHKHRFS^RCHRFSUT(DFN,DT,DT)
IF HRFSFLG
QUIT
+15 SET PTDONE=0
+16 SET RCBILL=0
FOR
SET RCBILL=$ORDER(^PRCA(430,"C",DEBTOR,RCBILL))
if 'RCBILL
QUIT
Begin DoDot:2
+17 SET (DMCFLG,TCSPFLG,TOPFLG)=0
+18 ; DMC referral date; if 0, then bill is not at DMC
SET DMCDT=+$GET(^PRCA(430,RCBILL,12))
if DMCDT
SET DMCFLG=1
+19 SET IENS=RCBILL_","
+20 ; incorect bill status
SET RCSTAT=$$GET1^DIQ(430,IENS,8)
IF "^ACTIVE^SUSPENDED^CANCELLATION^COLLECTED/CLOSED^"'[(U_RCSTAT_U)
QUIT
+21 ; TOP referral date
SET TOPDT=+$GET(^PRCA(430,RCBILL,14))
if TOPDT
SET TOPFLG=1
+22 ; TCSP referral date, get if neither recall of stop referral flag is set
SET TCSPDT=0
SET Z=$GET(^PRCA(430,RCBILL,15))
IF '$PIECE(Z,U,2)
IF '$PIECE(Z,U,7)
SET TCSPDT=+$PIECE(Z,U)
+23 if TCSPDT
SET TCSPFLG=1
+24 ; debt at 2 or more referral programs
SET INCLUDE=$SELECT(TOPFLG=TCSPFLG:TOPFLG,1:DMCFLG)
+25 ; debt at treasury when debtor has A&A, housebound, or pension
IF AAFLG!HBFLG!PENFLG
SET INCLUDE=TOPFLG!TCSPFLG
+26 IF 'INCLUDE
QUIT
+27 ; Bill # and Bill Prepared Date
SET N0=^PRCA(430,RCBILL,0)
SET BILLNO=$PIECE(N0,U)
SET PREPDT=+$PIECE(N0,U,10)
+28 ; current bill balance
SET RCBAL=$$BALANCE^RCRPRPU(RCBILL)
+29 ; AR category
SET RCCAT=$$GET1^DIQ(430,IENS,2)
+30 SET N6=$GET(^PRCA(430,RCBILL,6))
SET LTRDT1=$PIECE(N6,U)
SET LTRDT2=$PIECE(N6,U,2)
SET LTRDT3=$PIECE(N6,U,3)
+31 IF 'PTDONE
SET ^TMP("RCRFRPT",$JOB,PNAME,DFN)=SSN_U_$SELECT(SCFLG:SC,1:"No")_U_AAFLG_U_PENFLG_U_HBFLG
SET PTDONE=1
+32 SET ^TMP("RCRFRPT",$JOB,PNAME,DFN,BILLNO)=RCCAT_U_RCSTAT_U_RCBAL_U_PREPDT_U_LTRDT1_U_LTRDT2_U_LTRDT3_U_TCSPDT_U_DMCDT_U_TOPDT
+33 QUIT
End DoDot:2
+34 QUIT
End DoDot:1
+35 DO PRINT
+36 KILL ^TMP("RCRFRPT",$JOB)
+37 IF '$DATA(ZTQUEUED)
DO ^%ZISC
+38 QUIT
+39 ;
PRINT ; print report
+1 NEW BDATA,BILLNO,DFN,EXTDT,PDATA,PNAME,SC,Z,Z1
+2 USE IO
+3 SET EXTDT=$$FMTE^XLFDT(DT)
+4 WRITE !,"Multiple Referral Programs Report^",EXTDT
+5 WRITE !!,"This report includes debts at multiple referral programs along with debts at treasury where the veteran has Aid and Attendance, Housebound or Pension benefits."
+6 WRITE !!,"Name^SSN^Bill #^AR Category^Bill Status^Bill Balance^Bill Prepared Date^Letter 1^Letter 2^Letter 3^TCSP Referral Date^DMC Referral Date^TOP Referral Date^SC %^A&A^VA Pension^Housebound Benefits"
+7 IF '$DATA(^TMP("RCRFRPT",$JOB))
WRITE !!,"No records found."
QUIT
+8 SET PNAME=""
FOR
SET PNAME=$ORDER(^TMP("RCRFRPT",$JOB,PNAME))
if PNAME=""
QUIT
Begin DoDot:1
+9 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("RCRFRPT",$JOB,PNAME,DFN))
if 'DFN
QUIT
Begin DoDot:2
+10 SET PDATA=^TMP("RCRFRPT",$JOB,PNAME,DFN)
+11 SET BILLNO=""
FOR
SET BILLNO=$ORDER(^TMP("RCRFRPT",$JOB,PNAME,DFN,BILLNO))
if BILLNO=""
QUIT
Begin DoDot:3
+12 SET BDATA=^TMP("RCRFRPT",$JOB,PNAME,DFN,BILLNO)
+13 WRITE !,PNAME,U,$PIECE(PDATA,U),U,BILLNO,U,$PIECE(BDATA,U),U,$PIECE(BDATA,U,2),U,$PIECE(BDATA,U,3),U
+14 FOR Z=4:1:10
SET Z1=$PIECE(BDATA,U,Z)
WRITE $SELECT('Z1:"N/A",1:$$FMTE^XLFDT(Z1,"2DZ")),U
+15 SET SC=$PIECE(PDATA,U,2)
IF SC'="No"
SET SC=SC_"%"
+16 WRITE SC,U,$SELECT($PIECE(PDATA,U,3):"Yes",1:"No"),U,$SELECT($PIECE(PDATA,U,4):"Yes",1:"No"),U,$SELECT($PIECE(PDATA,U,5):"Yes",1:"No")
+17 QUIT
End DoDot:3
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT
