RCRPENTR ;EDE/SAB - CREATE NEW REPAYMENT PLAN;11/16/2020 7:40 AM
;;4.5;Accounts Receivable;**377,381,378,389**;Mar 20, 1995;Build 36
;;Per VA Directive 6402, this routine should not be modified.
;
Q
ENTER ; Main Entry Point
;
N RCAUTO,RCDBTR,RCCTS,RCACPL,RCTOT,RCBLCH,RCALLFLG,RCDONE,RCSVFLG,Z
;
F D Q:+RCDBTR=0
. ;
. S RCDONE=0
. W @IOF
. ;Ask user for Debtor to build the plan for
. S RCDBTR=$$GETDBTR^RCRPU
. Q:+RCDBTR=0
. ;
. ;clear working array
. K ^TMP("RCRPP",$J)
. ;
. ;Check for an active Repayment Plan
. S RCACPL=$$CHKACT^RCRPU(+RCDBTR)
. ;If an active repayment plan print warning message to user and exit.
. I +RCACPL D Q
. . W !,"This Debtor already has a Repayment Plan that is active."
. . W !,"A new plan was not created.",!
. . D PAUSE^RCRPU ;Any key to continue prompt
. ;Otherwise, print the list of Active Bills
. W !,"This Debtor does not have a Repayment Plan",!!,"List of Active Bills:",!!
. S RCCTS=$$GETACTS^RCRPU(+RCDBTR)
. W @IOF
. D PRTACTS^RCRPU(+RCCTS)
. ;Ask user which Active bills to add to new plan (single, range, or all)
. S RCBLCH=$$GETBILLS^RCRPU(+RCCTS)
. S RCALLFLG=+RCBLCH,RCBLCH=$P(RCBLCH,U,2)
. ;If no bills selected, exit.
. I RCBLCH="" D Q
. . W !,"No Bills selected",!
. . D PAUSE^RCRPU
. . W @IOF
. ;Display Bills selected if All Bills not selected
. I 'RCALLFLG D Q:'RCDONE
. . S RCDONE=$$ECHOBL^RCRPADD($P(RCBLCH,U,2))
. ;Display total sum of bills chosen and confirm with user, exit if no.
. S RCTOT=$$TOT^RCRPU(RCBLCH)
. I '+RCTOT D Q
. . D PAUSE^RCRPU ;Any key to continue prompt
. S RCAUTO=$$AUTOADD^RCRPU1(0) Q:RCAUTO<0 ; prompt for auto-adding bills to the RPP PRCA*4.5*378
. ;Strip confirm flag to get total.
. S RCTOT=$P(RCTOT,U,2)
. ;Get the repayment plan details and save
. S RCSVFLG=$$GETDET^RCRPU(RCBLCH,RCTOT,RCDBTR,RCAUTO)
. Q:RCSVFLG<1
. ;Display bills at CS and recall them if necessary
. D ASKRCL^RCRPU2 ; PRCA*4.5*389
. ;Display bills at TOP/DMC
. S Z=$$DISPREF^RCRPU2(1) ; PRCA*4.5*389
;
;Clear working array when exiting.
K ^TMP("RCRPP",$J)
;
Q
;
EDIT ;Edit A Repayment Plan
;
N RCEND
;
F D Q:+RCEND<1
. ;Ask user for Debtor to build the plan for
. S RCEND=$$GETPLAN
Q
;
GETPLAN() ;Get the Plan IEN using Debtor or Repayment Plan ID.
N RCDATA,RCIEN,RCERROR,RCDBTR,RCDBTRN,RCRPID,RCMNAMT,RCLNG,RCSTAT,RCLP,RCEDTYPE
N RCAUTO,RCIENC,RCMSCT,RCPYMD,RCSTDT,RCEXIT,RCEXIT1,RCAFLG,RCPYFB
;
;Ask user if they wish to perform the lookup by ID or by Debtor
;
S RCEXIT=0
F D Q:RCEXIT<0
.W @IOF
.S RCIEN=$$SELRPP^RCRPU1()
.I +RCIEN<1 S RCEXIT=-1 Q
.D EDITPLAN(RCIEN) ; PRCA*4.5*389
.Q
;
Q RCEXIT
;
EDITPLAN(RCIEN) ; edit selected plan, entry point from repayment plan worklist PRCA*4.5*389
;
; RCIEN - file 340.5 ien
;
N RCAFLG,RCDBTR,RCDBTRN,RCERROR,RCEXIT1,RCIENC,RCLNG,RCLP,RCMNAMT,RCMSCT,RCPYMD,RCRPID,RCSTAT,RCSTDT
; don't allow editing of plans in "closed", "paid in full", and "terminated" status
I "^6^7^8^"[$$GET1^DIQ(340.5,RCIEN_",",.07,"I")_U W !!,"Can't edit a closed repayment plan.",! D PAUSE^RCRPRPU Q
F D Q:RCEXIT1<1
.S (RCDATA,RCERROR)="",RCIENC=RCIEN_","
.; Get the Plan information
.K RCDATA N RCDATA ; Clear and redefine RCDATA before reprinting screen
.D GETS^DIQ(340.5,RCIENC,"**","EI","RCDATA","RCERROR")
.; Get the Base info
.S RCRPID=RCDATA(340.5,RCIENC,.01,"E")
.S RCDBTRN=RCDATA(340.5,RCIENC,.02,"E")
.S RCDBTR=RCDATA(340.5,RCIENC,.02,"I")
.S RCSTDT=RCDATA(340.5,RCIENC,.04,"I")
.S RCMNAMT=RCDATA(340.5,RCIENC,.06,"E")
.S RCLNG=RCDATA(340.5,RCIENC,.05,"E")
.S RCSTAT=RCDATA(340.5,RCIENC,.07,"E")
.S RCAFLG=RCDATA(340.5,RCIENC,.12,"E")
.; Calculate the # payments remaining
.S RCLP="",RCMSCT=0
.F S RCLP=$O(RCDATA(340.52,RCLP)) Q:'RCLP D
..S RCPYMD=RCDATA(340.52,RCLP,1,"I"),RCPYFB=RCDATA(340.52,RCLP,2,"I")
..I 'RCPYMD,'RCPYFB S RCMSCT=RCMSCT+1
..Q
.; Display the Plan summary information
.W @IOF,!,"--------------------------------------------------------------------------------"
.W !,"Repayment Plan Overview for AR Debtor: ",RCDBTRN,!
.W !,?23,"Repayment Plan ID: ",RCRPID,!
.W !,"Monthly Repayment Amount:",?32,"$",$J(RCMNAMT,0,2)
.W ?45,"Original # of Payments:",?70,RCLNG
.W !,"# of Remaining Payments:",?32,RCMSCT
.W ?45,"Current Status:",?70,RCSTAT
.W !,"Date First Payment Due:",?32,$$FMTE^XLFDT(RCSTDT,"5DZ")
.W ?45,"Auto Add New Bills:",?70,RCAFLG
.W !,"--------------------------------------------------------------------------------",!
.; Ask user what to edit (Close Plan, Edit Monthly Payment, or Allow Auto Adding of Bills
.S RCEXIT1=0
.S RCEDTYPE=$$GETTYPE
.I RCEDTYPE=-1 S RCEXIT1=0 Q ; Time out or user "^" to exit option
.; PRCA*4.5*378 - Added 2 new user prompts
.I RCEDTYPE="Q" S RCEXIT1=0 Q ;User requested Exit pla using prompt
.I RCEDTYPE="C" D CLOSE(RCIEN) K ^TMP($J,"RPPFLDNO") S RCEXIT1=0 Q
.I RCEDTYPE="E" D EDMN(RCDBTR,RCIEN,RCMSCT) S RCEXIT1=1 Q
.I RCEDTYPE="A" S RCAUTO=$$AUTOADD^RCRPU1 D:RCAUTO'<0 UPDAUTO^RCRPU1(RCIEN,RCAUTO) S RCEXIT1=1
.Q
Q
;
GETTYPE() ;Get the user requested type of editing.
;
N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
;
; Prompt Summary or Detail version
;S DIR("A")="(C)lose the Plan or (E)dit Monthly Payment? "
S DIR("A")="(C)lose Plan, (E)dit Monthly Payment, (A)llow Bill Auto-Add, or (Q)uit? "
S DIR("B")="Q"
S DIR(0)="SA^C:Close Plan;E:Edit Payment Amount;A:Allow Auto-add;Q:Quit"
S DIR("?")="Select whether to Close the plan, Change the amount of the Monthly Payment, Turn on or off the Auto-add of bills ability, or Quit."
;
D ^DIR K DIR
;
I $D(DTOUT)!$D(DUOUT)!($G(Y)="") Q -1
;
Q Y
;
EDMN(RCDBTR,RCIEN,RCORLN) ;Edit the monthly payment
;INPUT - RCIEN - IEN of the Repayment Plan being edited.
; RCORLN - Original # remaining Payments.
;
N RCTOT,RCPLN,RCCRDT
;
S RCCRDT=$$DT^XLFDT
;Determine actual amount remaining
S RCTOT=$$CALCTOT^RCRPU2(RCIEN)
;
;Ask for the new amount and plan length
S RCPLN=$$GETPLN^RCRPU(RCDBTR,RCTOT,1)
Q:'RCPLN
;
;Confirm that this is correct
Q:'$$CORRECT^RCRPU
;
;Update the amount per Month, # payments in the plan, Update the REVIEW field
D UPDTERMS^RCRPU1(RCIEN,RCPLN)
;
;Determine if the Review flag should be set or cleared.
S RCFLG=0
I $P(RCPLN,U,2)>57 S RCFLG=1
D UPDRVW^RCRPU2(RCIEN,RCFLG)
;
;Update the audit log.
D UPDAUDIT^RCRPU2(RCIEN,RCCRDT,"E","T") ;Post a Edit/Terms Adjusted entry in Audit log.
;
;Update Audit Log with Supervisor Approvals, if any.
D:$G(^TMP("RCRPP",$J,"SUP25")) UPDAUDIT^RCRPU2(RCIEN,RCCRDT,"E","SA")
D:$G(^TMP("RCRPP",$J,"SUP36")) UPDFLG36^RCRPU1(RCIEN,1),UPDAUDIT^RCRPU2(RCIEN,RCCRDT,"E","SM") ; PRCA*4.5*389
;
;Update the schedule, removing any extra payments not needed.
I RCORLN'=$P(RCPLN,U,2) D ADJSCHED(RCIEN,RCORLN,$P(RCPLN,U,2))
;
;File a transaction to signal the plan was edited.
D UPDTRAN^RCRPU1(RCIEN)
;
W !,"Plan Updated. " D PAUSE^RCRPU
;
Q
;
CLOSE(RCIEN) ;Close the Plan
;
N RCREASON,RCCURST,RCFIELD
;
;Extract the Current sTatus
S RCCURST=$$GET1^DIQ(340.5,RCIEN_",",.07,"I")
; Set up the field # array for the metrics file
D BLDSTARY^RCRPNP
;
;Confirm that the user wishes to close the plan
Q:'$$CORRECT^RCRPU(3) -1
;
; Enter the reason for closing the plan (defaulting for non-payment or administrative)
S RCREASON=$$GETRSN^RCRPU1
Q:RCREASON=-1 -1
;
;Confirm that the reason and closure is correct
Q:'$$CORRECT^RCRPU -1
;
;Update the Plan status to CLOSED
D UPDSTAT^RCRPU1(RCIEN,7)
;
;Update the correct Status Movement Metric
S RCFIELD=$G(^TMP($J,"RPPFLDNO",RCCURST,7))
D UPDMET^RCSTATU(RCFIELD,1)
;
;Update the Close Reason Metric (Default reason updates field 1.28, otherwise, update 1.27 in the AR Metrics file (340.7)
S RCFIELD=$S(RCREASON="D":1.28,1:1.27)
D UPDMET^RCSTATU(RCFIELD,1)
;
;Update the audit log with the reason
D UPDAUDIT^RCRPU2(RCIEN,$$DT^XLFDT,"C",RCREASON)
;
;Update the Bills on the plan to remove the REPAYMENT PLAN DATE and AR REPAYMENT PLAN ID
;Also, file a transaction indicating that the Plan was closed.
D RMBILL^RCRPU1(RCIEN)
;
W !,"Plan Closed. " D PAUSE^RCRPU
;
Q 1
;
ADJSCHED(RCIEN,RCORLN,RCNEWLN) ; Add or subtract payments from a plan's Schedule.
;INPUT - RCIEN - IEN of the Repayment Plan being adjusted
; RCORLN - Original Term Length of the payments
; RCNEWLN - New Term Length
;
N RCFBFLG,RCLP,RCLP1,RCPD,RCSTDT,RCSUB,RCFB,RCFBCT,RCORIEN
;
;Clear RPP Temp array
K ^TMP("RCRPP",$J)
;
I RCORLN>RCNEWLN D Q
. ;Count the # of payments forborne
. S RCFBCT=0,RCLP=0
. F S RCLP=$O(^RCRP(340.5,RCIEN,2,RCLP)) Q:'RCLP D
. . S RCFB=$P($G(^RCRP(340.5,RCIEN,2,RCLP,0)),U,3)
. . I RCFB S RCFBCT=RCFBCT+1
. ;
. ;find all of the payments paid, stop on the first unpaid.
. S RCLP=0 F S RCLP=$O(^RCRP(340.5,RCIEN,2,RCLP)) Q:'RCLP S RCPD=$P($G(^RCRP(340.5,RCIEN,2,RCLP,0)),U,2) Q:'RCPD
. ;
. ; Count the new remaining payment out.
. S RCLP1=RCLP+RCFBCT+RCNEWLN-1 ;first missing payment + # Forborne months + new length of payment - 1 for the first missing payment)
. ;
. ; remove the remaining payments from schedule
. F S RCLP1=$O(^RCRP(340.5,RCIEN,2,RCLP1)) Q:'RCLP1 D
. . ;Do not remove payments forborne
. . S RCFBFLG=+$P($G(^RCRP(340.5,RCIEN,2,RCLP1,0)),U,3)
. . Q:RCFBFLG
. . ;
. . ; Remove the month from the schedule.
. . S DA(1)=RCIEN,DA=RCLP1,DIK="^RCRP(340.5,"_DA(1)_",2,"
. . D ^DIK
. . K DA,DIK
;
;Otherwise, add new payments to schedule.
;Find the last date by looking for the last entry and grabbing the first piece.
S RCORIEN=$O(^RCRP(340.5,RCIEN,2,"A"),-1)
S RCSTDT=$P($G(^RCRP(340.5,RCIEN,2,RCORIEN,0)),U,1)
D BLDPLN^RCRPU2(RCSTDT,(RCNEWLN-RCORLN),1,RCIEN)
;
; Add the new months to the Schedule
; Update the Schedule Node
S RCSUB=0
F S RCSUB=$O(^TMP("RCRPP",$J,"PLAN",RCSUB)) Q:'RCSUB D UPDSCHED^RCRPU(RCIEN,RCSUB)
;
;Clear temp array
K ^TMP("RCRPP",$J)
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRPENTR 10196 printed Apr 09, 2024@20:51:09 Page 2
RCRPENTR ;EDE/SAB - CREATE NEW REPAYMENT PLAN;11/16/2020 7:40 AM
+1 ;;4.5;Accounts Receivable;**377,381,378,389**;Mar 20, 1995;Build 36
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
ENTER ; Main Entry Point
+1 ;
+2 NEW RCAUTO,RCDBTR,RCCTS,RCACPL,RCTOT,RCBLCH,RCALLFLG,RCDONE,RCSVFLG,Z
+3 ;
+4 FOR
Begin DoDot:1
+5 ;
+6 SET RCDONE=0
+7 WRITE @IOF
+8 ;Ask user for Debtor to build the plan for
+9 SET RCDBTR=$$GETDBTR^RCRPU
+10 if +RCDBTR=0
QUIT
+11 ;
+12 ;clear working array
+13 KILL ^TMP("RCRPP",$JOB)
+14 ;
+15 ;Check for an active Repayment Plan
+16 SET RCACPL=$$CHKACT^RCRPU(+RCDBTR)
+17 ;If an active repayment plan print warning message to user and exit.
+18 IF +RCACPL
Begin DoDot:2
+19 WRITE !,"This Debtor already has a Repayment Plan that is active."
+20 WRITE !,"A new plan was not created.",!
+21 ;Any key to continue prompt
DO PAUSE^RCRPU
End DoDot:2
QUIT
+22 ;Otherwise, print the list of Active Bills
+23 WRITE !,"This Debtor does not have a Repayment Plan",!!,"List of Active Bills:",!!
+24 SET RCCTS=$$GETACTS^RCRPU(+RCDBTR)
+25 WRITE @IOF
+26 DO PRTACTS^RCRPU(+RCCTS)
+27 ;Ask user which Active bills to add to new plan (single, range, or all)
+28 SET RCBLCH=$$GETBILLS^RCRPU(+RCCTS)
+29 SET RCALLFLG=+RCBLCH
SET RCBLCH=$PIECE(RCBLCH,U,2)
+30 ;If no bills selected, exit.
+31 IF RCBLCH=""
Begin DoDot:2
+32 WRITE !,"No Bills selected",!
+33 DO PAUSE^RCRPU
+34 WRITE @IOF
End DoDot:2
QUIT
+35 ;Display Bills selected if All Bills not selected
+36 IF 'RCALLFLG
Begin DoDot:2
+37 SET RCDONE=$$ECHOBL^RCRPADD($PIECE(RCBLCH,U,2))
End DoDot:2
if 'RCDONE
QUIT
+38 ;Display total sum of bills chosen and confirm with user, exit if no.
+39 SET RCTOT=$$TOT^RCRPU(RCBLCH)
+40 IF '+RCTOT
Begin DoDot:2
+41 ;Any key to continue prompt
DO PAUSE^RCRPU
End DoDot:2
QUIT
+42 ; prompt for auto-adding bills to the RPP PRCA*4.5*378
SET RCAUTO=$$AUTOADD^RCRPU1(0)
if RCAUTO<0
QUIT
+43 ;Strip confirm flag to get total.
+44 SET RCTOT=$PIECE(RCTOT,U,2)
+45 ;Get the repayment plan details and save
+46 SET RCSVFLG=$$GETDET^RCRPU(RCBLCH,RCTOT,RCDBTR,RCAUTO)
+47 if RCSVFLG<1
QUIT
+48 ;Display bills at CS and recall them if necessary
+49 ; PRCA*4.5*389
DO ASKRCL^RCRPU2
+50 ;Display bills at TOP/DMC
+51 ; PRCA*4.5*389
SET Z=$$DISPREF^RCRPU2(1)
End DoDot:1
if +RCDBTR=0
QUIT
+52 ;
+53 ;Clear working array when exiting.
+54 KILL ^TMP("RCRPP",$JOB)
+55 ;
+56 QUIT
+57 ;
EDIT ;Edit A Repayment Plan
+1 ;
+2 NEW RCEND
+3 ;
+4 FOR
Begin DoDot:1
+5 ;Ask user for Debtor to build the plan for
+6 SET RCEND=$$GETPLAN
End DoDot:1
if +RCEND<1
QUIT
+7 QUIT
+8 ;
GETPLAN() ;Get the Plan IEN using Debtor or Repayment Plan ID.
+1 NEW RCDATA,RCIEN,RCERROR,RCDBTR,RCDBTRN,RCRPID,RCMNAMT,RCLNG,RCSTAT,RCLP,RCEDTYPE
+2 NEW RCAUTO,RCIENC,RCMSCT,RCPYMD,RCSTDT,RCEXIT,RCEXIT1,RCAFLG,RCPYFB
+3 ;
+4 ;Ask user if they wish to perform the lookup by ID or by Debtor
+5 ;
+6 SET RCEXIT=0
+7 FOR
Begin DoDot:1
+8 WRITE @IOF
+9 SET RCIEN=$$SELRPP^RCRPU1()
+10 IF +RCIEN<1
SET RCEXIT=-1
QUIT
+11 ; PRCA*4.5*389
DO EDITPLAN(RCIEN)
+12 QUIT
End DoDot:1
if RCEXIT<0
QUIT
+13 ;
+14 QUIT RCEXIT
+15 ;
EDITPLAN(RCIEN) ; edit selected plan, entry point from repayment plan worklist PRCA*4.5*389
+1 ;
+2 ; RCIEN - file 340.5 ien
+3 ;
+4 NEW RCAFLG,RCDBTR,RCDBTRN,RCERROR,RCEXIT1,RCIENC,RCLNG,RCLP,RCMNAMT,RCMSCT,RCPYMD,RCRPID,RCSTAT,RCSTDT
+5 ; don't allow editing of plans in "closed", "paid in full", and "terminated" status
+6 IF "^6^7^8^"[$$GET1^DIQ(340.5,RCIEN_",",.07,"I")_U
WRITE !!,"Can't edit a closed repayment plan.",!
DO PAUSE^RCRPRPU
QUIT
+7 FOR
Begin DoDot:1
+8 SET (RCDATA,RCERROR)=""
SET RCIENC=RCIEN_","
+9 ; Get the Plan information
+10 ; Clear and redefine RCDATA before reprinting screen
KILL RCDATA
NEW RCDATA
+11 DO GETS^DIQ(340.5,RCIENC,"**","EI","RCDATA","RCERROR")
+12 ; Get the Base info
+13 SET RCRPID=RCDATA(340.5,RCIENC,.01,"E")
+14 SET RCDBTRN=RCDATA(340.5,RCIENC,.02,"E")
+15 SET RCDBTR=RCDATA(340.5,RCIENC,.02,"I")
+16 SET RCSTDT=RCDATA(340.5,RCIENC,.04,"I")
+17 SET RCMNAMT=RCDATA(340.5,RCIENC,.06,"E")
+18 SET RCLNG=RCDATA(340.5,RCIENC,.05,"E")
+19 SET RCSTAT=RCDATA(340.5,RCIENC,.07,"E")
+20 SET RCAFLG=RCDATA(340.5,RCIENC,.12,"E")
+21 ; Calculate the # payments remaining
+22 SET RCLP=""
SET RCMSCT=0
+23 FOR
SET RCLP=$ORDER(RCDATA(340.52,RCLP))
if 'RCLP
QUIT
Begin DoDot:2
+24 SET RCPYMD=RCDATA(340.52,RCLP,1,"I")
SET RCPYFB=RCDATA(340.52,RCLP,2,"I")
+25 IF 'RCPYMD
IF 'RCPYFB
SET RCMSCT=RCMSCT+1
+26 QUIT
End DoDot:2
+27 ; Display the Plan summary information
+28 WRITE @IOF,!,"--------------------------------------------------------------------------------"
+29 WRITE !,"Repayment Plan Overview for AR Debtor: ",RCDBTRN,!
+30 WRITE !,?23,"Repayment Plan ID: ",RCRPID,!
+31 WRITE !,"Monthly Repayment Amount:",?32,"$",$JUSTIFY(RCMNAMT,0,2)
+32 WRITE ?45,"Original # of Payments:",?70,RCLNG
+33 WRITE !,"# of Remaining Payments:",?32,RCMSCT
+34 WRITE ?45,"Current Status:",?70,RCSTAT
+35 WRITE !,"Date First Payment Due:",?32,$$FMTE^XLFDT(RCSTDT,"5DZ")
+36 WRITE ?45,"Auto Add New Bills:",?70,RCAFLG
+37 WRITE !,"--------------------------------------------------------------------------------",!
+38 ; Ask user what to edit (Close Plan, Edit Monthly Payment, or Allow Auto Adding of Bills
+39 SET RCEXIT1=0
+40 SET RCEDTYPE=$$GETTYPE
+41 ; Time out or user "^" to exit option
IF RCEDTYPE=-1
SET RCEXIT1=0
QUIT
+42 ; PRCA*4.5*378 - Added 2 new user prompts
+43 ;User requested Exit pla using prompt
IF RCEDTYPE="Q"
SET RCEXIT1=0
QUIT
+44 IF RCEDTYPE="C"
DO CLOSE(RCIEN)
KILL ^TMP($JOB,"RPPFLDNO")
SET RCEXIT1=0
QUIT
+45 IF RCEDTYPE="E"
DO EDMN(RCDBTR,RCIEN,RCMSCT)
SET RCEXIT1=1
QUIT
+46 IF RCEDTYPE="A"
SET RCAUTO=$$AUTOADD^RCRPU1
if RCAUTO'<0
DO UPDAUTO^RCRPU1(RCIEN,RCAUTO)
SET RCEXIT1=1
+47 QUIT
End DoDot:1
if RCEXIT1<1
QUIT
+48 QUIT
+49 ;
GETTYPE() ;Get the user requested type of editing.
+1 ;
+2 NEW X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
+3 ;
+4 ; Prompt Summary or Detail version
+5 ;S DIR("A")="(C)lose the Plan or (E)dit Monthly Payment? "
+6 SET DIR("A")="(C)lose Plan, (E)dit Monthly Payment, (A)llow Bill Auto-Add, or (Q)uit? "
+7 SET DIR("B")="Q"
+8 SET DIR(0)="SA^C:Close Plan;E:Edit Payment Amount;A:Allow Auto-add;Q:Quit"
+9 SET DIR("?")="Select whether to Close the plan, Change the amount of the Monthly Payment, Turn on or off the Auto-add of bills ability, or Quit."
+10 ;
+11 DO ^DIR
KILL DIR
+12 ;
+13 IF $DATA(DTOUT)!$DATA(DUOUT)!($GET(Y)="")
QUIT -1
+14 ;
+15 QUIT Y
+16 ;
EDMN(RCDBTR,RCIEN,RCORLN) ;Edit the monthly payment
+1 ;INPUT - RCIEN - IEN of the Repayment Plan being edited.
+2 ; RCORLN - Original # remaining Payments.
+3 ;
+4 NEW RCTOT,RCPLN,RCCRDT
+5 ;
+6 SET RCCRDT=$$DT^XLFDT
+7 ;Determine actual amount remaining
+8 SET RCTOT=$$CALCTOT^RCRPU2(RCIEN)
+9 ;
+10 ;Ask for the new amount and plan length
+11 SET RCPLN=$$GETPLN^RCRPU(RCDBTR,RCTOT,1)
+12 if 'RCPLN
QUIT
+13 ;
+14 ;Confirm that this is correct
+15 if '$$CORRECT^RCRPU
QUIT
+16 ;
+17 ;Update the amount per Month, # payments in the plan, Update the REVIEW field
+18 DO UPDTERMS^RCRPU1(RCIEN,RCPLN)
+19 ;
+20 ;Determine if the Review flag should be set or cleared.
+21 SET RCFLG=0
+22 IF $PIECE(RCPLN,U,2)>57
SET RCFLG=1
+23 DO UPDRVW^RCRPU2(RCIEN,RCFLG)
+24 ;
+25 ;Update the audit log.
+26 ;Post a Edit/Terms Adjusted entry in Audit log.
DO UPDAUDIT^RCRPU2(RCIEN,RCCRDT,"E","T")
+27 ;
+28 ;Update Audit Log with Supervisor Approvals, if any.
+29 if $GET(^TMP("RCRPP",$JOB,"SUP25"))
DO UPDAUDIT^RCRPU2(RCIEN,RCCRDT,"E","SA")
+30 ; PRCA*4.5*389
if $GET(^TMP("RCRPP",$JOB,"SUP36"))
DO UPDFLG36^RCRPU1(RCIEN,1)
DO UPDAUDIT^RCRPU2(RCIEN,RCCRDT,"E","SM")
+31 ;
+32 ;Update the schedule, removing any extra payments not needed.
+33 IF RCORLN'=$PIECE(RCPLN,U,2)
DO ADJSCHED(RCIEN,RCORLN,$PIECE(RCPLN,U,2))
+34 ;
+35 ;File a transaction to signal the plan was edited.
+36 DO UPDTRAN^RCRPU1(RCIEN)
+37 ;
+38 WRITE !,"Plan Updated. "
DO PAUSE^RCRPU
+39 ;
+40 QUIT
+41 ;
CLOSE(RCIEN) ;Close the Plan
+1 ;
+2 NEW RCREASON,RCCURST,RCFIELD
+3 ;
+4 ;Extract the Current sTatus
+5 SET RCCURST=$$GET1^DIQ(340.5,RCIEN_",",.07,"I")
+6 ; Set up the field # array for the metrics file
+7 DO BLDSTARY^RCRPNP
+8 ;
+9 ;Confirm that the user wishes to close the plan
+10 if '$$CORRECT^RCRPU(3)
QUIT -1
+11 ;
+12 ; Enter the reason for closing the plan (defaulting for non-payment or administrative)
+13 SET RCREASON=$$GETRSN^RCRPU1
+14 if RCREASON=-1
QUIT -1
+15 ;
+16 ;Confirm that the reason and closure is correct
+17 if '$$CORRECT^RCRPU
QUIT -1
+18 ;
+19 ;Update the Plan status to CLOSED
+20 DO UPDSTAT^RCRPU1(RCIEN,7)
+21 ;
+22 ;Update the correct Status Movement Metric
+23 SET RCFIELD=$GET(^TMP($JOB,"RPPFLDNO",RCCURST,7))
+24 DO UPDMET^RCSTATU(RCFIELD,1)
+25 ;
+26 ;Update the Close Reason Metric (Default reason updates field 1.28, otherwise, update 1.27 in the AR Metrics file (340.7)
+27 SET RCFIELD=$SELECT(RCREASON="D":1.28,1:1.27)
+28 DO UPDMET^RCSTATU(RCFIELD,1)
+29 ;
+30 ;Update the audit log with the reason
+31 DO UPDAUDIT^RCRPU2(RCIEN,$$DT^XLFDT,"C",RCREASON)
+32 ;
+33 ;Update the Bills on the plan to remove the REPAYMENT PLAN DATE and AR REPAYMENT PLAN ID
+34 ;Also, file a transaction indicating that the Plan was closed.
+35 DO RMBILL^RCRPU1(RCIEN)
+36 ;
+37 WRITE !,"Plan Closed. "
DO PAUSE^RCRPU
+38 ;
+39 QUIT 1
+40 ;
ADJSCHED(RCIEN,RCORLN,RCNEWLN) ; Add or subtract payments from a plan's Schedule.
+1 ;INPUT - RCIEN - IEN of the Repayment Plan being adjusted
+2 ; RCORLN - Original Term Length of the payments
+3 ; RCNEWLN - New Term Length
+4 ;
+5 NEW RCFBFLG,RCLP,RCLP1,RCPD,RCSTDT,RCSUB,RCFB,RCFBCT,RCORIEN
+6 ;
+7 ;Clear RPP Temp array
+8 KILL ^TMP("RCRPP",$JOB)
+9 ;
+10 IF RCORLN>RCNEWLN
Begin DoDot:1
+11 ;Count the # of payments forborne
+12 SET RCFBCT=0
SET RCLP=0
+13 FOR
SET RCLP=$ORDER(^RCRP(340.5,RCIEN,2,RCLP))
if 'RCLP
QUIT
Begin DoDot:2
+14 SET RCFB=$PIECE($GET(^RCRP(340.5,RCIEN,2,RCLP,0)),U,3)
+15 IF RCFB
SET RCFBCT=RCFBCT+1
End DoDot:2
+16 ;
+17 ;find all of the payments paid, stop on the first unpaid.
+18 SET RCLP=0
FOR
SET RCLP=$ORDER(^RCRP(340.5,RCIEN,2,RCLP))
if 'RCLP
QUIT
SET RCPD=$PIECE($GET(^RCRP(340.5,RCIEN,2,RCLP,0)),U,2)
if 'RCPD
QUIT
+19 ;
+20 ; Count the new remaining payment out.
+21 ;first missing payment + # Forborne months + new length of payment - 1 for the first missing payment)
SET RCLP1=RCLP+RCFBCT+RCNEWLN-1
+22 ;
+23 ; remove the remaining payments from schedule
+24 FOR
SET RCLP1=$ORDER(^RCRP(340.5,RCIEN,2,RCLP1))
if 'RCLP1
QUIT
Begin DoDot:2
+25 ;Do not remove payments forborne
+26 SET RCFBFLG=+$PIECE($GET(^RCRP(340.5,RCIEN,2,RCLP1,0)),U,3)
+27 if RCFBFLG
QUIT
+28 ;
+29 ; Remove the month from the schedule.
+30 SET DA(1)=RCIEN
SET DA=RCLP1
SET DIK="^RCRP(340.5,"_DA(1)_",2,"
+31 DO ^DIK
+32 KILL DA,DIK
End DoDot:2
End DoDot:1
QUIT
+33 ;
+34 ;Otherwise, add new payments to schedule.
+35 ;Find the last date by looking for the last entry and grabbing the first piece.
+36 SET RCORIEN=$ORDER(^RCRP(340.5,RCIEN,2,"A"),-1)
+37 SET RCSTDT=$PIECE($GET(^RCRP(340.5,RCIEN,2,RCORIEN,0)),U,1)
+38 DO BLDPLN^RCRPU2(RCSTDT,(RCNEWLN-RCORLN),1,RCIEN)
+39 ;
+40 ; Add the new months to the Schedule
+41 ; Update the Schedule Node
+42 SET RCSUB=0
+43 FOR
SET RCSUB=$ORDER(^TMP("RCRPP",$JOB,"PLAN",RCSUB))
if 'RCSUB
QUIT
DO UPDSCHED^RCRPU(RCIEN,RCSUB)
+44 ;
+45 ;Clear temp array
+46 KILL ^TMP("RCRPP",$JOB)
+47 ;
+48 QUIT
+49 ;
