PRCECAL ;WISC/LDB/BGJ-RECALCULATE AUTHORIZATION BALANCES ; 03 Feb 93 10:29 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
FISCAL ;Entry point for any obligation's authorizations
D EXIT S PRCF("X")="AS" D ^PRCFSITE
I '$D(PRC("SITE")) D EXIT Q
D OBLK^PRCH58OB(.PODA)
I '$G(PODA) D EXIT Q
I (+PODA(1)'=PRC("SITE")) D EXIT Q
G:'$P(PODA(0),U,12) EXIT S PO=$P(PODA(0),U,12) D NODE^PRCS58OB(PO,.TRNODE) G:$P($G(TRNODE(0)),U,4)'=1 EXIT S PO=PODA(1)
Q:'$D(^PRC(424,"AF",PO))
D RECALC
Q
;
FCP ;Entry point for Fund Control Point for obligations within the FCP
D EXIT,EN3^PRCSUT I '$D(PRC("CP"))!'$D(PRC("SITE")) D EXIT Q
D OBLK^PRCH58OB(.PODA)
I '$G(PODA) D EXIT Q
I (+PODA(0)'=PRC("SITE"))!(+PODA(2)'=+PRC("CP"))!('$P(PODA(0),U,12)) D EXIT Q
S PO=$P(PODA(0),U,12) D NODE^PRCS58OB(PO,.TRNODE)
S PO=PODA(1) I '$D(^PRC(424,"AF",PO)) D EXIT Q
;
RECALC ;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)
;S AMT=+$G(BAL)-LQAMT D BAL1^PRCH58OB(PODA,AMT)
;Update authorizations balances
S (DRAMT,AUDA,DRAUMT)=0 F S AUDA=$O(^PRC(424,"AD",PO,AUDA)) Q:'AUDA I $D(^PRC(424,AUDA,0)),$P(^(0),U,3)="AU" S DRAUMT=$P(^(0),U,12) D
. S (DRPAMT,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)=$P(^PRC(424,AUDA,0),U,12)+$G(DRPAMT),AUAMT(AUDA)=$P(^(0),U)_"^"_$P(^(0),U,12)_"^"_$P(^(0),U,5)_"^"_-DRPAMT,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
;Print obligation, liquidation and authorization balances
S BAL1=AMT D BALAU^PRCH58(PODA,BAL1)
S BAL=$$BAL^PRCH58(PODA)
W @IOF,!,?25,PO," ","OBLIGATION BALANCES"
W !!," OBLIGATION AMOUNT: $",$$LBF1^PRCFU($FN(+BAL,",P",2),14)
W ?37," SERVICE BALANCE: $",$$LBF1^PRCFU($FN(+BAL-$P(BAL,U,3),",P",2),14)
W !,"LIQUIDATION BALANCE: $",$$LBF1^PRCFU($FN($P(BAL,U)-$P(BAL,U,2),",P",2),14)
W ?37,"TOTAL LIQUIDATIONS: $",$$LBF1^PRCFU($FN($P(BAL,U,2),",P",2),14)
W !!,"AUTHORIZATION BALANCE(S): " S AUDA=0
W !!,"AUTHORIZATION #",?21,"AMOUNT",?37,"BALANCE",?54,"PAYMENT"
F S AUDA=$O(AUAMT(AUDA)) Q:'AUDA D Q:X="^"
.S DIR(0)="E" I ((IOSL-$Y)<4) D ^DIR Q:X="^" W @IOF
.W !,$P(AUAMT(AUDA),U)
.W ?17,"$",$$LBF1^PRCFU($FN($P(AUAMT(AUDA),U,2),",P",2),14)
.W ?34,"$",$$LBF1^PRCFU($FN($P(AUAMT(AUDA),U,3),",P",2),14)
.W ?51,"$",$$LBF1^PRCFU($FN($P(AUAMT(AUDA),U,4),",P",2),14)
G:X="^" EXIT I $Y+4>IOSL D ^DIR Q:X="^" W @IOF
W !,?17,"______________",?34,"______________",?51,"______________" W !?17,"$",$$LBF1^PRCFU($FN(AMT,",P",2),14),?34,"$",$$LBF1^PRCFU($FN(AUBAL,",P",2),14),?51,"$",$$LBF1^PRCFU($FN(AMT-AUBAL,",P",2),14)
EXIT K AMT,AUAMT,AUBAL,AUDA,BAL,BAL1,DA,DIC,DIR,DRAMT,DRAUMT,FCPAMT,LQAMT,PO,PODA,PRC,PRCF,X,Y,TRNODE,PRCF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCECAL 3535 printed Jan 18, 2025@03:02:32 Page 2
PRCECAL ;WISC/LDB/BGJ-RECALCULATE AUTHORIZATION BALANCES ; 03 Feb 93 10:29 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
FISCAL ;Entry point for any obligation's authorizations
+1 DO EXIT
SET PRCF("X")="AS"
DO ^PRCFSITE
+2 IF '$DATA(PRC("SITE"))
DO EXIT
QUIT
+3 DO OBLK^PRCH58OB(.PODA)
+4 IF '$GET(PODA)
DO EXIT
QUIT
+5 IF (+PODA(1)'=PRC("SITE"))
DO EXIT
QUIT
+6 if '$PIECE(PODA(0),U,12)
GOTO EXIT
SET PO=$PIECE(PODA(0),U,12)
DO NODE^PRCS58OB(PO,.TRNODE)
if $PIECE($GET(TRNODE(0)),U,4)'=1
GOTO EXIT
SET PO=PODA(1)
+7 if '$DATA(^PRC(424,"AF",PO))
QUIT
+8 DO RECALC
+9 QUIT
+10 ;
FCP ;Entry point for Fund Control Point for obligations within the FCP
+1 DO EXIT
DO EN3^PRCSUT
IF '$DATA(PRC("CP"))!'$DATA(PRC("SITE"))
DO EXIT
QUIT
+2 DO OBLK^PRCH58OB(.PODA)
+3 IF '$GET(PODA)
DO EXIT
QUIT
+4 IF (+PODA(0)'=PRC("SITE"))!(+PODA(2)'=+PRC("CP"))!('$PIECE(PODA(0),U,12))
DO EXIT
QUIT
+5 SET PO=$PIECE(PODA(0),U,12)
DO NODE^PRCS58OB(PO,.TRNODE)
+6 SET PO=PODA(1)
IF '$DATA(^PRC(424,"AF",PO))
DO EXIT
QUIT
+7 ;
RECALC ;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 ;S AMT=+$G(BAL)-LQAMT D BAL1^PRCH58OB(PODA,AMT)
+10 ;Update authorizations balances
+11 SET (DRAMT,AUDA,DRAUMT)=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"
SET DRAUMT=$PIECE(^(0),U,12)
Begin DoDot:1
+12 SET (DRPAMT,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
+13 ;S:$P(^(0),U,11)["A" DRAUMT=DRAUMT+$P(^(0),U,3)
if $PIECE(^PRC(424.1,DA,0),U,11)="P"
SET DRPAMT=$PIECE(^PRC(424.1,DA,0),U,3)+DRPAMT
End DoDot:2
+14 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))
+15 SET $PIECE(^PRC(424,AUDA,0),U,5)=$PIECE(^PRC(424,AUDA,0),U,12)+$GET(DRPAMT)
SET AUAMT(AUDA)=$PIECE(^(0),U)_"^"_$PIECE(^(0),U,12)_"^"_$PIECE(^(0),U,5)_"^"_-DRPAMT
SET AUAMT=AUAMT+DRAMT
SET AUBAL=AUBAL+$PIECE(^(0),U,5)
End DoDot:1
+16 ;Update obligation balance
+17 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
+18 SET AMT=$PIECE(^(0),U,12)+AMT
End DoDot:1
+19 ;Print obligation, liquidation and authorization balances
+20 SET BAL1=AMT
DO BALAU^PRCH58(PODA,BAL1)
+21 SET BAL=$$BAL^PRCH58(PODA)
+22 WRITE @IOF,!,?25,PO," ","OBLIGATION BALANCES"
+23 WRITE !!," OBLIGATION AMOUNT: $",$$LBF1^PRCFU($FNUMBER(+BAL,",P",2),14)
+24 WRITE ?37," SERVICE BALANCE: $",$$LBF1^PRCFU($FNUMBER(+BAL-$PIECE(BAL,U,3),",P",2),14)
+25 WRITE !,"LIQUIDATION BALANCE: $",$$LBF1^PRCFU($FNUMBER($PIECE(BAL,U)-$PIECE(BAL,U,2),",P",2),14)
+26 WRITE ?37,"TOTAL LIQUIDATIONS: $",$$LBF1^PRCFU($FNUMBER($PIECE(BAL,U,2),",P",2),14)
+27 WRITE !!,"AUTHORIZATION BALANCE(S): "
SET AUDA=0
+28 WRITE !!,"AUTHORIZATION #",?21,"AMOUNT",?37,"BALANCE",?54,"PAYMENT"
+29 FOR
SET AUDA=$ORDER(AUAMT(AUDA))
if 'AUDA
QUIT
Begin DoDot:1
+30 SET DIR(0)="E"
IF ((IOSL-$Y)<4)
DO ^DIR
if X="^"
QUIT
WRITE @IOF
+31 WRITE !,$PIECE(AUAMT(AUDA),U)
+32 WRITE ?17,"$",$$LBF1^PRCFU($FNUMBER($PIECE(AUAMT(AUDA),U,2),",P",2),14)
+33 WRITE ?34,"$",$$LBF1^PRCFU($FNUMBER($PIECE(AUAMT(AUDA),U,3),",P",2),14)
+34 WRITE ?51,"$",$$LBF1^PRCFU($FNUMBER($PIECE(AUAMT(AUDA),U,4),",P",2),14)
End DoDot:1
if X="^"
QUIT
+35 if X="^"
GOTO EXIT
IF $Y+4>IOSL
DO ^DIR
if X="^"
QUIT
WRITE @IOF
+36 WRITE !,?17,"______________",?34,"______________",?51,"______________"
WRITE !?17,"$",$$LBF1^PRCFU($FNUMBER(AMT,",P",2),14),?34,"$",$$LBF1^PRCFU($FNUMBER(AUBAL,",P",2),14),?51,"$",$$LBF1^PRCFU($FNUMBER(AMT-AUBAL,",P",2),14)
EXIT KILL AMT,AUAMT,AUBAL,AUDA,BAL,BAL1,DA,DIC,DIR,DRAMT,DRAUMT,FCPAMT,LQAMT,PO,PODA,PRC,PRCF,X,Y,TRNODE,PRCF
+1 QUIT
