PRCEBAL ;WISC/LDB/BGJ-DISPLAY BALANCES ;8/7/92 11:31 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
START ;Display obligation,liquidation and authorization balances
FISCAL D EXIT S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) D OBLK^PRCH58OB(.PODA)
I '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)
D DISP,EXIT Q
FCP D EXIT,EN3^PRCSUT I '$D(PRC("CP"))!'$D(PRC("SITE")) D EXIT Q
D OBLK^PRCH58OB(.PODA,+PRC("CP"))
Q:'PODA 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)
DISP S BAL=$$BAL^PRCH58(PODA)
S (AMT,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 AMT=$P(^PRC(424,AUDA,0),U,12)+AMT,AUAMT(AUDA)=$P(^(0),U)_U_$P(^(0),U,12)_U_$P(^(0),U,5)
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(+BAL-$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
S AUDA=0 F S AUDA=$O(AUAMT(AUDA)) Q:'AUDA I $D(^PRC(424,AUDA,0)) D
.W !,$P(AUAMT(AUDA),U)
.W ?16,"AMOUNT: $",$$LBF1^PRCFU($FN($P(AUAMT(AUDA),U,2),",P",2),14)
.W ?48,"BALANCE: $",$$LBF1^PRCFU($FN($P(AUAMT(AUDA),U,3),",P",2),14)
W !!," AUTHORIZATION TOTAL: $",$$LBF1^PRCFU($FN(AMT,",P",2),14)
EXIT K AMT,AUAMT,AUDA,BAL,BAL1,DA,DIC,DRAMT,FCPAMT,LQAMT,PO,PODA,PRC,PRCF,Y,TRNODE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCEBAL 1767 printed Oct 16, 2024@18:02:04 Page 2
PRCEBAL ;WISC/LDB/BGJ-DISPLAY BALANCES ;8/7/92 11:31 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
START ;Display obligation,liquidation and authorization balances
FISCAL DO EXIT
SET PRCF("X")="S"
DO ^PRCFSITE
if '$DATA(PRC("SITE"))
QUIT
DO OBLK^PRCH58OB(.PODA)
+1 IF 'PODA
DO EXIT
QUIT
+2 IF (+PODA(1)'=PRC("SITE"))
DO EXIT
QUIT
+3 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)
+4 DO DISP
DO EXIT
QUIT
FCP DO EXIT
DO EN3^PRCSUT
IF '$DATA(PRC("CP"))!'$DATA(PRC("SITE"))
DO EXIT
QUIT
+1 DO OBLK^PRCH58OB(.PODA,+PRC("CP"))
+2 if 'PODA
QUIT
IF (+PODA(0)'=PRC("SITE"))!(+PODA(2)'=+PRC("CP"))!('$PIECE(PODA(0),U,12))
DO EXIT
QUIT
+3 SET PO=$PIECE(PODA(0),U,12)
DO NODE^PRCS58OB(PO,.TRNODE)
+4 SET PO=PODA(1)
DISP SET BAL=$$BAL^PRCH58(PODA)
+1 SET (AMT,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
+2 SET AMT=$PIECE(^PRC(424,AUDA,0),U,12)+AMT
SET AUAMT(AUDA)=$PIECE(^(0),U)_U_$PIECE(^(0),U,12)_U_$PIECE(^(0),U,5)
End DoDot:1
+3 WRITE @IOF,?25,PO," OBLIGATION BALANCES"
+4 WRITE !!," OBLIGATION AMOUNT: $",$$LBF1^PRCFU($FNUMBER(+BAL,",P",2),14)
+5 WRITE ?37," SERVICE BALANCE: $",$$LBF1^PRCFU($FNUMBER(+BAL-$PIECE(BAL,U,3),",P",2),14)
+6 WRITE !,"LIQUIDATION BALANCE: $",$$LBF1^PRCFU($FNUMBER(+BAL-$PIECE(BAL,U,2),",P",2),14)
+7 WRITE ?37,"TOTAL LIQUIDATIONS: $",$$LBF1^PRCFU($FNUMBER(+$PIECE(BAL,U,2),",P",2),14)
+8 WRITE !!,"AUTHORIZATION BALANCE(S): ",!
SET AUDA=0
+9 SET AUDA=0
FOR
SET AUDA=$ORDER(AUAMT(AUDA))
if 'AUDA
QUIT
IF $DATA(^PRC(424,AUDA,0))
Begin DoDot:1
+10 WRITE !,$PIECE(AUAMT(AUDA),U)
+11 WRITE ?16,"AMOUNT: $",$$LBF1^PRCFU($FNUMBER($PIECE(AUAMT(AUDA),U,2),",P",2),14)
+12 WRITE ?48,"BALANCE: $",$$LBF1^PRCFU($FNUMBER($PIECE(AUAMT(AUDA),U,3),",P",2),14)
End DoDot:1
+13 WRITE !!," AUTHORIZATION TOTAL: $",$$LBF1^PRCFU($FNUMBER(AMT,",P",2),14)
EXIT KILL AMT,AUAMT,AUDA,BAL,BAL1,DA,DIC,DRAMT,FCPAMT,LQAMT,PO,PODA,PRC,PRCF,Y,TRNODE
+1 QUIT
