Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCF826

PRCF826.m

Go to the documentation of this file. 
  1. PRCF826 ;WISC/CLH/TEN-826 STATUS OF FUNDS RPT ;5/4/93  9:14 AM
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1.  S PRCF("X")="ABSQ"
  1.  D ^PRCFSITE
  1.  G:'% OUT
  1.  ;
  1. D S %ZIS="MQ"
  1.  D ^%ZIS
  1.  G:POP OUT
  1.  I '$D(IO("Q")) D  G Q1
  1.  . U IO
  1.  . D DQ
  1.  . U IO(0)
  1.  . Q
  1.  ;
  1.  S ZTSAVE("PRCF*")=""
  1.  S ZTSAVE("PRCB*")=""
  1.  S ZTSAVE("PRC*")=""
  1.  S ZTRTN="DQ^PRCF826"
  1.  S ZTDESC="826 STATUS OF FUNDS REPORT"
  1.  S ZTIO=ION
  1.  D ^%ZTLOAD
  1.  ;
  1. Q1 D ^%ZISC
  1.  K POP
  1.  Q
  1.  ;
  1. DQ D:$D(ZTQUEUED) KILL^%ZTLOAD
  1.  ;
  1.  N ZX,OB,OB1,OBCP,OBCP1,TOT,CA,CO,FYC,FYO,DA,CP,SI,FY,QTR,CPB,X,CPN,APS,LINE,PG
  1.  K ^TMP($J)
  1.  ;
  1.  S ZX=""
  1.  S QTR=PRC("QTR")
  1.  S FY=PRC("FY")
  1.  S SI=PRC("SITE")
  1.  ;
  1.  D CEIL^PRCS826(SI,FY,QTR,.CA,.CO)
  1.  ;
  1.  S TOT=0
  1.  S TOT(1)=0
  1.  S TOT(2)=0
  1.  S TOT(3)=0
  1.  S CP=0
  1.  ;
  1.  F  S CP=$O(^PRC(420,PRC("SITE"),1,CP)) Q:('CP)  D
  1.  . I CP<9999 D
  1.  .. S CPB=$G(^PRC(420,SI,1,CP,4,FY,0)) Q:CPB=""
  1.  .. S APS=$P($$ACC^PRC0C(SI,CP_"^"_FY_"^"_+$$YEAR^PRC0C(FY)),"^",11)
  1.  .. S APS=" "_APS
  1.  .. S CPN=+$P($G(^PRC(420,SI,1,CP,0)),U,1)
  1.  .. I '$D(^TMP($J,QTR,APS,"9999 GRAND TOTAL")) S ^TMP($J,QTR,APS,"9999 GRAND TOTAL")="0^0^0^0^0"
  1.  .. I '$D(^TMP($J,QTR,APS,CPN)) S ^TMP($J,QTR,APS,CPN)="0^0^0^0^0"
  1.  .. I '$D(^TMP($J,"GT")) S ^TMP($J,"GT")="0^0^0^0^0"
  1.  .. S ^TMP($J,QTR,APS,CPN)=$G(CA($P(CPN," ")))_U_+$P(CPB,U,QTR+1)_U_+$P(CPB,U,QTR+5)
  1.  .. F I=1:1:3 S TOT(I)=+$P(^TMP($J,QTR,APS,"9999 GRAND TOTAL"),U,I)
  1.  .. S TOT(1)=TOT(1)+$G(CA($P(CPN," ")))
  1.  .. S TOT(2)=TOT(2)+$P(CPB,U,QTR+1)
  1.  .. S TOT(3)=TOT(3)+$P(CPB,U,QTR+5)
  1.  .. S ^TMP($J,QTR,APS,"9999 GRAND TOTAL")=TOT(1)_U_TOT(2)_U_TOT(3)
  1.  .. S OB=$G(^TMP($J,QTR,APS,"9999 GRAND TOTAL"))
  1.  .. S OBCP=$G(^TMP($J,QTR,APS,CPN))
  1.  .. S OB1=$P(OB,U)-$P(OB,U,3)
  1.  .. S OBCP1=$P(OBCP,U)-$P(OBCP,U,3)
  1.  .. S $P(^TMP($J,QTR,APS,"9999 GRAND TOTAL"),U,4)=OB1
  1.  .. S $P(^TMP($J,QTR,APS,CPN),U,4)=OBCP1
  1.  .. S OB=$G(^TMP($J,QTR,APS,"9999 GRAND TOTAL"))
  1.  .. S $P(^TMP($J,QTR,APS,CPN),U,5)=$G(CO($P(CPN," ")))
  1.  .. S X=^TMP($J,"GT")
  1.  .. F I=1:1:4 S $P(X,U,I)=$P(X,U,I)+$P(OB,U,I)
  1.  .. S $P(X,U,5)=$P(X,U,5)+$G(CO($P(CPN," ")))
  1.  .. S ^TMP($J,"GT")=X
  1.  .. Q
  1.  . Q
  1.  ;
  1.  S PG=0
  1.  S LINE=""
  1.  S $P(LINE,"-",81)=""
  1.  W:($E(IOST)="C") @IOF
  1.  D HDR1
  1.  ;
  1.  S AP=""
  1.  S CPN=""
  1.  ;
  1.  F  S AP=$O(^TMP($J,QTR,AP)) Q:(AP="")  D  G:(ZX=U) OUT
  1.  . W !!,"APPROPRIATION:  ",AP,!!
  1.  . F  S CPN=$O(^TMP($J,QTR,AP,CPN)) Q:(CPN="")  D  Q:(ZX=U)
  1.  .. ;
  1.  .. ;     WRITE APPROPRIATION (9999 GRAND TOTAL) TOTALS.
  1.  .. ;
  1.  .. I +CPN=9999 D PAUSE:$Y+5>IOSL Q:(ZX=U)  D  Q
  1.  ... W !,"TOTAL:"
  1.  ... S X=$G(^TMP($J,QTR,AP,CPN))
  1.  ... W ?21,$J($FN($P(X,U,1),"P,",2),14)
  1.  ... W ?36,$J($FN($P(X,U,4),"P,",2),14)
  1.  ... W ?52,$J($FN($P(X,U,3),"P,",2),14)
  1.  ... W ?66,$J($FN($P(X,U,5),"P,",2),14)
  1.  ... W !
  1.  ... Q
  1.  .. ;
  1.  .. ;             WRITE CONTROL POINT TOTALS.
  1.  .. ;
  1.  .. D PAUSE:($Y+5>IOSL) Q:(ZX=U)
  1.  .. S X=CPN S:X<100 X=$E(1000+X,2,999) W $E(X,1,15)
  1.  .. I $P($G(^PRC(420,PRC("SITE"),1,+CPN,0)),U,19)=1 W " *" ;MARK DEACTIVATED CONTROL POINT.
  1.  .. S X=$G(^TMP($J,QTR,AP,CPN))
  1.  .. W ?21,$J($FN($P(X,U,1),"P,",2),14)
  1.  .. W ?36,$J($FN($P(X,U,4),"P,",2),14)
  1.  .. W ?52,$J($FN($P(X,U,3),"P,",2),14)
  1.  .. W ?66,$J($FN($P(X,U,5),"P,",2),14)
  1.  .. W !
  1.  .. ;  COMPUTE FYTD OBLIGATION AMOUNT BY APPROPRIATION.
  1.  .. 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," ")))
  1.  .. Q
  1.  ;
  1.  ;             WRITE STATION (SITE) GRAND TOTALS.
  1.  ;
  1.  D PAUSE:($Y+5>IOSL) Q:(ZX=U)
  1.  W !!,"STATION TOTALS: "
  1.  S X=$G(^TMP($J,"GT"))
  1.  W ?21,$J($FN($P(X,U,1),"P,",2),14)
  1.  W ?36,$J($FN($P(X,U,4),"P,",2),14)
  1.  W ?52,$J($FN($P(X,U,3),"P,",2),14)
  1.  W ?66,$J($FN($P(X,U,5),"P,",2),14)
  1.  W:($E(IOST)="P") @IOF
  1.  ;
  1. OUT K PRC,PRCF,PRCB,^TMP($J)
  1.  Q
  1.  ;
  1. HDR1 S PG=PG+1
  1.  W !,"STATUS OF FUNDS - 826 REPORT"
  1.  W ?40,"STATION NO: ",SI
  1.  W ?71,"PAGE: ",$J(PG,3)
  1.  W !!,"* = DEACTIVATED CONTROL POINT"
  1.  W !!,"FISCAL YEAR: ",FY
  1.  W !,"QUARTER:",?14,QTR
  1.  W !!,?54,"UNOBLIGATED"
  1.  W !,?22,"COST CEILING",?38,"OBLIGATIONS",?58,"BALANCE",?69,"FYTD"
  1.  W !,"FUND CONTROL POINT",?22,"FOR QTR",?38,"FOR QTR",?58,"FOR QTR",?69,"OBLIGATIONS"
  1.  W !,LINE
  1.  Q
  1.  ;
  1. HDR W @IOF
  1.  S PG=PG+1
  1.  W !,"826 REPORT - STATION NO: ",SI
  1.  W ?71,"PAGE: ",$J(PG,3)
  1.  W !,"* = DEACTIVATED CONTROL POINT"
  1.  W !,LINE,!
  1.  Q
  1.  ;
  1. PAUSE I $E(IOST)="C" D  Q:(ZX=U)
  1.  . S ZX=""
  1.  . R !,"Press <return> to continue or '^' to quit: ",ZX:DTIME
  1.  . S:('$T) ZX=U
  1.  . Q
  1.  D HDR
  1.  Q