ASURMDBK ; IHS/ITSC/LMH - MANAGEMENT SUPPLY DATA BOOK REPORTS K SERIES ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;;Y2K/OK/AEF/2970411
;This routine produces the Management Supply Data Book Reports K1-K7
;
EN ;EP -- MAIN ENTRY POINT (USER INTERACTIVE)
;
N ASUDT,ASURPT,ASUTYP
D ^XBKVAR,HOME^%ZIS
D K^ASURMDBK G QUIT:$G(ASURPT)']""
D SELXTRCT^ASUUTIL G QUIT:'$D(ASUDT)
W !,*7,"THIS REPORT REQUIRES 132 COLUMNS!"
S (ZTSAVE("ASUDT"),ZTSAVE("ASUTYP"),ZTSAVE("ASURPT"))=""
D QUE^ASUUTIL("DQ^ASURMDBK",.ZTSAVE,"SAMS MGMT SUPPLY DATABOOK REPORT K")
D QUIT
Q
EN1(ASUDT,ASUTYP,ASURPT) ;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
; ASURPT = which reports, i.e., K1, K2, K3, K4, K5, K6, K7
;
D ^XBKVAR
D:'$D(^XTMP("ASUR","RDBK")) GET
D PRT,QUIT
Q
GET ;EP ; GATHER DATA
;
; Builds ^XTMP("ASUR","RDBK") global to sort and store
; transaction amounts
;
; ASU = array containing beginning, ending fiscal dates
; ASU0 = transaction type
; ASU1 = extracted date in 'AX' crossreference
; ASU2 = internal file entry number
; ASUD = array containing transaction data
; ASUPC = the piece in ^TMP global to put the total in
;
N ASU,ASU0,ASU1,ASU2,ASUD,ASUPC
K ^XTMP("ASUR","RDBK")
D FPP^ASUUTIL1(ASUDT)
I ASUTYP="M" S ASUDT=$$LDOM^ASUUTIL1(ASUDT)
S ASU1=ASU("DT","BEG2")-1
F S ASU1=$O(^ASUH("AX",ASU1)) Q:'ASU1 Q:ASU1>ASUDT 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
. . D DATA16^ASUUTIL(ASU2)
. . S ASUPC=0
. . I ASU1'<ASU("DT","BEG")&(ASU1'>ASU("DT","END")) S ASUPC=0
. . I ASU1'<ASU("DT","BEG1")&(ASU1'>ASU("DT","END1")) S ASUPC=2
. . I ASU1'<ASU("DT","BEG2")&(ASU1'>ASU("DT","END2")) S ASUPC=4
. . I ASU0=3 S ASUPC=ASUPC+1
. . I ASU0=7 S ASUPC=ASUPC+2
. . S ASUD("ACC")=+$P(ASUD("ACC"),".",2)
. . D SET
Q
SET ;----- SETS TOTALS IN ^TMP GLOBAL
;
S $P(^XTMP("ASUR","RDBK","IHS",ASUD("AREA"),ASUD("ACC"),0),U,ASUPC)=$P($G(^XTMP("ASUR","RDBK","IHS",ASUD("AREA"),ASUD("ACC"),0)),U,ASUPC)+ASUD("VAL")
S $P(^XTMP("ASUR","RDBK","IHS",ASUD("AREA"),999,0),U,ASUPC)=$P($G(^XTMP("ASUR","RDBK","IHS",ASUD("AREA"),999,0)),U,ASUPC)+ASUD("VAL")
S $P(^XTMP("ASUR","RDBK","IHS",ASUD("AREA"),ASUD("ACC"),ASUD("STA"),0),U,ASUPC)=$P($G(^XTMP("ASUR","RDBK","IHS",ASUD("AREA"),ASUD("ACC"),ASUD("STA"),0)),U,ASUPC)+ASUD("VAL")
S $P(^XTMP("ASUR","RDBK","IHS",ASUD("AREA"),999,ASUD("STA"),0),U,ASUPC)=$P($G(^XTMP("ASUR","RDBK","IHS",ASUD("AREA"),999,ASUD("STA"),0)),U,ASUPC)+ASUD("VAL")
Q
PRT ;----- PRINTS THE DATA
;
; ASUDATA = temporary data storage
; ASUL = array used for loop counters
; ASUOUT = '^' to escape controller
; ASUPAGE = report page number
;
N ASUL,ASULIST,ASUOUT,ASUPAGE
S ASUOUT=0
D K1,LOOPS
Q
LOOPS ;----- LOOPS THROUGH THE ^XTMP("ASUR","RDBK") GLOBAL AND PRINTS
; THE REPORT
;
1 ;----- LOOP THROUGH THE AREA SUBSCRIPT
;
S ASUL(1)="" F S ASUL(1)=$O(^XTMP("ASUR","RDBK","IHS",ASUL(1))) Q:ASUL(1)']"" D Q:ASUOUT
. Q:ASUL(1)=0
. D 2
Q
2 ;----- LOOP THROUGH THE REPORT NUMBER SUBSCRIPT
;
N ASUDATA,I
F I=1:1:$L(ASURPT,",") S ASUL(2)=$P(ASURPT,",",I) D Q:ASUOUT
. D HDR Q:ASUOUT
. I '$D(^XTMP("ASUR","RDBK","IHS",ASUL(1),ASUL(2))) D Q
. . W !!,"NO DATA FOR DATA BOOK REPORT ",ASULIST(2,ASUL(2))
. D 3 Q:ASUOUT
. I $Y>(IOSL-5) D HDR Q:ASUOUT
. W !!,"TOTAL"
. S ASUDATA=^XTMP("ASUR","RDBK","IHS",ASUL(1),ASUL(2),0)
. D WRITE(ASUDATA)
Q
3 ;----- LOOP THROUGH THE STATION SUBSCRIPT
;
N ASUDATA
S ASUL(3)="" F S ASUL(3)=$O(^XTMP("ASUR","RDBK","IHS",ASUL(1),ASUL(2),ASUL(3))) Q:ASUL(3)']"" D Q:ASUOUT
. Q:ASUL(3)=0
. I $Y>(IOSL-5) D HDR Q:ASUOUT
. S ASUDATA=^XTMP("ASUR","RDBK","IHS",ASUL(1),ASUL(2),ASUL(3),0)
. W !!,$E(ASUL(3),1,15)
. D WRITE(ASUDATA)
Q
WRITE(X) ;
;----- WRITES REPORT DATA COLUMNS
;
W ?18,$J($P(X,U),10,2),?30,$J($$DIV($P(X,U),$P(X,U)+$P(X,U,2)),5,1)
W ?37,$J($P(X,U,2),10,2),?49,$J($$DIV($P(X,U,2),$P(X,U)+$P(X,U,2)),5,1)
W ?57,$J($P(X,U,3),10,2),?69,$J($$DIV($P(X,U,3),$P(X,U,3)+$P(X,U,4)),5,1)
W ?76,$J($P(X,U,4),10,2),?88,$J($$DIV($P(X,U,4),$P(X,U,3)+$P(X,U,4)),5,1)
W ?96,$J($P(X,U,5),10,2),?108,$J($$DIV($P(X,U,5),$P(X,U,5)+$P(X,U,6)),5,1)
W ?115,$J($P(X,U,6),10,2),?127,$J($$DIV($P(X,U,6),$P(X,U,5)+$P(X,U,6)),5,1)
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 "MANAGEMENT SUPPLY DATA BOOK for "
S Y=ASUDT X ^DD("DD") W $P(Y," ")," ",$P(Y,",",2)
W !,"AREA ",ASUL(1)
W !!,ASULIST(2,ASUL(2))," - ","DIRECT ISSUE VALUE versus STOCK ISSUE VALUE"
W !!?26,"CURRENT FISCAL YEAR",?65,"PREVIOUS FISCAL YEAR",?103,"PREV-PREV FISCAL YEAR"
W !?18,"DIRECT ISS",?34,"%",?37,"STOCK ISSU",?53,"%",?57,"DIRECT ISS",?73,"%",?76,"STOCK ISSU",?92,"%",?96,"DIRECT ISS",?112,"%",?115,"STOCK ISSU",?131,"%"
W !,"STATION",?23,"VALUE",?31,"D.I.",?42,"VALUE",?50,"S.I.",?62,"VALUE",?70,"D.I.",?81,"VALUE",?89,"S.I.",?101,"VALUE",?109,"D.I.",?120,"VALUE",?128,"S.I."
Q
DIV(X1,X2) ;
;----- COMPUTES PERCENT - EXTRINSIC FUNCTION
; call by $$DIV(VALUE1,VALUE2)
;
; Returns percentage of first number divided by second number
;
I +X2=0 Q 0
Q (X1/X2)*100
;
K ;----- SELECT THE K REPORTS TO PRINT
;
; Allows user to select which K reports to print
;
; Returns ASURPT = string containing which reports to print
;
; ASULIST = array containing list of selectable reports
; ASUDATA = temporary data storage
; ASUCNT = counter
;
N ASULIST,I
D K1,K2
I ASURPT="A" S ASURPT="",I=0 F S I=$O(ASULIST(2,I)) Q:'I S ASURPT=ASURPT_$S(ASURPT]"":",",1:"")_I
Q
K1 ;----- BUILDS SELECTION ARRAYS
;
N ASUDATA,I,J
F I=1:1 S ASUDATA=$T(KLIST+I) Q:ASUDATA["$$END" D
. F J=3:1:5 D
. . Q:$P(ASUDATA,";",5)']""
. . S:$P(ASUDATA,";",J)]"" ASULIST(1,$P(ASUDATA,";",J))=$P(ASUDATA,";",5),ASULIST(2,$P(ASUDATA,";",5))=$P(ASUDATA,";",3)_" "_$P(ASUDATA,";",4),ASULIST(1,$P(ASUDATA,";",3)_" "_$P(ASUDATA,";",4))=$P(ASUDATA,";",5)
Q
;
K2 ;----- ISSUE PROMPTS TO CHOOSE WHICH REPORT(S)
;
N ASUCNT,ASUX,ASUZ,DIR,I,J,X,Y
W !,"DIRECT ISSUE VALUE versus STOCK ISSUE VALUE Reports:",!
S I="" F S I=$O(ASULIST(2,I)) Q:I']"" W !?3,I,?8,ASULIST(2,I)
S DIR(0)="FA"
S DIR("A")="Which report(s): "
S DIR("?")="Enter '??' for more help"
S DIR("??")="^D KHELP^ASURMDBK"
D ^DIR
S ASURPT=Y
I ASURPT']""!(ASURPT["^") S ASURPT="" Q
I $L(ASURPT,",")=1&(ASURPT'["-") D G:ASURPT']"" K2 W " ",$P(ASULIST(2,ASURPT)," ",2) Q
. S ASURPT=$P(ASURPT,",")
. I $D(ASULIST(1,ASURPT)) S ASURPT=ASULIST(1,ASURPT) Q
. K ASULIST(3),ASULIST(4)
. S ASUX="" F S ASUX=$O(ASULIST(1,ASUX)) Q:ASUX']"" D
. . I $E(ASUX,1,$L(ASURPT))=ASURPT S ASULIST(3,ASULIST(1,ASUX))=""
. S ASUCNT=0,ASUX="" F S ASUX=$O(ASULIST(3,ASUX)) Q:ASUX']"" D
. . S ASUCNT=ASUCNT+1,ASULIST(4,ASUCNT)=ASULIST(2,ASUX)
. I '$D(ASULIST(4)) W *7," ??" S ASURPT="" Q
. I ASUCNT=1 S ASURPT=ASULIST(4,ASUCNT),ASURPT=ASULIST(1,ASURPT) Q
. K ASURPT
. W !
. S (ASUCNT,I)=0 F S I=$O(ASULIST(4,I)) Q:'I S ASUCNT=ASUCNT+1 W !?3,I_" "_ASULIST(4,I)
. W ! S DIR(0)="NA^1:"_ASUCNT D ^DIR K DIR S ASURPT=Y
. I 'ASURPT S ASURPT="" Q
. S ASURPT=ASULIST(4,ASURPT),ASURPT=ASULIST(1,ASURPT)
S ASUZ=""
F I=1:1:$L(ASURPT,",") S ASUX=$P(ASURPT,",",I) D
. Q:ASUX']""
. I ASUX["-" D
. . I ASUX["A" S ASUZ=ASUZ_$S(ASUZ]"":",",1:"")_"A" Q
. . F J=$P(ASUX,"-"):1:$P(ASUX,"-",2) D
. . . I $D(ASULIST(2,J)) S ASUZ=ASUZ_$S(ASUZ]"":",",1:"")_J
. I $D(ASULIST(2,ASUX)) S ASUZ=ASUZ_$S(ASUZ]"":",",1:"")_ASUX
S ASURPT=ASUZ
I ASURPT["A" S ASURPT="A" Q
I ASURPT']"" W *7," ??" G K2
Q
KLIST ;----- K REPORT LIST
;;K1;DRUGS;1
;;K2;MEDICAL/DENTAL/XRAY;2
;;K3;SUBSISTENCE;3
;;K4;LABORATORY;4
;;K5;OFFICE/ADMINISTRATIVE;5
;;K6;OTHER SUPPLIES;9
;;K7;TOTAL ALL CATEGORIES;999
;;ALL;ALL OF THE ABOVE;A
;;$$END
Q
KHELP ;----- HELP FOR REPORT SELECTION
;
W !!?5,"Select ONE report by number or name, or"
W !?5,"enter report NUMBERS separated by commas, or select a range of"
W !?5,"NUMBERS: for example '1,2,5', or '1-5', or '1,2,5-7',"
W !?5,"or select 'A' for All."
W !?5,"DO NOT mix numbers and names.",!
Q
QUIT ;----- KILL VARIABLES, CLOSE DEVICE, QUIT
;
K ZTSAVE
K ^XTMP("ASUR","RDBK")
I $G(ASUK("PTRSEL"))]"" W @IOF Q
D ^%ZISC
Q
ASURMDBK ; IHS/ITSC/LMH - MANAGEMENT SUPPLY DATA BOOK REPORTS K SERIES ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;;Y2K/OK/AEF/2970411
+3 ;This routine produces the Management Supply Data Book Reports K1-K7
+4 ;
EN ;EP -- MAIN ENTRY POINT (USER INTERACTIVE)
+1 ;
+2 NEW ASUDT,ASURPT,ASUTYP
+3 DO ^XBKVAR
DO HOME^%ZIS
+4 DO K^ASURMDBK
IF $GET(ASURPT)']""
GOTO QUIT
+5 DO SELXTRCT^ASUUTIL
IF '$DATA(ASUDT)
GOTO QUIT
+6 WRITE !,*7,"THIS REPORT REQUIRES 132 COLUMNS!"
+7 SET (ZTSAVE("ASUDT"),ZTSAVE("ASUTYP"),ZTSAVE("ASURPT"))=""
+8 DO QUE^ASUUTIL("DQ^ASURMDBK",.ZTSAVE,"SAMS MGMT SUPPLY DATABOOK REPORT K")
+9 DO QUIT
+10 QUIT
EN1(ASUDT,ASUTYP,ASURPT) ;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 ; ASURPT = which reports, i.e., K1, K2, K3, K4, K5, K6, K7
+5 ;
+6 DO ^XBKVAR
+7 IF '$DATA(^XTMP("ASUR","RDBK"))
DO GET
+8 DO PRT
DO QUIT
+9 QUIT
GET ;EP ; GATHER DATA
+1 ;
+2 ; Builds ^XTMP("ASUR","RDBK") global to sort and store
+3 ; transaction amounts
+4 ;
+5 ; ASU = array containing beginning, ending fiscal dates
+6 ; ASU0 = transaction type
+7 ; ASU1 = extracted date in 'AX' crossreference
+8 ; ASU2 = internal file entry number
+9 ; ASUD = array containing transaction data
+10 ; ASUPC = the piece in ^TMP global to put the total in
+11 ;
+12 NEW ASU,ASU0,ASU1,ASU2,ASUD,ASUPC
+13 KILL ^XTMP("ASUR","RDBK")
+14 DO FPP^ASUUTIL1(ASUDT)
+15 IF ASUTYP="M"
SET ASUDT=$$LDOM^ASUUTIL1(ASUDT)
+16 SET ASU1=ASU("DT","BEG2")-1
+17 FOR
SET ASU1=$ORDER(^ASUH("AX",ASU1))
IF 'ASU1
QUIT
IF ASU1>ASUDT
QUIT
Begin DoDot:1
+18 SET ASU2=0
FOR
SET ASU2=$ORDER(^ASUH("AX",ASU1,ASU2))
IF 'ASU2
QUIT
Begin DoDot:2
+19 SET ASUD("TRANS")=$PIECE($GET(^ASUH(ASU2,1)),U)
SET ASU0=$EXTRACT(ASUD("TRANS"))
IF ASU0=0
SET ASU0=7
+20 IF ASU0'=3&(ASU0'=7)
QUIT
+21 DO DATA16^ASUUTIL(ASU2)
+22 SET ASUPC=0
+23 IF ASU1'<ASU("DT","BEG")&(ASU1'>ASU("DT","END"))
SET ASUPC=0
+24 IF ASU1'<ASU("DT","BEG1")&(ASU1'>ASU("DT","END1"))
SET ASUPC=2
+25 IF ASU1'<ASU("DT","BEG2")&(ASU1'>ASU("DT","END2"))
SET ASUPC=4
+26 IF ASU0=3
SET ASUPC=ASUPC+1
+27 IF ASU0=7
SET ASUPC=ASUPC+2
+28 SET ASUD("ACC")=+$PIECE(ASUD("ACC"),".",2)
+29 DO SET
End DoDot:2
End DoDot:1
+30 QUIT
SET ;----- SETS TOTALS IN ^TMP GLOBAL
+1 ;
+2 SET $PIECE(^XTMP("ASUR","RDBK","IHS",ASUD("AREA"),ASUD("ACC"),0),U,ASUPC)=$PIECE($GET(^XTMP("ASUR","RDBK","IHS",ASUD("AREA"),ASUD("ACC"),0)),U,ASUPC)+ASUD("VAL")
+3 SET $PIECE(^XTMP("ASUR","RDBK","IHS",ASUD("AREA"),999,0),U,ASUPC)=$PIECE($GET(^XTMP("ASUR","RDBK","IHS",ASUD("AREA"),999,0)),U,ASUPC)+ASUD("VAL")
+4 SET $PIECE(^XTMP("ASUR","RDBK","IHS",ASUD("AREA"),ASUD("ACC"),ASUD("STA"),0),U,ASUPC)=$PIECE($GET(^XTMP("ASUR","RDBK","IHS",ASUD("AREA"),ASUD("ACC"),ASUD("STA"),0)),U,ASUPC)+ASUD("VAL")
+5 SET $PIECE(^XTMP("ASUR","RDBK","IHS",ASUD("AREA"),999,ASUD("STA"),0),U,ASUPC)=$PIECE($GET(^XTMP("ASUR","RDBK","IHS",ASUD("AREA"),999,ASUD("STA"),0)),U,ASUPC)+ASUD("VAL")
+6 QUIT
PRT ;----- PRINTS THE DATA
+1 ;
+2 ; ASUDATA = temporary data storage
+3 ; ASUL = array used for loop counters
+4 ; ASUOUT = '^' to escape controller
+5 ; ASUPAGE = report page number
+6 ;
+7 NEW ASUL,ASULIST,ASUOUT,ASUPAGE
+8 SET ASUOUT=0
+9 DO K1
DO LOOPS
+10 QUIT
LOOPS ;----- LOOPS THROUGH THE ^XTMP("ASUR","RDBK") GLOBAL AND PRINTS
+1 ; THE REPORT
+2 ;
1 ;----- LOOP THROUGH THE AREA SUBSCRIPT
+1 ;
+2 SET ASUL(1)=""
FOR
SET ASUL(1)=$ORDER(^XTMP("ASUR","RDBK","IHS",ASUL(1)))
IF ASUL(1)']""
QUIT
Begin DoDot:1
+3 IF ASUL(1)=0
QUIT
+4 DO 2
End DoDot:1
IF ASUOUT
QUIT
+5 QUIT
2 ;----- LOOP THROUGH THE REPORT NUMBER SUBSCRIPT
+1 ;
+2 NEW ASUDATA,I
+3 FOR I=1:1:$LENGTH(ASURPT,",")
SET ASUL(2)=$PIECE(ASURPT,",",I)
Begin DoDot:1
+4 DO HDR
IF ASUOUT
QUIT
+5 IF '$DATA(^XTMP("ASUR","RDBK","IHS",ASUL(1),ASUL(2)))
Begin DoDot:2
+6 WRITE !!,"NO DATA FOR DATA BOOK REPORT ",ASULIST(2,ASUL(2))
End DoDot:2
QUIT
+7 DO 3
IF ASUOUT
QUIT
+8 IF $Y>(IOSL-5)
DO HDR
IF ASUOUT
QUIT
+9 WRITE !!,"TOTAL"
+10 SET ASUDATA=^XTMP("ASUR","RDBK","IHS",ASUL(1),ASUL(2),0)
+11 DO WRITE(ASUDATA)
End DoDot:1
IF ASUOUT
QUIT
+12 QUIT
3 ;----- LOOP THROUGH THE STATION SUBSCRIPT
+1 ;
+2 NEW ASUDATA
+3 SET ASUL(3)=""
FOR
SET ASUL(3)=$ORDER(^XTMP("ASUR","RDBK","IHS",ASUL(1),ASUL(2),ASUL(3)))
IF ASUL(3)']""
QUIT
Begin DoDot:1
+4 IF ASUL(3)=0
QUIT
+5 IF $Y>(IOSL-5)
DO HDR
IF ASUOUT
QUIT
+6 SET ASUDATA=^XTMP("ASUR","RDBK","IHS",ASUL(1),ASUL(2),ASUL(3),0)
+7 WRITE !!,$EXTRACT(ASUL(3),1,15)
+8 DO WRITE(ASUDATA)
End DoDot:1
IF ASUOUT
QUIT
+9 QUIT
WRITE(X) ;
+1 ;----- WRITES REPORT DATA COLUMNS
+2 ;
+3 WRITE ?18,$JUSTIFY($PIECE(X,U),10,2),?30,$JUSTIFY($$DIV($PIECE(X,U),$PIECE(X,U)+$PIECE(X,U,2)),5,1)
+4 WRITE ?37,$JUSTIFY($PIECE(X,U,2),10,2),?49,$JUSTIFY($$DIV($PIECE(X,U,2),$PIECE(X,U)+$PIECE(X,U,2)),5,1)
+5 WRITE ?57,$JUSTIFY($PIECE(X,U,3),10,2),?69,$JUSTIFY($$DIV($PIECE(X,U,3),$PIECE(X,U,3)+$PIECE(X,U,4)),5,1)
+6 WRITE ?76,$JUSTIFY($PIECE(X,U,4),10,2),?88,$JUSTIFY($$DIV($PIECE(X,U,4),$PIECE(X,U,3)+$PIECE(X,U,4)),5,1)
+7 WRITE ?96,$JUSTIFY($PIECE(X,U,5),10,2),?108,$JUSTIFY($$DIV($PIECE(X,U,5),$PIECE(X,U,5)+$PIECE(X,U,6)),5,1)
+8 WRITE ?115,$JUSTIFY($PIECE(X,U,6),10,2),?127,$JUSTIFY($$DIV($PIECE(X,U,6),$PIECE(X,U,5)+$PIECE(X,U,6)),5,1)
+9 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 "MANAGEMENT SUPPLY DATA BOOK for "
+7 SET Y=ASUDT
XECUTE ^DD("DD")
WRITE $PIECE(Y," ")," ",$PIECE(Y,",",2)
+8 WRITE !,"AREA ",ASUL(1)
+9 WRITE !!,ASULIST(2,ASUL(2))," - ","DIRECT ISSUE VALUE versus STOCK ISSUE VALUE"
+10 WRITE !!?26,"CURRENT FISCAL YEAR",?65,"PREVIOUS FISCAL YEAR",?103,"PREV-PREV FISCAL YEAR"
+11 WRITE !?18,"DIRECT ISS",?34,"%",?37,"STOCK ISSU",?53,"%",?57,"DIRECT ISS",?73,"%",?76,"STOCK ISSU",?92,"%",?96,"DIRECT ISS",?112,"%",?115,"STOCK ISSU",?131,"%"
+12 WRITE !,"STATION",?23,"VALUE",?31,"D.I.",?42,"VALUE",?50,"S.I.",?62,"VALUE",?70,"D.I.",?81,"VALUE",?89,"S.I.",?101,"VALUE",?109,"D.I.",?120,"VALUE",?128,"S.I."
+13 QUIT
DIV(X1,X2) ;
+1 ;----- COMPUTES PERCENT - EXTRINSIC FUNCTION
+2 ; call by $$DIV(VALUE1,VALUE2)
+3 ;
+4 ; Returns percentage of first number divided by second number
+5 ;
+6 IF +X2=0
QUIT 0
+7 QUIT (X1/X2)*100
+8 ;
K ;----- SELECT THE K REPORTS TO PRINT
+1 ;
+2 ; Allows user to select which K reports to print
+3 ;
+4 ; Returns ASURPT = string containing which reports to print
+5 ;
+6 ; ASULIST = array containing list of selectable reports
+7 ; ASUDATA = temporary data storage
+8 ; ASUCNT = counter
+9 ;
+10 NEW ASULIST,I
+11 DO K1
DO K2
+12 IF ASURPT="A"
SET ASURPT=""
SET I=0
FOR
SET I=$ORDER(ASULIST(2,I))
IF 'I
QUIT
SET ASURPT=ASURPT_$SELECT(ASURPT]"":",",1:"")_I
+13 QUIT
K1 ;----- BUILDS SELECTION ARRAYS
+1 ;
+2 NEW ASUDATA,I,J
+3 FOR I=1:1
SET ASUDATA=$TEXT(KLIST+I)
IF ASUDATA["$$END"
QUIT
Begin DoDot:1
+4 FOR J=3:1:5
Begin DoDot:2
+5 IF $PIECE(ASUDATA,";",5)']""
QUIT
+6 IF $PIECE(ASUDATA,";",J)]""
SET ASULIST(1,$PIECE(ASUDATA,";",J))=$PIECE(ASUDATA,";",5)
SET ASULIST(2,$PIECE(ASUDATA,";",5))=$PIECE(ASUDATA,";",3)_" "_$PIECE(ASUDATA,";",4)
SET ASULIST(1,$PIECE(ASUDATA,";",3)_" "_$PIECE(ASUDATA,";",4))=$PIECE(ASUDATA,";",5)
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
K2 ;----- ISSUE PROMPTS TO CHOOSE WHICH REPORT(S)
+1 ;
+2 NEW ASUCNT,ASUX,ASUZ,DIR,I,J,X,Y
+3 WRITE !,"DIRECT ISSUE VALUE versus STOCK ISSUE VALUE Reports:",!
+4 SET I=""
FOR
SET I=$ORDER(ASULIST(2,I))
IF I']""
QUIT
WRITE !?3,I,?8,ASULIST(2,I)
+5 SET DIR(0)="FA"
+6 SET DIR("A")="Which report(s): "
+7 SET DIR("?")="Enter '??' for more help"
+8 SET DIR("??")="^D KHELP^ASURMDBK"
+9 DO ^DIR
+10 SET ASURPT=Y
+11 IF ASURPT']""!(ASURPT["^")
SET ASURPT=""
QUIT
+12 IF $LENGTH(ASURPT,",")=1&(ASURPT'["-")
Begin DoDot:1
+13 SET ASURPT=$PIECE(ASURPT,",")
+14 IF $DATA(ASULIST(1,ASURPT))
SET ASURPT=ASULIST(1,ASURPT)
QUIT
+15 KILL ASULIST(3),ASULIST(4)
+16 SET ASUX=""
FOR
SET ASUX=$ORDER(ASULIST(1,ASUX))
IF ASUX']""
QUIT
Begin DoDot:2
+17 IF $EXTRACT(ASUX,1,$LENGTH(ASURPT))=ASURPT
SET ASULIST(3,ASULIST(1,ASUX))=""
End DoDot:2
+18 SET ASUCNT=0
SET ASUX=""
FOR
SET ASUX=$ORDER(ASULIST(3,ASUX))
IF ASUX']""
QUIT
Begin DoDot:2
+19 SET ASUCNT=ASUCNT+1
SET ASULIST(4,ASUCNT)=ASULIST(2,ASUX)
End DoDot:2
+20 IF '$DATA(ASULIST(4))
WRITE *7," ??"
SET ASURPT=""
QUIT
+21 IF ASUCNT=1
SET ASURPT=ASULIST(4,ASUCNT)
SET ASURPT=ASULIST(1,ASURPT)
QUIT
+22 KILL ASURPT
+23 WRITE !
+24 SET (ASUCNT,I)=0
FOR
SET I=$ORDER(ASULIST(4,I))
IF 'I
QUIT
SET ASUCNT=ASUCNT+1
WRITE !?3,I_" "_ASULIST(4,I)
+25 WRITE !
SET DIR(0)="NA^1:"_ASUCNT
DO ^DIR
KILL DIR
SET ASURPT=Y
+26 IF 'ASURPT
SET ASURPT=""
QUIT
+27 SET ASURPT=ASULIST(4,ASURPT)
SET ASURPT=ASULIST(1,ASURPT)
End DoDot:1
IF ASURPT']""
GOTO K2
WRITE " ",$PIECE(ASULIST(2,ASURPT)," ",2)
QUIT
+28 SET ASUZ=""
+29 FOR I=1:1:$LENGTH(ASURPT,",")
SET ASUX=$PIECE(ASURPT,",",I)
Begin DoDot:1
+30 IF ASUX']""
QUIT
+31 IF ASUX["-"
Begin DoDot:2
+32 IF ASUX["A"
SET ASUZ=ASUZ_$SELECT(ASUZ]"":",",1:"")_"A"
QUIT
+33 FOR J=$PIECE(ASUX,"-"):1:$PIECE(ASUX,"-",2)
Begin DoDot:3
+34 IF $DATA(ASULIST(2,J))
SET ASUZ=ASUZ_$SELECT(ASUZ]"":",",1:"")_J
End DoDot:3
End DoDot:2
+35 IF $DATA(ASULIST(2,ASUX))
SET ASUZ=ASUZ_$SELECT(ASUZ]"":",",1:"")_ASUX
End DoDot:1
+36 SET ASURPT=ASUZ
+37 IF ASURPT["A"
SET ASURPT="A"
QUIT
+38 IF ASURPT']""
WRITE *7," ??"
GOTO K2
+39 QUIT
KLIST ;----- K REPORT LIST
+1 ;;K1;DRUGS;1
+2 ;;K2;MEDICAL/DENTAL/XRAY;2
+3 ;;K3;SUBSISTENCE;3
+4 ;;K4;LABORATORY;4
+5 ;;K5;OFFICE/ADMINISTRATIVE;5
+6 ;;K6;OTHER SUPPLIES;9
+7 ;;K7;TOTAL ALL CATEGORIES;999
+8 ;;ALL;ALL OF THE ABOVE;A
+9 ;;$$END
+10 QUIT
KHELP ;----- HELP FOR REPORT SELECTION
+1 ;
+2 WRITE !!?5,"Select ONE report by number or name, or"
+3 WRITE !?5,"enter report NUMBERS separated by commas, or select a range of"
+4 WRITE !?5,"NUMBERS: for example '1,2,5', or '1-5', or '1,2,5-7',"
+5 WRITE !?5,"or select 'A' for All."
+6 WRITE !?5,"DO NOT mix numbers and names.",!
+7 QUIT
QUIT ;----- KILL VARIABLES, CLOSE DEVICE, QUIT
+1 ;
+2 KILL ZTSAVE
+3 KILL ^XTMP("ASUR","RDBK")
+4 IF $GET(ASUK("PTRSEL"))]""
WRITE @IOF
QUIT
+5 DO ^%ZISC
+6 QUIT
