RCRPDR ;EDE/YMG - REPAYMENT PLAN DELINQUENT / DEFAULT LETTER REPORTS; 12/28/2020
;;4.5;Accounts Receivable;**378,389**;Mar 20, 1995;Build 36
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
EN(TYPE) ; entry point
;
; TYPE = 0 for delinquent letter report, 1 for default letter report
;
N CLEARQ,EXCEL,POP,ZTDESC,ZTRTN,ZTSAVE,ZTSK,%ZIS
K ^TMP("RCRPDR",$J)
W !!,"Print ",$S(TYPE=1:"Default",1:"Delinquent")," Letter Report",!
; export to Excel?
W !,"Answer Yes to print this report in a Mail-merge compatible format."
W !!,"If you Answer No, the Statement Account Number for the Debtor will not" ; PRCA*4.5*389
W !,"appear on the screen.",!! ; PRCA*4.5*389
S EXCEL=$$ASKEXCEL^RCRPRPU() I EXCEL<0 Q
I 'EXCEL W !!,"This report requires 132 characters",!
I EXCEL D EXCMSG^RCTCSJR ; Display Excel display message I EXCEL
; ask for device
K IOP,IO("Q")
S %ZIS="MQ",%ZIS("B")="",POP=0 D ^%ZIS Q:POP
I $D(IO("Q")) S CLEARQ=$$ASKCLR() Q:CLEARQ<0 D Q ; queued report: ask if print queue should be cleared, then queue task
.S ZTDESC="Repayment Plan "_$S(TYPE=1:"Default",1:"Delinquent")_" Letter Report"
.S ZTRTN="COMPILE^RCRPDR"
.S ZTSAVE("TYPE")="",ZTSAVE("EXCEL")="",ZTSAVE("CLEARQ")="",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 ACCTNUM,ADDRSTR,CRNTDT,DEBT,DEBTOR,N0,NAME,RPIEN,RPPID,TMP,TMPSTR,XREF
S XREF=$S(TYPE:"PRTDEF",1:"PRTDEL")
S RPIEN=0 F S RPIEN=$O(^RCRP(340.5,XREF,1,RPIEN)) Q:'RPIEN D
.S N0=^RCRP(340.5,RPIEN,0)
.S RPPID=$P(N0,U),DEBTOR=+$P(N0,U,2) Q:DEBTOR'>0
.S ADDRSTR=$P($$DADD^RCAMADD(DEBTOR,1),U,1,6) ; ADDRSTR = Str1^Str2^Str3^City^State^ZIP
.S NAME=$$NAM^RCFN01(DEBTOR) Q:NAME="" ; debtor name
.S DEBT=U_$P(NAME,",") ; needed for ACCT^PRCAAPR1, 2nd piece contains last name of the debtor PRCA*4.5*389
.S ACCTNUM="N/A",TMP=$P($G(^RCD(340,DEBTOR,0)),U) I $P(TMP,";",2)="DPT(" S ACCTNUM=$$ACCT^PRCAAPR1($P(TMP,";")) ; PRCA*4.5*389
.S TMPSTR="" S TMPSTR=$$CALC(RPIEN,+$P(N0,U,6)) Q:'+$P(TMPSTR,U) ; PRCA*4.5*389
.S ^TMP("RCRPDR",$J,NAME)=ADDRSTR_U_ACCTNUM ; PRCA*4.5*389
.S ^TMP("RCRPDR",$J,NAME,RPPID)=TMPSTR
.S ^TMP("RCRPDR",$J,NAME,RPPID,"IEN")=RPIEN
.Q
;
D PRINT
K ^TMP("RCRPDR",$J)
Q
;
PRINT ; print report
N ACCTNUM,ADDR,AMNT,CNT,DATA,DATA1,EXTDT,LN,NAME,PAGE,RPPID,UPDT
U IO
S PAGE=0
S EXTDT=$$FMTE^XLFDT(DT)
I EXCEL D
.W !,"Print ",$S(TYPE=1:"Default",1:"Delinquent")," Letter Report;",EXTDT
.W !,"Name^Statement Account Number^Street Address^Address 2^Address 3^City^State^Zip Code^RPP ID^Amount Due" W:'TYPE "^Current Through"
.Q
I 'EXCEL D
.I $E(IOST,1,2)["C-",'$D(ZTQUEUED) W @IOF
.D HDR
.Q
I '$D(^TMP("RCRPDR",$J)) D Q
.I EXCEL W !!,"No records found." Q
.W !!,$$CJ^XLFSTR("No records found.",132)
.Q
S NAME="" F S NAME=$O(^TMP("RCRPDR",$J,NAME)) Q:NAME="" D
.S RPPID="" F S RPPID=$O(^TMP("RCRPDR",$J,NAME,RPPID)) Q:RPPID="" D
..S DATA1=^TMP("RCRPDR",$J,NAME),ADDR=$P(DATA1,U,1,6),ACCTNUM=$P(DATA1,U,7) ; PRCA*4.5*389
..S DATA=^TMP("RCRPDR",$J,NAME,RPPID)
..S AMNT=$FN($P(DATA,U),"",2)
..I 'TYPE S UPDT=$$FMTE^XLFDT($P(DATA,U,2),"5DZ")
..I EXCEL D Q
...W !,NAME,U,ACCTNUM,U,$P(ADDR,U),U,$P(ADDR,U,2),U,$P(ADDR,U,3),U,$P(ADDR,U,4),U,$P(ADDR,U,5),U,$P(ADDR,U,6),U,RPPID,U,AMNT ; PRCA*4.5*389
...I 'TYPE W U,UPDT ; PRCA*4.5*389
...Q
..S LN=LN+1
..W !,$E(NAME,1,26)
..W ?28,$E($P(ADDR,U)_" "_$P(ADDR,U,2)_" "_$P(ADDR,U,3)_", "_$P(ADDR,U,4)_", "_$P(ADDR,U,5)_" "_$P(ADDR,U,6),1,56)
..W ?86,RPPID,?107,AMNT W:'TYPE ?119,UPDT ; PRCA*4.5*389
..I LN>(IOSL-4) D HDR
..Q
.Q
; if not queued, clear print queue if necessary
I '$D(ZTQUEUED),EXCEL W ! S CLEARQ=$$ASKCLR() I CLEARQ=1 D
.; clear print flag in file 340.5
.S NAME="" F S NAME=$O(^TMP("RCRPDR",$J,NAME)) Q:NAME="" D
..S RPPID="" F S RPPID=$O(^TMP("RCRPDR",$J,NAME,RPPID)) Q:RPPID="" D CLRPRNT(^TMP("RCRPDR",$J,NAME,RPPID,"IEN"),TYPE)
..Q
.Q
Q
;
HDR ; print header
I PAGE>0,'$D(ZTQUEUED) D PAUSE^RCRPRPU
W @IOF
S PAGE=PAGE+1,LN=4
W !,"Print ",$S(TYPE=1:"Default",1:"Delinquent")," Letter Report",?66,EXTDT,?120,"Page: ",PAGE
W !!,?11,"Name",?53,"Address",?91,"RPP ID",?105,"Amount Due" W:'TYPE ?117,"Current Through" ; PRCA*4.5*389
W ! D DASH^RCRPRPU(132)
Q
;
CALC(RPIEN,MAMNT) ; calculate amount due and "current through" date
;
; RPIEN - file 340.5 ien
; MAMNT - monthly amount (340.5/.06)
;
; returns amount due ^ "current through" date, or "" if no missing payments were found
;
N CNT,N0,RPDT,TOTAL,UPDT,Z
I $G(MAMNT)'>0 Q ""
; loop backwards from today's date, count entries with no payment and no forbearance
S CNT=0,RPDT=DT F S RPDT=$O(^RCRP(340.5,RPIEN,2,"B",RPDT),-1) Q:'RPDT D
.S Z=$O(^RCRP(340.5,RPIEN,2,"B",RPDT,"")) Q:'Z
.S N0=^RCRP(340.5,RPIEN,2,Z,0) I +$P(N0,U,2)=0,+$P(N0,U,3)=0 S CNT=CNT+1
.Q
I CNT=0 Q "" ; no missing payments found
S CNT=CNT+1 ; add upcoming payment
S UPDT=$O(^RCRP(340.5,RPIEN,2,"B",DT)) ; upcoming payment date
; if today's date is between 21st and 28th, add 2nd upcoming payment and go to the next upcoming payment date
S Z=$E(DT,6,7) I Z>21,Z<28 S CNT=CNT+1,UPDT=$O(^RCRP(340.5,RPIEN,2,"B",UPDT))
S TOTAL=MAMNT*CNT ; total amount owed for missed payments
Q TOTAL_U_UPDT
;
ASKCLR() ; display "clear print queue?" prompt
;
; returns 1 for Yes, 0 for No, -1 for no selection
;
;Ask if the user wishes to clear the queue
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Clear the print queue after printing? (Y/N)"
D ^DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1
Q:+Y'=1 0
;
;Confirm that the user wishes to clear the queue
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Are you sure you wish to clear the queue? If you do, the data in this report will be lost. (Y/N)"
D ^DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1
Q Y
;
CLRPRNT(RPIEN,TYPE) ; clear print delinquent / print default flag for a given RPP
;
; RPIEN - repayment plan ien (file 340.5)
; TYPE - 0 for print delinquent? field (340.5/1.03), 1 for print default? field (340.5/1.02)
;
N FDA,FLD
I RPIEN'>0 Q
S FLD=$S(TYPE:1.02,1:1.03)
L +^RCRP(340.5,RPIEN):5 I '$T Q
S FDA(340.5,RPIEN_",",FLD)=0
D FILE^DIE("","FDA")
; update audit log
D UPDAUDIT^RCRPU2(RPIEN,DT,"E",$S(TYPE:"DF",1:"DL"))
L -^RCRP(340.5,RPIEN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRPDR 6508 printed Apr 09, 2024@20:46:28 Page 2
RCRPDR ;EDE/YMG - REPAYMENT PLAN DELINQUENT / DEFAULT LETTER REPORTS; 12/28/2020
+1 ;;4.5;Accounts Receivable;**378,389**;Mar 20, 1995;Build 36
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
EN(TYPE) ; entry point
+1 ;
+2 ; TYPE = 0 for delinquent letter report, 1 for default letter report
+3 ;
+4 NEW CLEARQ,EXCEL,POP,ZTDESC,ZTRTN,ZTSAVE,ZTSK,%ZIS
+5 KILL ^TMP("RCRPDR",$JOB)
+6 WRITE !!,"Print ",$SELECT(TYPE=1:"Default",1:"Delinquent")," Letter Report",!
+7 ; export to Excel?
+8 WRITE !,"Answer Yes to print this report in a Mail-merge compatible format."
+9 ; PRCA*4.5*389
WRITE !!,"If you Answer No, the Statement Account Number for the Debtor will not"
+10 ; PRCA*4.5*389
WRITE !,"appear on the screen.",!!
+11 SET EXCEL=$$ASKEXCEL^RCRPRPU()
IF EXCEL<0
QUIT
+12 IF 'EXCEL
WRITE !!,"This report requires 132 characters",!
+13 ; Display Excel display message I EXCEL
IF EXCEL
DO EXCMSG^RCTCSJR
+14 ; ask for device
+15 KILL IOP,IO("Q")
+16 SET %ZIS="MQ"
SET %ZIS("B")=""
SET POP=0
DO ^%ZIS
if POP
QUIT
+17 ; queued report: ask if print queue should be cleared, then queue task
IF $DATA(IO("Q"))
SET CLEARQ=$$ASKCLR()
if CLEARQ<0
QUIT
Begin DoDot:1
+18 SET ZTDESC="Repayment Plan "_$SELECT(TYPE=1:"Default",1:"Delinquent")_" Letter Report"
+19 SET ZTRTN="COMPILE^RCRPDR"
+20 SET ZTSAVE("TYPE")=""
SET ZTSAVE("EXCEL")=""
SET ZTSAVE("CLEARQ")=""
SET ZTSAVE("ZTREQ")="@"
+21 DO ^%ZTLOAD
DO HOME^%ZIS
+22 IF $GET(ZTSK)
WRITE !!,"Report compilation has started with task# ",ZTSK,".",!
DO PAUSE^RCRPRPU
+23 QUIT
End DoDot:1
QUIT
+24 DO COMPILE
+25 QUIT
+26 ;
COMPILE ; compile report
+1 NEW ACCTNUM,ADDRSTR,CRNTDT,DEBT,DEBTOR,N0,NAME,RPIEN,RPPID,TMP,TMPSTR,XREF
+2 SET XREF=$SELECT(TYPE:"PRTDEF",1:"PRTDEL")
+3 SET RPIEN=0
FOR
SET RPIEN=$ORDER(^RCRP(340.5,XREF,1,RPIEN))
if 'RPIEN
QUIT
Begin DoDot:1
+4 SET N0=^RCRP(340.5,RPIEN,0)
+5 SET RPPID=$PIECE(N0,U)
SET DEBTOR=+$PIECE(N0,U,2)
if DEBTOR'>0
QUIT
+6 ; ADDRSTR = Str1^Str2^Str3^City^State^ZIP
SET ADDRSTR=$PIECE($$DADD^RCAMADD(DEBTOR,1),U,1,6)
+7 ; debtor name
SET NAME=$$NAM^RCFN01(DEBTOR)
if NAME=""
QUIT
+8 ; needed for ACCT^PRCAAPR1, 2nd piece contains last name of the debtor PRCA*4.5*389
SET DEBT=U_$PIECE(NAME,",")
+9 ; PRCA*4.5*389
SET ACCTNUM="N/A"
SET TMP=$PIECE($GET(^RCD(340,DEBTOR,0)),U)
IF $PIECE(TMP,";",2)="DPT("
SET ACCTNUM=$$ACCT^PRCAAPR1($PIECE(TMP,";"))
+10 ; PRCA*4.5*389
SET TMPSTR=""
SET TMPSTR=$$CALC(RPIEN,+$PIECE(N0,U,6))
if '+$PIECE(TMPSTR,U)
QUIT
+11 ; PRCA*4.5*389
SET ^TMP("RCRPDR",$JOB,NAME)=ADDRSTR_U_ACCTNUM
+12 SET ^TMP("RCRPDR",$JOB,NAME,RPPID)=TMPSTR
+13 SET ^TMP("RCRPDR",$JOB,NAME,RPPID,"IEN")=RPIEN
+14 QUIT
End DoDot:1
+15 ;
+16 DO PRINT
+17 KILL ^TMP("RCRPDR",$JOB)
+18 QUIT
+19 ;
PRINT ; print report
+1 NEW ACCTNUM,ADDR,AMNT,CNT,DATA,DATA1,EXTDT,LN,NAME,PAGE,RPPID,UPDT
+2 USE IO
+3 SET PAGE=0
+4 SET EXTDT=$$FMTE^XLFDT(DT)
+5 IF EXCEL
Begin DoDot:1
+6 WRITE !,"Print ",$SELECT(TYPE=1:"Default",1:"Delinquent")," Letter Report;",EXTDT
+7 WRITE !,"Name^Statement Account Number^Street Address^Address 2^Address 3^City^State^Zip Code^RPP ID^Amount Due"
if 'TYPE
WRITE "^Current Through"
+8 QUIT
End DoDot:1
+9 IF 'EXCEL
Begin DoDot:1
+10 IF $EXTRACT(IOST,1,2)["C-"
IF '$DATA(ZTQUEUED)
WRITE @IOF
+11 DO HDR
+12 QUIT
End DoDot:1
+13 IF '$DATA(^TMP("RCRPDR",$JOB))
Begin DoDot:1
+14 IF EXCEL
WRITE !!,"No records found."
QUIT
+15 WRITE !!,$$CJ^XLFSTR("No records found.",132)
+16 QUIT
End DoDot:1
QUIT
+17 SET NAME=""
FOR
SET NAME=$ORDER(^TMP("RCRPDR",$JOB,NAME))
if NAME=""
QUIT
Begin DoDot:1
+18 SET RPPID=""
FOR
SET RPPID=$ORDER(^TMP("RCRPDR",$JOB,NAME,RPPID))
if RPPID=""
QUIT
Begin DoDot:2
+19 ; PRCA*4.5*389
SET DATA1=^TMP("RCRPDR",$JOB,NAME)
SET ADDR=$PIECE(DATA1,U,1,6)
SET ACCTNUM=$PIECE(DATA1,U,7)
+20 SET DATA=^TMP("RCRPDR",$JOB,NAME,RPPID)
+21 SET AMNT=$FNUMBER($PIECE(DATA,U),"",2)
+22 IF 'TYPE
SET UPDT=$$FMTE^XLFDT($PIECE(DATA,U,2),"5DZ")
+23 IF EXCEL
Begin DoDot:3
+24 ; PRCA*4.5*389
WRITE !,NAME,U,ACCTNUM,U,$PIECE(ADDR,U),U,$PIECE(ADDR,U,2),U,$PIECE(ADDR,U,3),U,$PIECE(ADDR,U,4),U,$PIECE(ADDR,U,5),U,$PIECE(ADDR,U,6),U,RPPID,U,AMNT
+25 ; PRCA*4.5*389
IF 'TYPE
WRITE U,UPDT
+26 QUIT
End DoDot:3
QUIT
+27 SET LN=LN+1
+28 WRITE !,$EXTRACT(NAME,1,26)
+29 WRITE ?28,$EXTRACT($PIECE(ADDR,U)_" "_$PIECE(ADDR,U,2)_" "_$PIECE(ADDR,U,3)_", "_$PIECE(ADDR,U,4)_", "_$PIECE(ADDR,U,5)_" "_$PIECE(ADDR,U,6),1,56)
+30 ; PRCA*4.5*389
WRITE ?86,RPPID,?107,AMNT
if 'TYPE
WRITE ?119,UPDT
+31 IF LN>(IOSL-4)
DO HDR
+32 QUIT
End DoDot:2
+33 QUIT
End DoDot:1
+34 ; if not queued, clear print queue if necessary
+35 IF '$DATA(ZTQUEUED)
IF EXCEL
WRITE !
SET CLEARQ=$$ASKCLR()
IF CLEARQ=1
Begin DoDot:1
+36 ; clear print flag in file 340.5
+37 SET NAME=""
FOR
SET NAME=$ORDER(^TMP("RCRPDR",$JOB,NAME))
if NAME=""
QUIT
Begin DoDot:2
+38 SET RPPID=""
FOR
SET RPPID=$ORDER(^TMP("RCRPDR",$JOB,NAME,RPPID))
if RPPID=""
QUIT
DO CLRPRNT(^TMP("RCRPDR",$JOB,NAME,RPPID,"IEN"),TYPE)
+39 QUIT
End DoDot:2
+40 QUIT
End DoDot:1
+41 QUIT
+42 ;
HDR ; print header
+1 IF PAGE>0
IF '$DATA(ZTQUEUED)
DO PAUSE^RCRPRPU
+2 WRITE @IOF
+3 SET PAGE=PAGE+1
SET LN=4
+4 WRITE !,"Print ",$SELECT(TYPE=1:"Default",1:"Delinquent")," Letter Report",?66,EXTDT,?120,"Page: ",PAGE
+5 ; PRCA*4.5*389
WRITE !!,?11,"Name",?53,"Address",?91,"RPP ID",?105,"Amount Due"
if 'TYPE
WRITE ?117,"Current Through"
+6 WRITE !
DO DASH^RCRPRPU(132)
+7 QUIT
+8 ;
CALC(RPIEN,MAMNT) ; calculate amount due and "current through" date
+1 ;
+2 ; RPIEN - file 340.5 ien
+3 ; MAMNT - monthly amount (340.5/.06)
+4 ;
+5 ; returns amount due ^ "current through" date, or "" if no missing payments were found
+6 ;
+7 NEW CNT,N0,RPDT,TOTAL,UPDT,Z
+8 IF $GET(MAMNT)'>0
QUIT ""
+9 ; loop backwards from today's date, count entries with no payment and no forbearance
+10 SET CNT=0
SET RPDT=DT
FOR
SET RPDT=$ORDER(^RCRP(340.5,RPIEN,2,"B",RPDT),-1)
if 'RPDT
QUIT
Begin DoDot:1
+11 SET Z=$ORDER(^RCRP(340.5,RPIEN,2,"B",RPDT,""))
if 'Z
QUIT
+12 SET N0=^RCRP(340.5,RPIEN,2,Z,0)
IF +$PIECE(N0,U,2)=0
IF +$PIECE(N0,U,3)=0
SET CNT=CNT+1
+13 QUIT
End DoDot:1
+14 ; no missing payments found
IF CNT=0
QUIT ""
+15 ; add upcoming payment
SET CNT=CNT+1
+16 ; upcoming payment date
SET UPDT=$ORDER(^RCRP(340.5,RPIEN,2,"B",DT))
+17 ; if today's date is between 21st and 28th, add 2nd upcoming payment and go to the next upcoming payment date
+18 SET Z=$EXTRACT(DT,6,7)
IF Z>21
IF Z<28
SET CNT=CNT+1
SET UPDT=$ORDER(^RCRP(340.5,RPIEN,2,"B",UPDT))
+19 ; total amount owed for missed payments
SET TOTAL=MAMNT*CNT
+20 QUIT TOTAL_U_UPDT
+21 ;
ASKCLR() ; display "clear print queue?" prompt
+1 ;
+2 ; returns 1 for Yes, 0 for No, -1 for no selection
+3 ;
+4 ;Ask if the user wishes to clear the queue
+5 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+6 SET DIR(0)="Y"
SET DIR("B")="NO"
+7 SET DIR("A")="Clear the print queue after printing? (Y/N)"
+8 DO ^DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT -1
+9 if +Y'=1
QUIT 0
+10 ;
+11 ;Confirm that the user wishes to clear the queue
+12 SET DIR(0)="Y"
SET DIR("B")="NO"
+13 SET DIR("A")="Are you sure you wish to clear the queue? If you do, the data in this report will be lost. (Y/N)"
+14 DO ^DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT -1
+15 QUIT Y
+16 ;
CLRPRNT(RPIEN,TYPE) ; clear print delinquent / print default flag for a given RPP
+1 ;
+2 ; RPIEN - repayment plan ien (file 340.5)
+3 ; TYPE - 0 for print delinquent? field (340.5/1.03), 1 for print default? field (340.5/1.02)
+4 ;
+5 NEW FDA,FLD
+6 IF RPIEN'>0
QUIT
+7 SET FLD=$SELECT(TYPE:1.02,1:1.03)
+8 LOCK +^RCRP(340.5,RPIEN):5
IF '$TEST
QUIT
+9 SET FDA(340.5,RPIEN_",",FLD)=0
+10 DO FILE^DIE("","FDA")
+11 ; update audit log
+12 DO UPDAUDIT^RCRPU2(RPIEN,DT,"E",$SELECT(TYPE:"DF",1:"DL"))
+13 LOCK -^RCRP(340.5,RPIEN)
+14 QUIT
