ASURMDBA ; IHS/ITSC/LMH - MANAGEMENT SUPPLY DATA BOOK REPORT A ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;;Y2K/OK AEF/2970324
;This routine produces the Management Supply Data Book Report A
;Records Processed into the Supply Accounting and Management System
;
;
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^ASURMDBA",.ZTSAVE,"SAMS MGMT SUPPLY DATABOOK REPORT A")
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","RDBA")) GET
D PRT,QUIT
Q
GET ;EP ; GATHER DATA
;
; Builds ^XTMP("ASUR","RDBA") global to sort and store
; transaction counts
;
; ASU = array containing beginning, ending fiscal dates
; ASU1 = extracted date in 'AX' crossreference
; ASU2 = internal file entry number
; ASUD = array containing transaction data
; ASUREV = array containing transaction reverse codes
; ASUPC = which piece in the ^TMP global to put the count in
;
N ASU,ASU1,ASU2,ASUD,ASUPC,ASUREV
K ^XTMP("ASUR","RDBA")
D FPP^ASUUTIL1(ASUDT)
I ASUTYP="M" S ASUDT=$$LDOM^ASUUTIL1(ASUDT)
D REV
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
. . 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=3
. . I ASU1'<ASU("DT","BEG2")&(ASU1'>ASU("DT","END2")) S ASUPC=6
. . I '$D(ASUREV(ASUD("TRANS"))),ASUD("STATUS")'="R" S ASUPC=ASUPC+1
. . I $D(ASUREV(ASUD("TRANS"))),ASUD("STATUS")'="R" S ASUPC=ASUPC+2
. . I ASUD("STATUS")="R" S ASUPC=ASUPC+3
. . D SET
Q
SET ;----- SETS COUNTS IN ^TMP GLOBAL
;
S $P(^XTMP("ASUR","RDBA","IHS",ASUD("AREA"),ASUD("ACCNAM"),0),U,ASUPC)=$P($G(^XTMP("ASUR","RDBA","IHS",ASUD("AREA"),ASUD("ACCNAM"),0)),U,ASUPC)+1
S $P(^XTMP("ASUR","RDBA","IHS",ASUD("AREA"),ASUD("ACCNAM"),ASUD("STA"),0),U,ASUPC)=$P($G(^XTMP("ASUR","RDBA","IHS",ASUD("AREA"),ASUD("ACCNAM"),ASUD("STA"),0)),U,ASUPC)+1
Q
PRT ;----- PRINTS THE REPORT
;
; ASUDATA = 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","RDBA")) W !!,"NO DATA FOR DATABOOK REPORT A" Q
S ASUOUT=0
D LOOPS
Q
LOOPS ;----- LOOPS THROUGH THE ^TMP("ASU",$J,"ASURMDBA") GLOBAL AND PRINTS
; THE REPORT
;
1 ;----- LOOP THROUGH THE AREA SUBSCRIPT
;
S ASUL(1)="" F S ASUL(1)=$O(^XTMP("ASUR","RDBA","IHS",ASUL(1))) Q:ASUL(1)']"" D Q:ASUOUT
. Q:ASUL(1)=0
. D 2 Q:ASUOUT
Q
2 ;----- LOOP THROUGH THE ACCOUNT SUBSCRIPT
;
N ASUDATA
S ASUL(2)="" F S ASUL(2)=$O(^XTMP("ASUR","RDBA","IHS",ASUL(1),ASUL(2))) Q:ASUL(2)']"" D Q:ASUOUT
. Q:ASUL(2)=0
. D HDR Q:ASUOUT
. D 3 Q:ASUOUT
. I $Y>(IOSL-5) D HDR Q:ASUOUT
. S ASUDATA=^XTMP("ASUR","RDBA","IHS",ASUL(1),ASUL(2),0)
. W !,"TOTAL"
. D WRITE(ASUDATA)
Q
3 ;----- LOOP THROUGH THE STATION SUBSCRIPT
;
N ASUDATA
S ASUL(3)="" F S ASUL(3)=$O(^XTMP("ASUR","RDBA","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","RDBA","IHS",ASUL(1),ASUL(2),ASUL(3),0)
. W !,$E(ASUL(3),1,20)
. D WRITE(ASUDATA)
Q
WRITE(X) ;----- WRITES DATA
;
; X = contains the data to be written
;
N ASUX
W ?24,$J($P(X,U),8),?34,$J($P(X,U,2),8),?44,$J($P(X,U,3),8)
S ASUX=$$PRCNT($P(X,U)+$P(X,U,2),$P(X,U,3))
I +ASUX'=0 W ?54,$J(ASUX,4,1)
W ?61,$J($P(X,U,4),8),?71,$J($P(X,U,5),8),?81,$J($P(X,U,6),8)
S ASUX=$$PRCNT($P(X,U,4)+$P(X,U,5),$P(X,U,6))
I +ASUX'=0 W ?91,$J(ASUX,4,1)
W ?98,$J($P(X,U,7),8),?108,$J($P(X,U,8),8),?118,$J($P(X,U,9),8)
S ASUX=$$PRCNT($P(X,U,7)+$P(X,U,8),$P(X,U,9))
I +ASUX'=0 W ?128,$J(ASUX,4,1)
W !
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 !!,"A. RECORDS PROCESSED INTO THE SUPPLY ACCOUNTING AND MANAGEMENT SYSTEM (SAMS)"
W !?3,"Category: ",ASUL(2)
W !!?29,"CURRENT FISCAL YEAR",?66,"PREVIOUS FISCAL YEAR",?103,"PREV-PREV FISCAL YEAR"
W !?25,"Number Number Number %",?62,"Number Number Number %",?99,"Number Number Number %"
W !,"STATION",?25,"Regular Reversal Rejects Rej",?62,"Regular Reversal Rejects Rej",?99,"Regular Reversal Rejects Rej"
W !
Q
REV ;----- SETS UP REVERSAL TRANSACTION CODE ARRAY
;
; Returns AUSREV array containing SAMS reversal transaction codes
;
K ASUREV
F ASUREV="3J","3K","3M","3O","0K","0M","0N","0O","2K","2M","2N","2O","2P","3P","1K","1M","1N","1O" S ASUREV(ASUREV)=""
Q
PRCNT(X,Y) ;
;----- CALCULATES PERCENT OF REJECTS
;
I +X=0 Q ""
Q (Y/X)*100
;
QUIT ;CLEAN UP VARIABLES, CLOSE DEVICE, QUIT
;
K ZTSAVE
K ^XTMP("ASUR","RDBA")
I $G(ASUK("PTRSEL"))]"" W @IOF Q
D ^%ZISC
Q
ASURMDBA ; IHS/ITSC/LMH - MANAGEMENT SUPPLY DATA BOOK REPORT A ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;;Y2K/OK AEF/2970324
+3 ;This routine produces the Management Supply Data Book Report A
+4 ;Records Processed into the Supply Accounting and Management System
+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^ASURMDBA",.ZTSAVE,"SAMS MGMT SUPPLY DATABOOK REPORT A")
+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","RDBA"))
DO GET
+7 DO PRT
DO QUIT
+8 QUIT
GET ;EP ; GATHER DATA
+1 ;
+2 ; Builds ^XTMP("ASUR","RDBA") global to sort and store
+3 ; transaction counts
+4 ;
+5 ; ASU = array containing beginning, ending fiscal dates
+6 ; ASU1 = extracted date in 'AX' crossreference
+7 ; ASU2 = internal file entry number
+8 ; ASUD = array containing transaction data
+9 ; ASUREV = array containing transaction reverse codes
+10 ; ASUPC = which piece in the ^TMP global to put the count in
+11 ;
+12 NEW ASU,ASU1,ASU2,ASUD,ASUPC,ASUREV
+13 KILL ^XTMP("ASUR","RDBA")
+14 DO FPP^ASUUTIL1(ASUDT)
+15 IF ASUTYP="M"
SET ASUDT=$$LDOM^ASUUTIL1(ASUDT)
+16 DO REV
+17 SET ASU1=ASU("DT","BEG2")-1
+18 FOR
SET ASU1=$ORDER(^ASUH("AX",ASU1))
IF 'ASU1
QUIT
IF ASU1>ASUDT
QUIT
Begin DoDot:1
+19 SET ASU2=0
FOR
SET ASU2=$ORDER(^ASUH("AX",ASU1,ASU2))
IF 'ASU2
QUIT
Begin DoDot:2
+20 DO DATA16^ASUUTIL(ASU2)
+21 SET ASUPC=0
+22 IF ASU1'<ASU("DT","BEG")&(ASU1'>ASU("DT","END"))
SET ASUPC=0
+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=6
+25 IF '$DATA(ASUREV(ASUD("TRANS")))
IF ASUD("STATUS")'="R"
SET ASUPC=ASUPC+1
+26 IF $DATA(ASUREV(ASUD("TRANS")))
IF ASUD("STATUS")'="R"
SET ASUPC=ASUPC+2
+27 IF ASUD("STATUS")="R"
SET ASUPC=ASUPC+3
+28 DO SET
End DoDot:2
End DoDot:1
+29 QUIT
SET ;----- SETS COUNTS IN ^TMP GLOBAL
+1 ;
+2 SET $PIECE(^XTMP("ASUR","RDBA","IHS",ASUD("AREA"),ASUD("ACCNAM"),0),U,ASUPC)=$PIECE($GET(^XTMP("ASUR","RDBA","IHS",ASUD("AREA"),ASUD("ACCNAM"),0)),U,ASUPC)+1
+3 SET $PIECE(^XTMP("ASUR","RDBA","IHS",ASUD("AREA"),ASUD("ACCNAM"),ASUD("STA"),0),U,ASUPC)=$PIECE($GET(^XTMP("ASUR","RDBA","IHS",ASUD("AREA"),ASUD("ACCNAM"),ASUD("STA"),0)),U,ASUPC)+1
+4 QUIT
PRT ;----- PRINTS THE REPORT
+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,ASUOUT,ASUPAGE
+8 IF '$DATA(^XTMP("ASUR","RDBA"))
WRITE !!,"NO DATA FOR DATABOOK REPORT A"
QUIT
+9 SET ASUOUT=0
+10 DO LOOPS
+11 QUIT
LOOPS ;----- LOOPS THROUGH THE ^TMP("ASU",$J,"ASURMDBA") 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","RDBA","IHS",ASUL(1)))
IF ASUL(1)']""
QUIT
Begin DoDot:1
+3 IF ASUL(1)=0
QUIT
+4 DO 2
IF ASUOUT
QUIT
End DoDot:1
IF ASUOUT
QUIT
+5 QUIT
2 ;----- LOOP THROUGH THE ACCOUNT SUBSCRIPT
+1 ;
+2 NEW ASUDATA
+3 SET ASUL(2)=""
FOR
SET ASUL(2)=$ORDER(^XTMP("ASUR","RDBA","IHS",ASUL(1),ASUL(2)))
IF ASUL(2)']""
QUIT
Begin DoDot:1
+4 IF ASUL(2)=0
QUIT
+5 DO HDR
IF ASUOUT
QUIT
+6 DO 3
IF ASUOUT
QUIT
+7 IF $Y>(IOSL-5)
DO HDR
IF ASUOUT
QUIT
+8 SET ASUDATA=^XTMP("ASUR","RDBA","IHS",ASUL(1),ASUL(2),0)
+9 WRITE !,"TOTAL"
+10 DO WRITE(ASUDATA)
End DoDot:1
IF ASUOUT
QUIT
+11 QUIT
3 ;----- LOOP THROUGH THE STATION SUBSCRIPT
+1 ;
+2 NEW ASUDATA
+3 SET ASUL(3)=""
FOR
SET ASUL(3)=$ORDER(^XTMP("ASUR","RDBA","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","RDBA","IHS",ASUL(1),ASUL(2),ASUL(3),0)
+7 WRITE !,$EXTRACT(ASUL(3),1,20)
+8 DO WRITE(ASUDATA)
End DoDot:1
IF ASUOUT
QUIT
+9 QUIT
WRITE(X) ;----- WRITES DATA
+1 ;
+2 ; X = contains the data to be written
+3 ;
+4 NEW ASUX
+5 WRITE ?24,$JUSTIFY($PIECE(X,U),8),?34,$JUSTIFY($PIECE(X,U,2),8),?44,$JUSTIFY($PIECE(X,U,3),8)
+6 SET ASUX=$$PRCNT($PIECE(X,U)+$PIECE(X,U,2),$PIECE(X,U,3))
+7 IF +ASUX'=0
WRITE ?54,$JUSTIFY(ASUX,4,1)
+8 WRITE ?61,$JUSTIFY($PIECE(X,U,4),8),?71,$JUSTIFY($PIECE(X,U,5),8),?81,$JUSTIFY($PIECE(X,U,6),8)
+9 SET ASUX=$$PRCNT($PIECE(X,U,4)+$PIECE(X,U,5),$PIECE(X,U,6))
+10 IF +ASUX'=0
WRITE ?91,$JUSTIFY(ASUX,4,1)
+11 WRITE ?98,$JUSTIFY($PIECE(X,U,7),8),?108,$JUSTIFY($PIECE(X,U,8),8),?118,$JUSTIFY($PIECE(X,U,9),8)
+12 SET ASUX=$$PRCNT($PIECE(X,U,7)+$PIECE(X,U,8),$PIECE(X,U,9))
+13 IF +ASUX'=0
WRITE ?128,$JUSTIFY(ASUX,4,1)
+14 WRITE !
+15 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 !!,"A. RECORDS PROCESSED INTO THE SUPPLY ACCOUNTING AND MANAGEMENT SYSTEM (SAMS)"
+10 WRITE !?3,"Category: ",ASUL(2)
+11 WRITE !!?29,"CURRENT FISCAL YEAR",?66,"PREVIOUS FISCAL YEAR",?103,"PREV-PREV FISCAL YEAR"
+12 WRITE !?25,"Number Number Number %",?62,"Number Number Number %",?99,"Number Number Number %"
+13 WRITE !,"STATION",?25,"Regular Reversal Rejects Rej",?62,"Regular Reversal Rejects Rej",?99,"Regular Reversal Rejects Rej"
+14 WRITE !
+15 QUIT
REV ;----- SETS UP REVERSAL TRANSACTION CODE ARRAY
+1 ;
+2 ; Returns AUSREV array containing SAMS reversal transaction codes
+3 ;
+4 KILL ASUREV
+5 FOR ASUREV="3J","3K","3M","3O","0K","0M","0N","0O","2K","2M","2N","2O","2P","3P","1K","1M","1N","1O"
SET ASUREV(ASUREV)=""
+6 QUIT
PRCNT(X,Y) ;
+1 ;----- CALCULATES PERCENT OF REJECTS
+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","RDBA")
+4 IF $GET(ASUK("PTRSEL"))]""
WRITE @IOF
QUIT
+5 DO ^%ZISC
+6 QUIT
