ASUJVALF ; IHS/ITSC/LMH -VALIDATE ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;;This routine is called to validate fields
S ASUV("DDSREFT")=DDSREFT D:$G(ASUSB) CKFLD^ASUJBTCH
Q
BOIDX(X,E) ;EP;BO cancel idx
;
D IDX(X,E) Q:$G(E)=1 Q:X=""
S ASUT(ASUT,"PT","REQ")=$O(^ASUMB("C",X,"")) I ASUT(ASUT,"PT","REQ")="" D Q
.D BOIDX^ASUJHELP
S X(1)=$O(^ASUMB("C",X,ASUT(ASUT,"PT","REQ"))) I X(1)="" D
.D REQ^ASULDIRR(ASUT(ASUT,"PT","REQ"))
.S ASUT(ASUT,"PT","SST")=$G(ASUL(18,"SST","E#")),ASUT(ASUT,"SST")=$G(ASUL(18,"SST")) D SST^ASUJSAVE(ASUT(ASUT,"SST"))
.S ASUT(ASUT,"PT","USR")=$G(ASUL(19,"USR","E#")),ASUT(ASUT,"USR")=$G(ASUL(19,"USR")) D USR^ASUJSAVE(ASUT(ASUT,"USR"))
Q
CAN(X,E) ;EP;Common Account #
I $G(ASUL(20,"REQ","E#"))="" D Q:Y<0
.I $G(ASUL(18,"SST","E#"))="" D CANSS^ASUJHELP
.E D
..I $G(ASUL(19,"USR","E#"))="" D CANUS^ASUJHELP
..E D
...D REQ^ASULDIRR(ASUL(19,"USR","E#")) I $G(ASUL(20,"REQ","E#"))]"" Q
...D REQ^ASUJHELP
Q:$G(E)=1
S X("CAN")=$O(^ASUL(20,ASUL(20,"REQ","E#"),2,"B",X)) I X("CAN")="" D CAN^ASUJHELP Q
S ASUL(20,"CAN","E#")=$O(^ASUL(20,ASUL(20,"REQ","E#"),2,"B",X("CAN"),"")) D CAN^ASUJSAVE(X) Q
CAT(X,E) ;EP;Category
I $G(ASUT)="" S Y=-1 S E=1 Q
I $G(ASUL(9,"ACC","E#"))="" D Q:Y<0
.I $G(ASUT(ASUT,"ACC"))]"" D ACC^ASULDIRF(ASUT(ASUT,"ACC"))
.E S Y=-1
.I Y<0 D CATAC^ASUJHELP
I $G(ASUL(3,"SOBJ","E#"))="" D Q:Y<0
.I $G(ASUT(ASUT,"SOBJ"))]"" D SSO^ASULDIRF(ASUT(ASUT,"SOBJ"))
.E S Y=-2
.I Y<0 D CATSO^ASUJHELP
D CAT^ASULDIRF(X) I Y<0 D CAT^ASUJHELP
E D
.I $E(Y)=$G(ASUL(9,"ACC","E#")),$E(Y,1,3)=$G(ASUL(3,"SOBJ","E#")) S Y=0 D CAT^ASUJSAVE(X) S:$G(ASUT("TRCD"))="4C" ASUS("CHG")=1
.E D CAT^ASUJHELP
Q
EOQ(X,E) ;EP;EOQ Type
N F S F="EOQ" I X="" D CL Q
K E
I $G(ASUSB)'=1 D
.F Z="EQQM","EQMM","EQAM" D REQ^DDSUTL(Z,"","",0) D:$G(ASUSB)'=1 UNED^DDSUTL(Z,"","",1)
.F Z=52:1:54 D PUT^DDSVAL(DIE,.DA,Z,"")
D EOQ^ASULDIRF(.X) I Y<0 D HP Q
I $G(ASUT(ASUT,"RPQ"))]""&(+$G(ASUT(ASUT,"RPQ"))=0) D Q
.I ASUL(6,"EOQTP")="P" D SV Q
.I ASUL(6,"EOQTP")="Y" D SV Q
.D EOQZR^ASUJHELP
I $G(ASUSB)=1 D Q:$G(E)>0
.I ASUL(6,"EOQTP")="B" N Q S Q=$G(ASUT(ASUT,"EOQ QM")) D EQQM(.Q,.E) Q:$G(E)>0 S ASUT(ASUT,"EOQ QM")=Q Q
.I ASUL(6,"EOQTP")="C" N Q S Q=$G(ASUT(ASUT,"EOQ MM")) D EQMM(.Q,.E) Q:$G(E)>0 S ASUT(ASUT,"EOQ MM")=Q Q
.I (ASUL(6,"EOQTP")="D")!(ASUL(6,"EOQTP")="Q")!(ASUL(6,"EOQTP")="Y") D EQAM($G(ASUT(ASUT,"EOQ AM")),.E)
E D
.I ASUL(6,"EOQTP")="B" D REQ^DDSUTL("EQQM","","",1) D UNED^DDSUTL("EQMM","","",1)
.I ASUL(6,"EOQTP")="C" D REQ^DDSUTL("EQMM","","",1) D UNED^DDSUTL("EQMM","","",1)
.I (ASUL(6,"EOQTP")="D")!(ASUL(6,"EOQTP")="Q")!(ASUL(6,"EOQTP")="Y") D REQ^DDSUTL("EQAM","","",1) D UNED^DDSUTL("EQAM","","",1)
D SV Q
EQMM(X,E) ;EP;Eoq Mo
K E N F S F="EQMM" I X?1N.N,X<13 S:$L(X)=1 X="0"_X D SV Q
D HP S E=1 Q
EQQM(X,E) ;EP;Eoq Qty
K E N F S F="EQQM" I X?1N.N,$L(X)'>4 D SV Q
D HP S E=1 Q
EQAM(X,E) ;EP;Eoq Act
K E N Z,F S Z=X,F="EQAM"
S X=$E(Z) I "0123"'[X D EQAM^ASUJHELP(1) S E=1 Q
S X=$E(Z,2) I "0456"'[X D EQAM^ASUJHELP(2) S E=1 Q
S X=$E(Z,3) I "0789"'[X D EQAM^ASUJHELP(3) S E=1 Q
S X=$E(Z,4,5) D Q:$G(E)=1
.Q:X="10" Q:X="11" Q:X="12" S E=1 D EQAM^ASUJHELP(4)
I +Z=0 D EQAM^ASUJHELP(0) S E=1 Q
S X=Z D SV Q
FPN(X,E) ;EP;Fill
K E N F S F="FPN" I X="" D CL Q
I $G(ASUT)="" D FPNTR^ASUJHELP S ASUT(ASUT,"FPN")="" Q
S ASUT(ASUT,"FPN")=X
I F[X,$G(ASUT(ASUT,"PST"))="I",ASUT(ASUT,"QTY","REQ")]"" N Z S Z=ASUT(ASUT,"QTY","REQ") D FILLSTAT^ASU3IUPD(.Z)
I $G(ASUT("TRCD"))="32",$G(ASUT)]"" I ASUT(ASUT,"PST")="" S (ASUT(ASUT,"FPN"),X)="",Y=0 Q
I $G(ASUT("TRCD"))="22",ASUT(ASUT,"PON")]"",$G(ASUS("PON"))="" N Z S Z=ASUT(ASUT,"PON") D POCK^ASU2RUPD(.Z) Q:$G(E)
I $G(ASUT(ASUT,"QTY"))>0,"FP"[X S Y=0 D SV Q
I $G(ASUT(ASUT,"QTY"))=0 S X="N" S Y=0 D SV Q
D FPNQT^ASUJHELP S ASUT(ASUT,"FPN")="" Q
IDX(X,E) ;EP;Index
K E N F S F="IDX" I X="" D CL Q
I $G(ASUT("TRCD"))="4A" D Q:$G(E)=1
.D IDXM11(.X) Q:Y D IDX11^ASUJHELP
K Y S ASUMX("IDX")=X
D DIX^ASUMDIRM(.X)
;I ASUJ'=4&(ASUJ'=5) D ;WAR 5/10/99 LOOK BELOW FOR 5D CHECK
I ASUJ'=4 D
.D DISX^ASUMDIRM(X)
;E D
;.D DIX^ASUMDIRM(.X)
I $G(ASUT("TRCD"))="4A" D
.I Y>0 D
..D IDXOF^ASUJHELP
.E D
..S (ASUMX("E#","IDX"),ASUT(ASUT,"IDX","PT"))=X
..D SV
E D
.I Y<0 D
..I Y=-9,$E(ASUT("TRCD"),2)="D" D IDXDL^ASUJHELP Q
..D IDXNF^ASUJHELP
.E D
..;I ASUT("TRCD")="5D" D DISX^ASUMDIRM(X) ;WAR 4/29/99
..D READ^ASUMXDIO I ASUMX("DELDS")]"" D IDXDL^ASUJHELP S E=1 Q
..K ASUT(ASUT,"IDX"),ASUT(ASUT,"PT","IDX")
..I $E(ASUT("TRCD"))'=4 D
...I ASUT("TRCD")="5A" D
....N Z S Z=$G(^ASUMS(ASUL(2,"STA","E#"),1,ASUMX("E#","IDX"),0))
....I Z]"",$P(Z,U)'[999999 D SIXOF^ASUJHELP
...E D
....S ASUMS("E#","IDX")=ASUMX("E#","IDX") D ^ASUMSTRD
..D SV
Q
IDXM11(X,E) ;EP;Idx # 'Mod11' Algol
N Z S:X'?6N X=$P($FN((X*.000001),",",6),".",2) I $L(X)>6!(X'?.N)!(X'>0) S Y(1)=9 S E=1 Q
S Z="000000",X=$E(Z,1,6-$L(X))_X I X=Z S E=1 Q
S Y(1)=$E(X)*6,Y(1)=Y(1)+($E(X,2)*5),Y(1)=Y(1)+($E(X,3)*4),Y(1)=Y(1)+($E(X,4)*3),Y(1)=Y(1)+($E(X,5)*2),Y(1)=Y(1)+($E(X,6)*1),Y(1)=Y(1)#11,Y=X
I Y(1)'=0 S E=1,Y=-1
K Y(1) Q
KEY(X,E) ;EP;Key
N F S F="KEY" I X="" D CL Q
D SV Q
NSN(X,E) ;EP;Natl Stk #
K E N F S F="NSN" I X="" D CL Q
S Y=-1 I X?4N,X>0 S Y=X
I $L(X)=13,X?4N.2AN.7N,$E(X,1,4)>0,$E(X,7,13)>0 S Y=X Q
I $L(X)=14,X?4N.2AN.7N.1A,$E(X,1,4)>0,$E(X,7,13)>0 S Y=X Q
I Y>0 D
.D SV S:$G(ASUT("TRCD"))="4C" ASUS("CHG")=1
E D
.I $G(ASUT("TRCD"))="4C",X="" Q
.D HP
Q
ORD(X,E) ;EP;Order #
K E N F S F="ORD" I X="" D CL Q
I X?1"M".AN D SV Q
I X?1N.12N.AP D SV Q
D HP Q
PON(X,E) ;EP;Prchs Ord #
K E N F S F="PON" I X="" D CL Q
I $E(X)=0,+X=0 D HP Q
I X'?.UNP D HP Q
I ASUT("TRCD")=22 D POCK^ASU2RUPD(.X) Q:$G(E)
D SV Q
PST(X,E) ;EP;Post
K E N F S F="PST" I X="" D CL,SV Q
I $G(ASUL(1,"AR","WHSE"))=0 S X="I",Y=0
I X="I" D Q
.N Z F Z="QTY","FPN","ISSQTY","ISSVAL" D
..D:$G(ASUSB)'=1 UNED^DDSUTL(Z,"","",0)
.D SV
D HP Q
QTY(X,E) ;EP;Qty Recvd/Issued
;IN ASUJVALF
K E N F S F="QTY" I X="" D CL Q
I $G(ASUT(ASUT,"PST"))="I",ASUT(ASUT,"QTY","REQ")="" S E=1,X="" D CL Q
S ASUT(ASUT,"QTY")=X D NUM^ASUJVALD Q:$G(E)
I ASUT("TYPE")'=1,ASUT("TRCD")'=32 D Q:$G(E)>0
.I $G(ASUT(ASUT,"IDX"))="" D Q
..S E=1 D IDXFS^ASUJHELP S X="" D CL
.I $G(ASUMS("QTY","O/H"))+(X*ASUT(ASUT,"SIGN"))<0 S E=2 D QTYCB^ASUJHELP Q
I $G(E) D HP Q
D QTYVAL
I $G(E)>0 D CL Q
D SV Q
QTYR(X,E) ;EP;Qty Req
K E N F S F="QTY" I X="" D CL Q
S (ASUT(ASUT,"QTY"),ASUT(ASUT,"QTY","REQ"))=X D NUM^ASUJVALD Q:$G(E)=1
D:ASUT(ASUT,"PST")="I" PST("I") D FILLSTAT^ASU3IUPD(.X) Q:$G(E)=""
D HP Q
RTP(X,E) ;EP;Req type
K E N F S F="RTP" I X="" D CL Q
I "12"'[X S E=1 D HP Q
D SV Q
STA(X,E) ;EP;Station
K E N F S F="STA" I X="" D CL Q
I X=$G(ASUL(2,"STA","CD")) S Y=$G(ASUL(2,"STA","E#"))
E I X=$G(ASUL(2,"STA","E#")) S X=$G(ASUL(2,"STA","CD")),Y=ASUL(2,"STA","E#")
I X'?2N!($G(Y)'?5N) D HP Q
I X]"" D STA^ASULARST(.X),SV
Q
VAL(X,E) ;EP;Value
K E N F,W S F="VAL" I X="" D CL Q
D DOL^ASUJVALD Q:$G(E)
I $G(ASUT("TRCD"))?1N.1A S W=1
E S W=0
I X<W!X>99999999.99 D VAL^ASUJHELP(W) Q
I ASUT("TYPE")'=1,ASUT("TRCD")'=32 I ASUMS("VAL","O/H")+(X*ASUT(ASUT,"SIGN"))<0 S E=3 D VALCB^ASUJHELP Q
D QTYVAL I $G(E)>0 D CL Q
D SV Q
QTYVAL ;EP;Ck Credit Qty/Val
Q:$G(E)>0 K E
Q:ASUT("TYPE")<2 Q:ASUT("TRCD")=32
I $G(ASUT(ASUT,"QTY"))]"",$G(ASUT(ASUT,"VAL"))]"" D
.N Z S Z("VAL")=ASUMS("VAL","O/H")+(ASUT(ASUT,"VAL")*ASUT(ASUT,"SIGN"))
.S Z("QTY")=ASUMS("QTY","O/H")+(ASUT(ASUT,"QTY")*ASUT(ASUT,"SIGN"))
.I Z("VAL")<0 D VALCB^ASUJHELP Q
.I Z("QTY")<0 D QTYCB^ASUJHELP Q
.I Z("VAL")=0&(Z("QTY")>0) D QTYVAL0^ASUJHELP Q
.I Z("QTY")=0&(Z("VAL")>0) D VALQTY0^ASUJHELP Q
Q
VEN(X,E) ;EP;Vendor
K E N F S F="VEN" I X="" D CL Q
D VENLKU(.X,.E) D SV:X]""
Q
VENLKU(X,E) ;EP;Vendor lookup
S DIC=9999999.11,DIC(0)="MS" D ^DIC
I Y>0 S ASUT(ASUT,"PT","VEN")=+Y,ASUT(ASUT,"VEN NM")=$P(Y,U,2)
E S ASUT(ASUT,"VEN NM")=X,ASUT(ASUT,"PT","VEN")=""
Q
VOU(X,E) ;EP;Voucher #
K E N F S F="VOU" I X="" D CL Q
I '$D(ASUK("DT","FM")) D DAYTIM^ASUUDATE S ASUF("DT")=1
I X["-" S Y("Y")=$P(X,"-"),Y("M")=$P(X,"-",2),Y("S")=$P(X,"-",3)
E S Y("Y")=$E(X,1,2),Y("M")=$E(X,3,4),Y("S")=$E(X,5,8)
I Y("M")<1!(Y("M")>12) D VOUMO^ASUJHELP Q
S Y("F")=1,Y("D")=ASUK("DT","CFY")-Y("Y") S:Y("F")=2&(Y("D")=-1) Y("D")=1
I Y("D")>Y("F")!(Y("D")<0&(ASUK("DT","CFY")'="00")) D VOUYR^ASUJHELP Q
I Y("S")'>0 D VOUSR^ASUJHELP Q
I $L(Y("S"))<4!($L(Y("S"))>4) D HP Q
S X=Y("Y")_"-"_Y("M")_"-"_Y("S") D:$G(ASUT)]"" SV K:$D(ASUF("DT")) ASUK("DT") Q
CL ;
N Z S Z="D "_F_"^ASUJCLER" X Z Q
SV ;Save
N Z S Z="D "_F_"^ASUJSAVE(.X)" X Z Q
HP ;Help
N Z S Z="D "_F_"^ASUJHELP" S:F="VAL" Z=Z_$S($G(ASUT("TRCD"))?1N.1A:"(1)",1:"(0)") X Z Q
ASUJVALF ; IHS/ITSC/LMH -VALIDATE ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;;This routine is called to validate fields
+3 SET ASUV("DDSREFT")=DDSREFT
IF $GET(ASUSB)
DO CKFLD^ASUJBTCH
+4 QUIT
BOIDX(X,E) ;EP;BO cancel idx
+1 ;
+2 DO IDX(X,E)
IF $GET(E)=1
QUIT
IF X=""
QUIT
+3 SET ASUT(ASUT,"PT","REQ")=$ORDER(^ASUMB("C",X,""))
IF ASUT(ASUT,"PT","REQ")=""
Begin DoDot:1
+4 DO BOIDX^ASUJHELP
End DoDot:1
QUIT
+5 SET X(1)=$ORDER(^ASUMB("C",X,ASUT(ASUT,"PT","REQ")))
IF X(1)=""
Begin DoDot:1
+6 DO REQ^ASULDIRR(ASUT(ASUT,"PT","REQ"))
+7 SET ASUT(ASUT,"PT","SST")=$GET(ASUL(18,"SST","E#"))
SET ASUT(ASUT,"SST")=$GET(ASUL(18,"SST"))
DO SST^ASUJSAVE(ASUT(ASUT,"SST"))
+8 SET ASUT(ASUT,"PT","USR")=$GET(ASUL(19,"USR","E#"))
SET ASUT(ASUT,"USR")=$GET(ASUL(19,"USR"))
DO USR^ASUJSAVE(ASUT(ASUT,"USR"))
End DoDot:1
+9 QUIT
CAN(X,E) ;EP;Common Account #
+1 IF $GET(ASUL(20,"REQ","E#"))=""
Begin DoDot:1
+2 IF $GET(ASUL(18,"SST","E#"))=""
DO CANSS^ASUJHELP
+3 IF '$TEST
Begin DoDot:2
+4 IF $GET(ASUL(19,"USR","E#"))=""
DO CANUS^ASUJHELP
+5 IF '$TEST
Begin DoDot:3
+6 DO REQ^ASULDIRR(ASUL(19,"USR","E#"))
IF $GET(ASUL(20,"REQ","E#"))]""
QUIT
+7 DO REQ^ASUJHELP
End DoDot:3
End DoDot:2
End DoDot:1
IF Y<0
QUIT
+8 IF $GET(E)=1
QUIT
+9 SET X("CAN")=$ORDER(^ASUL(20,ASUL(20,"REQ","E#"),2,"B",X))
IF X("CAN")=""
DO CAN^ASUJHELP
QUIT
+10 SET ASUL(20,"CAN","E#")=$ORDER(^ASUL(20,ASUL(20,"REQ","E#"),2,"B",X("CAN"),""))
DO CAN^ASUJSAVE(X)
QUIT
CAT(X,E) ;EP;Category
+1 IF $GET(ASUT)=""
SET Y=-1
SET E=1
QUIT
+2 IF $GET(ASUL(9,"ACC","E#"))=""
Begin DoDot:1
+3 IF $GET(ASUT(ASUT,"ACC"))]""
DO ACC^ASULDIRF(ASUT(ASUT,"ACC"))
+4 IF '$TEST
SET Y=-1
+5 IF Y<0
DO CATAC^ASUJHELP
End DoDot:1
IF Y<0
QUIT
+6 IF $GET(ASUL(3,"SOBJ","E#"))=""
Begin DoDot:1
+7 IF $GET(ASUT(ASUT,"SOBJ"))]""
DO SSO^ASULDIRF(ASUT(ASUT,"SOBJ"))
+8 IF '$TEST
SET Y=-2
+9 IF Y<0
DO CATSO^ASUJHELP
End DoDot:1
IF Y<0
QUIT
+10 DO CAT^ASULDIRF(X)
IF Y<0
DO CAT^ASUJHELP
+11 IF '$TEST
Begin DoDot:1
+12 IF $EXTRACT(Y)=$GET(ASUL(9,"ACC","E#"))
IF $EXTRACT(Y,1,3)=$GET(ASUL(3,"SOBJ","E#"))
SET Y=0
DO CAT^ASUJSAVE(X)
IF $GET(ASUT("TRCD"))="4C"
SET ASUS("CHG")=1
+13 IF '$TEST
DO CAT^ASUJHELP
End DoDot:1
+14 QUIT
EOQ(X,E) ;EP;EOQ Type
+1 NEW F
SET F="EOQ"
IF X=""
DO CL
QUIT
+2 KILL E
+3 IF $GET(ASUSB)'=1
Begin DoDot:1
+4 FOR Z="EQQM","EQMM","EQAM"
DO REQ^DDSUTL(Z,"","",0)
IF $GET(ASUSB)'=1
DO UNED^DDSUTL(Z,"","",1)
+5 FOR Z=52:1:54
DO PUT^DDSVAL(DIE,.DA,Z,"")
End DoDot:1
+6 DO EOQ^ASULDIRF(.X)
IF Y<0
DO HP
QUIT
+7 IF $GET(ASUT(ASUT,"RPQ"))]""&(+$GET(ASUT(ASUT,"RPQ"))=0)
Begin DoDot:1
+8 IF ASUL(6,"EOQTP")="P"
DO SV
QUIT
+9 IF ASUL(6,"EOQTP")="Y"
DO SV
QUIT
+10 DO EOQZR^ASUJHELP
End DoDot:1
QUIT
+11 IF $GET(ASUSB)=1
Begin DoDot:1
+12 IF ASUL(6,"EOQTP")="B"
NEW Q
SET Q=$GET(ASUT(ASUT,"EOQ QM"))
DO EQQM(.Q,.E)
IF $GET(E)>0
QUIT
SET ASUT(ASUT,"EOQ QM")=Q
QUIT
+13 IF ASUL(6,"EOQTP")="C"
NEW Q
SET Q=$GET(ASUT(ASUT,"EOQ MM"))
DO EQMM(.Q,.E)
IF $GET(E)>0
QUIT
SET ASUT(ASUT,"EOQ MM")=Q
QUIT
+14 IF (ASUL(6,"EOQTP")="D")!(ASUL(6,"EOQTP")="Q")!(ASUL(6,"EOQTP")="Y")
DO EQAM($GET(ASUT(ASUT,"EOQ AM")),.E)
End DoDot:1
IF $GET(E)>0
QUIT
+15 IF '$TEST
Begin DoDot:1
+16 IF ASUL(6,"EOQTP")="B"
DO REQ^DDSUTL("EQQM","","",1)
DO UNED^DDSUTL("EQMM","","",1)
+17 IF ASUL(6,"EOQTP")="C"
DO REQ^DDSUTL("EQMM","","",1)
DO UNED^DDSUTL("EQMM","","",1)
+18 IF (ASUL(6,"EOQTP")="D")!(ASUL(6,"EOQTP")="Q")!(ASUL(6,"EOQTP")="Y")
DO REQ^DDSUTL("EQAM","","",1)
DO UNED^DDSUTL("EQAM","","",1)
End DoDot:1
+19 DO SV
QUIT
EQMM(X,E) ;EP;Eoq Mo
+1 KILL E
NEW F
SET F="EQMM"
IF X?1N.N
IF X<13
IF $LENGTH(X)=1
SET X="0"_X
DO SV
QUIT
+2 DO HP
SET E=1
QUIT
EQQM(X,E) ;EP;Eoq Qty
+1 KILL E
NEW F
SET F="EQQM"
IF X?1N.N
IF $LENGTH(X)'>4
DO SV
QUIT
+2 DO HP
SET E=1
QUIT
EQAM(X,E) ;EP;Eoq Act
+1 KILL E
NEW Z,F
SET Z=X
SET F="EQAM"
+2 SET X=$EXTRACT(Z)
IF "0123"'[X
DO EQAM^ASUJHELP(1)
SET E=1
QUIT
+3 SET X=$EXTRACT(Z,2)
IF "0456"'[X
DO EQAM^ASUJHELP(2)
SET E=1
QUIT
+4 SET X=$EXTRACT(Z,3)
IF "0789"'[X
DO EQAM^ASUJHELP(3)
SET E=1
QUIT
+5 SET X=$EXTRACT(Z,4,5)
Begin DoDot:1
+6 IF X="10"
QUIT
IF X="11"
QUIT
IF X="12"
QUIT
SET E=1
DO EQAM^ASUJHELP(4)
End DoDot:1
IF $GET(E)=1
QUIT
+7 IF +Z=0
DO EQAM^ASUJHELP(0)
SET E=1
QUIT
+8 SET X=Z
DO SV
QUIT
FPN(X,E) ;EP;Fill
+1 KILL E
NEW F
SET F="FPN"
IF X=""
DO CL
QUIT
+2 IF $GET(ASUT)=""
DO FPNTR^ASUJHELP
SET ASUT(ASUT,"FPN")=""
QUIT
+3 SET ASUT(ASUT,"FPN")=X
+4 IF F[X
IF $GET(ASUT(ASUT,"PST"))="I"
IF ASUT(ASUT,"QTY","REQ")]""
NEW Z
SET Z=ASUT(ASUT,"QTY","REQ")
DO FILLSTAT^ASU3IUPD(.Z)
+5 IF $GET(ASUT("TRCD"))="32"
IF $GET(ASUT)]""
IF ASUT(ASUT,"PST")=""
SET (ASUT(ASUT,"FPN"),X)=""
SET Y=0
QUIT
+6 IF $GET(ASUT("TRCD"))="22"
IF ASUT(ASUT,"PON")]""
IF $GET(ASUS("PON"))=""
NEW Z
SET Z=ASUT(ASUT,"PON")
DO POCK^ASU2RUPD(.Z)
IF $GET(E)
QUIT
+7 IF $GET(ASUT(ASUT,"QTY"))>0
IF "FP"[X
SET Y=0
DO SV
QUIT
+8 IF $GET(ASUT(ASUT,"QTY"))=0
SET X="N"
SET Y=0
DO SV
QUIT
+9 DO FPNQT^ASUJHELP
SET ASUT(ASUT,"FPN")=""
QUIT
IDX(X,E) ;EP;Index
+1 KILL E
NEW F
SET F="IDX"
IF X=""
DO CL
QUIT
+2 IF $GET(ASUT("TRCD"))="4A"
Begin DoDot:1
+3 DO IDXM11(.X)
IF Y
QUIT
DO IDX11^ASUJHELP
End DoDot:1
IF $GET(E)=1
QUIT
+4 KILL Y
SET ASUMX("IDX")=X
+5 DO DIX^ASUMDIRM(.X)
+6 ;I ASUJ'=4&(ASUJ'=5) D ;WAR 5/10/99 LOOK BELOW FOR 5D CHECK
+7 IF ASUJ'=4
Begin DoDot:1
+8 DO DISX^ASUMDIRM(X)
End DoDot:1
+9 ;E D
+10 ;.D DIX^ASUMDIRM(.X)
+11 IF $GET(ASUT("TRCD"))="4A"
Begin DoDot:1
+12 IF Y>0
Begin DoDot:2
+13 DO IDXOF^ASUJHELP
End DoDot:2
+14 IF '$TEST
Begin DoDot:2
+15 SET (ASUMX("E#","IDX"),ASUT(ASUT,"IDX","PT"))=X
+16 DO SV
End DoDot:2
End DoDot:1
+17 IF '$TEST
Begin DoDot:1
+18 IF Y<0
Begin DoDot:2
+19 IF Y=-9
IF $EXTRACT(ASUT("TRCD"),2)="D"
DO IDXDL^ASUJHELP
QUIT
+20 DO IDXNF^ASUJHELP
End DoDot:2
+21 IF '$TEST
Begin DoDot:2
+22 ;I ASUT("TRCD")="5D" D DISX^ASUMDIRM(X) ;WAR 4/29/99
+23 DO READ^ASUMXDIO
IF ASUMX("DELDS")]""
DO IDXDL^ASUJHELP
SET E=1
QUIT
+24 KILL ASUT(ASUT,"IDX"),ASUT(ASUT,"PT","IDX")
+25 IF $EXTRACT(ASUT("TRCD"))'=4
Begin DoDot:3
+26 IF ASUT("TRCD")="5A"
Begin DoDot:4
+27 NEW Z
SET Z=$GET(^ASUMS(ASUL(2,"STA","E#"),1,ASUMX("E#","IDX"),0))
+28 IF Z]""
IF $PIECE(Z,U)'[999999
DO SIXOF^ASUJHELP
End DoDot:4
+29 IF '$TEST
Begin DoDot:4
+30 SET ASUMS("E#","IDX")=ASUMX("E#","IDX")
DO ^ASUMSTRD
End DoDot:4
End DoDot:3
+31 DO SV
End DoDot:2
End DoDot:1
+32 QUIT
IDXM11(X,E) ;EP;Idx # 'Mod11' Algol
+1 NEW Z
IF X'?6N
SET X=$PIECE($FNUMBER((X*.000001),",",6),".",2)
IF $LENGTH(X)>6!(X'?.N)!(X'>0)
SET Y(1)=9
SET E=1
QUIT
+2 SET Z="000000"
SET X=$EXTRACT(Z,1,6-$LENGTH(X))_X
IF X=Z
SET E=1
QUIT
+3 SET Y(1)=$EXTRACT(X)*6
SET Y(1)=Y(1)+($EXTRACT(X,2)*5)
SET Y(1)=Y(1)+($EXTRACT(X,3)*4)
SET Y(1)=Y(1)+($EXTRACT(X,4)*3)
SET Y(1)=Y(1)+($EXTRACT(X,5)*2)
SET Y(1)=Y(1)+($EXTRACT(X,6)*1)
SET Y(1)=Y(1)#11
SET Y=X
+4 IF Y(1)'=0
SET E=1
SET Y=-1
+5 KILL Y(1)
QUIT
KEY(X,E) ;EP;Key
+1 NEW F
SET F="KEY"
IF X=""
DO CL
QUIT
+2 DO SV
QUIT
NSN(X,E) ;EP;Natl Stk #
+1 KILL E
NEW F
SET F="NSN"
IF X=""
DO CL
QUIT
+2 SET Y=-1
IF X?4N
IF X>0
SET Y=X
+3 IF $LENGTH(X)=13
IF X?4N.2AN.7N
IF $EXTRACT(X,1,4)>0
IF $EXTRACT(X,7,13)>0
SET Y=X
QUIT
+4 IF $LENGTH(X)=14
IF X?4N.2AN.7N.1A
IF $EXTRACT(X,1,4)>0
IF $EXTRACT(X,7,13)>0
SET Y=X
QUIT
+5 IF Y>0
Begin DoDot:1
+6 DO SV
IF $GET(ASUT("TRCD"))="4C"
SET ASUS("CHG")=1
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 IF $GET(ASUT("TRCD"))="4C"
IF X=""
QUIT
+9 DO HP
End DoDot:1
+10 QUIT
ORD(X,E) ;EP;Order #
+1 KILL E
NEW F
SET F="ORD"
IF X=""
DO CL
QUIT
+2 IF X?1"M".AN
DO SV
QUIT
+3 IF X?1N.12N.AP
DO SV
QUIT
+4 DO HP
QUIT
PON(X,E) ;EP;Prchs Ord #
+1 KILL E
NEW F
SET F="PON"
IF X=""
DO CL
QUIT
+2 IF $EXTRACT(X)=0
IF +X=0
DO HP
QUIT
+3 IF X'?.UNP
DO HP
QUIT
+4 IF ASUT("TRCD")=22
DO POCK^ASU2RUPD(.X)
IF $GET(E)
QUIT
+5 DO SV
QUIT
PST(X,E) ;EP;Post
+1 KILL E
NEW F
SET F="PST"
IF X=""
DO CL
DO SV
QUIT
+2 IF $GET(ASUL(1,"AR","WHSE"))=0
SET X="I"
SET Y=0
+3 IF X="I"
Begin DoDot:1
+4 NEW Z
FOR Z="QTY","FPN","ISSQTY","ISSVAL"
Begin DoDot:2
+5 IF $GET(ASUSB)'=1
DO UNED^DDSUTL(Z,"","",0)
End DoDot:2
+6 DO SV
End DoDot:1
QUIT
+7 DO HP
QUIT
QTY(X,E) ;EP;Qty Recvd/Issued
+1 ;IN ASUJVALF
+2 KILL E
NEW F
SET F="QTY"
IF X=""
DO CL
QUIT
+3 IF $GET(ASUT(ASUT,"PST"))="I"
IF ASUT(ASUT,"QTY","REQ")=""
SET E=1
SET X=""
DO CL
QUIT
+4 SET ASUT(ASUT,"QTY")=X
DO NUM^ASUJVALD
IF $GET(E)
QUIT
+5 IF ASUT("TYPE")'=1
IF ASUT("TRCD")'=32
Begin DoDot:1
+6 IF $GET(ASUT(ASUT,"IDX"))=""
Begin DoDot:2
+7 SET E=1
DO IDXFS^ASUJHELP
SET X=""
DO CL
End DoDot:2
QUIT
+8 IF $GET(ASUMS("QTY","O/H"))+(X*ASUT(ASUT,"SIGN"))<0
SET E=2
DO QTYCB^ASUJHELP
QUIT
End DoDot:1
IF $GET(E)>0
QUIT
+9 IF $GET(E)
DO HP
QUIT
+10 DO QTYVAL
+11 IF $GET(E)>0
DO CL
QUIT
+12 DO SV
QUIT
QTYR(X,E) ;EP;Qty Req
+1 KILL E
NEW F
SET F="QTY"
IF X=""
DO CL
QUIT
+2 SET (ASUT(ASUT,"QTY"),ASUT(ASUT,"QTY","REQ"))=X
DO NUM^ASUJVALD
IF $GET(E)=1
QUIT
+3 IF ASUT(ASUT,"PST")="I"
DO PST("I")
DO FILLSTAT^ASU3IUPD(.X)
IF $GET(E)=""
QUIT
+4 DO HP
QUIT
RTP(X,E) ;EP;Req type
+1 KILL E
NEW F
SET F="RTP"
IF X=""
DO CL
QUIT
+2 IF "12"'[X
SET E=1
DO HP
QUIT
+3 DO SV
QUIT
STA(X,E) ;EP;Station
+1 KILL E
NEW F
SET F="STA"
IF X=""
DO CL
QUIT
+2 IF X=$GET(ASUL(2,"STA","CD"))
SET Y=$GET(ASUL(2,"STA","E#"))
+3 IF '$TEST
IF X=$GET(ASUL(2,"STA","E#"))
SET X=$GET(ASUL(2,"STA","CD"))
SET Y=ASUL(2,"STA","E#")
+4 IF X'?2N!($GET(Y)'?5N)
DO HP
QUIT
+5 IF X]""
DO STA^ASULARST(.X)
DO SV
+6 QUIT
VAL(X,E) ;EP;Value
+1 KILL E
NEW F,W
SET F="VAL"
IF X=""
DO CL
QUIT
+2 DO DOL^ASUJVALD
IF $GET(E)
QUIT
+3 IF $GET(ASUT("TRCD"))?1N.1A
SET W=1
+4 IF '$TEST
SET W=0
+5 IF X<W!X>99999999.99
DO VAL^ASUJHELP(W)
QUIT
+6 IF ASUT("TYPE")'=1
IF ASUT("TRCD")'=32
IF ASUMS("VAL","O/H")+(X*ASUT(ASUT,"SIGN"))<0
SET E=3
DO VALCB^ASUJHELP
QUIT
+7 DO QTYVAL
IF $GET(E)>0
DO CL
QUIT
+8 DO SV
QUIT
QTYVAL ;EP;Ck Credit Qty/Val
+1 IF $GET(E)>0
QUIT
KILL E
+2 IF ASUT("TYPE")<2
QUIT
IF ASUT("TRCD")=32
QUIT
+3 IF $GET(ASUT(ASUT,"QTY"))]""
IF $GET(ASUT(ASUT,"VAL"))]""
Begin DoDot:1
+4 NEW Z
SET Z("VAL")=ASUMS("VAL","O/H")+(ASUT(ASUT,"VAL")*ASUT(ASUT,"SIGN"))
+5 SET Z("QTY")=ASUMS("QTY","O/H")+(ASUT(ASUT,"QTY")*ASUT(ASUT,"SIGN"))
+6 IF Z("VAL")<0
DO VALCB^ASUJHELP
QUIT
+7 IF Z("QTY")<0
DO QTYCB^ASUJHELP
QUIT
+8 IF Z("VAL")=0&(Z("QTY")>0)
DO QTYVAL0^ASUJHELP
QUIT
+9 IF Z("QTY")=0&(Z("VAL")>0)
DO VALQTY0^ASUJHELP
QUIT
End DoDot:1
+10 QUIT
VEN(X,E) ;EP;Vendor
+1 KILL E
NEW F
SET F="VEN"
IF X=""
DO CL
QUIT
+2 DO VENLKU(.X,.E)
IF X]""
DO SV
+3 QUIT
VENLKU(X,E) ;EP;Vendor lookup
+1 SET DIC=9999999.11
SET DIC(0)="MS"
DO ^DIC
+2 IF Y>0
SET ASUT(ASUT,"PT","VEN")=+Y
SET ASUT(ASUT,"VEN NM")=$PIECE(Y,U,2)
+3 IF '$TEST
SET ASUT(ASUT,"VEN NM")=X
SET ASUT(ASUT,"PT","VEN")=""
+4 QUIT
VOU(X,E) ;EP;Voucher #
+1 KILL E
NEW F
SET F="VOU"
IF X=""
DO CL
QUIT
+2 IF '$DATA(ASUK("DT","FM"))
DO DAYTIM^ASUUDATE
SET ASUF("DT")=1
+3 IF X["-"
SET Y("Y")=$PIECE(X,"-")
SET Y("M")=$PIECE(X,"-",2)
SET Y("S")=$PIECE(X,"-",3)
+4 IF '$TEST
SET Y("Y")=$EXTRACT(X,1,2)
SET Y("M")=$EXTRACT(X,3,4)
SET Y("S")=$EXTRACT(X,5,8)
+5 IF Y("M")<1!(Y("M")>12)
DO VOUMO^ASUJHELP
QUIT
+6 SET Y("F")=1
SET Y("D")=ASUK("DT","CFY")-Y("Y")
IF Y("F")=2&(Y("D")=-1)
SET Y("D")=1
+7 IF Y("D")>Y("F")!(Y("D")<0&(ASUK("DT","CFY")'="00"))
DO VOUYR^ASUJHELP
QUIT
+8 IF Y("S")'>0
DO VOUSR^ASUJHELP
QUIT
+9 IF $LENGTH(Y("S"))<4!($LENGTH(Y("S"))>4)
DO HP
QUIT
+10 SET X=Y("Y")_"-"_Y("M")_"-"_Y("S")
IF $GET(ASUT)]""
DO SV
IF $DATA(ASUF("DT"))
KILL ASUK("DT")
QUIT
CL ;
+1 NEW Z
SET Z="D "_F_"^ASUJCLER"
XECUTE Z
QUIT
SV ;Save
+1 NEW Z
SET Z="D "_F_"^ASUJSAVE(.X)"
XECUTE Z
QUIT
HP ;Help
+1 NEW Z
SET Z="D "_F_"^ASUJHELP"
IF F="VAL"
SET Z=Z_$SELECT($GET(ASUT("TRCD"))?1N.1A:"(1)",1:"(0)")
XECUTE Z
QUIT
