- 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 Feb 18, 2025@23:27:44 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