| 1 | PRCS826 ;WISC/CLH/TEN-826 CEILING RPT ;6/29/00 12:22
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | CEIL(SI,FY,QTR,CA,CO) ;
|
|---|
| 5 | N TN,IN,CP
|
|---|
| 6 | ;
|
|---|
| 7 | ; CALCULATE TOTAL CEILING DOLLARS FOR USER SELECTED QUARTER.
|
|---|
| 8 | ;
|
|---|
| 9 | S TN=SI_"-"_FY_"-"_QTR_"-000"
|
|---|
| 10 | ;
|
|---|
| 11 | ; PICK ALL TRANSACTIONS FOR USER SELECTED QUARTER.
|
|---|
| 12 | ;
|
|---|
| 13 | F D Q:'TN!($P(TN,"-",3)'=QTR)
|
|---|
| 14 | . S TN=$O(^PRCS(410,"AE",TN))
|
|---|
| 15 | . Q:('TN)!($P(TN,"-",3)'=QTR)
|
|---|
| 16 | . S CP=+$P(TN,"-",4)
|
|---|
| 17 | . S CA(CP)=0
|
|---|
| 18 | . S IN=0
|
|---|
| 19 | . ; PICK ALL "CEILING" TRANSACTION TYPES WITHIN QTR.
|
|---|
| 20 | . F D Q:'IN
|
|---|
| 21 | .. S IN=$O(^PRCS(410,"AE",TN,IN))
|
|---|
| 22 | .. Q:'IN
|
|---|
| 23 | .. I $D(^PRCS(410,IN,0)),$P(^PRCS(410,IN,0),U,2)="C" S CA(CP)=CA(CP)+$P($G(^PRCS(410,IN,6)),"^") ;"C"=CEILING
|
|---|
| 24 | .. Q
|
|---|
| 25 | . Q
|
|---|
| 26 | ;
|
|---|
| 27 | ; CALCULATE TOTAL USER SELECTED FISCAL YEAR-TO-DATE OBLIGATIONS.
|
|---|
| 28 | ;
|
|---|
| 29 | S TN=SI_"-"_FY_"-1-000"
|
|---|
| 30 | ;
|
|---|
| 31 | ; PICK ALL TRANSACTIONS FOR USER SELECTED FISCAL YEAR.
|
|---|
| 32 | ;
|
|---|
| 33 | F D Q:'TN!($P(TN,"-",2)'=FY)
|
|---|
| 34 | . S TN=$O(^PRCS(410,"AE",TN))
|
|---|
| 35 | . Q:('TN)!($P(TN,"-",2)'=FY)
|
|---|
| 36 | . S CP=+$P(TN,"-",4)
|
|---|
| 37 | . I '$D(CO(CP)) S CO(CP)=0
|
|---|
| 38 | . S IN=0
|
|---|
| 39 | . ; PICK ALL "OBLIGATION" TRANSACTION TYPES WITHIN FISCAL YEAR.
|
|---|
| 40 | . F D Q:'IN
|
|---|
| 41 | .. S IN=$O(^PRCS(410,"AE",TN,IN))
|
|---|
| 42 | .. Q:'IN
|
|---|
| 43 | .. I $D(^PRCS(410,IN,0)),$P(^PRCS(410,IN,0),U,2)="O" S CO(CP)=CO(CP)+$P($G(^PRCS(410,IN,4)),U,3) ;"O"=OBLIGATION
|
|---|
| 44 | .. Q
|
|---|
| 45 | . Q
|
|---|
| 46 | ;
|
|---|
| 47 | Q ;QUIT PROGRAM
|
|---|
