ASURMDBL ; IHS/ITSC/LMH - MANAGEMENT SUPPLY DATA BOOK REPORT L ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;;Y2K/OK/AEF/2970423
;This routine produces the Management Supply Databook Report L
;Receipt Values by Major Sources of Supply
;
;
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^ASURMDBL",.ZTSAVE,"SAMS DATABOOK REPORT L")
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, M=monthly
;
D ^XBKVAR
D:'$D(^XTMP("ASUR","RDBL")) GET
D PRT,QUIT
Q
GET ;EP ; GATHER DATA
;
; Builds ^XTMP("ASUR","RDBL") global to sort and store
; transaction totals
;
; ASU = array containing beginning, ending fiscal dates
; ASU0 = file to get data from
; ASU1 = extracted date in 'AX' crossreference
; ASU2 = internal file entry number
; ASUD = array containing transaction data
; ASUPC = piece in ^TMP global to put the count in
;
N ASU,ASU0,ASU1,ASU2,ASUD,ASUPC
K ^XTMP("ASUR","RDBL")
D FPP^ASUUTIL1(ASUDT)
I ASUTYP="M" S ASUDT=$$LDOM^ASUUTIL1(ASUDT)
F ASU0=2,7 D
. S ASU1=ASU("DT","BEG2")-1
. F S ASU1=$O(^ASUTH(ASU0,"AX",ASU1)) Q:'ASU1 Q:ASU1>ASUDT D
. . S ASU2=0 F S ASU2=$O(^ASUTH(ASU0,"AX",ASU1,ASU2)) Q:'ASU2 D
. . . D DATA16^ASUUTIL(ASU0,ASU2)
. . . S ASUPC=0
. . . I ASU1'<ASU("DT","BEG")&(ASU1'>ASU("DT","END")) S ASUPC=1
. . . I ASU1'<ASU("DT","BEG1")&(ASU1'>ASU("DT","END1")) S ASUPC=3
. . . I ASU1'<ASU("DT","BEG2")&(ASU1'>ASU("DT","END2")) S ASUPC=5
. . . I ASUPC,ASU0=2 S ASUPC=ASUPC+1
. . . D SET
Q
SET ;----- SETS TOTALS IN ^TMP GLOBAL
;
I '$D(^XTMP("ASUR","RDBL","SRC",ASUD("AREA"),ASUD("ACCNAM"),ASUD("STA"),0)) D SRC(ASUD("AREA"),ASUD("ACCNAM"),ASUD("STA"))
S $P(^XTMP("ASUR","RDBL","IHS",ASUD("AREA"),ASUD("ACCNAM"),ASUD("STA"),0),U,ASUPC)=$P($G(^XTMP("ASUR","RDBL","IHS",ASUD("AREA"),ASUD("ACCNAM"),ASUD("STA"),0)),U,ASUPC)+ASUD("VAL")
S $P(^XTMP("ASUR","RDBL","IHS",ASUD("AREA"),ASUD("ACCNAM"),ASUD("STA"),ASUD("SRC"),0),U,ASUPC)=$P($G(^XTMP("ASUR","RDBL","IHS",ASUD("AREA"),ASUD("ACCNAM"),ASUD("STA"),ASUD("SRC"),0)),U,ASUPC)+ASUD("VAL")
Q
SRC(X1,X2,X3) ;
;----- SETS UP SOURCE CODE ARRAY BY AREA, STATION
;
; X1 = area passed by calling routine
; X2 = account passed by calling routine
; X3 = station passed by calling routine
; X4 = source code
;
N X4
S X4=0 F S X4=$O(^ASUL(5,X4)) Q:'X4 D
. S ^XTMP("ASUR","RDBL","SRC",X1,X2,X3,0)=""
. S ^XTMP("ASUR","RDBL","IHS",X1,X2,X3,$P(^ASUL(5,X4,0),U),0)=""
Q
PRT ;----- PRINTS THE DATA
;
; ASUDATA = temporary data storage
; ASUDATA2 = temporary data storage
; ASUL = array used for loop counters
; ASUOUT = '^' to escape controller
; ASUPAGE = report page number
;
N ASUL,ASUOUT,ASUPAGE
I '$D(^XTMP("ASUR","RDBL")) W !!,"NO DATA FOR DATABOOK REPORT L" Q
S ASUOUT=0
D LOOPS
Q
;
LOOPS ;----- LOOPS THROUGH THE ^XTMP("ASUR","RDBK") GLOBAL AND PRINTS
; THE REPORT
;
1 ;----- LOOP THROUGH THE AREA SUBSCRIPT
;
N ASUDATA,ASUDATA2
S ASUL(1)="" F S ASUL(1)=$O(^XTMP("ASUR","RDBL","IHS",ASUL(1))) Q:ASUL(1)']"" D Q:ASUOUT
. D 2 Q:ASUOUT
Q
2 ;----- LOOP THROUGH THE ACCOUNT SUBSCRIPT
;
S ASUL(2)="" F S ASUL(2)=$O(^XTMP("ASUR","RDBL","IHS",ASUL(1),ASUL(2))) Q:ASUL(2)']"" D Q:ASUOUT
. Q:ASUL(2)=0
. D 3 Q:ASUOUT
Q
3 ;----- LOOP THROUGH THE STATION SUBSCRIPT
;
N ASUDATA,ASUDATA2
S ASUL(3)="" F S ASUL(3)=$O(^XTMP("ASUR","RDBL","IHS",ASUL(1),ASUL(2),ASUL(3))) Q:ASUL(3)']"" D Q:ASUOUT
. D HDR(ASUL(1),ASUL(2),ASUL(3)) Q:ASUOUT
. D 4 Q:ASUOUT
. I $Y>(IOSL-5) D HDR(ASUL(1),ASUL(2),ASUL(3)) Q:ASUOUT
. W !!,"TOTAL RECEIPTS"
. S (ASUDATA,ASUDATA2)=^XTMP("ASUR","RDBL","IHS",ASUL(1),ASUL(2),ASUL(3),0)
. D WRITE(ASUDATA,ASUDATA2)
Q
4 ;----- LOOP THROUGH THE SOURCE CODE SUBSCRIPT
;
N ASUDATA,ASUDATA2
S ASUDATA2=^XTMP("ASUR","RDBL","IHS",ASUL(1),ASUL(2),ASUL(3),0)
S ASUL(4)="" F S ASUL(4)=$O(^XTMP("ASUR","RDBL","IHS",ASUL(1),ASUL(2),ASUL(3),ASUL(4))) Q:ASUL(4)']"" D Q:ASUOUT
. Q:ASUL(4)=0
. S ASUDATA=^XTMP("ASUR","RDBL","IHS",ASUL(1),ASUL(2),ASUL(3),ASUL(4),0)
. I $Y>(IOSL-5) D HDR(ASUL(1),ASUL(2),ASUL(3)) Q:ASUOUT
. W !!,ASUL(4)
. D WRITE(ASUDATA,ASUDATA2)
Q
WRITE(X1,X2) ;
;----- WRITES DATA
;
N ASUX
W !?5,$J($P(X1,U),8,2)
S ASUX=$$PRCNT($P(X1,U)+$P(X1,U,2),$P(X1,U))
W ?14,$J(ASUX,4,1)
W ?19,$J($P(X1,U,2),8,2)
S ASUX=$$PRCNT($P(X1,U)+$P(X1,U,2),$P(X1,U,2))
W ?28,$J(ASUX,4,1)
W ?33,$J($P(X1,U)+$P(X1,U,2),8,2)
S ASUX=$$PRCNT($P(X2,U)+$P(X2,U,2),$P(X1,U)+$P(X1,U,2))
W ?42,$J(ASUX,4,1)
W ?48,$J($P(X1,U,3),8,2)
S ASUX=$$PRCNT($P(X1,U,3)+$P(X1,U,4),$P(X1,U,3))
W ?57,$J(ASUX,4,1)
W ?62,$J($P(X1,U,4),8,2)
S ASUX=$$PRCNT($P(X1,U,3)+$P(X1,U,4),$P(X1,U,4))
W ?71,$J(ASUX,4,1)
W ?76,$J($P(X1,U,3)+$P(X1,U,4),8,2)
S ASUX=$$PRCNT($P(X2,U,3)+$P(X2,U,4),$P(X1,U,3)+$P(X1,U,4))
W ?85,$J(ASUX,4,1)
W ?91,$J($P(X1,U,5),8,2)
S ASUX=$$PRCNT($P(X1,U,5)+$P(X1,U,6),$P(X1,U,5))
W ?100,$J(ASUX,4,1)
W ?105,$J($P(X1,U,6),8,2)
S ASUX=$$PRCNT($P(X1,U,5)+$P(X1,U,6),$P(X1,U,6))
W ?114,$J(ASUX,4,1)
W ?119,$J($P(X1,U,5)+$P(X1,U,6),8,2)
S ASUX=$$PRCNT($P(X2,U,5)+$P(X2,U,6),$P(X1,U,5)+$P(X1,U,6))
W ?128,$J(ASUX,4,1)
Q
HDR(X1,X2,X3) ;
;----- WRITES REPORT HEADER
;
; X1 = area
; X2 = account
; X3 = station
;
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 "MANAGEMENT SUPPLY DATA BOOK for "
S Y=ASUDT X ^DD("DD") W $P(Y," ")," ",$P(Y,",",2)
W ?116,"PAGE ",$J(ASUPAGE,6)
W !,"AREA ",X1
W !!,"L. RECEIPT VALUES BY MAJOR SOURCES OF SUPPLY"
W !?3,"Category: ",X2
W !!,"LOCATION: ",X3
W !!?16,"CURRENT FISCAL YEAR",?58,"PREVIOUS FISCAL YEAR",?98,"PREVIOUS-PREV FISCAL YEAR"
W !?7,"DIRECT",?17,"%",?22,"STOCK",?31,"%",?36,"TOTAL",?45,"%",?50,"DIRECT",?60,"%",?65,"STOCK",?74,"%",?79,"TOTAL",?88,"%",?93,"DIRECT",?103,"%",?108,"STOCK",?117,"%",?122,"TOTAL",?131,"%"
W !?7,"ISSUES",?15,"DIR RECEIPTS",?29,"STK RECEIPTS",?43,"TOT",?50,"ISSUES",?58,"DIR RECEIPTS",?72,"STK RECEIPTS",?86,"TOT",?93,"ISSUES",?101,"DIR RECEIPTS",?115,"STK RECEIPTS",?129,"TOT"
Q
PRCNT(X,Y) ;
;----- CALCULATES PERCENT
;
I +X=0 Q ""
Q (Y/X)*100
;
QUIT ;----- CLEAN UP VARIABLES, CLOSE DEVICE, QUIT
;
K ZTSAVE
K ^XTMP("ASUR","RDBL")
I $G(ASUK("PTRSEL"))]"" W @IOF Q
D ^%ZISC
Q
ASURMDBL ; IHS/ITSC/LMH - MANAGEMENT SUPPLY DATA BOOK REPORT L ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;;Y2K/OK/AEF/2970423
+3 ;This routine produces the Management Supply Databook Report L
+4 ;Receipt Values by Major Sources of Supply
+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 '$DATA(ASUDT)
GOTO QUIT
+5 WRITE !,*7,"THIS REPORT REQUIRES 132 COLUMNS!"
+6 SET ZTSAVE("ASUDT")=""
SET ZTSAVE("ASUTYP")=""
+7 DO QUE^ASUUTIL("DQ^ASURMDBL",.ZTSAVE,"SAMS DATABOOK REPORT L")
+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, M=monthly
+4 ;
+5 DO ^XBKVAR
+6 IF '$DATA(^XTMP("ASUR","RDBL"))
DO GET
+7 DO PRT
DO QUIT
+8 QUIT
GET ;EP ; GATHER DATA
+1 ;
+2 ; Builds ^XTMP("ASUR","RDBL") global to sort and store
+3 ; transaction totals
+4 ;
+5 ; ASU = array containing beginning, ending fiscal dates
+6 ; ASU0 = file to get data from
+7 ; ASU1 = extracted date in 'AX' crossreference
+8 ; ASU2 = internal file entry number
+9 ; ASUD = array containing transaction data
+10 ; ASUPC = piece in ^TMP global to put the count in
+11 ;
+12 NEW ASU,ASU0,ASU1,ASU2,ASUD,ASUPC
+13 KILL ^XTMP("ASUR","RDBL")
+14 DO FPP^ASUUTIL1(ASUDT)
+15 IF ASUTYP="M"
SET ASUDT=$$LDOM^ASUUTIL1(ASUDT)
+16 FOR ASU0=2,7
Begin DoDot:1
+17 SET ASU1=ASU("DT","BEG2")-1
+18 FOR
SET ASU1=$ORDER(^ASUTH(ASU0,"AX",ASU1))
IF 'ASU1
QUIT
IF ASU1>ASUDT
QUIT
Begin DoDot:2
+19 SET ASU2=0
FOR
SET ASU2=$ORDER(^ASUTH(ASU0,"AX",ASU1,ASU2))
IF 'ASU2
QUIT
Begin DoDot:3
+20 DO DATA16^ASUUTIL(ASU0,ASU2)
+21 SET ASUPC=0
+22 IF ASU1'<ASU("DT","BEG")&(ASU1'>ASU("DT","END"))
SET ASUPC=1
+23 IF ASU1'<ASU("DT","BEG1")&(ASU1'>ASU("DT","END1"))
SET ASUPC=3
+24 IF ASU1'<ASU("DT","BEG2")&(ASU1'>ASU("DT","END2"))
SET ASUPC=5
+25 IF ASUPC
IF ASU0=2
SET ASUPC=ASUPC+1
+26 DO SET
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
SET ;----- SETS TOTALS IN ^TMP GLOBAL
+1 ;
+2 IF '$DATA(^XTMP("ASUR","RDBL","SRC",ASUD("AREA"),ASUD("ACCNAM"),ASUD("STA"),0))
DO SRC(ASUD("AREA"),ASUD("ACCNAM"),ASUD("STA"))
+3 SET $PIECE(^XTMP("ASUR","RDBL","IHS",ASUD("AREA"),ASUD("ACCNAM"),ASUD("STA"),0),U,ASUPC)=$PIECE($GET(^XTMP("ASUR","RDBL","IHS",ASUD("AREA"),ASUD("ACCNAM"),ASUD("STA"),0)),U,ASUPC)+ASUD("VAL")
+4 SET $PIECE(^XTMP("ASUR","RDBL","IHS",ASUD("AREA"),ASUD("ACCNAM"),ASUD("STA"),ASUD("SRC"),0),U,ASUPC)=$PIECE($GET(^XTMP("ASUR","RDBL","IHS",ASUD("AREA"),ASUD("ACCNAM"),ASUD("STA"),ASUD("SRC"),0)),U,ASUPC)+ASUD("VAL")
+5 QUIT
SRC(X1,X2,X3) ;
+1 ;----- SETS UP SOURCE CODE ARRAY BY AREA, STATION
+2 ;
+3 ; X1 = area passed by calling routine
+4 ; X2 = account passed by calling routine
+5 ; X3 = station passed by calling routine
+6 ; X4 = source code
+7 ;
+8 NEW X4
+9 SET X4=0
FOR
SET X4=$ORDER(^ASUL(5,X4))
IF 'X4
QUIT
Begin DoDot:1
+10 SET ^XTMP("ASUR","RDBL","SRC",X1,X2,X3,0)=""
+11 SET ^XTMP("ASUR","RDBL","IHS",X1,X2,X3,$PIECE(^ASUL(5,X4,0),U),0)=""
End DoDot:1
+12 QUIT
PRT ;----- PRINTS THE DATA
+1 ;
+2 ; ASUDATA = temporary data storage
+3 ; ASUDATA2 = temporary data storage
+4 ; ASUL = array used for loop counters
+5 ; ASUOUT = '^' to escape controller
+6 ; ASUPAGE = report page number
+7 ;
+8 NEW ASUL,ASUOUT,ASUPAGE
+9 IF '$DATA(^XTMP("ASUR","RDBL"))
WRITE !!,"NO DATA FOR DATABOOK REPORT L"
QUIT
+10 SET ASUOUT=0
+11 DO LOOPS
+12 QUIT
+13 ;
LOOPS ;----- LOOPS THROUGH THE ^XTMP("ASUR","RDBK") GLOBAL AND PRINTS
+1 ; THE REPORT
+2 ;
1 ;----- LOOP THROUGH THE AREA SUBSCRIPT
+1 ;
+2 NEW ASUDATA,ASUDATA2
+3 SET ASUL(1)=""
FOR
SET ASUL(1)=$ORDER(^XTMP("ASUR","RDBL","IHS",ASUL(1)))
IF ASUL(1)']""
QUIT
Begin DoDot:1
+4 DO 2
IF ASUOUT
QUIT
End DoDot:1
IF ASUOUT
QUIT
+5 QUIT
2 ;----- LOOP THROUGH THE ACCOUNT SUBSCRIPT
+1 ;
+2 SET ASUL(2)=""
FOR
SET ASUL(2)=$ORDER(^XTMP("ASUR","RDBL","IHS",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 THE STATION SUBSCRIPT
+1 ;
+2 NEW ASUDATA,ASUDATA2
+3 SET ASUL(3)=""
FOR
SET ASUL(3)=$ORDER(^XTMP("ASUR","RDBL","IHS",ASUL(1),ASUL(2),ASUL(3)))
IF ASUL(3)']""
QUIT
Begin DoDot:1
+4 DO HDR(ASUL(1),ASUL(2),ASUL(3))
IF ASUOUT
QUIT
+5 DO 4
IF ASUOUT
QUIT
+6 IF $Y>(IOSL-5)
DO HDR(ASUL(1),ASUL(2),ASUL(3))
IF ASUOUT
QUIT
+7 WRITE !!,"TOTAL RECEIPTS"
+8 SET (ASUDATA,ASUDATA2)=^XTMP("ASUR","RDBL","IHS",ASUL(1),ASUL(2),ASUL(3),0)
+9 DO WRITE(ASUDATA,ASUDATA2)
End DoDot:1
IF ASUOUT
QUIT
+10 QUIT
4 ;----- LOOP THROUGH THE SOURCE CODE SUBSCRIPT
+1 ;
+2 NEW ASUDATA,ASUDATA2
+3 SET ASUDATA2=^XTMP("ASUR","RDBL","IHS",ASUL(1),ASUL(2),ASUL(3),0)
+4 SET ASUL(4)=""
FOR
SET ASUL(4)=$ORDER(^XTMP("ASUR","RDBL","IHS",ASUL(1),ASUL(2),ASUL(3),ASUL(4)))
IF ASUL(4)']""
QUIT
Begin DoDot:1
+5 IF ASUL(4)=0
QUIT
+6 SET ASUDATA=^XTMP("ASUR","RDBL","IHS",ASUL(1),ASUL(2),ASUL(3),ASUL(4),0)
+7 IF $Y>(IOSL-5)
DO HDR(ASUL(1),ASUL(2),ASUL(3))
IF ASUOUT
QUIT
+8 WRITE !!,ASUL(4)
+9 DO WRITE(ASUDATA,ASUDATA2)
End DoDot:1
IF ASUOUT
QUIT
+10 QUIT
WRITE(X1,X2) ;
+1 ;----- WRITES DATA
+2 ;
+3 NEW ASUX
+4 WRITE !?5,$JUSTIFY($PIECE(X1,U),8,2)
+5 SET ASUX=$$PRCNT($PIECE(X1,U)+$PIECE(X1,U,2),$PIECE(X1,U))
+6 WRITE ?14,$JUSTIFY(ASUX,4,1)
+7 WRITE ?19,$JUSTIFY($PIECE(X1,U,2),8,2)
+8 SET ASUX=$$PRCNT($PIECE(X1,U)+$PIECE(X1,U,2),$PIECE(X1,U,2))
+9 WRITE ?28,$JUSTIFY(ASUX,4,1)
+10 WRITE ?33,$JUSTIFY($PIECE(X1,U)+$PIECE(X1,U,2),8,2)
+11 SET ASUX=$$PRCNT($PIECE(X2,U)+$PIECE(X2,U,2),$PIECE(X1,U)+$PIECE(X1,U,2))
+12 WRITE ?42,$JUSTIFY(ASUX,4,1)
+13 WRITE ?48,$JUSTIFY($PIECE(X1,U,3),8,2)
+14 SET ASUX=$$PRCNT($PIECE(X1,U,3)+$PIECE(X1,U,4),$PIECE(X1,U,3))
+15 WRITE ?57,$JUSTIFY(ASUX,4,1)
+16 WRITE ?62,$JUSTIFY($PIECE(X1,U,4),8,2)
+17 SET ASUX=$$PRCNT($PIECE(X1,U,3)+$PIECE(X1,U,4),$PIECE(X1,U,4))
+18 WRITE ?71,$JUSTIFY(ASUX,4,1)
+19 WRITE ?76,$JUSTIFY($PIECE(X1,U,3)+$PIECE(X1,U,4),8,2)
+20 SET ASUX=$$PRCNT($PIECE(X2,U,3)+$PIECE(X2,U,4),$PIECE(X1,U,3)+$PIECE(X1,U,4))
+21 WRITE ?85,$JUSTIFY(ASUX,4,1)
+22 WRITE ?91,$JUSTIFY($PIECE(X1,U,5),8,2)
+23 SET ASUX=$$PRCNT($PIECE(X1,U,5)+$PIECE(X1,U,6),$PIECE(X1,U,5))
+24 WRITE ?100,$JUSTIFY(ASUX,4,1)
+25 WRITE ?105,$JUSTIFY($PIECE(X1,U,6),8,2)
+26 SET ASUX=$$PRCNT($PIECE(X1,U,5)+$PIECE(X1,U,6),$PIECE(X1,U,6))
+27 WRITE ?114,$JUSTIFY(ASUX,4,1)
+28 WRITE ?119,$JUSTIFY($PIECE(X1,U,5)+$PIECE(X1,U,6),8,2)
+29 SET ASUX=$$PRCNT($PIECE(X2,U,5)+$PIECE(X2,U,6),$PIECE(X1,U,5)+$PIECE(X1,U,6))
+30 WRITE ?128,$JUSTIFY(ASUX,4,1)
+31 QUIT
HDR(X1,X2,X3) ;
+1 ;----- WRITES REPORT HEADER
+2 ;
+3 ; X1 = area
+4 ; X2 = account
+5 ; X3 = station
+6 ;
+7 NEW %,DIR,X,Y
+8 IF $EXTRACT(IOST)="C"
IF $GET(ASUPAGE)
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET ASUOUT=1
QUIT
+9 SET ASUPAGE=$GET(ASUPAGE)+1
+10 WRITE @IOF
+11 WRITE "MANAGEMENT SUPPLY DATA BOOK for "
+12 SET Y=ASUDT
XECUTE ^DD("DD")
WRITE $PIECE(Y," ")," ",$PIECE(Y,",",2)
+13 WRITE ?116,"PAGE ",$JUSTIFY(ASUPAGE,6)
+14 WRITE !,"AREA ",X1
+15 WRITE !!,"L. RECEIPT VALUES BY MAJOR SOURCES OF SUPPLY"
+16 WRITE !?3,"Category: ",X2
+17 WRITE !!,"LOCATION: ",X3
+18 WRITE !!?16,"CURRENT FISCAL YEAR",?58,"PREVIOUS FISCAL YEAR",?98,"PREVIOUS-PREV FISCAL YEAR"
+19 WRITE !?7,"DIRECT",?17,"%",?22,"STOCK",?31,"%",?36,"TOTAL",?45,"%",?50,"DIRECT",?60,"%",?65,"STOCK",?74,"%",?79,"TOTAL",?88,"%",?93,"DIRECT",?103,"%",?108,"STOCK",?117,"%",?122,"TOTAL",?131,"%"
+20 WRITE !?7,"ISSUES",?15,"DIR RECEIPTS",?29,"STK RECEIPTS",?43,"TOT",?50,"ISSUES",?58,"DIR RECEIPTS",?72,"STK RECEIPTS",?86,"TOT",?93,"ISSUES",?101,"DIR RECEIPTS",?115,"STK RECEIPTS",?129,"TOT"
+21 QUIT
PRCNT(X,Y) ;
+1 ;----- CALCULATES PERCENT
+2 ;
+3 IF +X=0
QUIT ""
+4 QUIT (Y/X)*100
+5 ;
QUIT ;----- CLEAN UP VARIABLES, CLOSE DEVICE, QUIT
+1 ;
+2 KILL ZTSAVE
+3 KILL ^XTMP("ASUR","RDBL")
+4 IF $GET(ASUK("PTRSEL"))]""
WRITE @IOF
QUIT
+5 DO ^%ZISC
+6 QUIT
