ASURM15P ; IHS/ITSC/LMH - REPORT 15 MONTHLY COST REPORT ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;;Y2K/OK AEF/2970311
;This routine produces report #15, Monthly Cost Report
;
;
EN ;EP -- MAIN ENTRY POINT (USER INTERACTIVE)
;
N ASUDT,ASUTYP
D ^XBKVAR,HOME^%ZIS
D SELXTRCT^ASUUTIL G QUIT:'$D(ASUDT)
W !,*7,"THIS REPORT REQUIRES 132 COLUMNS!"
S ZTSAVE("ASUDT")="",ZTSAVE("ASUTYP")=""
D QUE^ASUUTIL("DQ^ASURM15P",.ZTSAVE,"SAMS RPT #15 - MONTHLY COST 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 and ASUTRN DIRECT ISSUE files
;
; ASU("DT","BEG") = beginning date of fiscal year
; ASU("DT","END") = ending date of fiscal year
; ASU("DT","FY") = fiscal year
; ASU("TC") = array containing allowable transaction codes
; ASU0 = transaction type where:
; 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,ASUI
K ^XTMP("ASUR","R15")
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"
F ASUI=32,33,"3K","3L" S ASU("TC",ASUI)=""
S ASU1=ASU("DT","BEG")
F S ASU1=$O(^ASUH("AX",ASU1)) Q:'ASU1 Q:ASU1>ASU("DT","END") D
. S ASU2=0 F S ASU2=$O(^ASUH("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'=3&(ASU0'=7) Q
. . I ASU0=3 Q:'$D(ASU("TC",ASUD("TRANS")))
. . D DATA16^ASUUTIL(ASU2)
. . Q:ASUD("STATUS")=""
. . Q:"UX"'[ASUD("STATUS")
. . D SET
Q
SET ;----- SETS DATA INTO ^XTMP("ASUR","R15") GLOBAL
;
; Sorts and totals the transaction data and sets it into the
; ^XTMP("ASUR","R15") global
;
; ASU = array containing dates and transaction codes
; ASUD = array containing transaction data
; ASU0 = transaction type where:
; 3 = ISSUE
; 7 = DIRECT ISSUE
; ASU1 = transaction date
; ASUPC = piece designation in ^TMP global where totals are put
; corresponding to report columns where:
; 1 = current month stock issue total
; 2 = fiscal year stock issue total
; 3 = direct issue current month stock issue total
; 4 = direct issue fiscal year direct issue total
; 5 = fuel oil current month total
; 6 = fuel oil fiscal year total
; ASUPCM = month piece (1, 3, or 5)
; ASUPCY = fiscal year piece (2, 4, or 6)
; ASUOOT = root of ^XTMP("ASUR","R15") global for data
; ASUGLOB = the ^XTMP("ASUR","R15") where data is stored
; ASUX = ^TMP global subscript
; ASU("DXTRACT") = array containing extract dates
; ASU("OBJ") = transaction object class code
; ASU("VAL") = transaction amount
;
N ASUGLOB,ASUPC,ASUPCM,ASUPCY,ASUOOT,ASUX
I $D(ASUDT("DXTRACT",ASU1)) D
. I ASU0=3 S ASUPCM=1,ASUPCY=2
. I ASU0=7,ASUD("OBJ")'="268H" S ASUPCM=3,ASUPCY=4
. I ASU0=7,ASUD("OBJ")="268H" S ASUPCM=5,ASUPCY=6
I '$D(ASUDT("DXTRACT",ASU1)) D
. I ASU0=3 S ASUPCM=0,ASUPCY=2
. I ASU0=7,ASUD("OBJ")'="268H" S ASUPCM=0,ASUPCY=4
. I ASU0=7,ASUD("OBJ")="268H" S ASUPCM=0,ASUPCY=6
F ASUPC=ASUPCM,ASUPCY D
. S ASUOOT="^TMP(""ASUR"","_$J_",""R15"","
. F ASUX="AREA","STA","SST","USR","CAN","ACC" D
. . S ASUOOT=ASUOOT_"ASUD("_""""_ASUX_""""_"),"
. . S ASUGLOB=ASUOOT_"0)"
. . S $P(@ASUGLOB,U,ASUPC)=$P($G(@ASUGLOB),U,ASUPC)+ASUD("VAL")
. I ASU0=7,ASUD("OBJ")'="248H",ASUPC'=ASUPCY D
. . S ASUOOT=ASUOOT_"ASUD("_""""_"OBJ"_""""_"),"
. . S ASUGLOB=ASUOOT_"0)"
. . S $P(@ASUGLOB,U,ASUPC)=$P($G(@ASUGLOB),U,ASUPC)+ASUD("VAL")
Q
PRT ;----- PRINTS THE DATA
;
; ASUL( = loop counter array
; ASUPAGE = report page number
; ASUTOT("ACC") = array where GL account totals are stored
; ASUOUT = '^' to continue controller
; ASUDATA = temporary data storage
;
N ASUL,ASUPAGE,ASUOUT,ASUTOT
S ASUOUT=0
I '$D(^XTMP("ASUR","R15")) W !!,"NO DATA FOR REPORT 15" Q
D LOOPS
Q
LOOPS ;----- Loops 1-7 loop through the ^XTMP("ASUR","R15") global and
; print the report
;
1 ;----- LOOP THROUGH THE AREA SUBSCRIPT
;
N ASUDATA
S ASUL(1)="" F S ASUL(1)=$O(^XTMP("ASUR","R15",ASUL(1))) Q:ASUL(1)']"" D Q:ASUOUT
. Q:ASUL(1)=0
. D 2 Q:ASUOUT
. S ASUDATA=^XTMP("ASUR","R15",ASUL(1),0)
. I $Y>(IOSL-5) D HDR Q:ASUOUT
. W !!,"AREA ",ASUL(1)," TOTALS"
. D WRITE(ASUDATA)
Q
2 ;----- LOOP THROUGH THE STATION SUBSCRIPT
;
N ASUDATA
S ASUL(2)="" F S ASUL(2)=$O(^XTMP("ASUR","R15",ASUL(1),ASUL(2))) Q:ASUL(2)']"" D Q:ASUOUT
. Q:ASUL(2)=0
. D HDR
. D 3 Q:ASUOUT
. S ASUDATA=^XTMP("ASUR","R15",ASUL(1),ASUL(2),0)
. I $Y>(IOSL-5) D HDR Q:ASUOUT
. W !,"STATION ",ASUL(2)," TOTALS"
. D WRITE(ASUDATA)
Q
3 ;----- LOOP THROUGH THE SUB-STATION SUBSCRIPT
;
N ASUDATA
S ASUL(3)="" F S ASUL(3)=$O(^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3))) Q:ASUL(3)']"" D Q:ASUOUT
. Q:ASUL(3)=0
. I $G(ASUPAGE)>1 D HDR
. D 4 Q:ASUOUT
. S ASUDATA=^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),0)
. I $Y>(IOSL-5) D HDR Q:ASUOUT
. W !,"SUB-STATION ",ASUL(3)," TOTALS"
. D WRITE(ASUDATA)
. W !
Q
4 ;----- LOOP THROUGH THE USER SUBSCRIPT
;
N ASUDATA,ASUI
S ASUL(4)="" F S ASUL(4)=$O(^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),ASUL(4))) Q:ASUL(4)']"" D Q:ASUOUT
. Q:ASUL(4)=0
. D 5 Q:ASUOUT
. S ASUI="" F S ASUI=$O(ASUTOT("ACC",ASUL(3),ASUL(4),ASUI)) Q:ASUI']"" D Q:ASUOUT
. . S ASUDATA=ASUTOT("ACC",ASUL(3),ASUL(4),ASUI)
. . I $Y>(IOSL-5) D HDR Q:ASUOUT
. . W !?25,ASUI,?31,"TOTAL"
. . D WRITE(ASUDATA)
. S ASUDATA=^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),ASUL(4),0)
. I $Y>(IOSL-5) D HDR Q:ASUOUT
. W !?8,"USER CODE TOTALS"
. D WRITE(ASUDATA)
. W !
Q
5 ;----- LOOP THROUGH THE CAN SUBSCRIPT
;
N ASUDATA
S ASUL(5)="" F S ASUL(5)=$O(^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),ASUL(4),ASUL(5))) Q:ASUL(5)']"" D Q:ASUOUT
. Q:ASUL(5)=0
. D 6 Q:ASUOUT
. S ASUDATA=^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),ASUL(4),ASUL(5),0)
. I $Y>(IOSL-5) D HDR Q:ASUOUT
. W !?17,"CAN TOTALS"
. D WRITE(ASUDATA)
. W !
Q
6 ;----- LOOP THROUGH THE GL ACCOUNT SUBSCRIPT
;
N ASUDATA,ASUI
S ASUL(6)="" F S ASUL(6)=$O(^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),ASUL(4),ASUL(5),ASUL(6))) Q:ASUL(6)']"" D Q:ASUOUT
. Q:ASUL(6)=0
. D 7 Q:ASUOUT
. S ASUDATA=^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),ASUL(4),ASUL(5),ASUL(6),0)
. F ASUI=1:1:6 D
. . S $P(ASUTOT("ACC",ASUL(3),ASUL(4),ASUL(6)),U,ASUI)=$P($G(ASUTOT("ACC",ASUL(3),ASUL(4),ASUL(6))),U,ASUI)+$P(ASUDATA,U,ASUI)
. I $Y>(IOSL-5) D HDR Q:ASUOUT
. W !?2,$E(ASUL(3),1,2),?8,ASUL(4),?17,ASUL(5),?25,ASUL(6),?31,"TOTAL"
. D WRITE(ASUDATA)
Q
7 ;----- LOOP THROUGH THE SUBOBJECT SUBSCRIPT
;
N ASUDATA
S ASUL(7)="" F S ASUL(7)=$O(^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),ASUL(4),ASUL(5),ASUL(6),ASUL(7))) Q:ASUL(7)']"" D Q:ASUOUT
. Q:ASUL(7)=0
. S ASUDATA=^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),ASUL(4),ASUL(5),ASUL(6),ASUL(7),0)
. I $Y>(IOSL-5) D HDR Q:ASUOUT
. W !?2,$E(ASUL(3),1,2),?8,ASUL(4),?17,ASUL(5),?25,ASUL(6),?38,$J($P(ASUDATA,U),10,2),?66,$S(ASUL(7)="268H":"",1:$E(ASUL(7),3,4))
. W ?70,$J($P(ASUDATA,U,3),10,2),?84,$J($P(ASUDATA,U,4),10,2),?104,$J($P(ASUDATA,U,5),10,2),?118,$J($P(ASUDATA,U,6),10,2)
Q
WRITE(X) ;----- WRITES TOTALS
;
W ?38,$J($P(X,U),10,2),?52,$J($P(X,U,2),10,2),?70,$J($P(X,U,3),10,2),?84,$J($P(X,U,4),10,2),?104,$J($P(X,U,5),10,2),?118,$J($P(X,U,6),10,2)
Q
HDR ;----- WRITES REPORT HEADER
;
N %,DIR,X,Y
I $E(IOST)="C",$G(ASUPAGE) S DIR(0)="E" D ^DIR K DIR I 'Y S ASUOUT=1 Q
S ASUPAGE=$G(ASUPAGE)+1
W @IOF
W "REPORT #15 MONTHLY COST REPORT FOR ",$S(ASUTYP="M":"MONTH ",ASUTYP="I":"EXTRACT DATE ",1:"")
S Y=ASUDT X ^DD("DD") W Y
W ?116,"PAGE ",$J(ASUPAGE,6)
W !,"AREA ",$G(ASUL(1)),!,"STAT ",$G(ASUL(2))
W !!,"SUB",?18,"COMMON",?27,"G L",?33,"STOCK ISSUES-OBJECT CLASS 26",?65,"DIRECT ISSUES-OBJECT CLASS 26",?101,"FUEL OIL OBJ-SUBOBJ 26.8H"
W !,"STAT",?8,"USER",?14,"ACCOUNTING",?26,"ACCT",?34,"CURRENT MONTH",?54,"YEAR-TO-",?66,"CURRENT MONTH",?87,"YEAR-TO-",?100,"CURRENT MONTH",?121,"YEAR-TO-"
W !,"CODE",?8,"CODE",?18,"NUMBER",?27,"NO.",?32,"SUBOBJ",?43,"VALUE",?52,"DATE VALUE",?64,"SUBOBJ",?75,"VALUE",?85,"DATE VALUE",?97,"SUBOBJ",?109,"VALUE",?119,"DATE VALUE"
W !
Q
QUIT ;----- CLEAN UP VARIABLES, CLOSE DEVICE, QUIT
;
K ZTSAVE
K ^XTMP("ASUR","R15")
I $G(ASUK("PTRSEL"))]"" W @IOF Q
D ^%ZISC
Q
ASURM15P ; IHS/ITSC/LMH - REPORT 15 MONTHLY COST REPORT ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;;Y2K/OK AEF/2970311
+3 ;This routine produces report #15, Monthly Cost Report
+4 ;
+5 ;
EN ;EP -- MAIN ENTRY POINT (USER INTERACTIVE)
+1 ;
+2 NEW ASUDT,ASUTYP
+3 DO ^XBKVAR
DO HOME^%ZIS
+4 DO SELXTRCT^ASUUTIL
IF '$DATA(ASUDT)
GOTO QUIT
+5 WRITE !,*7,"THIS REPORT REQUIRES 132 COLUMNS!"
+6 SET ZTSAVE("ASUDT")=""
SET ZTSAVE("ASUTYP")=""
+7 DO QUE^ASUUTIL("DQ^ASURM15P",.ZTSAVE,"SAMS RPT #15 - MONTHLY COST 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 and ASUTRN DIRECT ISSUE files
+3 ;
+4 ; ASU("DT","BEG") = beginning date of fiscal year
+5 ; ASU("DT","END") = ending date of fiscal year
+6 ; ASU("DT","FY") = fiscal year
+7 ; ASU("TC") = array containing allowable transaction codes
+8 ; ASU0 = transaction type where:
+9 ; 3 = ISSUE
+10 ; 7 = DIRECT ISSUE
+11 ; ASU1 = extracted date in 'AX' crossreference
+12 ; ASU2 = internal file entry number
+13 ; ASUD("TRANS") = transaction type
+14 ; ASUD("STATUS") = transaction status
+15 ;
+16 NEW ASU0,ASU1,ASU2,ASUI
+17 KILL ^XTMP("ASUR","R15")
+18 DO DT^ASUUTIL(.ASUDT,ASUTYP)
+19 IF '$DATA(ASUDT("DXTRACT"))
QUIT
+20 SET (ASU("DT","BEG"),ASU("DT","END"))=$EXTRACT(ASU("DT","FY"),1,3)
+21 SET ASU("DT","BEG")=(ASU("DT","BEG")-1)_"0999"
+22 SET ASU("DT","END")=ASU("DT","END")_"0999"
+23 FOR ASUI=32,33,"3K","3L"
SET ASU("TC",ASUI)=""
+24 SET ASU1=ASU("DT","BEG")
+25 FOR
SET ASU1=$ORDER(^ASUH("AX",ASU1))
IF 'ASU1
QUIT
IF ASU1>ASU("DT","END")
QUIT
Begin DoDot:1
+26 SET ASU2=0
FOR
SET ASU2=$ORDER(^ASUH("AX",ASU1,ASU2))
IF 'ASU2
QUIT
Begin DoDot:2
+27 SET ASUD("TRANS")=$PIECE($GET(^ASUH(ASU2,1)),U)
SET ASU0=$EXTRACT(ASUD("TRANS"))
IF ASU0=0
SET ASU0=7
+28 IF ASU0'=3&(ASU0'=7)
QUIT
+29 IF ASU0=3
IF '$DATA(ASU("TC",ASUD("TRANS")))
QUIT
+30 DO DATA16^ASUUTIL(ASU2)
+31 IF ASUD("STATUS")=""
QUIT
+32 IF "UX"'[ASUD("STATUS")
QUIT
+33 DO SET
End DoDot:2
End DoDot:1
+34 QUIT
SET ;----- SETS DATA INTO ^XTMP("ASUR","R15") GLOBAL
+1 ;
+2 ; Sorts and totals the transaction data and sets it into the
+3 ; ^XTMP("ASUR","R15") global
+4 ;
+5 ; ASU = array containing dates and transaction codes
+6 ; ASUD = array containing transaction data
+7 ; ASU0 = transaction type where:
+8 ; 3 = ISSUE
+9 ; 7 = DIRECT ISSUE
+10 ; ASU1 = transaction date
+11 ; ASUPC = piece designation in ^TMP global where totals are put
+12 ; corresponding to report columns where:
+13 ; 1 = current month stock issue total
+14 ; 2 = fiscal year stock issue total
+15 ; 3 = direct issue current month stock issue total
+16 ; 4 = direct issue fiscal year direct issue total
+17 ; 5 = fuel oil current month total
+18 ; 6 = fuel oil fiscal year total
+19 ; ASUPCM = month piece (1, 3, or 5)
+20 ; ASUPCY = fiscal year piece (2, 4, or 6)
+21 ; ASUOOT = root of ^XTMP("ASUR","R15") global for data
+22 ; ASUGLOB = the ^XTMP("ASUR","R15") where data is stored
+23 ; ASUX = ^TMP global subscript
+24 ; ASU("DXTRACT") = array containing extract dates
+25 ; ASU("OBJ") = transaction object class code
+26 ; ASU("VAL") = transaction amount
+27 ;
+28 NEW ASUGLOB,ASUPC,ASUPCM,ASUPCY,ASUOOT,ASUX
+29 IF $DATA(ASUDT("DXTRACT",ASU1))
Begin DoDot:1
+30 IF ASU0=3
SET ASUPCM=1
SET ASUPCY=2
+31 IF ASU0=7
IF ASUD("OBJ")'="268H"
SET ASUPCM=3
SET ASUPCY=4
+32 IF ASU0=7
IF ASUD("OBJ")="268H"
SET ASUPCM=5
SET ASUPCY=6
End DoDot:1
+33 IF '$DATA(ASUDT("DXTRACT",ASU1))
Begin DoDot:1
+34 IF ASU0=3
SET ASUPCM=0
SET ASUPCY=2
+35 IF ASU0=7
IF ASUD("OBJ")'="268H"
SET ASUPCM=0
SET ASUPCY=4
+36 IF ASU0=7
IF ASUD("OBJ")="268H"
SET ASUPCM=0
SET ASUPCY=6
End DoDot:1
+37 FOR ASUPC=ASUPCM,ASUPCY
Begin DoDot:1
+38 SET ASUOOT="^TMP(""ASUR"","_$JOB_",""R15"","
+39 FOR ASUX="AREA","STA","SST","USR","CAN","ACC"
Begin DoDot:2
+40 SET ASUOOT=ASUOOT_"ASUD("_""""_ASUX_""""_"),"
+41 SET ASUGLOB=ASUOOT_"0)"
+42 SET $PIECE(@ASUGLOB,U,ASUPC)=$PIECE($GET(@ASUGLOB),U,ASUPC)+ASUD("VAL")
End DoDot:2
+43 IF ASU0=7
IF ASUD("OBJ")'="248H"
IF ASUPC'=ASUPCY
Begin DoDot:2
+44 SET ASUOOT=ASUOOT_"ASUD("_""""_"OBJ"_""""_"),"
+45 SET ASUGLOB=ASUOOT_"0)"
+46 SET $PIECE(@ASUGLOB,U,ASUPC)=$PIECE($GET(@ASUGLOB),U,ASUPC)+ASUD("VAL")
End DoDot:2
End DoDot:1
+47 QUIT
PRT ;----- PRINTS THE DATA
+1 ;
+2 ; ASUL( = loop counter array
+3 ; ASUPAGE = report page number
+4 ; ASUTOT("ACC") = array where GL account totals are stored
+5 ; ASUOUT = '^' to continue controller
+6 ; ASUDATA = temporary data storage
+7 ;
+8 NEW ASUL,ASUPAGE,ASUOUT,ASUTOT
+9 SET ASUOUT=0
+10 IF '$DATA(^XTMP("ASUR","R15"))
WRITE !!,"NO DATA FOR REPORT 15"
QUIT
+11 DO LOOPS
+12 QUIT
LOOPS ;----- Loops 1-7 loop through the ^XTMP("ASUR","R15") global and
+1 ; print the report
+2 ;
1 ;----- LOOP THROUGH THE AREA SUBSCRIPT
+1 ;
+2 NEW ASUDATA
+3 SET ASUL(1)=""
FOR
SET ASUL(1)=$ORDER(^XTMP("ASUR","R15",ASUL(1)))
IF ASUL(1)']""
QUIT
Begin DoDot:1
+4 IF ASUL(1)=0
QUIT
+5 DO 2
IF ASUOUT
QUIT
+6 SET ASUDATA=^XTMP("ASUR","R15",ASUL(1),0)
+7 IF $Y>(IOSL-5)
DO HDR
IF ASUOUT
QUIT
+8 WRITE !!,"AREA ",ASUL(1)," TOTALS"
+9 DO WRITE(ASUDATA)
End DoDot:1
IF ASUOUT
QUIT
+10 QUIT
2 ;----- LOOP THROUGH THE STATION SUBSCRIPT
+1 ;
+2 NEW ASUDATA
+3 SET ASUL(2)=""
FOR
SET ASUL(2)=$ORDER(^XTMP("ASUR","R15",ASUL(1),ASUL(2)))
IF ASUL(2)']""
QUIT
Begin DoDot:1
+4 IF ASUL(2)=0
QUIT
+5 DO HDR
+6 DO 3
IF ASUOUT
QUIT
+7 SET ASUDATA=^XTMP("ASUR","R15",ASUL(1),ASUL(2),0)
+8 IF $Y>(IOSL-5)
DO HDR
IF ASUOUT
QUIT
+9 WRITE !,"STATION ",ASUL(2)," TOTALS"
+10 DO WRITE(ASUDATA)
End DoDot:1
IF ASUOUT
QUIT
+11 QUIT
3 ;----- LOOP THROUGH THE SUB-STATION SUBSCRIPT
+1 ;
+2 NEW ASUDATA
+3 SET ASUL(3)=""
FOR
SET ASUL(3)=$ORDER(^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3)))
IF ASUL(3)']""
QUIT
Begin DoDot:1
+4 IF ASUL(3)=0
QUIT
+5 IF $GET(ASUPAGE)>1
DO HDR
+6 DO 4
IF ASUOUT
QUIT
+7 SET ASUDATA=^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),0)
+8 IF $Y>(IOSL-5)
DO HDR
IF ASUOUT
QUIT
+9 WRITE !,"SUB-STATION ",ASUL(3)," TOTALS"
+10 DO WRITE(ASUDATA)
+11 WRITE !
End DoDot:1
IF ASUOUT
QUIT
+12 QUIT
4 ;----- LOOP THROUGH THE USER SUBSCRIPT
+1 ;
+2 NEW ASUDATA,ASUI
+3 SET ASUL(4)=""
FOR
SET ASUL(4)=$ORDER(^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),ASUL(4)))
IF ASUL(4)']""
QUIT
Begin DoDot:1
+4 IF ASUL(4)=0
QUIT
+5 DO 5
IF ASUOUT
QUIT
+6 SET ASUI=""
FOR
SET ASUI=$ORDER(ASUTOT("ACC",ASUL(3),ASUL(4),ASUI))
IF ASUI']""
QUIT
Begin DoDot:2
+7 SET ASUDATA=ASUTOT("ACC",ASUL(3),ASUL(4),ASUI)
+8 IF $Y>(IOSL-5)
DO HDR
IF ASUOUT
QUIT
+9 WRITE !?25,ASUI,?31,"TOTAL"
+10 DO WRITE(ASUDATA)
End DoDot:2
IF ASUOUT
QUIT
+11 SET ASUDATA=^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),ASUL(4),0)
+12 IF $Y>(IOSL-5)
DO HDR
IF ASUOUT
QUIT
+13 WRITE !?8,"USER CODE TOTALS"
+14 DO WRITE(ASUDATA)
+15 WRITE !
End DoDot:1
IF ASUOUT
QUIT
+16 QUIT
5 ;----- LOOP THROUGH THE CAN SUBSCRIPT
+1 ;
+2 NEW ASUDATA
+3 SET ASUL(5)=""
FOR
SET ASUL(5)=$ORDER(^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),ASUL(4),ASUL(5)))
IF ASUL(5)']""
QUIT
Begin DoDot:1
+4 IF ASUL(5)=0
QUIT
+5 DO 6
IF ASUOUT
QUIT
+6 SET ASUDATA=^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),ASUL(4),ASUL(5),0)
+7 IF $Y>(IOSL-5)
DO HDR
IF ASUOUT
QUIT
+8 WRITE !?17,"CAN TOTALS"
+9 DO WRITE(ASUDATA)
+10 WRITE !
End DoDot:1
IF ASUOUT
QUIT
+11 QUIT
6 ;----- LOOP THROUGH THE GL ACCOUNT SUBSCRIPT
+1 ;
+2 NEW ASUDATA,ASUI
+3 SET ASUL(6)=""
FOR
SET ASUL(6)=$ORDER(^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),ASUL(4),ASUL(5),ASUL(6)))
IF ASUL(6)']""
QUIT
Begin DoDot:1
+4 IF ASUL(6)=0
QUIT
+5 DO 7
IF ASUOUT
QUIT
+6 SET ASUDATA=^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),ASUL(4),ASUL(5),ASUL(6),0)
+7 FOR ASUI=1:1:6
Begin DoDot:2
+8 SET $PIECE(ASUTOT("ACC",ASUL(3),ASUL(4),ASUL(6)),U,ASUI)=$PIECE($GET(ASUTOT("ACC",ASUL(3),ASUL(4),ASUL(6))),U,ASUI)+$PIECE(ASUDATA,U,ASUI)
End DoDot:2
+9 IF $Y>(IOSL-5)
DO HDR
IF ASUOUT
QUIT
+10 WRITE !?2,$EXTRACT(ASUL(3),1,2),?8,ASUL(4),?17,ASUL(5),?25,ASUL(6),?31,"TOTAL"
+11 DO WRITE(ASUDATA)
End DoDot:1
IF ASUOUT
QUIT
+12 QUIT
7 ;----- LOOP THROUGH THE SUBOBJECT SUBSCRIPT
+1 ;
+2 NEW ASUDATA
+3 SET ASUL(7)=""
FOR
SET ASUL(7)=$ORDER(^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),ASUL(4),ASUL(5),ASUL(6),ASUL(7)))
IF ASUL(7)']""
QUIT
Begin DoDot:1
+4 IF ASUL(7)=0
QUIT
+5 SET ASUDATA=^XTMP("ASUR","R15",ASUL(1),ASUL(2),ASUL(3),ASUL(4),ASUL(5),ASUL(6),ASUL(7),0)
+6 IF $Y>(IOSL-5)
DO HDR
IF ASUOUT
QUIT
+7 WRITE !?2,$EXTRACT(ASUL(3),1,2),?8,ASUL(4),?17,ASUL(5),?25,ASUL(6),?38,$JUSTIFY($PIECE(ASUDATA,U),10,2),?66,$SELECT(ASUL(7)="268H":"",1:$EXTRACT(ASUL(7),3,4))
+8 WRITE ?70,$JUSTIFY($PIECE(ASUDATA,U,3),10,2),?84,$JUSTIFY($PIECE(ASUDATA,U,4),10,2),?104,$JUSTIFY($PIECE(ASUDATA,U,5),10,2),?118,$JUSTIFY($PIECE(ASUDATA,U,6),10,2)
End DoDot:1
IF ASUOUT
QUIT
+9 QUIT
WRITE(X) ;----- WRITES TOTALS
+1 ;
+2 WRITE ?38,$JUSTIFY($PIECE(X,U),10,2),?52,$JUSTIFY($PIECE(X,U,2),10,2),?70,$JUSTIFY($PIECE(X,U,3),10,2),?84,$JUSTIFY($PIECE(X,U,4),10,2),?104,$JUSTIFY($PIECE(X,U,5),10,2),?118,$JUSTIFY($PIECE(X,U,6),10,2)
+3 QUIT
HDR ;----- WRITES REPORT HEADER
+1 ;
+2 NEW %,DIR,X,Y
+3 IF $EXTRACT(IOST)="C"
IF $GET(ASUPAGE)
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET ASUOUT=1
QUIT
+4 SET ASUPAGE=$GET(ASUPAGE)+1
+5 WRITE @IOF
+6 WRITE "REPORT #15 MONTHLY COST REPORT FOR ",$SELECT(ASUTYP="M":"MONTH ",ASUTYP="I":"EXTRACT DATE ",1:"")
+7 SET Y=ASUDT
XECUTE ^DD("DD")
WRITE Y
+8 WRITE ?116,"PAGE ",$JUSTIFY(ASUPAGE,6)
+9 WRITE !,"AREA ",$GET">GET(ASUL(1)),!,"STAT ",$GET">GET(ASUL(2))
+10 WRITE !!,"SUB",?18,"COMMON",?27,"G L",?33,"STOCK ISSUES-OBJECT CLASS 26",?65,"DIRECT ISSUES-OBJECT CLASS 26",?101,"FUEL OIL OBJ-SUBOBJ 26.8H"
+11 WRITE !,"STAT",?8,"USER",?14,"ACCOUNTING",?26,"ACCT",?34,"CURRENT MONTH",?54,"YEAR-TO-",?66,"CURRENT MONTH",?87,"YEAR-TO-",?100,"CURRENT MONTH",?121,"YEAR-TO-"
+12 WRITE !,"CODE",?8,"CODE",?18,"NUMBER",?27,"NO.",?32,"SUBOBJ",?43,"VALUE",?52,"DATE VALUE",?64,"SUBOBJ",?75,"VALUE",?85,"DATE VALUE",?97,"SUBOBJ",?109,"VALUE",?119,"DATE VALUE"
+13 WRITE !
+14 QUIT
QUIT ;----- CLEAN UP VARIABLES, CLOSE DEVICE, QUIT
+1 ;
+2 KILL ZTSAVE
+3 KILL ^XTMP("ASUR","R15")
+4 IF $GET(ASUK("PTRSEL"))]""
WRITE @IOF
QUIT
+5 DO ^%ZISC
+6 QUIT
