Routine: ACRFFDH

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

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

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")

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")

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")

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")

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)

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)

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"

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)

QUIT ;----- CLEAN UP, CLOSE DEVICE, QUIT JOB

 K ZTSAVE

 K ^TMP("ACRFFDH",$J)

 D ^%ZISC

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

ACRFFDH.m