ASURM17P ; IHS/ITSC/LMH - REPORT 17 AREA MONTHLY SUB-SUB-ACTIVITY ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;;Y2K/OK AEF/2970311
;This routine produces report #17, Area Monthly Sub-Sub-Activity
;Report
;
;
EN ;EP -- MAIN ENTRY POINT (USER INTERACTIVE)
;
N ASUDT,ASUTYP
D ^XBKVAR,HOME^%ZIS
D SELXTRCT^ASUUTIL G QUIT:'$G(ASUDT)
W !,*7,"THIS REPORT REQUIRES 132 COLUMNS!"
S (ZTSAVE("ASUDT"),ZTSAVE("ASUTYP"))=""
D QUE^ASUUTIL("DQ^ASURM17P",.ZTSAVE,"SAMS RPT #17 - AREA MONTHLY SUB-SUB-ACTIVITY REPORT")
D QUIT
Q
EN1(ASUDT,ASUTYP) ;EP
;----- ENTRY POINT CALLED BY ^ASURMSTD (NON-USER INTERACTIVE)
;
DQ ;EP -- QUEUED JOB STARTS HERE
;
; ASUDT = report extract date or month
; ASUTYP = type of report, I=individual extract, M=monthly
;
N ASU,ASUD
D ^XBKVAR
D GET,PRT,QUIT
Q
GET ;EP ; GATHER DATA
;
; Main loop through ASUTRN ISSUE, ASUTRN DIRECT ISSUE, and
; ASUTRN RECEIPTS files
;
; ASU("DT","BEG") = beginning date of fiscal year
; ASU("DT","END") = ending date of fiscal year
; ASU("DT","FY") = fiscal year
; ASU0 = transaction type where:
; 2 = RECEIPTS
; 3 = ISSUE
; 7 = DIRECT ISSUE
; ASU1 = extracted date in 'AX' crossreference
; ASU2 = internal file entry number
; ASUD("TRANS") = transaction type
; ASUD("STATUS") = transaction status
;
N ASU0,ASU1,ASU2
K ^XTMP("ASUR","R17")
D DT^ASUUTIL(.ASUDT,ASUTYP)
Q:'$D(ASUDT("DXTRACT"))
S (ASU("DT","BEG"),ASU("DT","END"))=$E(ASU("DT","FY"),1,3)
S ASU("DT","BEG")=ASU("DT","BEG")-1_"0999"
S ASU("DT","END")=ASU("DT","END")_"0999"
D TC16^ASUUTIL
S ASU1=ASU("DT","BEG")
F S ASU1=$O(^ASUTH("AX",ASU1)) Q:'ASU1 Q:ASU1>ASU("DT","END") D
. S ASU2=0 F S ASU2=$O(^ASUTH("AX",ASU1,ASU2)) Q:'ASU2 D
. . S ASUD("TRANS")=$P($G(^ASUH(ASU2,1)),U),ASU0=$E(ASUD("TRANS")) S:ASU0=0 ASU0=7
. . I ASU0'=2&(ASU0'=3)&(ASU0'=7) Q
. . D DATA16^ASUUTIL(ASU2)
. . Q:'$D(ASU("TC",ASUD("TRANS")))
. . Q:ASUD("STATUS")=""
. . Q:"UX"'[ASUD("STATUS")
. . D SET
Q
SET ;----- SETS DATA INTO ^XTMP("ASUR","R17") GLOBAL
;
; Sorts and totals the transaction data and sets it into the
; ^XTMP("ASUR","R17") global
;
; ASU = array where date and transaction code data is stored
; ASUD = array where transaction data is stored
; ASU1 = transaction date
; ASUPC = piece designation in ^TMP global where totals are
; stored, the piece corresponds to the column on the
; report
; ASUPCM = piece in ^TMP global to put monthly totals (1-7)
; ASUPCY = piece in ^TMP global to put yearly todays (8-14)
; ASUDT("DXTRACT") = array containing extract dates
; ASUD("VAL") = transaction amount
;
N ASUPC,ASUPCM,ASUPCY
S ASUPCY=ASU("TC",ASUD("TRANS"))+7
S ASUPCM=0 S:$D(ASUDT("DXTRACT",ASU1)) ASUPCM=ASU("TC",ASUD("TRANS"))
F ASUPC=ASUPCM,ASUPCY D
. S $P(^XTMP("ASUR","R17",2,ASUD("AREA"),ASUD("ACC"),0),U,ASUPC)=$P($G(^XTMP("ASUR","R17",2,ASUD("AREA"),ASUD("ACC"),0)),U,ASUPC)+ASUD("VAL")
. S $P(^XTMP("ASUR","R17",1,ASUD("AREA"),0),U,ASUPC)=$P($G(^XTMP("ASUR","R17",1,ASUD("AREA"),0)),U,ASUPC)+ASUD("VAL")
. S $P(^XTMP("ASUR","R17",1,ASUD("AREA"),ASUD("SSA"),0),U,ASUPC)=$P($G(^XTMP("ASUR","R17",1,ASUD("AREA"),ASUD("SSA"),0)),U,ASUPC)+ASUD("VAL")
. S $P(^XTMP("ASUR","R17",1,ASUD("AREA"),ASUD("SSA"),ASUD("ACC"),0),U,ASUPC)=$P($G(^XTMP("ASUR","R17",1,ASUD("AREA"),ASUD("SSA"),ASUD("ACC"),0)),U,ASUPC)+ASUD("VAL")
Q
PRT ;----- PRINT THE DATA
;
; ASUL = loop counter array
; ASUPAGE = report page number
; ASUOUT = '^' to escape controller
; ASUDATA = temporary data storage
; ASUD("ACC") = general ledger account number
; ASUHDR = array containing report header segments
;
N ASUL,ASUPAGE,ASUOUT,ASUHDR
S ASUOUT=0
I '$D(^XTMP("ASUR","R17")) W !!,"NO DATA FOR REPORT 17" Q
;
S ASUHDR(1)="REPORT #17 AREA MONTHLY SUB-SUB-ACTIVITY REPORT"
S ASUHDR(2)="AREA "_ASUD("AREA")
S ASUHDR(4)="SUB G L"
S ASUHDR(5)="SUB ACC"
S ASUHDR(6)="ACT CODE"
;
D LOOPS
Q
LOOPS ;----- LOOPS THROUGH ^XTMP("ASUR","R17") GLOBAL AND PRINTS THE
; REPORT
;
1 ;----- LOOP THROUGH AREA SUBSCRIPT
;
N ASUDATA
S ASUL(1)="" F S ASUL(1)=$O(^XTMP("ASUR","R17",1,ASUL(1))) Q:ASUL(1)']"" D Q:ASUOUT
. Q:ASUL(1)=0
. D HDR16^ASUUTIL(ASUDT,ASUTYP,.ASUPAGE,.ASUHDR,.ASUOUT)
. D 2 Q:ASUOUT
. D HDR16^ASUUTIL(ASUDT,ASUTYP,.ASUPAGE,.ASUHDR,ASUOUT)
. S ASUD("ACC")="" F S ASUD("ACC")=$O(^XTMP("ASUR","R17",2,ASUL(1),ASUD("ACC"))) Q:ASUD("ACC")']"" D Q:ASUOUT
. . I $Y>(IOSL-5) D HDR16^ASUUTIL(ASUDT,ASUTYP,.ASUPAGE,.ASUHDR,.ASUOUT)
. . W !,"ALL ACCT ",$P(ASUD("ACC"),".",2)
. . S ASUDATA=^XTMP("ASUR","R17",2,ASUL(1),ASUD("ACC"),0)
. . D WRITE16^ASUUTIL(ASUDATA)
. I $Y>(IOSL-5) D HDR16^ASUUTIL(ASUDT,ASUTYP,.ASUPAGE,.ASUHDR,.ASUOUT)
. W !,"AREA TOTAL"
. S ASUDATA=^XTMP("ASUR","R17",1,ASUL(1),0)
. D WRITE16^ASUUTIL(ASUDATA)
Q
2 ;----- LOOP THROUGH SUB-SUB-ACTIVITY SUBSCRIPT
;
S ASUL(2)="" F S ASUL(2)=$O(^XTMP("ASUR","R17",1,ASUL(1),ASUL(2))) Q:ASUL(2)']"" D Q:ASUOUT
. Q:ASUL(2)=0
. D 3 Q:ASUOUT
Q
3 ;----- LOOP THROUGH GENERAL LEDGER ACCOUNT SUBSCRIPT
;
N ASUDATA
S ASUL(3)="" F S ASUL(3)=$O(^XTMP("ASUR","R17",1,ASUL(1),ASUL(2),ASUL(3))) Q:ASUL(3)']"" D Q:ASUOUT
. Q:ASUL(3)=0
. S ASUDATA=^XTMP("ASUR","R17",1,ASUL(1),ASUL(2),ASUL(3),0)
. I $Y>(IOSL-5) D HDR16^ASUUTIL(ASUDT,ASUTYP,.ASUPAGE,.ASUHDR,.ASUOUT) Q:ASUOUT
. W !?1,$S(ASUL(2)="UNK":"",1:$P(ASUL(2)," ")),?8,$S(ASUL(3)="UNK":"",1:$P(ASUL(3),".",2))
. D WRITE16^ASUUTIL(ASUDATA)
Q
QUIT ;----- CLEAN UP VARIABLES, CLOSE DEVICE, QUIT
;
K ZTSAVE
K ^XTMP("ASUR","R17")
I $G(ASUK("PTRSEL"))]"" W @IOF Q
D ^%ZISC
Q
ASURM17P ; IHS/ITSC/LMH - REPORT 17 AREA MONTHLY SUB-SUB-ACTIVITY ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;;Y2K/OK AEF/2970311
+3 ;This routine produces report #17, Area Monthly Sub-Sub-Activity
+4 ;Report
+5 ;
+6 ;
EN ;EP -- MAIN ENTRY POINT (USER INTERACTIVE)
+1 ;
+2 NEW ASUDT,ASUTYP
+3 DO ^XBKVAR
DO HOME^%ZIS
+4 DO SELXTRCT^ASUUTIL
IF '$GET(ASUDT)
GOTO QUIT
+5 WRITE !,*7,"THIS REPORT REQUIRES 132 COLUMNS!"
+6 SET (ZTSAVE("ASUDT"),ZTSAVE("ASUTYP"))=""
+7 DO QUE^ASUUTIL("DQ^ASURM17P",.ZTSAVE,"SAMS RPT #17 - AREA MONTHLY SUB-SUB-ACTIVITY REPORT")
+8 DO QUIT
+9 QUIT
EN1(ASUDT,ASUTYP) ;EP
+1 ;----- ENTRY POINT CALLED BY ^ASURMSTD (NON-USER INTERACTIVE)
+2 ;
DQ ;EP -- QUEUED JOB STARTS HERE
+1 ;
+2 ; ASUDT = report extract date or month
+3 ; ASUTYP = type of report, I=individual extract, M=monthly
+4 ;
+5 NEW ASU,ASUD
+6 DO ^XBKVAR
+7 DO GET
DO PRT
DO QUIT
+8 QUIT
GET ;EP ; GATHER DATA
+1 ;
+2 ; Main loop through ASUTRN ISSUE, ASUTRN DIRECT ISSUE, and
+3 ; ASUTRN RECEIPTS files
+4 ;
+5 ; ASU("DT","BEG") = beginning date of fiscal year
+6 ; ASU("DT","END") = ending date of fiscal year
+7 ; ASU("DT","FY") = fiscal year
+8 ; ASU0 = transaction type where:
+9 ; 2 = RECEIPTS
+10 ; 3 = ISSUE
+11 ; 7 = DIRECT ISSUE
+12 ; ASU1 = extracted date in 'AX' crossreference
+13 ; ASU2 = internal file entry number
+14 ; ASUD("TRANS") = transaction type
+15 ; ASUD("STATUS") = transaction status
+16 ;
+17 NEW ASU0,ASU1,ASU2
+18 KILL ^XTMP("ASUR","R17")
+19 DO DT^ASUUTIL(.ASUDT,ASUTYP)
+20 IF '$DATA(ASUDT("DXTRACT"))
QUIT
+21 SET (ASU("DT","BEG"),ASU("DT","END"))=$EXTRACT(ASU("DT","FY"),1,3)
+22 SET ASU("DT","BEG")=ASU("DT","BEG")-1_"0999"
+23 SET ASU("DT","END")=ASU("DT","END")_"0999"
+24 DO TC16^ASUUTIL
+25 SET ASU1=ASU("DT","BEG")
+26 FOR
SET ASU1=$ORDER(^ASUTH("AX",ASU1))
IF 'ASU1
QUIT
IF ASU1>ASU("DT","END")
QUIT
Begin DoDot:1
+27 SET ASU2=0
FOR
SET ASU2=$ORDER(^ASUTH("AX",ASU1,ASU2))
IF 'ASU2
QUIT
Begin DoDot:2
+28 SET ASUD("TRANS")=$PIECE($GET(^ASUH(ASU2,1)),U)
SET ASU0=$EXTRACT(ASUD("TRANS"))
IF ASU0=0
SET ASU0=7
+29 IF ASU0'=2&(ASU0'=3)&(ASU0'=7)
QUIT
+30 DO DATA16^ASUUTIL(ASU2)
+31 IF '$DATA(ASU("TC",ASUD("TRANS")))
QUIT
+32 IF ASUD("STATUS")=""
QUIT
+33 IF "UX"'[ASUD("STATUS")
QUIT
+34 DO SET
End DoDot:2
End DoDot:1
+35 QUIT
SET ;----- SETS DATA INTO ^XTMP("ASUR","R17") GLOBAL
+1 ;
+2 ; Sorts and totals the transaction data and sets it into the
+3 ; ^XTMP("ASUR","R17") global
+4 ;
+5 ; ASU = array where date and transaction code data is stored
+6 ; ASUD = array where transaction data is stored
+7 ; ASU1 = transaction date
+8 ; ASUPC = piece designation in ^TMP global where totals are
+9 ; stored, the piece corresponds to the column on the
+10 ; report
+11 ; ASUPCM = piece in ^TMP global to put monthly totals (1-7)
+12 ; ASUPCY = piece in ^TMP global to put yearly todays (8-14)
+13 ; ASUDT("DXTRACT") = array containing extract dates
+14 ; ASUD("VAL") = transaction amount
+15 ;
+16 NEW ASUPC,ASUPCM,ASUPCY
+17 SET ASUPCY=ASU("TC",ASUD("TRANS"))+7
+18 SET ASUPCM=0
IF $DATA(ASUDT("DXTRACT",ASU1))
SET ASUPCM=ASU("TC",ASUD("TRANS"))
+19 FOR ASUPC=ASUPCM,ASUPCY
Begin DoDot:1
+20 SET $PIECE(^XTMP("ASUR","R17",2,ASUD("AREA"),ASUD("ACC"),0),U,ASUPC)=$PIECE($GET(^XTMP("ASUR","R17",2,ASUD("AREA"),ASUD("ACC"),0)),U,ASUPC)+ASUD("VAL")
+21 SET $PIECE(^XTMP("ASUR","R17",1,ASUD("AREA"),0),U,ASUPC)=$PIECE($GET(^XTMP("ASUR","R17",1,ASUD("AREA"),0)),U,ASUPC)+ASUD("VAL")
+22 SET $PIECE(^XTMP("ASUR","R17",1,ASUD("AREA"),ASUD("SSA"),0),U,ASUPC)=$PIECE($GET(^XTMP("ASUR","R17",1,ASUD("AREA"),ASUD("SSA"),0)),U,ASUPC)+ASUD("VAL")
+23 SET $PIECE(^XTMP("ASUR","R17",1,ASUD("AREA"),ASUD("SSA"),ASUD("ACC"),0),U,ASUPC)=$PIECE($GET(^XTMP("ASUR","R17",1,ASUD("AREA"),ASUD("SSA"),ASUD("ACC"),0)),U,ASUPC)+ASUD("VAL")
End DoDot:1
+24 QUIT
PRT ;----- PRINT THE DATA
+1 ;
+2 ; ASUL = loop counter array
+3 ; ASUPAGE = report page number
+4 ; ASUOUT = '^' to escape controller
+5 ; ASUDATA = temporary data storage
+6 ; ASUD("ACC") = general ledger account number
+7 ; ASUHDR = array containing report header segments
+8 ;
+9 NEW ASUL,ASUPAGE,ASUOUT,ASUHDR
+10 SET ASUOUT=0
+11 IF '$DATA(^XTMP("ASUR","R17"))
WRITE !!,"NO DATA FOR REPORT 17"
QUIT
+12 ;
+13 SET ASUHDR(1)="REPORT #17 AREA MONTHLY SUB-SUB-ACTIVITY REPORT"
+14 SET ASUHDR(2)="AREA "_ASUD("AREA")
+15 SET ASUHDR(4)="SUB G L"
+16 SET ASUHDR(5)="SUB ACC"
+17 SET ASUHDR(6)="ACT CODE"
+18 ;
+19 DO LOOPS
+20 QUIT
LOOPS ;----- LOOPS THROUGH ^XTMP("ASUR","R17") GLOBAL AND PRINTS THE
+1 ; REPORT
+2 ;
1 ;----- LOOP THROUGH AREA SUBSCRIPT
+1 ;
+2 NEW ASUDATA
+3 SET ASUL(1)=""
FOR
SET ASUL(1)=$ORDER(^XTMP("ASUR","R17",1,ASUL(1)))
IF ASUL(1)']""
QUIT
Begin DoDot:1
+4 IF ASUL(1)=0
QUIT
+5 DO HDR16^ASUUTIL(ASUDT,ASUTYP,.ASUPAGE,.ASUHDR,.ASUOUT)
+6 DO 2
IF ASUOUT
QUIT
+7 DO HDR16^ASUUTIL(ASUDT,ASUTYP,.ASUPAGE,.ASUHDR,ASUOUT)
+8 SET ASUD("ACC")=""
FOR
SET ASUD("ACC")=$ORDER(^XTMP("ASUR","R17",2,ASUL(1),ASUD("ACC")))
IF ASUD("ACC")']""
QUIT
Begin DoDot:2
+9 IF $Y>(IOSL-5)
DO HDR16^ASUUTIL(ASUDT,ASUTYP,.ASUPAGE,.ASUHDR,.ASUOUT)
+10 WRITE !,"ALL ACCT ",$PIECE(ASUD("ACC"),".",2)
+11 SET ASUDATA=^XTMP("ASUR","R17",2,ASUL(1),ASUD("ACC"),0)
+12 DO WRITE16^ASUUTIL(ASUDATA)
End DoDot:2
IF ASUOUT
QUIT
+13 IF $Y>(IOSL-5)
DO HDR16^ASUUTIL(ASUDT,ASUTYP,.ASUPAGE,.ASUHDR,.ASUOUT)
+14 WRITE !,"AREA TOTAL"
+15 SET ASUDATA=^XTMP("ASUR","R17",1,ASUL(1),0)
+16 DO WRITE16^ASUUTIL(ASUDATA)
End DoDot:1
IF ASUOUT
QUIT
+17 QUIT
2 ;----- LOOP THROUGH SUB-SUB-ACTIVITY SUBSCRIPT
+1 ;
+2 SET ASUL(2)=""
FOR
SET ASUL(2)=$ORDER(^XTMP("ASUR","R17",1,ASUL(1),ASUL(2)))
IF ASUL(2)']""
QUIT
Begin DoDot:1
+3 IF ASUL(2)=0
QUIT
+4 DO 3
IF ASUOUT
QUIT
End DoDot:1
IF ASUOUT
QUIT
+5 QUIT
3 ;----- LOOP THROUGH GENERAL LEDGER ACCOUNT SUBSCRIPT
+1 ;
+2 NEW ASUDATA
+3 SET ASUL(3)=""
FOR
SET ASUL(3)=$ORDER(^XTMP("ASUR","R17",1,ASUL(1),ASUL(2),ASUL(3)))
IF ASUL(3)']""
QUIT
Begin DoDot:1
+4 IF ASUL(3)=0
QUIT
+5 SET ASUDATA=^XTMP("ASUR","R17",1,ASUL(1),ASUL(2),ASUL(3),0)
+6 IF $Y>(IOSL-5)
DO HDR16^ASUUTIL(ASUDT,ASUTYP,.ASUPAGE,.ASUHDR,.ASUOUT)
IF ASUOUT
QUIT
+7 WRITE !?1,$SELECT(ASUL(2)="UNK":"",1:$PIECE(ASUL(2)," ")),?8,$SELECT(ASUL(3)="UNK":"",1:$PIECE(ASUL(3),".",2))
+8 DO WRITE16^ASUUTIL(ASUDATA)
End DoDot:1
IF ASUOUT
QUIT
+9 QUIT
QUIT ;----- CLEAN UP VARIABLES, CLOSE DEVICE, QUIT
+1 ;
+2 KILL ZTSAVE
+3 KILL ^XTMP("ASUR","R17")
+4 IF $GET(ASUK("PTRSEL"))]""
WRITE @IOF
QUIT
+5 DO ^%ZISC
+6 QUIT
