PRCA399E ;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.
EN ;Purge old statement dates from file ^RC(341
Q
D NOW^%DTC S ^XTMP("PRCA399",$J,999,"C1RESET/STATEMENTDATES")=%
S U="^",(PRCAT,PRCAX)=0
1 ;KILL 341 DATED NODES FOR PRCA399 FIX
S PRCADEB=0,PRCADATE=6789468.884099 ;Delete statement runs past 5/31/21
2 F S PRCADEB=$O(^XTMP("PRCA399",$J,2,1,PRCADEB)),PRCADT=0 Q:'PRCADEB D
. F S PRCADT=$O(^RC(341,"AD",PRCADEB,2,PRCADT)),PRCAIEN=0 Q:'PRCADT D
.. I PRCADATE'>PRCADT Q
.. F S PRCAIEN=$O(^RC(341,"AD",PRCADEB,2,PRCADT,PRCAIEN)) Q:'PRCAIEN D
... S PRCAR=$G(^RC(341,PRCAIEN,1))
... I PRCAR["-" S ^XTMP("PRCA399",$J,7,5,341,PRCAIEN,1)=PRCAR
... M ^XTMP("PRCA399",$J,7,1,341,PRCAIEN)=^RC(341,PRCAIEN) S PRCADTW=9999999.999999-PRCADT
... ;W !,PRCADEB,?15,PRCADTW,?30,PRCAR
... S DA=PRCAIEN,DIK="^RC(341," D ^DIK ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
D NOW^%DTC S ^XTMP("PRCA399",$J,999,"C2ENDREMOVEOLDSTATEMENTDATES")=%
K PRCAT,PRCAXXX,PRCADEB,PRCADT,PRCADATE,PRCAIEN,PRCAR,PRCADTW,DA,DIK
Q
;
5 ;flip tx type 14 and negative amount to 13 and postive amount.
D NOW^%DTC S ^XTMP("PRCA399",$J,999,"D1BEGFLIPNEGTXCODE14")=%
S U="^",PRCAT=0,PRCAX=0,PRCAIEN=^XTMP("PRCA399",$J,1,0,0)-1 ;PRCAF1ST
F S PRCAIEN=$O(^PRCA(433,PRCAIEN)) Q:'PRCAIEN D
.S PRCATXN=$G(^PRCA(433,PRCAIEN,1)) Q:'PRCATXN I $P(PRCATXN,U,2)'=14!($P(PRCATXN,U,5)'<0) Q
.S ^XTMP("PRCA399",$J,7,2,PRCAIEN,1)=PRCATXN
.S $P(PRCATXN,U,2)=13,PRCAAMT=$P(PRCATXN,U,5),PRCAAMT=$TR(PRCAAMT,"-"),$P(PRCATXN,U,5)=PRCAAMT ;W:PRCAX !,?13,PRCATXN R:'PRCAX PRCAX:10
.S ^XTMP("PRCA399",$J,7,2,PRCAIEN,2)=PRCATXN
.S ^PRCA(433,PRCAIEN,1)=PRCATXN
D NOW^%DTC S ^XTMP("PRCA399",$J,999,"D2ENDFLIPNEGTXCODE14")=%
K PRCAT,PRCAX,PRCAIEN,PRCATXN,PRCAAMT
Q
;
10 ;set newly calc'd node 7 into file 430 when different (including missing 2nd half of node)
S U="^",(PRCABILL,PRCAT1,PRCAT2,PRCAT3,PRCAT4,PRCAX)=0
S ^XTMP("PRCA399",$J,999,"M1BEGNODE7FLIP")=%
F S PRCABILL=$O(^XTMP("PRCA399",$J,2,1,PRCADBTR,2,PRCABILL)) Q:'PRCABILL D
.Q:'$D(^XTMP("PRCA399",$J,1,1,PRCABILL,7))
.I ";16;42;"'[(";"_$P($G(^PRCA(430,PRCABILL,0)),U,8)_";") Q
.S PRCAND7=$G(^XTMP("PRCA399",$J,1,1,PRCABILL,7)),PRCAND7A=$G(^XTMP("PRCA399",$J,1,1,PRCABILL,8)) S PRCAT1=PRCAT1+1
.I PRCAND7'=PRCAND7A D Q
..S PRCAT4=PRCAT4+1
..F I=1:1:5,7:1:11 S $P(^PRCA(430,PRCABILL,7),U,I)=$P(PRCAND7A,U,I)
..S ^XTMP("PRCA399",$J,7,3,PRCABILL,"7A")=PRCAND7,^XTMP("PRCA399",$J,7,3,PRCABILL,"7B")=PRCAND7A
..I $P(PRCAND7,U,1,5)'=$P(PRCAND7A,U,1,5) S PRCAT2=PRCAT2+1
..I $P(PRCAND7,U,7,11)'=$P(PRCAND7A,U,7,11) S PRCAT3=PRCAT3+1
K PRCABILL,PRCAT1,PRCAT2,PRCAT3,PRCAT4,PRCAX,PRCAND7,PRCAND7A
Q
;
14 ;Modify transaction amt if leftover decrease or prepay
D NOW^%DTC S ^XTMP("PRCA399",$J,999,"G1BEGINTXADJUSTTX")=%
S U="^",PRCADEB=0
F S PRCADEB=$O(^XTMP("PRCA399",$J,2,1,PRCADEB)),PRCABILL=0 Q:'PRCADEB D
.F S PRCABILL=$O(^XTMP("PRCA399",$J,2,1,PRCADEB,4,PRCABILL)),PRCATX=0 Q:'PRCABILL D
..F S PRCATX=$O(^XTMP("PRCA399",$J,2,1,PRCADEB,4,PRCABILL,PRCATX)) Q:'PRCATX D
...S PRCARN=^XTMP("PRCA399",$J,2,1,PRCADEB,4,PRCABILL,PRCATX),PRCAADJ=$P(PRCARN,":")
...S PRCARO=^PRCA(433,PRCATX,1) ;W !!,PRCATX,?15,PRCARN,!,?15,PRCARO
...S $P(PRCARO,U,5)=$P(PRCARO,U,5)-PRCAADJ ;W !,?15,PRCARO
...S ^PRCA(433,PRCATX,1)=PRCARO,^XTMP("PRCA399",$J,999,"GADJTX",PRCATX)=PRCARO ;%%%%%%%%%%%%%%%%
D NOW^%DTC S ^XTMP("PRCA399",$J,999,"G2ENDTXADJUST")=%
K PRCADEB,PRCABILL,PRCATX,PRCARN,PRCARO,PRCAADJ,PRCASITE
Q
;
15 ;SET PREVIOUS EVENT FILE DATE (LAST STATEMENT) AND BALANCES INTO EVENT CAPTURE (341)
N PRCAEVT
D NOW^%DTC S ^XTMP("PRCA399",$J,999,"G3BEGINRC341STATEMENTSET")=%
S PRCASITE=$E($$SITE^RCMSITE(),1,3)
S U="^",PRCADB=0,PRCASTDT=$P(^XTMP("PRCA399",$J,2,1,0),U)+.000001,PRCADSET=(9999999.999999-PRCASTDT)\1
S PRCACTR=$P(^RC(341,0),U,3),$P(^RC(341,0),U,3)=$P(^RC(341,0),U,3)+300000,PRCAMAX=$P(^RC(341,0),U,3) L -^RC(341,0):0
F S PRCADB=$O(^XTMP("PRCA399",$J,2,8,PRCADB)),PRCAEVT=0 Q:'PRCADB D
.K PRCA341 S PRCAEBAL=^XTMP("PRCA399",$J,2,8,PRCADB,0)
.F I=1:1:3 S PRCAEVT=PRCAEVT+$P(PRCAEBAL,U,I)
.S:$D(^XTMP("PRCA399",$J,2,1,PRCADB,0)) $P(^XTMP("PRCA399",$J,2,1,PRCADB,0),U,4)=PRCAEVT
.;I $P(^XTMP("PRCA399",$J,2,1,PRCADB,0),U,4)<.01 S PRCAEBAL="0^0^0^0^0"
.I PRCAEVT["-" S ^XTMP("PRCA399",$J,9,7,PRCADB)=PRCAEVT
.S PRCACTR=PRCACTR+1 I PRCACTR>PRCAMAX D 151
.S PRCA341(0)=PRCASITE_"-"_PRCACTR_"-0^2^^^"_PRCADB_U_PRCASTDT_U_PRCASTDT_"^.5^"_PRCASITE_"^^1"
.S PRCA341(1)=$P(PRCAEBAL,U,1,5) ;S PRCA341(6)=$P(^XTMP("PRCA399",$J,2,1,0),U,4)
.D NOW^%DTC
.S PRCA341(4)="Patch PRCA*4.5*399 reset statement totals from recalculation processing^"_%
.M ^XTMP("PRCA399",$J,9,9,PRCADB,PRCACTR)=PRCA341
.D PREVDTCK
.M ^RC(341,PRCACTR)=PRCA341 S DA=PRCACTR,DIK="^RC(341," D IX^DIK ;%%%%%%%%%%%%%%%
D NOW^%DTC S ^XTMP("PRCA399",$J,999,"G4ENDRC341STATEMENTSET")=%
K PRCADSET,PRCAEBAL,PRCAMAX,PRCASTDT,PRCACTR,PRCA341,PRCADB,II
Q
;
PREVDTCK ;CHECK TO REMOVE SAME DATE ENTRY
S PRCAPDT=9999999.999999-PRCASTDT
F S PRCAPDTP=$O(^RC(341,"AD",PRCADB,2,PRCAPDT,0)) Q:'PRCAPDTP D
.S DA=PRCAPDTP,DIK="^RC(341," D ^DIK
Q
151 ;IN CASE NEW EVENT FILE SET FROM CALC EXCEED MAX
L +^RC(341,0):0
S PRCACTR=$P(^RC(341,0),U,3),$P(^RC(341,0),U,3)=$P(^RC(341,0),U,3)+100000,PRCAMAX=$P(^RC(341,0),U,3) L -^RC(341,0):0
Q
;****** CHECK NODE TOTAL TO TX DOLLLARS **********
16 ;SET NEW 2,3,8 NODE BACK INTO FILE 433
S PRCADEB=0,Z="/",XX=0,PRCAFIX=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 PRCAFIX=0
....F I=1:1:3 I +$P(PRCAT1,U,I)'=+$P(PRCAT2,U,I) S PRCAFIX=1 D Q
.....I PRCATYP=2 F I=2,3 S $P(^PRCA(433,PRCATX,2),U,I+5)=+$P(PRCAT2,U,I)
.....I ";3;8;"[PRCATYP F I=1:1:3 S $P(^PRCA(433,PRCATX,PRCATYP),U,I)=+$P(PRCAT2,U,I)
.....;I PRCAFIX S T=T+1 W !,PRCADEB,Z,PRCABILL,Z,PRCATX W ?30,PRCAT1,!,?30,PRCAT2 R:'XX XX
....Q
K PRCADB,PRCABILL,PRCATX,PRCATYP,PRCAT1,PRCAT2,PRCAFIX
Q
;
20 ;;LIST REMAINING DISCREPANCIES
F I=1:1:4 D MES^XPDUTL("")
D MES^XPDUTL("Debtor(s) discrepancy list after install:"),MES^XPDUTL("")
21 S U="^",PRCADB=0,$P(PRCASP," ",80)=""
D MES^XPDUTL($E(PRCASP,1,35)_"LST4 PRE + TBAL = BBAL DIFF") D MES^XPDUTL("")
F S PRCADB=$O(^XTMP("PRCA399",$J,9,1,PRCADB)) Q:'PRCADB D
. S PRCAR=^XTMP("PRCA399",$J,9,1,PRCADB)
. S PRCADPT=+$P(^RCD(340,PRCADB,0),U),PRCADBNM=$E($P(^DPT(PRCADPT,0),U),1,35)
. S PRCAW="" F I=1,2,3 S PRCAW=PRCAW_$J("$"_$FN($P(PRCAR,U,I),",",2),9)_" "_$E("+= ",I)_" "
. S PRCADIFF=$P(PRCAR,U,2)-$P(PRCAR,U)-$P(PRCAR,U,3),PRCAW=$P(PRCAR,U)+$P(PRCAR,U,2)-$P(PRCAR,U,3)
. S PRCAW=PRCAW_" ("_$J("$"_$FN(($P(PRCAR,U)+$P(PRCAR,U,2)-$P(PRCAR,U,3)),",",2),9)_")"
. D MES^XPDUTL($$LJ^XLFSTR(PRCADB,8," ")_$$LJ^XLFSTR(PRCADBNM,27," ")_$E($P(^DPT(PRCADPT,0),U,9),6,9)_" "_$P(PRCAR,U)_" + "_$P(PRCAR,U,2)_" = "_$P(PRCAR,U,3)_" "_PRCADIFF)
. D MES^XPDUTL("")
K PRCADB,PRCASP,PRCAR,PRCADPT,PRCADBNM,PRCADIFF,PRCAW
;
22 ;LIST ADJUSTED TRANSACTIONS
F I=1:1:4 D MES^XPDUTL("")
D MES^XPDUTL("Transactions modified during install to correct bill discrepancy:"),MES^XPDUTL("")
S PRCADB=0,$P(PRCASP," ",80)=""
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,1,PRCABILL)),PRCATX=0 Q:'PRCABILL D
..F S PRCATX=$O(^XTMP("PRCA399",$J,2,1,PRCADB,1,PRCABILL,2,PRCATX)) Q:'PRCATX D
...S PRCADPT=+$P(^RCD(340,PRCADB,0),U),PRCADBNM=$E($P(^DPT(PRCADPT,0),U),1,35),PRCASSN=$E($P(^DPT(PRCADPT,0),U,9),6,9)
...S PRCARN=^XTMP("PRCA399",$J,2,1,PRCADB,4,PRCABILL,PRCATX),PRCAADJ=$P(PRCARN,":"),PRCARO=$P(PRCARN,":",3)
...D MES^XPDUTL($E($P(^DPT(PRCADPT,0),U),1,35)_" "_PRCASSN_" "_$P(^PRCA(430,PRCABILL,0),U)_" TX#: "_PRCATX)
...D MES^XPDUTL("ADJ: "_PRCAADJ_$E(PRCASP,1,7)_"OLD TX: "_PRCARO)
...S $P(PRCARO,U,5)=$P(PRCARO,U,5)-PRCAADJ
...D MES^XPDUTL("ADJ: "_PRCAADJ_$E(PRCASP,1,7)_"ADJ TX: "_PRCARO) D MES^XPDUTL("")
K PRCADB,PRCABILL,PRCATX,PRCARN,PRCARO,PRCAADJ,PRCASP,PRCADBNM,PRCASSN,PRCADPT,PRCARO,PRCAADJ,PRCASP
;
23 ;LIST POTENTIAL PREPAYS
F I=1:1:4 D MES^XPDUTL("")
D MES^XPDUTL("List potential Prepays:"),MES^XPDUTL("")
S PRCADB=0
F S PRCADB=$O(^XTMP("PRCA399",$J,2,1,PRCADB)),PRCABILL=0 Q:'PRCADB D:$P(^XTMP("PRCA399",$J,2,1,PRCADB,0),U)
. F S PRCABILL=$O(^XTMP("PRCA399",$J,2,1,PRCADB,0,PRCABILL)),PRCATX=0 Q:'PRCABILL D:$P(^XTMP("PRCA399",$J,2,1,PRCADB,0,PRCABILL),U)
.. F S PRCATX=$O(^XTMP("PRCA399",$J,2,1,PRCADB,4,PRCABILL,PRCATX)) Q:'PRCATX D
...S PRCAR=^XTMP("PRCA399",$J,2,1,PRCADB,4,PRCABILL,PRCATX)
...S PRCABN=$P(^PRCA(430,PRCABILL,0),U),PRCADPT=+$P(^RCD(340,PRCADB,0),U),PRCADBNM=$P(^DPT(PRCADPT,0),U),PRCASSN=$E($P(^DPT(PRCADPT,0),U,9),6,9)
...S PRCATXR=^XTMP("PRCA399",$J,2,1,PRCADB,4,PRCABILL,PRCATX)
...D MES^XPDUTL($E(PRCADBNM,1,44)_" "_PRCASSN_" "_$P(^PRCA(430,PRCABILL,0),U)_" TX#: "_PRCATX)
...D MES^XPDUTL(" PREPAY $: "_$P(PRCATXR,":")_" "_$P(PRCATXR,":",3)) D MES^XPDUTL("")
K PRCADB,PRCABILL,PRCATX,PRCARN,PRCARO,PRCAADJ,PRCASSN,PRCATXR,PRCAR,PRCABN,PRCADPT,PRCADBNM,PRCASP
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCA399E 9926 printed Jul 11, 2026@01:35:30 Page 2
PRCA399E ;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.
EN ;Purge old statement dates from file ^RC(341
+1 QUIT
+2 DO NOW^%DTC
SET ^XTMP("PRCA399",$JOB,999,"C1RESET/STATEMENTDATES")=%
+3 SET U="^"
SET (PRCAT,PRCAX)=0
1 ;KILL 341 DATED NODES FOR PRCA399 FIX
+1 ;Delete statement runs past 5/31/21
SET PRCADEB=0
SET PRCADATE=6789468.884099
2 FOR
SET PRCADEB=$ORDER(^XTMP("PRCA399",$JOB,2,1,PRCADEB))
SET PRCADT=0
if 'PRCADEB
QUIT
Begin DoDot:1
+1 FOR
SET PRCADT=$ORDER(^RC(341,"AD",PRCADEB,2,PRCADT))
SET PRCAIEN=0
if 'PRCADT
QUIT
Begin DoDot:2
+2 IF PRCADATE'>PRCADT
QUIT
+3 FOR
SET PRCAIEN=$ORDER(^RC(341,"AD",PRCADEB,2,PRCADT,PRCAIEN))
if 'PRCAIEN
QUIT
Begin DoDot:3
+4 SET PRCAR=$GET(^RC(341,PRCAIEN,1))
+5 IF PRCAR["-"
SET ^XTMP("PRCA399",$JOB,7,5,341,PRCAIEN,1)=PRCAR
+6 MERGE ^XTMP("PRCA399",$JOB,7,1,341,PRCAIEN)=^RC(341,PRCAIEN)
SET PRCADTW=9999999.999999-PRCADT
+7 ;W !,PRCADEB,?15,PRCADTW,?30,PRCAR
+8 ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SET DA=PRCAIEN
SET DIK="^RC(341,"
DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+9 DO NOW^%DTC
SET ^XTMP("PRCA399",$JOB,999,"C2ENDREMOVEOLDSTATEMENTDATES")=%
+10 KILL PRCAT,PRCAXXX,PRCADEB,PRCADT,PRCADATE,PRCAIEN,PRCAR,PRCADTW,DA,DIK
+11 QUIT
+12 ;
5 ;flip tx type 14 and negative amount to 13 and postive amount.
+1 DO NOW^%DTC
SET ^XTMP("PRCA399",$JOB,999,"D1BEGFLIPNEGTXCODE14")=%
+2 ;PRCAF1ST
SET U="^"
SET PRCAT=0
SET PRCAX=0
SET PRCAIEN=^XTMP("PRCA399",$JOB,1,0,0)-1
+3 FOR
SET PRCAIEN=$ORDER(^PRCA(433,PRCAIEN))
if 'PRCAIEN
QUIT
Begin DoDot:1
+4 SET PRCATXN=$GET(^PRCA(433,PRCAIEN,1))
if 'PRCATXN
QUIT
IF $PIECE(PRCATXN,U,2)'=14!($PIECE(PRCATXN,U,5)'<0)
QUIT
+5 SET ^XTMP("PRCA399",$JOB,7,2,PRCAIEN,1)=PRCATXN
+6 ;W:PRCAX !,?13,PRCATXN R:'PRCAX PRCAX:10
SET $PIECE(PRCATXN,U,2)=13
SET PRCAAMT=$PIECE(PRCATXN,U,5)
SET PRCAAMT=$TRANSLATE(PRCAAMT,"-")
SET $PIECE(PRCATXN,U,5)=PRCAAMT
+7 SET ^XTMP("PRCA399",$JOB,7,2,PRCAIEN,2)=PRCATXN
+8 SET ^PRCA(433,PRCAIEN,1)=PRCATXN
End DoDot:1
+9 DO NOW^%DTC
SET ^XTMP("PRCA399",$JOB,999,"D2ENDFLIPNEGTXCODE14")=%
+10 KILL PRCAT,PRCAX,PRCAIEN,PRCATXN,PRCAAMT
+11 QUIT
+12 ;
10 ;set newly calc'd node 7 into file 430 when different (including missing 2nd half of node)
+1 SET U="^"
SET (PRCABILL,PRCAT1,PRCAT2,PRCAT3,PRCAT4,PRCAX)=0
+2 SET ^XTMP("PRCA399",$JOB,999,"M1BEGNODE7FLIP")=%
+3 FOR
SET PRCABILL=$ORDER(^XTMP("PRCA399",$JOB,2,1,PRCADBTR,2,PRCABILL))
if 'PRCABILL
QUIT
Begin DoDot:1
+4 if '$DATA(^XTMP("PRCA399",$JOB,1,1,PRCABILL,7))
QUIT
+5 IF ";16;42;"'[(";"_$PIECE($GET(^PRCA(430,PRCABILL,0)),U,8)_";")
QUIT
+6 SET PRCAND7=$GET(^XTMP("PRCA399",$JOB,1,1,PRCABILL,7))
SET PRCAND7A=$GET(^XTMP("PRCA399",$JOB,1,1,PRCABILL,8))
SET PRCAT1=PRCAT1+1
+7 IF PRCAND7'=PRCAND7A
Begin DoDot:2
+8 SET PRCAT4=PRCAT4+1
+9 FOR I=1:1:5,7:1:11
SET $PIECE(^PRCA(430,PRCABILL,7),U,I)=$PIECE(PRCAND7A,U,I)
+10 SET ^XTMP("PRCA399",$JOB,7,3,PRCABILL,"7A")=PRCAND7
SET ^XTMP("PRCA399",$JOB,7,3,PRCABILL,"7B")=PRCAND7A
+11 IF $PIECE(PRCAND7,U,1,5)'=$PIECE(PRCAND7A,U,1,5)
SET PRCAT2=PRCAT2+1
+12 IF $PIECE(PRCAND7,U,7,11)'=$PIECE(PRCAND7A,U,7,11)
SET PRCAT3=PRCAT3+1
End DoDot:2
QUIT
End DoDot:1
+13 KILL PRCABILL,PRCAT1,PRCAT2,PRCAT3,PRCAT4,PRCAX,PRCAND7,PRCAND7A
+14 QUIT
+15 ;
14 ;Modify transaction amt if leftover decrease or prepay
+1 DO NOW^%DTC
SET ^XTMP("PRCA399",$JOB,999,"G1BEGINTXADJUSTTX")=%
+2 SET U="^"
SET PRCADEB=0
+3 FOR
SET PRCADEB=$ORDER(^XTMP("PRCA399",$JOB,2,1,PRCADEB))
SET PRCABILL=0
if 'PRCADEB
QUIT
Begin DoDot:1
+4 FOR
SET PRCABILL=$ORDER(^XTMP("PRCA399",$JOB,2,1,PRCADEB,4,PRCABILL))
SET PRCATX=0
if 'PRCABILL
QUIT
Begin DoDot:2
+5 FOR
SET PRCATX=$ORDER(^XTMP("PRCA399",$JOB,2,1,PRCADEB,4,PRCABILL,PRCATX))
if 'PRCATX
QUIT
Begin DoDot:3
+6 SET PRCARN=^XTMP("PRCA399",$JOB,2,1,PRCADEB,4,PRCABILL,PRCATX)
SET PRCAADJ=$PIECE(PRCARN,":")
+7 ;W !!,PRCATX,?15,PRCARN,!,?15,PRCARO
SET PRCARO=^PRCA(433,PRCATX,1)
+8 ;W !,?15,PRCARO
SET $PIECE(PRCARO,U,5)=$PIECE(PRCARO,U,5)-PRCAADJ
+9 ;%%%%%%%%%%%%%%%%
SET ^PRCA(433,PRCATX,1)=PRCARO
SET ^XTMP("PRCA399",$JOB,999,"GADJTX",PRCATX)=PRCARO
End DoDot:3
End DoDot:2
End DoDot:1
+10 DO NOW^%DTC
SET ^XTMP("PRCA399",$JOB,999,"G2ENDTXADJUST")=%
+11 KILL PRCADEB,PRCABILL,PRCATX,PRCARN,PRCARO,PRCAADJ,PRCASITE
+12 QUIT
+13 ;
15 ;SET PREVIOUS EVENT FILE DATE (LAST STATEMENT) AND BALANCES INTO EVENT CAPTURE (341)
+1 NEW PRCAEVT
+2 DO NOW^%DTC
SET ^XTMP("PRCA399",$JOB,999,"G3BEGINRC341STATEMENTSET")=%
+3 SET PRCASITE=$EXTRACT($$SITE^RCMSITE(),1,3)
+4 SET U="^"
SET PRCADB=0
SET PRCASTDT=$PIECE(^XTMP("PRCA399",$JOB,2,1,0),U)+.000001
SET PRCADSET=(9999999.999999-PRCASTDT)\1
+5 SET PRCACTR=$PIECE(^RC(341,0),U,3)
SET $PIECE(^RC(341,0),U,3)=$PIECE(^RC(341,0),U,3)+300000
SET PRCAMAX=$PIECE(^RC(341,0),U,3)
LOCK -^RC(341,0):0
+6 FOR
SET PRCADB=$ORDER(^XTMP("PRCA399",$JOB,2,8,PRCADB))
SET PRCAEVT=0
if 'PRCADB
QUIT
Begin DoDot:1
+7 KILL PRCA341
SET PRCAEBAL=^XTMP("PRCA399",$JOB,2,8,PRCADB,0)
+8 FOR I=1:1:3
SET PRCAEVT=PRCAEVT+$PIECE(PRCAEBAL,U,I)
+9 if $DATA(^XTMP("PRCA399",$JOB,2,1,PRCADB,0))
SET $PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADB,0),U,4)=PRCAEVT
+10 ;I $P(^XTMP("PRCA399",$J,2,1,PRCADB,0),U,4)<.01 S PRCAEBAL="0^0^0^0^0"
+11 IF PRCAEVT["-"
SET ^XTMP("PRCA399",$JOB,9,7,PRCADB)=PRCAEVT
+12 SET PRCACTR=PRCACTR+1
IF PRCACTR>PRCAMAX
DO 151
+13 SET PRCA341(0)=PRCASITE_"-"_PRCACTR_"-0^2^^^"_PRCADB_U_PRCASTDT_U_PRCASTDT_"^.5^"_PRCASITE_"^^1"
+14 ;S PRCA341(6)=$P(^XTMP("PRCA399",$J,2,1,0),U,4)
SET PRCA341(1)=$PIECE(PRCAEBAL,U,1,5)
+15 DO NOW^%DTC
+16 SET PRCA341(4)="Patch PRCA*4.5*399 reset statement totals from recalculation processing^"_%
+17 MERGE ^XTMP("PRCA399",$JOB,9,9,PRCADB,PRCACTR)=PRCA341
+18 DO PREVDTCK
+19 ;%%%%%%%%%%%%%%%
MERGE ^RC(341,PRCACTR)=PRCA341
SET DA=PRCACTR
SET DIK="^RC(341,"
DO IX^DIK
End DoDot:1
+20 DO NOW^%DTC
SET ^XTMP("PRCA399",$JOB,999,"G4ENDRC341STATEMENTSET")=%
+21 KILL PRCADSET,PRCAEBAL,PRCAMAX,PRCASTDT,PRCACTR,PRCA341,PRCADB,II
+22 QUIT
+23 ;
PREVDTCK ;CHECK TO REMOVE SAME DATE ENTRY
+1 SET PRCAPDT=9999999.999999-PRCASTDT
+2 FOR
SET PRCAPDTP=$ORDER(^RC(341,"AD",PRCADB,2,PRCAPDT,0))
if 'PRCAPDTP
QUIT
Begin DoDot:1
+3 SET DA=PRCAPDTP
SET DIK="^RC(341,"
DO ^DIK
End DoDot:1
+4 QUIT
151 ;IN CASE NEW EVENT FILE SET FROM CALC EXCEED MAX
+1 LOCK +^RC(341,0):0
+2 SET PRCACTR=$PIECE(^RC(341,0),U,3)
SET $PIECE(^RC(341,0),U,3)=$PIECE(^RC(341,0),U,3)+100000
SET PRCAMAX=$PIECE(^RC(341,0),U,3)
LOCK -^RC(341,0):0
+3 QUIT
+4 ;****** CHECK NODE TOTAL TO TX DOLLLARS **********
16 ;SET NEW 2,3,8 NODE BACK INTO FILE 433
+1 SET PRCADEB=0
SET Z="/"
SET XX=0
SET PRCAFIX=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 PRCAFIX=0
+12 FOR I=1:1:3
IF +$PIECE(PRCAT1,U,I)'=+$PIECE(PRCAT2,U,I)
SET PRCAFIX=1
Begin DoDot:5
+13 IF PRCATYP=2
FOR I=2,3
SET $PIECE(^PRCA(433,PRCATX,2),U,I+5)=+$PIECE(PRCAT2,U,I)
+14 IF ";3;8;"[PRCATYP
FOR I=1:1:3
SET $PIECE(^PRCA(433,PRCATX,PRCATYP),U,I)=+$PIECE(PRCAT2,U,I)
+15 ;I PRCAFIX S T=T+1 W !,PRCADEB,Z,PRCABILL,Z,PRCATX W ?30,PRCAT1,!,?30,PRCAT2 R:'XX XX
End DoDot:5
QUIT
+16 QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+17 KILL PRCADB,PRCABILL,PRCATX,PRCATYP,PRCAT1,PRCAT2,PRCAFIX
+18 QUIT
+19 ;
20 ;;LIST REMAINING DISCREPANCIES
+1 FOR I=1:1:4
DO MES^XPDUTL("")
+2 DO MES^XPDUTL("Debtor(s) discrepancy list after install:")
DO MES^XPDUTL("")
21 SET U="^"
SET PRCADB=0
SET $PIECE(PRCASP," ",80)=""
+1 DO MES^XPDUTL($EXTRACT(PRCASP,1,35)_"LST4 PRE + TBAL = BBAL DIFF")
DO MES^XPDUTL("")
+2 FOR
SET PRCADB=$ORDER(^XTMP("PRCA399",$JOB,9,1,PRCADB))
if 'PRCADB
QUIT
Begin DoDot:1
+3 SET PRCAR=^XTMP("PRCA399",$JOB,9,1,PRCADB)
+4 SET PRCADPT=+$PIECE(^RCD(340,PRCADB,0),U)
SET PRCADBNM=$EXTRACT($PIECE(^DPT(PRCADPT,0),U),1,35)
+5 SET PRCAW=""
FOR I=1,2,3
SET PRCAW=PRCAW_$JUSTIFY("$"_$FNUMBER($PIECE(PRCAR,U,I),",",2),9)_" "_$EXTRACT("+= ",I)_" "
+6 SET PRCADIFF=$PIECE(PRCAR,U,2)-$PIECE(PRCAR,U)-$PIECE(PRCAR,U,3)
SET PRCAW=$PIECE(PRCAR,U)+$PIECE(PRCAR,U,2)-$PIECE(PRCAR,U,3)
+7 SET PRCAW=PRCAW_" ("_$JUSTIFY("$"_$FNUMBER(($PIECE(PRCAR,U)+$PIECE(PRCAR,U,2)-$PIECE(PRCAR,U,3)),",",2),9)_")"
+8 DO MES^XPDUTL($$LJ^XLFSTR(PRCADB,8," ")_$$LJ^XLFSTR(PRCADBNM,27," ")_$EXTRACT($PIECE(^DPT(PRCADPT,0),U,9),6,9)_" "_$PIECE(PRCAR,U)_" + "_$PIECE(PRCAR,U,2)_" = "_$PIECE(PRCAR,U,3)_" "_PRCADIFF)
+9 DO MES^XPDUTL("")
End DoDot:1
+10 KILL PRCADB,PRCASP,PRCAR,PRCADPT,PRCADBNM,PRCADIFF,PRCAW
+11 ;
22 ;LIST ADJUSTED TRANSACTIONS
+1 FOR I=1:1:4
DO MES^XPDUTL("")
+2 DO MES^XPDUTL("Transactions modified during install to correct bill discrepancy:")
DO MES^XPDUTL("")
+3 SET PRCADB=0
SET $PIECE(PRCASP," ",80)=""
+4 FOR
SET PRCADB=$ORDER(^XTMP("PRCA399",$JOB,2,1,PRCADB))
SET PRCABILL=0
if 'PRCADB
QUIT
Begin DoDot:1
+5 FOR
SET PRCABILL=$ORDER(^XTMP("PRCA399",$JOB,2,1,PRCADB,1,PRCABILL))
SET PRCATX=0
if 'PRCABILL
QUIT
Begin DoDot:2
+6 FOR
SET PRCATX=$ORDER(^XTMP("PRCA399",$JOB,2,1,PRCADB,1,PRCABILL,2,PRCATX))
if 'PRCATX
QUIT
Begin DoDot:3
+7 SET PRCADPT=+$PIECE(^RCD(340,PRCADB,0),U)
SET PRCADBNM=$EXTRACT($PIECE(^DPT(PRCADPT,0),U),1,35)
SET PRCASSN=$EXTRACT($PIECE(^DPT(PRCADPT,0),U,9),6,9)
+8 SET PRCARN=^XTMP("PRCA399",$JOB,2,1,PRCADB,4,PRCABILL,PRCATX)
SET PRCAADJ=$PIECE(PRCARN,":")
SET PRCARO=$PIECE(PRCARN,":",3)
+9 DO MES^XPDUTL($EXTRACT($PIECE(^DPT(PRCADPT,0),U),1,35)_" "_PRCASSN_" "_$PIECE(^PRCA(430,PRCABILL,0),U)_" TX#: "_PRCATX)
+10 DO MES^XPDUTL("ADJ: "_PRCAADJ_$EXTRACT(PRCASP,1,7)_"OLD TX: "_PRCARO)
+11 SET $PIECE(PRCARO,U,5)=$PIECE(PRCARO,U,5)-PRCAADJ
+12 DO MES^XPDUTL("ADJ: "_PRCAADJ_$EXTRACT(PRCASP,1,7)_"ADJ TX: "_PRCARO)
DO MES^XPDUTL("")
End DoDot:3
End DoDot:2
End DoDot:1
+13 KILL PRCADB,PRCABILL,PRCATX,PRCARN,PRCARO,PRCAADJ,PRCASP,PRCADBNM,PRCASSN,PRCADPT,PRCARO,PRCAADJ,PRCASP
+14 ;
23 ;LIST POTENTIAL PREPAYS
+1 FOR I=1:1:4
DO MES^XPDUTL("")
+2 DO MES^XPDUTL("List potential Prepays:")
DO MES^XPDUTL("")
+3 SET PRCADB=0
+4 FOR
SET PRCADB=$ORDER(^XTMP("PRCA399",$JOB,2,1,PRCADB))
SET PRCABILL=0
if 'PRCADB
QUIT
if $PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADB,0),U)
Begin DoDot:1
+5 FOR
SET PRCABILL=$ORDER(^XTMP("PRCA399",$JOB,2,1,PRCADB,0,PRCABILL))
SET PRCATX=0
if 'PRCABILL
QUIT
if $PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADB,0,PRCABILL),U)
Begin DoDot:2
+6 FOR
SET PRCATX=$ORDER(^XTMP("PRCA399",$JOB,2,1,PRCADB,4,PRCABILL,PRCATX))
if 'PRCATX
QUIT
Begin DoDot:3
+7 SET PRCAR=^XTMP("PRCA399",$JOB,2,1,PRCADB,4,PRCABILL,PRCATX)
+8 SET PRCABN=$PIECE(^PRCA(430,PRCABILL,0),U)
SET PRCADPT=+$PIECE(^RCD(340,PRCADB,0),U)
SET PRCADBNM=$PIECE(^DPT(PRCADPT,0),U)
SET PRCASSN=$EXTRACT($PIECE(^DPT(PRCADPT,0),U,9),6,9)
+9 SET PRCATXR=^XTMP("PRCA399",$JOB,2,1,PRCADB,4,PRCABILL,PRCATX)
+10 DO MES^XPDUTL($EXTRACT(PRCADBNM,1,44)_" "_PRCASSN_" "_$PIECE(^PRCA(430,PRCABILL,0),U)_" TX#: "_PRCATX)
+11 DO MES^XPDUTL(" PREPAY $: "_$PIECE(PRCATXR,":")_" "_$PIECE(PRCATXR,":",3))
DO MES^XPDUTL("")
End DoDot:3
End DoDot:2
End DoDot:1
+12 KILL PRCADB,PRCABILL,PRCATX,PRCARN,PRCARO,PRCAADJ,PRCASSN,PRCATXR,PRCAR,PRCABN,PRCADPT,PRCADBNM,PRCASP
+13 QUIT
+14 ;
