PRCAREP ;SF-ISC/YJK-CREATE REPAYMENT DATE SCHEDULE ;10/15/93 9:47 AM
V ;;4.5;Accounts Receivable;**301**;Mar 20, 1995;Build 144
;;Per VA Directive 6402, this routine should not be modified.
;This sets up repayment schedule for A/R.
BEGIN K DIC
EN W !! D BILL^PRCAUTL G:('$D(PRCABN)) END I +PRCA("STATUS")>0,$P(^PRCA(430.3,PRCA("STATUS"),0),U,3)'=102 W !,*7,"NOT AN ACTIVE ACCOUNT !" G EN
I $D(^PRCA(430,"TCSP",PRCABN)) W !,"BILL HAS BEEN REFERRED TO CROSS-SERVICING.",!,"A REPAYMENT PLAN FOR THIS BILL MUST BE ESTABLISHED WITH TREASURY." Q ;prca*4.5*301
I $D(^PRCA(430,PRCABN,5)) W *7,!,"THIS ACCOUNT ALREADY HAS A REPAYMENT PLAN !",!
S PRCAPB=$S($D(^PRCA(430,PRCABN,7)):$P(^(7),U,1)+$P(^(7),U,2)+$P(^(7),U,3)+$P(^(7),U,4)+$P(^(7),U,5),1:$P(^(0),U,3)),PRCAMT=0
S PRCADT="" D DIE G:PRCA("LOCK")=1 EN I (+PRCADT>0)&(+PRCAMT>0) D SET G EN
I '$D(^PRCA(430,PRCABN,4)) W !,"NO REPAYMENT PLAN!",*7 K ^PRCA(430,PRCABN,5) G EN
I $P(^PRCA(430,PRCABN,4),U,1)="" W *7,!,"NO REPAYMENT PLAN !" K ^PRCA(430,PRCABN,5) G EN
W !,"NOTHING CHANGED !",! G EN
;
DIE S DIC="^PRCA(430,",DIE=DIC,DA=PRCABN,DR="41;S PRCADT=X;42;S PRCADAY=X;43;S PRCAMT=X" S PRCA("LOCK")=0 D LOCKF^PRCAWO1 D:PRCA("LOCK")=0 ^DIE
K DIE,DR L -^PRCA(430,+$G(PRCABN)) Q ;end of DIE
SET S PRCANPAY=PRCAPB/PRCAMT,PRCANPAY=$S(PRCANPAY>(PRCAPB\PRCAMT):PRCAPB\PRCAMT+1,1:PRCAPB\PRCAMT)
W !!,"NUMBER OF PAYMENTS WILL BE ",PRCANPAY,! I PRCANPAY>60 W !,*7,"THIS NUMBER SHOULD BE LESS THAN 60 !, CHECK THE INPUT AGAIN",! Q
S %DT="AEFX",%DT("A")="DUE DATE OF 1ST PAYMENT: " D ^%DT K %DT
I Y<0 W !,*7,"NOTHING CHANGED !" Q
K ^PRCA(430,PRCABN,5) S PRCAYR=$E(Y,1,3),PRCAMON=$E(Y,4,5) S:$L(PRCADAY)=1 PRCADAY="0"_PRCADAY D HOLD^PRCAUT1
F Z0=1:1:PRCANPAY S Z1=PRCAYR_$S((PRCAMON<10&($E(PRCAMON,1)'=0)):0_PRCAMON,1:PRCAMON)_PRCADAY,^PRCA(430,DA,5,Z0,0)=Z1_U_"0",PRCAMON=PRCAMON+1 S:PRCAMON=13 PRCAMON=1,PRCAYR=PRCAYR+1
S ^PRCA(430,DA,5,0)="^430.051DA^"_PRCANPAY_"^"_PRCANPAY,$P(^PRCA(430,DA,4),U,4)=PRCANPAY
S PRCAKTY=$O(^PRCA(430.3,"AC",16,"")) D TRAN,IXDIK S $P(^PRCA(433,PRCAEN,0),U,4)=2
W !!,"THE REPAYMENT PLAN HAS BEEN ESTABLISHED.",!
EXIT K PRCAKTY,PRCAMON,PRCAYR,PRCANPAY,DA1,DIK,DA Q ;end of SET
IXDIK S DIK="^PRCA(430,"_PRCABN_",5,",DA(1)=PRCABN D IXALL^DIK K DIK Q
TRAN S PRCAEN=-1 D SETTR^PRCAUTL Q:PRCAEN<0 S DA=PRCAEN
S DIE="^PRCA(433,",DR=".03////"_PRCABN_";11///"_PRCADT_";12///"_PRCAKTY_";15///"_PRCAPB_"" D ^DIE
K DIE,DR,PRCADT Q
END K PRCAS,PRCAMT,PRCA,PRCAKTY,PRCADT,DA,DIE,PRCAYR,PRCAMON,PRCANPAY,DR,PRCAEN,PRCABN,PRCAPB,Z0,PRCADAY,DIC,PRCAS,PRCATY D KVAR^VADPT Q ;end of PRCAREP
PROFILE ;print the repayment plan profile.
K %ZIS,DXS,IOP
D BILL^PRCAUTL G:'$D(PRCABN) END
S %ZIS="Q" D ^%ZIS Q:POP S IOM=80,PRCAIO=IO,PRCAIO(0)=IO(0)
I IO=IO(0) W:$D(IOF) @IOF D TR,CLOSE K PRCAIO,PRCATY G PROFILE
I $D(IO("Q")) K IO("Q") S ZTRTN="TR^PRCAREP",ZTSAVE("PRCABN")=PRCABN,ZTSAVE("PRCAIO(0)")=PRCAIO(0),ZTSAVE("PRCAIO")=PRCAIO,ZTDESC="Repayment Plan Profile"
I D ^%ZTLOAD,CLOSE W:(IOM-$X)<20 ! W " <REQUEST QUEUED>",*7,! K PRCA,PRCATY G PROFILE
U IO D TR,CLOSE G PROFILE
TR S D0=PRCABN K DXS D ^PRCATR1 K DXS W !! K PRCABN,PRCAKTY,PRCA Q
CLOSE D ^%ZISC K IOP,%ZIS,PRCAIO Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAREP 3198 printed Apr 09, 2024@20:51:22 Page 2
PRCAREP ;SF-ISC/YJK-CREATE REPAYMENT DATE SCHEDULE ;10/15/93 9:47 AM
V ;;4.5;Accounts Receivable;**301**;Mar 20, 1995;Build 144
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 ;This sets up repayment schedule for A/R.
BEGIN KILL DIC
EN WRITE !!
DO BILL^PRCAUTL
if ('$DATA(PRCABN))
GOTO END
IF +PRCA("STATUS")>0
IF $PIECE(^PRCA(430.3,PRCA("STATUS"),0),U,3)'=102
WRITE !,*7,"NOT AN ACTIVE ACCOUNT !"
GOTO EN
+1 ;prca*4.5*301
IF $DATA(^PRCA(430,"TCSP",PRCABN))
WRITE !,"BILL HAS BEEN REFERRED TO CROSS-SERVICING.",!,"A REPAYMENT PLAN FOR THIS BILL MUST BE ESTABLISHED WITH TREASURY."
QUIT
+2 IF $DATA(^PRCA(430,PRCABN,5))
WRITE *7,!,"THIS ACCOUNT ALREADY HAS A REPAYMENT PLAN !",!
+3 SET PRCAPB=$SELECT($DATA(^PRCA(430,PRCABN,7)):$PIECE(^(7),U,1)+$PIECE(^(7),U,2)+$PIECE(^(7),U,3)+$PIECE(^(7),U,4)+$PIECE(^(7),U,5),1:$PIECE(^(0),U,3))
SET PRCAMT=0
+4 SET PRCADT=""
DO DIE
if PRCA("LOCK")=1
GOTO EN
IF (+PRCADT>0)&(+PRCAMT>0)
DO SET
GOTO EN
+5 IF '$DATA(^PRCA(430,PRCABN,4))
WRITE !,"NO REPAYMENT PLAN!",*7
KILL ^PRCA(430,PRCABN,5)
GOTO EN
+6 IF $PIECE(^PRCA(430,PRCABN,4),U,1)=""
WRITE *7,!,"NO REPAYMENT PLAN !"
KILL ^PRCA(430,PRCABN,5)
GOTO EN
+7 WRITE !,"NOTHING CHANGED !",!
GOTO EN
+8 ;
DIE SET DIC="^PRCA(430,"
SET DIE=DIC
SET DA=PRCABN
SET DR="41;S PRCADT=X;42;S PRCADAY=X;43;S PRCAMT=X"
SET PRCA("LOCK")=0
DO LOCKF^PRCAWO1
if PRCA("LOCK")=0
DO ^DIE
+1 ;end of DIE
KILL DIE,DR
LOCK -^PRCA(430,+$GET(PRCABN))
QUIT
SET SET PRCANPAY=PRCAPB/PRCAMT
SET PRCANPAY=$SELECT(PRCANPAY>(PRCAPB\PRCAMT):PRCAPB\PRCAMT+1,1:PRCAPB\PRCAMT)
+1 WRITE !!,"NUMBER OF PAYMENTS WILL BE ",PRCANPAY,!
IF PRCANPAY>60
WRITE !,*7,"THIS NUMBER SHOULD BE LESS THAN 60 !, CHECK THE INPUT AGAIN",!
QUIT
+2 SET %DT="AEFX"
SET %DT("A")="DUE DATE OF 1ST PAYMENT: "
DO ^%DT
KILL %DT
+3 IF Y<0
WRITE !,*7,"NOTHING CHANGED !"
QUIT
+4 KILL ^PRCA(430,PRCABN,5)
SET PRCAYR=$EXTRACT(Y,1,3)
SET PRCAMON=$EXTRACT(Y,4,5)
if $LENGTH(PRCADAY)=1
SET PRCADAY="0"_PRCADAY
DO HOLD^PRCAUT1
+5 FOR Z0=1:1:PRCANPAY
SET Z1=PRCAYR_$SELECT((PRCAMON<10&($EXTRACT(PRCAMON,1)'=0)):0_PRCAMON,1:PRCAMON)_PRCADAY
SET ^PRCA(430,DA,5,Z0,0)=Z1_U_"0"
SET PRCAMON=PRCAMON+1
if PRCAMON=13
SET PRCAMON=1
SET PRCAYR=PRCAYR+1
+6 SET ^PRCA(430,DA,5,0)="^430.051DA^"_PRCANPAY_"^"_PRCANPAY
SET $PIECE(^PRCA(430,DA,4),U,4)=PRCANPAY
+7 SET PRCAKTY=$ORDER(^PRCA(430.3,"AC",16,""))
DO TRAN
DO IXDIK
SET $PIECE(^PRCA(433,PRCAEN,0),U,4)=2
+8 WRITE !!,"THE REPAYMENT PLAN HAS BEEN ESTABLISHED.",!
EXIT ;end of SET
KILL PRCAKTY,PRCAMON,PRCAYR,PRCANPAY,DA1,DIK,DA
QUIT
IXDIK SET DIK="^PRCA(430,"_PRCABN_",5,"
SET DA(1)=PRCABN
DO IXALL^DIK
KILL DIK
QUIT
TRAN SET PRCAEN=-1
DO SETTR^PRCAUTL
if PRCAEN<0
QUIT
SET DA=PRCAEN
+1 SET DIE="^PRCA(433,"
SET DR=".03////"_PRCABN_";11///"_PRCADT_";12///"_PRCAKTY_";15///"_PRCAPB_""
DO ^DIE
+2 KILL DIE,DR,PRCADT
QUIT
END ;end of PRCAREP
KILL PRCAS,PRCAMT,PRCA,PRCAKTY,PRCADT,DA,DIE,PRCAYR,PRCAMON,PRCANPAY,DR,PRCAEN,PRCABN,PRCAPB,Z0,PRCADAY,DIC,PRCAS,PRCATY
DO KVAR^VADPT
QUIT
PROFILE ;print the repayment plan profile.
+1 KILL %ZIS,DXS,IOP
+2 DO BILL^PRCAUTL
if '$DATA(PRCABN)
GOTO END
+3 SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
SET IOM=80
SET PRCAIO=IO
SET PRCAIO(0)=IO(0)
+4 IF IO=IO(0)
if $DATA(IOF)
WRITE @IOF
DO TR
DO CLOSE
KILL PRCAIO,PRCATY
GOTO PROFILE
+5 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="TR^PRCAREP"
SET ZTSAVE("PRCABN")=PRCABN
SET ZTSAVE("PRCAIO(0)")=PRCAIO(0)
SET ZTSAVE("PRCAIO")=PRCAIO
SET ZTDESC="Repayment Plan Profile"
+6 IF $TEST
DO ^%ZTLOAD
DO CLOSE
if (IOM-$X)<20
WRITE !
WRITE " <REQUEST QUEUED>",*7,!
KILL PRCA,PRCATY
GOTO PROFILE
+7 USE IO
DO TR
DO CLOSE
GOTO PROFILE
TR SET D0=PRCABN
KILL DXS
DO ^PRCATR1
KILL DXS
WRITE !!
KILL PRCABN,PRCAKTY,PRCA
QUIT
CLOSE DO ^%ZISC
KILL IOP,%ZIS,PRCAIO
QUIT
