PRCF826 ;WISC/CLH/TEN-826 STATUS OF FUNDS RPT ;5/4/93 9:14 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
S PRCF("X")="ABSQ"
D ^PRCFSITE
G:'% OUT
;
D S %ZIS="MQ"
D ^%ZIS
G:POP OUT
I '$D(IO("Q")) D G Q1
. U IO
. D DQ
. U IO(0)
. Q
;
S ZTSAVE("PRCF*")=""
S ZTSAVE("PRCB*")=""
S ZTSAVE("PRC*")=""
S ZTRTN="DQ^PRCF826"
S ZTDESC="826 STATUS OF FUNDS REPORT"
S ZTIO=ION
D ^%ZTLOAD
;
Q1 D ^%ZISC
K POP
Q
;
DQ D:$D(ZTQUEUED) KILL^%ZTLOAD
;
N ZX,OB,OB1,OBCP,OBCP1,TOT,CA,CO,FYC,FYO,DA,CP,SI,FY,QTR,CPB,X,CPN,APS,LINE,PG
K ^TMP($J)
;
S ZX=""
S QTR=PRC("QTR")
S FY=PRC("FY")
S SI=PRC("SITE")
;
D CEIL^PRCS826(SI,FY,QTR,.CA,.CO)
;
S TOT=0
S TOT(1)=0
S TOT(2)=0
S TOT(3)=0
S CP=0
;
F S CP=$O(^PRC(420,PRC("SITE"),1,CP)) Q:('CP) D
. I CP<9999 D
.. S CPB=$G(^PRC(420,SI,1,CP,4,FY,0)) Q:CPB=""
.. S APS=$P($$ACC^PRC0C(SI,CP_"^"_FY_"^"_+$$YEAR^PRC0C(FY)),"^",11)
.. S APS=" "_APS
.. S CPN=+$P($G(^PRC(420,SI,1,CP,0)),U,1)
.. I '$D(^TMP($J,QTR,APS,"9999 GRAND TOTAL")) S ^TMP($J,QTR,APS,"9999 GRAND TOTAL")="0^0^0^0^0"
.. I '$D(^TMP($J,QTR,APS,CPN)) S ^TMP($J,QTR,APS,CPN)="0^0^0^0^0"
.. I '$D(^TMP($J,"GT")) S ^TMP($J,"GT")="0^0^0^0^0"
.. S ^TMP($J,QTR,APS,CPN)=$G(CA($P(CPN," ")))_U_+$P(CPB,U,QTR+1)_U_+$P(CPB,U,QTR+5)
.. F I=1:1:3 S TOT(I)=+$P(^TMP($J,QTR,APS,"9999 GRAND TOTAL"),U,I)
.. S TOT(1)=TOT(1)+$G(CA($P(CPN," ")))
.. S TOT(2)=TOT(2)+$P(CPB,U,QTR+1)
.. S TOT(3)=TOT(3)+$P(CPB,U,QTR+5)
.. S ^TMP($J,QTR,APS,"9999 GRAND TOTAL")=TOT(1)_U_TOT(2)_U_TOT(3)
.. S OB=$G(^TMP($J,QTR,APS,"9999 GRAND TOTAL"))
.. S OBCP=$G(^TMP($J,QTR,APS,CPN))
.. S OB1=$P(OB,U)-$P(OB,U,3)
.. S OBCP1=$P(OBCP,U)-$P(OBCP,U,3)
.. S $P(^TMP($J,QTR,APS,"9999 GRAND TOTAL"),U,4)=OB1
.. S $P(^TMP($J,QTR,APS,CPN),U,4)=OBCP1
.. S OB=$G(^TMP($J,QTR,APS,"9999 GRAND TOTAL"))
.. S $P(^TMP($J,QTR,APS,CPN),U,5)=$G(CO($P(CPN," ")))
.. S X=^TMP($J,"GT")
.. F I=1:1:4 S $P(X,U,I)=$P(X,U,I)+$P(OB,U,I)
.. S $P(X,U,5)=$P(X,U,5)+$G(CO($P(CPN," ")))
.. S ^TMP($J,"GT")=X
.. Q
. Q
;
S PG=0
S LINE=""
S $P(LINE,"-",81)=""
W:($E(IOST)="C") @IOF
D HDR1
;
S AP=""
S CPN=""
;
F S AP=$O(^TMP($J,QTR,AP)) Q:(AP="") D G:(ZX=U) OUT
. W !!,"APPROPRIATION: ",AP,!!
. F S CPN=$O(^TMP($J,QTR,AP,CPN)) Q:(CPN="") D Q:(ZX=U)
.. ;
.. ; WRITE APPROPRIATION (9999 GRAND TOTAL) TOTALS.
.. ;
.. I +CPN=9999 D PAUSE:$Y+5>IOSL Q:(ZX=U) D Q
... W !,"TOTAL:"
... S X=$G(^TMP($J,QTR,AP,CPN))
... W ?21,$J($FN($P(X,U,1),"P,",2),14)
... W ?36,$J($FN($P(X,U,4),"P,",2),14)
... W ?52,$J($FN($P(X,U,3),"P,",2),14)
... W ?66,$J($FN($P(X,U,5),"P,",2),14)
... W !
... Q
.. ;
.. ; WRITE CONTROL POINT TOTALS.
.. ;
.. D PAUSE:($Y+5>IOSL) Q:(ZX=U)
.. S X=CPN S:X<100 X=$E(1000+X,2,999) W $E(X,1,15)
.. I $P($G(^PRC(420,PRC("SITE"),1,+CPN,0)),U,19)=1 W " *" ;MARK DEACTIVATED CONTROL POINT.
.. S X=$G(^TMP($J,QTR,AP,CPN))
.. W ?21,$J($FN($P(X,U,1),"P,",2),14)
.. W ?36,$J($FN($P(X,U,4),"P,",2),14)
.. W ?52,$J($FN($P(X,U,3),"P,",2),14)
.. W ?66,$J($FN($P(X,U,5),"P,",2),14)
.. W !
.. ; COMPUTE FYTD OBLIGATION AMOUNT BY APPROPRIATION.
.. S $P(^TMP($J,QTR,AP,"9999 GRAND TOTAL"),U,5)=$P(^TMP($J,QTR,AP,"9999 GRAND TOTAL"),U,5)+$G(CO($P(CPN," ")))
.. Q
;
; WRITE STATION (SITE) GRAND TOTALS.
;
D PAUSE:($Y+5>IOSL) Q:(ZX=U)
W !!,"STATION TOTALS: "
S X=$G(^TMP($J,"GT"))
W ?21,$J($FN($P(X,U,1),"P,",2),14)
W ?36,$J($FN($P(X,U,4),"P,",2),14)
W ?52,$J($FN($P(X,U,3),"P,",2),14)
W ?66,$J($FN($P(X,U,5),"P,",2),14)
W:($E(IOST)="P") @IOF
;
OUT K PRC,PRCF,PRCB,^TMP($J)
Q
;
HDR1 S PG=PG+1
W !,"STATUS OF FUNDS - 826 REPORT"
W ?40,"STATION NO: ",SI
W ?71,"PAGE: ",$J(PG,3)
W !!,"* = DEACTIVATED CONTROL POINT"
W !!,"FISCAL YEAR: ",FY
W !,"QUARTER:",?14,QTR
W !!,?54,"UNOBLIGATED"
W !,?22,"COST CEILING",?38,"OBLIGATIONS",?58,"BALANCE",?69,"FYTD"
W !,"FUND CONTROL POINT",?22,"FOR QTR",?38,"FOR QTR",?58,"FOR QTR",?69,"OBLIGATIONS"
W !,LINE
Q
;
HDR W @IOF
S PG=PG+1
W !,"826 REPORT - STATION NO: ",SI
W ?71,"PAGE: ",$J(PG,3)
W !,"* = DEACTIVATED CONTROL POINT"
W !,LINE,!
Q
;
PAUSE I $E(IOST)="C" D Q:(ZX=U)
. S ZX=""
. R !,"Press <return> to continue or '^' to quit: ",ZX:DTIME
. S:('$T) ZX=U
. Q
D HDR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCF826 4410 printed Dec 13, 2024@02:01:42 Page 2
PRCF826 ;WISC/CLH/TEN-826 STATUS OF FUNDS RPT ;5/4/93 9:14 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 SET PRCF("X")="ABSQ"
+4 DO ^PRCFSITE
+5 if '%
GOTO OUT
+6 ;
D SET %ZIS="MQ"
+1 DO ^%ZIS
+2 if POP
GOTO OUT
+3 IF '$DATA(IO("Q"))
Begin DoDot:1
+4 USE IO
+5 DO DQ
+6 USE IO(0)
+7 QUIT
End DoDot:1
GOTO Q1
+8 ;
+9 SET ZTSAVE("PRCF*")=""
+10 SET ZTSAVE("PRCB*")=""
+11 SET ZTSAVE("PRC*")=""
+12 SET ZTRTN="DQ^PRCF826"
+13 SET ZTDESC="826 STATUS OF FUNDS REPORT"
+14 SET ZTIO=ION
+15 DO ^%ZTLOAD
+16 ;
Q1 DO ^%ZISC
+1 KILL POP
+2 QUIT
+3 ;
DQ if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
+1 ;
+2 NEW ZX,OB,OB1,OBCP,OBCP1,TOT,CA,CO,FYC,FYO,DA,CP,SI,FY,QTR,CPB,X,CPN,APS,LINE,PG
+3 KILL ^TMP($JOB)
+4 ;
+5 SET ZX=""
+6 SET QTR=PRC("QTR")
+7 SET FY=PRC("FY")
+8 SET SI=PRC("SITE")
+9 ;
+10 DO CEIL^PRCS826(SI,FY,QTR,.CA,.CO)
+11 ;
+12 SET TOT=0
+13 SET TOT(1)=0
+14 SET TOT(2)=0
+15 SET TOT(3)=0
+16 SET CP=0
+17 ;
+18 FOR
SET CP=$ORDER(^PRC(420,PRC("SITE"),1,CP))
if ('CP)
QUIT
Begin DoDot:1
+19 IF CP<9999
Begin DoDot:2
+20 SET CPB=$GET(^PRC(420,SI,1,CP,4,FY,0))
if CPB=""
QUIT
+21 SET APS=$PIECE($$ACC^PRC0C(SI,CP_"^"_FY_"^"_+$$YEAR^PRC0C(FY)),"^",11)
+22 SET APS=" "_APS
+23 SET CPN=+$PIECE($GET(^PRC(420,SI,1,CP,0)),U,1)
+24 IF '$DATA(^TMP($JOB,QTR,APS,"9999 GRAND TOTAL"))
SET ^TMP($JOB,QTR,APS,"9999 GRAND TOTAL")="0^0^0^0^0"
+25 IF '$DATA(^TMP($JOB,QTR,APS,CPN))
SET ^TMP($JOB,QTR,APS,CPN)="0^0^0^0^0"
+26 IF '$DATA(^TMP($JOB,"GT"))
SET ^TMP($JOB,"GT")="0^0^0^0^0"
+27 SET ^TMP($JOB,QTR,APS,CPN)=$GET(CA($PIECE(CPN," ")))_U_+$PIECE(CPB,U,QTR+1)_U_+$PIECE(CPB,U,QTR+5)
+28 FOR I=1:1:3
SET TOT(I)=+$PIECE(^TMP($JOB,QTR,APS,"9999 GRAND TOTAL"),U,I)
+29 SET TOT(1)=TOT(1)+$GET(CA($PIECE(CPN," ")))
+30 SET TOT(2)=TOT(2)+$PIECE(CPB,U,QTR+1)
+31 SET TOT(3)=TOT(3)+$PIECE(CPB,U,QTR+5)
+32 SET ^TMP($JOB,QTR,APS,"9999 GRAND TOTAL")=TOT(1)_U_TOT(2)_U_TOT(3)
+33 SET OB=$GET(^TMP($JOB,QTR,APS,"9999 GRAND TOTAL"))
+34 SET OBCP=$GET(^TMP($JOB,QTR,APS,CPN))
+35 SET OB1=$PIECE(OB,U)-$PIECE(OB,U,3)
+36 SET OBCP1=$PIECE(OBCP,U)-$PIECE(OBCP,U,3)
+37 SET $PIECE(^TMP($JOB,QTR,APS,"9999 GRAND TOTAL"),U,4)=OB1
+38 SET $PIECE(^TMP($JOB,QTR,APS,CPN),U,4)=OBCP1
+39 SET OB=$GET(^TMP($JOB,QTR,APS,"9999 GRAND TOTAL"))
+40 SET $PIECE(^TMP($JOB,QTR,APS,CPN),U,5)=$GET(CO($PIECE(CPN," ")))
+41 SET X=^TMP($JOB,"GT")
+42 FOR I=1:1:4
SET $PIECE(X,U,I)=$PIECE(X,U,I)+$PIECE(OB,U,I)
+43 SET $PIECE(X,U,5)=$PIECE(X,U,5)+$GET(CO($PIECE(CPN," ")))
+44 SET ^TMP($JOB,"GT")=X
+45 QUIT
End DoDot:2
+46 QUIT
End DoDot:1
+47 ;
+48 SET PG=0
+49 SET LINE=""
+50 SET $PIECE(LINE,"-",81)=""
+51 if ($EXTRACT(IOST)="C")
WRITE @IOF
+52 DO HDR1
+53 ;
+54 SET AP=""
+55 SET CPN=""
+56 ;
+57 FOR
SET AP=$ORDER(^TMP($JOB,QTR,AP))
if (AP="")
QUIT
Begin DoDot:1
+58 WRITE !!,"APPROPRIATION: ",AP,!!
+59 FOR
SET CPN=$ORDER(^TMP($JOB,QTR,AP,CPN))
if (CPN="")
QUIT
Begin DoDot:2
+60 ;
+61 ; WRITE APPROPRIATION (9999 GRAND TOTAL) TOTALS.
+62 ;
+63 IF +CPN=9999
if $Y+5>IOSL
DO PAUSE
if (ZX=U)
QUIT
Begin DoDot:3
+64 WRITE !,"TOTAL:"
+65 SET X=$GET(^TMP($JOB,QTR,AP,CPN))
+66 WRITE ?21,$JUSTIFY($FNUMBER($PIECE(X,U,1),"P,",2),14)
+67 WRITE ?36,$JUSTIFY($FNUMBER($PIECE(X,U,4),"P,",2),14)
+68 WRITE ?52,$JUSTIFY($FNUMBER($PIECE(X,U,3),"P,",2),14)
+69 WRITE ?66,$JUSTIFY($FNUMBER($PIECE(X,U,5),"P,",2),14)
+70 WRITE !
+71 QUIT
End DoDot:3
QUIT
+72 ;
+73 ; WRITE CONTROL POINT TOTALS.
+74 ;
+75 if ($Y+5>IOSL)
DO PAUSE
if (ZX=U)
QUIT
+76 SET X=CPN
if X<100
SET X=$EXTRACT(1000+X,2,999)
WRITE $EXTRACT(X,1,15)
+77 ;MARK DEACTIVATED CONTROL POINT.
IF $PIECE($GET(^PRC(420,PRC("SITE"),1,+CPN,0)),U,19)=1
WRITE " *"
+78 SET X=$GET(^TMP($JOB,QTR,AP,CPN))
+79 WRITE ?21,$JUSTIFY($FNUMBER($PIECE(X,U,1),"P,",2),14)
+80 WRITE ?36,$JUSTIFY($FNUMBER($PIECE(X,U,4),"P,",2),14)
+81 WRITE ?52,$JUSTIFY($FNUMBER($PIECE(X,U,3),"P,",2),14)
+82 WRITE ?66,$JUSTIFY($FNUMBER($PIECE(X,U,5),"P,",2),14)
+83 WRITE !
+84 ; COMPUTE FYTD OBLIGATION AMOUNT BY APPROPRIATION.
+85 SET $PIECE(^TMP($JOB,QTR,AP,"9999 GRAND TOTAL"),U,5)=$PIECE(^TMP($JOB,QTR,AP,"9999 GRAND TOTAL"),U,5)+$GET(CO($PIECE(CPN," ")))
+86 QUIT
End DoDot:2
if (ZX=U)
QUIT
End DoDot:1
if (ZX=U)
GOTO OUT
+87 ;
+88 ; WRITE STATION (SITE) GRAND TOTALS.
+89 ;
+90 if ($Y+5>IOSL)
DO PAUSE
if (ZX=U)
QUIT
+91 WRITE !!,"STATION TOTALS: "
+92 SET X=$GET(^TMP($JOB,"GT"))
+93 WRITE ?21,$JUSTIFY($FNUMBER($PIECE(X,U,1),"P,",2),14)
+94 WRITE ?36,$JUSTIFY($FNUMBER($PIECE(X,U,4),"P,",2),14)
+95 WRITE ?52,$JUSTIFY($FNUMBER($PIECE(X,U,3),"P,",2),14)
+96 WRITE ?66,$JUSTIFY($FNUMBER($PIECE(X,U,5),"P,",2),14)
+97 if ($EXTRACT(IOST)="P")
WRITE @IOF
+98 ;
OUT KILL PRC,PRCF,PRCB,^TMP($JOB)
+1 QUIT
+2 ;
HDR1 SET PG=PG+1
+1 WRITE !,"STATUS OF FUNDS - 826 REPORT"
+2 WRITE ?40,"STATION NO: ",SI
+3 WRITE ?71,"PAGE: ",$JUSTIFY(PG,3)
+4 WRITE !!,"* = DEACTIVATED CONTROL POINT"
+5 WRITE !!,"FISCAL YEAR: ",FY
+6 WRITE !,"QUARTER:",?14,QTR
+7 WRITE !!,?54,"UNOBLIGATED"
+8 WRITE !,?22,"COST CEILING",?38,"OBLIGATIONS",?58,"BALANCE",?69,"FYTD"
+9 WRITE !,"FUND CONTROL POINT",?22,"FOR QTR",?38,"FOR QTR",?58,"FOR QTR",?69,"OBLIGATIONS"
+10 WRITE !,LINE
+11 QUIT
+12 ;
HDR WRITE @IOF
+1 SET PG=PG+1
+2 WRITE !,"826 REPORT - STATION NO: ",SI
+3 WRITE ?71,"PAGE: ",$JUSTIFY(PG,3)
+4 WRITE !,"* = DEACTIVATED CONTROL POINT"
+5 WRITE !,LINE,!
+6 QUIT
+7 ;
PAUSE IF $EXTRACT(IOST)="C"
Begin DoDot:1
+1 SET ZX=""
+2 READ !,"Press <return> to continue or '^' to quit: ",ZX:DTIME
+3 if ('$TEST)
SET ZX=U
+4 QUIT
End DoDot:1
if (ZX=U)
QUIT
+5 DO HDR
+6 QUIT
