RCRPSTR ;EDE/YMG - REPAYMENT PLAN STATUS REPORT; 11/30/2020
;;4.5;Accounts Receivable;**381,390,396,378,389**;Mar 20, 1995;Build 36
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
EN ; entry point
N EXCEL,FILTER,POP,SORT,ZTDESC,ZTRTN,ZTSAVE,ZTSK,%ZIS
K ^TMP("RCRPSTR",$J)
W !!,"Repayment Plan Status Report",!
; sort by?
S SORT=$$ASKSORT() I SORT=-1 Q
; filter by?
S FILTER=$$ASKFLTR() I FILTER=-1 Q
; export to Excel?
S EXCEL=$$ASKEXCEL^RCRPRPU() I EXCEL<0 Q
;Device settings printout
I EXCEL D EXCMSG^RCTCSJR ; Display Excel display message
I 'EXCEL W !!,"This report requires 132 column display.",!
; 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="Repayment Plan Status Report",ZTRTN="COMPILE^RCRPSTR"
.S ZTSAVE("FILTER")="",ZTSAVE("SORT")="",ZTSAVE("EXCEL")="",ZTSAVE("ZTREQ")="@"
.D ^%ZTLOAD,HOME^%ZIS
.I $G(ZTSK) W !!,"Report compilation has started with task# ",ZTSK,".",! D PAUSE^RCRPRPU
.Q
D COMPILE
;
Q
;
ASKSORT() ; display "sort by" prompt
;
; returns N for debtor name, S for status, A for account balance, -1 for user exit / timeout
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="SA^N:Name;S:Status;A:Account Balance",DIR("B")="N"
S DIR("A")="Sort By Debtor (N)ame, (S)tatus or (A)ccount Balance: "
D ^DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1
Q Y
;
ASKFLTR() ; display "filter by" prompt
;
; returns "N ^ start name ^ end name" for debtor name,
; "S ^ selected statuses ^ min days in status ^ max days in status" for status,
; "U" for no filter,
; -1 for user exit / timeout
;
N RES,STOP,Z,RCANS
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="SA^N:Name;S:Status;U:Unfiltered",DIR("B")="S"
S DIR("A")="Filter By Debtor (N)ame, (S)tatus or (U)nfiltered: "
S STOP=0 F D Q:STOP
.D ^DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) S RES=-1,STOP=1 Q
.S RES=Y
.I RES="N" D Q
..S Z=$$INTV ; Ask for the First and last name
..I Z=-1 S RES=-1,STOP=1 Q
..S $P(RES,U,2)=$P(Z,U),$P(RES,U,3)=$P(Z,U,2),STOP=1
..Q
.I RES="S" D
..S Z=$$ASKSTAT() I (Z=-1)!(Z="Q") S RES=-1,STOP=1 Q
..S $P(RES,U,2)=Z
..S Z=$$ASKDAYS() I Z=-1 S RES=-1,STOP=1 Q
..S $P(RES,U,3)=Z
..S Z=$$ASKDAYS1($P(RES,U,3)) I Z=-1 S RES=-1,STOP=1 Q ; PRCA*4.5*389
..S $P(RES,U,4)=Z,STOP=1
..Q
.S STOP=1
.Q
Q RES
;
ASKNM(SNAME) ; display "start with name" / "end with name" prompts
;
; SNAME - starting name (selected at "start with name" prompt), used in screen, optional
;
; returns selected debtor name or -1 for no selection / user exit / timeout
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S SNAME=$G(SNAME,"")
S DIR(0)="PAO^340:EBS"
S DIR("A")=$S(SNAME="":"Start",1:"End")_" with name: "
I SNAME'="" S DIR("S")="I $$NAM^RCFN01(Y)]"""_SNAME_""""
D ^DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1
Q $$NAM^RCFN01($P(Y,U))
;
ASKSTAT() ; display "which statuses" prompt
;
; returns selected statuses (comma separated list of internal codes from 340.5/.07) or -1 for no selection / user exit / timeout
;
N RES,SEL,STOP,STSTR
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S STSTR="NCLDFTSP"
S DIR(0)="SAO^A:All;N:New;C:Current;L:Late;D:Delinquent;P:Paid in Full;S:Closed;F:Defaulted;T:Terminated;U:Continue;Q:Quit"
S DIR("A",1)=""
S DIR("A",2)="Statuses available:"
S DIR("A",3)=" (A)ll, (N)ew, (C)urrent, (L)ate, (D)elinquent, (P)aid in Full, Clo(S)ed,"
S DIR("A",4)=" De(F)aulted, (T)erminated,"
S DIR("A",5)=""
S DIR("A",6)=""
S DIR("A",7)=""
S DIR("A")="Select Status to add, Enter to continue or (Q)uit? "
S (RES,SEL)="",STOP=0 F D Q:STOP
.I SEL'="" S DIR("A",6)="Statuses currently selected: "_SEL
.D ^DIR
.I Y="" S STOP=1 Q ;User is ready to enter the days.
.I $D(DUOUT)!$D(DIROUT) S RES=-1,STOP=1 Q ;User issued exit command, leave utilitystandard time out or ^ escape
.I $D(DIRUT)!$D(DTOUT) S STOP=1 Q ;standard time out or ^ escape
.I Y="A" D Q ;User selected all available statuses for report
..S RES="1,2,3,4,7,8,5,6"
..S SEL="New,Current,Late,Delinquent,Paid in Full,Closed,Defaulted,Terminated"
..S STOP=1
.I Y="Q" S RES=-1,STOP=1 Q
.I Y="U" S STOP=1 Q
.I SEL'[Y(0) D
..S RES=RES_$S(RES'="":","_($F(STSTR,Y)-1),1:$F(STSTR,Y)-1)
..S SEL=SEL_$S(SEL'="":", "_Y(0),1:Y(0))
..Q
.I $L(RES,",")=8 S STOP=1 ; all statuses selected - we're done
.Q
Q $S(RES="":-1,1:RES)
;
ASKDAYS() ; display "min. days in status" prompt
;
; returns min. # of days in status or -1 for no selection / user exit / timeout
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
W !
S DIR(0)="NA^0:999:0"
S DIR("A")="Enter the Minimum # of Days in Status or ^ to quit: "
D ^DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1
Q Y
;
ASKDAYS1(MINDAYS) ; display "max. days in status" prompt PRCA*4.5*389
;
; returns max. # of days in status or -1 for no selection / user exit / timeout
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
W !
S DIR(0)="NAO^"_MINDAYS_":999:0"
S DIR("A")="Enter the Maximum # of Days in Status or ^ to quit: "
D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q -1
Q Y
;
COMPILE ; compile report
N BEGDT,CNT,ENDDT,NAME,RPIEN,STATDT,STATUS,STLIST,Z
;
S CNT=0
I $P(FILTER,U)="S" D
.; filtering by statuses
.S BEGDT=$$FMADD^XLFDT(DT,-$P(FILTER,U,3),,1) ; date to begin the search with
.S Z=$P(FILTER,U,4),ENDDT="" I Z>0 S ENDDT=$$FMADD^XLFDT(DT,-$P(FILTER,U,4),,-1) ; date to end the search with PRCA*4.5*389
.S STLIST=$P(FILTER,U,2) F Z=1:1:$L(STLIST,",") S STATUS=$P(STLIST,",",Z) D
..S STATDT=BEGDT F S STATDT=$O(^RCRP(340.5,"D",STATUS,STATDT),-1) Q:'STATDT!(ENDDT'=""&(STATDT<ENDDT)) D ; PRCA*4.5*389
...S RPIEN="" F S RPIEN=$O(^RCRP(340.5,"D",STATUS,STATDT,RPIEN)) Q:'RPIEN S CNT=CNT+1 D GETDATA(RPIEN,CNT)
...Q
..Q
.Q
I $P(FILTER,U)="N"!($P(FILTER,U)="U") D
.; filtering by name or no filter
.S Z="" F S Z=$O(^RCRP(340.5,"B",Z)) Q:'Z D
..S RPIEN=$O(^RCRP(340.5,"B",Z,"")) Q:'RPIEN
..I $P(FILTER,U)="N" S NAME=$$NAM^RCFN01($P(^RCRP(340.5,RPIEN,0),U,2)) Q:$P(FILTER,U,2)]NAME Q:NAME]$P(FILTER,U,3)
..S CNT=CNT+1 D GETDATA(RPIEN,CNT)
..Q
.Q
D PRINT
K ^TMP("RCRPSTR",$J)
Q
;
GETDATA(RPIEN,CNT) ; fetch data and put it into ^TMP global
;
; RPIEN - file 340.5 ien
; CNT - sequential # of ^TMP entry to create
;
N AMNT,DAYS,DEBTOR,N0,MED,SSN,TMPSTR,Z,ORPLNDT,RMNOPY
I RPIEN'>0!(CNT'>0) Q
S N0=^RCRP(340.5,RPIEN,0) ; 0-node in file 340.5
S DEBTOR=$P(N0,U,2) ; pointer to file 340
S ORPLNDT=$P(N0,U,3) ; Original Plan Date (Creation Date)
S NAME=$$NAM^RCFN01(DEBTOR) Q:NAME="" ; debtor name
S MED=1 I DEBTOR>0,$P($P(^RCD(340,DEBTOR,0),U),";",2)'="DPT(" S MED=0 ; non-medical debt PRCA*4.5*389
S SSN=$$SSN^RCFN01(DEBTOR) ; debtor SSN
S AMNT=$$CBAL^RCRPU3(RPIEN,+$P(N0,U,11)) ; amount owed
S DAYS=$$FMDIFF^XLFDT(DT,$P(N0,U,8)) ; days in status
S RMNOPY=$$REMPMNTS^RCRPU3(RPIEN,$P(N0,U,6)) ; remaining # payments
; each entry is: debtor name ^ ssn ^ repayment plan ID ^ Original Plan Date ^ status (internal) ^ status date ^ days in status ^ last payment date ^ # of payments ^
; remaining balance ^ at CS? ^ # of forbearances ^ medical debt (1/0)
S TMPSTR=NAME_U_SSN_U_$P(N0,U)_U_ORPLNDT_U_$P(N0,U,7)_U_$P(N0,U,8)_U_DAYS
S TMPSTR=TMPSTR_U_$O(^RCRP(340.5,RPIEN,3,"B",""),-1) ; last payment date
S TMPSTR=TMPSTR_U_RMNOPY_U_AMNT_U_$P($G(^RCRP(340.5,RPIEN,1)),U,4)_U_$P(N0,U,9)_U_MED
; add a new entry to ^TMP global
S ^TMP("RCRPSTR",$J,CNT)=TMPSTR
S Z=$S(SORT="N":NAME,SORT="S":$$EXTERNAL^DILFD(340.5,.07,,$P(N0,U,7)),1:AMNT) Q:Z=""
S ^TMP("RCRPSTR",$J,"IDX",Z,DAYS,CNT)=""
Q
;
PRINT ; print report
N ATCS,BAL,CNT,DATA,DAYS,EXTDT,LN,NAME,PAGE,SSN,STATUS,Z,Z1,QUIT
U IO
S PAGE=0
S EXTDT=$$FMTE^XLFDT(DT)
S QUIT=0
I EXCEL D
.W !,"Repayment Plan Status Report^",EXTDT,U,$$FLTRSTR(),U,$$SORTSTR() ; PRCA*4.5*389
.W !,"Name^SSN^RPP ID^Orig Plan date^Status^Status date^Days in status^Last payment^Current plan length^Remaining balance^CS^Forbearances" ; PRCA*4.5*389
.Q
I 'EXCEL D
.I $E(IOST,1,2)["C-",'$D(ZTQUEUED) W @IOF
.D HDR
.Q
I '$D(^TMP("RCRPSTR",$J)) D Q
.I EXCEL W !!,"No records found." Q
.W !!,$$CJ^XLFSTR("No records found.",132)
.Q
S Z="" F S Z=$O(^TMP("RCRPSTR",$J,"IDX",Z)) Q:Z="" D Q:$G(QUIT)
.S DAYS="" F S DAYS=$O(^TMP("RCRPSTR",$J,"IDX",Z,DAYS),-1) Q:DAYS="" D Q:$G(QUIT)
..S CNT=0 F S CNT=$O(^TMP("RCRPSTR",$J,"IDX",Z,DAYS,CNT)) Q:'CNT D Q:$G(QUIT)
...S DATA=^TMP("RCRPSTR",$J,CNT),NAME=$S($P(DATA,U,13):"",1:"*")_$P(DATA,U) ; PRCA*4.5*389
...; convert status code
...S Z1=$P(DATA,U,5),STATUS=$S(Z1=1:"NEW",Z1=2:"CURR",Z1=3:"LATE",Z1=4:"DELQ",Z1=5:"DEF",Z1=6:"TERM",Z1=7:"CLOS",Z1=8:"PAID",1:"")
...; format remaining balance
...S BAL=$FN($P(DATA,U,10),"",2)
...; convert "at CS" value
...S ATCS=$S($P(DATA,U,11):"Y",1:"N")
...; format SSN to last 4 digits
...S Z1=$P(DATA,U,2),SSN=$E(Z1,$L(Z1)-3,$L(Z1)) I SSN'>0 S SSN="N/A"
...I EXCEL D Q
....W !,NAME,U,SSN,U,$P(DATA,U,3),U,$$FMTE^XLFDT($P(DATA,U,4),"2DZ"),U,STATUS,U,$$FMTE^XLFDT($P(DATA,U,6),"2DZ"),U,$P(DATA,U,7),U ; PRCA*4.5*389
....W $$FMTE^XLFDT($P(DATA,U,8),"2DZ"),U,$P(DATA,U,9),U,BAL,U,ATCS,U,$P(DATA,U,12) ;
....Q
...S LN=LN+1
...W !,$E(NAME,1,30),?31,SSN,?37,$P(DATA,U,3),?57,$$FMTE^XLFDT($P(DATA,U,4),"2DZ"),?67,STATUS,?73,$$FMTE^XLFDT($P(DATA,U,6),"2DZ"),?83,$P(DATA,U,7),?92 ; PRCA*4.5*389
...W $$FMTE^XLFDT($P(DATA,U,8),"2DZ"),?102,$P(DATA,U,9),?112,$$CJ^XLFSTR("$"_BAL,13),?123,ATCS,?127,$P(DATA,U,12) ; PRCA*4.5*389
...I LN>(IOSL-3) D HDR I $G(QUIT) Q
...Q
..Q
.Q
I PAGE>0,'$D(ZTQUEUED) D PAUSE^RCRPRPU W @IOF
Q
;
HDR ; print header
I PAGE>0,'$D(ZTQUEUED) D PAUSE^RCRPU W @IOF I $G(QUIT) Q
S PAGE=PAGE+1,LN=9 ; PRCA*4.5*389
W !,"Repayment Plan Status Report",?66,EXTDT,?120,"Page: ",PAGE
W !,$$FLTRSTR()
W !,$$SORTSTR()
W !!,"* Indicates a non-medical debt repayment plan" ; PRCA*4.5*389
W !!," For-"
W !," Original Status Days in Last Cur plan Remaining bear-"
W !,"Name SSN RPP ID Plan Dt Stat date status payment length balance CS ances"
W ! D DASH^RCRPRPU(132)
Q
;
FLTRSTR() ; returns "Filtered by" string to print
N STR,Z
S STR="Filtered by: "
I $P(FILTER,U)="U" S STR=STR_"No filter"
I $P(FILTER,U)="N" S STR=STR_"Debtor name (from "_$P(FILTER,U,2)_" to "_$P(FILTER,U,3)_")"
I $P(FILTER,U)="S" D
.S STR=STR_"Status ("
.F Z=1:1:$L($P(FILTER,U,2),",") S STR=STR_$S(Z>1:", ",1:"")_$$EXTERNAL^DILFD(340.5,.07,,$P($P(FILTER,U,2),",",Z)) ; PRCA*4.5*378
.S STR=STR_"), "_$S(+$P(FILTER,U,4)>0:"from "_$P(FILTER,U,3)_" to "_$P(FILTER,U,4),1:"at least "_$P(FILTER,U,3)) ; PRCA*4.5*389
.S STR=STR_" days in status" ; PRCA*4.5*389
.Q
Q STR
;
SORTSTR() ; returns "Sorted by" string to print
N STR
S STR="Sorted by: "_$S(SORT="N":"Debtor name",SORT="S":"Status",1:"Account balance")
Q STR
;
; Select name range
INTV() ; Selects the range of names
; Output: First value ^ Last Value OR -1
;
N RCFRST,RCLAST,X
;
S (RCFRST,RCLAST)=""
FRST W !!?3,"START WITH NAME: FIRST// " R X:DTIME I '$T!(X["^") Q -1
I $E(X)="?" D HFST(1) G FRST
S RCFRST=X
LAST W !?8,"GO TO NAME: LAST// " R X:DTIME I '$T!(X["^") Q -1
I $E(X)="?" D HFST(2) G LAST
I X="" S RCLAST="zzzzz" G QINT
I RCFRST]X D G LAST
.W *7,!!?7,"The LAST value must follow the FIRST.",!
S RCLAST=X
;
QINT Q (RCFRST_"^"_RCLAST)
;
HFST(RCVAL) ; - 'START WITH PATIENT/DEBTOR...' prompt
N RCPRMPT
S RCPRMPT="First" S:RCVAL=2 RCPRMPT="Last"
;
W !!," Enter a valid field value, or"
W !," '<CR>' - To start from the '"_RCPRMPT_"' value for this field"
W !," '^' - To quit this option"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRPSTR 12203 printed Apr 09, 2024@20:44:13 Page 2
RCRPSTR ;EDE/YMG - REPAYMENT PLAN STATUS REPORT; 11/30/2020
+1 ;;4.5;Accounts Receivable;**381,390,396,378,389**;Mar 20, 1995;Build 36
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
EN ; entry point
+1 NEW EXCEL,FILTER,POP,SORT,ZTDESC,ZTRTN,ZTSAVE,ZTSK,%ZIS
+2 KILL ^TMP("RCRPSTR",$JOB)
+3 WRITE !!,"Repayment Plan Status Report",!
+4 ; sort by?
+5 SET SORT=$$ASKSORT()
IF SORT=-1
QUIT
+6 ; filter by?
+7 SET FILTER=$$ASKFLTR()
IF FILTER=-1
QUIT
+8 ; export to Excel?
+9 SET EXCEL=$$ASKEXCEL^RCRPRPU()
IF EXCEL<0
QUIT
+10 ;Device settings printout
+11 ; Display Excel display message
IF EXCEL
DO EXCMSG^RCTCSJR
+12 IF 'EXCEL
WRITE !!,"This report requires 132 column display.",!
+13 ; ask for device
+14 KILL IOP,IO("Q")
+15 SET %ZIS="MQ"
SET %ZIS("B")=""
SET POP=0
DO ^%ZIS
if POP
QUIT
+16 ; queued report
IF $DATA(IO("Q"))
Begin DoDot:1
+17 SET ZTDESC="Repayment Plan Status Report"
SET ZTRTN="COMPILE^RCRPSTR"
+18 SET ZTSAVE("FILTER")=""
SET ZTSAVE("SORT")=""
SET ZTSAVE("EXCEL")=""
SET ZTSAVE("ZTREQ")="@"
+19 DO ^%ZTLOAD
DO HOME^%ZIS
+20 IF $GET(ZTSK)
WRITE !!,"Report compilation has started with task# ",ZTSK,".",!
DO PAUSE^RCRPRPU
+21 QUIT
End DoDot:1
QUIT
+22 DO COMPILE
+23 ;
+24 QUIT
+25 ;
ASKSORT() ; display "sort by" prompt
+1 ;
+2 ; returns N for debtor name, S for status, A for account balance, -1 for user exit / timeout
+3 ;
+4 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+5 SET DIR(0)="SA^N:Name;S:Status;A:Account Balance"
SET DIR("B")="N"
+6 SET DIR("A")="Sort By Debtor (N)ame, (S)tatus or (A)ccount Balance: "
+7 DO ^DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT -1
+8 QUIT Y
+9 ;
ASKFLTR() ; display "filter by" prompt
+1 ;
+2 ; returns "N ^ start name ^ end name" for debtor name,
+3 ; "S ^ selected statuses ^ min days in status ^ max days in status" for status,
+4 ; "U" for no filter,
+5 ; -1 for user exit / timeout
+6 ;
+7 NEW RES,STOP,Z,RCANS
+8 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+9 SET DIR(0)="SA^N:Name;S:Status;U:Unfiltered"
SET DIR("B")="S"
+10 SET DIR("A")="Filter By Debtor (N)ame, (S)tatus or (U)nfiltered: "
+11 SET STOP=0
FOR
Begin DoDot:1
+12 DO ^DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET RES=-1
SET STOP=1
QUIT
+13 SET RES=Y
+14 IF RES="N"
Begin DoDot:2
+15 ; Ask for the First and last name
SET Z=$$INTV
+16 IF Z=-1
SET RES=-1
SET STOP=1
QUIT
+17 SET $PIECE(RES,U,2)=$PIECE(Z,U)
SET $PIECE(RES,U,3)=$PIECE(Z,U,2)
SET STOP=1
+18 QUIT
End DoDot:2
QUIT
+19 IF RES="S"
Begin DoDot:2
+20 SET Z=$$ASKSTAT()
IF (Z=-1)!(Z="Q")
SET RES=-1
SET STOP=1
QUIT
+21 SET $PIECE(RES,U,2)=Z
+22 SET Z=$$ASKDAYS()
IF Z=-1
SET RES=-1
SET STOP=1
QUIT
+23 SET $PIECE(RES,U,3)=Z
+24 ; PRCA*4.5*389
SET Z=$$ASKDAYS1($PIECE(RES,U,3))
IF Z=-1
SET RES=-1
SET STOP=1
QUIT
+25 SET $PIECE(RES,U,4)=Z
SET STOP=1
+26 QUIT
End DoDot:2
+27 SET STOP=1
+28 QUIT
End DoDot:1
if STOP
QUIT
+29 QUIT RES
+30 ;
ASKNM(SNAME) ; display "start with name" / "end with name" prompts
+1 ;
+2 ; SNAME - starting name (selected at "start with name" prompt), used in screen, optional
+3 ;
+4 ; returns selected debtor name or -1 for no selection / user exit / timeout
+5 ;
+6 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+7 SET SNAME=$GET(SNAME,"")
+8 SET DIR(0)="PAO^340:EBS"
+9 SET DIR("A")=$SELECT(SNAME="":"Start",1:"End")_" with name: "
+10 IF SNAME'=""
SET DIR("S")="I $$NAM^RCFN01(Y)]"""_SNAME_""""
+11 DO ^DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT -1
+12 QUIT $$NAM^RCFN01($PIECE(Y,U))
+13 ;
ASKSTAT() ; display "which statuses" prompt
+1 ;
+2 ; returns selected statuses (comma separated list of internal codes from 340.5/.07) or -1 for no selection / user exit / timeout
+3 ;
+4 NEW RES,SEL,STOP,STSTR
+5 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+6 SET STSTR="NCLDFTSP"
+7 SET DIR(0)="SAO^A:All;N:New;C:Current;L:Late;D:Delinquent;P:Paid in Full;S:Closed;F:Defaulted;T:Terminated;U:Continue;Q:Quit"
+8 SET DIR("A",1)=""
+9 SET DIR("A",2)="Statuses available:"
+10 SET DIR("A",3)=" (A)ll, (N)ew, (C)urrent, (L)ate, (D)elinquent, (P)aid in Full, Clo(S)ed,"
+11 SET DIR("A",4)=" De(F)aulted, (T)erminated,"
+12 SET DIR("A",5)=""
+13 SET DIR("A",6)=""
+14 SET DIR("A",7)=""
+15 SET DIR("A")="Select Status to add, Enter to continue or (Q)uit? "
+16 SET (RES,SEL)=""
SET STOP=0
FOR
Begin DoDot:1
+17 IF SEL'=""
SET DIR("A",6)="Statuses currently selected: "_SEL
+18 DO ^DIR
+19 ;User is ready to enter the days.
IF Y=""
SET STOP=1
QUIT
+20 ;User issued exit command, leave utilitystandard time out or ^ escape
IF $DATA(DUOUT)!$DATA(DIROUT)
SET RES=-1
SET STOP=1
QUIT
+21 ;standard time out or ^ escape
IF $DATA(DIRUT)!$DATA(DTOUT)
SET STOP=1
QUIT
+22 ;User selected all available statuses for report
IF Y="A"
Begin DoDot:2
+23 SET RES="1,2,3,4,7,8,5,6"
+24 SET SEL="New,Current,Late,Delinquent,Paid in Full,Closed,Defaulted,Terminated"
+25 SET STOP=1
End DoDot:2
QUIT
+26 IF Y="Q"
SET RES=-1
SET STOP=1
QUIT
+27 IF Y="U"
SET STOP=1
QUIT
+28 IF SEL'[Y(0)
Begin DoDot:2
+29 SET RES=RES_$SELECT(RES'="":","_($FIND(STSTR,Y)-1),1:$FIND(STSTR,Y)-1)
+30 SET SEL=SEL_$SELECT(SEL'="":", "_Y(0),1:Y(0))
+31 QUIT
End DoDot:2
+32 ; all statuses selected - we're done
IF $LENGTH(RES,",")=8
SET STOP=1
+33 QUIT
End DoDot:1
if STOP
QUIT
+34 QUIT $SELECT(RES="":-1,1:RES)
+35 ;
ASKDAYS() ; display "min. days in status" prompt
+1 ;
+2 ; returns min. # of days in status or -1 for no selection / user exit / timeout
+3 ;
+4 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+5 WRITE !
+6 SET DIR(0)="NA^0:999:0"
+7 SET DIR("A")="Enter the Minimum # of Days in Status or ^ to quit: "
+8 DO ^DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT -1
+9 QUIT Y
+10 ;
ASKDAYS1(MINDAYS) ; display "max. days in status" prompt PRCA*4.5*389
+1 ;
+2 ; returns max. # of days in status or -1 for no selection / user exit / timeout
+3 ;
+4 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+5 WRITE !
+6 SET DIR(0)="NAO^"_MINDAYS_":999:0"
+7 SET DIR("A")="Enter the Maximum # of Days in Status or ^ to quit: "
+8 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT -1
+9 QUIT Y
+10 ;
COMPILE ; compile report
+1 NEW BEGDT,CNT,ENDDT,NAME,RPIEN,STATDT,STATUS,STLIST,Z
+2 ;
+3 SET CNT=0
+4 IF $PIECE(FILTER,U)="S"
Begin DoDot:1
+5 ; filtering by statuses
+6 ; date to begin the search with
SET BEGDT=$$FMADD^XLFDT(DT,-$PIECE(FILTER,U,3),,1)
+7 ; date to end the search with PRCA*4.5*389
SET Z=$PIECE(FILTER,U,4)
SET ENDDT=""
IF Z>0
SET ENDDT=$$FMADD^XLFDT(DT,-$PIECE(FILTER,U,4),,-1)
+8 SET STLIST=$PIECE(FILTER,U,2)
FOR Z=1:1:$LENGTH(STLIST,",")
SET STATUS=$PIECE(STLIST,",",Z)
Begin DoDot:2
+9 ; PRCA*4.5*389
SET STATDT=BEGDT
FOR
SET STATDT=$ORDER(^RCRP(340.5,"D",STATUS,STATDT),-1)
if 'STATDT!(ENDDT'=""&(STATDT<ENDDT))
QUIT
Begin DoDot:3
+10 SET RPIEN=""
FOR
SET RPIEN=$ORDER(^RCRP(340.5,"D",STATUS,STATDT,RPIEN))
if 'RPIEN
QUIT
SET CNT=CNT+1
DO GETDATA(RPIEN,CNT)
+11 QUIT
End DoDot:3
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 IF $PIECE(FILTER,U)="N"!($PIECE(FILTER,U)="U")
Begin DoDot:1
+15 ; filtering by name or no filter
+16 SET Z=""
FOR
SET Z=$ORDER(^RCRP(340.5,"B",Z))
if 'Z
QUIT
Begin DoDot:2
+17 SET RPIEN=$ORDER(^RCRP(340.5,"B",Z,""))
if 'RPIEN
QUIT
+18 IF $PIECE(FILTER,U)="N"
SET NAME=$$NAM^RCFN01($PIECE(^RCRP(340.5,RPIEN,0),U,2))
if $PIECE(FILTER,U,2)]NAME
QUIT
if NAME]$PIECE(FILTER,U,3)
QUIT
+19 SET CNT=CNT+1
DO GETDATA(RPIEN,CNT)
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 DO PRINT
+23 KILL ^TMP("RCRPSTR",$JOB)
+24 QUIT
+25 ;
GETDATA(RPIEN,CNT) ; fetch data and put it into ^TMP global
+1 ;
+2 ; RPIEN - file 340.5 ien
+3 ; CNT - sequential # of ^TMP entry to create
+4 ;
+5 NEW AMNT,DAYS,DEBTOR,N0,MED,SSN,TMPSTR,Z,ORPLNDT,RMNOPY
+6 IF RPIEN'>0!(CNT'>0)
QUIT
+7 ; 0-node in file 340.5
SET N0=^RCRP(340.5,RPIEN,0)
+8 ; pointer to file 340
SET DEBTOR=$PIECE(N0,U,2)
+9 ; Original Plan Date (Creation Date)
SET ORPLNDT=$PIECE(N0,U,3)
+10 ; debtor name
SET NAME=$$NAM^RCFN01(DEBTOR)
if NAME=""
QUIT
+11 ; non-medical debt PRCA*4.5*389
SET MED=1
IF DEBTOR>0
IF $PIECE($PIECE(^RCD(340,DEBTOR,0),U),";",2)'="DPT("
SET MED=0
+12 ; debtor SSN
SET SSN=$$SSN^RCFN01(DEBTOR)
+13 ; amount owed
SET AMNT=$$CBAL^RCRPU3(RPIEN,+$PIECE(N0,U,11))
+14 ; days in status
SET DAYS=$$FMDIFF^XLFDT(DT,$PIECE(N0,U,8))
+15 ; remaining # payments
SET RMNOPY=$$REMPMNTS^RCRPU3(RPIEN,$PIECE(N0,U,6))
+16 ; each entry is: debtor name ^ ssn ^ repayment plan ID ^ Original Plan Date ^ status (internal) ^ status date ^ days in status ^ last payment date ^ # of payments ^
+17 ; remaining balance ^ at CS? ^ # of forbearances ^ medical debt (1/0)
+18 SET TMPSTR=NAME_U_SSN_U_$PIECE(N0,U)_U_ORPLNDT_U_$PIECE(N0,U,7)_U_$PIECE(N0,U,8)_U_DAYS
+19 ; last payment date
SET TMPSTR=TMPSTR_U_$ORDER(^RCRP(340.5,RPIEN,3,"B",""),-1)
+20 SET TMPSTR=TMPSTR_U_RMNOPY_U_AMNT_U_$PIECE($GET(^RCRP(340.5,RPIEN,1)),U,4)_U_$PIECE(N0,U,9)_U_MED
+21 ; add a new entry to ^TMP global
+22 SET ^TMP("RCRPSTR",$JOB,CNT)=TMPSTR
+23 SET Z=$SELECT(SORT="N":NAME,SORT="S":$$EXTERNAL^DILFD(340.5,.07,,$PIECE(N0,U,7)),1:AMNT)
if Z=""
QUIT
+24 SET ^TMP("RCRPSTR",$JOB,"IDX",Z,DAYS,CNT)=""
+25 QUIT
+26 ;
PRINT ; print report
+1 NEW ATCS,BAL,CNT,DATA,DAYS,EXTDT,LN,NAME,PAGE,SSN,STATUS,Z,Z1,QUIT
+2 USE IO
+3 SET PAGE=0
+4 SET EXTDT=$$FMTE^XLFDT(DT)
+5 SET QUIT=0
+6 IF EXCEL
Begin DoDot:1
+7 ; PRCA*4.5*389
WRITE !,"Repayment Plan Status Report^",EXTDT,U,$$FLTRSTR(),U,$$SORTSTR()
+8 ; PRCA*4.5*389
WRITE !,"Name^SSN^RPP ID^Orig Plan date^Status^Status date^Days in status^Last payment^Current plan length^Remaining balance^CS^Forbearances"
+9 QUIT
End DoDot:1
+10 IF 'EXCEL
Begin DoDot:1
+11 IF $EXTRACT(IOST,1,2)["C-"
IF '$DATA(ZTQUEUED)
WRITE @IOF
+12 DO HDR
+13 QUIT
End DoDot:1
+14 IF '$DATA(^TMP("RCRPSTR",$JOB))
Begin DoDot:1
+15 IF EXCEL
WRITE !!,"No records found."
QUIT
+16 WRITE !!,$$CJ^XLFSTR("No records found.",132)
+17 QUIT
End DoDot:1
QUIT
+18 SET Z=""
FOR
SET Z=$ORDER(^TMP("RCRPSTR",$JOB,"IDX",Z))
if Z=""
QUIT
Begin DoDot:1
+19 SET DAYS=""
FOR
SET DAYS=$ORDER(^TMP("RCRPSTR",$JOB,"IDX",Z,DAYS),-1)
if DAYS=""
QUIT
Begin DoDot:2
+20 SET CNT=0
FOR
SET CNT=$ORDER(^TMP("RCRPSTR",$JOB,"IDX",Z,DAYS,CNT))
if 'CNT
QUIT
Begin DoDot:3
+21 ; PRCA*4.5*389
SET DATA=^TMP("RCRPSTR",$JOB,CNT)
SET NAME=$SELECT($PIECE(DATA,U,13):"",1:"*")_$PIECE(DATA,U)
+22 ; convert status code
+23 SET Z1=$PIECE(DATA,U,5)
SET STATUS=$SELECT(Z1=1:"NEW",Z1=2:"CURR",Z1=3:"LATE",Z1=4:"DELQ",Z1=5:"DEF",Z1=6:"TERM",Z1=7:"CLOS",Z1=8:"PAID",1:"")
+24 ; format remaining balance
+25 SET BAL=$FNUMBER($PIECE(DATA,U,10),"",2)
+26 ; convert "at CS" value
+27 SET ATCS=$SELECT($PIECE(DATA,U,11):"Y",1:"N")
+28 ; format SSN to last 4 digits
+29 SET Z1=$PIECE(DATA,U,2)
SET SSN=$EXTRACT(Z1,$LENGTH(Z1)-3,$LENGTH(Z1))
IF SSN'>0
SET SSN="N/A"
+30 IF EXCEL
Begin DoDot:4
+31 ; PRCA*4.5*389
WRITE !,NAME,U,SSN,U,$PIECE(DATA,U,3),U,$$FMTE^XLFDT($PIECE(DATA,U,4),"2DZ"),U,STATUS,U,$$FMTE^XLFDT($PIECE(DATA,U,6),"2DZ"),U,$PIECE(DATA,U,7),U
+32 ;
WRITE $$FMTE^XLFDT($PIECE(DATA,U,8),"2DZ"),U,$PIECE(DATA,U,9),U,BAL,U,ATCS,U,$PIECE(DATA,U,12)
+33 QUIT
End DoDot:4
QUIT
+34 SET LN=LN+1
+35 ; PRCA*4.5*389
WRITE !,$EXTRACT(NAME,1,30),?31,SSN,?37,$PIECE(DATA,U,3),?57,$$FMTE^XLFDT($PIECE(DATA,U,4),"2DZ"),?67,STATUS,?73,$$FMTE^XLFDT($PIECE(DATA,U,6),"2DZ"),?83,$PIECE(DATA,U,7),?92
+36 ; PRCA*4.5*389
WRITE $$FMTE^XLFDT($PIECE(DATA,U,8),"2DZ"),?102,$PIECE(DATA,U,9),?112,$$CJ^XLFSTR("$"_BAL,13),?123,ATCS,?127,$PIECE(DATA,U,12)
+37 IF LN>(IOSL-3)
DO HDR
IF $GET(QUIT)
QUIT
+38 QUIT
End DoDot:3
if $GET(QUIT)
QUIT
+39 QUIT
End DoDot:2
if $GET(QUIT)
QUIT
+40 QUIT
End DoDot:1
if $GET(QUIT)
QUIT
+41 IF PAGE>0
IF '$DATA(ZTQUEUED)
DO PAUSE^RCRPRPU
WRITE @IOF
+42 QUIT
+43 ;
HDR ; print header
+1 IF PAGE>0
IF '$DATA(ZTQUEUED)
DO PAUSE^RCRPU
WRITE @IOF
IF $GET(QUIT)
QUIT
+2 ; PRCA*4.5*389
SET PAGE=PAGE+1
SET LN=9
+3 WRITE !,"Repayment Plan Status Report",?66,EXTDT,?120,"Page: ",PAGE
+4 WRITE !,$$FLTRSTR()
+5 WRITE !,$$SORTSTR()
+6 ; PRCA*4.5*389
WRITE !!,"* Indicates a non-medical debt repayment plan"
+7 WRITE !!," For-"
+8 WRITE !," Original Status Days in Last Cur plan Remaining bear-"
+9 WRITE !,"Name SSN RPP ID Plan Dt Stat date status payment length balance CS ances"
+10 WRITE !
DO DASH^RCRPRPU(132)
+11 QUIT
+12 ;
FLTRSTR() ; returns "Filtered by" string to print
+1 NEW STR,Z
+2 SET STR="Filtered by: "
+3 IF $PIECE(FILTER,U)="U"
SET STR=STR_"No filter"
+4 IF $PIECE(FILTER,U)="N"
SET STR=STR_"Debtor name (from "_$PIECE(FILTER,U,2)_" to "_$PIECE(FILTER,U,3)_")"
+5 IF $PIECE(FILTER,U)="S"
Begin DoDot:1
+6 SET STR=STR_"Status ("
+7 ; PRCA*4.5*378
FOR Z=1:1:$LENGTH($PIECE(FILTER,U,2),",")
SET STR=STR_$SELECT(Z>1:", ",1:"")_$$EXTERNAL^DILFD(340.5,.07,,$PIECE($PIECE(FILTER,U,2),",",Z))
+8 ; PRCA*4.5*389
SET STR=STR_"), "_$SELECT(+$PIECE(FILTER,U,4)>0:"from "_$PIECE(FILTER,U,3)_" to "_$PIECE(FILTER,U,4),1:"at least "_$PIECE(FILTER,U,3))
+9 ; PRCA*4.5*389
SET STR=STR_" days in status"
+10 QUIT
End DoDot:1
+11 QUIT STR
+12 ;
SORTSTR() ; returns "Sorted by" string to print
+1 NEW STR
+2 SET STR="Sorted by: "_$SELECT(SORT="N":"Debtor name",SORT="S":"Status",1:"Account balance")
+3 QUIT STR
+4 ;
+5 ; Select name range
INTV() ; Selects the range of names
+1 ; Output: First value ^ Last Value OR -1
+2 ;
+3 NEW RCFRST,RCLAST,X
+4 ;
+5 SET (RCFRST,RCLAST)=""
FRST WRITE !!?3,"START WITH NAME: FIRST// "
READ X:DTIME
IF '$TEST!(X["^")
QUIT -1
+1 IF $EXTRACT(X)="?"
DO HFST(1)
GOTO FRST
+2 SET RCFRST=X
LAST WRITE !?8,"GO TO NAME: LAST// "
READ X:DTIME
IF '$TEST!(X["^")
QUIT -1
+1 IF $EXTRACT(X)="?"
DO HFST(2)
GOTO LAST
+2 IF X=""
SET RCLAST="zzzzz"
GOTO QINT
+3 IF RCFRST]X
Begin DoDot:1
+4 WRITE *7,!!?7,"The LAST value must follow the FIRST.",!
End DoDot:1
GOTO LAST
+5 SET RCLAST=X
+6 ;
QINT QUIT (RCFRST_"^"_RCLAST)
+1 ;
HFST(RCVAL) ; - 'START WITH PATIENT/DEBTOR...' prompt
+1 NEW RCPRMPT
+2 SET RCPRMPT="First"
if RCVAL=2
SET RCPRMPT="Last"
+3 ;
+4 WRITE !!," Enter a valid field value, or"
+5 WRITE !," '<CR>' - To start from the '"_RCPRMPT_"' value for this field"
+6 WRITE !," '^' - To quit this option"
+7 QUIT
