PRCA399D ;MNTVBB/RGB - Restores any changes to AR files to allow re-testing ; 2/22/22
;;4.5;Accounts Receivable;**399**;Feb 05, 2022;Build 67
V ;;Per VA Directive 6402, this routine should not be modified.
EN(PRCADB,PRCABEG,PRCAEND,PRCATTY) ;*CALLER MUST KILL ^TMP("PRCAGT",$J)
K ^TMP("PRCAGT",$J) ;S (PRCABEG,PRCAEND,PRCATTY)="",PRCADB=PRCADBTR
S PRCAAC=+$O(^PRCA(430.3,"AC",102,0)),PRCAOP=+$O(^PRCA(430.3,"AC",112,0)),PRCARVW=+$O(^PRCA(430.3,"AC",113,0))
S:$G(PRCABEG)="" PRCABEG=0 I +$G(PRCAEND)=0 D NOW^%DTC S PRCAEND=%
S PRCABEG=0
S PRCATTY=$G(PRCATTY) I PRCATTY="" D F430
D F433
Q Q PRCATTY
F430 W:PRCAW !,"F430"
NEW PRCADAT,PRCABN
S PRCADAT=PRCABEG F S PRCADAT=$O(^PRCA(430,"ATD",PRCADB,PRCADAT)) Q:('PRCADAT)!(PRCADAT>PRCAEND) S PRCABN=0 F S PRCABN=$O(^PRCA(430,"ATD",PRCADB,PRCADAT,PRCABN)) Q:'PRCABN D
.Q:'$D(^XTMP("PRCA399",$J,1,1,PRCABN))!$D(^XTMP("PRCA399",$J,5,PRCADB,PRCABN,46))
.S PRCASTS=$P(^PRCA(430,PRCABN,0),U,8) I PRCASTS=PRCAAC!(PRCASTS=PRCAOP)!(PRCASTS=PRCARVW) D
..I $D(^XTMP("PRCA399",$J,1,1,PRCABN)),$P(^PRCA(430,PRCABN,0),U,3) S ^TMP("PRCAGT",$J,PRCADB,PRCADAT,PRCABN,99,1)=$P(^PRCA(430,PRCABN,0),"^",3)_"^1^"_PRCABN_U_"ORIG AMT"
Q
F433 ;
K ^PRCAGT("PRCAGT",$J)
N PRCAPREP,PRCAPRPY
W:PRCAW !,"F433"
S PRCACOMM=0,PRCAPREP=+$O(^PRCA(430.2,"AC",33,0)),PRCASKIP=0
F PRCADAT=PRCABEG:0 S PRCADAT=$O(^PRCA(433,"ATD",PRCADB,PRCADAT)) Q:('PRCADAT)!(PRCADAT>PRCAEND) F PRCATN=0:0 S PRCATN=$O(^PRCA(433,"ATD",PRCADB,PRCADAT,PRCATN)) Q:'PRCATN D
CK1 .S PRCATN0=$G(^PRCA(433,PRCATN,0)) Q:PRCATN0="" S PRCATN1=$G(^PRCA(433,PRCATN,1)),PRCADT=$P(PRCATN1,U,9)
.Q:'$P(PRCATN1,U,2)!'$P(PRCATN1,U,5)
.S PRCABILL=$P(PRCATN0,U,2),PRCAPRPY=0,PRCAPULL=0 Q:'PRCABILL
.I $P(^PRCA(430,PRCABILL,0),U,8)=31 Q
.I '$D(^XTMP("PRCA399",$J,1,1,PRCABILL)) Q
CK2 .I $D(^XTMP("PRCA399",$J,5,PRCADB,PRCABILL,46)) Q:$P(PRCATN1,U,9)<^XTMP("PRCA399",$J,5,PRCADB,PRCABILL,46)
.I $D(^XTMP("PRCA399",$J,2,1,PRCADB,1,PRCABILL,2,PRCATN)) S $P(PRCATN1,U,5)=$P(PRCATN1,U,5)-^XTMP("PRCA399",$J,2,1,PRCADB,1,PRCABILL,2,PRCATN)
.S PRCATYPE=$P(PRCATN1,U,2),PRCATAMT=$P(PRCATN1,U,5)
.I ":199:47:45:8:"[(":"_PRCATYPE_":") Q
.I PRCATYPE=14,PRCATAMT<0 S PRCATYPE=13,PRCATAMT=$TR(PRCATAMT,"-")
.I PRCATYPE=12,PRCATAMT<0 S PRCATAMT=$TR(PRCATAMT,"-")
.I PRCATYPE=2,$P(^XTMP("PRCA399",$J,2,1,0),U,3)=528,$P(PRCATN1,U,3)="P17011000" Q
CK3 .I '$D(^XTMP("PRCA399",$J,1,1,PRCABILL)),$P($G(^PRCA(430,PRCABILL,6)),U,21)<$P(^XTMP("PRCA399",$J,2,1,0),U),$P(PRCATN1,U,9)>$P(^XTMP("PRCA399",$J,2,1,0),U) D
..Q:",2,7,9,10,11,14,19,29,34,35,41,"'[(","_PRCATYPE_",")!($P(PRCATN0,U,10)=1)
..S $P(^XTMP("PRCA399",$J,2,8,PRCADBTR,0),U)=$P(^XTMP("PRCA399",$J,2,8,PRCADBTR,0),U)+$P(PRCATN1,U,5)
..S $P(^XTMP("PRCA399",$J,2,1,PRCADBTR,2,PRCABILL,0),":::")=$P(PRCATN1,U,5)
..S ^XTMP("PRCA399",$J,2,8,PRCADBTR,PRCABILL,2)=$P(PRCATN1,U,5),$P(^XTMP("PRCA399",$J,2,1,PRCADBTR,2,PRCABILL,0),":::",1)=$P(PRCATN1,U,5)
.I $P($G(^XTMP("PRCA399",$J,1,1,PRCABILL,0)),U,2)=PRCAPREP S PRCAPRPY=1 ;@@@@@@@@@@@@@@
.I $P(PRCATN0,U,10)=1,'$D(^XTMP("PRCA399",$J,1,1,PRCABILL)) S ^XTMP("PRCA399",$J,2,6,PRCABILL,PRCATN)=PRCATN0_U_PRCATYPE_U_PRCATAMT Q
.I PRCATYPE=14,PRCATAMT<0 S PRCATYPE=13,$P(PRCATN1,U,5)=$TR(PRCATAMT,"-")
.W:PRCAW !,PRCATN,?12,PRCATN0,?52,PRCATN1
.I $G(PRCATTY)'="",PRCATTY'=PRCATYPE Q
.I PRCATTY="",",3,4,5,6,7,24,25,30,90,91,92,"[(","_PRCATYPE_",") Q
.I (PRCATYPE="")!($P(PRCATN0,U,4)'=2) Q ;*******
.I $G(PRCAHIST)="THIST",PRCATYPE=45 Q
F433A .S ^TMP("PRCAGT",$J,PRCADB,PRCADAT,PRCABILL,99,PRCATN)=+PRCATAMT_U_PRCATYPE_U_PRCABILL_U_PRCAPRPY_U_PRCATN
.I PRCATAMT["-" S ^XTMP("PRCA399",$J,8,5,PRCADB,PRCABILL,PRCATN,0)=PRCATAMT_U_PRCATYPE_U_PRCABN_U_PRCAPRPY
S PRCADAT=0 F S PRCADAT=$O(^TMP("PRCAGT",$J,PRCADB,PRCADAT)) Q:'PRCADAT S PRCAEND=PRCADAT
K PRCADAT,PRCATN,PRCAPRCATN0,PRCATN1,PRCACOMM,PRCATYPE,PRCATTYP
Q
TBAL(PRCADB,PRCATBAL) ;get balance of transactions
N PRCAPRPY,PRCAPREP
NEW PRCABN,PRCACH,PRCADAT,PRCAPC,PRCARF,PRCARR,PRCATAMT,PRCATXN,PRCATTY,PRCACS,PRCACSFL
S (PRCATBAL,PRCAPC,PRCARF,PRCARR,PRCACH,PRCAZ,PRCAW,PRCATN,PRCACHH)=0
S PRCARR=+$O(^PRCA(430.2,"AC",33,0)),(PRCATOT,PRCAHTMT,PRCATTY)=0,PRCACSFL=$D(PRCACSTC),PRCAPNEG=0
I $D(^XTMP("PRCA399",$J,2,1,PRCADB,0)),($P(^XTMP("PRCA399",$J,2,1,PRCADB,0),U)+$P(^XTMP("PRCA399",$J,2,1,PRCADB,0),U,2)>0) D
.F PRCAI=1,2 S PRCAPC=PRCAPC-$P(^XTMP("PRCA399",$J,2,1,PRCADB,0),U,PRCAI)
.W:PRCAW !,"PRENEG HIT: ",^XTMP("PRCA399",$J,2,1,PRCADB,0) S PRCAPNEG=^XTMP("PRCA399",$J,2,1,PRCADB,0) R:PRCAW PRCAZ:10
I '$D(^TMP("PRCAGT",$J,PRCADB)) G TBALQ
F PRCADAT=0:0 S PRCADAT=$O(^TMP("PRCAGT",$J,PRCADB,PRCADAT)),PRCABN=0 Q:'PRCADAT F S PRCABN=$O(^TMP("PRCAGT",$J,PRCADB,PRCADAT,PRCABN)) Q:'PRCABN D
.S PRCACS=$D(^PRCA(430,"TCSP",PRCABN)) ; set flag for CS bills
.I $D(^TMP("PRCAGT",$J,PRCADB,PRCADAT,PRCABN,0)) S PRCACH=PRCACH+^(0) S:PRCACS PRCACTCH=$G(PRCACTCH)+^(0)
.S PRCATXN=0 F S PRCATXN=$O(^TMP("PRCAGT",$J,PRCADB,PRCADAT,PRCABN,99,PRCATXN)) Q:'PRCATXN D
..S PRCATAMT=^(PRCATXN),PRCATTY=$P(PRCATAMT,U,2),PRCAPRPY=$P(PRCATAMT,U,4) W:PRCAW !,PRCATXN,"/",$P(^PRCA(433,PRCATXN,0),U,2),?24,PRCATAMT
..I PRCATTY'=45 D
...I PRCATAMT["-" S PRCANFLG=1,^XTMP("PRCA399",$J,2,1,PRCADB,3,PRCABN,PRCATXN)=+PRCATAMT
...I PRCATTY=12!(PRCATTY=74) S:PRCATAMT<0 PRCAPC=PRCAPC+PRCATAMT D CHK S:PRCATAMT'<0 PRCACH=PRCACH+PRCATAMT S:PRCATAMT<0&PRCACS PRCACST=$G(PRCACST)+PRCATAMT S:PRCATAMT'<0 PRCACST=$G(PRCACST)+PRCATAMT D W
...; interest and admin charges may be negative
...; this was added in patch 165
...I PRCAPRPY,":1:41:35:"[(":"_PRCATTY_":") S:PRCATTY=1 PRCAPC=PRCAPC-PRCATAMT S:(PRCATTY=41!(PRCATTY=35)) PRCARF=PRCARF+PRCATAMT D CHK Q
...I ",2,7,9,10,11,14,19,29,34,35,47,"[(","_PRCATTY_",") S PRCAPC=PRCAPC-PRCATAMT S:PRCACS PRCACS=$G(PRCACS)-PRCATAMT D CHK D W Q
...I ",1,13,43,46,73,"[(","_PRCATTY_",") S PRCACH=PRCACH+PRCATAMT S:PRCACS PRCACS=$G(PRCACS)+PRCATAMT D W D CHK
;
TBALQ S PRCATBAL("RF")=PRCARF,PRCATBAL("CH")=PRCACH,PRCATBAL("PC")=PRCAPC,PRCATBAL=PRCARF+PRCACH+PRCAPC
I 'PRCACSFL K PRCACSCH,PRCACSPC
K PRCABN,PRCACH,PRCADAT,PRCAPC,PRCARF,PRCARR,PRCATAMT,PRCATXN,PRCACS,PRCACSFL,^TMP("PRCAGU",$J),^TMP("PRCAGT",$J)
K PRCAAC,PRCABILL,PRCACST,PRCACSTC,PRCACTCH,PRCAHIST,PRCAHTMT,PRCAOP,PRCAPNEG,PRCAQ,PRCASTS
K PRCATN0,PRCATOT,PRCAI,PRCANFLG,PRCAZ,PRCAPULL,PRCARVW
Q PRCATTY
CHK ;CHK TOTALS
;W !,PRCATAMT,?30,PRCARF_U_PRCACH_U_PRCAPC_U_(PRCARF+PRCACH+PRCAPC),?60,PRCAPBAL," / ",(PRCARF+PRCACH+PRCAPC)," / ",PRCABBAL
;S ^BZ2(1,PRCADB,PRCABN,PRCADAT,PRCATXN,1)=PRCARF_U_PRCACH_U_PRCAPC_U_(PRCARF+PRCACH+PRCAPC)
Q
W W:PRCAW ?40,PRCARF," ",PRCACH," ",PRCAPC," [ ",PRCAPNEG," ]" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCA399D 6676 printed Jul 11, 2026@01:35:29 Page 2
PRCA399D ;MNTVBB/RGB - Restores any changes to AR files to allow re-testing ; 2/22/22
+1 ;;4.5;Accounts Receivable;**399**;Feb 05, 2022;Build 67
V ;;Per VA Directive 6402, this routine should not be modified.
EN(PRCADB,PRCABEG,PRCAEND,PRCATTY) ;*CALLER MUST KILL ^TMP("PRCAGT",$J)
+1 ;S (PRCABEG,PRCAEND,PRCATTY)="",PRCADB=PRCADBTR
KILL ^TMP("PRCAGT",$JOB)
+2 SET PRCAAC=+$ORDER(^PRCA(430.3,"AC",102,0))
SET PRCAOP=+$ORDER(^PRCA(430.3,"AC",112,0))
SET PRCARVW=+$ORDER(^PRCA(430.3,"AC",113,0))
+3 if $GET(PRCABEG)=""
SET PRCABEG=0
IF +$GET(PRCAEND)=0
DO NOW^%DTC
SET PRCAEND=%
+4 SET PRCABEG=0
+5 SET PRCATTY=$GET(PRCATTY)
IF PRCATTY=""
DO F430
+6 DO F433
Q QUIT PRCATTY
F430 if PRCAW
WRITE !,"F430"
+1 NEW PRCADAT,PRCABN
+2 SET PRCADAT=PRCABEG
FOR
SET PRCADAT=$ORDER(^PRCA(430,"ATD",PRCADB,PRCADAT))
if ('PRCADAT)!(PRCADAT>PRCAEND)
QUIT
SET PRCABN=0
FOR
SET PRCABN=$ORDER(^PRCA(430,"ATD",PRCADB,PRCADAT,PRCABN))
if 'PRCABN
QUIT
Begin DoDot:1
+3 if '$DATA(^XTMP("PRCA399",$JOB,1,1,PRCABN))!$DATA(^XTMP("PRCA399",$JOB,5,PRCADB,PRCABN,46))
QUIT
+4 SET PRCASTS=$PIECE(^PRCA(430,PRCABN,0),U,8)
IF PRCASTS=PRCAAC!(PRCASTS=PRCAOP)!(PRCASTS=PRCARVW)
Begin DoDot:2
+5 IF $DATA(^XTMP("PRCA399",$JOB,1,1,PRCABN))
IF $PIECE(^PRCA(430,PRCABN,0),U,3)
SET ^TMP("PRCAGT",$JOB,PRCADB,PRCADAT,PRCABN,99,1)=$PIECE(^PRCA(430,PRCABN,0),"^",3)_"^1^"_PRCABN_U_"ORIG AMT"
End DoDot:2
End DoDot:1
+6 QUIT
F433 ;
+1 KILL ^PRCAGT("PRCAGT",$JOB)
+2 NEW PRCAPREP,PRCAPRPY
+3 if PRCAW
WRITE !,"F433"
+4 SET PRCACOMM=0
SET PRCAPREP=+$ORDER(^PRCA(430.2,"AC",33,0))
SET PRCASKIP=0
+5 FOR PRCADAT=PRCABEG:0
SET PRCADAT=$ORDER(^PRCA(433,"ATD",PRCADB,PRCADAT))
if ('PRCADAT)!(PRCADAT>PRCAEND)
QUIT
FOR PRCATN=0:0
SET PRCATN=$ORDER(^PRCA(433,"ATD",PRCADB,PRCADAT,PRCATN))
if 'PRCATN
QUIT
Begin DoDot:1
CK1 SET PRCATN0=$GET(^PRCA(433,PRCATN,0))
if PRCATN0=""
QUIT
SET PRCATN1=$GET(^PRCA(433,PRCATN,1))
SET PRCADT=$PIECE(PRCATN1,U,9)
+1 if '$PIECE(PRCATN1,U,2)!'$PIECE(PRCATN1,U,5)
QUIT
+2 SET PRCABILL=$PIECE(PRCATN0,U,2)
SET PRCAPRPY=0
SET PRCAPULL=0
if 'PRCABILL
QUIT
+3 IF $PIECE(^PRCA(430,PRCABILL,0),U,8)=31
QUIT
+4 IF '$DATA(^XTMP("PRCA399",$JOB,1,1,PRCABILL))
QUIT
CK2 IF $DATA(^XTMP("PRCA399",$JOB,5,PRCADB,PRCABILL,46))
if $PIECE(PRCATN1,U,9)<^XTMP("PRCA399",$JOB,5,PRCADB,PRCABILL,46)
QUIT
+1 IF $DATA(^XTMP("PRCA399",$JOB,2,1,PRCADB,1,PRCABILL,2,PRCATN))
SET $PIECE(PRCATN1,U,5)=$PIECE(PRCATN1,U,5)-^XTMP("PRCA399",$JOB,2,1,PRCADB,1,PRCABILL,2,PRCATN)
+2 SET PRCATYPE=$PIECE(PRCATN1,U,2)
SET PRCATAMT=$PIECE(PRCATN1,U,5)
+3 IF ":199:47:45:8:"[(":"_PRCATYPE_":")
QUIT
+4 IF PRCATYPE=14
IF PRCATAMT<0
SET PRCATYPE=13
SET PRCATAMT=$TRANSLATE(PRCATAMT,"-")
+5 IF PRCATYPE=12
IF PRCATAMT<0
SET PRCATAMT=$TRANSLATE(PRCATAMT,"-")
+6 IF PRCATYPE=2
IF $PIECE(^XTMP("PRCA399",$JOB,2,1,0),U,3)=528
IF $PIECE(PRCATN1,U,3)="P17011000"
QUIT
CK3 IF '$DATA(^XTMP("PRCA399",$JOB,1,1,PRCABILL))
IF $PIECE($GET(^PRCA(430,PRCABILL,6)),U,21)<$PIECE(^XTMP("PRCA399",$JOB,2,1,0),U)
IF $PIECE(PRCATN1,U,9)>$PIECE(^XTMP("PRCA399",$JOB,2,1,0),U)
Begin DoDot:2
+1 if ",2,7,9,10,11,14,19,29,34,35,41,"'[(","_PRCATYPE_",")!($PIECE(PRCATN0,U,10)=1)
QUIT
+2 SET $PIECE(^XTMP("PRCA399",$JOB,2,8,PRCADBTR,0),U)=$PIECE(^XTMP("PRCA399",$JOB,2,8,PRCADBTR,0),U)+$PIECE(PRCATN1,U,5)
+3 SET $PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,2,PRCABILL,0),":::")=$PIECE(PRCATN1,U,5)
+4 SET ^XTMP("PRCA399",$JOB,2,8,PRCADBTR,PRCABILL,2)=$PIECE(PRCATN1,U,5)
SET $PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,2,PRCABILL,0),":::",1)=$PIECE(PRCATN1,U,5)
End DoDot:2
+5 ;@@@@@@@@@@@@@@
IF $PIECE($GET(^XTMP("PRCA399",$JOB,1,1,PRCABILL,0)),U,2)=PRCAPREP
SET PRCAPRPY=1
+6 IF $PIECE(PRCATN0,U,10)=1
IF '$DATA(^XTMP("PRCA399",$JOB,1,1,PRCABILL))
SET ^XTMP("PRCA399",$JOB,2,6,PRCABILL,PRCATN)=PRCATN0_U_PRCATYPE_U_PRCATAMT
QUIT
+7 IF PRCATYPE=14
IF PRCATAMT<0
SET PRCATYPE=13
SET $PIECE(PRCATN1,U,5)=$TRANSLATE(PRCATAMT,"-")
+8 if PRCAW
WRITE !,PRCATN,?12,PRCATN0,?52,PRCATN1
+9 IF $GET(PRCATTY)'=""
IF PRCATTY'=PRCATYPE
QUIT
+10 IF PRCATTY=""
IF ",3,4,5,6,7,24,25,30,90,91,92,"[(","_PRCATYPE_",")
QUIT
+11 ;*******
IF (PRCATYPE="")!($PIECE(PRCATN0,U,4)'=2)
QUIT
+12 IF $GET(PRCAHIST)="THIST"
IF PRCATYPE=45
QUIT
F433A SET ^TMP("PRCAGT",$JOB,PRCADB,PRCADAT,PRCABILL,99,PRCATN)=+PRCATAMT_U_PRCATYPE_U_PRCABILL_U_PRCAPRPY_U_PRCATN
+1 IF PRCATAMT["-"
SET ^XTMP("PRCA399",$JOB,8,5,PRCADB,PRCABILL,PRCATN,0)=PRCATAMT_U_PRCATYPE_U_PRCABN_U_PRCAPRPY
End DoDot:1
+2 SET PRCADAT=0
FOR
SET PRCADAT=$ORDER(^TMP("PRCAGT",$JOB,PRCADB,PRCADAT))
if 'PRCADAT
QUIT
SET PRCAEND=PRCADAT
+3 KILL PRCADAT,PRCATN,PRCAPRCATN0,PRCATN1,PRCACOMM,PRCATYPE,PRCATTYP
+4 QUIT
TBAL(PRCADB,PRCATBAL) ;get balance of transactions
+1 NEW PRCAPRPY,PRCAPREP
+2 NEW PRCABN,PRCACH,PRCADAT,PRCAPC,PRCARF,PRCARR,PRCATAMT,PRCATXN,PRCATTY,PRCACS,PRCACSFL
+3 SET (PRCATBAL,PRCAPC,PRCARF,PRCARR,PRCACH,PRCAZ,PRCAW,PRCATN,PRCACHH)=0
+4 SET PRCARR=+$ORDER(^PRCA(430.2,"AC",33,0))
SET (PRCATOT,PRCAHTMT,PRCATTY)=0
SET PRCACSFL=$DATA(PRCACSTC)
SET PRCAPNEG=0
+5 IF $DATA(^XTMP("PRCA399",$JOB,2,1,PRCADB,0))
IF ($PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADB,0),U)+$PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADB,0),U,2)>0)
Begin DoDot:1
+6 FOR PRCAI=1,2
SET PRCAPC=PRCAPC-$PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADB,0),U,PRCAI)
+7 if PRCAW
WRITE !,"PRENEG HIT: ",^XTMP("PRCA399",$JOB,2,1,PRCADB,0)
SET PRCAPNEG=^XTMP("PRCA399",$JOB,2,1,PRCADB,0)
if PRCAW
READ PRCAZ:10
End DoDot:1
+8 IF '$DATA(^TMP("PRCAGT",$JOB,PRCADB))
GOTO TBALQ
+9 FOR PRCADAT=0:0
SET PRCADAT=$ORDER(^TMP("PRCAGT",$JOB,PRCADB,PRCADAT))
SET PRCABN=0
if 'PRCADAT
QUIT
FOR
SET PRCABN=$ORDER(^TMP("PRCAGT",$JOB,PRCADB,PRCADAT,PRCABN))
if 'PRCABN
QUIT
Begin DoDot:1
+10 ; set flag for CS bills
SET PRCACS=$DATA(^PRCA(430,"TCSP",PRCABN))
+11 IF $DATA(^TMP("PRCAGT",$JOB,PRCADB,PRCADAT,PRCABN,0))
SET PRCACH=PRCACH+^(0)
if PRCACS
SET PRCACTCH=$GET(PRCACTCH)+^(0)
+12 SET PRCATXN=0
FOR
SET PRCATXN=$ORDER(^TMP("PRCAGT",$JOB,PRCADB,PRCADAT,PRCABN,99,PRCATXN))
if 'PRCATXN
QUIT
Begin DoDot:2
+13 SET PRCATAMT=^(PRCATXN)
SET PRCATTY=$PIECE(PRCATAMT,U,2)
SET PRCAPRPY=$PIECE(PRCATAMT,U,4)
if PRCAW
WRITE !,PRCATXN,"/",$PIECE(^PRCA(433,PRCATXN,0),U,2),?24,PRCATAMT
+14 IF PRCATTY'=45
Begin DoDot:3
+15 IF PRCATAMT["-"
SET PRCANFLG=1
SET ^XTMP("PRCA399",$JOB,2,1,PRCADB,3,PRCABN,PRCATXN)=+PRCATAMT
+16 IF PRCATTY=12!(PRCATTY=74)
if PRCATAMT<0
SET PRCAPC=PRCAPC+PRCATAMT
DO CHK
if PRCATAMT'<0
SET PRCACH=PRCACH+PRCATAMT
if PRCATAMT<0&PRCACS
SET PRCACST=$GET(PRCACST)+PRCATAMT
if PRCATAMT'<0
SET PRCACST=$GET(PRCACST)+PRCATAMT
DO W
+17 ; interest and admin charges may be negative
+18 ; this was added in patch 165
+19 IF PRCAPRPY
IF ":1:41:35:"[(":"_PRCATTY_":")
if PRCATTY=1
SET PRCAPC=PRCAPC-PRCATAMT
if (PRCATTY=41!(PRCATTY=35))
SET PRCARF=PRCARF+PRCATAMT
DO CHK
QUIT
+20 IF ",2,7,9,10,11,14,19,29,34,35,47,"[(","_PRCATTY_",")
SET PRCAPC=PRCAPC-PRCATAMT
if PRCACS
SET PRCACS=$GET(PRCACS)-PRCATAMT
DO CHK
DO W
QUIT
+21 IF ",1,13,43,46,73,"[(","_PRCATTY_",")
SET PRCACH=PRCACH+PRCATAMT
if PRCACS
SET PRCACS=$GET(PRCACS)+PRCATAMT
DO W
DO CHK
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;
TBALQ SET PRCATBAL("RF")=PRCARF
SET PRCATBAL("CH")=PRCACH
SET PRCATBAL("PC")=PRCAPC
SET PRCATBAL=PRCARF+PRCACH+PRCAPC
+1 IF 'PRCACSFL
KILL PRCACSCH,PRCACSPC
+2 KILL PRCABN,PRCACH,PRCADAT,PRCAPC,PRCARF,PRCARR,PRCATAMT,PRCATXN,PRCACS,PRCACSFL,^TMP("PRCAGU",$JOB),^TMP("PRCAGT",$JOB)
+3 KILL PRCAAC,PRCABILL,PRCACST,PRCACSTC,PRCACTCH,PRCAHIST,PRCAHTMT,PRCAOP,PRCAPNEG,PRCAQ,PRCASTS
+4 KILL PRCATN0,PRCATOT,PRCAI,PRCANFLG,PRCAZ,PRCAPULL,PRCARVW
+5 QUIT PRCATTY
CHK ;CHK TOTALS
+1 ;W !,PRCATAMT,?30,PRCARF_U_PRCACH_U_PRCAPC_U_(PRCARF+PRCACH+PRCAPC),?60,PRCAPBAL," / ",(PRCARF+PRCACH+PRCAPC)," / ",PRCABBAL
+2 ;S ^BZ2(1,PRCADB,PRCABN,PRCADAT,PRCATXN,1)=PRCARF_U_PRCACH_U_PRCAPC_U_(PRCARF+PRCACH+PRCAPC)
+3 QUIT
W if PRCAW
WRITE ?40,PRCARF," ",PRCACH," ",PRCAPC," [ ",PRCAPNEG," ]"
QUIT
