RCRPENTR ;EDE/SAB - CREATE NEW REPAYMENT PLAN;11/16/2020 7:40 AM
;;4.5;Accounts Receivable;**377,381,378,389,422**;Mar 20, 1995;Build 13
;;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,"N",0) ; PRCA*4.5*422
. 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,.RCEXIT) Q ; PRCA*4.5*422
.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,RCEXIT) ;Edit the monthly payment
;INPUT - RCIEN - IEN of the Repayment Plan being edited.
; RCORLN - Original # remaining Payments.
; RCEXIT - exit flag for EDITPLAN tag (1/0)
;
N N0,RCTOT,RCPLN
;
S RCEXIT=1 ; PRCA*4.5*422
;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
S N0=^RCRP(340.5,RCIEN,0) ; PRCA*4.5*422
W !!,"You are changing the monthly payment for this repayment plan ",$P(N0,U),", this plan will be administratively closed. A new plan will be generated.",! ; PRCA*4.5*422
;
;Confirm that this is correct
Q:'$$CORRECT^RCRPU
; close the plan and create a new one PRCA*4.5*422
D CLSPLAN^RCRPU3(RCIEN,"T")
W !,"Repayment plan ",$P(N0,U)," has been closed.",!
I '$$CPYPLAN^RCRPU3(RCIEN,RCPLN) Q
S RCEXIT=0
D PAUSE^RCRPU
;
Q
;
CLOSE(RCIEN) ; Close the plan PRCA*4.5*422
;
N RCREASON
;
; 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
; Close the plan
D CLSPLAN^RCRPU3(RCIEN,RCREASON)
;
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 9069 printed Dec 13, 2024@01:48:22 Page 2
RCRPENTR ;EDE/SAB - CREATE NEW REPAYMENT PLAN;11/16/2020 7:40 AM
+1 ;;4.5;Accounts Receivable;**377,381,378,389,422**;Mar 20, 1995;Build 13
+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 ; PRCA*4.5*422
SET RCSVFLG=$$GETDET^RCRPU(RCBLCH,RCTOT,RCDBTR,RCAUTO,"N",0)
+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 ; PRCA*4.5*422
IF RCEDTYPE="E"
DO EDMN(RCDBTR,RCIEN,RCMSCT,.RCEXIT)
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,RCEXIT) ;Edit the monthly payment
+1 ;INPUT - RCIEN - IEN of the Repayment Plan being edited.
+2 ; RCORLN - Original # remaining Payments.
+3 ; RCEXIT - exit flag for EDITPLAN tag (1/0)
+4 ;
+5 NEW N0,RCTOT,RCPLN
+6 ;
+7 ; PRCA*4.5*422
SET RCEXIT=1
+8 ;Determine actual amount remaining
+9 SET RCTOT=$$CALCTOT^RCRPU2(RCIEN)
+10 ;
+11 ;Ask for the new amount and plan length
+12 SET RCPLN=$$GETPLN^RCRPU(RCDBTR,RCTOT,1)
+13 if 'RCPLN
QUIT
+14 ; PRCA*4.5*422
SET N0=^RCRP(340.5,RCIEN,0)
+15 ; PRCA*4.5*422
WRITE !!,"You are changing the monthly payment for this repayment plan ",$PIECE(N0,U),", this plan will be administratively closed. A new plan will be generated.",!
+16 ;
+17 ;Confirm that this is correct
+18 if '$$CORRECT^RCRPU
QUIT
+19 ; close the plan and create a new one PRCA*4.5*422
+20 DO CLSPLAN^RCRPU3(RCIEN,"T")
+21 WRITE !,"Repayment plan ",$PIECE(N0,U)," has been closed.",!
+22 IF '$$CPYPLAN^RCRPU3(RCIEN,RCPLN)
QUIT
+23 SET RCEXIT=0
+24 DO PAUSE^RCRPU
+25 ;
+26 QUIT
+27 ;
CLOSE(RCIEN) ; Close the plan PRCA*4.5*422
+1 ;
+2 NEW RCREASON
+3 ;
+4 ; Confirm that the user wishes to close the plan
+5 if '$$CORRECT^RCRPU(3)
QUIT -1
+6 ; Enter the reason for closing the plan (defaulting for non-payment or administrative)
+7 SET RCREASON=$$GETRSN^RCRPU1
+8 if RCREASON=-1
QUIT -1
+9 ; Confirm that the reason and closure is correct
+10 if '$$CORRECT^RCRPU
QUIT -1
+11 ; Close the plan
+12 DO CLSPLAN^RCRPU3(RCIEN,RCREASON)
+13 ;
+14 WRITE !,"Plan Closed. "
DO PAUSE^RCRPU
+15 ;
+16 QUIT 1
+17 ;
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 ;
