PRCA399A ;MNTVBB/RCB - RESET BILL NODE DEPENDING ON: TRANACTIONS & 382/385 ISSUES ; 2/23/22
;;4.5;Accounts Receivable;**399**;Feb 23, 2022;Build 67
;;Per VA Directive 6402, this routine should not be modified.
; PAYMENTS AFTER PANDEMIC TX POST DATES 382/385
Q
EN ;DEBTORS
D NOW^%DTC S ^XTMP("PRCA399",$J,999,"E1BEGCALCBILLDEBTOR")=%
S PRCAPREP=+$O(^PRCA(430.2,"AC",33,0))
S PRCABGTX=^XTMP("PRCA399",$J,1,0,0) ;TXPAN
S (PRCABDT,PRCADBTR,PRCAPPYT)=0
DEBTOR S PRCADBTR=$O(^XTMP("PRCA399",$J,2,1,PRCADBTR)) G QQ:'PRCADBTR
I '$D(^XTMP("PRCA399",$J,2,8,PRCADBTR,1)) S ^XTMP("PRCA399",$J,2,8,PRCADBTR,0)="0^0^0^0^0"
K ^XTMP("PRCA399",$J,9,8)
S ^XTMP("PRCA399",$J,999,"E2BEGCALCBILLDEBTOR")=PRCADBTR,PRCADD=PRCADBTR
A1 S U="^",(PRCAX,PRCAXX,PRCAY,PRCAYY,PRCAXYZ,PRCABILL,PRCAT)=0,PRCAW=^XTMP("PRCA399",$J,1,0) S:PRCAPRT=1 PRCAW=1
BILL S PRCABILL=$O(^XTMP("PRCA399",$J,2,1,PRCADBTR,2,PRCABILL)) G Q1:'PRCABILL
;I PRCADSCP="RECALC",";16;42;44;"'[(";"_$P($G(^PRCA(430,PRCABILL,0)),U,8)_";") G BILL ;SPECIAL DISC CHK
I '$D(^XTMP("PRCA399",$J,1,1,PRCABILL)) G BILL
L +^PRCA(430,PRCABILL):3 S ^XTMP("PRCA399",$J,9,8,PRCADBTR,PRCABILL)="",PRCABB=PRCABILL
S PRCAR0=^XTMP("PRCA399",$J,1,1,PRCABILL,0),(PRCATXCT,PRCAPPAY,PRCAPRPY,PRCANEG,PRCATPRE,PRCATNEG,PRCASKIP,PRCAORIG)=0
S PRCAR7=$G(^PRCA(430,PRCABILL,7)),PRCAORIG=+$P(^PRCA(430,PRCABILL,0),U,3)
I $P(PRCAR0,U,2)=PRCAPREP S PRCAPAMT=0 D PPAY S PRCAPPAY=1,$P(^XTMP("PRCA399",$J,2,1,PRCADBTR,0),U,3)=$P(^XTMP("PRCA399",$J,2,1,PRCADBTR,0),U,3)+PRCAPAMT ;+$P($G(^PRCA(430,PRCABILL,7)),U)
S ^XTMP("PRCA399",$J,999,"E3BEGCALCBILL")=PRCABILL,PRCARN="0^0^0^0^0^^0^0^0^0^0",PRCASET=0,PRCATOT=0
S ^XTMP("PRCA399",$J,1,1,PRCABILL,8)=PRCAR7 F I=1:1:5,7:1:11 S $P(^XTMP("PRCA399",$J,1,1,PRCABILL,8),U,I)=0
W:PRCAW !!!,$P(PRCAR0,U),?15,"STATUS= ",$P(^PRCA(430.3,$P(PRCAR0,U,8),0),U,1),?35,PRCABILL,?50,PRCADBTR
W:PRCAW !,?5,"BILL CURRENT TOTAL NODE 7 >> ",PRCAR7
F I=1:1:5 S PRCAP(I)=0,PRCAS(I)=0
S PRCATX=0 W:PRCAW !,?10,"PANDEMIC INTEREST/ADMIN REVERSALS: "
F S PRCATX=$O(^XTMP("PRCA399",$J,1,1,PRCABILL,99,PRCATX)) Q:'PRCATX D
.W:PRCAW !,?5,PRCATX,"= ",^XTMP("PRCA399",$J,1,1,PRCABILL,99,PRCATX,1)
;Rework node 7 from transactions for PRCABILL
D TX46 S PRCATX=0,YY=0
TX433 F S PRCATX=$O(^PRCA(433,"C",PRCABILL,PRCATX)) D:'PRCATX RN1 Q:'PRCATX S PRCATXCT=PRCATXCT+1 D D:PRCATX RN
.S ^XTMP("PRCA399",$J,999,"E4BEGCALCTX")=PRCATX,PRCATXN=0,PRCARSTR=0,PRCATXNG=0,PRCATT=PRCATX
CHECK .S PRCATXR=$G(^PRCA(433,PRCATX,1)),PRCATN0=$G(^PRCA(433,PRCATX,0)) Q:PRCATXR=""!($P(PRCATN0,U,4)'=2)
.I 'PRCAPPAY,$P(PRCATN0,U,10)=1,$P(PRCATN0,U,4)'=2 W:PRCAW "STS=Incomplete" S ^XTMP("PRCA399",$J,2,7,PRCABILL,PRCATX)=PRCATN0_":::"_PRCATXR,PRCATXCT=PRCATXCT-1 Q
.S PRCATXDL=+$P(PRCATXR,U,5),PRCACD=$P(PRCATXR,U,2) I 'PRCACD Q
.S PRCACMTH=$P(^TMP("PRCACD",$J,PRCACD),U,9),PRCACPC=$E(PRCACMTH,2),PRCAT238="0^0^0^",PRCAFLIP=0
.I PRCATXCT=1,PRCACD'=1,PRCAORIG>0 D
..S PRCAP(1)=PRCAP(1)+PRCAORIG W:PRCAW !,?9,"POSTED ORIGINAL AMOUNT: ",PRCAORIG
..;I PRCAORIG,$P(^PRCA(430,PRCABILL,6),U,21)>$P(^XTMP("PRCA399",$J,2,1,0),U) S PRCASET=1
..;S $P(^XTMP("PRCA399",$J,2,8,PRCADBTR,0),U)=$P(^XTMP("PRCA399",$J,2,8,PRCADBTR,0),U)+PRCAORIG
..S $P(^XTMP("PRCA399",$J,2,1,PRCADBTR,2,PRCABILL,0),":::")=^XTMP("PRCA399",$J,2,8,PRCADBTR,0)
..S PRCAORIG=0
.I PRCATXDL=0 Q
.I $D(^XTMP("PRCA399",$J,5,PRCADBTR,PRCABILL,46)) Q:$P(PRCATXR,U,9)<^XTMP("PRCA399",$J,5,PRCADBTR,PRCABILL,46)
.S ^XTMP("PRCA399",$J,1,1,PRCABILL,9,PRCATX,1)=PRCATXR,PRCATXH=PRCATX,PRCAFLIP=0
.I PRCACD=2,$P($G(^PRCA(433,PRCATX,5)),U,2)["P17011000",$P(PRCATXR,U)<3170131 Q
.I PRCATXDL<0,";12;13;14;74;"[(";"_PRCACD_";") D
..S ^XTMP("PRCA399",$J,8,2,PRCABILL,PRCATX,1)=PRCATXR,$P(PRCATXR,U,5)=$TR($P(PRCATXR,U,5),"-"),$P(PRCATXR,U,2)=13
..S ^XTMP("PRCA399",$J,8,2,PRCABILL,PRCATX,2)=PRCATXR,PRCACD=13,PRCATXDL=$P(PRCATXR,U,5)
.W:PRCAW !,PRCATX,?16,PRCATXR I PRCAW,$G(^PRCA(433,PRCATX,5))["PANDEMIC" W " ***PANDEMIC REVERSAL***"
T2 .S PRCATX2="" I ";12;13;14;74;"[(";"_PRCACD_";") S PRCATXN=2 D
..S:'$D(^PRCA(433,PRCATX,2)) PRCATX2="0^"_PRCATXDL_"^0",PRCATXNG=1
..I $D(^PRCA(433,PRCATX,2)) S PRCATX2="0^0^0" F I=2,3 S $P(PRCATX2,U,I)=+$P($G(^PRCA(433,PRCATX,2)),U,I+5)+0
..S ^XTMP("PRCA399",$J,1,1,PRCABILL,9,PRCATX,1,2)=PRCATX2 W:PRCAW !,?9,"NODE 2: "
T3 .S PRCATX3="" I ";2;34;35;"[(";"_PRCACD_";") S PRCATXN=3,PRCATX3="0^0^0" D
..I $D(^PRCA(433,PRCATX,3)) F I=1:1:3 S $P(PRCATX3,U,I)=+$P(^PRCA(433,PRCATX,3),U,I)
..I '$D(^PRCA(433,PRCATX,3)) S PRCATX3=PRCATXDL_"^0^0",PRCATXNG=1
..S ^XTMP("PRCA399",$J,1,1,PRCABILL,9,PRCATX,1,3)=PRCATX3 W:PRCAW !,?9,"NODE 3: ",PRCATX3
T8 .S PRCATX8="" I ";8;9;10;11;32;71;43;45;46;"[(";"_PRCACD_";") S PRCATXN=8 D
..I '$D(^PRCA(433,PRCATX,8)) S PRCATX8=PRCATXDL_"^0^0^",PRCATXNG=1
..I $D(^PRCA(433,PRCATX,8)) F I=1:1:3 S $P(PRCATX8,U,I)=$P(^PRCA(433,PRCATX,8),U,I)+0
..S ^XTMP("PRCA399",$J,1,1,PRCABILL,9,PRCATX,1,8)=PRCATX8 W:PRCAW !,?9,"NODE 3: ",PRCATX8
.I PRCATXN,@("PRCATX"_PRCATXN)["-" S PRCATXNG=1,@("PRCATX"_PRCATXN)=$TR(@("PRCATX"_PRCATXN),"-")
.I PRCATXN>0 D
..S ^XTMP("PRCA399",$J,4,1,PRCADBTR,PRCABILL,PRCATX,PRCATXN,1)=@("PRCATX"_PRCATXN)_U_PRCATXN_U_PRCACD_U_PRCATXDL
..S PRCATTL=0 F I=1:1:3 S PRCATTL=PRCATTL+$P(@("PRCATX"_PRCATXN),U,I)
..I PRCATTL'=PRCATXDL S PRCATXNG=1 D
...S ^XTMP("PRCA399",$J,1,1,PRCABILL,9,PRCATX,1,PRCATXN)=@("PRCATX"_PRCATXN)_"^"_PRCATXDL
..S PRCAT238="0^0^0^"_PRCATXN_U_PRCACD_U_PRCATXDL
.I PRCACD=23 M ^XTMP("PRCA399",$J,4,23,PRCATX)=^PRCA(433,PRCATX)
.I PRCACMTH="ZZ" Q
.I PRCATXDL=0 D Q
..S ^XTMP("PRCA399",$J,5,6,PRCATX,1)=PRCATXR
..I PRCATXN'=0 S ^XTMP("PRCA399",$J,5,6,PRCATX,PRCATXN,1)=@("PRCATX"_PRCATXN)
..S ^XTMP("PRCA399",$J,5,6,PRCATX,3)=PRCATXDL I PRCATXDL W:PRCATXDL&PRCAW&'PRCAXYZ " **>>"
TX .S (PRCAPRPY,PRCANEG,PRCATOT)=0 F I=1:1:3 S PRCATOT=PRCATOT+$P(PRCARN,U,I)
.I 'PRCASET,$P(PRCATXR,U,9)>$P(^XTMP("PRCA399",$J,2,1,0),U) D S PRCASET=1
..F I=1:1:5 S $P(^XTMP("PRCA399",$J,2,8,PRCADBTR,0),U,I)=$P(^XTMP("PRCA399",$J,2,8,PRCADBTR,0),U,I)+$S('PRCAPPAY:$P(PRCARN,U,I),1:-$P(PRCARN,U,I))
..S $P(^XTMP("PRCA399",$J,2,1,PRCADBTR,2,PRCABILL,0),":::")=$S('PRCAPPAY:PRCARN,1:-PRCARN)
FLIP .I (PRCATX'<PRCABGTX)!PRCATXNG D
..I $D(^XTMP("PRCA399",$J,2,1,PRCADBTR,2,PRCABILL)) S PRCAHCD=PRCACD,PRCAFLIP=1 D EN^PRCA399B S PRCACD=999 Q
1 .I PRCACD=1,PRCAPPAY D
..I '$D(^XTMP("PRCA399",$J,1,1,PRCABILL,11)) S ^XTMP("PRCA399",$J,1,1,PRCABILL,11)=0
..S ^XTMP("PRCA399",$J,1,1,PRCABILL,11)=^XTMP("PRCA399",$J,1,1,PRCABILL,11)+PRCATXDL,PRCAP(1)=PRCAP(1)+PRCATXDL
11 .I PRCACD=1,'PRCAPPAY S PRCAP(1)=PRCAP(1)+PRCATXDL
23 .I PRCACD=23 D
..F I=1:1:3 S PRCAP(I)=0 S:I=1 PRCAS(I+5)=PRCAS(I+5)+PRCATXDL
79 .I ";79;80;"[(";"_PRCACD_";") S PRCAP(1)=PRCAP(1)+PRCATXDL
43 .I PRCACD=43 S PRCAP(1)=PRCAP(1)+PRCATXDL S $P(PRCAT238,U)=$P(PRCAT238,U)+PRCATXDL
73 .I PRCACD=73 S PRCAP(1)=PRCAP(1)+PRCATXDL
46 .I PRCACD=46 F I=1:1:3 S PRCAP(I)=PRCAP(I)+$P(PRCATX8,U,I),$P(PRCAT238,U,I)=$P(PRCATX8,U,I)
47 .I PRCACD=47 F I=1:1:3 S PRCAP(I)=PRCAP(I)-$P(PRCATX8,U,I),$P(PRCAT238,U,I)=$P(PRCATX8,U,I)
10 .I ";8;9;10;11;"[(";"_PRCACD_";") D
..F I=2,3,1 S PRCAAMT=$S(PRCATXDL'>PRCAP(I):PRCATXDL,1:PRCAP(I)) S PRCAP(I)=PRCAP(I)-PRCAAMT,PRCAS(I)=PRCAS(I)+PRCAAMT,PRCATXDL=PRCATXDL-PRCAAMT,$P(PRCAT238,U,I)=$P(PRCAT238,U,I)+PRCAAMT Q:'PRCATXDL
..S:PRCATXDL ^XTMP("PRCA399",$J,1,1,PRCABILL,9,PRCATX,2)=PRCACD_U_PRCATXDL,PRCANEG=PRCATXDL_U_PRCACD
..I PRCATXDL'=0 S ^XTMP("PRCA399",$J,1,1,PRCABILL,9,PRCATX,2)=PRCACD_U_PRCATXDL,PRCANEG=PRCATXDL_U_PRCACD
12 .I ";12;13;74;"[(";"_PRCACD_";") D
..S PRCADOLI=$P(PRCATX2,U,2),PRCADOLA=$P(PRCATX2,U,3)
..S PRCAP(2)=PRCAP(2)+PRCADOLI,PRCAP(3)=PRCAP(3)+PRCADOLA,$P(PRCAT238,U,2)=PRCADOLI,$P(PRCAT238,U,3)=PRCADOLA
14 .I PRCACD=14 D
..F I=2,3 S PRCAAMT=$S($P(PRCATX2,U,I)>PRCAP(I):PRCAP(I),1:$P(PRCATX2,U,I)),PRCAP(I)=PRCAP(I)-PRCAAMT,PRCAS(I)=PRCAS(I)+PRCAAMT,$P(PRCAT238,U,I)=PRCAAMT,PRCATXDL=PRCATXDL-PRCAAMT
..S:PRCATXDL ^XTMP("PRCA399",$J,1,1,PRCABILL,9,PRCATX,2)=PRCACD_U_PRCATXDL,PRCANEG=PRCATXDL_U_PRCACD
26 .I ";26;41;"[(";"_PRCACD_";") D
..F I=2,3,1 S PRCAAMT=$S(PRCATXDL'>PRCAP(I):PRCATXDL,1:PRCAP(I)) S PRCAP(I)=PRCAP(I)-PRCAAMT,PRCAS(I)=PRCAS(I)+PRCAAMT,PRCATXDL=PRCATXDL-PRCAAMT Q:'PRCATXDL
..S:PRCATXDL ^XTMP("PRCA399",$J,1,1,PRCABILL,9,PRCATX,3)=PRCACD_U_PRCATXDL,PRCANEG=PRCATXDL_U_PRCACD
39 .I ";39;70;"[(";"_PRCACD_";") D
..S PRCAAMT=$S(PRCAP(1)'>PRCATXDL:PRCAP(1),1:PRCATXDL) S PRCAP(1)=PRCAP(1)-PRCAAMT,PRCAS(1)=PRCAS(1)+PRCAAMT,PRCATXDL=PRCATXDL-PRCAAMT,$P(PRCAT238,U)=PRCAAMT Q:'PRCATXDL
..S:PRCATXDL ^XTMP("PRCA399",$J,1,1,PRCABILL,9,PRCATX,3)=PRCACD_U_PRCATXDL,PRCANEG=PRCATXDL_U_PRCACD
2 .I ";2;34;35;"[(";"_PRCACD_";") D
..S PRCAPDOL=0 F I=1:1:3 S PRCAPDOL=PRCAPDOL+$P(PRCATX3,U,I)
..I PRCAPDOL'=PRCATXDL S PRCATXDL=PRCAPDOL,^XTMP("PRCA399",$J,1,1,PRCABILL,9,PRCATX,3)=PRCACD_U_PRCATXDL_PRCAPDOL
..S PRCAAMT=$S($P(PRCATX3,U,2)>PRCAP(2):PRCAP(2),1:$P(PRCATX3,U,2)),PRCAP(2)=PRCAP(2)-PRCAAMT,$P(PRCAT238,U,2)=PRCAAMT
..S PRCAS(2)=PRCAS(2)+PRCAAMT,PRCATXDL=PRCATXDL-PRCAAMT S $P(PRCATX3,U,2)=$P(PRCATX3,U,2)-PRCAAMT
..S PRCAAMT=$S($P(PRCATX3,U,3)>PRCAP(3):PRCAP(3),1:$P(PRCATX3,U,3)) D:$P(PRCATX3,U,3)
...S PRCAP(3)=PRCAP(3)-PRCAAMT,PRCAS(3)=PRCAS(3)+PRCAAMT,$P(PRCAT238,U,3)=PRCAAMT,PRCATXDL=PRCATXDL-PRCAAMT
...S $P(PRCATX3,U,3)=$P(PRCATX3,U,3)-PRCAAMT
..S PRCAAMT=$S(PRCATXDL>PRCAP(1):PRCAP(1),1:PRCATXDL) S PRCAP(1)=PRCAP(1)-PRCAAMT,PRCAS(1)=PRCAS(1)+PRCAAMT,$P(PRCAT238,U)=PRCAAMT,PRCATXDL=PRCATXDL-PRCAAMT
..S PRCAPRPY=PRCATXDL_U_PRCACD S ^XTMP("PRCA399",$J,1,1,PRCABILL,9,PRCATX,5)=PRCAPRPY
.S:PRCACD=999 PRCACD=PRCAHCD
.I PRCAPRPY>0 D
..S ^XTMP("PRCA399",$J,1,1,PRCABILL,9,PRCATX,3,"9C")=PRCAPRPY
..S ^XTMP("PRCA399",$J,2,1,PRCADBTR,1,PRCABILL,1,PRCATX)=PRCAPRPY,PRCATPRE=PRCATPRE+PRCAPRPY
..W:PRCAW !,"PREPAYA DETERMINED: ",+PRCAPRPY," FOR PRCABILL: ",$P(PRCAR0,U) R:'PRCAY&PRCAW PRCAY:10
.I PRCANEG D
..S ^XTMP("PRCA399",$J,1,1,PRCABILL,9,PRCATX,3,"9B")=PRCANEG,^XTMP("PRCA399",$J,2,1,PRCADBTR,1,PRCABILL,2,PRCATX)=PRCANEG
..S PRCATNEG=PRCATNEG+PRCANEG
..W:PRCAW " ",PRCATX," $$ (",PRCANEG,") DID NOT CLEAR WITH POST!" R:'PRCAY&PRCAW PRCAY:10
.I PRCANEG!PRCAPRPY S PRCANGPY=PRCANEG+PRCAPRPY S ^XTMP("PRCA399",$J,2,1,PRCADBTR,4,PRCABILL,PRCATXH)=PRCANGPY_"::"_PRCATXR
.I PRCATXN D
..S ^XTMP("PRCA399",$J,4,1,PRCADBTR,PRCABILL,PRCATX,PRCATXN,2)=PRCAT238_U_PRCAPRPY_U_PRCANEG
.Q
G BILL
TX46 S PRCATX=0 K ^XTMP("PRCA399",$J,5,PRCADBTR,PRCABILL,46)
F S PRCATX=$O(^PRCA(433,"C",PRCABILL,PRCATX)) Q:'PRCATX D
.I $P(^PRCA(433,PRCATX,1),U,2)=46 D
..S ^XTMP("PRCA399",$J,5,PRCADBTR,PRCABILL,46)=$P(^PRCA(433,PRCATX,1),U,9)
Q
Q1 D NOW^%DTC S ^XTMP("PRCA399",$J,999,"E2ENDCALCBILL/DEBTOR")=%
K I,P,S,PRCAAMT,PRCABDT,PRCABILL,PRCACD,PRCACMTH,PRCACPC,PRCAPPYT,PRCATXN,PRCAHCD
K PRCADOLA,PRCADOLI,PRCAFLIP,PRCANEG,PRCANGPY,PRCAORIG,PRCAP,PRCAPDOL,PRCAPRPY,PRCATNEG
K PRCAR0,PRCAR1,PRCAR2,PRCAR7,PRCARN,PRCARR,PRCAS,PRCAT,PRCAT1,PRCAT2,PRCAT3,PRCATN0,PRCATNEG,PRCATOT7,PRCATPRE,PRCATX
K PRCATX2,PRCATX3,PRCATX8,PRCATXCT,PRCATXDL,PRCATXH,PRCATXR,PRCAW,PRCAX,PRCAXX
K PRCAXYZ,PRCAY,PRCAYY,PRCASKIP,PRCAPPAY,PRCASET,PRCATOT,PRCATNEG
K PRCATPRE,PRCATX,XX,PRCATXN,PRCAPAMT
D EN^PRCA399C(PRCADBTR),10^PRCA399E
S PRCABILL=0 F S PRCABILL=$O(^XTMP("PRCA399",$J,9,8,PRCADBTR,PRCABILL)) Q:'PRCABILL L -^PRCA(430,PRCABILL)
G DEBTOR
PPAY ;GRAB ORIGINAL PREPAY AMOUNT
N PRCAPPT,PRCATXPP
S PRCAPPT=$O(^PRCA(433,"C",PRCABILL,0)) I 'PRCAPPT S PRCAPAMT=0 Q
S PRCATXPP=$G(^PRCA(433,PRCAPPT,1)),PRCAPAMT=+$P(PRCATXPP,U,5)
Q
;
RN ;W !,"TX ADD: ",PRCADBTR,U,PRCABILL,U,PRCATX," ",PRCATXR," ",PRCAP(1),"/",PRCAS(1) ;###1
S PRCARN="" F I=1:1:5 S $P(PRCARN,U,I)=PRCAP(I)
F I=7:1:11 S $P(PRCARN,U,I)=PRCAS(I-6)
W:PRCAW !,?10,"REBUILT NODE 7 >> ",PRCARN R:'PRCAXX&PRCAW PRCAX:10
I 'PRCATX,(PRCATNEG!PRCATPRE) D
.S ^XTMP("PRCA399",$J,1,1,PRCABILL,6)=PRCATPRE_U_PRCATNEG
.S:'$D(^XTMP("PRCA399",$J,2,1,PRCADBTR,0)) ^XTMP("PRCA399",$J,2,1,PRCADBTR,0)="0^0" S:'$D(^XTMP("PRCA399",$J,1,1,PRCADBTR,0,PRCABILL)) ^XTMP("PRCA399",$J,2,1,PRCADBTR,0,PRCABILL)="0^0"
.S $P(^XTMP("PRCA399",$J,2,1,PRCADBTR,0),U)=$P(^XTMP("PRCA399",$J,2,1,PRCADBTR,0),U)+PRCATPRE,$P(^XTMP("PRCA399",$J,2,1,PRCADBTR,0,PRCABILL),U)=$P(^XTMP("PRCA399",$J,2,1,PRCADBTR,0,PRCABILL),U)+PRCATPRE
.S $P(^XTMP("PRCA399",$J,2,1,PRCADBTR,0),U,2)=$P(^XTMP("PRCA399",$J,2,1,PRCADBTR,0),U,2)+PRCATNEG,$P(^XTMP("PRCA399",$J,2,1,PRCADBTR,0,PRCABILL),U,2)=$P(^XTMP("PRCA399",$J,2,1,PRCADBTR,0,PRCABILL),U,2)+PRCATNEG
I 'PRCATX D
.S ^XTMP("PRCA399",$J,2,2,PRCADBTR,1,PRCABILL,1)=PRCAR7,^XTMP("PRCA399",$J,2,2,PRCADBTR,1,PRCABILL,2)=PRCARN I $P(PRCARN,U,1,5)'=$P(PRCAR7,U,1,5) S ^XTMP("PRCA399",$J,2,3,PRCADBTR,PRCABILL)=$P(PRCAR7,U,1,5)_":::"_$P(PRCARN,U,1,5)
.I PRCARN["-" S ^XTMP("PRCA399",$J,1,1,PRCABILL,12)=PRCARN W:PRCAW !,"NEW BAL NODE NEGATIVE: ",PRCABILL
I (PRCAR7["-")!(PRCARN["-") S ^XTMP("PRCA399",$J,2,5,PRCADBTR,PRCABILL)=PRCAR7_"::"_PRCARN W:PRCAW " =>>NEGATIVE AMOUNT IN CURRENT NODE7 OR RECALC." R:'PRCAY&PRCAW PRCAY:10
;W !,?5,PRCATX,?17,PRCATXR,"/",PRCARN,! R XX
Q
RN1 I PRCATXCT=0,PRCAORIG S PRCAP(1)=PRCAP(1)+PRCAORIG,PRCASET=1 I $P(^PRCA(430,PRCABILL,6),U,21)<$P(^XTMP("PRCA399",$J,2,1,0),U) D
.S $P(^XTMP("PRCA399",$J,2,8,PRCADBTR,0),U)=$P(^XTMP("PRCA399",$J,2,8,PRCADBTR,0),U)+PRCAORIG
.S $P(^XTMP("PRCA399",$J,2,1,PRCADBTR,2,PRCABILL,0),":::")=PRCAORIG,$P(PRCARN,U)=$P(PRCARN,U)+PRCAORIG
RN2 I 'PRCASET,";16;42;"[(";"_$P(PRCAR0,U,8)_";"),$P(^PRCA(430,PRCABILL,6),U,21)<$P(^XTMP("PRCA399",$J,2,1,0),U) D S PRCASET=1
.F I=1:1:5,7:1:11 S $P(^XTMP("PRCA399",$J,2,8,PRCADBTR,0),U,I)=$P(^XTMP("PRCA399",$J,2,8,PRCADBTR,0),U,I)+$S('PRCAPPAY:$P(PRCARN,U,I),1:-$P(PRCARN,U,I))
.S $P(^XTMP("PRCA399",$J,2,1,PRCADBTR,2,PRCABILL,0),":::")=$P(PRCARN,U,1,3)
W:PRCAW !!,?18,"Node 7: ",PRCAR7
D:'PRCATX RN R:'PRCAX&PRCAW PRCAX:10
F I=1:1:5,7:1:11 S $P(^XTMP("PRCA399",$J,1,1,PRCABILL,8),U,I)=$P(^XTMP("PRCA399",$J,1,1,PRCABILL,8),U,I)+$P(PRCARN,U,I)
S ^XTMP("PRCA399",$J,9,3,PRCABILL,1)=PRCAR7,^XTMP("PRCA399",$J,9,3,PRCABILL,2)=PRCARN_":::"_$G(PRCATPRE)_U_$G(PRCATNEG)
S ^XTMP("PRCA399",$J,2,8,PRCADBTR,PRCABILL,2)=PRCARN,$P(^XTMP("PRCA399",$J,2,1,PRCADBTR,2,PRCABILL,0),":::",1)=PRCARN
Q
QQ ;END OF DEBTOR/BILL BUILD/CROSSCHECK
K PRCADBTR,PRCABGTX,PRCAPREP
D NOW^%DTC S ^XTMP("PRCA399",$J,999,"E2ENDCALCBILLDEBTOR")=%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCA399A 14391 printed Jul 11, 2026@01:35:26 Page 2
PRCA399A ;MNTVBB/RCB - RESET BILL NODE DEPENDING ON: TRANACTIONS & 382/385 ISSUES ; 2/23/22
+1 ;;4.5;Accounts Receivable;**399**;Feb 23, 2022;Build 67
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ; PAYMENTS AFTER PANDEMIC TX POST DATES 382/385
+4 QUIT
EN ;DEBTORS
+1 DO NOW^%DTC
SET ^XTMP("PRCA399",$JOB,999,"E1BEGCALCBILLDEBTOR")=%
+2 SET PRCAPREP=+$ORDER(^PRCA(430.2,"AC",33,0))
+3 ;TXPAN
SET PRCABGTX=^XTMP("PRCA399",$JOB,1,0,0)
+4 SET (PRCABDT,PRCADBTR,PRCAPPYT)=0
DEBTOR SET PRCADBTR=$ORDER(^XTMP("PRCA399",$JOB,2,1,PRCADBTR))
if 'PRCADBTR
GOTO QQ
+1 IF '$DATA(^XTMP("PRCA399",$JOB,2,8,PRCADBTR,1))
SET ^XTMP("PRCA399",$JOB,2,8,PRCADBTR,0)="0^0^0^0^0"
+2 KILL ^XTMP("PRCA399",$JOB,9,8)
+3 SET ^XTMP("PRCA399",$JOB,999,"E2BEGCALCBILLDEBTOR")=PRCADBTR
SET PRCADD=PRCADBTR
A1 SET U="^"
SET (PRCAX,PRCAXX,PRCAY,PRCAYY,PRCAXYZ,PRCABILL,PRCAT)=0
SET PRCAW=^XTMP("PRCA399",$JOB,1,0)
if PRCAPRT=1
SET PRCAW=1
BILL SET PRCABILL=$ORDER(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,2,PRCABILL))
if 'PRCABILL
GOTO Q1
+1 ;I PRCADSCP="RECALC",";16;42;44;"'[(";"_$P($G(^PRCA(430,PRCABILL,0)),U,8)_";") G BILL ;SPECIAL DISC CHK
+2 IF '$DATA(^XTMP("PRCA399",$JOB,1,1,PRCABILL))
GOTO BILL
+3 LOCK +^PRCA(430,PRCABILL):3
SET ^XTMP("PRCA399",$JOB,9,8,PRCADBTR,PRCABILL)=""
SET PRCABB=PRCABILL
+4 SET PRCAR0=^XTMP("PRCA399",$JOB,1,1,PRCABILL,0)
SET (PRCATXCT,PRCAPPAY,PRCAPRPY,PRCANEG,PRCATPRE,PRCATNEG,PRCASKIP,PRCAORIG)=0
+5 SET PRCAR7=$GET(^PRCA(430,PRCABILL,7))
SET PRCAORIG=+$PIECE(^PRCA(430,PRCABILL,0),U,3)
+6 ;+$P($G(^PRCA(430,PRCABILL,7)),U)
IF $PIECE(PRCAR0,U,2)=PRCAPREP
SET PRCAPAMT=0
DO PPAY
SET PRCAPPAY=1
SET $PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,0),U,3)=$PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,0),U,3)+PRCAPAMT
+7 SET ^XTMP("PRCA399",$JOB,999,"E3BEGCALCBILL")=PRCABILL
SET PRCARN="0^0^0^0^0^^0^0^0^0^0"
SET PRCASET=0
SET PRCATOT=0
+8 SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,8)=PRCAR7
FOR I=1:1:5,7:1:11
SET $PIECE(^XTMP("PRCA399",$JOB,1,1,PRCABILL,8),U,I)=0
+9 if PRCAW
WRITE !!!,$PIECE(PRCAR0,U),?15,"STATUS= ",$PIECE(^PRCA(430.3,$PIECE(PRCAR0,U,8),0),U,1),?35,PRCABILL,?50,PRCADBTR
+10 if PRCAW
WRITE !,?5,"BILL CURRENT TOTAL NODE 7 >> ",PRCAR7
+11 FOR I=1:1:5
SET PRCAP(I)=0
SET PRCAS(I)=0
+12 SET PRCATX=0
if PRCAW
WRITE !,?10,"PANDEMIC INTEREST/ADMIN REVERSALS: "
+13 FOR
SET PRCATX=$ORDER(^XTMP("PRCA399",$JOB,1,1,PRCABILL,99,PRCATX))
if 'PRCATX
QUIT
Begin DoDot:1
+14 if PRCAW
WRITE !,?5,PRCATX,"= ",^XTMP("PRCA399",$JOB,1,1,PRCABILL,99,PRCATX,1)
End DoDot:1
+15 ;Rework node 7 from transactions for PRCABILL
+16 DO TX46
SET PRCATX=0
SET YY=0
TX433 FOR
SET PRCATX=$ORDER(^PRCA(433,"C",PRCABILL,PRCATX))
if 'PRCATX
DO RN1
if 'PRCATX
QUIT
SET PRCATXCT=PRCATXCT+1
Begin DoDot:1
+1 SET ^XTMP("PRCA399",$JOB,999,"E4BEGCALCTX")=PRCATX
SET PRCATXN=0
SET PRCARSTR=0
SET PRCATXNG=0
SET PRCATT=PRCATX
CHECK SET PRCATXR=$GET(^PRCA(433,PRCATX,1))
SET PRCATN0=$GET(^PRCA(433,PRCATX,0))
if PRCATXR=""!($PIECE(PRCATN0,U,4)'=2)
QUIT
+1 IF 'PRCAPPAY
IF $PIECE(PRCATN0,U,10)=1
IF $PIECE(PRCATN0,U,4)'=2
if PRCAW
WRITE "STS=Incomplete"
SET ^XTMP("PRCA399",$JOB,2,7,PRCABILL,PRCATX)=PRCATN0_":::"_PRCATXR
SET PRCATXCT=PRCATXCT-1
QUIT
+2 SET PRCATXDL=+$PIECE(PRCATXR,U,5)
SET PRCACD=$PIECE(PRCATXR,U,2)
IF 'PRCACD
QUIT
+3 SET PRCACMTH=$PIECE(^TMP("PRCACD",$JOB,PRCACD),U,9)
SET PRCACPC=$EXTRACT(PRCACMTH,2)
SET PRCAT238="0^0^0^"
SET PRCAFLIP=0
+4 IF PRCATXCT=1
IF PRCACD'=1
IF PRCAORIG>0
Begin DoDot:2
+5 SET PRCAP(1)=PRCAP(1)+PRCAORIG
if PRCAW
WRITE !,?9,"POSTED ORIGINAL AMOUNT: ",PRCAORIG
+6 ;I PRCAORIG,$P(^PRCA(430,PRCABILL,6),U,21)>$P(^XTMP("PRCA399",$J,2,1,0),U) S PRCASET=1
+7 ;S $P(^XTMP("PRCA399",$J,2,8,PRCADBTR,0),U)=$P(^XTMP("PRCA399",$J,2,8,PRCADBTR,0),U)+PRCAORIG
+8 SET $PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,2,PRCABILL,0),":::")=^XTMP("PRCA399",$JOB,2,8,PRCADBTR,0)
+9 SET PRCAORIG=0
End DoDot:2
+10 IF PRCATXDL=0
QUIT
+11 IF $DATA(^XTMP("PRCA399",$JOB,5,PRCADBTR,PRCABILL,46))
if $PIECE(PRCATXR,U,9)<^XTMP("PRCA399",$JOB,5,PRCADBTR,PRCABILL,46)
QUIT
+12 SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,9,PRCATX,1)=PRCATXR
SET PRCATXH=PRCATX
SET PRCAFLIP=0
+13 IF PRCACD=2
IF $PIECE($GET(^PRCA(433,PRCATX,5)),U,2)["P17011000"
IF $PIECE(PRCATXR,U)<3170131
QUIT
+14 IF PRCATXDL<0
IF ";12;13;14;74;"[(";"_PRCACD_";")
Begin DoDot:2
+15 SET ^XTMP("PRCA399",$JOB,8,2,PRCABILL,PRCATX,1)=PRCATXR
SET $PIECE(PRCATXR,U,5)=$TRANSLATE($PIECE(PRCATXR,U,5),"-")
SET $PIECE(PRCATXR,U,2)=13
+16 SET ^XTMP("PRCA399",$JOB,8,2,PRCABILL,PRCATX,2)=PRCATXR
SET PRCACD=13
SET PRCATXDL=$PIECE(PRCATXR,U,5)
End DoDot:2
+17 if PRCAW
WRITE !,PRCATX,?16,PRCATXR
IF PRCAW
IF $GET(^PRCA(433,PRCATX,5))["PANDEMIC"
WRITE " ***PANDEMIC REVERSAL***"
T2 SET PRCATX2=""
IF ";12;13;14;74;"[(";"_PRCACD_";")
SET PRCATXN=2
Begin DoDot:2
+1 if '$DATA(^PRCA(433,PRCATX,2))
SET PRCATX2="0^"_PRCATXDL_"^0"
SET PRCATXNG=1
+2 IF $DATA(^PRCA(433,PRCATX,2))
SET PRCATX2="0^0^0"
FOR I=2,3
SET $PIECE(PRCATX2,U,I)=+$PIECE($GET(^PRCA(433,PRCATX,2)),U,I+5)+0
+3 SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,9,PRCATX,1,2)=PRCATX2
if PRCAW
WRITE !,?9,"NODE 2: "
End DoDot:2
T3 SET PRCATX3=""
IF ";2;34;35;"[(";"_PRCACD_";")
SET PRCATXN=3
SET PRCATX3="0^0^0"
Begin DoDot:2
+1 IF $DATA(^PRCA(433,PRCATX,3))
FOR I=1:1:3
SET $PIECE(PRCATX3,U,I)=+$PIECE(^PRCA(433,PRCATX,3),U,I)
+2 IF '$DATA(^PRCA(433,PRCATX,3))
SET PRCATX3=PRCATXDL_"^0^0"
SET PRCATXNG=1
+3 SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,9,PRCATX,1,3)=PRCATX3
if PRCAW
WRITE !,?9,"NODE 3: ",PRCATX3
End DoDot:2
T8 SET PRCATX8=""
IF ";8;9;10;11;32;71;43;45;46;"[(";"_PRCACD_";")
SET PRCATXN=8
Begin DoDot:2
+1 IF '$DATA(^PRCA(433,PRCATX,8))
SET PRCATX8=PRCATXDL_"^0^0^"
SET PRCATXNG=1
+2 IF $DATA(^PRCA(433,PRCATX,8))
FOR I=1:1:3
SET $PIECE(PRCATX8,U,I)=$PIECE(^PRCA(433,PRCATX,8),U,I)+0
+3 SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,9,PRCATX,1,8)=PRCATX8
if PRCAW
WRITE !,?9,"NODE 3: ",PRCATX8
End DoDot:2
+4 IF PRCATXN
IF @("PRCATX"_PRCATXN)["-"
SET PRCATXNG=1
SET @("PRCATX"_PRCATXN)=$TRANSLATE(@("PRCATX"_PRCATXN),"-")
+5 IF PRCATXN>0
Begin DoDot:2
+6 SET ^XTMP("PRCA399",$JOB,4,1,PRCADBTR,PRCABILL,PRCATX,PRCATXN,1)=@("PRCATX"_PRCATXN)_U_PRCATXN_U_PRCACD_U_PRCATXDL
+7 SET PRCATTL=0
FOR I=1:1:3
SET PRCATTL=PRCATTL+$PIECE(@("PRCATX"_PRCATXN),U,I)
+8 IF PRCATTL'=PRCATXDL
SET PRCATXNG=1
Begin DoDot:3
+9 SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,9,PRCATX,1,PRCATXN)=@("PRCATX"_PRCATXN)_"^"_PRCATXDL
End DoDot:3
+10 SET PRCAT238="0^0^0^"_PRCATXN_U_PRCACD_U_PRCATXDL
End DoDot:2
+11 IF PRCACD=23
MERGE ^XTMP("PRCA399",$JOB,4,23,PRCATX)=^PRCA(433,PRCATX)
+12 IF PRCACMTH="ZZ"
QUIT
+13 IF PRCATXDL=0
Begin DoDot:2
+14 SET ^XTMP("PRCA399",$JOB,5,6,PRCATX,1)=PRCATXR
+15 IF PRCATXN'=0
SET ^XTMP("PRCA399",$JOB,5,6,PRCATX,PRCATXN,1)=@("PRCATX"_PRCATXN)
+16 SET ^XTMP("PRCA399",$JOB,5,6,PRCATX,3)=PRCATXDL
IF PRCATXDL
if PRCATXDL&PRCAW&'PRCAXYZ
WRITE " **>>"
End DoDot:2
QUIT
TX SET (PRCAPRPY,PRCANEG,PRCATOT)=0
FOR I=1:1:3
SET PRCATOT=PRCATOT+$PIECE(PRCARN,U,I)
+1 IF 'PRCASET
IF $PIECE(PRCATXR,U,9)>$PIECE(^XTMP("PRCA399",$JOB,2,1,0),U)
Begin DoDot:2
+2 FOR I=1:1:5
SET $PIECE(^XTMP("PRCA399",$JOB,2,8,PRCADBTR,0),U,I)=$PIECE(^XTMP("PRCA399",$JOB,2,8,PRCADBTR,0),U,I)+$SELECT('PRCAPPAY:$PIECE(PRCARN,U,I),1:-$PIECE(PRCARN,U,I))
+3 SET $PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,2,PRCABILL,0),":::")=$SELECT('PRCAPPAY:PRCARN,1:-PRCARN)
End DoDot:2
SET PRCASET=1
FLIP IF (PRCATX'<PRCABGTX)!PRCATXNG
Begin DoDot:2
+1 IF $DATA(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,2,PRCABILL))
SET PRCAHCD=PRCACD
SET PRCAFLIP=1
DO EN^PRCA399B
SET PRCACD=999
QUIT
End DoDot:2
1 IF PRCACD=1
IF PRCAPPAY
Begin DoDot:2
+1 IF '$DATA(^XTMP("PRCA399",$JOB,1,1,PRCABILL,11))
SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,11)=0
+2 SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,11)=^XTMP("PRCA399",$JOB,1,1,PRCABILL,11)+PRCATXDL
SET PRCAP(1)=PRCAP(1)+PRCATXDL
End DoDot:2
11 IF PRCACD=1
IF 'PRCAPPAY
SET PRCAP(1)=PRCAP(1)+PRCATXDL
23 IF PRCACD=23
Begin DoDot:2
+1 FOR I=1:1:3
SET PRCAP(I)=0
if I=1
SET PRCAS(I+5)=PRCAS(I+5)+PRCATXDL
End DoDot:2
79 IF ";79;80;"[(";"_PRCACD_";")
SET PRCAP(1)=PRCAP(1)+PRCATXDL
43 IF PRCACD=43
SET PRCAP(1)=PRCAP(1)+PRCATXDL
SET $PIECE(PRCAT238,U)=$PIECE(PRCAT238,U)+PRCATXDL
73 IF PRCACD=73
SET PRCAP(1)=PRCAP(1)+PRCATXDL
46 IF PRCACD=46
FOR I=1:1:3
SET PRCAP(I)=PRCAP(I)+$PIECE(PRCATX8,U,I)
SET $PIECE(PRCAT238,U,I)=$PIECE(PRCATX8,U,I)
47 IF PRCACD=47
FOR I=1:1:3
SET PRCAP(I)=PRCAP(I)-$PIECE(PRCATX8,U,I)
SET $PIECE(PRCAT238,U,I)=$PIECE(PRCATX8,U,I)
10 IF ";8;9;10;11;"[(";"_PRCACD_";")
Begin DoDot:2
+1 FOR I=2,3,1
SET PRCAAMT=$SELECT(PRCATXDL'>PRCAP(I):PRCATXDL,1:PRCAP(I))
SET PRCAP(I)=PRCAP(I)-PRCAAMT
SET PRCAS(I)=PRCAS(I)+PRCAAMT
SET PRCATXDL=PRCATXDL-PRCAAMT
SET $PIECE(PRCAT238,U,I)=$PIECE(PRCAT238,U,I)+PRCAAMT
if 'PRCATXDL
QUIT
+2 if PRCATXDL
SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,9,PRCATX,2)=PRCACD_U_PRCATXDL
SET PRCANEG=PRCATXDL_U_PRCACD
+3 IF PRCATXDL'=0
SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,9,PRCATX,2)=PRCACD_U_PRCATXDL
SET PRCANEG=PRCATXDL_U_PRCACD
End DoDot:2
12 IF ";12;13;74;"[(";"_PRCACD_";")
Begin DoDot:2
+1 SET PRCADOLI=$PIECE(PRCATX2,U,2)
SET PRCADOLA=$PIECE(PRCATX2,U,3)
+2 SET PRCAP(2)=PRCAP(2)+PRCADOLI
SET PRCAP(3)=PRCAP(3)+PRCADOLA
SET $PIECE(PRCAT238,U,2)=PRCADOLI
SET $PIECE(PRCAT238,U,3)=PRCADOLA
End DoDot:2
14 IF PRCACD=14
Begin DoDot:2
+1 FOR I=2,3
SET PRCAAMT=$SELECT($PIECE(PRCATX2,U,I)>PRCAP(I):PRCAP(I),1:$PIECE(PRCATX2,U,I))
SET PRCAP(I)=PRCAP(I)-PRCAAMT
SET PRCAS(I)=PRCAS(I)+PRCAAMT
SET $PIECE(PRCAT238,U,I)=PRCAAMT
SET PRCATXDL=PRCATXDL-PRCAAMT
+2 if PRCATXDL
SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,9,PRCATX,2)=PRCACD_U_PRCATXDL
SET PRCANEG=PRCATXDL_U_PRCACD
End DoDot:2
26 IF ";26;41;"[(";"_PRCACD_";")
Begin DoDot:2
+1 FOR I=2,3,1
SET PRCAAMT=$SELECT(PRCATXDL'>PRCAP(I):PRCATXDL,1:PRCAP(I))
SET PRCAP(I)=PRCAP(I)-PRCAAMT
SET PRCAS(I)=PRCAS(I)+PRCAAMT
SET PRCATXDL=PRCATXDL-PRCAAMT
if 'PRCATXDL
QUIT
+2 if PRCATXDL
SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,9,PRCATX,3)=PRCACD_U_PRCATXDL
SET PRCANEG=PRCATXDL_U_PRCACD
End DoDot:2
39 IF ";39;70;"[(";"_PRCACD_";")
Begin DoDot:2
+1 SET PRCAAMT=$SELECT(PRCAP(1)'>PRCATXDL:PRCAP(1),1:PRCATXDL)
SET PRCAP(1)=PRCAP(1)-PRCAAMT
SET PRCAS(1)=PRCAS(1)+PRCAAMT
SET PRCATXDL=PRCATXDL-PRCAAMT
SET $PIECE(PRCAT238,U)=PRCAAMT
if 'PRCATXDL
QUIT
+2 if PRCATXDL
SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,9,PRCATX,3)=PRCACD_U_PRCATXDL
SET PRCANEG=PRCATXDL_U_PRCACD
End DoDot:2
2 IF ";2;34;35;"[(";"_PRCACD_";")
Begin DoDot:2
+1 SET PRCAPDOL=0
FOR I=1:1:3
SET PRCAPDOL=PRCAPDOL+$PIECE(PRCATX3,U,I)
+2 IF PRCAPDOL'=PRCATXDL
SET PRCATXDL=PRCAPDOL
SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,9,PRCATX,3)=PRCACD_U_PRCATXDL_PRCAPDOL
+3 SET PRCAAMT=$SELECT($PIECE(PRCATX3,U,2)>PRCAP(2):PRCAP(2),1:$PIECE(PRCATX3,U,2))
SET PRCAP(2)=PRCAP(2)-PRCAAMT
SET $PIECE(PRCAT238,U,2)=PRCAAMT
+4 SET PRCAS(2)=PRCAS(2)+PRCAAMT
SET PRCATXDL=PRCATXDL-PRCAAMT
SET $PIECE(PRCATX3,U,2)=$PIECE(PRCATX3,U,2)-PRCAAMT
+5 SET PRCAAMT=$SELECT($PIECE(PRCATX3,U,3)>PRCAP(3):PRCAP(3),1:$PIECE(PRCATX3,U,3))
if $PIECE(PRCATX3,U,3)
Begin DoDot:3
+6 SET PRCAP(3)=PRCAP(3)-PRCAAMT
SET PRCAS(3)=PRCAS(3)+PRCAAMT
SET $PIECE(PRCAT238,U,3)=PRCAAMT
SET PRCATXDL=PRCATXDL-PRCAAMT
+7 SET $PIECE(PRCATX3,U,3)=$PIECE(PRCATX3,U,3)-PRCAAMT
End DoDot:3
+8 SET PRCAAMT=$SELECT(PRCATXDL>PRCAP(1):PRCAP(1),1:PRCATXDL)
SET PRCAP(1)=PRCAP(1)-PRCAAMT
SET PRCAS(1)=PRCAS(1)+PRCAAMT
SET $PIECE(PRCAT238,U)=PRCAAMT
SET PRCATXDL=PRCATXDL-PRCAAMT
+9 SET PRCAPRPY=PRCATXDL_U_PRCACD
SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,9,PRCATX,5)=PRCAPRPY
End DoDot:2
+10 if PRCACD=999
SET PRCACD=PRCAHCD
+11 IF PRCAPRPY>0
Begin DoDot:2
+12 SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,9,PRCATX,3,"9C")=PRCAPRPY
+13 SET ^XTMP("PRCA399",$JOB,2,1,PRCADBTR,1,PRCABILL,1,PRCATX)=PRCAPRPY
SET PRCATPRE=PRCATPRE+PRCAPRPY
+14 if PRCAW
WRITE !,"PREPAYA DETERMINED: ",+PRCAPRPY," FOR PRCABILL: ",$PIECE(PRCAR0,U)
if 'PRCAY&PRCAW
READ PRCAY:10
End DoDot:2
+15 IF PRCANEG
Begin DoDot:2
+16 SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,9,PRCATX,3,"9B")=PRCANEG
SET ^XTMP("PRCA399",$JOB,2,1,PRCADBTR,1,PRCABILL,2,PRCATX)=PRCANEG
+17 SET PRCATNEG=PRCATNEG+PRCANEG
+18 if PRCAW
WRITE " ",PRCATX," $$ (",PRCANEG,") DID NOT CLEAR WITH POST!"
if 'PRCAY&PRCAW
READ PRCAY:10
End DoDot:2
+19 IF PRCANEG!PRCAPRPY
SET PRCANGPY=PRCANEG+PRCAPRPY
SET ^XTMP("PRCA399",$JOB,2,1,PRCADBTR,4,PRCABILL,PRCATXH)=PRCANGPY_"::"_PRCATXR
+20 IF PRCATXN
Begin DoDot:2
+21 SET ^XTMP("PRCA399",$JOB,4,1,PRCADBTR,PRCABILL,PRCATX,PRCATXN,2)=PRCAT238_U_PRCAPRPY_U_PRCANEG
End DoDot:2
+22 QUIT
End DoDot:1
if PRCATX
DO RN
+23 GOTO BILL
TX46 SET PRCATX=0
KILL ^XTMP("PRCA399",$JOB,5,PRCADBTR,PRCABILL,46)
+1 FOR
SET PRCATX=$ORDER(^PRCA(433,"C",PRCABILL,PRCATX))
if 'PRCATX
QUIT
Begin DoDot:1
+2 IF $PIECE(^PRCA(433,PRCATX,1),U,2)=46
Begin DoDot:2
+3 SET ^XTMP("PRCA399",$JOB,5,PRCADBTR,PRCABILL,46)=$PIECE(^PRCA(433,PRCATX,1),U,9)
End DoDot:2
End DoDot:1
+4 QUIT
Q1 DO NOW^%DTC
SET ^XTMP("PRCA399",$JOB,999,"E2ENDCALCBILL/DEBTOR")=%
+1 KILL I,P,S,PRCAAMT,PRCABDT,PRCABILL,PRCACD,PRCACMTH,PRCACPC,PRCAPPYT,PRCATXN,PRCAHCD
+2 KILL PRCADOLA,PRCADOLI,PRCAFLIP,PRCANEG,PRCANGPY,PRCAORIG,PRCAP,PRCAPDOL,PRCAPRPY,PRCATNEG
+3 KILL PRCAR0,PRCAR1,PRCAR2,PRCAR7,PRCARN,PRCARR,PRCAS,PRCAT,PRCAT1,PRCAT2,PRCAT3,PRCATN0,PRCATNEG,PRCATOT7,PRCATPRE,PRCATX
+4 KILL PRCATX2,PRCATX3,PRCATX8,PRCATXCT,PRCATXDL,PRCATXH,PRCATXR,PRCAW,PRCAX,PRCAXX
+5 KILL PRCAXYZ,PRCAY,PRCAYY,PRCASKIP,PRCAPPAY,PRCASET,PRCATOT,PRCATNEG
+6 KILL PRCATPRE,PRCATX,XX,PRCATXN,PRCAPAMT
+7 DO EN^PRCA399C(PRCADBTR)
DO 10^PRCA399E
+8 SET PRCABILL=0
FOR
SET PRCABILL=$ORDER(^XTMP("PRCA399",$JOB,9,8,PRCADBTR,PRCABILL))
if 'PRCABILL
QUIT
LOCK -^PRCA(430,PRCABILL)
+9 GOTO DEBTOR
PPAY ;GRAB ORIGINAL PREPAY AMOUNT
+1 NEW PRCAPPT,PRCATXPP
+2 SET PRCAPPT=$ORDER(^PRCA(433,"C",PRCABILL,0))
IF 'PRCAPPT
SET PRCAPAMT=0
QUIT
+3 SET PRCATXPP=$GET(^PRCA(433,PRCAPPT,1))
SET PRCAPAMT=+$PIECE(PRCATXPP,U,5)
+4 QUIT
+5 ;
RN ;W !,"TX ADD: ",PRCADBTR,U,PRCABILL,U,PRCATX," ",PRCATXR," ",PRCAP(1),"/",PRCAS(1) ;###1
+1 SET PRCARN=""
FOR I=1:1:5
SET $PIECE(PRCARN,U,I)=PRCAP(I)
+2 FOR I=7:1:11
SET $PIECE(PRCARN,U,I)=PRCAS(I-6)
+3 if PRCAW
WRITE !,?10,"REBUILT NODE 7 >> ",PRCARN
if 'PRCAXX&PRCAW
READ PRCAX:10
+4 IF 'PRCATX
IF (PRCATNEG!PRCATPRE)
Begin DoDot:1
+5 SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,6)=PRCATPRE_U_PRCATNEG
+6 if '$DATA(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,0))
SET ^XTMP("PRCA399",$JOB,2,1,PRCADBTR,0)="0^0"
if '$DATA(^XTMP("PRCA399",$JOB,1,1,PRCADBTR,0,PRCABILL))
SET ^XTMP("PRCA399",$JOB,2,1,PRCADBTR,0,PRCABILL)="0^0"
+7 SET $PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,0),U)=$PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,0),U)+PRCATPRE
SET $PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,0,PRCABILL),U)=$PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,0,PRCABILL),U)+PRCATPRE
+8 SET $PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,0),U,2)=$PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,0),U,2)+PRCATNEG
SET $PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,0,PRCABILL),U,2)=$PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,0,PRCABILL),U,2)+PRCATNEG
End DoDot:1
+9 IF 'PRCATX
Begin DoDot:1
+10 SET ^XTMP("PRCA399",$JOB,2,2,PRCADBTR,1,PRCABILL,1)=PRCAR7
SET ^XTMP("PRCA399",$JOB,2,2,PRCADBTR,1,PRCABILL,2)=PRCARN
IF $PIECE(PRCARN,U,1,5)'=$PIECE(PRCAR7,U,1,5)
SET ^XTMP("PRCA399",$JOB,2,3,PRCADBTR,PRCABILL)=$PIECE(PRCAR7,U,1,5)_":::"_$PIECE(PRCARN,U,1,5)
+11 IF PRCARN["-"
SET ^XTMP("PRCA399",$JOB,1,1,PRCABILL,12)=PRCARN
if PRCAW
WRITE !,"NEW BAL NODE NEGATIVE: ",PRCABILL
End DoDot:1
+12 IF (PRCAR7["-")!(PRCARN["-")
SET ^XTMP("PRCA399",$JOB,2,5,PRCADBTR,PRCABILL)=PRCAR7_"::"_PRCARN
if PRCAW
WRITE " =>>NEGATIVE AMOUNT IN CURRENT NODE7 OR RECALC."
if 'PRCAY&PRCAW
READ PRCAY:10
+13 ;W !,?5,PRCATX,?17,PRCATXR,"/",PRCARN,! R XX
+14 QUIT
RN1 IF PRCATXCT=0
IF PRCAORIG
SET PRCAP(1)=PRCAP(1)+PRCAORIG
SET PRCASET=1
IF $PIECE(^PRCA(430,PRCABILL,6),U,21)<$PIECE(^XTMP("PRCA399",$JOB,2,1,0),U)
Begin DoDot:1
+1 SET $PIECE(^XTMP("PRCA399",$JOB,2,8,PRCADBTR,0),U)=$PIECE(^XTMP("PRCA399",$JOB,2,8,PRCADBTR,0),U)+PRCAORIG
+2 SET $PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,2,PRCABILL,0),":::")=PRCAORIG
SET $PIECE(PRCARN,U)=$PIECE(PRCARN,U)+PRCAORIG
End DoDot:1
RN2 IF 'PRCASET
IF ";16;42;"[(";"_$PIECE(PRCAR0,U,8)_";")
IF $PIECE(^PRCA(430,PRCABILL,6),U,21)<$PIECE(^XTMP("PRCA399",$JOB,2,1,0),U)
Begin DoDot:1
+1 FOR I=1:1:5,7:1:11
SET $PIECE(^XTMP("PRCA399",$JOB,2,8,PRCADBTR,0),U,I)=$PIECE(^XTMP("PRCA399",$JOB,2,8,PRCADBTR,0),U,I)+$SELECT('PRCAPPAY:$PIECE(PRCARN,U,I),1:-$PIECE(PRCARN,U,I))
+2 SET $PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,2,PRCABILL,0),":::")=$PIECE(PRCARN,U,1,3)
End DoDot:1
SET PRCASET=1
+3 if PRCAW
WRITE !!,?18,"Node 7: ",PRCAR7
+4 if 'PRCATX
DO RN
if 'PRCAX&PRCAW
READ PRCAX:10
+5 FOR I=1:1:5,7:1:11
SET $PIECE(^XTMP("PRCA399",$JOB,1,1,PRCABILL,8),U,I)=$PIECE(^XTMP("PRCA399",$JOB,1,1,PRCABILL,8),U,I)+$PIECE(PRCARN,U,I)
+6 SET ^XTMP("PRCA399",$JOB,9,3,PRCABILL,1)=PRCAR7
SET ^XTMP("PRCA399",$JOB,9,3,PRCABILL,2)=PRCARN_":::"_$GET(PRCATPRE)_U_$GET(PRCATNEG)
+7 SET ^XTMP("PRCA399",$JOB,2,8,PRCADBTR,PRCABILL,2)=PRCARN
SET $PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,2,PRCABILL,0),":::",1)=PRCARN
+8 QUIT
QQ ;END OF DEBTOR/BILL BUILD/CROSSCHECK
+1 KILL PRCADBTR,PRCABGTX,PRCAPREP
+2 DO NOW^%DTC
SET ^XTMP("PRCA399",$JOB,999,"E2ENDCALCBILLDEBTOR")=%
+3 QUIT
