ACRFFDH ;IHS/OIRM/DSD/AEF - PRINT FUNDS DISTRIBUTION ACCOUNTS HIERARCHICAL STRUCTURE [ 10/27/2004 4:18 PM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**5,13**;NOV 05, 2001
;;SPECIAL DIAGNOSTIC REPORTS
;
;
;This routine loops through the FMS Department, FMS Sub-Allowance, FMS
;Allowance and FMS Appropriation files and produces a report showing
;the hierarchical structure of the accounts
;
EN ;EP -- MAIN ENTRY POINT
;
N X,Y,ZTDESC,ZTRTN,ZTSAVE
D ^XBKVAR,HOME^%ZIS
D QUE^ACRFUTL("DQ^ACRFFDH",.ZTSAVE,"FUNDS DISTRIBUTION REPORT") ;ACR*2.1*13.02 IM13574
Q
DQ ;EP -- QUEUED JOB STARTS HERE
;
N ALLOW,APPROP,DEPT,SUBALLOW
K ^TMP("ACRFFDH",$J)
D DEPT
D SUB
D ALLOW
D APP
I $D(^TMP("ACRFFDH",$J)) D ^ACRFFDH1
D QUIT
Q
DEPT ;----- LOOP THROUGH DEPARTMENT FILE
;
S DEPT("D","IEN")=0 F S DEPT("D","IEN")=$O(^ACRLOCB(DEPT("D","IEN"))) Q:'DEPT("D","IEN") D
. D D(DEPT("D","IEN"))
. S ^TMP("ACRFFDH",$J,4,DEPT("D","IEN"),0)=DEPT("D","FY")_U_DEPT("D","CREATE FY")_U_DEPT("D","AMOUNT")_U_U_U_DEPT("D","SUBALLOW IEN")
. I $G(DEPT("D","SUBALLOW IEN")) D
. . D S(DEPT("D","SUBALLOW IEN"))
. . S ^TMP("ACRFFDH",$J,3,SUBALLOW("D","IEN"),4,DEPT("D","IEN"),0)=DEPT("D","FY")_U_DEPT("D","CREATE FY")_U_DEPT("D","AMOUNT")_U_U_U_DEPT("D","SUBALLOW IEN")
. I $G(SUBALLOW("D","ALLOW IEN")) D
. . D A(SUBALLOW("D","ALLOW IEN"))
. . S ^TMP("ACRFFDH",$J,2,ALLOW("D","IEN"),3,SUBALLOW("D","IEN"),4,DEPT("D","IEN"),0)=DEPT("D","FY")_U_DEPT("D","CREATE FY")_U_DEPT("D","AMOUNT")_U_U_U_DEPT("D","SUBALLOW IEN")
. I $G(ALLOW("D","APPROP IEN")) D
. . D P(ALLOW("D","APPROP IEN"))
. . S ^TMP("ACRFFDH",$J,1,APPROP("D","IEN"),2,ALLOW("D","IEN"),3,SUBALLOW("D","IEN"),4,DEPT("D","IEN"),0)=DEPT("D","FY")_U_DEPT("D","CREATE FY")_U_DEPT("D","AMOUNT")_U_U_U_DEPT("D","SUBALLOW IEN")
Q
SUB ;EP -- LOOP THROUGH SUB-ALLOWANCE FILE
;
S SUBALLOW("D","IEN")=0 F S SUBALLOW("D","IEN")=$O(^ACRALC(SUBALLOW("D","IEN"))) Q:'SUBALLOW("D","IEN") D
. D S(SUBALLOW("D","IEN"))
. S ^TMP("ACRFFDH",$J,3,SUBALLOW("D","IEN"),0)=SUBALLOW("D","FY")_U_SUBALLOW("D","CREATE FY")_U_SUBALLOW("D","AMOUNT")_U_U_SUBALLOW("D","ALLOW IEN")
. I $G(SUBALLOW("D","ALLOW IEN")) D
. . D A(SUBALLOW("D","ALLOW IEN"))
. . S ^TMP("ACRFFDH",$J,2,ALLOW("D","IEN"),3,SUBALLOW("D","IEN"),0)=SUBALLOW("D","FY")_U_SUBALLOW("D","CREATE FY")_U_SUBALLOW("D","AMOUNT")_U_U_SUBALLOW("D","ALLOW IEN")
. I $G(ALLOW("D","APPROP IEN")) D
. . D P(ALLOW("D","APPROP IEN"))
. . S ^TMP("ACRFFDH",$J,1,APPROP("D","IEN"),2,ALLOW("D","IEN"),3,SUBALLOW("D","IEN"),0)=SUBALLOW("D","FY")_U_SUBALLOW("D","CREATE FY")_U_SUBALLOW("D","AMOUNT")_U_U_SUBALLOW("D","ALLOW IEN")
Q
ALLOW ;EP -- LOOP THROUGH ALLOWANCE FILE
;
S ALLOW("D","IEN")=0 F S ALLOW("D","IEN")=$O(^ACRALW(ALLOW("D","IEN"))) Q:'ALLOW("D","IEN") D
. D A(ALLOW("D","IEN"))
. S ^TMP("ACRFFDH",$J,2,ALLOW("D","IEN"),0)=ALLOW("D","FY")_U_ALLOW("D","CREATE FY")_U_ALLOW("D","AMOUNT")_U_ALLOW("D","APPROP IEN")
. I $G(ALLOW("D","APPROP IEN")) D
. . D P(ALLOW("D","APPROP IEN"))
. . S ^TMP("ACRFFDH",$J,1,APPROP("D","IEN"),2,ALLOW("D","IEN"),0)=ALLOW("D","FY")_U_ALLOW("D","CREATE FY")_U_ALLOW("D","AMOUNT")_U_ALLOW("D","APPROP IEN")
Q
APP ;EP -- LOOP THROUGH APPROPRIATION FILE
;
S APPROP("D","IEN")=0 F S APPROP("D","IEN")=$O(^ACRAPP(APPROP("D","IEN"))) Q:'APPROP("D","IEN") D
. D P(APPROP("D","IEN"))
. S ^TMP("ACRFFDH",$J,1,APPROP("D","IEN"),0)=APPROP("D","FY")_U_APPROP("D","CREATE FY")_U_APPROP("D","AMOUNT")
Q
D(X) ;----- SET DEPARTMENT VARIABLES
;
; X = DEPARTMENT IEN
;
N DATA
K DEPT("D")
S DEPT("D","IEN")=X
S DATA=$G(^ACRLOCB(DEPT("D","IEN"),0))
S DEPT("D","PTR")=$P(DATA,U,5)
I DEPT("D","PTR") S DEPT("D","NAME")=$P($G(^AUTTPRG(DEPT("D","PTR"),0)),U)
I $G(DEPT("D","NAME"))']"" S DEPT("D","NAME")="UNKNOWN"
S DEPT("D","SUBALLOW IEN")=$P(DATA,U,4)
S DEPT("D","AMOUNT")=$P(DATA,U)
S DEPT("D","CREATE FY")=$P(DATA,U,16)
S DEPT("D","FY")=$P($G(^ACRLOCB(DEPT("D","IEN"),"DT")),U)
Q
S(X) ;EP -- SET SUB ALLOWANCE VARIABLES
;
; X = SUBALLOWANCE IEN
;
N DATA
K SUBALLOW("D")
S SUBALLOW("D","IEN")=X
S DATA=$G(^ACRALC(SUBALLOW("D","IEN"),0))
S SUBALLOW("D","NAME")=$P(DATA,U,12) ;ACR*2.1*5.16
I SUBALLOW("D","NAME")']"" S SUBALLOW("D","NAME")="UNKNOWN" ;ACR*2.1*5.16
S SUBALLOW("D","ALLOW IEN")=$P(DATA,U,3)
S SUBALLOW("D","AMOUNT")=$P(DATA,U)
S SUBALLOW("D","CREATE FY")=$P(DATA,U,16)
S SUBALLOW("D","FY")=$P($G(^ACRALC(SUBALLOW("D","IEN"),"DT")),U)
Q
A(X) ;EP -- SET ALLOWANCE VARIABLES
;
; X = ALLOWANCE IEN
;
N DATA
K ALLOW("D")
S ALLOW("D","IEN")=X
S DATA=$G(^ACRALW(ALLOW("D","IEN"),0))
S ALLOW("D","NAME")=$P(DATA,U,12) ;ACR*2.1*5.16
S ALLOW("D","APPROP IEN")=$P(DATA,U,2)
S ALLOW("D","AMOUNT")=$P(DATA,U)
S ALLOW("D","CREATE FY")=$P(DATA,U,16)
S DATA=$G(^ACRALW(ALLOW("D","IEN"),"DT"))
S ALLOW("D","FY")=$P(DATA,U)
S ALLOW("D","PTR")=$P(DATA,U,5)
I ALLOW("D","PTR")]"" S ALLOW("D","NAME")=$P($G(^AUTTALLW(ALLOW("D","PTR"),0)),U)_" "_ALLOW("D","NAME") ;ACR*2.1*5.16
I $G(ALLOW("D","NAME"))']"" S ALLOW("D","NAME")="UNKNOWN"
Q
P(X) ;EP -- SET APPROPRIATION VARIABLES
;
; X = APPROPRIATION IEN
;
N DATA
K APPROP("D")
S APPROP("D","IEN")=X
S DATA=$G(^ACRAPP(APPROP("D","IEN"),0))
S APPROP("D","PTR")=$P(DATA,U,2)
I APPROP("D","PTR")]"" S APPROP("D","NAME")=$P($G(^AUTTPRO(APPROP("D","PTR"),0)),U)
I $G(APPROP("D","NAME"))']"" S APPROP("D","NAME")="UNKNOWN"
S APPROP("D","AMOUNT")=$P(DATA,U)
S APPROP("D","CREATE FY")=$P(DATA,U,16)
S APPROP("D","FY")=$P($G(^ACRAPP(APPROP("D","IEN"),"DT")),U)
Q
QUIT ;----- CLEAN UP, CLOSE DEVICE, QUIT JOB
;
K ZTSAVE
K ^TMP("ACRFFDH",$J)
D ^%ZISC
Q
ACRFFDH ;IHS/OIRM/DSD/AEF - PRINT FUNDS DISTRIBUTION ACCOUNTS HIERARCHICAL STRUCTURE [ 10/27/2004 4:18 PM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**5,13**;NOV 05, 2001
+2 ;;SPECIAL DIAGNOSTIC REPORTS
+3 ;
+4 ;
+5 ;This routine loops through the FMS Department, FMS Sub-Allowance, FMS
+6 ;Allowance and FMS Appropriation files and produces a report showing
+7 ;the hierarchical structure of the accounts
+8 ;
EN ;EP -- MAIN ENTRY POINT
+1 ;
+2 NEW X,Y,ZTDESC,ZTRTN,ZTSAVE
+3 DO ^XBKVAR
DO HOME^%ZIS
+4 ;ACR*2.1*13.02 IM13574
DO QUE^ACRFUTL("DQ^ACRFFDH",.ZTSAVE,"FUNDS DISTRIBUTION REPORT")
+5 QUIT
DQ ;EP -- QUEUED JOB STARTS HERE
+1 ;
+2 NEW ALLOW,APPROP,DEPT,SUBALLOW
+3 KILL ^TMP("ACRFFDH",$JOB)
+4 DO DEPT
+5 DO SUB
+6 DO ALLOW
+7 DO APP
+8 IF $DATA(^TMP("ACRFFDH",$JOB))
DO ^ACRFFDH1
+9 DO QUIT
+10 QUIT
DEPT ;----- LOOP THROUGH DEPARTMENT FILE
+1 ;
+2 SET DEPT("D","IEN")=0
FOR
SET DEPT("D","IEN")=$ORDER(^ACRLOCB(DEPT("D","IEN")))
IF 'DEPT("D","IEN")
QUIT
Begin DoDot:1
+3 DO D(DEPT("D","IEN"))
+4 SET ^TMP("ACRFFDH",$JOB,4,DEPT("D","IEN"),0)=DEPT("D","FY")_U_DEPT("D","CREATE FY")_U_DEPT("D","AMOUNT")_U_U_U_DEPT("D","SUBALLOW IEN")
+5 IF $GET(DEPT("D","SUBALLOW IEN"))
Begin DoDot:2
+6 DO S(DEPT("D","SUBALLOW IEN"))
+7 SET ^TMP("ACRFFDH",$JOB,3,SUBALLOW("D","IEN"),4,DEPT("D","IEN"),0)=DEPT("D","FY")_U_DEPT("D","CREATE FY")_U_DEPT("D","AMOUNT")_U_U_U_DEPT("D","SUBALLOW IEN")
End DoDot:2
+8 IF $GET(SUBALLOW("D","ALLOW IEN"))
Begin DoDot:2
+9 DO A(SUBALLOW("D","ALLOW IEN"))
+10 SET ^TMP("ACRFFDH",$JOB,2,ALLOW("D","IEN"),3,SUBALLOW("D","IEN"),4,DEPT("D","IEN"),0)=DEPT("D","FY")_U_DEPT("D","CREATE FY")_U_DEPT("D","AMOUNT")_U_U_U_DEPT("D","SUBALLOW IEN")
End DoDot:2
+11 IF $GET(ALLOW("D","APPROP IEN"))
Begin DoDot:2
+12 DO P(ALLOW("D","APPROP IEN"))
+13 SET ^TMP("ACRFFDH",$JOB,1,APPROP("D","IEN"),2,ALLOW("D","IEN"),3,SUBALLOW("D","IEN"),4,DEPT("D","IEN"),0)=DEPT("D","FY")_U_DEPT("D","CREATE FY")_U_DEPT("D","AMOUNT")_U_U_U_DEPT("D","SUBALLOW IEN")
End DoDot:2
End DoDot:1
+14 QUIT
SUB ;EP -- LOOP THROUGH SUB-ALLOWANCE FILE
+1 ;
+2 SET SUBALLOW("D","IEN")=0
FOR
SET SUBALLOW("D","IEN")=$ORDER(^ACRALC(SUBALLOW("D","IEN")))
IF 'SUBALLOW("D","IEN")
QUIT
Begin DoDot:1
+3 DO S(SUBALLOW("D","IEN"))
+4 SET ^TMP("ACRFFDH",$JOB,3,SUBALLOW("D","IEN"),0)=SUBALLOW("D","FY")_U_SUBALLOW("D","CREATE FY")_U_SUBALLOW("D","AMOUNT")_U_U_SUBALLOW("D","ALLOW IEN")
+5 IF $GET(SUBALLOW("D","ALLOW IEN"))
Begin DoDot:2
+6 DO A(SUBALLOW("D","ALLOW IEN"))
+7 SET ^TMP("ACRFFDH",$JOB,2,ALLOW("D","IEN"),3,SUBALLOW("D","IEN"),0)=SUBALLOW("D","FY")_U_SUBALLOW("D","CREATE FY")_U_SUBALLOW("D","AMOUNT")_U_U_SUBALLOW("D","ALLOW IEN")
End DoDot:2
+8 IF $GET(ALLOW("D","APPROP IEN"))
Begin DoDot:2
+9 DO P(ALLOW("D","APPROP IEN"))
+10 SET ^TMP("ACRFFDH",$JOB,1,APPROP("D","IEN"),2,ALLOW("D","IEN"),3,SUBALLOW("D","IEN"),0)=SUBALLOW("D","FY")_U_SUBALLOW("D","CREATE FY")_U_SUBALLOW("D","AMOUNT")_U_U_SUBALLOW("D","ALLOW IEN")
End DoDot:2
End DoDot:1
+11 QUIT
ALLOW ;EP -- LOOP THROUGH ALLOWANCE FILE
+1 ;
+2 SET ALLOW("D","IEN")=0
FOR
SET ALLOW("D","IEN")=$ORDER(^ACRALW(ALLOW("D","IEN")))
IF 'ALLOW("D","IEN")
QUIT
Begin DoDot:1
+3 DO A(ALLOW("D","IEN"))
+4 SET ^TMP("ACRFFDH",$JOB,2,ALLOW("D","IEN"),0)=ALLOW("D","FY")_U_ALLOW("D","CREATE FY")_U_ALLOW("D","AMOUNT")_U_ALLOW("D","APPROP IEN")
+5 IF $GET(ALLOW("D","APPROP IEN"))
Begin DoDot:2
+6 DO P(ALLOW("D","APPROP IEN"))
+7 SET ^TMP("ACRFFDH",$JOB,1,APPROP("D","IEN"),2,ALLOW("D","IEN"),0)=ALLOW("D","FY")_U_ALLOW("D","CREATE FY")_U_ALLOW("D","AMOUNT")_U_ALLOW("D","APPROP IEN")
End DoDot:2
End DoDot:1
+8 QUIT
APP ;EP -- LOOP THROUGH APPROPRIATION FILE
+1 ;
+2 SET APPROP("D","IEN")=0
FOR
SET APPROP("D","IEN")=$ORDER(^ACRAPP(APPROP("D","IEN")))
IF 'APPROP("D","IEN")
QUIT
Begin DoDot:1
+3 DO P(APPROP("D","IEN"))
+4 SET ^TMP("ACRFFDH",$JOB,1,APPROP("D","IEN"),0)=APPROP("D","FY")_U_APPROP("D","CREATE FY")_U_APPROP("D","AMOUNT")
End DoDot:1
+5 QUIT
D(X) ;----- SET DEPARTMENT VARIABLES
+1 ;
+2 ; X = DEPARTMENT IEN
+3 ;
+4 NEW DATA
+5 KILL DEPT("D")
+6 SET DEPT("D","IEN")=X
+7 SET DATA=$GET(^ACRLOCB(DEPT("D","IEN"),0))
+8 SET DEPT("D","PTR")=$PIECE(DATA,U,5)
+9 IF DEPT("D","PTR")
SET DEPT("D","NAME")=$PIECE($GET(^AUTTPRG(DEPT("D","PTR"),0)),U)
+10 IF $GET(DEPT("D","NAME"))']""
SET DEPT("D","NAME")="UNKNOWN"
+11 SET DEPT("D","SUBALLOW IEN")=$PIECE(DATA,U,4)
+12 SET DEPT("D","AMOUNT")=$PIECE(DATA,U)
+13 SET DEPT("D","CREATE FY")=$PIECE(DATA,U,16)
+14 SET DEPT("D","FY")=$PIECE($GET(^ACRLOCB(DEPT("D","IEN"),"DT")),U)
+15 QUIT
S(X) ;EP -- SET SUB ALLOWANCE VARIABLES
+1 ;
+2 ; X = SUBALLOWANCE IEN
+3 ;
+4 NEW DATA
+5 KILL SUBALLOW("D")
+6 SET SUBALLOW("D","IEN")=X
+7 SET DATA=$GET(^ACRALC(SUBALLOW("D","IEN"),0))
+8 ;ACR*2.1*5.16
SET SUBALLOW("D","NAME")=$PIECE(DATA,U,12)
+9 ;ACR*2.1*5.16
IF SUBALLOW("D","NAME")']""
SET SUBALLOW("D","NAME")="UNKNOWN"
+10 SET SUBALLOW("D","ALLOW IEN")=$PIECE(DATA,U,3)
+11 SET SUBALLOW("D","AMOUNT")=$PIECE(DATA,U)
+12 SET SUBALLOW("D","CREATE FY")=$PIECE(DATA,U,16)
+13 SET SUBALLOW("D","FY")=$PIECE($GET(^ACRALC(SUBALLOW("D","IEN"),"DT")),U)
+14 QUIT
A(X) ;EP -- SET ALLOWANCE VARIABLES
+1 ;
+2 ; X = ALLOWANCE IEN
+3 ;
+4 NEW DATA
+5 KILL ALLOW("D")
+6 SET ALLOW("D","IEN")=X
+7 SET DATA=$GET(^ACRALW(ALLOW("D","IEN"),0))
+8 ;ACR*2.1*5.16
SET ALLOW("D","NAME")=$PIECE(DATA,U,12)
+9 SET ALLOW("D","APPROP IEN")=$PIECE(DATA,U,2)
+10 SET ALLOW("D","AMOUNT")=$PIECE(DATA,U)
+11 SET ALLOW("D","CREATE FY")=$PIECE(DATA,U,16)
+12 SET DATA=$GET(^ACRALW(ALLOW("D","IEN"),"DT"))
+13 SET ALLOW("D","FY")=$PIECE(DATA,U)
+14 SET ALLOW("D","PTR")=$PIECE(DATA,U,5)
+15 ;ACR*2.1*5.16
IF ALLOW("D","PTR")]""
SET ALLOW("D","NAME")=$PIECE($GET(^AUTTALLW(ALLOW("D","PTR"),0)),U)_" "_ALLOW("D","NAME")
+16 IF $GET(ALLOW("D","NAME"))']""
SET ALLOW("D","NAME")="UNKNOWN"
+17 QUIT
P(X) ;EP -- SET APPROPRIATION VARIABLES
+1 ;
+2 ; X = APPROPRIATION IEN
+3 ;
+4 NEW DATA
+5 KILL APPROP("D")
+6 SET APPROP("D","IEN")=X
+7 SET DATA=$GET(^ACRAPP(APPROP("D","IEN"),0))
+8 SET APPROP("D","PTR")=$PIECE(DATA,U,2)
+9 IF APPROP("D","PTR")]""
SET APPROP("D","NAME")=$PIECE($GET(^AUTTPRO(APPROP("D","PTR"),0)),U)
+10 IF $GET(APPROP("D","NAME"))']""
SET APPROP("D","NAME")="UNKNOWN"
+11 SET APPROP("D","AMOUNT")=$PIECE(DATA,U)
+12 SET APPROP("D","CREATE FY")=$PIECE(DATA,U,16)
+13 SET APPROP("D","FY")=$PIECE($GET(^ACRAPP(APPROP("D","IEN"),"DT")),U)
+14 QUIT
QUIT ;----- CLEAN UP, CLOSE DEVICE, QUIT JOB
+1 ;
+2 KILL ZTSAVE
+3 KILL ^TMP("ACRFFDH",$JOB)
+4 DO ^%ZISC
+5 QUIT
