- ACRFFDH1 ;IHS/OIRM/DSD/AEF - continuation of ACRFFDH [ 10/27/2004 4:18 PM ]
- ;;2.1;ADMIN RESOURCE MGT SYSTEM;**13**;NOV 05, 2001
- ;;SPECIAL DIAGNOSTIC REPORTS
- ;
- ;
- EN ;EP -- MAIN ENTRY POINT
- ;
- N ALLOW,APPROP,DATA,DEPT,OUT,PAGE,SUBALLOW,X,Y
- D PRT
- Q
- PRT ;----- PRINT THE REPORT
- D P
- Q
- P ;----- LOOP THROUGH APPROPRIATION SUBSCRIPT
- ;
- S APPROP=0 F S APPROP=$O(^TMP("ACRFFDH",$J,1,APPROP)) Q:'APPROP D ONE(APPROP) Q:$G(OUT)
- Q
- ONE(X) ;EP -- PRINT STRUCTURE OF ONE APPROPRIATION
- ;
- ; X = APPROPRIATION IEN
- ;
- D P^ACRFFDH(X)
- D HDR
- Q:$G(OUT)
- W !,"APPROPRIATION:",?16,"("_APPROP("D","IEN")_") ",?25,APPROP("D","NAME")
- D WRITE(APPROP("D","FY"),APPROP("D","CREATE FY"),APPROP("D","AMOUNT"))
- D A(APPROP("D","IEN"))
- Q
- A(X) ;----- LOOP THROUGH ALLOWANCE SUBSCRIPT
- ;
- ; X = APPROPRIATION IEN
- ;
- S APPROP=X
- S ALLOW=0 F S ALLOW=$O(^TMP("ACRFFDH",$J,1,APPROP,2,ALLOW)) Q:'ALLOW D Q:$G(OUT)
- . D A^ACRFFDH(ALLOW)
- . I $Y>(IOSL-5) D HDR Q:$G(OUT)
- . W !," ALLOWANCE:",?16,"("_ALLOW("D","IEN")_") ",?25,ALLOW("D","NAME")
- . D WRITE(ALLOW("D","FY"),ALLOW("D","CREATE FY"),ALLOW("D","AMOUNT"))
- . D S(ALLOW("D","IEN"))
- Q
- S(X) ;----- LOOP THROUGH SUB ALLOWANCE SUBSCRIPT
- ;
- ; X = ALLOWANCE IEN
- ;
- S ALLOW=X
- S SUBALLOW=0 F S SUBALLOW=$O(^TMP("ACRFFDH",$J,1,APPROP,2,ALLOW,3,SUBALLOW)) Q:'SUBALLOW D Q:$G(OUT)
- . D S^ACRFFDH(SUBALLOW)
- . I $Y>(IOSL-5) D HDR Q:$G(OUT)
- . W !," SUBALLOW:",?16,"("_SUBALLOW("D","IEN")_") ",?25,SUBALLOW("D","NAME")
- . D WRITE(SUBALLOW("D","FY"),SUBALLOW("D","CREATE FY"),SUBALLOW("D","AMOUNT"))
- . D D(SUBALLOW("D","IEN"))
- Q
- D(X) ;----- LOOP THROUGH DEPARTMENT SUBSCRIPT
- ;
- ; X = SUB-ALLOWANCE IEN
- ;
- S SUBALLOW=X
- S DEPT=0 F S DEPT=$O(^TMP("ACRFFDH",$J,1,APPROP,2,ALLOW,3,SUBALLOW,4,DEPT)) Q:'DEPT D Q:$G(OUT)
- . D D^ACRFFDH(DEPT)
- . I $Y>(IOSL-5) D HDR Q:$G(OUT)
- . W !," DEPT:",?16,"("_DEPT("D","IEN")_") ",?25,DEPT("D","NAME")
- . D WRITE(DEPT("D","FY"),DEPT("D","CREATE FY"),DEPT("D","AMOUNT"))
- Q
- WRITE(FY,NFY,AMT) ;
- ;----- WRITES DATA
- ;
- W ?58,FY
- W ?63,$S(NFY=1:"Y",NFY=2:"N",1:"")
- W ?67,$J(AMT,12,2)
- Q
- HDR ;----- WRITES HEADER
- ;
- N DIR
- I $E(IOST)="C",$G(PAGE) S DIR(0)="E" D ^DIR K DIR I 'Y S OUT=1 Q
- S PAGE=$G(PAGE)+1
- W @IOF
- W !,"DISTRIBUTION OF FUNDS HIERARCHICAL STRUCTURE"
- W ?49,$$NOW
- W " PAGE ",PAGE
- W !,"APPROPRIATION: "_APPROP("D","NAME")
- W !!,?58,"FY",?62,"NXT",?73,"AMOUNT"
- W !
- Q
- NOW() ;EP -- RETURNS CURRENT DATE/TIME
- ;
- N %,%H,%I,X
- D NOW^%DTC
- S Y=DT
- X ^DD("DD")
- Q Y_" "_$E($P(%,".",2),1,2)_":"_$E($P(%,".",2),3,4)
- ;
- QUE(ZTRTN,ZTSAVE,ZTDESC) ;EP;
- Q ;ACR*2.1*13.02 IM13574
- ;----- QUEUEING CODE
- ;
- N %ZIS,IO,POP,ZTIO,ZTSK
- S %ZIS="Q" D ^%ZIS Q:POP
- I $D(IO("Q")) K IO("Q") S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL D ^%ZTLOAD I $G(ZTSK) W !,"Task #",$G(ZTSK)," queued"
- E D @ZTRTN
- Q
- ACRFFDH1 ;IHS/OIRM/DSD/AEF - continuation of ACRFFDH [ 10/27/2004 4:18 PM ]
- +1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**13**;NOV 05, 2001
- +2 ;;SPECIAL DIAGNOSTIC REPORTS
- +3 ;
- +4 ;
- EN ;EP -- MAIN ENTRY POINT
- +1 ;
- +2 NEW ALLOW,APPROP,DATA,DEPT,OUT,PAGE,SUBALLOW,X,Y
- +3 DO PRT
- +4 QUIT
- PRT ;----- PRINT THE REPORT
- +1 DO P
- +2 QUIT
- P ;----- LOOP THROUGH APPROPRIATION SUBSCRIPT
- +1 ;
- +2 SET APPROP=0
- FOR
- SET APPROP=$ORDER(^TMP("ACRFFDH",$JOB,1,APPROP))
- IF 'APPROP
- QUIT
- DO ONE(APPROP)
- IF $GET(OUT)
- QUIT
- +3 QUIT
- ONE(X) ;EP -- PRINT STRUCTURE OF ONE APPROPRIATION
- +1 ;
- +2 ; X = APPROPRIATION IEN
- +3 ;
- +4 DO P^ACRFFDH(X)
- +5 DO HDR
- +6 IF $GET(OUT)
- QUIT
- +7 WRITE !,"APPROPRIATION:",?16,"("_APPROP("D","IEN")_") ",?25,APPROP("D","NAME")
- +8 DO WRITE(APPROP("D","FY"),APPROP("D","CREATE FY"),APPROP("D","AMOUNT"))
- +9 DO A(APPROP("D","IEN"))
- +10 QUIT
- A(X) ;----- LOOP THROUGH ALLOWANCE SUBSCRIPT
- +1 ;
- +2 ; X = APPROPRIATION IEN
- +3 ;
- +4 SET APPROP=X
- +5 SET ALLOW=0
- FOR
- SET ALLOW=$ORDER(^TMP("ACRFFDH",$JOB,1,APPROP,2,ALLOW))
- IF 'ALLOW
- QUIT
- Begin DoDot:1
- +6 DO A^ACRFFDH(ALLOW)
- +7 IF $Y>(IOSL-5)
- DO HDR
- IF $GET(OUT)
- QUIT
- +8 WRITE !," ALLOWANCE:",?16,"("_ALLOW("D","IEN")_") ",?25,ALLOW("D","NAME")
- +9 DO WRITE(ALLOW("D","FY"),ALLOW("D","CREATE FY"),ALLOW("D","AMOUNT"))
- +10 DO S(ALLOW("D","IEN"))
- End DoDot:1
- IF $GET(OUT)
- QUIT
- +11 QUIT
- S(X) ;----- LOOP THROUGH SUB ALLOWANCE SUBSCRIPT
- +1 ;
- +2 ; X = ALLOWANCE IEN
- +3 ;
- +4 SET ALLOW=X
- +5 SET SUBALLOW=0
- FOR
- SET SUBALLOW=$ORDER(^TMP("ACRFFDH",$JOB,1,APPROP,2,ALLOW,3,SUBALLOW))
- IF 'SUBALLOW
- QUIT
- Begin DoDot:1
- +6 DO S^ACRFFDH(SUBALLOW)
- +7 IF $Y>(IOSL-5)
- DO HDR
- IF $GET(OUT)
- QUIT
- +8 WRITE !," SUBALLOW:",?16,"("_SUBALLOW("D","IEN")_") ",?25,SUBALLOW("D","NAME")
- +9 DO WRITE(SUBALLOW("D","FY"),SUBALLOW("D","CREATE FY"),SUBALLOW("D","AMOUNT"))
- +10 DO D(SUBALLOW("D","IEN"))
- End DoDot:1
- IF $GET(OUT)
- QUIT
- +11 QUIT
- D(X) ;----- LOOP THROUGH DEPARTMENT SUBSCRIPT
- +1 ;
- +2 ; X = SUB-ALLOWANCE IEN
- +3 ;
- +4 SET SUBALLOW=X
- +5 SET DEPT=0
- FOR
- SET DEPT=$ORDER(^TMP("ACRFFDH",$JOB,1,APPROP,2,ALLOW,3,SUBALLOW,4,DEPT))
- IF 'DEPT
- QUIT
- Begin DoDot:1
- +6 DO D^ACRFFDH(DEPT)
- +7 IF $Y>(IOSL-5)
- DO HDR
- IF $GET(OUT)
- QUIT
- +8 WRITE !," DEPT:",?16,"("_DEPT("D","IEN")_") ",?25,DEPT("D","NAME")
- +9 DO WRITE(DEPT("D","FY"),DEPT("D","CREATE FY"),DEPT("D","AMOUNT"))
- End DoDot:1
- IF $GET(OUT)
- QUIT
- +10 QUIT
- WRITE(FY,NFY,AMT) ;
- +1 ;----- WRITES DATA
- +2 ;
- +3 WRITE ?58,FY
- +4 WRITE ?63,$SELECT(NFY=1:"Y",NFY=2:"N",1:"")
- +5 WRITE ?67,$JUSTIFY(AMT,12,2)
- +6 QUIT
- HDR ;----- WRITES HEADER
- +1 ;
- +2 NEW DIR
- +3 IF $EXTRACT(IOST)="C"
- IF $GET(PAGE)
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET OUT=1
- QUIT
- +4 SET PAGE=$GET(PAGE)+1
- +5 WRITE @IOF
- +6 WRITE !,"DISTRIBUTION OF FUNDS HIERARCHICAL STRUCTURE"
- +7 WRITE ?49,$$NOW
- +8 WRITE " PAGE ",PAGE
- +9 WRITE !,"APPROPRIATION: "_APPROP("D","NAME")
- +10 WRITE !!,?58,"FY",?62,"NXT",?73,"AMOUNT"
- +11 WRITE !
- +12 QUIT
- NOW() ;EP -- RETURNS CURRENT DATE/TIME
- +1 ;
- +2 NEW %,%H,%I,X
- +3 DO NOW^%DTC
- +4 SET Y=DT
- +5 XECUTE ^DD("DD")
- +6 QUIT Y_" "_$EXTRACT($PIECE(%,".",2),1,2)_":"_$EXTRACT($PIECE(%,".",2),3,4)
- +7 ;
- QUE(ZTRTN,ZTSAVE,ZTDESC) ;EP;
- +1 ;ACR*2.1*13.02 IM13574
- QUIT
- +2 ;----- QUEUEING CODE
- +3 ;
- +4 NEW %ZIS,IO,POP,ZTIO,ZTSK
- +5 SET %ZIS="Q"
- DO ^%ZIS
- IF POP
- QUIT
- +6 IF $DATA(IO("Q"))
- KILL IO("Q")
- SET ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
- DO ^%ZTLOAD
- IF $GET(ZTSK)
- WRITE !,"Task #",$GET(ZTSK)," queued"
- +7 IF '$TEST
- DO @ZTRTN
- +8 QUIT