- PRCARPS ;SF-ISC/YJK-REPAYMENT PAYMENT STATEMENT ;10/23/93 9:50 AM
- ;;4.5;Accounts Receivable;**104,315**;Mar 20, 1995;Build 67
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ;PRINT THE PAYMENT STATEMENT FOR REPAYMENT PLAN
- N PRCALL
- BEGIN ;PRCA*4.5*315 Allow GOTBILL (PRCABN) to be passed in
- I $G(GOTBILL)="" D BILL^PRCAUTL Q:'$D(PRCABN)
- S PRCA("BILLN")=$P(^PRCA(430,PRCABN,0),U,1),PRCA("DEBTOR")=$P(^(0),U,9)
- I $G(GOTBILL)="" I '$D(^PRCA(430,PRCABN,5)) W !,*7,"NO REPAYMENT PLAN FOR THIS ACCOUNT.",! Q
- I $G(GOTBILL)=1 I '$D(^PRCA(430,PRCABN,5)) W !,*7,"NO REPAYMENT PLAN FOR THIS ACCOUNT.",! H 5 Q
- S PRCAREP=1 Q
- PRINTST S PRCAREP=0 D BEGIN G:PRCAREP=0 END D EN,KILLV G PRINTST
- EN S PRCAPT=0 D GETPT I PRCAPT=0 W !,"NO PAYMENT DATA!",! Q
- I '$D(DT) S %DT="",X="T" D ^%DT S DT=+Y K %DT
- S %ZIS="Q" D ^%ZIS Q:POP I IO=IO(0) D PRT Q
- I $D(IO("Q")) K IO("Q") D QUE D:IO'=IO(0) CLOSEDV Q
- U IO D PRT Q
- PRT K PRCAPP D GETPAY Q:'$D(PRCAPP) D SETLINE,GETPB,WRST^PRCARPS1
- I '$D(DT) S %DT="",X="T" D ^%DT S DT=+Y K %DT
- I PRCANOD>0 S $P(^PRCA(430,PRCABN,5,PRCANOD,0),U,3)=1,$P(^PRCA(430,PRCABN,5,PRCANOD,0),U,5)=DT
- D CLOSEDV Q
- QUE K ZTSK,ZTSAVE S ZTSAVE("PRCAPT")=PRCAPT,ZTSAVE("PRCADUE")=PRCADUE,ZTSAVE("PRCABN")=PRCABN,ZTSAVE("PRCA(""BILLN"")")=PRCA("BILLN"),ZTSAVE("PRCA(""DEBTOR"")")=PRCA("DEBTOR"),ZTSAVE("PRCANOD")=PRCANOD
- S ZTRTN="PRT^PRCARPS",ZTDESC="Repayment Plan Statement" D ^%ZTLOAD K ZTRTN,ZTSAVE Q
- CLOSEDV D ^%ZISC Q
- KILLV ;
- END K PRCAREP,PRCABN,PRCA,PRCAPP,PRCAPB,PRCALN,PRCAST1,PRCACITY,PRCA("DEBTNAM"),PRCA("DEBTOR"),I,PRCADT,PRCADUE,PRCAMT,PRCANOD,PRCAPT,PRCASSAN,PRCAKIP,PRCABN1,PRCA1,PRCATY,PRCARDT,PRCANO D KVAR^VADPT Q
- ;
- GETPT S PRCAKEN=+$P(^PRCA(430,PRCABN,5,0),U,4),(PRCADUE,PRCANOD)=0
- F Z=1:1:PRCAKEN I +$P(^PRCA(430,PRCABN,5,Z,0),U,4)>0,+$P(^(0),U,3)'>0 S PRCAPT=$P(^(0),U,4),PRCANOD=Z Q
- F Z=1:1:PRCAKEN I +$P(^PRCA(430,PRCABN,5,Z,0),U,2)<1 S PRCADUE=+$P(^(0),U,1) Q
- K Z,PRCAKEN Q
- GETPAY S PRCADT=$P(^PRCA(433,PRCAPT,1),U,1) Q:PRCADT=""
- S Y=PRCADT D DD^%DT
- S PRCADT=$E(PRCADT,4,5)_"/"_$E(PRCADT,6,7)_"/"_$P(Y,", ",2)
- S PRCAMT=+$P(^PRCA(433,PRCAPT,1),U,5) Q:PRCAMT'>0
- S Z3=$S($D(^PRCA(433,PRCAPT,3)):^(3),1:"") Q:Z3=""
- F Z=1:1:5 S PRCAPP(Z)=+$P(Z3,U,Z)
- K Z,Z3 Q
- GETPB S Z4=^PRCA(430,PRCABN,7)
- F Z=1:1:5 S PRCAPB(Z)=+$P(Z4,U,Z)
- K Z,Z4 Q
- SETLINE S PRCALN=0 S:IOM>87 PRCALN=7 S PRCALN(0)=25+PRCALN,PRCALN(1)=50+PRCALN,PRCALN(2)=52+PRCALN,PRCALN(3)=62+PRCALN,PRCALN(4)=64+PRCALN,PRCALN(5)=10+PRCALN,PRCALN(6)=30+PRCALN
- S PRCALL(1)=18+PRCALN,PRCALL(2)=20+PRCALN,PRCALL(3)=30+PRCALN,PRCALL(4)=32+PRCALN,PRCALL(5)=42+PRCALN,PRCALL(6)=44+PRCALN,PRCALL(7)=54+PRCALN,PRCALL(8)=56+PRCALN,PRCALL(9)=66+PRCALN,PRCALL(10)=68+PRCALN,PRCALL(11)=78+PRCALN Q
- ;==================== REPRINT STATEMENT ============================
- EN1 ;Reprint the payment statement.
- S PRCAREP=0 D BEGIN G:+PRCAREP=0 END
- K PRCARDT D DATE G:'$D(PRCARDT) END
- S PRCA1=0 D LOOK I PRCA1=0 W !,*7,"THE DATE DOES NOT MATCH !, PLEASE CHECK REPAYMENT PROFILE.",!! G END
- D CLDATE D EN,KILLV G EN1
- LOOK S Z1=0
- F Z0=0:0 S Z1=$O(^PRCA(430,PRCABN,5,Z1)) Q:+Z1'>0 I $P(^(Z1,0),U,5)=PRCARDT S PRCA1=1,PRCABN1=Z1 K Z1 Q
- K Z0 Q
- DATE S %DT="AE",%DT("A")="Enter the date the statement was printed: " D ^%DT Q:Y<0 S PRCARDT=+Y Q
- CLDATE Q:'$D(^PRCA(430,PRCABN,5,PRCABN1,0)) S $P(^(0),U,3)=0,$P(^(0),U,5)="" Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCARPS 3373 printed Jan 18, 2025@02:42:29 Page 2
- PRCARPS ;SF-ISC/YJK-REPAYMENT PAYMENT STATEMENT ;10/23/93 9:50 AM
- +1 ;;4.5;Accounts Receivable;**104,315**;Mar 20, 1995;Build 67
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;PRINT THE PAYMENT STATEMENT FOR REPAYMENT PLAN
- +5 NEW PRCALL
- BEGIN ;PRCA*4.5*315 Allow GOTBILL (PRCABN) to be passed in
- +1 IF $GET(GOTBILL)=""
- DO BILL^PRCAUTL
- if '$DATA(PRCABN)
- QUIT
- +2 SET PRCA("BILLN")=$PIECE(^PRCA(430,PRCABN,0),U,1)
- SET PRCA("DEBTOR")=$PIECE(^(0),U,9)
- +3 IF $GET(GOTBILL)=""
- IF '$DATA(^PRCA(430,PRCABN,5))
- WRITE !,*7,"NO REPAYMENT PLAN FOR THIS ACCOUNT.",!
- QUIT
- +4 IF $GET(GOTBILL)=1
- IF '$DATA(^PRCA(430,PRCABN,5))
- WRITE !,*7,"NO REPAYMENT PLAN FOR THIS ACCOUNT.",!
- HANG 5
- QUIT
- +5 SET PRCAREP=1
- QUIT
- PRINTST SET PRCAREP=0
- DO BEGIN
- if PRCAREP=0
- GOTO END
- DO EN
- DO KILLV
- GOTO PRINTST
- EN SET PRCAPT=0
- DO GETPT
- IF PRCAPT=0
- WRITE !,"NO PAYMENT DATA!",!
- QUIT
- +1 IF '$DATA(DT)
- SET %DT=""
- SET X="T"
- DO ^%DT
- SET DT=+Y
- KILL %DT
- +2 SET %ZIS="Q"
- DO ^%ZIS
- if POP
- QUIT
- IF IO=IO(0)
- DO PRT
- QUIT
- +3 IF $DATA(IO("Q"))
- KILL IO("Q")
- DO QUE
- if IO'=IO(0)
- DO CLOSEDV
- QUIT
- +4 USE IO
- DO PRT
- QUIT
- PRT KILL PRCAPP
- DO GETPAY
- if '$DATA(PRCAPP)
- QUIT
- DO SETLINE
- DO GETPB
- DO WRST^PRCARPS1
- +1 IF '$DATA(DT)
- SET %DT=""
- SET X="T"
- DO ^%DT
- SET DT=+Y
- KILL %DT
- +2 IF PRCANOD>0
- SET $PIECE(^PRCA(430,PRCABN,5,PRCANOD,0),U,3)=1
- SET $PIECE(^PRCA(430,PRCABN,5,PRCANOD,0),U,5)=DT
- +3 DO CLOSEDV
- QUIT
- QUE KILL ZTSK,ZTSAVE
- SET ZTSAVE("PRCAPT")=PRCAPT
- SET ZTSAVE("PRCADUE")=PRCADUE
- SET ZTSAVE("PRCABN")=PRCABN
- SET ZTSAVE("PRCA(""BILLN"")")=PRCA("BILLN")
- SET ZTSAVE("PRCA(""DEBTOR"")")=PRCA("DEBTOR")
- SET ZTSAVE("PRCANOD")=PRCANOD
- +1 SET ZTRTN="PRT^PRCARPS"
- SET ZTDESC="Repayment Plan Statement"
- DO ^%ZTLOAD
- KILL ZTRTN,ZTSAVE
- QUIT
- CLOSEDV DO ^%ZISC
- QUIT
- KILLV ;
- END KILL PRCAREP,PRCABN,PRCA,PRCAPP,PRCAPB,PRCALN,PRCAST1,PRCACITY,PRCA("DEBTNAM"),PRCA("DEBTOR"),I,PRCADT,PRCADUE,PRCAMT,PRCANOD,PRCAPT,PRCASSAN,PRCAKIP,PRCABN1,PRCA1,PRCATY,PRCARDT,PRCANO
- DO KVAR^VADPT
- QUIT
- +1 ;
- GETPT SET PRCAKEN=+$PIECE(^PRCA(430,PRCABN,5,0),U,4)
- SET (PRCADUE,PRCANOD)=0
- +1 FOR Z=1:1:PRCAKEN
- IF +$PIECE(^PRCA(430,PRCABN,5,Z,0),U,4)>0
- IF +$PIECE(^(0),U,3)'>0
- SET PRCAPT=$PIECE(^(0),U,4)
- SET PRCANOD=Z
- QUIT
- +2 FOR Z=1:1:PRCAKEN
- IF +$PIECE(^PRCA(430,PRCABN,5,Z,0),U,2)<1
- SET PRCADUE=+$PIECE(^(0),U,1)
- QUIT
- +3 KILL Z,PRCAKEN
- QUIT
- GETPAY SET PRCADT=$PIECE(^PRCA(433,PRCAPT,1),U,1)
- if PRCADT=""
- QUIT
- +1 SET Y=PRCADT
- DO DD^%DT
- +2 SET PRCADT=$EXTRACT(PRCADT,4,5)_"/"_$EXTRACT(PRCADT,6,7)_"/"_$PIECE(Y,", ",2)
- +3 SET PRCAMT=+$PIECE(^PRCA(433,PRCAPT,1),U,5)
- if PRCAMT'>0
- QUIT
- +4 SET Z3=$SELECT($DATA(^PRCA(433,PRCAPT,3)):^(3),1:"")
- if Z3=""
- QUIT
- +5 FOR Z=1:1:5
- SET PRCAPP(Z)=+$PIECE(Z3,U,Z)
- +6 KILL Z,Z3
- QUIT
- GETPB SET Z4=^PRCA(430,PRCABN,7)
- +1 FOR Z=1:1:5
- SET PRCAPB(Z)=+$PIECE(Z4,U,Z)
- +2 KILL Z,Z4
- QUIT
- SETLINE SET PRCALN=0
- if IOM>87
- SET PRCALN=7
- SET PRCALN(0)=25+PRCALN
- SET PRCALN(1)=50+PRCALN
- SET PRCALN(2)=52+PRCALN
- SET PRCALN(3)=62+PRCALN
- SET PRCALN(4)=64+PRCALN
- SET PRCALN(5)=10+PRCALN
- SET PRCALN(6)=30+PRCALN
- +1 SET PRCALL(1)=18+PRCALN
- SET PRCALL(2)=20+PRCALN
- SET PRCALL(3)=30+PRCALN
- SET PRCALL(4)=32+PRCALN
- SET PRCALL(5)=42+PRCALN
- SET PRCALL(6)=44+PRCALN
- SET PRCALL(7)=54+PRCALN
- SET PRCALL(8)=56+PRCALN
- SET PRCALL(9)=66+PRCALN
- SET PRCALL(10)=68+PRCALN
- SET PRCALL(11)=78+PRCALN
- QUIT
- +2 ;==================== REPRINT STATEMENT ============================
- EN1 ;Reprint the payment statement.
- +1 SET PRCAREP=0
- DO BEGIN
- if +PRCAREP=0
- GOTO END
- +2 KILL PRCARDT
- DO DATE
- if '$DATA(PRCARDT)
- GOTO END
- +3 SET PRCA1=0
- DO LOOK
- IF PRCA1=0
- WRITE !,*7,"THE DATE DOES NOT MATCH !, PLEASE CHECK REPAYMENT PROFILE.",!!
- GOTO END
- +4 DO CLDATE
- DO EN
- DO KILLV
- GOTO EN1
- LOOK SET Z1=0
- +1 FOR Z0=0:0
- SET Z1=$ORDER(^PRCA(430,PRCABN,5,Z1))
- if +Z1'>0
- QUIT
- IF $PIECE(^(Z1,0),U,5)=PRCARDT
- SET PRCA1=1
- SET PRCABN1=Z1
- KILL Z1
- QUIT
- +2 KILL Z0
- QUIT
- DATE SET %DT="AE"
- SET %DT("A")="Enter the date the statement was printed: "
- DO ^%DT
- if Y<0
- QUIT
- SET PRCARDT=+Y
- QUIT
- CLDATE if '$DATA(^PRCA(430,PRCABN,5,PRCABN1,0))
- QUIT
- SET $PIECE(^(0),U,3)=0
- SET $PIECE(^(0),U,5)=""
- QUIT