PRCECALL ;WISC/LDB/CLH-RECALC FOR ALL OBLIGATIONS ;1/15/93 2:33 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
N PRC,PODA,DIC,DA,TRNODE,PRCF,X,I,RQUIT,AMT,AUAMT,AUBAL,AUDA,BAL,BAL1,DRAMT,DRAUMT,FCPAMT,LQAMT,PO,Y
S PRCF("X")="AS" D ^PRCFSITE Q:'PRC("SITE")
S DA=0 F D Q:RQUIT
. F I=1:1:100 D
.. S DA=$O(^PRC(442,DA)) S:'DA RQUIT=1 Q:'DA I $D(^PRC(442,DA,0)) D
... S PODA=DA,PODA(1)=$P(Y,U,2),PODA(2)=$P(Y(0),U,3),PODA(0)=Y(0)
... I (+PODA(1)'=PRC("SITE")) Q
... Q:'$P(PODA(0),U,12) S PO=$P(PODA(0),U,12) D NODE^PRCS58OB(PO,.TRNODE) Q:$P($G(TRNODE(0)),U,4)'=1 S PO=PODA(1)
... Q:'$D(^PRC(424,"AF",PO))
... D RECAL
... Q
.. Q
. W "."
. Q
Q
RECAL ;Recalculate totals in file 424
;Update obligation estimated balance
S AUDA="",FCPAMT=0 F S AUDA=$O(^PRC(424,"AF",PO,AUDA)) Q:'AUDA I $D(^PRC(424,AUDA,0)) S (AUAMT,AUBAL)=0 D
.S FCPAMT=$P(^PRC(424,AUDA,0),U,6)+FCPAMT
D BALOB^PRCH58(PODA,FCPAMT)
;Update obligation Fiscal liquidation balance
S AUDA="",LQAMT=0 F S AUDA=$O(^PRC(424,"AG",PO,AUDA)) Q:'AUDA I $D(^PRC(424,AUDA,0)) D
.S LQAMT=$P(^PRC(424,AUDA,0),U,4)+LQAMT
D BAL1^PRCH58OB(PODA,LQAMT)
;Update authorizations balances
S (DRAMT,AUDA)=0 F S AUDA=$O(^PRC(424,"AD",PO,AUDA)) Q:'AUDA I $D(^PRC(424,AUDA,0)),$P(^(0),U,3)="AU" D
. S (DRPAMT,DRAUMT,DA)=0 F S DA=$O(^PRC(424.1,"C",AUDA,DA)) Q:'DA I $D(^PRC(424.1,DA,0)) D
..S:$P(^PRC(424.1,DA,0),U,11)="P" DRPAMT=$P(^PRC(424.1,DA,0),U,3)+DRPAMT S:$P(^(0),U,11)["A" DRAUMT=DRAUMT+$P(^(0),U,3)
. S $P(^PRC(424,AUDA,0),U,12)=$S((+$G(DRAUMT)>0):DRAUMT,(+$G(DRAMT)>0):DRAMT,1:+$P($G(^PRC(424,AUDA,0)),U,13))
. S $P(^PRC(424,AUDA,0),U,5)=$S(+$G(DRPAMT)>0:$P(^PRC(424,AUDA,0),U,12)-DRPAMT,1:$P(^PRC(424,AUDA,0),U,12)),AUAMT(AUDA)=$P(^(0),U)_"^"_$P(^(0),U,12)_"^"_$P(^(0),U,5)_"^"_-DRAMT,AUAMT=AUAMT+DRAMT,AUBAL=AUBAL+$P(^(0),U,5)
;Update obligation balance
S (AMT,AUDA)=0 F S AUDA=$O(^PRC(424,"AD",PO,AUDA)) Q:'AUDA I $D(^PRC(424,AUDA,0)) D
. S AMT=$P(^(0),U,12)+AMT
S BAL1=AMT D BALAU^PRCH58(PODA,BAL1)
S BAL=$$BAL^PRCH58(PODA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCECALL 2135 printed Sep 23, 2025@19:37:25 Page 2
PRCECALL ;WISC/LDB/CLH-RECALC FOR ALL OBLIGATIONS ;1/15/93 2:33 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 NEW PRC,PODA,DIC,DA,TRNODE,PRCF,X,I,RQUIT,AMT,AUAMT,AUBAL,AUDA,BAL,BAL1,DRAMT,DRAUMT,FCPAMT,LQAMT,PO,Y
+3 SET PRCF("X")="AS"
DO ^PRCFSITE
if 'PRC("SITE")
QUIT
+4 SET DA=0
FOR
Begin DoDot:1
+5 FOR I=1:1:100
Begin DoDot:2
+6 SET DA=$ORDER(^PRC(442,DA))
if 'DA
SET RQUIT=1
if 'DA
QUIT
IF $DATA(^PRC(442,DA,0))
Begin DoDot:3
+7 SET PODA=DA
SET PODA(1)=$PIECE(Y,U,2)
SET PODA(2)=$PIECE(Y(0),U,3)
SET PODA(0)=Y(0)
+8 IF (+PODA(1)'=PRC("SITE"))
QUIT
+9 if '$PIECE(PODA(0),U,12)
QUIT
SET PO=$PIECE(PODA(0),U,12)
DO NODE^PRCS58OB(PO,.TRNODE)
if $PIECE($GET(TRNODE(0)),U,4)'=1
QUIT
SET PO=PODA(1)
+10 if '$DATA(^PRC(424,"AF",PO))
QUIT
+11 DO RECAL
+12 QUIT
End DoDot:3
+13 QUIT
End DoDot:2
+14 WRITE "."
+15 QUIT
End DoDot:1
if RQUIT
QUIT
+16 QUIT
RECAL ;Recalculate totals in file 424
+1 ;Update obligation estimated balance
+2 SET AUDA=""
SET FCPAMT=0
FOR
SET AUDA=$ORDER(^PRC(424,"AF",PO,AUDA))
if 'AUDA
QUIT
IF $DATA(^PRC(424,AUDA,0))
SET (AUAMT,AUBAL)=0
Begin DoDot:1
+3 SET FCPAMT=$PIECE(^PRC(424,AUDA,0),U,6)+FCPAMT
End DoDot:1
+4 DO BALOB^PRCH58(PODA,FCPAMT)
+5 ;Update obligation Fiscal liquidation balance
+6 SET AUDA=""
SET LQAMT=0
FOR
SET AUDA=$ORDER(^PRC(424,"AG",PO,AUDA))
if 'AUDA
QUIT
IF $DATA(^PRC(424,AUDA,0))
Begin DoDot:1
+7 SET LQAMT=$PIECE(^PRC(424,AUDA,0),U,4)+LQAMT
End DoDot:1
+8 DO BAL1^PRCH58OB(PODA,LQAMT)
+9 ;Update authorizations balances
+10 SET (DRAMT,AUDA)=0
FOR
SET AUDA=$ORDER(^PRC(424,"AD",PO,AUDA))
if 'AUDA
QUIT
IF $DATA(^PRC(424,AUDA,0))
IF $PIECE(^(0),U,3)="AU"
Begin DoDot:1
+11 SET (DRPAMT,DRAUMT,DA)=0
FOR
SET DA=$ORDER(^PRC(424.1,"C",AUDA,DA))
if 'DA
QUIT
IF $DATA(^PRC(424.1,DA,0))
Begin DoDot:2
+12 if $PIECE(^PRC(424.1,DA,0),U,11)="P"
SET DRPAMT=$PIECE(^PRC(424.1,DA,0),U,3)+DRPAMT
if $PIECE(^(0),U,11)["A"
SET DRAUMT=DRAUMT+$PIECE(^(0),U,3)
End DoDot:2
+13 SET $PIECE(^PRC(424,AUDA,0),U,12)=$SELECT((+$GET(DRAUMT)>0):DRAUMT,(+$GET(DRAMT)>0):DRAMT,1:+$PIECE($GET(^PRC(424,AUDA,0)),U,13))
+14 SET $PIECE(^PRC(424,AUDA,0),U,5)=$SELECT(+$GET(DRPAMT)>0:$PIECE(^PRC(424,AUDA,0),U,12)-DRPAMT,1:$PIECE(^PRC(424,AUDA,0),U,12))
SET AUAMT(AUDA)=$PIECE(^(0),U)_"^"_$PIECE(^(0),U,12)_"^"_$PIECE(^(0),U,5)_"^"_-DRAMT
SET AUAMT=AUAMT+DRAMT
SET AUBAL=AUBAL+$PIECE(^(0),U,5)
End DoDot:1
+15 ;Update obligation balance
+16 SET (AMT,AUDA)=0
FOR
SET AUDA=$ORDER(^PRC(424,"AD",PO,AUDA))
if 'AUDA
QUIT
IF $DATA(^PRC(424,AUDA,0))
Begin DoDot:1
+17 SET AMT=$PIECE(^(0),U,12)+AMT
End DoDot:1
+18 SET BAL1=AMT
DO BALAU^PRCH58(PODA,BAL1)
+19 SET BAL=$$BAL^PRCH58(PODA)
+20 QUIT
