ASU3IUPD ; IHS/ITSC/LMH -POST REPLENISHMENT ISS TRANS ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine provides logic to post (process) ISSUE transactions
;to the SAMS master files.
Q:$G(DDSERROR)>0 Q:$G(ASUT(ASUT,"QTY","REQ"))=""
S ASUF("SV")=2 D SETMOIS,UPDATE,^ASUMKBPS,^ASUMYDPS
G EXIT
RVIS ;EP ;REVERSAL ISSUE
Q:$G(DDSERROR)>0
S:'$D(ASUT(ASUT,"QTY","ISS")) ASUT(ASUT,"QTY","ISS")=$G(ASUT(ASUT,"QTY"))
S ASUF("SV")=2 D SETMOIS,UPDATE
D:ASUT("TRCD")="3K" ^ASUMKBPS,^ASUMYDPS D:ASUT("TRCD")="3L" ^ASUMYDPS
EXIT ;
;K ASUT,ASUF("SV") D PSTKL^ASUCOKIL ;WAR 5/11/99 INCLUDED IF STMT
I '$D(ASU("DA CNT")) K ASUT,ASUF("SV") D PSTKL^ASUCOKIL
Q
TXFIS ;EP ;TRANSFER ISSUE
Q:$G(DDSERROR)>0
S:$G(ASUT(ASUT,"QTY","ISS"))="" ASUT(ASUT,"QTY","ISS")=$G(ASUT(ASUT,"QTY"))
S:$G(DDSREFT)="" DDSREFT=$G(ASUV("DDSREFT"))
;D SETMOIS
D UPDATE Q
SETMOIS ;EP;
S:$G(DDSREFT)="" DDSREFT=$G(ASUV("DDSREFT"))
N X
;Note the following date manipulation should pass requirement for Y2K
;two digit voucher year greater than 85 = 1900+yr all others, 2000+yr
;beginning Y2K fix
;I $E(ASUT("TRCD"),2)?1N S X=$S($P(ASUT(ASUT,"VOU"),"-")>85:2,1:3)_$P(ASUT(ASUT,"VOU"),"-")_$P(ASUT(ASUT,"VOU"),"-",2)_"00" S:X>ASUMS("LSTISS") ASUMS("LSTISS")=X
I $E(ASUT("TRCD"),2)?1N D ;Y2000
.S X=$P(ASUT(ASUT,"VOU"),"-",2)_$P(ASUT(ASUT,"VOU"),"-") ;Y2000
.D START^ASUUY2K(.X,1,U,"N") ;Y2000
.S X=Y ;Y2000
.S:X>ASUMS("LSTISS") ASUMS("LSTISS")=X ;Y2000
;end Y2K fix block
S X=$P(ASUT(ASUT,"VOU"),"-",2),Y=(ASUT(ASUT,"SIGN")*-1) S:$E(X)=0 X=$E(X,2)
S ASUMS("DMD","CALL",X)=$G(ASUMS("DMD","CALL",X))+Y
S:$G(ASUT(ASUT,"QTY","ISS"))="" ASUT(ASUT,"QTY","ISS")=$G(ASUT(ASUT,"QTY"))
S ASUMS("DMD","QTY",X)=$G(ASUMS("DMD","QTY",X))+(ASUT(ASUT,"QTY","ISS")*Y)
Q
UPDATE ;EP;
S ASUMS("VAL","O/H")=ASUMS("VAL","O/H")+(ASUT(ASUT,"VAL")*ASUT(ASUT,"SIGN"))
S ASUMS("QTY","O/H")=ASUMS("QTY","O/H")+(ASUT(ASUT,"QTY","ISS")*ASUT(ASUT,"SIGN"))
S ASUS("ADD")=2 D ^ASUMSTWR K ASUS("ADD")
S:ASUT(ASUT,"FPN")="B" ASUT(ASUT,"FPN")="N"
D ^ASUJHIST ;Move transaction to History file
Q
FILLSTAT(X) ;EP ;CALCULATE FILL STATUS (F=FULL, P=PART, N=NONE)
; X=Quantity Requested
Q:$E(ASUT("TRCD"),2)?1A
N Z
S (ASUT(ASUT,"B/O"),ASUT(ASUT,"FPN"),ASUT(ASUT,"QTY","ADJ"))=""
S ASUF("ERR")=0
;WAR 5/7/99S ASUF("ERR")=0,ASUT(ASUT,"B/O")="",ASUT(ASUT,"QTY","ADJ")=""
I $G(ASUT(ASUT,"PST"))="I" D
.I X=0!(ASUMS("QTY","O/H")=0) D
..I ASUMS("QTY","O/H")'>0,X>0 D
...S ASUF("ERR")=1,DDSERROR=1,Z="No Quantity On Hand - Issuing "_X_" would cause a credit balance"
...S ASUT(ASUT,"FPN")="",ASUT(ASUT,"QTY","ISS")=""
...D HLP^ASUJHELP(Z),QTY^ASUJCLER,QTYI^ASUJSAVE(ASUT(ASUT,"QTY","ISS")),FPN^ASUJSAVE(ASUT(ASUT,"FPN"))
..S (ASUT(ASUT,"QTY","ISS"),ASUT(ASUT,"QTY"),ASUT(ASUT,"QTY","REQ"))=0
..S ASUT(ASUT,"FPN")="N",ASUT(ASUT,"VAL")=0
.E D
..I ASUMS("QTY","O/H")<X D Q
...S ASUF("ERR")=1,DDSERROR=1,Z="Not enough Quantity On Hand - Issuing "_X_" would cause a credit balance"
...S ASUT(ASUT,"FPN")="",ASUT(ASUT,"QTY","ISS")=""
...D HLP^ASUJHELP(Z),QTY^ASUJCLER,QTYI^ASUJSAVE(ASUT(ASUT,"QTY","ISS")),FPN^ASUJSAVE(ASUT(ASUT,"FPN"))
..S ASUT(ASUT,"FPN")=$G(ASUT(ASUT,"FPN")) S:ASUT(ASUT,"FPN")="" ASUT(ASUT,"FPN")="F" ;DFM 4/7/99
..I $G(ASUT(ASUT,"FPN"))="F" D
...S ASUT(ASUT,"QTY","ISS")=X S (Z,Y)="" D MSUNCST(.Z,.Y) S ASUT(ASUT,"VAL")=Y
..E D
...I $G(ASUT(ASUT,"FPN"))="P" D
....I ASUT(ASUT,"QTY","ISS")]"" D
.....S (Z,Y)="" D MSUNCST(.Z,.Y) S ASUT(ASUT,"VAL")=Y
....E D
.....S ASUT(ASUT,"QTY","ISS")=X
.....S (Z,Y)="" D MSUNCST(.Z,.Y) S ASUT(ASUT,"VAL")=Y
E D
.I ASUT(ASUT,"FPN")="" D
..S ASUT(ASUT,"QTY","ADJ")="",ASUS("QTYAJ")=0
..S Z=ASUT(ASUT,"QTY","REQ"),Y="" D SPQ^ASU3ISQA(.Z,.Y) S ASUT(ASUT,"QTY","ISS")=Y
..I ASUT(ASUT,"QTY","ISS")'=ASUT(ASUT,"QTY","REQ") D
...S Z="Requested quantity adjusted to comply with Standard Pack Quantity" D HLP^ASUJHELP(Z) ;DFM P1 9/1/98 WAR 5/3/99
...S ASUT(ASUT,"QTY","ADJ")="A",ASUS("QTYAJ")=1
..E D
...S ASUT(ASUT,"QTY","ADJ")="",ASUS("QTYAJ")=0
.;I ASUMS("QTY","O/H")=ASUT(ASUT,"QTY","ISS")!(ASUMS("QTY","O/H")>ASUT(ASUT,"QTY","ISS")) D
.I ASUMS("QTY","O/H")'<ASUT(ASUT,"QTY","ISS") D ;WAR 5/5/99
..S ASUT(ASUT,"FPN")="F"
.E D
..I ASUT("TRCD")'=32 D Q
...S ASUF("ERR")=1,DDSERROR=1
...S Z="Not enough Quantity On Hand - would cause credit balance" D HLP^ASUJHELP(Z) ;DFM P1 9/1/98 WAR 5/3/99
...D QTY^ASUJCLER
..;I ASUMS("QTY","O/H")=0!(ASUMS("QTY","O/H")<0) D
..I ASUMS("QTY","O/H")'>0 D ;WAR 5/5/99
...S ASUT(ASUT,"FPN")="N",ASUT(ASUT,"QTY","ISS")=0
..E D
...S ASUT(ASUT,"FPN")="P"
...S ASUT(ASUT,"QTY","ISS")=ASUMS("QTY","O/H")
.I ASUT(ASUT,"FPN")="N" S ASUF("ERR")=0 D ;Q:ASUF("ERR")
..;D QTYREQ^ASUJHELP ;WAR 5/5/99 and the next 5 lines
..S Z="No Quantity On Hand - will attempt to Backorder" D HLP^ASUJHELP(Z) ;DFM P1 9/1/98 WAR 5/3/99
..S X=ASUT(ASUT,"QTY","REQ")
..N Q S Q=X D BKORDR(.Q)
..I ASUF("ERR") S:ASUF("ERR")=7 ASUT(ASUT,"FPN")="B" S ASUT(ASUT,"QTY","ISS")=0,ASUT(ASUT,"VAL")=0 D QTY^ASUJCLER,VAL^ASUJCLER Q
..S ASUV("CST/U")=0,ASUMS("D/O","QTY")=Q
.I ASUT(ASUT,"FPN")="P" D
..;D QTYREQ^ASUJHELP ;WAR 5/5/99 and next 10 lines
..S X=ASUT(ASUT,"QTY","REQ")-ASUMS("QTY","O/H"),ASUT(ASUT,"QTY","ISS")=ASUMS("QTY","O/H")
..S Z="Not enough Quantity to fill order - will attempt to Backorder "_X D HLP^ASUJHELP(Z) ;DFM P1 9/1/98 WAR 5/3/99
..N Q S Q=X,ASUF("ERR")=0 D BKORDR(.Q)
..I ASUF("ERR") D VAL^ASUJCLER,QTY^ASUJCLER Q
..S ASUT(ASUT,"B/O")="B"
..S ASUMS("D/O","QTY")=ASUMS("D/O","QTY")+Q
..S:'$D(ASUT(ASUT,"PON")) ASUT(ASUT,"PON")=""
..S:'$D(ASUT(ASUT,"SUI")) ASUT(ASUT,"SUI")=""
..S:'$D(ASUT(ASUT,"SRC")) ASUT(ASUT,"SRC")=""
..S:'$D(ASUT(ASUT,"REQ TYP")) ASUT(ASUT,"REQ TYP")=""
.I ASUMS("QTY","O/H")'>0 D
..S ASUT(ASUT,"VAL")=0 D VAL^ASUJCLER
.E D
..I ASUT(ASUT,"FPN")'="N" S (Z,Y)="" D MSUNCST(.Z,.Y) S ASUT(ASUT,"VAL")=Y
S:$G(DA)="" DA=ASUHDA
S DDSERROR="",Z=ASUT(ASUT,"VAL") D VAL^ASUJVALF(.Z,.DDSERROR)
S Z=ASUT(ASUT,"FPN") D FPN^ASUJSAVE(.Z)
Q:"2P37"[ASUT("TRCD")
S DDSERROR="",Z=ASUT(ASUT,"QTY","ISS") D EN^ASUJVALD(.Z,.DDSERROR,"QTYI","N")
Q
MSUNCST(X,Y) ;EP; -Calculate Unit cost for issue from Station Master QTY & VAL
N Z S Z=ASUT(ASUT,"QTY","ISS") D UCSVAL(.Z,.X,.Y)
I ASUMS("QTY","O/H")-ASUT(ASUT,"QTY","ISS")=0 S Y=ASUMS("VAL","O/H")
I Y>ASUMS("VAL","O/H") S Y=ASUMS("VAL","O/H")
Q
UCSVAL(Z,X,Y) ;EP
;Z - Quantity
;X - Returns Unit Cost
;Y - Returns value of (Unit cost X Quantity)
S X=$S(ASUMS("VAL","O/H")=0!(ASUMS("VAL","O/H")=""):0,ASUMS("QTY","O/H")=0!(ASUMS("QTY","O/H")=""):0,1:$FN((ASUMS("VAL","O/H")/ASUMS("QTY","O/H")),"",2))
I $G(ASUT("TRCD"))=27 S:X=0 X=$G(ASUMS("LPP"))
I $G(ASUT("TRCD"))=31 S:X=0 X=$G(ASUMS("LPP"))
S Y=+$G(X)*(+$G(Z)),ASUMB("UCS")=$G(X)
Q
BKORDR(Q) ;CREATE ISSUE BACKORDER
;Q - QUANTITY TO BACKORDER
S ASUVQBO=Q
I $G(ASUT(ASUT,"SST"))="" D Q
.S Z="Can't Backorder - No Sub Station Code" D HLP^ASUJHELP(Z) S ASUF("ERR")=1 ;DFM P1 9/1/98
I $G(ASUT(ASUT,"USR"))="" D Q
.S Z="Can't Backorder - No User Code" D HLP^ASUJHELP(Z) S ASUF("ERR")=2 ;DFM P1 9/1/98
S ASUMB("E#","USR")=$G(ASUT(ASUT,"PT","USR")),ASUMB("E#","REQ")=$G(ASUT(ASUT,"PT","REQ")),ASUMB("E#","IDX")=$G(ASUT(ASUT,"PT","IDX"))
S ASUF("ERR")=0
;D REQ^ASUMBOIO(ASUMB("E#","USR")) ;Lookup REQ in Backorder master
D REQ^ASUMBOIO(ASUMB("E#","REQ")) ;WAR 5/4/99 line above is incorrect
I Y<1 D Q:ASUF("ERR")
.I Y=0 D ;No backorders on file for Requsitioner
..D REQADD^ASUMBOIO(ASUMB("E#","REQ")) ;Add REQ to Backorder master
..N Z I Y<0 D ;Error in add
...S Z="Backorder for Requsitioner : "_ASUMB("E#","REQ")_" not created - error code="_Y D HLP^ASUJHELP(Z) S ASUF("ERR")=3
.E D ;Error -requsitioner not in lookup table
..S Z="Requsitioner : "_ASUMB("E#","REQ")_" not valid - error code="_Y D HLP^ASUJHELP(Z) S ASUF("ERR")=4
N Z S Z(0)=ASUT("TRCD") S ASUT("TRCD")=31 D UCSVAL(.ASUVQBO,.ASUVUCS,.ASUVAL) S ASUT("TRCD")=Z(0) S ASUMB("VAL")=ASUVAL,ASUMB("UCS")=ASUVUCS,ASUMB("QTYB/O")=ASUVQBO
K ASUVAL,ASUVUCS,ASUVQBO
S ASUMB("QTYISS")=ASUT(ASUT,"QTY","ISS")
D IDX^ASUMBOIO(ASUMB("E#","IDX")) ;Lookup IDX in Backorder master
N Z I Y<1 D Q:$D(ASUM("ERR"))
.I Y=0 D ;No backorder on file for this item for this requsitioner
..D IDXADD^ASUMBOIO(ASUMB("E#","IDX")) ;Add IDX to Backorder master
..I Y<0 D ;Error Index master not on file
...S Z="Index : "_ASUMB("E#","IDX")_" not valid - error code="_Y D HLP^ASUJHELP(Z) S ASUF("ERR")=5
.E D ;Error Index master not on file
..S Z="Index : "_ASUMB("E#","IDX")_" not valid - error code="_Y D HLP^ASUJHELP(Z) S ASUF("ERR")=6
E D Q
.S Z="Backorder already on file for Vou# "_ASUVOU_" w/this Requsitoner and Index" D HLP^ASUJHELP(Z) S ASUF("ERR")=7
.S ASUT(ASUT,"VAL")=0,X=0
D READBO^ASUMBOIO ;Read Backorder master into variables
D:$G(ASUSB)'=1 PUT^DDSVALF("BOQTY","","",Q)
S ASUMB("DT")=ASUT(ASUT,"DTR"),ASUMB("DTPS")=ASUK("DT","FM")
N V S V=ASUT(ASUT,"VOU") D
.I V["-" D
..S ASUMB("VOU")=$P(V,"-")_"-"_$P(V,"-",2)_"-",V("#")=$P(V,"-",3)
.E D
..S ASUMB("VOU")=$E(V,1,2)_"-"_$E(V,3,4)_"-",V("#")=$E(V,5,8)
I V("#")<5000 D
.S V("#")=V("#")+5000
E D
.S V("#")="5"_$E(V("#"),2,4)
S ASUMB("VOU")=ASUMB("VOU")_V("#")
I $G(ASUSB)'=1 D PUT^DDSVALF("BOVOU","","",ASUMB("VOU")),PUT^DDSVALF("BOQTY","","",Q)
E W "B.O. Vou:",V
D UPDTBO^ASUMBOIO ;Write Backorder master from variables
Q
ASU3IUPD ; IHS/ITSC/LMH -POST REPLENISHMENT ISS TRANS ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine provides logic to post (process) ISSUE transactions
+3 ;to the SAMS master files.
+4 IF $GET(DDSERROR)>0
QUIT
IF $GET(ASUT(ASUT,"QTY","REQ"))=""
QUIT
+5 SET ASUF("SV")=2
DO SETMOIS
DO UPDATE
DO ^ASUMKBPS
DO ^ASUMYDPS
+6 GOTO EXIT
RVIS ;EP ;REVERSAL ISSUE
+1 IF $GET(DDSERROR)>0
QUIT
+2 IF '$DATA(ASUT(ASUT,"QTY","ISS"))
SET ASUT(ASUT,"QTY","ISS")=$GET(ASUT(ASUT,"QTY"))
+3 SET ASUF("SV")=2
DO SETMOIS
DO UPDATE
+4 IF ASUT("TRCD")="3K"
DO ^ASUMKBPS
DO ^ASUMYDPS
IF ASUT("TRCD")="3L"
DO ^ASUMYDPS
EXIT ;
+1 ;K ASUT,ASUF("SV") D PSTKL^ASUCOKIL ;WAR 5/11/99 INCLUDED IF STMT
+2 IF '$DATA(ASU("DA CNT"))
KILL ASUT,ASUF("SV")
DO PSTKL^ASUCOKIL
+3 QUIT
TXFIS ;EP ;TRANSFER ISSUE
+1 IF $GET(DDSERROR)>0
QUIT
+2 IF $GET(ASUT(ASUT,"QTY","ISS"))=""
SET ASUT(ASUT,"QTY","ISS")=$GET(ASUT(ASUT,"QTY"))
+3 IF $GET(DDSREFT)=""
SET DDSREFT=$GET(ASUV("DDSREFT"))
+4 ;D SETMOIS
+5 DO UPDATE
QUIT
SETMOIS ;EP;
+1 IF $GET(DDSREFT)=""
SET DDSREFT=$GET(ASUV("DDSREFT"))
+2 NEW X
+3 ;Note the following date manipulation should pass requirement for Y2K
+4 ;two digit voucher year greater than 85 = 1900+yr all others, 2000+yr
+5 ;beginning Y2K fix
+6 ;I $E(ASUT("TRCD"),2)?1N S X=$S($P(ASUT(ASUT,"VOU"),"-")>85:2,1:3)_$P(ASUT(ASUT,"VOU"),"-")_$P(ASUT(ASUT,"VOU"),"-",2)_"00" S:X>ASUMS("LSTISS") ASUMS("LSTISS")=X
+7 ;Y2000
IF $EXTRACT(ASUT("TRCD"),2)?1N
Begin DoDot:1
+8 ;Y2000
SET X=$PIECE(ASUT(ASUT,"VOU"),"-",2)_$PIECE(ASUT(ASUT,"VOU"),"-")
+9 ;Y2000
DO START^ASUUY2K(.X,1,U,"N")
+10 ;Y2000
SET X=Y
+11 ;Y2000
IF X>ASUMS("LSTISS")
SET ASUMS("LSTISS")=X
End DoDot:1
+12 ;end Y2K fix block
+13 SET X=$PIECE(ASUT(ASUT,"VOU"),"-",2)
SET Y=(ASUT(ASUT,"SIGN")*-1)
IF $EXTRACT(X)=0
SET X=$EXTRACT(X,2)
+14 SET ASUMS("DMD","CALL",X)=$GET(ASUMS("DMD","CALL",X))+Y
+15 IF $GET(ASUT(ASUT,"QTY","ISS"))=""
SET ASUT(ASUT,"QTY","ISS")=$GET(ASUT(ASUT,"QTY"))
+16 SET ASUMS("DMD","QTY",X)=$GET(ASUMS("DMD","QTY",X))+(ASUT(ASUT,"QTY","ISS")*Y)
+17 QUIT
UPDATE ;EP;
+1 SET ASUMS("VAL","O/H")=ASUMS("VAL","O/H")+(ASUT(ASUT,"VAL")*ASUT(ASUT,"SIGN"))
+2 SET ASUMS("QTY","O/H")=ASUMS("QTY","O/H")+(ASUT(ASUT,"QTY","ISS")*ASUT(ASUT,"SIGN"))
+3 SET ASUS("ADD")=2
DO ^ASUMSTWR
KILL ASUS("ADD")
+4 IF ASUT(ASUT,"FPN")="B"
SET ASUT(ASUT,"FPN")="N"
+5 ;Move transaction to History file
DO ^ASUJHIST
+6 QUIT
FILLSTAT(X) ;EP ;CALCULATE FILL STATUS (F=FULL, P=PART, N=NONE)
+1 ; X=Quantity Requested
+2 IF $EXTRACT(ASUT("TRCD"),2)?1A
QUIT
+3 NEW Z
+4 SET (ASUT(ASUT,"B/O"),ASUT(ASUT,"FPN"),ASUT(ASUT,"QTY","ADJ"))=""
+5 SET ASUF("ERR")=0
+6 ;WAR 5/7/99S ASUF("ERR")=0,ASUT(ASUT,"B/O")="",ASUT(ASUT,"QTY","ADJ")=""
+7 IF $GET(ASUT(ASUT,"PST"))="I"
Begin DoDot:1
+8 IF X=0!(ASUMS("QTY","O/H")=0)
Begin DoDot:2
+9 IF ASUMS("QTY","O/H")'>0
IF X>0
Begin DoDot:3
+10 SET ASUF("ERR")=1
SET DDSERROR=1
SET Z="No Quantity On Hand - Issuing "_X_" would cause a credit balance"
+11 SET ASUT(ASUT,"FPN")=""
SET ASUT(ASUT,"QTY","ISS")=""
+12 DO HLP^ASUJHELP(Z)
DO QTY^ASUJCLER
DO QTYI^ASUJSAVE(ASUT(ASUT,"QTY","ISS"))
DO FPN^ASUJSAVE(ASUT(ASUT,"FPN"))
End DoDot:3
+13 SET (ASUT(ASUT,"QTY","ISS"),ASUT(ASUT,"QTY"),ASUT(ASUT,"QTY","REQ"))=0
+14 SET ASUT(ASUT,"FPN")="N"
SET ASUT(ASUT,"VAL")=0
End DoDot:2
+15 IF '$TEST
Begin DoDot:2
+16 IF ASUMS("QTY","O/H")<X
Begin DoDot:3
+17 SET ASUF("ERR")=1
SET DDSERROR=1
SET Z="Not enough Quantity On Hand - Issuing "_X_" would cause a credit balance"
+18 SET ASUT(ASUT,"FPN")=""
SET ASUT(ASUT,"QTY","ISS")=""
+19 DO HLP^ASUJHELP(Z)
DO QTY^ASUJCLER
DO QTYI^ASUJSAVE(ASUT(ASUT,"QTY","ISS"))
DO FPN^ASUJSAVE(ASUT(ASUT,"FPN"))
End DoDot:3
QUIT
+20 ;DFM 4/7/99
SET ASUT(ASUT,"FPN")=$GET(ASUT(ASUT,"FPN"))
IF ASUT(ASUT,"FPN")=""
SET ASUT(ASUT,"FPN")="F"
+21 IF $GET(ASUT(ASUT,"FPN"))="F"
Begin DoDot:3
+22 SET ASUT(ASUT,"QTY","ISS")=X
SET (Z,Y)=""
DO MSUNCST(.Z,.Y)
SET ASUT(ASUT,"VAL")=Y
End DoDot:3
+23 IF '$TEST
Begin DoDot:3
+24 IF $GET(ASUT(ASUT,"FPN"))="P"
Begin DoDot:4
+25 IF ASUT(ASUT,"QTY","ISS")]""
Begin DoDot:5
+26 SET (Z,Y)=""
DO MSUNCST(.Z,.Y)
SET ASUT(ASUT,"VAL")=Y
End DoDot:5
+27 IF '$TEST
Begin DoDot:5
+28 SET ASUT(ASUT,"QTY","ISS")=X
+29 SET (Z,Y)=""
DO MSUNCST(.Z,.Y)
SET ASUT(ASUT,"VAL")=Y
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+30 IF '$TEST
Begin DoDot:1
+31 IF ASUT(ASUT,"FPN")=""
Begin DoDot:2
+32 SET ASUT(ASUT,"QTY","ADJ")=""
SET ASUS("QTYAJ")=0
+33 SET Z=ASUT(ASUT,"QTY","REQ")
SET Y=""
DO SPQ^ASU3ISQA(.Z,.Y)
SET ASUT(ASUT,"QTY","ISS")=Y
+34 IF ASUT(ASUT,"QTY","ISS")'=ASUT(ASUT,"QTY","REQ")
Begin DoDot:3
+35 ;DFM P1 9/1/98 WAR 5/3/99
SET Z="Requested quantity adjusted to comply with Standard Pack Quantity"
DO HLP^ASUJHELP(Z)
+36 SET ASUT(ASUT,"QTY","ADJ")="A"
SET ASUS("QTYAJ")=1
End DoDot:3
+37 IF '$TEST
Begin DoDot:3
+38 SET ASUT(ASUT,"QTY","ADJ")=""
SET ASUS("QTYAJ")=0
End DoDot:3
End DoDot:2
+39 ;I ASUMS("QTY","O/H")=ASUT(ASUT,"QTY","ISS")!(ASUMS("QTY","O/H")>ASUT(ASUT,"QTY","ISS")) D
+40 ;WAR 5/5/99
IF ASUMS("QTY","O/H")'<ASUT(ASUT,"QTY","ISS")
Begin DoDot:2
+41 SET ASUT(ASUT,"FPN")="F"
End DoDot:2
+42 IF '$TEST
Begin DoDot:2
+43 IF ASUT("TRCD")'=32
Begin DoDot:3
+44 SET ASUF("ERR")=1
SET DDSERROR=1
+45 ;DFM P1 9/1/98 WAR 5/3/99
SET Z="Not enough Quantity On Hand - would cause credit balance"
DO HLP^ASUJHELP(Z)
+46 DO QTY^ASUJCLER
End DoDot:3
QUIT
+47 ;I ASUMS("QTY","O/H")=0!(ASUMS("QTY","O/H")<0) D
+48 ;WAR 5/5/99
IF ASUMS("QTY","O/H")'>0
Begin DoDot:3
+49 SET ASUT(ASUT,"FPN")="N"
SET ASUT(ASUT,"QTY","ISS")=0
End DoDot:3
+50 IF '$TEST
Begin DoDot:3
+51 SET ASUT(ASUT,"FPN")="P"
+52 SET ASUT(ASUT,"QTY","ISS")=ASUMS("QTY","O/H")
End DoDot:3
End DoDot:2
+53 ;Q:ASUF("ERR")
IF ASUT(ASUT,"FPN")="N"
SET ASUF("ERR")=0
Begin DoDot:2
+54 ;D QTYREQ^ASUJHELP ;WAR 5/5/99 and the next 5 lines
+55 ;DFM P1 9/1/98 WAR 5/3/99
SET Z="No Quantity On Hand - will attempt to Backorder"
DO HLP^ASUJHELP(Z)
+56 SET X=ASUT(ASUT,"QTY","REQ")
+57 NEW Q
SET Q=X
DO BKORDR(.Q)
+58 IF ASUF("ERR")
IF ASUF("ERR")=7
SET ASUT(ASUT,"FPN")="B"
SET ASUT(ASUT,"QTY","ISS")=0
SET ASUT(ASUT,"VAL")=0
DO QTY^ASUJCLER
DO VAL^ASUJCLER
QUIT
+59 SET ASUV("CST/U")=0
SET ASUMS("D/O","QTY")=Q
End DoDot:2
+60 IF ASUT(ASUT,"FPN")="P"
Begin DoDot:2
+61 ;D QTYREQ^ASUJHELP ;WAR 5/5/99 and next 10 lines
+62 SET X=ASUT(ASUT,"QTY","REQ")-ASUMS("QTY","O/H")
SET ASUT(ASUT,"QTY","ISS")=ASUMS("QTY","O/H")
+63 ;DFM P1 9/1/98 WAR 5/3/99
SET Z="Not enough Quantity to fill order - will attempt to Backorder "_X
DO HLP^ASUJHELP(Z)
+64 NEW Q
SET Q=X
SET ASUF("ERR")=0
DO BKORDR(.Q)
+65 IF ASUF("ERR")
DO VAL^ASUJCLER
DO QTY^ASUJCLER
QUIT
+66 SET ASUT(ASUT,"B/O")="B"
+67 SET ASUMS("D/O","QTY")=ASUMS("D/O","QTY")+Q
+68 IF '$DATA(ASUT(ASUT,"PON"))
SET ASUT(ASUT,"PON")=""
+69 IF '$DATA(ASUT(ASUT,"SUI"))
SET ASUT(ASUT,"SUI")=""
+70 IF '$DATA(ASUT(ASUT,"SRC"))
SET ASUT(ASUT,"SRC")=""
+71 IF '$DATA(ASUT(ASUT,"REQ TYP"))
SET ASUT(ASUT,"REQ TYP")=""
End DoDot:2
+72 IF ASUMS("QTY","O/H")'>0
Begin DoDot:2
+73 SET ASUT(ASUT,"VAL")=0
DO VAL^ASUJCLER
End DoDot:2
+74 IF '$TEST
Begin DoDot:2
+75 IF ASUT(ASUT,"FPN")'="N"
SET (Z,Y)=""
DO MSUNCST(.Z,.Y)
SET ASUT(ASUT,"VAL")=Y
End DoDot:2
End DoDot:1
+76 IF $GET(DA)=""
SET DA=ASUHDA
+77 SET DDSERROR=""
SET Z=ASUT(ASUT,"VAL")
DO VAL^ASUJVALF(.Z,.DDSERROR)
+78 SET Z=ASUT(ASUT,"FPN")
DO FPN^ASUJSAVE(.Z)
+79 IF "2P37"[ASUT("TRCD")
QUIT
+80 SET DDSERROR=""
SET Z=ASUT(ASUT,"QTY","ISS")
DO EN^ASUJVALD(.Z,.DDSERROR,"QTYI","N")
+81 QUIT
MSUNCST(X,Y) ;EP; -Calculate Unit cost for issue from Station Master QTY & VAL
+1 NEW Z
SET Z=ASUT(ASUT,"QTY","ISS")
DO UCSVAL(.Z,.X,.Y)
+2 IF ASUMS("QTY","O/H")-ASUT(ASUT,"QTY","ISS")=0
SET Y=ASUMS("VAL","O/H")
+3 IF Y>ASUMS("VAL","O/H")
SET Y=ASUMS("VAL","O/H")
+4 QUIT
UCSVAL(Z,X,Y) ;EP
+1 ;Z - Quantity
+2 ;X - Returns Unit Cost
+3 ;Y - Returns value of (Unit cost X Quantity)
+4 SET X=$SELECT(ASUMS("VAL","O/H")=0!(ASUMS("VAL","O/H")=""):0,ASUMS("QTY","O/H")=0!(ASUMS("QTY","O/H")=""):0,1:$FNUMBER((ASUMS("VAL","O/H")/ASUMS("QTY","O/H")),"",2))
+5 IF $GET(ASUT("TRCD"))=27
IF X=0
SET X=$GET(ASUMS("LPP"))
+6 IF $GET(ASUT("TRCD"))=31
IF X=0
SET X=$GET(ASUMS("LPP"))
+7 SET Y=+$GET(X)*(+$GET(Z))
SET ASUMB("UCS")=$GET(X)
+8 QUIT
BKORDR(Q) ;CREATE ISSUE BACKORDER
+1 ;Q - QUANTITY TO BACKORDER
+2 SET ASUVQBO=Q
+3 IF $GET(ASUT(ASUT,"SST"))=""
Begin DoDot:1
+4 ;DFM P1 9/1/98
SET Z="Can't Backorder - No Sub Station Code"
DO HLP^ASUJHELP(Z)
SET ASUF("ERR")=1
End DoDot:1
QUIT
+5 IF $GET(ASUT(ASUT,"USR"))=""
Begin DoDot:1
+6 ;DFM P1 9/1/98
SET Z="Can't Backorder - No User Code"
DO HLP^ASUJHELP(Z)
SET ASUF("ERR")=2
End DoDot:1
QUIT
+7 SET ASUMB("E#","USR")=$GET(ASUT(ASUT,"PT","USR"))
SET ASUMB("E#","REQ")=$GET(ASUT(ASUT,"PT","REQ"))
SET ASUMB("E#","IDX")=$GET(ASUT(ASUT,"PT","IDX"))
+8 SET ASUF("ERR")=0
+9 ;D REQ^ASUMBOIO(ASUMB("E#","USR")) ;Lookup REQ in Backorder master
+10 ;WAR 5/4/99 line above is incorrect
DO REQ^ASUMBOIO(ASUMB("E#","REQ"))
+11 IF Y<1
Begin DoDot:1
+12 ;No backorders on file for Requsitioner
IF Y=0
Begin DoDot:2
+13 ;Add REQ to Backorder master
DO REQADD^ASUMBOIO(ASUMB("E#","REQ"))
+14 ;Error in add
NEW Z
IF Y<0
Begin DoDot:3
+15 SET Z="Backorder for Requsitioner : "_ASUMB("E#","REQ")_" not created - error code="_Y
DO HLP^ASUJHELP(Z)
SET ASUF("ERR")=3
End DoDot:3
End DoDot:2
+16 ;Error -requsitioner not in lookup table
IF '$TEST
Begin DoDot:2
+17 SET Z="Requsitioner : "_ASUMB("E#","REQ")_" not valid - error code="_Y
DO HLP^ASUJHELP(Z)
SET ASUF("ERR")=4
End DoDot:2
End DoDot:1
IF ASUF("ERR")
QUIT
+18 NEW Z
SET Z(0)=ASUT("TRCD")
SET ASUT("TRCD")=31
DO UCSVAL(.ASUVQBO,.ASUVUCS,.ASUVAL)
SET ASUT("TRCD")=Z(0)
SET ASUMB("VAL")=ASUVAL
SET ASUMB("UCS")=ASUVUCS
SET ASUMB("QTYB/O")=ASUVQBO
+19 KILL ASUVAL,ASUVUCS,ASUVQBO
+20 SET ASUMB("QTYISS")=ASUT(ASUT,"QTY","ISS")
+21 ;Lookup IDX in Backorder master
DO IDX^ASUMBOIO(ASUMB("E#","IDX"))
+22 NEW Z
IF Y<1
Begin DoDot:1
+23 ;No backorder on file for this item for this requsitioner
IF Y=0
Begin DoDot:2
+24 ;Add IDX to Backorder master
DO IDXADD^ASUMBOIO(ASUMB("E#","IDX"))
+25 ;Error Index master not on file
IF Y<0
Begin DoDot:3
+26 SET Z="Index : "_ASUMB("E#","IDX")_" not valid - error code="_Y
DO HLP^ASUJHELP(Z)
SET ASUF("ERR")=5
End DoDot:3
End DoDot:2
+27 ;Error Index master not on file
IF '$TEST
Begin DoDot:2
+28 SET Z="Index : "_ASUMB("E#","IDX")_" not valid - error code="_Y
DO HLP^ASUJHELP(Z)
SET ASUF("ERR")=6
End DoDot:2
End DoDot:1
IF $DATA(ASUM("ERR"))
QUIT
+29 IF '$TEST
Begin DoDot:1
+30 SET Z="Backorder already on file for Vou# "_ASUVOU_" w/this Requsitoner and Index"
DO HLP^ASUJHELP(Z)
SET ASUF("ERR")=7
+31 SET ASUT(ASUT,"VAL")=0
SET X=0
End DoDot:1
QUIT
+32 ;Read Backorder master into variables
DO READBO^ASUMBOIO
+33 IF $GET(ASUSB)'=1
DO PUT^DDSVALF("BOQTY","","",Q)
+34 SET ASUMB("DT")=ASUT(ASUT,"DTR")
SET ASUMB("DTPS")=ASUK("DT","FM")
+35 NEW V
SET V=ASUT(ASUT,"VOU")
Begin DoDot:1
+36 IF V["-"
Begin DoDot:2
+37 SET ASUMB("VOU")=$PIECE(V,"-")_"-"_$PIECE(V,"-",2)_"-"
SET V("#")=$PIECE(V,"-",3)
End DoDot:2
+38 IF '$TEST
Begin DoDot:2
+39 SET ASUMB("VOU")=$EXTRACT(V,1,2)_"-"_$EXTRACT(V,3,4)_"-"
SET V("#")=$EXTRACT(V,5,8)
End DoDot:2
End DoDot:1
+40 IF V("#")<5000
Begin DoDot:1
+41 SET V("#")=V("#")+5000
End DoDot:1
+42 IF '$TEST
Begin DoDot:1
+43 SET V("#")="5"_$EXTRACT(V("#"),2,4)
End DoDot:1
+44 SET ASUMB("VOU")=ASUMB("VOU")_V("#")
+45 IF $GET(ASUSB)'=1
DO PUT^DDSVALF("BOVOU","","",ASUMB("VOU"))
DO PUT^DDSVALF("BOQTY","","",Q)
+46 IF '$TEST
WRITE "B.O. Vou:",V
+47 ;Write Backorder master from variables
DO UPDTBO^ASUMBOIO
+48 QUIT
