PRCA399F ;MNTVBB/RGB - Restores any changes to AR files to allow re-testing ; FEB 05, 2022
;;4.5;Accounts Receivable;**399**;;Build 67
;;Per VA Directive 6402, this routine should not be modified.
Q
EN I '$D(^XTMP("PRCA399",$J,998)) W !!,"*********THERE IS NO PENDING RESTORE DATA, ALREADY DONE ********" Q
D A1,A2,A5,A12,A14,A16 Q
A1 ;RESTORE FOR REMOVED EVENT FILE ENTRIES IN 399 CALC
Q ;NO LONGER REMOVE PREVIOUS EVENTS!!
S U="^",PRCADB=0,XX=0 ;^XTMP("PRCA399",$J,9,9,PRCACTR)=PRCA341
F S PRCADB=$O(^XTMP("PRCA399",$J,9,9,PRCADB)),PRCACTR=0 Q:'PRCADB D
.F S PRCACTR=$O(^XTMP("PRCA399",$J,9,9,PRCADB,PRCACTR)) Q:'PRCACTR D
..S DA=PRCACTR,DIK="^RC(341," D IX^DIK ;I 'XX W !,PRCADB," / ",PRCACTR R:'XX XX:25
W !,"ALL PRCA399 CALC SET 341 ENTRIES BACKED OUT**"
K PRCACTR,DA,DIK,XX
Q
;
A2 ;Remove new file 341 entries set during install
S U="^",PRCADB=0,XX=0
F S PRCAIEN=$O(^XTMP("PRCA399",$J,9,9,PRCADB)),PRCACTR=0 Q:'PRCADB D
.F S PRCACTR=$O(^XTMP("PRCA399",$J,9,9,PRCADB,PRCACTR)) Q:'PRCACTR D
..S DA=PRCACTR,DIK="^RC(341," D ^DIK ;I 'XX W !,PRCACTR R:'XX XX:25
;W !!,"==> new EVENT FILE (431) entry "_PRCACTR_" removed"
K PRCAIEN,PRCACTR,DA,DIK,XX
Q
;
A5 ;Reset flipped cd 14 tx in file 433 to before testing status
W !!,"Reset transaction type 14 with negative amount",!
S U="^",PRCAIEN=0,XX=0
F S PRCAIEN=$O(^XTMP("PRCA399",$J,7,2,PRCAIEN)) Q:'PRCAIEN D
.S PRCATXN1=^XTMP("PRCA399",$J,7,2,PRCAIEN,1) W !,PRCAIEN,?12,PRCATXN1
.S ^PRCA(433,PRCAIEN,1)=PRCATXN1
K PRCAIEN,PRCATXN1,XX
W !!,"Original flipped 14 nodes restore to before instance"
Q
;
A12 ;RESTORE ORIGINAL NODE 7 FROM ^XTMP("PRCA399",$J,7,3,,"7A")
S U="^",PRCABILL=0,XX=0
F S PRCABILL=$O(^XTMP("PRCA399",$J,7,3,PRCABILL)) Q:'PRCABILL D
.S PRCAOLD7=^XTMP("PRCA399",$J,7,3,PRCABILL,"7A"),^PRCA(430,PRCABILL,7)=PRCAOLD7
K PRCABILL,PRCAOLD7,XX
W !!,"Original adj transactions restore to before instance"
Q
;
A14 ;reset original tx from tag 14 to before testing update
S U="^",PRCADB=0,XX=0
F S PRCADB=$O(^XTMP("PRCA399",$J,2,1,PRCADB)),PRCABILL=0 Q:'PRCADB D
.F S PRCABILL=$O(^XTMP("PRCA399",$J,2,1,PRCADB,4,PRCABILL)),PRCATX=0 Q:'PRCABILL D
..F S PRCATX=$O(^XTMP("PRCA399",$J,2,1,PRCADB,4,PRCABILL,PRCATX)) Q:'PRCATX D
...S ^PRCA(433,PRCATX,1)=$P(^XTMP("PRCA399",$J,2,1,PRCADB,4,PRCABILL,PRCATX),":",3)
...W !,"RESTORED: ",PRCATX,?22,$P(^XTMP("PRCA399",$J,2,1,PRCADB,4,PRCABILL,PRCATX),":",3)
W !!,"Restored modified transaction amts from leftover decrease or prepay"
K PRCADB,PRCABILL,PRCATX,XX
K ^XTMP("PRCA399",$J,998) ;PREVENTS BACK TO BACK RUNS BY SETTING IN PRCA399P, BUT ALLOWS RUN ONCE RESTORED
Q
;
A16 ;SET OLD 2,3,8 NODE BACK INTO FILE 433
S PRCADEB=0,Z="/",XX=0,PRCAREST=0,T=0
;PRCAT238=PRIN;INT;FEE;NODE#;TX CD;TX CHG;DIFF BETWEEN TX CHG AND NODE TOT;FLIP
;S ^XTMP("PRCA399",$J,4,1,PRCADEB,PRCABILL,PRCATX,PRCATXN,1)=PRCAT238
;S ^XTMP("PRCA399",$J,4,1,PRCADEB,PRCABILL,PRCATX,PRCATXN,2)=PRCAT238.DIFF.FLIP?
F S PRCADEB=$O(^XTMP("PRCA399",$J,4,1,PRCADEB)),PRCABILL=0 Q:'PRCADEB D
.F S PRCABILL=$O(^XTMP("PRCA399",$J,4,1,PRCADEB,PRCABILL)),PRCATX=0 Q:'PRCABILL D
..F S PRCATX=$O(^XTMP("PRCA399",$J,4,1,PRCADEB,PRCABILL,PRCATX)),PRCATYP=0 Q:'PRCATX D
...F S PRCATYP=$O(^XTMP("PRCA399",$J,4,1,PRCADEB,PRCABILL,PRCATX,PRCATYP)) Q:'PRCATYP D
....S PRCAT1=^XTMP("PRCA399",$J,4,1,PRCADEB,PRCABILL,PRCATX,PRCATYP,1)
....S PRCAT2=^XTMP("PRCA399",$J,4,1,PRCADEB,PRCABILL,PRCATX,PRCATYP,2)
....S PRCAREST=0
....F I=1:1:3 I +$P(PRCAT1,U,I)'=+$P(PRCAT2,U,I) S PRCAREST=1 D
.....I PRCATYP=2 F I=2,3 S $P(^PRCA(433,PRCATX,2),U,I+5)=+$P(PRCAT1,U,I)
.....I PRCATYP'=2 F I=1:1:3 S $P(^PRCA(433,PRCATX,PRCATYP),U,I)=+$P(PRCAT1,U,I)
.....;I PRCAREST W !,PRCADEB,Z,PRCABILL,Z,PRCATX,Z,PRCATYP W ?30,PRCAT1,!,?30,PRCAT2 R:'XX XX
K PRCADB,PRCABILL,PRCATX,PRCATYP,PRCAT1,PRCAT2,PRCAFIX
Q
;
A17 ;RESTORE 433 NODES MODIFIED DUE TO PREPAY/PNEG TO BALANCE BILL
B190 ;TEST DISCREPS
S U="^"
B191 R !,"DEBTOR IEN: ",PRCADEB:30 Q:'PRCADEB
S PRCABN=0
F S PRCABN=$O(^PRCA(430,"C",PRCADEB,PRCABN)) G B192:'PRCABN D
.S PRCAX=$$GETTRANS^RCDPBTLM(PRCABN),PRCAY=$P($G(^PRCA(430,PRCABN,7)),U,1,5)
.X "S PRCAOK=1 F PRCAPCE=1:1:5 I +$P(PRCAX,U,PRCAPCE)'=+$P(PRCAY,U,PRCAPCE) S PRCAOK=0 Q"
.I 'PRCAOK W !,PRCABN,?9,$P($G(^PRCA(430,PRCABN,0)),U,1),?30,PRCAX,?50,PRCAY
G B191
B192 K PRCADEB,PRCABN,PRCAY,PRCAX,PRCAOK,PRCAPCE
Q
X1 ;Gather 433 tx with zero amt
S PRCATX=0,PRCATX=0
F S PRCATX=$O(^PRCA(433,PRCATX)) Q:'PRCATX D
.S PRCAR=$G(^PRCA(433,PRCATX,1))
.I $P(PRCAR,U,2)'=45,$P(PRCAR,U,5)=0 S ^XTMP("PRCA399",$J,5,1,PRCATX)=PRCAR
.W !,PRCATX,?15,PRCAR R:'PRCAX PRCAX:10
K PRCATX,PRCAOLD7,PRCAR,PRCAX
Q
;
X2 ;CHECK ^XTMP("PRCA399",$J,5,1 ZERO AMT ENTRIES AGAINST SUB NODES
S U="^",PRCAX=0
R !,"STARTING TX IEN: ",PRCATX:30 Q:'PRCATX
F S PRCATX=$O(^XTMP("PRCA399",$J,5,1,PRCATX)) Q:'PRCATX D
.S PRCATXB="NONE",PRCATXN=^XTMP("PRCA399",$J,5,1,PRCATX),PRCACD=$P(PRCATXN,U,2) Q:PRCACD=45 W:PRCAX !,PRCATX,?11,PRCATXN
.I ";12;13;14;"[(";"_PRCACD_";") S PRCATXB=$G(^PRCA(433,PRCATX,2))
.I ";2;34;"[(";"_PRCACD_";") S PRCATXB=$G(^PRCA(433,PRCATX,3))
.I ";8;9;10;11;35;43;46;47;"[(";"_PRCACD_";") S PRCATXB=$G(^PRCA(433,PRCATX,8))
.;W ?58,PRCATXB R:'PRCAX PRCAX:10
K PRCAX,PRCATX,PRCATXB,PRCATXN,PRCACD
Q
;
TRACEON ;Turn tracing ON to watch calcs
S ^XTMP("PRCA399",$J,1,0)=1
S ^XTMP("PRCA399",$J,2,0)=1
Q
TRACEOFF ;Turn tracing OFF to NOT watch calcs
S ^XTMP("PRCA399",$J,1,0)=0
S ^XTMP("PRCA399",$J,2,0)=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCA399F 5586 printed Jul 11, 2026@01:35:31 Page 2
PRCA399F ;MNTVBB/RGB - Restores any changes to AR files to allow re-testing ; FEB 05, 2022
+1 ;;4.5;Accounts Receivable;**399**;;Build 67
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
EN IF '$DATA(^XTMP("PRCA399",$JOB,998))
WRITE !!,"*********THERE IS NO PENDING RESTORE DATA, ALREADY DONE ********"
QUIT
+1 DO A1
DO A2
DO A5
DO A12
DO A14
DO A16
QUIT
A1 ;RESTORE FOR REMOVED EVENT FILE ENTRIES IN 399 CALC
+1 ;NO LONGER REMOVE PREVIOUS EVENTS!!
QUIT
+2 ;^XTMP("PRCA399",$J,9,9,PRCACTR)=PRCA341
SET U="^"
SET PRCADB=0
SET XX=0
+3 FOR
SET PRCADB=$ORDER(^XTMP("PRCA399",$JOB,9,9,PRCADB))
SET PRCACTR=0
if 'PRCADB
QUIT
Begin DoDot:1
+4 FOR
SET PRCACTR=$ORDER(^XTMP("PRCA399",$JOB,9,9,PRCADB,PRCACTR))
if 'PRCACTR
QUIT
Begin DoDot:2
+5 ;I 'XX W !,PRCADB," / ",PRCACTR R:'XX XX:25
SET DA=PRCACTR
SET DIK="^RC(341,"
DO IX^DIK
End DoDot:2
End DoDot:1
+6 WRITE !,"ALL PRCA399 CALC SET 341 ENTRIES BACKED OUT**"
+7 KILL PRCACTR,DA,DIK,XX
+8 QUIT
+9 ;
A2 ;Remove new file 341 entries set during install
+1 SET U="^"
SET PRCADB=0
SET XX=0
+2 FOR
SET PRCAIEN=$ORDER(^XTMP("PRCA399",$JOB,9,9,PRCADB))
SET PRCACTR=0
if 'PRCADB
QUIT
Begin DoDot:1
+3 FOR
SET PRCACTR=$ORDER(^XTMP("PRCA399",$JOB,9,9,PRCADB,PRCACTR))
if 'PRCACTR
QUIT
Begin DoDot:2
+4 ;I 'XX W !,PRCACTR R:'XX XX:25
SET DA=PRCACTR
SET DIK="^RC(341,"
DO ^DIK
End DoDot:2
End DoDot:1
+5 ;W !!,"==> new EVENT FILE (431) entry "_PRCACTR_" removed"
+6 KILL PRCAIEN,PRCACTR,DA,DIK,XX
+7 QUIT
+8 ;
A5 ;Reset flipped cd 14 tx in file 433 to before testing status
+1 WRITE !!,"Reset transaction type 14 with negative amount",!
+2 SET U="^"
SET PRCAIEN=0
SET XX=0
+3 FOR
SET PRCAIEN=$ORDER(^XTMP("PRCA399",$JOB,7,2,PRCAIEN))
if 'PRCAIEN
QUIT
Begin DoDot:1
+4 SET PRCATXN1=^XTMP("PRCA399",$JOB,7,2,PRCAIEN,1)
WRITE !,PRCAIEN,?12,PRCATXN1
+5 SET ^PRCA(433,PRCAIEN,1)=PRCATXN1
End DoDot:1
+6 KILL PRCAIEN,PRCATXN1,XX
+7 WRITE !!,"Original flipped 14 nodes restore to before instance"
+8 QUIT
+9 ;
A12 ;RESTORE ORIGINAL NODE 7 FROM ^XTMP("PRCA399",$J,7,3,,"7A")
+1 SET U="^"
SET PRCABILL=0
SET XX=0
+2 FOR
SET PRCABILL=$ORDER(^XTMP("PRCA399",$JOB,7,3,PRCABILL))
if 'PRCABILL
QUIT
Begin DoDot:1
+3 SET PRCAOLD7=^XTMP("PRCA399",$JOB,7,3,PRCABILL,"7A")
SET ^PRCA(430,PRCABILL,7)=PRCAOLD7
End DoDot:1
+4 KILL PRCABILL,PRCAOLD7,XX
+5 WRITE !!,"Original adj transactions restore to before instance"
+6 QUIT
+7 ;
A14 ;reset original tx from tag 14 to before testing update
+1 SET U="^"
SET PRCADB=0
SET XX=0
+2 FOR
SET PRCADB=$ORDER(^XTMP("PRCA399",$JOB,2,1,PRCADB))
SET PRCABILL=0
if 'PRCADB
QUIT
Begin DoDot:1
+3 FOR
SET PRCABILL=$ORDER(^XTMP("PRCA399",$JOB,2,1,PRCADB,4,PRCABILL))
SET PRCATX=0
if 'PRCABILL
QUIT
Begin DoDot:2
+4 FOR
SET PRCATX=$ORDER(^XTMP("PRCA399",$JOB,2,1,PRCADB,4,PRCABILL,PRCATX))
if 'PRCATX
QUIT
Begin DoDot:3
+5 SET ^PRCA(433,PRCATX,1)=$PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADB,4,PRCABILL,PRCATX),":",3)
+6 WRITE !,"RESTORED: ",PRCATX,?22,$PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADB,4,PRCABILL,PRCATX),":",3)
End DoDot:3
End DoDot:2
End DoDot:1
+7 WRITE !!,"Restored modified transaction amts from leftover decrease or prepay"
+8 KILL PRCADB,PRCABILL,PRCATX,XX
+9 ;PREVENTS BACK TO BACK RUNS BY SETTING IN PRCA399P, BUT ALLOWS RUN ONCE RESTORED
KILL ^XTMP("PRCA399",$JOB,998)
+10 QUIT
+11 ;
A16 ;SET OLD 2,3,8 NODE BACK INTO FILE 433
+1 SET PRCADEB=0
SET Z="/"
SET XX=0
SET PRCAREST=0
SET T=0
+2 ;PRCAT238=PRIN;INT;FEE;NODE#;TX CD;TX CHG;DIFF BETWEEN TX CHG AND NODE TOT;FLIP
+3 ;S ^XTMP("PRCA399",$J,4,1,PRCADEB,PRCABILL,PRCATX,PRCATXN,1)=PRCAT238
+4 ;S ^XTMP("PRCA399",$J,4,1,PRCADEB,PRCABILL,PRCATX,PRCATXN,2)=PRCAT238.DIFF.FLIP?
+5 FOR
SET PRCADEB=$ORDER(^XTMP("PRCA399",$JOB,4,1,PRCADEB))
SET PRCABILL=0
if 'PRCADEB
QUIT
Begin DoDot:1
+6 FOR
SET PRCABILL=$ORDER(^XTMP("PRCA399",$JOB,4,1,PRCADEB,PRCABILL))
SET PRCATX=0
if 'PRCABILL
QUIT
Begin DoDot:2
+7 FOR
SET PRCATX=$ORDER(^XTMP("PRCA399",$JOB,4,1,PRCADEB,PRCABILL,PRCATX))
SET PRCATYP=0
if 'PRCATX
QUIT
Begin DoDot:3
+8 FOR
SET PRCATYP=$ORDER(^XTMP("PRCA399",$JOB,4,1,PRCADEB,PRCABILL,PRCATX,PRCATYP))
if 'PRCATYP
QUIT
Begin DoDot:4
+9 SET PRCAT1=^XTMP("PRCA399",$JOB,4,1,PRCADEB,PRCABILL,PRCATX,PRCATYP,1)
+10 SET PRCAT2=^XTMP("PRCA399",$JOB,4,1,PRCADEB,PRCABILL,PRCATX,PRCATYP,2)
+11 SET PRCAREST=0
+12 FOR I=1:1:3
IF +$PIECE(PRCAT1,U,I)'=+$PIECE(PRCAT2,U,I)
SET PRCAREST=1
Begin DoDot:5
+13 IF PRCATYP=2
FOR I=2,3
SET $PIECE(^PRCA(433,PRCATX,2),U,I+5)=+$PIECE(PRCAT1,U,I)
+14 IF PRCATYP'=2
FOR I=1:1:3
SET $PIECE(^PRCA(433,PRCATX,PRCATYP),U,I)=+$PIECE(PRCAT1,U,I)
+15 ;I PRCAREST W !,PRCADEB,Z,PRCABILL,Z,PRCATX,Z,PRCATYP W ?30,PRCAT1,!,?30,PRCAT2 R:'XX XX
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 KILL PRCADB,PRCABILL,PRCATX,PRCATYP,PRCAT1,PRCAT2,PRCAFIX
+17 QUIT
+18 ;
A17 ;RESTORE 433 NODES MODIFIED DUE TO PREPAY/PNEG TO BALANCE BILL
B190 ;TEST DISCREPS
+1 SET U="^"
B191 READ !,"DEBTOR IEN: ",PRCADEB:30
if 'PRCADEB
QUIT
+1 SET PRCABN=0
+2 FOR
SET PRCABN=$ORDER(^PRCA(430,"C",PRCADEB,PRCABN))
if 'PRCABN
GOTO B192
Begin DoDot:1
+3 SET PRCAX=$$GETTRANS^RCDPBTLM(PRCABN)
SET PRCAY=$PIECE($GET(^PRCA(430,PRCABN,7)),U,1,5)
+4 XECUTE "S PRCAOK=1 F PRCAPCE=1:1:5 I +$P(PRCAX,U,PRCAPCE)'=+$P(PRCAY,U,PRCAPCE) S PRCAOK=0 Q"
+5 IF 'PRCAOK
WRITE !,PRCABN,?9,$PIECE($GET(^PRCA(430,PRCABN,0)),U,1),?30,PRCAX,?50,PRCAY
End DoDot:1
+6 GOTO B191
B192 KILL PRCADEB,PRCABN,PRCAY,PRCAX,PRCAOK,PRCAPCE
+1 QUIT
X1 ;Gather 433 tx with zero amt
+1 SET PRCATX=0
SET PRCATX=0
+2 FOR
SET PRCATX=$ORDER(^PRCA(433,PRCATX))
if 'PRCATX
QUIT
Begin DoDot:1
+3 SET PRCAR=$GET(^PRCA(433,PRCATX,1))
+4 IF $PIECE(PRCAR,U,2)'=45
IF $PIECE(PRCAR,U,5)=0
SET ^XTMP("PRCA399",$JOB,5,1,PRCATX)=PRCAR
+5 WRITE !,PRCATX,?15,PRCAR
if 'PRCAX
READ PRCAX:10
End DoDot:1
+6 KILL PRCATX,PRCAOLD7,PRCAR,PRCAX
+7 QUIT
+8 ;
X2 ;CHECK ^XTMP("PRCA399",$J,5,1 ZERO AMT ENTRIES AGAINST SUB NODES
+1 SET U="^"
SET PRCAX=0
+2 READ !,"STARTING TX IEN: ",PRCATX:30
if 'PRCATX
QUIT
+3 FOR
SET PRCATX=$ORDER(^XTMP("PRCA399",$JOB,5,1,PRCATX))
if 'PRCATX
QUIT
Begin DoDot:1
+4 SET PRCATXB="NONE"
SET PRCATXN=^XTMP("PRCA399",$JOB,5,1,PRCATX)
SET PRCACD=$PIECE(PRCATXN,U,2)
if PRCACD=45
QUIT
if PRCAX
WRITE !,PRCATX,?11,PRCATXN
+5 IF ";12;13;14;"[(";"_PRCACD_";")
SET PRCATXB=$GET(^PRCA(433,PRCATX,2))
+6 IF ";2;34;"[(";"_PRCACD_";")
SET PRCATXB=$GET(^PRCA(433,PRCATX,3))
+7 IF ";8;9;10;11;35;43;46;47;"[(";"_PRCACD_";")
SET PRCATXB=$GET(^PRCA(433,PRCATX,8))
+8 ;W ?58,PRCATXB R:'PRCAX PRCAX:10
End DoDot:1
+9 KILL PRCAX,PRCATX,PRCATXB,PRCATXN,PRCACD
+10 QUIT
+11 ;
TRACEON ;Turn tracing ON to watch calcs
+1 SET ^XTMP("PRCA399",$JOB,1,0)=1
+2 SET ^XTMP("PRCA399",$JOB,2,0)=1
+3 QUIT
TRACEOFF ;Turn tracing OFF to NOT watch calcs
+1 SET ^XTMP("PRCA399",$JOB,1,0)=0
+2 SET ^XTMP("PRCA399",$JOB,2,0)=0
+3 QUIT
