PRCACOL ;WASH-ISC@ALTOONA,PA/LDB - Payment History Report ;9/27/93 4:31 PM
V ;;4.5;Accounts Receivable;**165,198,264,304**;Mar 20, 1995;Build 104
;;Per VA Directive 6402, this routine should not be modified.
;
EN ;Ask debtor and date range for payment history
N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1
K DIR S POP=0
S DIR(0)="PO^340:QEAMZ",DIR("A")="Select Patient ",DIR("?")="Enter a Patient name" D ^DIR
I $D(DIRUT)!(Y="") G EXIT1
I $P($G(^RCD(340,+Y,0)),U)'["DPT" W *7 G EN
S DEBTOR=+Y K DIR
I '$D(^PRCA(433,"ATD",DEBTOR)) W !,"This patient has made no payments." Q
S BDATE=$S(($$LST^RCFN01(DEBTOR,2)<0):$$FMADD^XLFDT(DT,-30),1:+$$LST^RCFN01(DEBTOR,2)),DIR(0)="DO^2880101:DT",DIR("A")="Payment history beginning date",DIR("B")=$$FMTE^XLFDT(BDATE,"1D")
S DIR("?")="The default date is either the last statement day or T-30, but any date may be entered."
D ^DIR
S:Y'="" BDATE=Y I $D(DIRUT)&'Y G EXIT1 Q
K DIR,X,Y
S DIR(0)="DO^"_BDATE_":DT",DIR("A")="Payment history ending date",DIR("B")=$$FMTE^XLFDT(DT,"1D")
D ^DIR S:Y="" Y=DT I $D(DIRUT)&'Y G EXIT1 Q
S EDATE=Y
K DIR
S %ZIS="AEQ" D ^%ZIS G:POP EXIT1
I $D(IO("Q")) D Q
.S ZTSAVE("DEBTOR")="",ZTSAVE("BDATE")="",ZTSAVE("EDATE")="",ZTRTN="DQ^PRCACOL",ZTDESC="Patient Payment/Refund Transaction History Report"
.D ^%ZTLOAD,^%ZISC,EXIT1 K ZTSAVE,ZTRTN,IO("Q") Q
;
DQ ;Call to build array of payment transactions
;
U IO
D TRANS
I '$D(^TMP($J,"PRCACOL")) D HDR W !!,"This patient has no payments or refunds during this time period."
I $D(^TMP($J)) D HDR,PRINT
;
EXIT1 K AMT,BDATE,EDATE,DATE,DEBTOR,DIR,DUOUT,DX,DY,LINE,PG,PNODE,TN,X,Y,ZTSK,TOTPD,TOTREF,TOTPRIN,TOTINT,TOTADM,^TMP($J),^UTILITY($J)
I $D(DIRUT)!POP K DIRUT,POP Q
;end of routine
EXIT2 I $E(IOST,1,2)'="C-" W @IOF D ^%ZISC Q
I $E(IOST,1,2)="C-" D ENS^%ZISS S DY=IOM-1,DX=0 X IOXY D KILL^%ZISS K DIR,X,Y,^UTILITY($J) S DIR(0)="E" D ^DIR
I $D(DIRUT) K DIRUT Q
D ^%ZISC
G EN
;
TRANS ;Build array of transactions
N BILL
S (PG,TOTPD,TOTREF,TOTPRIN,TOTINT,TOTADM)=0,$P(LINE,"-",75)="-" K ^TMP($J) D DT^DICRW
S BILL=0 F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:'BILL D
.S TN=0 F S TN=$O(^PRCA(433,"C",+BILL,TN)) Q:'TN D
..I $D(^PRCA(433,TN,0)),$D(^(1)),"^2^34^41^"[("^"_$P(^(1),"^",2)_"^") D
...; if transaction is not complete (2), do not display it
...I $P(^PRCA(433,TN,0),"^",4)'=2 Q
...S X=^PRCA(433,TN,1),DATE=+X Q:DATE<BDATE!(+X>EDATE)
...S ^TMP($J,"PRCACOL",DATE,TN)=$P($G(^PRCA(433,+TN,0)),U,2)_U_$P(X,U)_U_$S($P(X,U,2)=41:"Y",1:"")_U_$P(X,U,3)_U_$P(X,U,5)
...S:$P(^TMP($J,"PRCACOL",DATE,TN),U,3)'="Y" TOTPD=TOTPD+$P(X,U,5) S:$P(^(TN),U,3)="Y" TOTREF=TOTREF+$P(X,U,5)
...I $D(^PRCA(433,TN,3)) S X=^(3),^TMP($J,"PRCACOL",DATE,TN)=^TMP($J,"PRCACOL",DATE,TN)_U_$P(X,U)_U_$P(X,U,2)_U_$P(X,U,3) D
....S:$P(^TMP($J,"PRCACOL",DATE,TN),U,3)'="Y" TOTPRIN=TOTPRIN+$P(X,U),TOTINT=TOTINT+$P(X,U,2),TOTADM=TOTADM+$P(X,U,3)
Q
;
PRINT ;Print transactions
S DATE=0 F S DATE=$O(^TMP($J,"PRCACOL",DATE)) Q:'DATE Q:$D(DIRUT) D
.S TN=0 F S TN=$O(^TMP($J,"PRCACOL",DATE,TN)) Q:'TN D SCRN Q:$D(DIRUT) D
..S PNODE=^TMP($J,"PRCACOL",DATE,TN) W !,$$FMTE^XLFDT($P(PNODE,U,2),"1D"),?15,$P($G(^PRCA(430,+$P(PNODE,U),0)),U)
..W ?27,$P(PNODE,U,3),?32,$P(PNODE,U,4),?45 S AMT=$P(PNODE,U,5) W $J(AMT,6,2)
..F X=1:1:3 S X(X)=$P(PNODE,U,X+5) W:X=1 ?53,$J(X(X),6,2) W:X=2 ?61,$J(X(X),6,2) W:X=3 ?69,$J(X(X),6,2)
..D SCRN Q:$D(DIRUT)
..Q
.Q
;
D SCRN Q:$D(DIRUT)
W !!,?25," Total Principal Paid: ",?50,$J(TOTPRIN,12,2)
D SCRN Q:$D(DIRUT)
W !,?25," Total Interest Paid: ",?50,$J(TOTINT,12,2)
D SCRN Q:$D(DIRUT)
W !,?25," Total Admin Paid: ",?50,$J(TOTADM,12,2)
D SCRN Q:$D(DIRUT)
W !,?25," Total Paid: ",?50,$J(TOTPD,12,2)
D SCRN Q:$D(DIRUT)
W !,?25," Total Refund: ",?50,$J(TOTREF,12,2)
Q
;
SCRN ;Check for screen
K DIR I ($Y+3)>IOSL D
.I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR Q:$D(DIRUT)
.D HDR
Q
;
HDR ;Heading for report
S PG=PG+1
W @IOF,!,?20,"Patient Payment History Report",?70,"Page ",PG
W !,?20,"------------------------------"
W !!,?18,"For Patient: ",$$NAM^RCFN01(DEBTOR),!,?25,"SSN : ",$$SSN^RCFN01(DEBTOR)
W !,?20,"For dates: ",$$FMTE^XLFDT(BDATE,"ID"),"-",$$FMTE^XLFDT(EDATE,"1D")
W !!," DATE OF",!,"PAYMENT/REFUND",?16,"BILL #",?25,"REFUND",?32,"RECEIPT #",?45,"AMOUNT",?54,"PRIN.",?62,"INT.",?70,"ADMIN.",!,LINE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCACOL 4445 printed Sep 23, 2025@19:15:14 Page 2
PRCACOL ;WASH-ISC@ALTOONA,PA/LDB - Payment History Report ;9/27/93 4:31 PM
V ;;4.5;Accounts Receivable;**165,198,264,304**;Mar 20, 1995;Build 104
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 ;
EN ;Ask debtor and date range for payment history
+1 NEW DPTNOFZY,DPTNOFZK
SET (DPTNOFZY,DPTNOFZK)=1
+2 KILL DIR
SET POP=0
+3 SET DIR(0)="PO^340:QEAMZ"
SET DIR("A")="Select Patient "
SET DIR("?")="Enter a Patient name"
DO ^DIR
+4 IF $DATA(DIRUT)!(Y="")
GOTO EXIT1
+5 IF $PIECE($GET(^RCD(340,+Y,0)),U)'["DPT"
WRITE *7
GOTO EN
+6 SET DEBTOR=+Y
KILL DIR
+7 IF '$DATA(^PRCA(433,"ATD",DEBTOR))
WRITE !,"This patient has made no payments."
QUIT
+8 SET BDATE=$SELECT(($$LST^RCFN01(DEBTOR,2)<0):$$FMADD^XLFDT(DT,-30),1:+$$LST^RCFN01(DEBTOR,2))
SET DIR(0)="DO^2880101:DT"
SET DIR("A")="Payment history beginning date"
SET DIR("B")=$$FMTE^XLFDT(BDATE,"1D")
+9 SET DIR("?")="The default date is either the last statement day or T-30, but any date may be entered."
+10 DO ^DIR
+11 if Y'=""
SET BDATE=Y
IF $DATA(DIRUT)&'Y
GOTO EXIT1
QUIT
+12 KILL DIR,X,Y
+13 SET DIR(0)="DO^"_BDATE_":DT"
SET DIR("A")="Payment history ending date"
SET DIR("B")=$$FMTE^XLFDT(DT,"1D")
+14 DO ^DIR
if Y=""
SET Y=DT
IF $DATA(DIRUT)&'Y
GOTO EXIT1
QUIT
+15 SET EDATE=Y
+16 KILL DIR
+17 SET %ZIS="AEQ"
DO ^%ZIS
if POP
GOTO EXIT1
+18 IF $DATA(IO("Q"))
Begin DoDot:1
+19 SET ZTSAVE("DEBTOR")=""
SET ZTSAVE("BDATE")=""
SET ZTSAVE("EDATE")=""
SET ZTRTN="DQ^PRCACOL"
SET ZTDESC="Patient Payment/Refund Transaction History Report"
+20 DO ^%ZTLOAD
DO ^%ZISC
DO EXIT1
KILL ZTSAVE,ZTRTN,IO("Q")
QUIT
End DoDot:1
QUIT
+21 ;
DQ ;Call to build array of payment transactions
+1 ;
+2 USE IO
+3 DO TRANS
+4 IF '$DATA(^TMP($JOB,"PRCACOL"))
DO HDR
WRITE !!,"This patient has no payments or refunds during this time period."
+5 IF $DATA(^TMP($JOB))
DO HDR
DO PRINT
+6 ;
EXIT1 KILL AMT,BDATE,EDATE,DATE,DEBTOR,DIR,DUOUT,DX,DY,LINE,PG,PNODE,TN,X,Y,ZTSK,TOTPD,TOTREF,TOTPRIN,TOTINT,TOTADM,^TMP($JOB),^UTILITY($JOB)
+1 IF $DATA(DIRUT)!POP
KILL DIRUT,POP
QUIT
+2 ;end of routine
EXIT2 IF $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
DO ^%ZISC
QUIT
+1 IF $EXTRACT(IOST,1,2)="C-"
DO ENS^%ZISS
SET DY=IOM-1
SET DX=0
XECUTE IOXY
DO KILL^%ZISS
KILL DIR,X,Y,^UTILITY($JOB)
SET DIR(0)="E"
DO ^DIR
+2 IF $DATA(DIRUT)
KILL DIRUT
QUIT
+3 DO ^%ZISC
+4 GOTO EN
+5 ;
TRANS ;Build array of transactions
+1 NEW BILL
+2 SET (PG,TOTPD,TOTREF,TOTPRIN,TOTINT,TOTADM)=0
SET $PIECE(LINE,"-",75)="-"
KILL ^TMP($JOB)
DO DT^DICRW
+3 SET BILL=0
FOR
SET BILL=$ORDER(^PRCA(430,"C",DEBTOR,BILL))
if 'BILL
QUIT
Begin DoDot:1
+4 SET TN=0
FOR
SET TN=$ORDER(^PRCA(433,"C",+BILL,TN))
if 'TN
QUIT
Begin DoDot:2
+5 IF $DATA(^PRCA(433,TN,0))
IF $DATA(^(1))
IF "^2^34^41^"[("^"_$PIECE(^(1),"^",2)_"^")
Begin DoDot:3
+6 ; if transaction is not complete (2), do not display it
+7 IF $PIECE(^PRCA(433,TN,0),"^",4)'=2
QUIT
+8 SET X=^PRCA(433,TN,1)
SET DATE=+X
if DATE<BDATE!(+X>EDATE)
QUIT
+9 SET ^TMP($JOB,"PRCACOL",DATE,TN)=$PIECE($GET(^PRCA(433,+TN,0)),U,2)_U_$PIECE(X,U)_U_$SELECT($PIECE(X,U,2)=41:"Y",1:"")_U_$PIECE(X,U,3)_U_$PIECE(X,U,5)
+10 if $PIECE(^TMP($JOB,"PRCACOL",DATE,TN),U,3)'="Y"
SET TOTPD=TOTPD+$PIECE(X,U,5)
if $PIECE(^(TN),U,3)="Y"
SET TOTREF=TOTREF+$PIECE(X,U,5)
+11 IF $DATA(^PRCA(433,TN,3))
SET X=^(3)
SET ^TMP($JOB,"PRCACOL",DATE,TN)=^TMP($JOB,"PRCACOL",DATE,TN)_U_$PIECE(X,U)_U_$PIECE(X,U,2)_U_$PIECE(X,U,3)
Begin DoDot:4
+12 if $PIECE(^TMP($JOB,"PRCACOL",DATE,TN),U,3)'="Y"
SET TOTPRIN=TOTPRIN+$PIECE(X,U)
SET TOTINT=TOTINT+$PIECE(X,U,2)
SET TOTADM=TOTADM+$PIECE(X,U,3)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
PRINT ;Print transactions
+1 SET DATE=0
FOR
SET DATE=$ORDER(^TMP($JOB,"PRCACOL",DATE))
if 'DATE
QUIT
if $DATA(DIRUT)
QUIT
Begin DoDot:1
+2 SET TN=0
FOR
SET TN=$ORDER(^TMP($JOB,"PRCACOL",DATE,TN))
if 'TN
QUIT
DO SCRN
if $DATA(DIRUT)
QUIT
Begin DoDot:2
+3 SET PNODE=^TMP($JOB,"PRCACOL",DATE,TN)
WRITE !,$$FMTE^XLFDT($PIECE(PNODE,U,2),"1D"),?15,$PIECE($GET(^PRCA(430,+$PIECE(PNODE,U),0)),U)
+4 WRITE ?27,$PIECE(PNODE,U,3),?32,$PIECE(PNODE,U,4),?45
SET AMT=$PIECE(PNODE,U,5)
WRITE $JUSTIFY(AMT,6,2)
+5 FOR X=1:1:3
SET X(X)=$PIECE(PNODE,U,X+5)
if X=1
WRITE ?53,$JUSTIFY(X(X),6,2)
if X=2
WRITE ?61,$JUSTIFY(X(X),6,2)
if X=3
WRITE ?69,$JUSTIFY(X(X),6,2)
+6 DO SCRN
if $DATA(DIRUT)
QUIT
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 ;
+10 DO SCRN
if $DATA(DIRUT)
QUIT
+11 WRITE !!,?25," Total Principal Paid: ",?50,$JUSTIFY(TOTPRIN,12,2)
+12 DO SCRN
if $DATA(DIRUT)
QUIT
+13 WRITE !,?25," Total Interest Paid: ",?50,$JUSTIFY(TOTINT,12,2)
+14 DO SCRN
if $DATA(DIRUT)
QUIT
+15 WRITE !,?25," Total Admin Paid: ",?50,$JUSTIFY(TOTADM,12,2)
+16 DO SCRN
if $DATA(DIRUT)
QUIT
+17 WRITE !,?25," Total Paid: ",?50,$JUSTIFY(TOTPD,12,2)
+18 DO SCRN
if $DATA(DIRUT)
QUIT
+19 WRITE !,?25," Total Refund: ",?50,$JUSTIFY(TOTREF,12,2)
+20 QUIT
+21 ;
SCRN ;Check for screen
+1 KILL DIR
IF ($Y+3)>IOSL
Begin DoDot:1
+2 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)
QUIT
+3 DO HDR
End DoDot:1
+4 QUIT
+5 ;
HDR ;Heading for report
+1 SET PG=PG+1
+2 WRITE @IOF,!,?20,"Patient Payment History Report",?70,"Page ",PG
+3 WRITE !,?20,"------------------------------"
+4 WRITE !!,?18,"For Patient: ",$$NAM^RCFN01(DEBTOR),!,?25,"SSN : ",$$SSN^RCFN01(DEBTOR)
+5 WRITE !,?20,"For dates: ",$$FMTE^XLFDT(BDATE,"ID"),"-",$$FMTE^XLFDT(EDATE,"1D")
+6 WRITE !!," DATE OF",!,"PAYMENT/REFUND",?16,"BILL #",?25,"REFUND",?32,"RECEIPT #",?45,"AMOUNT",?54,"PRIN.",?62,"INT.",?70,"ADMIN.",!,LINE
+7 QUIT
