Routine: RCRFRPT

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.

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

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

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRFRPT   4702     printed  Mar 13, 2025@20:52:42                                                                                                                                                                                                     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

RCRFRPT.m