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
