ASULDIRR ; IHS/ITSC/LMH -DIRECT LOOKUP REQUSITION RELATED ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine is a utility which provides entry points to lookup
;entries in SAMS requsitioner related tables.
;**SELCAN & MULTCAN subroutines created to enable mult. can lookup LMH
SST(X) ;EP ; DIRECT SUB STATION TABLE LOOKUP
I X["PL" S X=999
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 Sub Station IEN edit
I $D(^ASUL(18,X,0)) D
.S (Y,ASUL(18,"SST","E#"))=X ;Record found for input parameter
.S ASUL(18,"SST")=$P($G(^ASUL(18,X,1)),U)
.S ASUL(18,"SST","NM")=$P($G(^ASUL(18,X,0)),U)
E D
.S ASUL(18,"SST","E#")=X ;IEN to use for LAYGO call
.S ASUL(18,"SST")=$E(ASUL(18,"SST","E#"),4,5)
.S:'$D(ASUL(18,"SST","NM")) ASUL(18,"SST","NM")="UNKNOWN"
.S Y=-1 ;No record found for Input parameter
Q
USR(X) ;EP ; DIRECT USER TABLE LOOKUP
USRX ;
I '$G(ASUL(22,"PGM","E#")),X]"" D Q:$G(Y)'=ASUL(22,"PGM","E#")
.S X(22)=$S(X'?6N:$E(X,1,2),1:$E(X,3,4)) S:X="00" X=100
.D PGM($E(X(22),1,2))
I $L(X)=3,X?2N.1AN S ASUL(19,"USR")=X D USR^ASULALGO(.X) Q:Y<0 ;Translate 3 digit user code to IEN
I $L(X)=4 S X=ASUL(1,"AR","AP")_X
I X'?6N D Q
.S Y=-4 Q ;Input paramater did not pass User IEN edit
I $D(^ASUL(19,X,0)) D
.S (Y,ASUL(19,"USR","E#"))=X ;Record found for input parameter
.S ASUL(19,"USR")=$P(^ASUL(19,X,1),U)
.S ASUL(19,"USR","NM")=$P(^ASUL(19,X,0),U)
E D
.S ASUL(19,"USR","E#")=X ;IEN to use for LAYGO call
.I '$D(ASUL(19,"USR","NM")) S ASUL(19,"USR","NM")=$G(ASUL(22,"PGM","NM"))
.S Y=-1 ;No record found for Input parameter
Q
REQ(X) ;EP ; DIRECT REQUISTIONER TABLE LOOKUP
I $G(ASUL(18,"SST","E#"))="" D Q:$G(Y)<0
.I X?9N S ASUL(18,"SST","E#")=$E(X,1,5) Q
.S Y=-10 ;Must have Sub Station
I $G(ASUL(18,"SST"))="" S X(1)=ASUL(18,"SST","E#") D SST(X(1))
I $G(ASUL(19,"USR","E#"))="" D Q:Y'=$G(ASUL(19,"USR","E#"))
.I X?9N S X(1)=X,(X,ASUL(19,"USR","E#"))=$E(X(1),1,2)_$E(X(1),6,9) D USR(X) S X=X(1) Q
.D USRX
I $G(ASUL(19,"USR"))="" S X(1)=ASUL(19,"USR","E#") D USR(X(1))
S X=ASUL(18,"SST","E#")_$E(ASUL(19,"USR","E#"),3,6)
I X'?9N D Q
.S Y=-4 Q ;Input paramater did not pass User IEN edit
S ASUL(20,"REQ")=ASUL(19,"USR")
I $D(^ASUL(20,X,0)) D
.S (Y,ASUL(20,"REQ","E#"))=X ;Record found for input parameter
.S ASUL(20,"REQ","NM")=$P(^ASUL(20,X,0),U)
.S ASUL(20,"ULVQ FCTR")=$P($G(^ASUL(20,X,1)),U)
.N Z S Z=0
.;F ASUC("SSA")=1:1 S Z=$O(^ASUL(20,ASUL(20,"REQ","E#"),2,"C",Z)) I ASUC("SSA")>1 D MULTCAN K ASUC("SSA"),ASUL("SSA") Q Q:Z="" D
.F ASUC("SSA")=1:1 S Z=$O(^ASUL(20,ASUL(20,"REQ","E#"),2,"C",Z)) Q:Z="" D
..S ASUL(20,"SSA")=Z,ASUL(20,"SSA","CNT")=ASUC("SSA")
..S ASUL("SSA","E#")=$O(^ASUL(20,ASUL(20,"REQ","E#"),2,"C",ASUL(20,"SSA"),0))
..S ASUL(20,"CAN",ASUL(20,"SSA"))=$P(^ASUL(20,ASUL(20,"REQ","E#"),2,ASUL("SSA","E#"),0),U)
.I $G(ASUL(20,"SSA","CNT"))>1 D MULTCAN ;WAR 11/26/99
.K ASUC("SSA"),ASUL("SSA")
E D
.S ASUL(20,"REQ","E#")=X ;IEN to use for LAYGO call
.S ASUL(20,"ULVQ FCTR")=""
.S ASUL(20,"REQ","NM")=ASUL(19,"USR","NM")_" @ "_ASUL(18,"SST","NM")
.S Y=-1 ;No record found for Input parameter
Q
;
MULTCAN ; Allows selection of multiple CANs
;
I $G(ASUDDS)=1 D
.S DA(1)=ASUL(20,"REQ","E#")
.S DIC="^ASUL(20,"_DA(1)_",2,"
.S DIC(0)="AEMQL"
.I ASUT("TRCD")["0" W !!!! S DIC("A")="Enter a ""??"" and select a CAN: "
.W !!!! S DIC("A")="Enter a ""??"" and select a CAN: "
.D ^DIC
.I +$G(Y)>0 D SELCAN
Q
;
SELCAN ; If there are multiple CANs, uses selection for transaction
;
S ASUL("SSA","E#")=+Y
S ASUL(20,"SSA")=$P(^ASUL(20,ASUL(20,"REQ","E#"),2,ASUL("SSA","E#"),0),U,2)
S ASUL(20,"CAN",ASUL(20,"SSA"))=$P(^ASUL(20,ASUL(20,"REQ","E#"),2,ASUL("SSA","E#"),0),U)
K ASUC("SSA"),ASUL("SSA")
Q
SSA(X) ;EP ; DIRECT SUB-SUB ACTVITY TABLE LOOKUP
I X'?1N.N D
.S Y=-4 Q ;Input paramater did not pass Sub-sub activity IEN edit
S:+X=0 X=100
I $D(^ASUL(17,+X,0)) D
.S (Y,ASUL(17,"SSA","E#"))=+X ;Record found for input parameter
.S ASUL(17,"SSA")=$P(^ASUL(17,+X,1),U)
.S ASUL(17,"SSA","NM")=$P(^ASUL(17,+X,0),U)
E D
.S ASUL(17,"SSA","E#")=+X ;IEN to use for LAYGO call
.S ASUL(17,"SSA")="N/F"
.S ASUL(17,"SSA","NM")="UNKNOWN"
.S Y=-1 ;No record found for Input parameter
Q
PGM(X) ;EP ; DIRECT PROGRAM TABLE LOOKUP
PGMX ;
I +X=0 S X=100
I $D(^ASUL(22,+X,0)) D
.S (Y,ASUL(22,"PGM","E#"))=+X ;Record found for input parameter
.S ASUL(22,"PGM")=$P(^ASUL(22,+X,0),U)
.S ASUL(22,"PGM","NM")=$P(^ASUL(22,+X,0),U,2)
E D
.I X="" S Y=-2 Q
.S ASUL(22,"PGM","E#")=+X ;IEN to use for LAYGO call
.S ASUL(22,"PGM")="N/F"
.S ASUL(22,"PGM","NM")="UNKNOWN"
.S Y=-1 ;No record found for Input parameter
Q
SLC(X) ;EP;.
S:X]"" ASUL(10,"SLC","E#")=$O(^ASUL(10,"B",X,""))
I $G(ASUL(10,"SLC","E#"))="" S ASUL(10,"SLC","NM")="UNKNOWN",ASUL(10,"SLC")=" ",ASUL(10,"SLC","E#")="" Q
S ASUL(10,"SLC","NM")=$P(^ASUL(10,ASUL(10,"SLC","E#"),0),U,2)
S ASUL(10,"SLC")=X
Q
ASULDIRR ; IHS/ITSC/LMH -DIRECT LOOKUP REQUSITION RELATED ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine is a utility which provides entry points to lookup
+3 ;entries in SAMS requsitioner related tables.
+4 ;**SELCAN & MULTCAN subroutines created to enable mult. can lookup LMH
SST(X) ;EP ; DIRECT SUB STATION TABLE LOOKUP
+1 IF X["PL"
SET X=999
+2 IF $LENGTH(X)=3
SET X=ASUL(1,"AR","AP")_X
+3 IF $LENGTH(X)=2
SET X=ASUL(1,"AR","AP")_"0"_X
+4 IF X'?5N
Begin DoDot:1
+5 ;Input paramater did not pass Sub Station IEN edit
SET Y=-4
QUIT
End DoDot:1
QUIT
+6 IF $DATA(^ASUL(18,X,0))
Begin DoDot:1
+7 ;Record found for input parameter
SET (Y,ASUL(18,"SST","E#"))=X
+8 SET ASUL(18,"SST")=$PIECE($GET(^ASUL(18,X,1)),U)
+9 SET ASUL(18,"SST","NM")=$PIECE($GET(^ASUL(18,X,0)),U)
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 ;IEN to use for LAYGO call
SET ASUL(18,"SST","E#")=X
+12 SET ASUL(18,"SST")=$EXTRACT(ASUL(18,"SST","E#"),4,5)
+13 IF '$DATA(ASUL(18,"SST","NM"))
SET ASUL(18,"SST","NM")="UNKNOWN"
+14 ;No record found for Input parameter
SET Y=-1
End DoDot:1
+15 QUIT
USR(X) ;EP ; DIRECT USER TABLE LOOKUP
USRX ;
+1 IF '$GET(ASUL(22,"PGM","E#"))
IF X]""
Begin DoDot:1
+2 SET X(22)=$SELECT(X'?6N:$EXTRACT(X,1,2),1:$EXTRACT(X,3,4))
IF X="00"
SET X=100
+3 DO PGM($EXTRACT(X(22),1,2))
End DoDot:1
IF $GET(Y)'=ASUL(22,"PGM","E#")
QUIT
+4 ;Translate 3 digit user code to IEN
IF $LENGTH(X)=3
IF X?2N.1AN
SET ASUL(19,"USR")=X
DO USR^ASULALGO(.X)
IF Y<0
QUIT
+5 IF $LENGTH(X)=4
SET X=ASUL(1,"AR","AP")_X
+6 IF X'?6N
Begin DoDot:1
+7 ;Input paramater did not pass User IEN edit
SET Y=-4
QUIT
End DoDot:1
QUIT
+8 IF $DATA(^ASUL(19,X,0))
Begin DoDot:1
+9 ;Record found for input parameter
SET (Y,ASUL(19,"USR","E#"))=X
+10 SET ASUL(19,"USR")=$PIECE(^ASUL(19,X,1),U)
+11 SET ASUL(19,"USR","NM")=$PIECE(^ASUL(19,X,0),U)
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 ;IEN to use for LAYGO call
SET ASUL(19,"USR","E#")=X
+14 IF '$DATA(ASUL(19,"USR","NM"))
SET ASUL(19,"USR","NM")=$GET(ASUL(22,"PGM","NM"))
+15 ;No record found for Input parameter
SET Y=-1
End DoDot:1
+16 QUIT
REQ(X) ;EP ; DIRECT REQUISTIONER TABLE LOOKUP
+1 IF $GET(ASUL(18,"SST","E#"))=""
Begin DoDot:1
+2 IF X?9N
SET ASUL(18,"SST","E#")=$EXTRACT(X,1,5)
QUIT
+3 ;Must have Sub Station
SET Y=-10
End DoDot:1
IF $GET(Y)<0
QUIT
+4 IF $GET(ASUL(18,"SST"))=""
SET X(1)=ASUL(18,"SST","E#")
DO SST(X(1))
+5 IF $GET(ASUL(19,"USR","E#"))=""
Begin DoDot:1
+6 IF X?9N
SET X(1)=X
SET (X,ASUL(19,"USR","E#"))=$EXTRACT(X(1),1,2)_$EXTRACT(X(1),6,9)
DO USR(X)
SET X=X(1)
QUIT
+7 DO USRX
End DoDot:1
IF Y'=$GET(ASUL(19,"USR","E#"))
QUIT
+8 IF $GET(ASUL(19,"USR"))=""
SET X(1)=ASUL(19,"USR","E#")
DO USR(X(1))
+9 SET X=ASUL(18,"SST","E#")_$EXTRACT(ASUL(19,"USR","E#"),3,6)
+10 IF X'?9N
Begin DoDot:1
+11 ;Input paramater did not pass User IEN edit
SET Y=-4
QUIT
End DoDot:1
QUIT
+12 SET ASUL(20,"REQ")=ASUL(19,"USR")
+13 IF $DATA(^ASUL(20,X,0))
Begin DoDot:1
+14 ;Record found for input parameter
SET (Y,ASUL(20,"REQ","E#"))=X
+15 SET ASUL(20,"REQ","NM")=$PIECE(^ASUL(20,X,0),U)
+16 SET ASUL(20,"ULVQ FCTR")=$PIECE($GET(^ASUL(20,X,1)),U)
+17 NEW Z
SET Z=0
+18 ;F ASUC("SSA")=1:1 S Z=$O(^ASUL(20,ASUL(20,"REQ","E#"),2,"C",Z)) I ASUC("SSA")>1 D MULTCAN K ASUC("SSA"),ASUL("SSA") Q Q:Z="" D
+19 FOR ASUC("SSA")=1:1
SET Z=$ORDER(^ASUL(20,ASUL(20,"REQ","E#"),2,"C",Z))
IF Z=""
QUIT
Begin DoDot:2
+20 SET ASUL(20,"SSA")=Z
SET ASUL(20,"SSA","CNT")=ASUC("SSA")
+21 SET ASUL("SSA","E#")=$ORDER(^ASUL(20,ASUL(20,"REQ","E#"),2,"C",ASUL(20,"SSA"),0))
+22 SET ASUL(20,"CAN",ASUL(20,"SSA"))=$PIECE(^ASUL(20,ASUL(20,"REQ","E#"),2,ASUL("SSA","E#"),0),U)
End DoDot:2
+23 ;WAR 11/26/99
IF $GET(ASUL(20,"SSA","CNT"))>1
DO MULTCAN
+24 KILL ASUC("SSA"),ASUL("SSA")
End DoDot:1
+25 IF '$TEST
Begin DoDot:1
+26 ;IEN to use for LAYGO call
SET ASUL(20,"REQ","E#")=X
+27 SET ASUL(20,"ULVQ FCTR")=""
+28 SET ASUL(20,"REQ","NM")=ASUL(19,"USR","NM")_" @ "_ASUL(18,"SST","NM")
+29 ;No record found for Input parameter
SET Y=-1
End DoDot:1
+30 QUIT
+31 ;
MULTCAN ; Allows selection of multiple CANs
+1 ;
+2 IF $GET(ASUDDS)=1
Begin DoDot:1
+3 SET DA(1)=ASUL(20,"REQ","E#")
+4 SET DIC="^ASUL(20,"_DA(1)_",2,"
+5 SET DIC(0)="AEMQL"
+6 IF ASUT("TRCD")["0"
WRITE !!!!
SET DIC("A")="Enter a ""??"" and select a CAN: "
+7 WRITE !!!!
SET DIC("A")="Enter a ""??"" and select a CAN: "
+8 DO ^DIC
+9 IF +$GET(Y)>0
DO SELCAN
End DoDot:1
+10 QUIT
+11 ;
SELCAN ; If there are multiple CANs, uses selection for transaction
+1 ;
+2 SET ASUL("SSA","E#")=+Y
+3 SET ASUL(20,"SSA")=$PIECE(^ASUL(20,ASUL(20,"REQ","E#"),2,ASUL("SSA","E#"),0),U,2)
+4 SET ASUL(20,"CAN",ASUL(20,"SSA"))=$PIECE(^ASUL(20,ASUL(20,"REQ","E#"),2,ASUL("SSA","E#"),0),U)
+5 KILL ASUC("SSA"),ASUL("SSA")
+6 QUIT
SSA(X) ;EP ; DIRECT SUB-SUB ACTVITY TABLE LOOKUP
+1 IF X'?1N.N
Begin DoDot:1
+2 ;Input paramater did not pass Sub-sub activity IEN edit
SET Y=-4
QUIT
End DoDot:1
+3 IF +X=0
SET X=100
+4 IF $DATA(^ASUL(17,+X,0))
Begin DoDot:1
+5 ;Record found for input parameter
SET (Y,ASUL(17,"SSA","E#"))=+X
+6 SET ASUL(17,"SSA")=$PIECE(^ASUL(17,+X,1),U)
+7 SET ASUL(17,"SSA","NM")=$PIECE(^ASUL(17,+X,0),U)
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 ;IEN to use for LAYGO call
SET ASUL(17,"SSA","E#")=+X
+10 SET ASUL(17,"SSA")="N/F"
+11 SET ASUL(17,"SSA","NM")="UNKNOWN"
+12 ;No record found for Input parameter
SET Y=-1
End DoDot:1
+13 QUIT
PGM(X) ;EP ; DIRECT PROGRAM TABLE LOOKUP
PGMX ;
+1 IF +X=0
SET X=100
+2 IF $DATA(^ASUL(22,+X,0))
Begin DoDot:1
+3 ;Record found for input parameter
SET (Y,ASUL(22,"PGM","E#"))=+X
+4 SET ASUL(22,"PGM")=$PIECE(^ASUL(22,+X,0),U)
+5 SET ASUL(22,"PGM","NM")=$PIECE(^ASUL(22,+X,0),U,2)
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 IF X=""
SET Y=-2
QUIT
+8 ;IEN to use for LAYGO call
SET ASUL(22,"PGM","E#")=+X
+9 SET ASUL(22,"PGM")="N/F"
+10 SET ASUL(22,"PGM","NM")="UNKNOWN"
+11 ;No record found for Input parameter
SET Y=-1
End DoDot:1
+12 QUIT
SLC(X) ;EP;.
+1 IF X]""
SET ASUL(10,"SLC","E#")=$ORDER(^ASUL(10,"B",X,""))
+2 IF $GET(ASUL(10,"SLC","E#"))=""
SET ASUL(10,"SLC","NM")="UNKNOWN"
SET ASUL(10,"SLC")=" "
SET ASUL(10,"SLC","E#")=""
QUIT
+3 SET ASUL(10,"SLC","NM")=$PIECE(^ASUL(10,ASUL(10,"SLC","E#"),0),U,2)
+4 SET ASUL(10,"SLC")=X
+5 QUIT
