- PRCBCPR ;WISC@ALTOONA/CTB-CONTROL POINT REPORT ; 05/18/93 2:10 PM
- V ;;5.1;IFCAP;**97**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- D ^PRCFSITE Q:'% D QT^PRCBSUT Q
- INDIV D V G:'% OUT S DIC="^PRC(420,"_PRC("SITE")_",1,",DIC(0)="AEMNZ" D ^DIC G:Y<0 OUT S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(Y(0)," ") D QUE
- W !!,"CONTROL POINT OFFICIAL'S BALANCE: ",?35,"$"_$J(PRCS("C"),10,2),!,"FISCAL UNOBLIGATED BALANCE: ",?35,"$"_$J(PRCS("O"),10,2)
- W !,"TOTAL COMMITTED, NOT OBLIGATED: ",?35,"$"_$J((PRCS("O")-PRCS("C")),10,2) K %DT,%P,I,N,PRCS,Z,Z1 W ! G INDIV
- OUT K %,C,DIC,J,POP,PRCSQTT,T,T1,X,Y,Z Q
- QALL ;;PRINT ALL CONTROL POINT BALANCES
- D V G:'% OUT S ZTDESC=$P($T(QALL),";",3),ZTRTN="ALL^PRCBCPR",ZTSAVE("PRC*")="" D ^PRCFQ G OUT
- ALL ;PRINT BALANCES FOR ALL CONTROL POINTS
- D:$D(ZTQUEUED) KILL^%ZTLOAD S DA=0,ZZ=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"
- S PAGE=1,$P(LINE,"-",IOM-2)="" D HDR
- F K=1:1 S DA=$O(^PRC(420,PRC("SITE"),1,DA)) G OUT:DA>9998!'DA I $D(^(DA,0)) S PRC("CP")=^(0),Z=ZZ_$P(PRC("CP")," ") D QUE S %=1 D:IOSL-$Y<4&(IOST["C-") ENCON^PRCFQ G:'%!(X=U) OUT D:IOSL-$Y<4 HDR D LINE K PRC("CP")
- W !,"DONE" Q
- LINE W !!,$P(PRC("CP"),"^"),?32,"$"_$J(PRCS("C"),10,2),?49,"$"_$J(PRCS("O"),10,2),?66,"$"_$J((PRCS("O")-PRCS("C")),10,2) K %DT,%P,I,N,PRCS,Z,Z1 Q
- HDR ;HEADER
- D NOW^%DTC S Y=% D DD^%DT S DATETIME=Y
- W @IOF,"FUND CONTROL POINT BALANCE LISTING",?IOM-40,"PAGE: ",PAGE,?IOM-20,DATETIME,!,"FOR STATION: ",PRC("SITE")," FY-QTR: ",PRC("FY")_"-"_PRC("QTR")
- W !!,"FUND CONTROL POINT",?32,"UNCOMMITTED",?49,"UNOBLIGATED",?70,"PENDING",!,LINE S PAGE=PAGE+1 Q
- QUE ;
- S PRCS("O")=$$FCPBAL^PRC0D(PRC("SITE"),PRC("CP"),PRC("FY"),1),PRCS("O")=$P(PRCS("O"),"^",PRC("QTR"))
- S PRCS("C")=$$FCPBAL^PRC0D(PRC("SITE"),PRC("CP"),PRC("FY"),2),PRCS("C")=$P(PRCS("C"),"^",PRC("QTR"))
- QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCBCPR 1863 printed Apr 23, 2025@18:15:05 Page 2
- PRCBCPR ;WISC@ALTOONA/CTB-CONTROL POINT REPORT ; 05/18/93 2:10 PM
- V ;;5.1;IFCAP;**97**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 DO ^PRCFSITE
- if '%
- QUIT
- DO QT^PRCBSUT
- QUIT
- INDIV DO V
- if '%
- GOTO OUT
- SET DIC="^PRC(420,"_PRC("SITE")_",1,"
- SET DIC(0)="AEMNZ"
- DO ^DIC
- if Y<0
- GOTO OUT
- SET Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(Y(0)," ")
- DO QUE
- +1 WRITE !!,"CONTROL POINT OFFICIAL'S BALANCE: ",?35,"$"_$JUSTIFY(PRCS("C"),10,2),!,"FISCAL UNOBLIGATED BALANCE: ",?35,"$"_$JUSTIFY(PRCS("O"),10,2)
- +2 WRITE !,"TOTAL COMMITTED, NOT OBLIGATED: ",?35,"$"_$JUSTIFY((PRCS("O")-PRCS("C")),10,2)
- KILL %DT,%P,I,N,PRCS,Z,Z1
- WRITE !
- GOTO INDIV
- OUT KILL %,C,DIC,J,POP,PRCSQTT,T,T1,X,Y,Z
- QUIT
- QALL ;;PRINT ALL CONTROL POINT BALANCES
- +1 DO V
- if '%
- GOTO OUT
- SET ZTDESC=$PIECE($TEXT(QALL),";",3)
- SET ZTRTN="ALL^PRCBCPR"
- SET ZTSAVE("PRC*")=""
- DO ^PRCFQ
- GOTO OUT
- ALL ;PRINT BALANCES FOR ALL CONTROL POINTS
- +1 if $DATA(ZTQUEUED)
- DO KILL^%ZTLOAD
- SET DA=0
- SET ZZ=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"
- +2 SET PAGE=1
- SET $PIECE(LINE,"-",IOM-2)=""
- DO HDR
- +3 FOR K=1:1
- SET DA=$ORDER(^PRC(420,PRC("SITE"),1,DA))
- if DA>9998!'DA
- GOTO OUT
- IF $DATA(^(DA,0))
- SET PRC("CP")=^(0)
- SET Z=ZZ_$PIECE(PRC("CP")," ")
- DO QUE
- SET %=1
- if IOSL-$Y<4&(IOST["C-")
- DO ENCON^PRCFQ
- if '%!(X=U)
- GOTO OUT
- if IOSL-$Y<4
- DO HDR
- DO LINE
- KILL PRC("CP")
- +4 WRITE !,"DONE"
- QUIT
- LINE WRITE !!,$PIECE(PRC("CP"),"^"),?32,"$"_$JUSTIFY(PRCS("C"),10,2),?49,"$"_$JUSTIFY(PRCS("O"),10,2),?66,"$"_$JUSTIFY((PRCS("O")-PRCS("C")),10,2)
- KILL %DT,%P,I,N,PRCS,Z,Z1
- QUIT
- HDR ;HEADER
- +1 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET DATETIME=Y
- +2 WRITE @IOF,"FUND CONTROL POINT BALANCE LISTING",?IOM-40,"PAGE: ",PAGE,?IOM-20,DATETIME,!,"FOR STATION: ",PRC("SITE")," FY-QTR: ",PRC("FY")_"-"_PRC("QTR")
- +3 WRITE !!,"FUND CONTROL POINT",?32,"UNCOMMITTED",?49,"UNOBLIGATED",?70,"PENDING",!,LINE
- SET PAGE=PAGE+1
- QUIT
- QUE ;
- +1 SET PRCS("O")=$$FCPBAL^PRC0D(PRC("SITE"),PRC("CP"),PRC("FY"),1)
- SET PRCS("O")=$PIECE(PRCS("O"),"^",PRC("QTR"))
- +2 SET PRCS("C")=$$FCPBAL^PRC0D(PRC("SITE"),PRC("CP"),PRC("FY"),2)
- SET PRCS("C")=$PIECE(PRCS("C"),"^",PRC("QTR"))
- +3 QUIT
