- PRCADR3 ;SF-ISC/YJK-TRANSACTION PROFILE ;6/15/93 9:43 AM
- V ;;4.5;Accounts Receivable;**78,153**;Mar 20, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;PRINT THE TRANSACTION PROFILE.
- EN1 ;
- Q:'$D(D0) Q:'$D(^PRCA(433,D0,1)) S Z=$P(^(1),U,2) Q:Z'>0 S PRCATYPE=$P(^PRCA(430.3,Z,0),U,3) K Z S PRCAGL=^PRCA(433,D0,1) W ! D EN3
- W:(PRCATYPE=2)!(PRCATYPE=20) "RECEIPT #:",?13,$P(PRCAGL,U,3),!
- W:(PRCATYPE=21)!(PRCATYPE=1) "ADJUSTMENT #:",?15,$P(PRCAGL,U,4),!
- I (PRCATYPE=8)!(PRCATYPE=9) W "TERMINATION REASON:" D TERM
- D EN2
- I PRCATYPE=12 D ADM
- D @$S((PRCATYPE=2)!(PRCATYPE=20)!(PRCATYPE=7):"COLL",1:"BAL")
- K PRCATYPE,PRCAGL Q
- ADM Q:'$D(^PRCA(433,D0,2)) S PRCAGL=^(2) F I=1:1:9 S Z(I)=$J($P(PRCAGL,U,I),0,2)
- K I W !!,"ADMINISTRATIVE COST CHARGE",!,"---------------------------",! S Z=4,Z0=22
- W:Z(1)>0 ?Z,"IRS LOCATOR:",?Z0,Z(1),!
- W:Z(2)>0 ?Z,"CREDIT AGENCY:",?Z0,Z(2),!
- W:Z(3)>0 ?Z,"DMV LOCATOR:",?Z0,Z(3),!
- W:Z(4)>0 ?Z,"CONSUMER REP.:",?Z0,Z(4),!
- W:Z(5)>0 ?Z,"MARSHALL FEE:",?Z0,Z(5),!
- W:Z(6)>0 ?Z,"COURT COST:",?Z0,Z(6),!
- W:Z(7)>0 ?Z,"INTEREST CHARGE:",?Z0,Z(7),!
- W:Z(8)>0 ?Z,"ADM. CHARGE: ",?Z0,Z(8),!
- W:Z(9)>0 ?Z,"PENALTY CHARGE: ",?Z0,Z(9),!
- I PRCAIO=PRCAIO(0) W !,"PRESS <RETURN> TO CONTINUE: " R X:DTIME W !
- K Z,PRCAGL,Z1 Q
- TERM S Z0=$P(^DD(433,17,0),U,3),Z1=$P(^PRCA(433,D0,1),U,7),Z2=$P(Z0,";",Z1)
- S Z2=$P(Z2,":",2) W ?20,Z2,! K Z0,Z1,Z2 Q
- COLL Q:('$D(^PRCA(433,D0,8)))&('$D(^(3))) S (PRCATL,PRCATL1)=0
- F I=1:1:5 S (Z(I),Z2(I))=0
- I ('$D(^PRCA(433,D0,8)))!('$D(^(3))) K Z,Z2,PRCATL,PRCATL1 Q
- S PRCAGL1=^PRCA(433,D0,8),PRCAGL=^(3) F I=1:1:5 S Z(I)=$J($P(PRCAGL,U,I),0,2),PRCATL=PRCATL+Z(I)
- F I=1:1:5 S Z2(I)=$J($P(PRCAGL1,U,I),0,2),PRCATL1=PRCATL1+Z2(I)
- C1 S Z=40,Z1=49,Z0=4,Z2=20 W !!,?Z2,"BALANCES",?40,"COLLECTED",!,?Z2,"--------",?40,"---------",!
- W ?Z0,"PRINCIPAL:",?Z2,Z2(1),?Z,Z(1),!
- W ?Z0,"INTEREST:",?Z2,Z2(2),?Z,Z(2),!
- W ?Z0,"ADMINISTRATIVE:",?Z2,Z2(3),?Z,Z(3),!
- W ?Z0,"MARSHALL FEE:",?Z2,Z2(4),?Z,Z(4),!
- W ?Z0,"COURT COST:",?Z2,Z2(5),?Z,Z(5)
- W !,?Z2,"---------",?Z,"----------",!,?Z0,"TOTAL:",?Z2,$J(PRCATL1,0,2),?Z,$J(PRCATL,0,2)
- I PRCAIO=PRCAIO(0),PRCATYPE'=12 W !,"PRESS <RETURN> TO CONTINUE: " R X:DTIME W !
- K Z0,I,Z,Z1,Z2,PRCAGL1,PRCAGL,PRCATL,PRCATL1 Q
- BAL Q:'$D(^PRCA(433,D0,8)) S PRCAGL=^(8),PRCATL=0 F I=1:1:5 S Z(I)=$J($P(PRCAGL,U,I),0,2),PRCATL=PRCATL+Z(I)
- S Z=3,Z1=19 W !,"BALANCES",!,"--------",!
- W ?Z,"PRINCIPAL: ",?Z1,Z(1),!,?Z,"INTEREST: ",?Z1,Z(2),!,?Z,"ADMINISTRATIVE: ",?Z1,Z(3),!,?Z,"MARSHALL FEE: ",?Z1,Z(4),!,?Z,"COURT COST: ",?Z1,Z(5),!
- W ?Z1,"------------",!,?Z,"TOTAL",?Z1,$J(PRCATL,0,2),!
- I PRCAIO=PRCAIO(0),PRCATYPE'=12 W !,"PRESS <RETURN> TO CONTINUE: " R X:DTIME W !
- K Z,PRCATL,PRCAGL,Z1 Q
- EN2 ;print the appropriation,pat ref #. (multiple) and amount.
- W !,"FISCAL YEAR",?17,"PRINCIPAL AMOUNT",?42,"FY TRANS. AMOUNT"
- W !,"-----------",?17,"----------------",?42,"----------------"
- S PRCAFN=0 F PRCAE1=0:0 S PRCAFN=$O(^PRCA(433,D0,4,PRCAFN)) Q:PRCAFN'>0 D WRPAT
- I $P(^PRCA(433,D0,0),U,10) W !,"NOTE:**** This transaction is flagged as invalid for patient statement.",!,?10,"It WILL NOT appear on the patient statement.****"
- END1 K PRCAE1,PRCAFN Q ;end of EN1
- WRPAT Q:'$D(^PRCA(433,D0,4,PRCAFN,0)) S PRCAFY=$P(^(0),U,1),PRCAMT=$P(^(0),U,2),PRCATRM=$J($P(^(0),U,5),0,2)
- W !,$J(PRCAFY,11),?17,$J(PRCAMT,16,2),?42,$J(PRCATRM,16,2)
- K PRCAPAT,PRCATRM,PRCAFY,PRCAMT Q
- EN3 S Y=$P(^PRCA(433,D0,0),U,5) D D^PRCAQUE S PRCADT=Y
- W "TRANS. AMOUNT: ",$S($P(^PRCA(433,D0,1),U,5)<0:"-$",1:"$"),$FN($TR($P(^PRCA(433,D0,1),U,5),"-"),",",2) S Y=$P(^(1),"^",9) I Y]"" X ^DD("DD") W:$X>35 ! W ?34,"DATE POSTED: ",$P(Y,"@")," ",$P(Y,"@",2)
- W ! K PRCADT Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCADR3 3712 printed Feb 18, 2025@23:05:45 Page 2
- PRCADR3 ;SF-ISC/YJK-TRANSACTION PROFILE ;6/15/93 9:43 AM
- V ;;4.5;Accounts Receivable;**78,153**;Mar 20, 1995
- +1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;PRINT THE TRANSACTION PROFILE.
- EN1 ;
- +1 if '$DATA(D0)
- QUIT
- if '$DATA(^PRCA(433,D0,1))
- QUIT
- SET Z=$PIECE(^(1),U,2)
- if Z'>0
- QUIT
- SET PRCATYPE=$PIECE(^PRCA(430.3,Z,0),U,3)
- KILL Z
- SET PRCAGL=^PRCA(433,D0,1)
- WRITE !
- DO EN3
- +2 if (PRCATYPE=2)!(PRCATYPE=20)
- WRITE "RECEIPT #:",?13,$PIECE(PRCAGL,U,3),!
- +3 if (PRCATYPE=21)!(PRCATYPE=1)
- WRITE "ADJUSTMENT #:",?15,$PIECE(PRCAGL,U,4),!
- +4 IF (PRCATYPE=8)!(PRCATYPE=9)
- WRITE "TERMINATION REASON:"
- DO TERM
- +5 DO EN2
- +6 IF PRCATYPE=12
- DO ADM
- +7 DO @$SELECT((PRCATYPE=2)!(PRCATYPE=20)!(PRCATYPE=7):"COLL",1:"BAL")
- +8 KILL PRCATYPE,PRCAGL
- QUIT
- ADM if '$DATA(^PRCA(433,D0,2))
- QUIT
- SET PRCAGL=^(2)
- FOR I=1:1:9
- SET Z(I)=$JUSTIFY($PIECE(PRCAGL,U,I),0,2)
- +1 KILL I
- WRITE !!,"ADMINISTRATIVE COST CHARGE",!,"---------------------------",!
- SET Z=4
- SET Z0=22
- +2 if Z(1)>0
- WRITE ?Z,"IRS LOCATOR:",?Z0,Z(1),!
- +3 if Z(2)>0
- WRITE ?Z,"CREDIT AGENCY:",?Z0,Z(2),!
- +4 if Z(3)>0
- WRITE ?Z,"DMV LOCATOR:",?Z0,Z(3),!
- +5 if Z(4)>0
- WRITE ?Z,"CONSUMER REP.:",?Z0,Z(4),!
- +6 if Z(5)>0
- WRITE ?Z,"MARSHALL FEE:",?Z0,Z(5),!
- +7 if Z(6)>0
- WRITE ?Z,"COURT COST:",?Z0,Z(6),!
- +8 if Z(7)>0
- WRITE ?Z,"INTEREST CHARGE:",?Z0,Z(7),!
- +9 if Z(8)>0
- WRITE ?Z,"ADM. CHARGE: ",?Z0,Z(8),!
- +10 if Z(9)>0
- WRITE ?Z,"PENALTY CHARGE: ",?Z0,Z(9),!
- +11 IF PRCAIO=PRCAIO(0)
- WRITE !,"PRESS <RETURN> TO CONTINUE: "
- READ X:DTIME
- WRITE !
- +12 KILL Z,PRCAGL,Z1
- QUIT
- TERM SET Z0=$PIECE(^DD(433,17,0),U,3)
- SET Z1=$PIECE(^PRCA(433,D0,1),U,7)
- SET Z2=$PIECE(Z0,";",Z1)
- +1 SET Z2=$PIECE(Z2,":",2)
- WRITE ?20,Z2,!
- KILL Z0,Z1,Z2
- QUIT
- COLL if ('$DATA(^PRCA(433,D0,8)))&('$DATA(^(3)))
- QUIT
- SET (PRCATL,PRCATL1)=0
- +1 FOR I=1:1:5
- SET (Z(I),Z2(I))=0
- +2 IF ('$DATA(^PRCA(433,D0,8)))!('$DATA(^(3)))
- KILL Z,Z2,PRCATL,PRCATL1
- QUIT
- +3 SET PRCAGL1=^PRCA(433,D0,8)
- SET PRCAGL=^(3)
- FOR I=1:1:5
- SET Z(I)=$JUSTIFY($PIECE(PRCAGL,U,I),0,2)
- SET PRCATL=PRCATL+Z(I)
- +4 FOR I=1:1:5
- SET Z2(I)=$JUSTIFY($PIECE(PRCAGL1,U,I),0,2)
- SET PRCATL1=PRCATL1+Z2(I)
- C1 SET Z=40
- SET Z1=49
- SET Z0=4
- SET Z2=20
- WRITE !!,?Z2,"BALANCES",?40,"COLLECTED",!,?Z2,"--------",?40,"---------",!
- +1 WRITE ?Z0,"PRINCIPAL:",?Z2,Z2(1),?Z,Z(1),!
- +2 WRITE ?Z0,"INTEREST:",?Z2,Z2(2),?Z,Z(2),!
- +3 WRITE ?Z0,"ADMINISTRATIVE:",?Z2,Z2(3),?Z,Z(3),!
- +4 WRITE ?Z0,"MARSHALL FEE:",?Z2,Z2(4),?Z,Z(4),!
- +5 WRITE ?Z0,"COURT COST:",?Z2,Z2(5),?Z,Z(5)
- +6 WRITE !,?Z2,"---------",?Z,"----------",!,?Z0,"TOTAL:",?Z2,$JUSTIFY(PRCATL1,0,2),?Z,$JUSTIFY(PRCATL,0,2)
- +7 IF PRCAIO=PRCAIO(0)
- IF PRCATYPE'=12
- WRITE !,"PRESS <RETURN> TO CONTINUE: "
- READ X:DTIME
- WRITE !
- +8 KILL Z0,I,Z,Z1,Z2,PRCAGL1,PRCAGL,PRCATL,PRCATL1
- QUIT
- BAL if '$DATA(^PRCA(433,D0,8))
- QUIT
- SET PRCAGL=^(8)
- SET PRCATL=0
- FOR I=1:1:5
- SET Z(I)=$JUSTIFY($PIECE(PRCAGL,U,I),0,2)
- SET PRCATL=PRCATL+Z(I)
- +1 SET Z=3
- SET Z1=19
- WRITE !,"BALANCES",!,"--------",!
- +2 WRITE ?Z,"PRINCIPAL: ",?Z1,Z(1),!,?Z,"INTEREST: ",?Z1,Z(2),!,?Z,"ADMINISTRATIVE: ",?Z1,Z(3),!,?Z,"MARSHALL FEE: ",?Z1,Z(4),!,?Z,"COURT COST: ",?Z1,Z(5),!
- +3 WRITE ?Z1,"------------",!,?Z,"TOTAL",?Z1,$JUSTIFY(PRCATL,0,2),!
- +4 IF PRCAIO=PRCAIO(0)
- IF PRCATYPE'=12
- WRITE !,"PRESS <RETURN> TO CONTINUE: "
- READ X:DTIME
- WRITE !
- +5 KILL Z,PRCATL,PRCAGL,Z1
- QUIT
- EN2 ;print the appropriation,pat ref #. (multiple) and amount.
- +1 WRITE !,"FISCAL YEAR",?17,"PRINCIPAL AMOUNT",?42,"FY TRANS. AMOUNT"
- +2 WRITE !,"-----------",?17,"----------------",?42,"----------------"
- +3 SET PRCAFN=0
- FOR PRCAE1=0:0
- SET PRCAFN=$ORDER(^PRCA(433,D0,4,PRCAFN))
- if PRCAFN'>0
- QUIT
- DO WRPAT
- +4 IF $PIECE(^PRCA(433,D0,0),U,10)
- WRITE !,"NOTE:**** This transaction is flagged as invalid for patient statement.",!,?10,"It WILL NOT appear on the patient statement.****"
- END1 ;end of EN1
- KILL PRCAE1,PRCAFN
- QUIT
- WRPAT if '$DATA(^PRCA(433,D0,4,PRCAFN,0))
- QUIT
- SET PRCAFY=$PIECE(^(0),U,1)
- SET PRCAMT=$PIECE(^(0),U,2)
- SET PRCATRM=$JUSTIFY($PIECE(^(0),U,5),0,2)
- +1 WRITE !,$JUSTIFY(PRCAFY,11),?17,$JUSTIFY(PRCAMT,16,2),?42,$JUSTIFY(PRCATRM,16,2)
- +2 KILL PRCAPAT,PRCATRM,PRCAFY,PRCAMT
- QUIT
- EN3 SET Y=$PIECE(^PRCA(433,D0,0),U,5)
- DO D^PRCAQUE
- SET PRCADT=Y
- +1 WRITE "TRANS. AMOUNT: ",$SELECT($PIECE(^PRCA(433,D0,1),U,5)<0:"-$",1:"$"),$FNUMBER($TRANSLATE($PIECE(^PRCA(433,D0,1),U,5),"-"),",",2)
- SET Y=$PIECE(^(1),"^",9)
- IF Y]""
- XECUTE ^DD("DD")
- if $X>35
- WRITE !
- WRITE ?34,"DATE POSTED: ",$PIECE(Y,"@")," ",$PIECE(Y,"@",2)
- +2 WRITE !
- KILL PRCADT
- QUIT