ASULARST ; IHS/ITSC/LMH -AREA & STATION TABLE LOOKUP ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine is a utility which provides entry points to do lookups
;and verification for Area Code and Station Code.
Q:$D(ASUL(1,"AR","AP"))
D CLS^ASUUHDG W *7 D:'$D(ASUL(1,"AR","E#")) SETAREA I $D(ASUL(1,"AR","AP")) I ASUL(1,"AR","AP")=U Q
W !?14,"Reminder, Area Code you are signed on with is : ",ASUL(1,"AR","E#"),!
W !!?35-($L(ASUL(1,"AR","NM"))/2),ASUL(1,"AR","NM"),!!
W !?10,"If this is correct, enter <cr> to continue."
W !?10,"Otherwise, enter '^', exit form the KERNEL S.A.M.S. MENU"
W !?15,"and then re-enter with the correct Area.",!!
S DIR(0)="E" D ^DIR K DIR
I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) S ASUL(1,"AR","E#")=U
S ASUL(1,"AR","AP")=ASUL(1,"AR","E#")
K ASUL(1,"AR","E#")
Q
SETAREA ;EP ;SET ASUL(1,"AR","E#") BASED ON DUZ(2) THEN SET ASUL(1) ARRAY
D LOOKUP S ASUF("LOOKA")=0 D AREA K ASUF("LOOKA")
Q
LOOKUP ;EP ;LOOKUP AREA BASED ON DUZ(2)
I '$D(DUZ(2)) S (X,ASUL(1,"AR","AP"))=$P(^ASUSITE(1,0),U) D ARE(ASUL(1,"AR","AP")) Q
D:'$D(U) ^XBKVAR
S (X,ASUL(1,"AR","E#"))=$E($P(^AUTTAREA($P(^AUTTLOC(DUZ(2),0),U,4),0),U,4),2,3)
S ASUK("LOC")=$P(^AUTTLOC(DUZ(2),0),U,2)
S ASUK("ASUFAC")=$P(^AUTTLOC(DUZ(2),0),U,10)
I ASUL(1,"AR","E#")']"" W "No Accounting Point stored in your SITE file; contact site manager",!,"Program can not continue -Aborting",! S ASUL(1,"AR","AP")="^" Q
Q
ARPRINT ;EP; Write out Area Name and save Area Lookup table EIN
D:$G(ASUL(1,"AR","NM"))']"" ARL
W " ",ASUL(1,"AR","NM") Q
AREA ;EP -Lookup Area Name. X=AREA CODE
S ASUF("LOOKA")=$G(ASUF("LOOKA"))
S:ASUF("LOOKA")="" ASUF("LOOKA")=1
ARL ;
I '$D(ASUL(1,"AR","AP")) D ;Q:ASUF("LOOKA")=0
.I ASUF("LOOKA"),'$D(X) D SETAREA S ASUF("LOOKA")=0 Q
.S ASUL(1,"AR","AP")=X
D ARE(X)
S ASUF("LOOKA")=$G(ASUF("LOOKA"))
D:ASUF("LOOKA") LOOKUP
Q
FINDAREA ;EP ;FIND AREA FROM TABLE 01
N DIR
S DIR(0)="PO^9002039.01:EM",DIR("A")="SELECT AREA" D ^DIR
Q:$D(DIRUT) Q:+Y<0
S X=+Y
G AREX
ARE(X) ;EP ;LOOKUP AREA IN TABLE 01
AREX ;
S (ASUL(1,"AR","E#"),ASUL(1,"AR","AP"))=X
I $D(^ASUL(1,X,0)) D
.S ASUL(1,"AR","NM")=$P(^ASUL(1,X,0),U)
.S ASUL(1,"AR","STA1")=$P(^ASUL(1,X,1),U)
.S ASUL(1,"AR","WHSE")=$P(^ASUL(1,X,1),U,2)
.S ASUL(1,"AR","DLTM")=$P(^ASUL(1,X,1),U,3)
E D
.S ASUL(1,"AR","NM")="NOT FOUND",(ASUL(1,"AR","STA1"),ASUL(1,"AR","WHSE"))=""
Q
STPRINT ;
S:'$D(X1) X1=$G(ASUK("STA","CD"))
D STA(X1) W " ",ASUL(2,"STA","NM") Q
STAT ;EP -Lookup Station Name. X=AREA CODE, X1=STATION CODE.
I '$D(ASUL(1,"AR","AP")) D
.I '$D(X) D
..D SETAREA
.E D
..D ARE(X)
I $G(ASUL(2,"STA","E#"))']"" D Q:ASUL(2,"STA","E#")']""
.I '$D(X1) S ASUL(2,"STA","E#")="",ASUL(2,"STA","NM")="UNKNOWN" Q
.S ASUL(2,"STA","E#")=X1
D:'$D(ASUL(1,"AR","E#")) SETAREA
D STA(X1)
Q
STA(X) ;EP ; DIRECT STATION TABLE LOOKUP
I $L(X)=3 S X=ASUL(1,"AR","AP")_X
I $L(X)=2 S X=ASUL(1,"AR","AP")_"0"_X
I X'?5N D Q
.S Y=-4 Q ;Input paramater did not pass Station IEN edit
I $D(^ASUL(2,X,0)) D
.S (Y,ASUL(2,"STA","E#"))=X ;Record found for input parameter
.S ASUL(2,"STA","CD")=$P(^ASUL(2,X,1),U)
.S ASUL(2,"STA","NM")=$P(^ASUL(2,X,0),U)
.S ASUL(2,"STA","TYP")=$P(^ASUL(2,X,1),U,2)
.S ASUL(2,"STA","CTP")=$P(^ASUL(2,X,1),U,3)
.S ASUL(2,"STA","TP#")=$P(^ASUL(2,X,1),U,4)
.S ASUL(2,"STA","EOQTB")=$P(^ASUL(2,X,1),U,6)
.S:ASUL(2,"STA","EOQTB")']"" ASUL(2,"STA","EOQTB")=50
E D
.S ASUL(2,"STA","E#")=X ;IEN to use for LAYGO call
.S ASUL(2,"STA","CD")="N/F",ASUL(2,"STA","NM")="UNKNOWN",ASUL(2,"STA","EOQTB")=50
.S Y=-1 ;No record found for Input parameter
Q
TRN(X) ;EP ;TRANSACTION CODE
K ASUL(11)
I X?1N.N,$D(^ASUL(11,+X)) S ASUL(11,"TRN","E#")=+X
E S:$E(X)'="T" X="T"_X S ASUL(11,"TRN","E#")=$O(^ASUL(11,"B",X,""))
I $G(ASUL(11,"TRN","E#"))']"" S Y=-1 Q
E S Y=$G(^ASUL(11,ASUL(11,"TRN","E#"),0))
S ASUL(11,"TRN","KEY")=$P(Y,U,1)
S ASUL(11,"TRN","CDE")=$E(Y,2,3)
S ASUL(11,"TRN","NAME")=$P(Y,U,2)
N Z S (Z,ASUL(11,"TRN","TYPE"))=$P(Y,U,3)
S ASUL(11,"TRN","TYPN")=$S(Z=1:"DUE IN",Z=2:"RECEIPT",Z=3:"ISSUE",Z=4:"INDEX",Z=5:"STATION",Z=6:"ADJUSTMENT",Z=7:"TRANSFER DUE IN",Z=8:"TRANSFER IN",Z=9:"TRANSFER OUT",Z=0:"DIRECT ISSUE",1:"TRANSFER ISSUE")
S (Z,ASUL(11,"TRN","EXT"))=$P(Y,U,4)
S ASUL(11,"TRN","EXTN")=$S(Z=0:"ADD",Z=1:"CHANGE",Z=2:"DELETE",Z=3:"USER LEVEL",Z=4:"PURCHASED",Z=5:"UNREQUIRED",Z=6:"DONATED",Z=7:"EXCESS",Z=8:"STOCK REPLENISHMENT",Z=9:"NON REPLENISHMENT",1:"")
S ASUL(11,"TRN","DRCR")=$P(Y,U,5)
S ASUL(11,"TRN","DBCR")=$S(ASUL(11,"TRN","TYPE")=4:"",ASUL(11,"TRN","TYPE")=5:"",ASUL(11,"TRN","DRCR")=-1:"CREDIT",1:"DEBIT")
S ASUL(11,"TRN","REV")=$P(Y,U,6)
S ASUL(11,"TRN","TAG")=$P(Y,U,7)
S ASUL(11,"TRN","FIL")=$P(Y,U,8)
Q
ASULARST ; IHS/ITSC/LMH -AREA & STATION TABLE LOOKUP ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine is a utility which provides entry points to do lookups
+3 ;and verification for Area Code and Station Code.
+4 IF $DATA(ASUL(1,"AR","AP"))
QUIT
+5 DO CLS^ASUUHDG
WRITE *7
IF '$DATA(ASUL(1,"AR","E#"))
DO SETAREA
IF $DATA(ASUL(1,"AR","AP"))
IF ASUL(1,"AR","AP")=U
QUIT
+6 WRITE !?14,"Reminder, Area Code you are signed on with is : ",ASUL(1,"AR","E#"),!
+7 WRITE !!?35-($LENGTH(ASUL(1,"AR","NM"))/2),ASUL(1,"AR","NM"),!!
+8 WRITE !?10,"If this is correct, enter <cr> to continue."
+9 WRITE !?10,"Otherwise, enter '^', exit form the KERNEL S.A.M.S. MENU"
+10 WRITE !?15,"and then re-enter with the correct Area.",!!
+11 SET DIR(0)="E"
DO ^DIR
KILL DIR
+12 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))
SET ASUL(1,"AR","E#")=U
+13 SET ASUL(1,"AR","AP")=ASUL(1,"AR","E#")
+14 KILL ASUL(1,"AR","E#")
+15 QUIT
SETAREA ;EP ;SET ASUL(1,"AR","E#") BASED ON DUZ(2) THEN SET ASUL(1) ARRAY
+1 DO LOOKUP
SET ASUF("LOOKA")=0
DO AREA
KILL ASUF("LOOKA")
+2 QUIT
LOOKUP ;EP ;LOOKUP AREA BASED ON DUZ(2)
+1 IF '$DATA(DUZ(2))
SET (X,ASUL(1,"AR","AP"))=$PIECE(^ASUSITE(1,0),U)
DO ARE(ASUL(1,"AR","AP"))
QUIT
+2 IF '$DATA(U)
DO ^XBKVAR
+3 SET (X,ASUL(1,"AR","E#"))=$EXTRACT($PIECE(^AUTTAREA($PIECE(^AUTTLOC(DUZ(2),0),U,4),0),U,4),2,3)
+4 SET ASUK("LOC")=$PIECE(^AUTTLOC(DUZ(2),0),U,2)
+5 SET ASUK("ASUFAC")=$PIECE(^AUTTLOC(DUZ(2),0),U,10)
+6 IF ASUL(1,"AR","E#")']""
WRITE "No Accounting Point stored in your SITE file; contact site manager",!,"Program can not continue -Aborting",!
SET ASUL(1,"AR","AP")="^"
QUIT
+7 QUIT
ARPRINT ;EP; Write out Area Name and save Area Lookup table EIN
+1 IF $GET(ASUL(1,"AR","NM"))']""
DO ARL
+2 WRITE " ",ASUL(1,"AR","NM")
QUIT
AREA ;EP -Lookup Area Name. X=AREA CODE
+1 SET ASUF("LOOKA")=$GET(ASUF("LOOKA"))
+2 IF ASUF("LOOKA")=""
SET ASUF("LOOKA")=1
ARL ;
+1 ;Q:ASUF("LOOKA")=0
IF '$DATA(ASUL(1,"AR","AP"))
Begin DoDot:1
+2 IF ASUF("LOOKA")
IF '$DATA(X)
DO SETAREA
SET ASUF("LOOKA")=0
QUIT
+3 SET ASUL(1,"AR","AP")=X
End DoDot:1
+4 DO ARE(X)
+5 SET ASUF("LOOKA")=$GET(ASUF("LOOKA"))
+6 IF ASUF("LOOKA")
DO LOOKUP
+7 QUIT
FINDAREA ;EP ;FIND AREA FROM TABLE 01
+1 NEW DIR
+2 SET DIR(0)="PO^9002039.01:EM"
SET DIR("A")="SELECT AREA"
DO ^DIR
+3 IF $DATA(DIRUT)
QUIT
IF +Y<0
QUIT
+4 SET X=+Y
+5 GOTO AREX
ARE(X) ;EP ;LOOKUP AREA IN TABLE 01
AREX ;
+1 SET (ASUL(1,"AR","E#"),ASUL(1,"AR","AP"))=X
+2 IF $DATA(^ASUL(1,X,0))
Begin DoDot:1
+3 SET ASUL(1,"AR","NM")=$PIECE(^ASUL(1,X,0),U)
+4 SET ASUL(1,"AR","STA1")=$PIECE(^ASUL(1,X,1),U)
+5 SET ASUL(1,"AR","WHSE")=$PIECE(^ASUL(1,X,1),U,2)
+6 SET ASUL(1,"AR","DLTM")=$PIECE(^ASUL(1,X,1),U,3)
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET ASUL(1,"AR","NM")="NOT FOUND"
SET (ASUL(1,"AR","STA1"),ASUL(1,"AR","WHSE"))=""
End DoDot:1
+9 QUIT
STPRINT ;
+1 IF '$DATA(X1)
SET X1=$GET(ASUK("STA","CD"))
+2 DO STA(X1)
WRITE " ",ASUL(2,"STA","NM")
QUIT
STAT ;EP -Lookup Station Name. X=AREA CODE, X1=STATION CODE.
+1 IF '$DATA(ASUL(1,"AR","AP"))
Begin DoDot:1
+2 IF '$DATA(X)
Begin DoDot:2
+3 DO SETAREA
End DoDot:2
+4 IF '$TEST
Begin DoDot:2
+5 DO ARE(X)
End DoDot:2
End DoDot:1
+6 IF $GET(ASUL(2,"STA","E#"))']""
Begin DoDot:1
+7 IF '$DATA(X1)
SET ASUL(2,"STA","E#")=""
SET ASUL(2,"STA","NM")="UNKNOWN"
QUIT
+8 SET ASUL(2,"STA","E#")=X1
End DoDot:1
IF ASUL(2,"STA","E#")']""
QUIT
+9 IF '$DATA(ASUL(1,"AR","E#"))
DO SETAREA
+10 DO STA(X1)
+11 QUIT
STA(X) ;EP ; DIRECT STATION TABLE LOOKUP
+1 IF $LENGTH(X)=3
SET X=ASUL(1,"AR","AP")_X
+2 IF $LENGTH(X)=2
SET X=ASUL(1,"AR","AP")_"0"_X
+3 IF X'?5N
Begin DoDot:1
+4 ;Input paramater did not pass Station IEN edit
SET Y=-4
QUIT
End DoDot:1
QUIT
+5 IF $DATA(^ASUL(2,X,0))
Begin DoDot:1
+6 ;Record found for input parameter
SET (Y,ASUL(2,"STA","E#"))=X
+7 SET ASUL(2,"STA","CD")=$PIECE(^ASUL(2,X,1),U)
+8 SET ASUL(2,"STA","NM")=$PIECE(^ASUL(2,X,0),U)
+9 SET ASUL(2,"STA","TYP")=$PIECE(^ASUL(2,X,1),U,2)
+10 SET ASUL(2,"STA","CTP")=$PIECE(^ASUL(2,X,1),U,3)
+11 SET ASUL(2,"STA","TP#")=$PIECE(^ASUL(2,X,1),U,4)
+12 SET ASUL(2,"STA","EOQTB")=$PIECE(^ASUL(2,X,1),U,6)
+13 IF ASUL(2,"STA","EOQTB")']""
SET ASUL(2,"STA","EOQTB")=50
End DoDot:1
+14 IF '$TEST
Begin DoDot:1
+15 ;IEN to use for LAYGO call
SET ASUL(2,"STA","E#")=X
+16 SET ASUL(2,"STA","CD")="N/F"
SET ASUL(2,"STA","NM")="UNKNOWN"
SET ASUL(2,"STA","EOQTB")=50
+17 ;No record found for Input parameter
SET Y=-1
End DoDot:1
+18 QUIT
TRN(X) ;EP ;TRANSACTION CODE
+1 KILL ASUL(11)
+2 IF X?1N.N
IF $DATA(^ASUL(11,+X))
SET ASUL(11,"TRN","E#")=+X
+3 IF '$TEST
IF $EXTRACT(X)'="T"
SET X="T"_X
SET ASUL(11,"TRN","E#")=$ORDER(^ASUL(11,"B",X,""))
+4 IF $GET(ASUL(11,"TRN","E#"))']""
SET Y=-1
QUIT
+5 IF '$TEST
SET Y=$GET(^ASUL(11,ASUL(11,"TRN","E#"),0))
+6 SET ASUL(11,"TRN","KEY")=$PIECE(Y,U,1)
+7 SET ASUL(11,"TRN","CDE")=$EXTRACT(Y,2,3)
+8 SET ASUL(11,"TRN","NAME")=$PIECE(Y,U,2)
+9 NEW Z
SET (Z,ASUL(11,"TRN","TYPE"))=$PIECE(Y,U,3)
+10 SET ASUL(11,"TRN","TYPN")=$SELECT(Z=1:"DUE IN",Z=2:"RECEIPT",Z=3:"ISSUE",Z=4:"INDEX",Z=5:"STATION",Z=6:"ADJUSTMENT",Z=7:"TRANSFER DUE IN",Z=8:"TRANSFER IN",Z=9:"TRANSFER OUT",Z=0:"DIRECT ISSUE",1:"TRANSFER ISSUE")
+11 SET (Z,ASUL(11,"TRN","EXT"))=$PIECE(Y,U,4)
+12 SET ASUL(11,"TRN","EXTN")=$SELECT(Z=0:"ADD",Z=1:"CHANGE",Z=2:"DELETE",Z=3:"USER LEVEL",Z=4:"PURCHASED",Z=5:"UNREQUIRED",Z=6:"DONATED",Z=7:"EXCESS",Z=8:"STOCK REPLENISHMENT",Z=9:"NON REPLENISHMENT",1:"")
+13 SET ASUL(11,"TRN","DRCR")=$PIECE(Y,U,5)
+14 SET ASUL(11,"TRN","DBCR")=$SELECT(ASUL(11,"TRN","TYPE")=4:"",ASUL(11,"TRN","TYPE")=5:"",ASUL(11,"TRN","DRCR")=-1:"CREDIT",1:"DEBIT")
+15 SET ASUL(11,"TRN","REV")=$PIECE(Y,U,6)
+16 SET ASUL(11,"TRN","TAG")=$PIECE(Y,U,7)
+17 SET ASUL(11,"TRN","FIL")=$PIECE(Y,U,8)
+18 QUIT
