Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ASURMDBA

ASURMDBA.m

Go to the documentation of this file. 
  1. ASURMDBA ; IHS/ITSC/LMH - MANAGEMENT SUPPLY DATA BOOK REPORT A ; 
  1.  ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
  1.  ;;Y2K/OK AEF/2970324
  1.  ;This routine produces the Management Supply Data Book Report A
  1.  ;Records Processed into the Supply Accounting and Management System
  1.  ;
  1.  ;
  1. EN ;EP -- MAIN ENTRY POINT (USER INTERACTIVE)      
  1.  ;
  1.  N ASUDT,ASUTYP
  1.  D ^XBKVAR,HOME^%ZIS
  1.  D SELXTRCT^ASUUTIL G QUIT:'$D(ASUDT)
  1.  W !,*7,"THIS REPORT REQUIRES 132 COLUMNS!"
  1.  S ZTSAVE("ASUDT")="",ZTSAVE("ASUTYP")=""
  1.  D QUE^ASUUTIL("DQ^ASURMDBA",.ZTSAVE,"SAMS MGMT SUPPLY DATABOOK REPORT A")
  1.  D QUIT
  1.  Q
  1. EN1(ASUDT,ASUTYP)  ;EP
  1.  ;----- ENTRY POINT CALLED BY ^ASURMSTD (NON-USER INTERACTIVE)
  1.  ;
  1. DQ ;EP -- QUEUED JOB STARTS HERE
  1.  ;
  1.  ;      ASUDT  = report extract date or month
  1.  ;      ASUTYP = type of report, I=individual, M=monthly
  1.  ;
  1.  D ^XBKVAR
  1.  D:'$D(^XTMP("ASUR","RDBA")) GET
  1.  D PRT,QUIT
  1.  Q
  1. GET ;EP ; GATHER DATA
  1.  ;
  1.  ;      Builds ^XTMP("ASUR","RDBA") global to sort and store
  1.  ;      transaction counts
  1.  ;
  1.  ;      ASU      =  array containing beginning, ending fiscal dates
  1.  ;      ASU1     =  extracted date in 'AX' crossreference
  1.  ;      ASU2     =  internal file entry number
  1.  ;      ASUD     =  array containing transaction data
  1.  ;      ASUREV   =  array containing transaction reverse codes
  1.  ;      ASUPC    =  which piece in the ^TMP global to put the count in
  1.  ;
  1.  N ASU,ASU1,ASU2,ASUD,ASUPC,ASUREV
  1.  K ^XTMP("ASUR","RDBA")
  1.  D FPP^ASUUTIL1(ASUDT)
  1.  I ASUTYP="M" S ASUDT=$$LDOM^ASUUTIL1(ASUDT)
  1.  D REV
  1.  S ASU1=ASU("DT","BEG2")-1
  1.  F  S ASU1=$O(^ASUH("AX",ASU1)) Q:'ASU1  Q:ASU1>ASUDT  D
  1.  . S ASU2=0 F  S ASU2=$O(^ASUH("AX",ASU1,ASU2)) Q:'ASU2  D
  1.  . . D DATA16^ASUUTIL(ASU2)
  1.  . . S ASUPC=0
  1.  . . I ASU1'<ASU("DT","BEG")&(ASU1'>ASU("DT","END")) S ASUPC=0
  1.  . . I ASU1'<ASU("DT","BEG1")&(ASU1'>ASU("DT","END1")) S ASUPC=3
  1.  . . I ASU1'<ASU("DT","BEG2")&(ASU1'>ASU("DT","END2")) S ASUPC=6
  1.  . . I '$D(ASUREV(ASUD("TRANS"))),ASUD("STATUS")'="R" S ASUPC=ASUPC+1
  1.  . . I $D(ASUREV(ASUD("TRANS"))),ASUD("STATUS")'="R" S ASUPC=ASUPC+2
  1.  . . I ASUD("STATUS")="R" S ASUPC=ASUPC+3
  1.  . . D SET
  1.  Q
  1. SET ;----- SETS COUNTS IN ^TMP GLOBAL
  1.  ;
  1.  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
  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
  1.  Q
  1. PRT ;----- PRINTS THE REPORT
  1.  ;
  1.  ;      ASUDATA  =  temporary data storage
  1.  ;      ASUL     =  array used for loop counters
  1.  ;      ASUOUT   =  '^' to escape controller
  1.  ;      ASUPAGE  =  report page number
  1.  ;
  1.  N ASUL,ASUOUT,ASUPAGE
  1.  I '$D(^XTMP("ASUR","RDBA")) W !!,"NO DATA FOR DATABOOK REPORT A" Q
  1.  S ASUOUT=0
  1.  D LOOPS
  1.  Q
  1. LOOPS ;----- LOOPS THROUGH THE ^TMP("ASU",$J,"ASURMDBA") GLOBAL AND PRINTS
  1.  ;      THE REPORT
  1.  ;
  1. 1 ;----- LOOP THROUGH THE AREA SUBSCRIPT
  1.  ;
  1.  S ASUL(1)="" F  S ASUL(1)=$O(^XTMP("ASUR","RDBA","IHS",ASUL(1))) Q:ASUL(1)']""  D  Q:ASUOUT
  1.  . Q:ASUL(1)=0
  1.  . D 2 Q:ASUOUT
  1.  Q
  1. 2 ;----- LOOP THROUGH THE ACCOUNT SUBSCRIPT
  1.  ;
  1.  N ASUDATA
  1.  S ASUL(2)="" F  S ASUL(2)=$O(^XTMP("ASUR","RDBA","IHS",ASUL(1),ASUL(2))) Q:ASUL(2)']""  D  Q:ASUOUT
  1.  . Q:ASUL(2)=0
  1.  . D HDR Q:ASUOUT
  1.  . D 3 Q:ASUOUT
  1.  . I $Y>(IOSL-5) D HDR Q:ASUOUT
  1.  . S ASUDATA=^XTMP("ASUR","RDBA","IHS",ASUL(1),ASUL(2),0)
  1.  . W !,"TOTAL"
  1.  . D WRITE(ASUDATA)
  1.  Q
  1. 3 ;----- LOOP THROUGH THE STATION SUBSCRIPT
  1.  ;
  1.  N ASUDATA
  1.  S ASUL(3)="" F  S ASUL(3)=$O(^XTMP("ASUR","RDBA","IHS",ASUL(1),ASUL(2),ASUL(3))) Q:ASUL(3)']""  D  Q:ASUOUT
  1.  . Q:ASUL(3)=0
  1.  . I $Y>(IOSL-5) D HDR Q:ASUOUT
  1.  . S ASUDATA=^XTMP("ASUR","RDBA","IHS",ASUL(1),ASUL(2),ASUL(3),0)
  1.  . W !,$E(ASUL(3),1,20)
  1.  . D WRITE(ASUDATA)
  1.  Q
  1. WRITE(X) ;----- WRITES DATA
  1.  ;
  1.  ;      X = contains the data to be written
  1.  ;
  1.  N ASUX
  1.  W ?24,$J($P(X,U),8),?34,$J($P(X,U,2),8),?44,$J($P(X,U,3),8)
  1.  S ASUX=$$PRCNT($P(X,U)+$P(X,U,2),$P(X,U,3))
  1.  I +ASUX'=0 W ?54,$J(ASUX,4,1)
  1.  W ?61,$J($P(X,U,4),8),?71,$J($P(X,U,5),8),?81,$J($P(X,U,6),8)
  1.  S ASUX=$$PRCNT($P(X,U,4)+$P(X,U,5),$P(X,U,6))
  1.  I +ASUX'=0 W ?91,$J(ASUX,4,1)
  1.  W ?98,$J($P(X,U,7),8),?108,$J($P(X,U,8),8),?118,$J($P(X,U,9),8)
  1.  S ASUX=$$PRCNT($P(X,U,7)+$P(X,U,8),$P(X,U,9))
  1.  I +ASUX'=0 W ?128,$J(ASUX,4,1)
  1.  W !
  1.  Q
  1. HDR ;----- WRITES REPORT HEADER
  1.  ;
  1.  N %,DIR,X,Y
  1.  I $E(IOST)="C",$G(ASUPAGE) S DIR(0)="E" D ^DIR K DIR I 'Y S ASUOUT=1 Q
  1.  S ASUPAGE=$G(ASUPAGE)+1
  1.  W @IOF
  1.  W "MANAGEMENT SUPPLY DATA BOOK FOR "
  1.  S Y=ASUDT X ^DD("DD") W $P(Y," ")," ",$P(Y,",",2)
  1.  W !,"AREA ",ASUL(1)
  1.  W !!,"A. RECORDS PROCESSED INTO THE SUPPLY ACCOUNTING AND MANAGEMENT SYSTEM (SAMS)"
  1.  W !?3,"Category: ",ASUL(2)
  1.  W !!?29,"CURRENT FISCAL YEAR",?66,"PREVIOUS FISCAL YEAR",?103,"PREV-PREV FISCAL YEAR"
  1.  W !?25,"Number   Number     Number      %",?62,"Number   Number     Number      %",?99,"Number   Number     Number      %"
  1.  W !,"STATION",?25,"Regular  Reversal   Rejects   Rej",?62,"Regular  Reversal   Rejects   Rej",?99,"Regular  Reversal   Rejects   Rej"
  1.  W !
  1.  Q
  1. REV ;----- SETS UP REVERSAL TRANSACTION CODE ARRAY
  1.  ;
  1.  ;      Returns AUSREV array containing SAMS reversal transaction codes
  1.  ;
  1.  K ASUREV
  1.  F ASUREV="3J","3K","3M","3O","0K","0M","0N","0O","2K","2M","2N","2O","2P","3P","1K","1M","1N","1O" S ASUREV(ASUREV)=""
  1.  Q
  1. PRCNT(X,Y)         ;
  1.  ;----- CALCULATES PERCENT OF REJECTS
  1.  ;
  1.  I +X=0 Q ""
  1.  Q (Y/X)*100
  1.  ;
  1. QUIT ;CLEAN UP VARIABLES, CLOSE DEVICE, QUIT
  1.  ;
  1.  K ZTSAVE
  1.  K ^XTMP("ASUR","RDBA")
  1.  I $G(ASUK("PTRSEL"))]"" W @IOF Q
  1.  D ^%ZISC
  1.  Q