PRCS826 ;WISC/CLH/TEN-826 CEILING RPT ;6/29/00 12:22
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
CEIL(SI,FY,QTR,CA,CO) ;
N TN,IN,CP
;
; CALCULATE TOTAL CEILING DOLLARS FOR USER SELECTED QUARTER.
;
S TN=SI_"-"_FY_"-"_QTR_"-000"
;
; PICK ALL TRANSACTIONS FOR USER SELECTED QUARTER.
;
F D Q:'TN!($P(TN,"-",3)'=QTR)
. S TN=$O(^PRCS(410,"AE",TN))
. Q:('TN)!($P(TN,"-",3)'=QTR)
. S CP=+$P(TN,"-",4)
. S CA(CP)=0
. S IN=0
. ; PICK ALL "CEILING" TRANSACTION TYPES WITHIN QTR.
. F D Q:'IN
.. S IN=$O(^PRCS(410,"AE",TN,IN))
.. Q:'IN
.. 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
.. Q
. Q
;
; CALCULATE TOTAL USER SELECTED FISCAL YEAR-TO-DATE OBLIGATIONS.
;
S TN=SI_"-"_FY_"-1-000"
;
; PICK ALL TRANSACTIONS FOR USER SELECTED FISCAL YEAR.
;
F D Q:'TN!($P(TN,"-",2)'=FY)
. S TN=$O(^PRCS(410,"AE",TN))
. Q:('TN)!($P(TN,"-",2)'=FY)
. S CP=+$P(TN,"-",4)
. I '$D(CO(CP)) S CO(CP)=0
. S IN=0
. ; PICK ALL "OBLIGATION" TRANSACTION TYPES WITHIN FISCAL YEAR.
. F D Q:'IN
.. S IN=$O(^PRCS(410,"AE",TN,IN))
.. Q:'IN
.. 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
.. Q
. Q
;
Q ;QUIT PROGRAM
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCS826 1357 printed Sep 23, 2025@19:53:14 Page 2
PRCS826 ;WISC/CLH/TEN-826 CEILING RPT ;6/29/00 12:22
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
CEIL(SI,FY,QTR,CA,CO) ;
+1 NEW TN,IN,CP
+2 ;
+3 ; CALCULATE TOTAL CEILING DOLLARS FOR USER SELECTED QUARTER.
+4 ;
+5 SET TN=SI_"-"_FY_"-"_QTR_"-000"
+6 ;
+7 ; PICK ALL TRANSACTIONS FOR USER SELECTED QUARTER.
+8 ;
+9 FOR
Begin DoDot:1
+10 SET TN=$ORDER(^PRCS(410,"AE",TN))
+11 if ('TN)!($PIECE(TN,"-",3)'=QTR)
QUIT
+12 SET CP=+$PIECE(TN,"-",4)
+13 SET CA(CP)=0
+14 SET IN=0
+15 ; PICK ALL "CEILING" TRANSACTION TYPES WITHIN QTR.
+16 FOR
Begin DoDot:2
+17 SET IN=$ORDER(^PRCS(410,"AE",TN,IN))
+18 if 'IN
QUIT
+19 ;"C"=CEILING
IF $DATA(^PRCS(410,IN,0))
IF $PIECE(^PRCS(410,IN,0),U,2)="C"
SET CA(CP)=CA(CP)+$PIECE($GET(^PRCS(410,IN,6)),"^")
+20 QUIT
End DoDot:2
if 'IN
QUIT
+21 QUIT
End DoDot:1
if 'TN!($PIECE(TN,"-",3)'=QTR)
QUIT
+22 ;
+23 ; CALCULATE TOTAL USER SELECTED FISCAL YEAR-TO-DATE OBLIGATIONS.
+24 ;
+25 SET TN=SI_"-"_FY_"-1-000"
+26 ;
+27 ; PICK ALL TRANSACTIONS FOR USER SELECTED FISCAL YEAR.
+28 ;
+29 FOR
Begin DoDot:1
+30 SET TN=$ORDER(^PRCS(410,"AE",TN))
+31 if ('TN)!($PIECE(TN,"-",2)'=FY)
QUIT
+32 SET CP=+$PIECE(TN,"-",4)
+33 IF '$DATA(CO(CP))
SET CO(CP)=0
+34 SET IN=0
+35 ; PICK ALL "OBLIGATION" TRANSACTION TYPES WITHIN FISCAL YEAR.
+36 FOR
Begin DoDot:2
+37 SET IN=$ORDER(^PRCS(410,"AE",TN,IN))
+38 if 'IN
QUIT
+39 ;"O"=OBLIGATION
IF $DATA(^PRCS(410,IN,0))
IF $PIECE(^PRCS(410,IN,0),U,2)="O"
SET CO(CP)=CO(CP)+$PIECE($GET(^PRCS(410,IN,4)),U,3)
+40 QUIT
End DoDot:2
if 'IN
QUIT
+41 QUIT
End DoDot:1
if 'TN!($PIECE(TN,"-",2)'=FY)
QUIT
+42 ;
+43 ;QUIT PROGRAM
QUIT
