ASULDIRF ; IHS/ITSC/LMH -DIRECT LKUP FINANCE RELATED ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine is a utility which provides entry points to lookup
;entries in SAMS finance related tables.
ACC(X) ;EP ; DIRECT ACCOUNT TABLE LOOKUP
I $D(^ASUL(9,+X,0)) D
.S (Y,ASUL(9,"ACC","E#"))=+X ;Record found for input parameter
.S ASUL(9,"ACC")=$P(^ASUL(9,+X,0),U,2)
.S ASUL(9,"ACC","NM")=$P(^ASUL(9,+X,0),U)
.S ASUL(9,"ACG")=$S(ASUL(9,"ACC")=1:1,ASUL(9,"ACC")=3:3,1:"*") D ACGNM(ASUL(9,"ACG"))
E I X D ;IHS/DSD/JLG 5/6/99 Modified to only apply if X is true
.S ASUL(9,"ACC","E#")=+X ;IEN to use for LAYGO call
.S (ASUL(9,"ACC"),ASUL(9,"ACG"))="N/F"
.S (ASUL(9,"ACC","NM"),ASUL(9,"ACG","NM"))="UNKNOWN"
.S Y=-1 ;No record found for Input parameter
E D
.;If X is not a valid ien value set the flag and make sure there is
.;no left over values for the ASUL array. It is possible this will not
.;work out and may require something else to be done.
.S Y=-1 ;X is not a valid ien
.K ASUL(9,"ACC")
Q
ACGNM(X) ;EP ; SET ACCOUNT GROUP NAME
S:$G(ASUL(9,"ACG"))']"" ASUL(9,"ACG")=X
I X="*" S ASUL(9,"ACG","NM")="GENERAL SUPPLIES" Q
S ASUL(9,"ACG","NM")=$P(^ASUL(9,+X,0),U)
Q
SOBJ(X) ;EP
D SSO(.X)
Q
SSO(X) ;EP ; STOCK SUB OBJECT TABLE LOOKUP
;Format of IEN: 1st digit=Account
; digit 2-3 = digit 3-4 of Sub Object Code
;I (X?4N)!(X?1A.AN) D OBJ(3) I Y>0 S X=+Y
D OBJ(3) I Y>0 S X=+Y
I X']"" S Y=-10 K ASUL(3) Q
I '$G(ASUL(9,"ACC","E#")) D
.I $L(X)=3 D Q:$G(Y)<0
..S X(1)=$E(X) D ACC(X(1)) K:Y<0 ASUL(3)
E D Q:$G(Y)<0
.;I ASUT("E#")=13 B
.I $L(X)=3 D Q:$G(Y)<0
..I ASUL(9,"ACC","E#")'=$E(X) S Y=-11 K ASUL(3) Q
I X[".",$L(X)=5 S X=$E(X,5)
I $L(X)=4 S X=$E(X,4)
I $L(X)=1 D TR^ASULALGO(.X) S:Y>0 X=$G(ASUL(9,"ACC","E#"))_Y
I $L(X)=3,$D(^ASUL(3,X,0)) D
.S (Y,ASUL(3,"SOBJ","E#"))=X
.S ASUL(3,"SOBJ","ACC")=ASUL(9,"ACC","E#")
.S ASUL(3,"SOBJ","NM")=$P(^ASUL(3,Y,0),U)
.S X=$P(^ASUL(3,Y,1),U),ASUL(3,"SOBJ","CD")=$E(X,1,2)_"."_$E(X,3,4)
E D
.S ASUL(3,"SOBJ","NM")="UNKNOWN",ASUL(3,"SOBJ","CD")="NF",ASUL(3,"SOBJ","ACC")=""
.S Y=-1
Q
OBJ(Z) ;
S DIC="^ASUL("_Z_",",DIC(0)="MS" D ^DIC
;I ASUT("E#")=13 B
Q
DSO(X) ;EP ; DIRECT SUB OBJECT TABLE LOOKUP
;Format of IEN: 1st digit=Account
; digit 2-3 = digit 3-4 of Sub Object Code
;I (X?4N)!(X?1A.AN) D OBJ(4) I Y>0 S X=+Y
D OBJ(4) I Y>0 S X=+Y
I X']"" S Y=-10 K ASUL(4) Q
I '$G(ASUL(9,"ACC","E#")) D
.I $L(X)=3 D Q:$G(Y)<0
..S X(1)=$E(X) D ACC(X(1)) K:Y<0 ASUL(4)
E D Q:Y<0
.I $L(X)=3 D Q:$G(Y)<0
..I ASUL(9,"ACC","E#")'=$E(X) S Y=-11 K ASUL(4) Q
I X[".",$L(X)=5 S X=$E(X,5)
I $L(X)=4 S X=$E(X,4)
I $L(X)=1 D TR^ASULALGO(.X) S:Y>0 X=$G(ASUL(9,"ACC","E#"))_Y
I $L(X)=3,$D(^ASUL(4,X,0)) D
.S (Y,ASUL(4,"SOBJ","E#"))=X,ASUL(4,"SOBJ","ACC")=ASUL(9,"ACC","E#")
.S ASUL(4,"SOBJ","NM")=$P(^ASUL(4,X,0),U)
.S X=$P(^ASUL(4,Y,1),U),ASUL(4,"SOBJ","CD")=$E(X,1,2)_"."_$E(X,3,4)
E D
.S ASUL(4,"SOBJ","NM")="UNKNOWN",ASUL(4,"SOBJ","CD")="NF",ASUL(4,"SOBJ","ACC")=""
.S Y=-1
Q
DCAN(X) ;EP ; DIRECT ISSUE COMMON ACCOUNTING NUMBER
Q
SRC(X) ;EP ; DIRECT SOURCE TABLE LOOKUP
;I X?1AN D TR^ASULALGO(.X)
;I X?2N,$D(^ASUL(5,X,0)) D
S Y=$O(^ASUL(5,"C",X,"")) I Y D
.S ASUL(5,"SRC","E#")=Y ;Record found for input parameter
.S ASUL(5,"SRC","NM")=$P(^ASUL(5,Y,0),U),ASUL(5,"SRC")=$P(^(0),U,2)
E D
.S Y=-1 ;No record found for Input parameter
Q
CAT(X) ;EP ; DIRECT CATEGORY TABLE LOOKUP
;Format of IEN - digits1-3 = IEN of Stock Sub Object (ASUL(3))
; digits4-5 = Algolrythm of Category Code
; ie 1=01,2=02,A=10,B=11
I $G(ASUL(3,"SOBJ","E#"))']"" D Q:Y<0
.I X?5N S ASUL(3,"SOBJ","E#")=$E(X,1,3)
E D
.K ASUL(7) S Y=-10 Q ;Must have Stock Sub Object
I $G(ASUL(3,"SOBJ","CD"))']"" S X(1)=ASUL(3,"SOBJ","E#") D SSO(X(1))
I X?1AN D TR^ASULALGO(.X) S:Y>0 X=ASUL(3,"SOBJ","E#")_Y
I X'?5N D Q
.S Y=-4 Q ;Input paramater did not pass User IEN edit
I $D(^ASUL(7,X,0)) D
.S (Y,ASUL(7,"CAT","E#"))=X ;Record found for input parameter
.S ASUL(7,"CAT","NM")=$P(^ASUL(7,X,0),U)
.S ASUL(7,"CAT","CD")=$P(^ASUL(7,X,1),U)
E D
.S ASUL(7,"CAT","E#")=X ;IEN to use for LAYGO call
.S Y=-1 ;No record found for Input parameter
Q
EOQT(X) ;EP ; DIRECT EOQ TABLE LOOKUP
S ASUL(8,"EOQTB","E#")=X,Y=0
I $D(^ASUL(8,X))'>0 S Y=-1 Q
F S Y=$O(^ASUL(8,X,1,Y)) Q:Y']"" D
.S ASUL(8,"EOQTB",Y)=^ASUL(8,X,1,Y,0)
Q
EOQ(X) ;EP ; DIRECT EOQ TYPE LOOKUP
S Y=0
I X?1A D
.S ASUL(6,"EOQTP","E#")=$O(^ASUL(6,"B",X,""))
E D
.S ASUL(6,"EOQTP","E#")=X
I ASUL(6,"EOQTP","E#")'?1N.N S Y=-1 Q
I $D(^ASUL(6,ASUL(6,"EOQTP","E#")))'>0 S Y=-2 Q
S ASUL(6,"EOQTP")=$P($G(^ASUL(6,ASUL(6,"EOQTP","E#"),0)),U)
S ASUL(6,"EOQTP","NM")=$P($G(^ASUL(6,ASUL(6,"EOQTP","E#"),0)),U,2)
Q
ASULDIRF ; IHS/ITSC/LMH -DIRECT LKUP FINANCE 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 finance related tables.
ACC(X) ;EP ; DIRECT ACCOUNT TABLE LOOKUP
+1 IF $DATA(^ASUL(9,+X,0))
Begin DoDot:1
+2 ;Record found for input parameter
SET (Y,ASUL(9,"ACC","E#"))=+X
+3 SET ASUL(9,"ACC")=$PIECE(^ASUL(9,+X,0),U,2)
+4 SET ASUL(9,"ACC","NM")=$PIECE(^ASUL(9,+X,0),U)
+5 SET ASUL(9,"ACG")=$SELECT(ASUL(9,"ACC")=1:1,ASUL(9,"ACC")=3:3,1:"*")
DO ACGNM(ASUL(9,"ACG"))
End DoDot:1
+6 ;IHS/DSD/JLG 5/6/99 Modified to only apply if X is true
IF '$TEST
IF X
Begin DoDot:1
+7 ;IEN to use for LAYGO call
SET ASUL(9,"ACC","E#")=+X
+8 SET (ASUL(9,"ACC"),ASUL(9,"ACG"))="N/F"
+9 SET (ASUL(9,"ACC","NM"),ASUL(9,"ACG","NM"))="UNKNOWN"
+10 ;No record found for Input parameter
SET Y=-1
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 ;If X is not a valid ien value set the flag and make sure there is
+13 ;no left over values for the ASUL array. It is possible this will not
+14 ;work out and may require something else to be done.
+15 ;X is not a valid ien
SET Y=-1
+16 KILL ASUL(9,"ACC")
End DoDot:1
+17 QUIT
ACGNM(X) ;EP ; SET ACCOUNT GROUP NAME
+1 IF $GET(ASUL(9,"ACG"))']""
SET ASUL(9,"ACG")=X
+2 IF X="*"
SET ASUL(9,"ACG","NM")="GENERAL SUPPLIES"
QUIT
+3 SET ASUL(9,"ACG","NM")=$PIECE(^ASUL(9,+X,0),U)
+4 QUIT
SOBJ(X) ;EP
+1 DO SSO(.X)
+2 QUIT
SSO(X) ;EP ; STOCK SUB OBJECT TABLE LOOKUP
+1 ;Format of IEN: 1st digit=Account
+2 ; digit 2-3 = digit 3-4 of Sub Object Code
+3 ;I (X?4N)!(X?1A.AN) D OBJ(3) I Y>0 S X=+Y
+4 DO OBJ(3)
IF Y>0
SET X=+Y
+5 IF X']""
SET Y=-10
KILL ASUL(3)
QUIT
+6 IF '$GET(ASUL(9,"ACC","E#"))
Begin DoDot:1
+7 IF $LENGTH(X)=3
Begin DoDot:2
+8 SET X(1)=$EXTRACT(X)
DO ACC(X(1))
IF Y<0
KILL ASUL(3)
End DoDot:2
IF $GET(Y)<0
QUIT
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 ;I ASUT("E#")=13 B
+11 IF $LENGTH(X)=3
Begin DoDot:2
+12 IF ASUL(9,"ACC","E#")'=$EXTRACT(X)
SET Y=-11
KILL ASUL(3)
QUIT
End DoDot:2
IF $GET(Y)<0
QUIT
End DoDot:1
IF $GET(Y)<0
QUIT
+13 IF X["."
IF $LENGTH(X)=5
SET X=$EXTRACT(X,5)
+14 IF $LENGTH(X)=4
SET X=$EXTRACT(X,4)
+15 IF $LENGTH(X)=1
DO TR^ASULALGO(.X)
IF Y>0
SET X=$GET(ASUL(9,"ACC","E#"))_Y
+16 IF $LENGTH(X)=3
IF $DATA(^ASUL(3,X,0))
Begin DoDot:1
+17 SET (Y,ASUL(3,"SOBJ","E#"))=X
+18 SET ASUL(3,"SOBJ","ACC")=ASUL(9,"ACC","E#")
+19 SET ASUL(3,"SOBJ","NM")=$PIECE(^ASUL(3,Y,0),U)
+20 SET X=$PIECE(^ASUL(3,Y,1),U)
SET ASUL(3,"SOBJ","CD")=$EXTRACT(X,1,2)_"."_$EXTRACT(X,3,4)
End DoDot:1
+21 IF '$TEST
Begin DoDot:1
+22 SET ASUL(3,"SOBJ","NM")="UNKNOWN"
SET ASUL(3,"SOBJ","CD")="NF"
SET ASUL(3,"SOBJ","ACC")=""
+23 SET Y=-1
End DoDot:1
+24 QUIT
OBJ(Z) ;
+1 SET DIC="^ASUL("_Z_","
SET DIC(0)="MS"
DO ^DIC
+2 ;I ASUT("E#")=13 B
+3 QUIT
DSO(X) ;EP ; DIRECT SUB OBJECT TABLE LOOKUP
+1 ;Format of IEN: 1st digit=Account
+2 ; digit 2-3 = digit 3-4 of Sub Object Code
+3 ;I (X?4N)!(X?1A.AN) D OBJ(4) I Y>0 S X=+Y
+4 DO OBJ(4)
IF Y>0
SET X=+Y
+5 IF X']""
SET Y=-10
KILL ASUL(4)
QUIT
+6 IF '$GET(ASUL(9,"ACC","E#"))
Begin DoDot:1
+7 IF $LENGTH(X)=3
Begin DoDot:2
+8 SET X(1)=$EXTRACT(X)
DO ACC(X(1))
IF Y<0
KILL ASUL(4)
End DoDot:2
IF $GET(Y)<0
QUIT
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 IF $LENGTH(X)=3
Begin DoDot:2
+11 IF ASUL(9,"ACC","E#")'=$EXTRACT(X)
SET Y=-11
KILL ASUL(4)
QUIT
End DoDot:2
IF $GET(Y)<0
QUIT
End DoDot:1
IF Y<0
QUIT
+12 IF X["."
IF $LENGTH(X)=5
SET X=$EXTRACT(X,5)
+13 IF $LENGTH(X)=4
SET X=$EXTRACT(X,4)
+14 IF $LENGTH(X)=1
DO TR^ASULALGO(.X)
IF Y>0
SET X=$GET(ASUL(9,"ACC","E#"))_Y
+15 IF $LENGTH(X)=3
IF $DATA(^ASUL(4,X,0))
Begin DoDot:1
+16 SET (Y,ASUL(4,"SOBJ","E#"))=X
SET ASUL(4,"SOBJ","ACC")=ASUL(9,"ACC","E#")
+17 SET ASUL(4,"SOBJ","NM")=$PIECE(^ASUL(4,X,0),U)
+18 SET X=$PIECE(^ASUL(4,Y,1),U)
SET ASUL(4,"SOBJ","CD")=$EXTRACT(X,1,2)_"."_$EXTRACT(X,3,4)
End DoDot:1
+19 IF '$TEST
Begin DoDot:1
+20 SET ASUL(4,"SOBJ","NM")="UNKNOWN"
SET ASUL(4,"SOBJ","CD")="NF"
SET ASUL(4,"SOBJ","ACC")=""
+21 SET Y=-1
End DoDot:1
+22 QUIT
DCAN(X) ;EP ; DIRECT ISSUE COMMON ACCOUNTING NUMBER
+1 QUIT
SRC(X) ;EP ; DIRECT SOURCE TABLE LOOKUP
+1 ;I X?1AN D TR^ASULALGO(.X)
+2 ;I X?2N,$D(^ASUL(5,X,0)) D
+3 SET Y=$ORDER(^ASUL(5,"C",X,""))
IF Y
Begin DoDot:1
+4 ;Record found for input parameter
SET ASUL(5,"SRC","E#")=Y
+5 SET ASUL(5,"SRC","NM")=$PIECE(^ASUL(5,Y,0),U)
SET ASUL(5,"SRC")=$PIECE(^(0),U,2)
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 ;No record found for Input parameter
SET Y=-1
End DoDot:1
+8 QUIT
CAT(X) ;EP ; DIRECT CATEGORY TABLE LOOKUP
+1 ;Format of IEN - digits1-3 = IEN of Stock Sub Object (ASUL(3))
+2 ; digits4-5 = Algolrythm of Category Code
+3 ; ie 1=01,2=02,A=10,B=11
+4 IF $GET(ASUL(3,"SOBJ","E#"))']""
Begin DoDot:1
+5 IF X?5N
SET ASUL(3,"SOBJ","E#")=$EXTRACT(X,1,3)
End DoDot:1
IF Y<0
QUIT
+6 IF '$TEST
Begin DoDot:1
+7 ;Must have Stock Sub Object
KILL ASUL(7)
SET Y=-10
QUIT
End DoDot:1
+8 IF $GET(ASUL(3,"SOBJ","CD"))']""
SET X(1)=ASUL(3,"SOBJ","E#")
DO SSO(X(1))
+9 IF X?1AN
DO TR^ASULALGO(.X)
IF Y>0
SET X=ASUL(3,"SOBJ","E#")_Y
+10 IF X'?5N
Begin DoDot:1
+11 ;Input paramater did not pass User IEN edit
SET Y=-4
QUIT
End DoDot:1
QUIT
+12 IF $DATA(^ASUL(7,X,0))
Begin DoDot:1
+13 ;Record found for input parameter
SET (Y,ASUL(7,"CAT","E#"))=X
+14 SET ASUL(7,"CAT","NM")=$PIECE(^ASUL(7,X,0),U)
+15 SET ASUL(7,"CAT","CD")=$PIECE(^ASUL(7,X,1),U)
End DoDot:1
+16 IF '$TEST
Begin DoDot:1
+17 ;IEN to use for LAYGO call
SET ASUL(7,"CAT","E#")=X
+18 ;No record found for Input parameter
SET Y=-1
End DoDot:1
+19 QUIT
EOQT(X) ;EP ; DIRECT EOQ TABLE LOOKUP
+1 SET ASUL(8,"EOQTB","E#")=X
SET Y=0
+2 IF $DATA(^ASUL(8,X))'>0
SET Y=-1
QUIT
+3 FOR
SET Y=$ORDER(^ASUL(8,X,1,Y))
IF Y']""
QUIT
Begin DoDot:1
+4 SET ASUL(8,"EOQTB",Y)=^ASUL(8,X,1,Y,0)
End DoDot:1
+5 QUIT
EOQ(X) ;EP ; DIRECT EOQ TYPE LOOKUP
+1 SET Y=0
+2 IF X?1A
Begin DoDot:1
+3 SET ASUL(6,"EOQTP","E#")=$ORDER(^ASUL(6,"B",X,""))
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 SET ASUL(6,"EOQTP","E#")=X
End DoDot:1
+6 IF ASUL(6,"EOQTP","E#")'?1N.N
SET Y=-1
QUIT
+7 IF $DATA(^ASUL(6,ASUL(6,"EOQTP","E#")))'>0
SET Y=-2
QUIT
+8 SET ASUL(6,"EOQTP")=$PIECE($GET(^ASUL(6,ASUL(6,"EOQTP","E#"),0)),U)
+9 SET ASUL(6,"EOQTP","NM")=$PIECE($GET(^ASUL(6,ASUL(6,"EOQTP","E#"),0)),U,2)
+10 QUIT
