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

ASURMDBK.m

Go to the documentation of this file. 
  1. ASURMDBK ; IHS/ITSC/LMH - MANAGEMENT SUPPLY DATA BOOK REPORTS K SERIES ; 
  1.  ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
  1.  ;;Y2K/OK/AEF/2970411
  1.  ;This routine produces the Management Supply Data Book Reports K1-K7
  1.  ;
  1. EN ;EP -- MAIN ENTRY POINT (USER INTERACTIVE)
  1.  ;
  1.  N ASUDT,ASURPT,ASUTYP
  1.  D ^XBKVAR,HOME^%ZIS
  1.  D K^ASURMDBK G QUIT:$G(ASURPT)']""
  1.  D SELXTRCT^ASUUTIL G QUIT:'$D(ASUDT)
  1.  W !,*7,"THIS REPORT REQUIRES 132 COLUMNS!"
  1.  S (ZTSAVE("ASUDT"),ZTSAVE("ASUTYP"),ZTSAVE("ASURPT"))=""
  1.  D QUE^ASUUTIL("DQ^ASURMDBK",.ZTSAVE,"SAMS MGMT SUPPLY DATABOOK REPORT K")
  1.  D QUIT
  1.  Q
  1. EN1(ASUDT,ASUTYP,ASURPT)     ;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.  ;      ASURPT = which reports, i.e., K1, K2, K3, K4, K5, K6, K7
  1.  ;
  1.  D ^XBKVAR
  1.  D:'$D(^XTMP("ASUR","RDBK")) GET
  1.  D PRT,QUIT
  1.  Q
  1. GET ;EP ; GATHER DATA
  1.  ;
  1.  ;      Builds ^XTMP("ASUR","RDBK") global to sort and store
  1.  ;      transaction amounts
  1.  ;
  1.  ;      ASU     =  array containing beginning, ending fiscal dates
  1.  ;      ASU0    =  transaction type
  1.  ;      ASU1    =  extracted date in 'AX' crossreference
  1.  ;      ASU2    =  internal file entry number
  1.  ;      ASUD    =  array containing transaction data
  1.  ;      ASUPC   =  the piece in ^TMP global to put the total in
  1.  ;
  1.  N ASU,ASU0,ASU1,ASU2,ASUD,ASUPC
  1.  K ^XTMP("ASUR","RDBK")
  1.  D FPP^ASUUTIL1(ASUDT)
  1.  I ASUTYP="M" S ASUDT=$$LDOM^ASUUTIL1(ASUDT)
  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.  . . S ASUD("TRANS")=$P($G(^ASUH(ASU2,1)),U),ASU0=$E(ASUD("TRANS")) S:ASU0=0 ASU0=7
  1.  . . I ASU0'=3&(ASU0'=7) Q
  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=2
  1.  . . I ASU1'<ASU("DT","BEG2")&(ASU1'>ASU("DT","END2")) S ASUPC=4
  1.  . . I ASU0=3 S ASUPC=ASUPC+1
  1.  . . I ASU0=7 S ASUPC=ASUPC+2
  1.  . . S ASUD("ACC")=+$P(ASUD("ACC"),".",2)
  1.  . . D SET
  1.  Q
  1. SET ;----- SETS TOTALS IN ^TMP GLOBAL
  1.  ;
  1.  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")
  1.  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")
  1.  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")
  1.  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")
  1.  Q
  1. PRT ;----- PRINTS THE DATA
  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,ASULIST,ASUOUT,ASUPAGE
  1.  S ASUOUT=0
  1.  D K1,LOOPS
  1.  Q
  1. LOOPS ;----- LOOPS THROUGH THE ^XTMP("ASUR","RDBK") 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","RDBK","IHS",ASUL(1))) Q:ASUL(1)']""  D  Q:ASUOUT
  1.  . Q:ASUL(1)=0
  1.  . D 2
  1.  Q
  1. 2 ;----- LOOP THROUGH THE REPORT NUMBER SUBSCRIPT
  1.  ;
  1.  N ASUDATA,I
  1.  F I=1:1:$L(ASURPT,",") S ASUL(2)=$P(ASURPT,",",I) D  Q:ASUOUT
  1.  . D HDR Q:ASUOUT
  1.  . I '$D(^XTMP("ASUR","RDBK","IHS",ASUL(1),ASUL(2))) D  Q
  1.  . . W !!,"NO DATA FOR DATA BOOK REPORT ",ASULIST(2,ASUL(2))
  1.  . D 3 Q:ASUOUT
  1.  . I $Y>(IOSL-5) D HDR Q:ASUOUT
  1.  . W !!,"TOTAL"
  1.  . S ASUDATA=^XTMP("ASUR","RDBK","IHS",ASUL(1),ASUL(2),0)
  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","RDBK","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","RDBK","IHS",ASUL(1),ASUL(2),ASUL(3),0)
  1.  . W !!,$E(ASUL(3),1,15)
  1.  . D WRITE(ASUDATA)
  1.  Q
  1. WRITE(X) ;
  1.  ;----- WRITES REPORT DATA COLUMNS
  1.  ;
  1.  W ?18,$J($P(X,U),10,2),?30,$J($$DIV($P(X,U),$P(X,U)+$P(X,U,2)),5,1)
  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)
  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)
  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)
  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)
  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)
  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 !!,ASULIST(2,ASUL(2))," - ","DIRECT ISSUE VALUE versus STOCK ISSUE VALUE"
  1.  W !!?26,"CURRENT FISCAL YEAR",?65,"PREVIOUS FISCAL YEAR",?103,"PREV-PREV FISCAL YEAR"
  1.  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,"%"
  1.  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."
  1.  Q
  1. DIV(X1,X2)         ;
  1.  ;----- COMPUTES PERCENT - EXTRINSIC FUNCTION
  1.  ;      call by $$DIV(VALUE1,VALUE2)
  1.  ;
  1.  ;      Returns percentage of first number divided by second number
  1.  ;
  1.  I +X2=0 Q 0
  1.  Q (X1/X2)*100
  1.  ;
  1. K ;----- SELECT THE K REPORTS TO PRINT
  1.  ;
  1.  ;      Allows user to select which K reports to print
  1.  ;
  1.  ;      Returns ASURPT = string containing which reports to print
  1.  ;
  1.  ;      ASULIST  = array containing list of selectable reports
  1.  ;      ASUDATA  = temporary data storage
  1.  ;      ASUCNT   = counter
  1.  ;
  1.  N ASULIST,I
  1.  D K1,K2
  1.  I ASURPT="A" S ASURPT="",I=0 F  S I=$O(ASULIST(2,I)) Q:'I  S ASURPT=ASURPT_$S(ASURPT]"":",",1:"")_I
  1.  Q
  1. K1 ;----- BUILDS SELECTION ARRAYS
  1.  ;
  1.  N ASUDATA,I,J
  1.  F I=1:1 S ASUDATA=$T(KLIST+I) Q:ASUDATA["$$END"  D
  1.  . F J=3:1:5 D
  1.  . . Q:$P(ASUDATA,";",5)']""
  1.  . . 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)
  1.  Q
  1.  ;
  1. K2 ;----- ISSUE PROMPTS TO CHOOSE WHICH REPORT(S)
  1.  ;
  1.  N ASUCNT,ASUX,ASUZ,DIR,I,J,X,Y
  1.  W !,"DIRECT ISSUE VALUE versus STOCK ISSUE VALUE Reports:",!
  1.  S I="" F  S I=$O(ASULIST(2,I)) Q:I']""  W !?3,I,?8,ASULIST(2,I)
  1.  S DIR(0)="FA"
  1.  S DIR("A")="Which report(s): "
  1.  S DIR("?")="Enter '??' for more help"
  1.  S DIR("??")="^D KHELP^ASURMDBK"
  1.  D ^DIR
  1.  S ASURPT=Y
  1.  I ASURPT']""!(ASURPT["^") S ASURPT="" Q
  1.  I $L(ASURPT,",")=1&(ASURPT'["-") D  G:ASURPT']"" K2 W "  ",$P(ASULIST(2,ASURPT),"  ",2) Q
  1.  . S ASURPT=$P(ASURPT,",")
  1.  . I $D(ASULIST(1,ASURPT)) S ASURPT=ASULIST(1,ASURPT) Q
  1.  . K ASULIST(3),ASULIST(4)
  1.  . S ASUX="" F  S ASUX=$O(ASULIST(1,ASUX)) Q:ASUX']""  D
  1.  . . I $E(ASUX,1,$L(ASURPT))=ASURPT S ASULIST(3,ASULIST(1,ASUX))=""
  1.  . S ASUCNT=0,ASUX="" F  S ASUX=$O(ASULIST(3,ASUX)) Q:ASUX']""  D
  1.  . . S ASUCNT=ASUCNT+1,ASULIST(4,ASUCNT)=ASULIST(2,ASUX)
  1.  . I '$D(ASULIST(4)) W *7," ??" S ASURPT="" Q
  1.  . I ASUCNT=1 S ASURPT=ASULIST(4,ASUCNT),ASURPT=ASULIST(1,ASURPT) Q
  1.  . K ASURPT
  1.  . W !
  1.  . S (ASUCNT,I)=0 F  S I=$O(ASULIST(4,I)) Q:'I  S ASUCNT=ASUCNT+1 W !?3,I_"  "_ASULIST(4,I)
  1.  . W ! S DIR(0)="NA^1:"_ASUCNT D ^DIR K DIR S ASURPT=Y
  1.  . I 'ASURPT S ASURPT="" Q
  1.  . S ASURPT=ASULIST(4,ASURPT),ASURPT=ASULIST(1,ASURPT)
  1.  S ASUZ=""
  1.  F I=1:1:$L(ASURPT,",") S ASUX=$P(ASURPT,",",I) D
  1.  . Q:ASUX']""
  1.  . I ASUX["-" D
  1.  . . I ASUX["A" S ASUZ=ASUZ_$S(ASUZ]"":",",1:"")_"A" Q
  1.  . . F J=$P(ASUX,"-"):1:$P(ASUX,"-",2) D
  1.  . . . I $D(ASULIST(2,J)) S ASUZ=ASUZ_$S(ASUZ]"":",",1:"")_J
  1.  . I $D(ASULIST(2,ASUX)) S ASUZ=ASUZ_$S(ASUZ]"":",",1:"")_ASUX
  1.  S ASURPT=ASUZ
  1.  I ASURPT["A" S ASURPT="A" Q
  1.  I ASURPT']"" W *7," ??" G K2
  1.  Q
  1. KLIST ;----- K REPORT LIST
  1.  ;;K1;DRUGS;1
  1.  ;;K2;MEDICAL/DENTAL/XRAY;2
  1.  ;;K3;SUBSISTENCE;3
  1.  ;;K4;LABORATORY;4
  1.  ;;K5;OFFICE/ADMINISTRATIVE;5
  1.  ;;K6;OTHER SUPPLIES;9
  1.  ;;K7;TOTAL ALL CATEGORIES;999
  1.  ;;ALL;ALL OF THE ABOVE;A
  1.  ;;$$END
  1.  Q
  1. KHELP ;----- HELP FOR REPORT SELECTION
  1.  ;
  1.  W !!?5,"Select ONE report by number or name, or"
  1.  W !?5,"enter report NUMBERS separated by commas, or select a range of"
  1.  W !?5,"NUMBERS:  for example '1,2,5', or '1-5', or '1,2,5-7',"
  1.  W !?5,"or select 'A' for All."
  1.  W !?5,"DO NOT mix numbers and names.",!
  1.  Q
  1. QUIT ;----- KILL VARIABLES, CLOSE DEVICE, QUIT
  1.  ;
  1.  K ZTSAVE
  1.  K ^XTMP("ASUR","RDBK")
  1.  I $G(ASUK("PTRSEL"))]"" W @IOF Q
  1.  D ^%ZISC
  1.  Q