ASUMSOLR ; IHS/ITSC/LMH - ONLINE STATION MASTER REVIEW ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;;Y2K/OK AEF/2970626
;
;This routine allows display of the Station Master file.
;
; Program variables:
; ASUAR = area internal number
; ASUIDX = index internal number
; ASUL( = array containing area and station data
; ASUMS( = array containing station master data
; ASUMX( = array containing index master data
; ASUOUT = escape controller
; ASUSTA = station internal number
; ASUTXT = holds text to be printed
; ASUY = holds user input
;
EN1 ;EP -- MAIN ENTRY POINT FOR DATA DISPLAY
;
N ASUEP
S ASUEP=1
D START(ASUEP)
D QUIT
Q
EN2 ;EP -- ENTRY POINT TO EDIT PURCHASE ORDER DUE IN DATES
;
N ASUEP
S ASUEP=2
D START(ASUEP)
D QUIT
Q
;
START(ASUEP) ;
;----- START THE PROGRAM
;
N ASUOUT
F D Q:$G(ASUOUT)
. N ASUAR,ASUF,ASUK,ASUMX,ASUMS,ASUS,ASUSTA,ASUV,X,Y,ZTSAVE
. S ASUSTA=ASUL(2,"STA","E#")
. D ^XBKVAR,HOME^%ZIS
. K ^TMP("ASU",$J,"IDX")
. D SETUP(.ASUL,.ASUAR,.ASUOUT) Q:$G(ASUOUT)
. D IDX(ASUAR,ASUSTA)
. I '$D(^TMP("ASU",$J,"IDX")) S ASUOUT=1 Q
. I $G(ASUEP)=2 D Q
. . D DISP(ASUSTA,ASUEP)
. . H 2
. S ZTSAVE("^TMP(""ASU"",$J,""IDX"",")="",(ZTSAVE("ASUEP"),ZTSAVE("ASUSTA"))=""
. D QUE^ASUUTIL("DQ^ASUMSOLR",.ZTSAVE,"SAMS - ONLINE STATION MASTER REVIEW")
Q
;
SETUP(ASUL,ASUAR,ASUOUT) ;
;----- GET ACCOUNTING POINT OR AREA INTERNAL NUMBER
;
W @IOF
W !?5,"S.A.M.S S.T.A.T.I.O.N M.A.S.T.E.R O.N.L.I.N.E R.E.V.I.E.W",!!
I $G(ASUL(1,"AR","E#"))']"" D ^ASUVAR I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) Q
I $G(ASUL(1,"AR","E#"))']"" W !,"UNABLE TO FIND ACCOUNTING POINT" S ASUOUT=1 Q
S ASUAR=ASUL(1,"AR","E#")
Q
IDX(ASUAR,ASUSTA) ;
;----- GETS INDEX NUMBERS
;
N ASUOUT
F D Q:$G(ASUOUT)
. N ASUY
. K ^TMP("ASU",$J,"IDX")
. D GET(.ASUY,.ASUOUT)
. Q:$G(ASUOUT)
. D BLD(ASUY,ASUAR,ASUSTA)
. I $D(^TMP("ASU",$J,"IDX")) S ASUOUT=1 Q
. W !!,"You have not selected any valid items for this station.",!
Q
GET(ASUY,ASUOUT) ;
;----- PROMPTS USER FOR INDEX NUMBERS
;
N DIR,X,Y
S DIR(0)="FA"
S DIR("A")="Enter INDEX(S): "
S DIR("?")="Enter ONE index, a RANGE using '-', or ANY NUMBER of index numbers separated by ','"
D ^DIR
I Y["^"!($D(DUOUT))!($D(DTOUT)) S ASUOUT=1 Q
S ASUY=Y
Q
BLD(ASUY,ASUAR,ASUSTA) ;
;----- BUILDS INDEX NUMBER ARRAY
;
; Stores index numbers in ^TMP("ASU",$J,"IDX") global
;
N ASUX,I
F I=1:1:$L(ASUY,",") D
. S ASUX=$P(ASUY,",",I)
. I ASUX["-" D RANGE($P(ASUX,"-"),$P(ASUX,"-",2),ASUAR,ASUSTA) Q
. S ASUX=$$PAD(ASUX,6)
. I $L(ASUX)<8 S ASUX=ASUAR_ASUX
. Q:$E(ASUX,1,2)'=ASUAR
. I $D(^ASUMX(ASUX)),$D(^ASUMS(ASUSTA,1,ASUX)) S ^TMP("ASU",$J,"IDX",ASUX)=""
Q
RANGE(X,Y,ASUAR,ASUSTA) ;
;----- BUILDS ARRAY CONTAINING RANGE OF INDEX NUMBERS
;
; X = starting number
; Y = ending number
;
Q:X>Y
S X=$$PAD(X,6),Y=$$PAD(Y,6)
I $L(X)<8 S X=ASUAR_X
I $L(Y)<8 S Y=ASUAR_Y
Q:$E(X,1,2)'=ASUAR
S X=X-1 F S X=$O(^ASUMX(X)) Q:X']"" Q:X>Y Q:$E(X,1,2)'=ASUAR D
. I $D(^ASUMS(ASUSTA,1,X)) S ^TMP("ASU",$J,"IDX",X)=""
Q
;
DQ ;EP -- QUEUED JOB STARTS HERE
;
D DISP(ASUSTA,ASUEP)
D QUIT
Q
DISP(ASUSTA,ASUEP) ;
;----- DISPLAYS INDEX ITEM DATA
;
N ASUIDX,ASUMS,ASUMX,ASUOUT
D ^ASUVAR I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) Q ;DFM P1 9/3/98
S ASUIDX=0 F S ASUIDX=$O(^TMP("ASU",$J,"IDX",ASUIDX)) Q:'ASUIDX D WRITE(ASUSTA,ASUIDX,.ASUMS,ASUEP,.ASUOUT) Q:$G(ASUOUT)
Q
WRITE(ASUSTA,ASUIDX,ASUMS,ASUEP,ASUOUT) ;
;----- WRITES OUTPUT
;
N DIR,X,Y
D SEGS(ASUSTA,ASUIDX,ASUEP)
I $G(ASUEP)=2 D EDIT(ASUSTA,ASUIDX,.ASUMS,ASUEP)
I $E(IOST)="C" S DIR(0)="E" D ^DIR I 'Y S ASUOUT=1
Q
SEGS(ASUSTA,ASUIDX,ASUEP) ;
;----- WRITES DATA SEGMENTS
;
S ASUMS("E#","STA")=ASUSTA
S (ASUMS("E#","IDX"),ASUMX("E#","IDX"))=ASUIDX
D ^ASUMXDIO,^ASUMSTRD I ASUMS("E#","IDX")[999999 W @(IOF) W !,"INDEX ",$G(ASUMX("DELIX"))," FOR ",$G(ASUMX("DELDS"))," DELETED ",$E($G(ASUMX("DELDT")),2,3),"-",$E($G(ASUMS("DELDT")),4,5) Q
D HDR(ASUSTA),ID(.ASUMX),SS(.ASUMS,ASUEP),OV(.ASUMS,ASUEP),DI(.ASUMS),DD(.ASUMS,ASUEP)
Q
HDR(ASUSTA) ;
;----- WRITES HEADER
;
W @IOF
N ASUTXT
;D STA^ASULARST(ASUSTA)
W !,"*****"
S ASUTXT="S T A T I O N M A S T E R E N T R Y F O R"
W ?(IOM-$L(ASUTXT))/2,ASUTXT
W ?IOM-5,"*****"
W !,"*****"
S ASUTXT=$G(ASUL(2,"STA","CD"))_" - "_$G(ASUL(2,"STA","NM"))
W ?(IOM-$L(ASUTXT))/2,ASUTXT
W ?IOM-5,"*****"
Q
ID(ASUMX) ;
;----- WRITES INDEX ITEM DATA
;
W !?(IOM-46)/2,"************** INDEX ITEM DATA ***************"
W !,"DESCR:",?9,$G(ASUMX("DESC",1)),?41,$G(ASUMX("DESC",2))
W !,"INDEX:" I $G(ASUMX("IDX"))]"" W ?9,$E(ASUMX("IDX"),1,5)_"."_$E(ASUMX("IDX"),6)
W ?19,"ACCOUNT:",?29,$G(ASUMX("ACC"))
W ?34,"DTESTB:" I $G(ASUMX("ESTB"))]"" W ?42,$E(ASUMX("ESTB"),2,3)_"/"_$E(ASUMX("ESTB"),4,5)
W ?49,"OBJSUB:" I $G(ASUMX("SOBJ"))]"" W ?57,$S(ASUMX("SOBJ")[".":ASUMX("SOBJ"),1:$E(ASUMX("SOBJ"),1,2)_"."_$E(ASUMX("SOBJ"),3,4))
W ?64,"CATGRY:",?74,$G(ASUMX("CAT"))
W !,"NSN:" I $G(ASUMX("NSN"))]"" W ?9,$S($L(ASUMX("NSN"))=13:$E(ASUMX("NSN"),1,4)_"-"_$E(ASUMX("NSN"),5,6)_"-"_$E(ASUMX("NSN"),7,9)_"-"_$E(ASUMX("NSN"),10,13),1:ASUMX("NSN"))
W ?34,"STA U/I:",?44,$G(ASUMX("AR U/I"))
Q
SS(ASUMS,ASUEP) ;
;----- WRITES STATION STATISTICS
;
Q:$G(ASUEP)=2
W !?(IOM-46)/2,"************* STATION STATISTICS *************"
W !,"QTY OH:" I $G(ASUMS("QTY","O/H"))]"" W ?8,$J(ASUMS("QTY","O/H"),7)
W ?19,"VALUE:" I $G(ASUMS("VAL","O/H"))]"" W ?25,$J(ASUMS("VAL","O/H"),12,2)
W ?39,"LSTISS:" I $G(ASUMS("LSTISS")) W ?47,$E(ASUMS("LSTISS"),2,3)_"/"_$E(ASUMS("LSTISS"),4,5)
W ?54,"DUEOUT:" I $G(ASUMS("D/O","QTY"))]"" W ?64,$J(ASUMS("D/O","QTY"),7)
W ?72,"SLC:",?78,$G(ASUMS("SLC"))
Q
OV(ASUMS,ASUEP) ;
;----- WRITES ORDER/VENDOR DATA
;
Q:$G(ASUEP)=2
W !?(IOM-46)/2,"************ ORDER / VENDOR DATA *************"
W !,"VENDOR:",?9,$G(ASUMS("VENAM"))
W ?39,"ORDER#:",?49,$G(ASUMS("ORD#"))
W !,"PAMIQ:" I $G(ASUMS("PMIQ")) W ?8,$J(ASUMS("PMIQ"),7)
W ?19,"CUR RPQ:" I $G(ASUMS("RPQ")) W ?29,$J(ASUMS("RPQ"),7)
W ?39,"OLD RPQ:" I $G(ASUMS("RPQ-O")) W ?49,$J(ASUMS("RPQ-O"),7)
W ?61,"SOURCE:",?69,$G(ASUMS("SRC"))
W !,"LASTPP:" I $G(ASUMS("LPP")) W ?7,$J(ASUMS("LPP"),10,2)
W ?19,"LEADTIM:",?29,$J($G(ASUMS("LTM")),3,1)
W ?39,"STDPACK:" I $G(ASUMS("SPQ")) W ?49,$J(ASUMS("SPQ"),7)
W ?61,"VEN U/I:",?71,$G(ASUMS("VENUI"))
W !,"EOQ TYP:",?9,$G(ASUMS("EOQ","TP"))
W ?11,"EOQ TBL:" I $G(ASUMS("EOQ","TB")) W ?19,$J(ASUMS("EOQ","TB"),4)
W ?24,"MOS MOD:",?34,$G(ASUMS("EOQ","MM"))
W ?39,"QTY MOD:" I $G(ASUMS("EOQ","QM")) W ?48,$J(ASUMS("EOQ","QM"),7)
W ?61,"ACT MOD:" I $G(ASUMS("EOQ","AM")) W ?69,$J(ASUMS("EOQ","AM"),7)
Q
DI(ASUMS) ;
;----- WRITES DUE IN DATA
;
N I
W !?(IOM-46)/2,"**************** DUE IN DATA *****************"
F I=1:1:3 D
. W !,"DUEIN "_I_" PO:",?12,$G(ASUMS("D/I","PO#",I))
. W ?21,"DT:" I $G(ASUMS("D/I","DT",I)) W ?26,$E(ASUMS("D/I","DT",I),4,7),$E(ASUMS("D/I","DT",I),2,3)
. W ?34,"QTY:" I $G(ASUMS("D/I","QTY",I)) W ?39,$J(ASUMS("D/I","QTY",I),7)
. W ?49,"VAL:" I $G(ASUMS("D/I","VAL",I)) W ?54,$J(ASUMS("D/I","VAL",I),10,2)
. W ?67,"ON72:" I $G(ASUMS("D/I","DTR72",I)) W ?73,$E(ASUMS("D/I","DTR72",I),4,7),$E(ASUMS("D/I","DTR72",I),2,3)
Q
DD(ASUMS,ASUEP) ;
;----- WRITES DEMAND DATA
;
Q:$G(ASUEP)=2
N ASUTOT,I,J
W !?((IOM-46)/2),"***** DEMAND DATA (CALLS & QTY BY MONTH) *****"
W !?5,"JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC TOT"
W !,"CA"
S ASUTOT=0
F I=1:1:12 S J=(I*6)-4 S ASUTOT=ASUTOT+$G(ASUMS("DMD","CALL",I)) W ?J,$J($G(ASUMS("DMD","CALL",I)),6,0)
W ?74,$J(ASUTOT,6,0)
W !,"QT"
S ASUTOT=0
F I=1:1:12 S J=(I*6)-4 S ASUTOT=ASUTOT+$G(ASUMS("DMD","QTY",I)) W ?J,$J($G(ASUMS("DMD","QTY",I)),6,0)
W ?74,$J(ASUTOT,6,0),!
Q
EDIT(ASUSTA,ASUIDX,ASUMS,ASUEP) ;
;----- EDITS PO DUE IN DATE
;
Q:$G(ASUEP)'=2
N ASUDATA,ASUDTFLD,ASUPOFLD,ASUOUT,DA,DIE,DIR,DR,X,Y
S ASUPOFLD="19^24^29"
S ASUDTFLD="20^25^30"
F D Q:$G(ASUOUT) D SEGS(ASUSTA,ASUIDX,ASUEP)
. S ASUDATA=^ASUMS(ASUSTA,1,ASUIDX,0)
. I $P(ASUDATA,U,20)']""&($P(ASUDATA,U,25)']"")&($P(ASUDATA,U,30)']"") S ASUOUT=1 Q
. S DIR(0)="NO^1:3:0"
. S DIR("A")="Which Purchase Order Due In Date do you wish to change"
. D ^DIR K DIR
. I Y'>0!($D(DUOUT))!($D(DTOUT)) S ASUOUT=1 Q
. I $P(ASUDATA,U,$P(ASUPOFLD,U,Y))']"" W !!,"NO PURCHASE ORDER IN THIS FIELD",! H 2 Q
. S DIE="^ASUMS("_ASUSTA_",1,"
. S DA=ASUIDX
. S DA(1)=ASUSTA
. S DR=$P(ASUDTFLD,U,Y)
. D ^DIE K DA,DIE,DR
. S DIR(0)="YO"
. S DIR("A")="Do you wish to edit another Purchase Order Due In Date for this Index"
. S DIR("B")="NO"
. D ^DIR K DIR
. I 'Y S ASUOUT=1
Q
;
PAD(X,Y) ;----- EXTRINSIC FUNCTION TO PAD NUMBER WITH LEADING ZEROS
;
; X = number to be padded with zeros
; Y = target length of number
;
F Q:$L(X)>(Y-1) S X="0"_X
Q X
QUIT ;----- CLEAN UP VARIABLES, CLOSE DEVICES, QUIT
;
K ^TMP("ASU",$J,"IDX")
D ^%ZISC
Q
ASUMSOLR ; IHS/ITSC/LMH - ONLINE STATION MASTER REVIEW ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;;Y2K/OK AEF/2970626
+3 ;
+4 ;This routine allows display of the Station Master file.
+5 ;
+6 ; Program variables:
+7 ; ASUAR = area internal number
+8 ; ASUIDX = index internal number
+9 ; ASUL( = array containing area and station data
+10 ; ASUMS( = array containing station master data
+11 ; ASUMX( = array containing index master data
+12 ; ASUOUT = escape controller
+13 ; ASUSTA = station internal number
+14 ; ASUTXT = holds text to be printed
+15 ; ASUY = holds user input
+16 ;
EN1 ;EP -- MAIN ENTRY POINT FOR DATA DISPLAY
+1 ;
+2 NEW ASUEP
+3 SET ASUEP=1
+4 DO START(ASUEP)
+5 DO QUIT
+6 QUIT
EN2 ;EP -- ENTRY POINT TO EDIT PURCHASE ORDER DUE IN DATES
+1 ;
+2 NEW ASUEP
+3 SET ASUEP=2
+4 DO START(ASUEP)
+5 DO QUIT
+6 QUIT
+7 ;
START(ASUEP) ;
+1 ;----- START THE PROGRAM
+2 ;
+3 NEW ASUOUT
+4 FOR
Begin DoDot:1
+5 NEW ASUAR,ASUF,ASUK,ASUMX,ASUMS,ASUS,ASUSTA,ASUV,X,Y,ZTSAVE
+6 SET ASUSTA=ASUL(2,"STA","E#")
+7 DO ^XBKVAR
DO HOME^%ZIS
+8 KILL ^TMP("ASU",$JOB,"IDX")
+9 DO SETUP(.ASUL,.ASUAR,.ASUOUT)
IF $GET(ASUOUT)
QUIT
+10 DO IDX(ASUAR,ASUSTA)
+11 IF '$DATA(^TMP("ASU",$JOB,"IDX"))
SET ASUOUT=1
QUIT
+12 IF $GET(ASUEP)=2
Begin DoDot:2
+13 DO DISP(ASUSTA,ASUEP)
+14 HANG 2
End DoDot:2
QUIT
+15 SET ZTSAVE("^TMP(""ASU"",$J,""IDX"",")=""
SET (ZTSAVE("ASUEP"),ZTSAVE("ASUSTA"))=""
+16 DO QUE^ASUUTIL("DQ^ASUMSOLR",.ZTSAVE,"SAMS - ONLINE STATION MASTER REVIEW")
End DoDot:1
IF $GET(ASUOUT)
QUIT
+17 QUIT
+18 ;
SETUP(ASUL,ASUAR,ASUOUT) ;
+1 ;----- GET ACCOUNTING POINT OR AREA INTERNAL NUMBER
+2 ;
+3 WRITE @IOF
+4 WRITE !?5,"S.A.M.S S.T.A.T.I.O.N M.A.S.T.E.R O.N.L.I.N.E R.E.V.I.E.W",!!
+5 IF $GET(ASUL(1,"AR","E#"))']""
DO ^ASUVAR
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))
QUIT
+6 IF $GET(ASUL(1,"AR","E#"))']""
WRITE !,"UNABLE TO FIND ACCOUNTING POINT"
SET ASUOUT=1
QUIT
+7 SET ASUAR=ASUL(1,"AR","E#")
+8 QUIT
IDX(ASUAR,ASUSTA) ;
+1 ;----- GETS INDEX NUMBERS
+2 ;
+3 NEW ASUOUT
+4 FOR
Begin DoDot:1
+5 NEW ASUY
+6 KILL ^TMP("ASU",$JOB,"IDX")
+7 DO GET(.ASUY,.ASUOUT)
+8 IF $GET(ASUOUT)
QUIT
+9 DO BLD(ASUY,ASUAR,ASUSTA)
+10 IF $DATA(^TMP("ASU",$JOB,"IDX"))
SET ASUOUT=1
QUIT
+11 WRITE !!,"You have not selected any valid items for this station.",!
End DoDot:1
IF $GET(ASUOUT)
QUIT
+12 QUIT
GET(ASUY,ASUOUT) ;
+1 ;----- PROMPTS USER FOR INDEX NUMBERS
+2 ;
+3 NEW DIR,X,Y
+4 SET DIR(0)="FA"
+5 SET DIR("A")="Enter INDEX(S): "
+6 SET DIR("?")="Enter ONE index, a RANGE using '-', or ANY NUMBER of index numbers separated by ','"
+7 DO ^DIR
+8 IF Y["^"!($DATA(DUOUT))!($DATA(DTOUT))
SET ASUOUT=1
QUIT
+9 SET ASUY=Y
+10 QUIT
BLD(ASUY,ASUAR,ASUSTA) ;
+1 ;----- BUILDS INDEX NUMBER ARRAY
+2 ;
+3 ; Stores index numbers in ^TMP("ASU",$J,"IDX") global
+4 ;
+5 NEW ASUX,I
+6 FOR I=1:1:$LENGTH(ASUY,",")
Begin DoDot:1
+7 SET ASUX=$PIECE(ASUY,",",I)
+8 IF ASUX["-"
DO RANGE($PIECE(ASUX,"-"),$PIECE(ASUX,"-",2),ASUAR,ASUSTA)
QUIT
+9 SET ASUX=$$PAD(ASUX,6)
+10 IF $LENGTH(ASUX)<8
SET ASUX=ASUAR_ASUX
+11 IF $EXTRACT(ASUX,1,2)'=ASUAR
QUIT
+12 IF $DATA(^ASUMX(ASUX))
IF $DATA(^ASUMS(ASUSTA,1,ASUX))
SET ^TMP("ASU",$JOB,"IDX",ASUX)=""
End DoDot:1
+13 QUIT
RANGE(X,Y,ASUAR,ASUSTA) ;
+1 ;----- BUILDS ARRAY CONTAINING RANGE OF INDEX NUMBERS
+2 ;
+3 ; X = starting number
+4 ; Y = ending number
+5 ;
+6 IF X>Y
QUIT
+7 SET X=$$PAD(X,6)
SET Y=$$PAD(Y,6)
+8 IF $LENGTH(X)<8
SET X=ASUAR_X
+9 IF $LENGTH(Y)<8
SET Y=ASUAR_Y
+10 IF $EXTRACT(X,1,2)'=ASUAR
QUIT
+11 SET X=X-1
FOR
SET X=$ORDER(^ASUMX(X))
IF X']""
QUIT
IF X>Y
QUIT
IF $EXTRACT(X,1,2)'=ASUAR
QUIT
Begin DoDot:1
+12 IF $DATA(^ASUMS(ASUSTA,1,X))
SET ^TMP("ASU",$JOB,"IDX",X)=""
End DoDot:1
+13 QUIT
+14 ;
DQ ;EP -- QUEUED JOB STARTS HERE
+1 ;
+2 DO DISP(ASUSTA,ASUEP)
+3 DO QUIT
+4 QUIT
DISP(ASUSTA,ASUEP) ;
+1 ;----- DISPLAYS INDEX ITEM DATA
+2 ;
+3 NEW ASUIDX,ASUMS,ASUMX,ASUOUT
+4 ;DFM P1 9/3/98
DO ^ASUVAR
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))
QUIT
+5 SET ASUIDX=0
FOR
SET ASUIDX=$ORDER(^TMP("ASU",$JOB,"IDX",ASUIDX))
IF 'ASUIDX
QUIT
DO WRITE(ASUSTA,ASUIDX,.ASUMS,ASUEP,.ASUOUT)
IF $GET(ASUOUT)
QUIT
+6 QUIT
WRITE(ASUSTA,ASUIDX,ASUMS,ASUEP,ASUOUT) ;
+1 ;----- WRITES OUTPUT
+2 ;
+3 NEW DIR,X,Y
+4 DO SEGS(ASUSTA,ASUIDX,ASUEP)
+5 IF $GET(ASUEP)=2
DO EDIT(ASUSTA,ASUIDX,.ASUMS,ASUEP)
+6 IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET ASUOUT=1
+7 QUIT
SEGS(ASUSTA,ASUIDX,ASUEP) ;
+1 ;----- WRITES DATA SEGMENTS
+2 ;
+3 SET ASUMS("E#","STA")=ASUSTA
+4 SET (ASUMS("E#","IDX"),ASUMX("E#","IDX"))=ASUIDX
+5 DO ^ASUMXDIO
DO ^ASUMSTRD
IF ASUMS("E#","IDX")[999999
WRITE @(IOF)
WRITE !,"INDEX ",$GET">GET">GET">GET">GET">GET">GET">GET(ASUMX("DELIX"))," FOR ",$GET">GET">GET">GET">GET">GET">GET">GET(ASUMX("DELDS"))," DELETED ",$EXTRACT($GET">GET">GET">GET">GET">GET">GET">GET(ASUMX("DELDT")),2,3),"-",$EXTRACT($GET">GET">GET">GET">GET">GET">GET">GET(ASUMS("DELDT")),4,5)
QUIT
+6 DO HDR(ASUSTA)
DO ID(.ASUMX)
DO SS(.ASUMS,ASUEP)
DO OV(.ASUMS,ASUEP)
DO DI(.ASUMS)
DO DD(.ASUMS,ASUEP)
+7 QUIT
HDR(ASUSTA) ;
+1 ;----- WRITES HEADER
+2 ;
+3 WRITE @IOF
+4 NEW ASUTXT
+5 ;D STA^ASULARST(ASUSTA)
+6 WRITE !,"*****"
+7 SET ASUTXT="S T A T I O N M A S T E R E N T R Y F O R"
+8 WRITE ?(IOM-$LENGTH(ASUTXT))/2,ASUTXT
+9 WRITE ?IOM-5,"*****"
+10 WRITE !,"*****"
+11 SET ASUTXT=$GET">GET(ASUL(2,"STA","CD"))_" - "_$GET">GET(ASUL(2,"STA","NM"))
+12 WRITE ?(IOM-$LENGTH(ASUTXT))/2,ASUTXT
+13 WRITE ?IOM-5,"*****"
+14 QUIT
ID(ASUMX) ;
+1 ;----- WRITES INDEX ITEM DATA
+2 ;
+3 WRITE !?(IOM-46)/2,"************** INDEX ITEM DATA ***************"
+4 WRITE !,"DESCR:",?9,$GET">GET(ASUMX("DESC",1)),?41,$GET">GET(ASUMX("DESC",2))
+5 WRITE !,"INDEX:"
IF $GET(ASUMX("IDX"))]""
WRITE ?9,$EXTRACT(ASUMX("IDX"),1,5)_"."_$EXTRACT(ASUMX("IDX"),6)
+6 WRITE ?19,"ACCOUNT:",?29,$GET(ASUMX("ACC"))
+7 WRITE ?34,"DTESTB:"
IF $GET(ASUMX("ESTB"))]""
WRITE ?42,$EXTRACT(ASUMX("ESTB"),2,3)_"/"_$EXTRACT(ASUMX("ESTB"),4,5)
+8 WRITE ?49,"OBJSUB:"
IF $GET(ASUMX("SOBJ"))]""
WRITE ?57,$SELECT(ASUMX("SOBJ")[".":ASUMX("SOBJ"),1:$EXTRACT(ASUMX("SOBJ"),1,2)_"."_$EXTRACT(ASUMX("SOBJ"),3,4))
+9 WRITE ?64,"CATGRY:",?74,$GET(ASUMX("CAT"))
+10 WRITE !,"NSN:"
IF $GET(ASUMX("NSN"))]""
WRITE ?9,$SELECT($LENGTH(ASUMX("NSN"))=13:$EXTRACT(ASUMX("NSN"),1,4)_"-"_$EXTRACT(ASUMX("NSN"),5,6)_"-"_$EXTRACT(ASUMX("NSN"),7,9)_"-"_$EXTRACT(ASUMX("NSN"),10,13),1:ASUMX("NSN"))
+11 WRITE ?34,"STA U/I:",?44,$GET(ASUMX("AR U/I"))
+12 QUIT
SS(ASUMS,ASUEP) ;
+1 ;----- WRITES STATION STATISTICS
+2 ;
+3 IF $GET(ASUEP)=2
QUIT
+4 WRITE !?(IOM-46)/2,"************* STATION STATISTICS *************"
+5 WRITE !,"QTY OH:"
IF $GET(ASUMS("QTY","O/H"))]""
WRITE ?8,$JUSTIFY(ASUMS("QTY","O/H"),7)
+6 WRITE ?19,"VALUE:"
IF $GET(ASUMS("VAL","O/H"))]""
WRITE ?25,$JUSTIFY(ASUMS("VAL","O/H"),12,2)
+7 WRITE ?39,"LSTISS:"
IF $GET(ASUMS("LSTISS"))
WRITE ?47,$EXTRACT(ASUMS("LSTISS"),2,3)_"/"_$EXTRACT(ASUMS("LSTISS"),4,5)
+8 WRITE ?54,"DUEOUT:"
IF $GET(ASUMS("D/O","QTY"))]""
WRITE ?64,$JUSTIFY(ASUMS("D/O","QTY"),7)
+9 WRITE ?72,"SLC:",?78,$GET(ASUMS("SLC"))
+10 QUIT
OV(ASUMS,ASUEP) ;
+1 ;----- WRITES ORDER/VENDOR DATA
+2 ;
+3 IF $GET(ASUEP)=2
QUIT
+4 WRITE !?(IOM-46)/2,"************ ORDER / VENDOR DATA *************"
+5 WRITE !,"VENDOR:",?9,$GET(ASUMS("VENAM"))
+6 WRITE ?39,"ORDER#:",?49,$GET(ASUMS("ORD#"))
+7 WRITE !,"PAMIQ:"
IF $GET(ASUMS("PMIQ"))
WRITE ?8,$JUSTIFY(ASUMS("PMIQ"),7)
+8 WRITE ?19,"CUR RPQ:"
IF $GET(ASUMS("RPQ"))
WRITE ?29,$JUSTIFY(ASUMS("RPQ"),7)
+9 WRITE ?39,"OLD RPQ:"
IF $GET(ASUMS("RPQ-O"))
WRITE ?49,$JUSTIFY(ASUMS("RPQ-O"),7)
+10 WRITE ?61,"SOURCE:",?69,$GET(ASUMS("SRC"))
+11 WRITE !,"LASTPP:"
IF $GET(ASUMS("LPP"))
WRITE ?7,$JUSTIFY(ASUMS("LPP"),10,2)
+12 WRITE ?19,"LEADTIM:",?29,$JUSTIFY($GET(ASUMS("LTM")),3,1)
+13 WRITE ?39,"STDPACK:"
IF $GET(ASUMS("SPQ"))
WRITE ?49,$JUSTIFY(ASUMS("SPQ"),7)
+14 WRITE ?61,"VEN U/I:",?71,$GET(ASUMS("VENUI"))
+15 WRITE !,"EOQ TYP:",?9,$GET(ASUMS("EOQ","TP"))
+16 WRITE ?11,"EOQ TBL:"
IF $GET(ASUMS("EOQ","TB"))
WRITE ?19,$JUSTIFY(ASUMS("EOQ","TB"),4)
+17 WRITE ?24,"MOS MOD:",?34,$GET(ASUMS("EOQ","MM"))
+18 WRITE ?39,"QTY MOD:"
IF $GET(ASUMS("EOQ","QM"))
WRITE ?48,$JUSTIFY(ASUMS("EOQ","QM"),7)
+19 WRITE ?61,"ACT MOD:"
IF $GET(ASUMS("EOQ","AM"))
WRITE ?69,$JUSTIFY(ASUMS("EOQ","AM"),7)
+20 QUIT
DI(ASUMS) ;
+1 ;----- WRITES DUE IN DATA
+2 ;
+3 NEW I
+4 WRITE !?(IOM-46)/2,"**************** DUE IN DATA *****************"
+5 FOR I=1:1:3
Begin DoDot:1
+6 WRITE !,"DUEIN "_I_" PO:",?12,$GET(ASUMS("D/I","PO#",I))
+7 WRITE ?21,"DT:"
IF $GET(ASUMS("D/I","DT",I))
WRITE ?26,$EXTRACT(ASUMS("D/I","DT",I),4,7),$EXTRACT(ASUMS("D/I","DT",I),2,3)
+8 WRITE ?34,"QTY:"
IF $GET(ASUMS("D/I","QTY",I))
WRITE ?39,$JUSTIFY(ASUMS("D/I","QTY",I),7)
+9 WRITE ?49,"VAL:"
IF $GET(ASUMS("D/I","VAL",I))
WRITE ?54,$JUSTIFY(ASUMS("D/I","VAL",I),10,2)
+10 WRITE ?67,"ON72:"
IF $GET(ASUMS("D/I","DTR72",I))
WRITE ?73,$EXTRACT(ASUMS("D/I","DTR72",I),4,7),$EXTRACT(ASUMS("D/I","DTR72",I),2,3)
End DoDot:1
+11 QUIT
DD(ASUMS,ASUEP) ;
+1 ;----- WRITES DEMAND DATA
+2 ;
+3 IF $GET(ASUEP)=2
QUIT
+4 NEW ASUTOT,I,J
+5 WRITE !?((IOM-46)/2),"***** DEMAND DATA (CALLS & QTY BY MONTH) *****"
+6 WRITE !?5,"JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC TOT"
+7 WRITE !,"CA"
+8 SET ASUTOT=0
+9 FOR I=1:1:12
SET J=(I*6)-4
SET ASUTOT=ASUTOT+$GET(ASUMS("DMD","CALL",I))
WRITE ?J,$JUSTIFY($GET(ASUMS("DMD","CALL",I)),6,0)
+10 WRITE ?74,$JUSTIFY(ASUTOT,6,0)
+11 WRITE !,"QT"
+12 SET ASUTOT=0
+13 FOR I=1:1:12
SET J=(I*6)-4
SET ASUTOT=ASUTOT+$GET(ASUMS("DMD","QTY",I))
WRITE ?J,$JUSTIFY($GET(ASUMS("DMD","QTY",I)),6,0)
+14 WRITE ?74,$JUSTIFY(ASUTOT,6,0),!
+15 QUIT
EDIT(ASUSTA,ASUIDX,ASUMS,ASUEP) ;
+1 ;----- EDITS PO DUE IN DATE
+2 ;
+3 IF $GET(ASUEP)'=2
QUIT
+4 NEW ASUDATA,ASUDTFLD,ASUPOFLD,ASUOUT,DA,DIE,DIR,DR,X,Y
+5 SET ASUPOFLD="19^24^29"
+6 SET ASUDTFLD="20^25^30"
+7 FOR
Begin DoDot:1
+8 SET ASUDATA=^ASUMS(ASUSTA,1,ASUIDX,0)
+9 IF $PIECE(ASUDATA,U,20)']""&($PIECE(ASUDATA,U,25)']"")&($PIECE(ASUDATA,U,30)']"")
SET ASUOUT=1
QUIT
+10 SET DIR(0)="NO^1:3:0"
+11 SET DIR("A")="Which Purchase Order Due In Date do you wish to change"
+12 DO ^DIR
KILL DIR
+13 IF Y'>0!($DATA(DUOUT))!($DATA(DTOUT))
SET ASUOUT=1
QUIT
+14 IF $PIECE(ASUDATA,U,$PIECE(ASUPOFLD,U,Y))']""
WRITE !!,"NO PURCHASE ORDER IN THIS FIELD",!
HANG 2
QUIT
+15 SET DIE="^ASUMS("_ASUSTA_",1,"
+16 SET DA=ASUIDX
+17 SET DA(1)=ASUSTA
+18 SET DR=$PIECE(ASUDTFLD,U,Y)
+19 DO ^DIE
KILL DA,DIE,DR
+20 SET DIR(0)="YO"
+21 SET DIR("A")="Do you wish to edit another Purchase Order Due In Date for this Index"
+22 SET DIR("B")="NO"
+23 DO ^DIR
KILL DIR
+24 IF 'Y
SET ASUOUT=1
End DoDot:1
IF $GET(ASUOUT)
QUIT
DO SEGS(ASUSTA,ASUIDX,ASUEP)
+25 QUIT
+26 ;
PAD(X,Y) ;----- EXTRINSIC FUNCTION TO PAD NUMBER WITH LEADING ZEROS
+1 ;
+2 ; X = number to be padded with zeros
+3 ; Y = target length of number
+4 ;
+5 FOR
IF $LENGTH(X)>(Y-1)
QUIT
SET X="0"_X
+6 QUIT X
QUIT ;----- CLEAN UP VARIABLES, CLOSE DEVICES, QUIT
+1 ;
+2 KILL ^TMP("ASU",$JOB,"IDX")
+3 DO ^%ZISC
+4 QUIT
