ASUMBOIO ; IHS/ITSC/LMH -BACKORDER MASTER I/O ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine is a utility which provides the ability to write to
;(update) and read (retrieve) from Backorder Master file (^ASUMB).
;A record entry number must be provided for Requsitioner
;(ASUMB("E#","REQ")) and Index (ASUMB("E#","IDX")).
READBO ;EP ;READ BACKORDER MASTER
Q:$G(ASUMB("E#","REQ"))=""
Q:$G(ASUMB("E#","IDX"))=""
S ASUMB(1)=$G(^ASUMB(ASUMB("E#","REQ"),1,ASUMB("E#","IDX"),1))
S ASUMB("E#","USR")=$P(^ASUL(20,ASUMB("E#","REQ"),0),U,2)
S ASUMB("USR")=$P(^ASUL(19,ASUMB("E#","USR"),1),U)
S ASUMB("USR","NM")=$P(^ASUL(19,ASUMB("E#","USR"),0),U)
S ASUMB("IDX")=$E(ASUMB("E#","IDX"),3,8)
S ASUMB("TRCD")=$P(ASUMB(1),U)
S ASUMB("VOU")=$P(ASUMB(1),U,2)
S ASUMB("QTYB/O")=$P(ASUMB(1),U,3)
S ASUMB("CAN")=$P(ASUMB(1),U,4)
S ASUMB("B/O")=$P(ASUMB(1),U,5)
S ASUMB("QTYAJ")=$P(ASUMB(1),U,6)
S ASUMB("ACC")=$P(ASUMB(1),U,7)
S ASUMB("SSA")=$P(ASUMB(1),U,8)
S ASUMB("CTG")=$P(ASUMB(1),U,9)
S ASUMB("DT")=$P(ASUMB(1),U,10)
S ASUMB("RQN")=$P(ASUMB(1),U,11)
S ASUMB("REQTYP")=$P(ASUMB(1),U,12)
S ASUMB("STA")=$P(ASUMB(1),U,13)
S ASUMB("SST")=$P(ASUMB(1),U,14)
S ASUMB("QTYISS")=$P(ASUMB(1),U,15)
S ASUMB("SLC")=$P(ASUMB(1),U,16) D SLC^ASULDIRR(ASUMB("SLC")) S ASUMB("E#","SLC")=ASUL(10,"SLC","E#")
S ASUMB("FPN")=$P(ASUMB(1),U,17)
S ASUMB("DTPR")=$P(ASUMB(1),U,18)
S ASUMB("UCS")=$P(ASUMB(1),U,19),ASUMB("VAL")=ASUMB("UCS")*ASUMB("QTYB/O")
Q
WRITEBO ;EP ;BUILD NEW BACKORDER MASTER FROM ISSUE TRANSACTION
Q:$G(ASUMB("E#","REQ"))=""
Q:$G(ASUMB("E#","IDX"))=""
S $P(ASUMB(1),U)=ASUT("TRCD")
S ASUMB("VOU")=$S($E(ASUT(ASUT,"VOU"),5)<5:$E(ASUT(ASUT,"VOU"),5)+5,1:$E(ASUT(ASUT,"VOU"),5))
S ASUMB("VOU")=$E(ASUT(ASUT,"VOU"),1,4)_ASUMB("VOU")_$E(ASUT(ASUT,"VOU"),6,8)
S $P(ASUMB(1),U,2)=ASUMB("VOU")
S $P(ASUMB(1),U,3)=ASUMB("QTYB/O")
S $P(ASUMB(1),U,4)=ASUT(ASUT,"CAN")
S $P(ASUMB(1),U,5)="B"
S $P(ASUMB(1),U,6)=ASUT(ASUT,"QTY","ADJ")
S $P(ASUMB(1),U,7)=ASUT(ASUT,"ACC")
S $P(ASUMB(1),U,8)=ASUT(ASUT,"SSA")
S $P(ASUMB(1),U,9)=ASUT(ASUT,"CTG")
S $P(ASUMB(1),U,10)=ASUT(ASUT,"DTR")
S $P(ASUMB(1),U,11)=ASUT(ASUT,"RQN")
S $P(ASUMB(1),U,12)=ASUT(ASUT,"REQ TYP")
S $P(ASUMB(1),U,13)=ASUT(ASUT,"STA")
S $P(ASUMB(1),U,14)=$E(ASUMB("E#","REQ"),1,5)
S $P(ASUMB(1),U,15)=ASUT(ASUT,"QTY","ISS")
S $P(ASUMB(1),U,16)=ASUMS("SLC")
S $P(ASUMB(1),U,17)=ASUT(ASUT,"FPN")
S $P(ASUMB(1),U,18)=ASUK("DT","FM")
S $P(ASUMB(1),U,19)=$G(ASUMB("UCS"))
S ^ASUMB(ASUMB("E#","REQ"),1,ASUMB("E#","IDX"),0)=ASUMB("E#","IDX")
D WNODE ;Write new node
Q
UPDTBO ;EP ;UPDATE BACKORDER MASTER
Q:$G(ASUMB("E#","REQ"))=""
Q:$G(ASUMB("E#","IDX"))=""
I ASUMB("VOU")'=$P(ASUMB(1),U,2) S $P(ASUMB(1),U,2)=ASUMB("VOU")
I ASUMB("QTYB/O")'=$P(ASUMB(1),U,3) D
.D KFAC^ASUMBOIO,KAC^ASUMBOIO ;Kill old quantity cross references before setting new quantity
.S $P(ASUMB(1),U,3)=ASUMB("QTYB/O")
I ASUMB("QTYAJ")'=$P(ASUMB(1),U,6) S $P(ASUMB(1),U,6)=ASUMB("QTYAJ")
I ASUMB("ACC")'=$P(ASUMB(1),U,7) S $P(ASUMB(1),U,7)=ASUMB("ACC")
I ASUMB("QTYISS")'=$P(ASUMB(1),U,15) S $P(ASUMB(1),U,15)=ASUMB("QTYISS")
I ASUMB("FPN")'=$P(ASUMB(1),U,17) S $P(ASUMB(1),U,17)=ASUMB("FPN")
I ASUMB("DTPR")'=$P(ASUMB(1),U,18) S $P(ASUMB(1),U,18)=ASUMB("DTPR")
WNODE ;EP ;
S ^ASUMB(ASUMB("E#","REQ"),1,ASUMB("E#","IDX"),1)=ASUMB(1),$P(^ASUMB(ASUMB("E#","REQ"),0),U,3)=ASUMB("E#","IDX")
XRF ;
S DA=ASUMB("E#","IDX"),DA(1)=ASUMB("E#","REQ"),DIK="^ASUMB("_DA(1)_",1,"
D IX^DIK K DA,DIK ;New quantity cross references will be created here
Q
REQADD(X) ;EP ; DIRECT USER ADD -MUST HAVE IEN FOR SUBSTATION
;Error conditions passed back in 'Y'
; -3 : No Index Master found for Index # add requested for
; -7 : IEN not for Area signed into KERNEL with (DUZ 2)
; -8 : Failed IEN edit
; -10 : Station IEN Index to be added to not in ASUMS variable
I $L(X)=4 S X=$G(ASUL(2,"E#","SST"))_X
I $E(X,1,2)'=ASUL(1,"AR","AP") S Y=-7 Q ;Not for Area Signed on as
I X'?9N S Y=-8 Q ;Failed IEN edit
I $D(^ASUMB(X,0)) S Y=0 Q ;Requsitioner already on file
S ASUMB("E#","REQ")=X
S ^ASUMB(X,0)=X
S ^ASUMB(X,1,0)="^9002035.01PA"
;Add one to the count of Requsitioners
S $P(^ASUMB(0),U,4)=$P(^ASUMB(0),U,4)+1
;Set last Requsitioner updated piece
S $P(^ASUMB(ASUMB("E#","REQ"),1,0),U,3)=X
S DA=X
S DIK="^ASUMB("
D IX^DIK K DIK,DA
Q
IDXADD(X) ;EP ; DIRECT INDEX ADD -MUST HAVE IEN FOR REQ
I $G(ASUMB("E#","REQ"))="" S Y=-11 Q ;Requsitioner IEN not available
I X'?1N.N D DIX^ASUMDIRM(.X) Q:Y<0
S ASUMB("E#","IDX")=X
I $D(^ASUMB(ASUMB("E#","REQ"),1,X,0)) S Y=0 Q ;IDX already on file
S ^ASUMB(ASUMB("E#","REQ"),1,X,0)=X
D WRITEBO^ASUMBOIO ;Set up new entry from issue transaction
S $P(^ASUMB(ASUMB("E#","REQ"),1,0),U,4)=$P(^ASUMB(ASUMB("E#","REQ"),1,0),U,4)+1 ;Add one to the count of IDX for this Requsitioner
S $P(^ASUMB(ASUMB("E#","REQ"),1,0),U,3)=X ;Set last IDX updated piece
S DA=X,DA(1)=ASUMB("E#","REQ")
S DIK="^ASUMB(DA(1),1,"
D IX^DIK K DIK,DA
Q
REQ(X) ;EP ; DIRECT USER LOOKUP -MUST HAVE IEN FOR SUBSTATION
;;This routine provides for the lookup of a Backorder record for a
;;Requsitioner and Index number. Since the Backorder file is primary
;;key is DINUM (has the exact same internal entry number) as an entry
;;in the EQUSITIONER TABLE, and that is based on SUB STATION & USER
;;codes, a Sub Station table lookup must have been made before calling
;;this User table lookup. If the actual internal entry number is being
;;passed, verification of a back order for that ien is determined.
I X'?9N D REQ^ASULDIRR(.X) Q:Y<0
I $D(^ASUMB(X,0)) D
.S (Y,ASUMB("E#","REQ"))=X ;Record found for input parameter
E D
.S ASUMB("E#","REQ")=X ;IEN to use for LAYGO call
.S Y=0 ;No record found for Input parameter
Q
IDX(X) ;EP ; DIRECT INDEX LOOKUP -MUST HAVE IEN FOR REQ
I $G(ASUMB("E#","REQ"))="" S Y=-11 Q ;Usr IEN not passed
I X?1N.N D DIX^ASUMDIRM(.X) Q:Y<0
I $D(^ASUMB(ASUMB("E#","REQ"),1,X,0)) D
.;S (Y,ASUMB("E#","IDX"))=X ;Record found for input parameter
.S Y=X ;WAR 5/4/99
.S ASUVOU=$P($G(^ASUMB(ASUMB("E#","REQ"),1,X,1)),U,2) ;WAR 5/4/99
E D
.S ASUMB("E#","IDX")=X ;IEN to use for LAYGO call
.S Y=0 ;No record found for Input parameter
Q
KFAC ;EP; KILL FACILITY
N X,Y
I $G(DA)="" S DA=$G(ASUMB("E#","IDX"))
I $G(DA(1))="" S DA=$G(ASUMB("E#","REQ"))
Q:$G(DA)="" Q:$G(DA(1))=""
I '$D(ASUMB(1)) D
.I $D(D) I D[U S ASUMB(1)=D Q
.S ASUMB(1)=^ASUMB(DA(1),1,DA,1)
.S $P(ASUMB(1),U,3)=$P(ASUMB(1),U,3)+$P(^ASUMB(DA(1),1,DA,1),U,15)
K ^ASUMB("AC",DA,$P(ASUMB(1),U,3),DA(1),DA)
I $G(ASUMB("E#","REQ"))="" K ASUMB(1)
Q
KAC ;EP; KILL ACCOUNT
N X,Y
I $G(DA)="" S DA=$G(ASUMB("E#","IDX"))
I $G(DA(1))="" S DA=$G(ASUMB("E#","REQ"))
Q:$G(DA)="" Q:$G(DA(1))=""
I '$D(ASUMB(1)) D
.I $D(D) I D[U S ASUMB(1)=D Q
.S ASUMB(1)=^ASUMB(DA(1),1,DA,1)
.S $P(ASUMB(1),U,3)=$P(ASUMB(1),U,3)+$P(^ASUMB(DA(1),1,DA,0),U,15)
D QTY
K ^ASUMB(DA(1),1,"AC",DA_ASUMB("B/OQ"),DA)
I $G(ASUMB("E#","REQ"))="" K ASUMB(1)
Q
SFAC ;EP ; SET FOR FACILITY
N X,Y
I $G(DA)="" S DA=$G(ASUMB("E#","IDX"))
I $G(DA(1))="" S DA=$G(ASUMB("E#","REQ"))
Q:$G(DA)="" Q:$G(DA(1))=""
S:'$D(ASUMB(1)) ASUMB(1)=^ASUMB(DA(1),1,DA,1)
S ^ASUMB("AC",DA,$P(ASUMB(1),U,3),DA(1),DA)=""
I $G(ASUMB("E#","IDX"))="" K ASUMB
Q
SAC ;EP ; SET FOR ACCOUNT
N X,Y
I $G(DA)="" S DA=$G(ASUMB("E#","IDX"))
I $G(DA(1))="" S DA=$G(ASUMB("E#","REQ"))
Q:$G(DA)="" Q:$G(DA(1))=""
S:'$D(ASUMB(1)) ASUMB(1)=^ASUMB(DA(1),1,DA,1)
D QTY
S ^ASUMB(DA(1),1,"AC",DA_ASUMB("B/OQ"),DA)=""
I $G(ASUMB("E#","IDX"))="" K ASUMB
Q
QTY ;EP -GET PROPER LENGTH ON QUANTITY
;;This routine left zero fills the quantity being backored.
S X=$P(ASUMB(1),U,4)*.000001
I $L($P(X,".",2))<6 S Y=1_$P(X,".",2),Y=Y*1000000,X="."_$E(Y,2,7)
S ASUMB("B/OQ")=$TR(X,".","*")
Q
ASUMBOIO ; IHS/ITSC/LMH -BACKORDER MASTER I/O ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine is a utility which provides the ability to write to
+3 ;(update) and read (retrieve) from Backorder Master file (^ASUMB).
+4 ;A record entry number must be provided for Requsitioner
+5 ;(ASUMB("E#","REQ")) and Index (ASUMB("E#","IDX")).
READBO ;EP ;READ BACKORDER MASTER
+1 IF $GET(ASUMB("E#","REQ"))=""
QUIT
+2 IF $GET(ASUMB("E#","IDX"))=""
QUIT
+3 SET ASUMB(1)=$GET(^ASUMB(ASUMB("E#","REQ"),1,ASUMB("E#","IDX"),1))
+4 SET ASUMB("E#","USR")=$PIECE(^ASUL(20,ASUMB("E#","REQ"),0),U,2)
+5 SET ASUMB("USR")=$PIECE(^ASUL(19,ASUMB("E#","USR"),1),U)
+6 SET ASUMB("USR","NM")=$PIECE(^ASUL(19,ASUMB("E#","USR"),0),U)
+7 SET ASUMB("IDX")=$EXTRACT(ASUMB("E#","IDX"),3,8)
+8 SET ASUMB("TRCD")=$PIECE(ASUMB(1),U)
+9 SET ASUMB("VOU")=$PIECE(ASUMB(1),U,2)
+10 SET ASUMB("QTYB/O")=$PIECE(ASUMB(1),U,3)
+11 SET ASUMB("CAN")=$PIECE(ASUMB(1),U,4)
+12 SET ASUMB("B/O")=$PIECE(ASUMB(1),U,5)
+13 SET ASUMB("QTYAJ")=$PIECE(ASUMB(1),U,6)
+14 SET ASUMB("ACC")=$PIECE(ASUMB(1),U,7)
+15 SET ASUMB("SSA")=$PIECE(ASUMB(1),U,8)
+16 SET ASUMB("CTG")=$PIECE(ASUMB(1),U,9)
+17 SET ASUMB("DT")=$PIECE(ASUMB(1),U,10)
+18 SET ASUMB("RQN")=$PIECE(ASUMB(1),U,11)
+19 SET ASUMB("REQTYP")=$PIECE(ASUMB(1),U,12)
+20 SET ASUMB("STA")=$PIECE(ASUMB(1),U,13)
+21 SET ASUMB("SST")=$PIECE(ASUMB(1),U,14)
+22 SET ASUMB("QTYISS")=$PIECE(ASUMB(1),U,15)
+23 SET ASUMB("SLC")=$PIECE(ASUMB(1),U,16)
DO SLC^ASULDIRR(ASUMB("SLC"))
SET ASUMB("E#","SLC")=ASUL(10,"SLC","E#")
+24 SET ASUMB("FPN")=$PIECE(ASUMB(1),U,17)
+25 SET ASUMB("DTPR")=$PIECE(ASUMB(1),U,18)
+26 SET ASUMB("UCS")=$PIECE(ASUMB(1),U,19)
SET ASUMB("VAL")=ASUMB("UCS")*ASUMB("QTYB/O")
+27 QUIT
WRITEBO ;EP ;BUILD NEW BACKORDER MASTER FROM ISSUE TRANSACTION
+1 IF $GET(ASUMB("E#","REQ"))=""
QUIT
+2 IF $GET(ASUMB("E#","IDX"))=""
QUIT
+3 SET $PIECE(ASUMB(1),U)=ASUT("TRCD")
+4 SET ASUMB("VOU")=$SELECT($EXTRACT(ASUT(ASUT,"VOU"),5)<5:$EXTRACT(ASUT(ASUT,"VOU"),5)+5,1:$EXTRACT(ASUT(ASUT,"VOU"),5))
+5 SET ASUMB("VOU")=$EXTRACT(ASUT(ASUT,"VOU"),1,4)_ASUMB("VOU")_$EXTRACT(ASUT(ASUT,"VOU"),6,8)
+6 SET $PIECE(ASUMB(1),U,2)=ASUMB("VOU")
+7 SET $PIECE(ASUMB(1),U,3)=ASUMB("QTYB/O")
+8 SET $PIECE(ASUMB(1),U,4)=ASUT(ASUT,"CAN")
+9 SET $PIECE(ASUMB(1),U,5)="B"
+10 SET $PIECE(ASUMB(1),U,6)=ASUT(ASUT,"QTY","ADJ")
+11 SET $PIECE(ASUMB(1),U,7)=ASUT(ASUT,"ACC")
+12 SET $PIECE(ASUMB(1),U,8)=ASUT(ASUT,"SSA")
+13 SET $PIECE(ASUMB(1),U,9)=ASUT(ASUT,"CTG")
+14 SET $PIECE(ASUMB(1),U,10)=ASUT(ASUT,"DTR")
+15 SET $PIECE(ASUMB(1),U,11)=ASUT(ASUT,"RQN")
+16 SET $PIECE(ASUMB(1),U,12)=ASUT(ASUT,"REQ TYP")
+17 SET $PIECE(ASUMB(1),U,13)=ASUT(ASUT,"STA")
+18 SET $PIECE(ASUMB(1),U,14)=$EXTRACT(ASUMB("E#","REQ"),1,5)
+19 SET $PIECE(ASUMB(1),U,15)=ASUT(ASUT,"QTY","ISS")
+20 SET $PIECE(ASUMB(1),U,16)=ASUMS("SLC")
+21 SET $PIECE(ASUMB(1),U,17)=ASUT(ASUT,"FPN")
+22 SET $PIECE(ASUMB(1),U,18)=ASUK("DT","FM")
+23 SET $PIECE(ASUMB(1),U,19)=$GET(ASUMB("UCS"))
+24 SET ^ASUMB(ASUMB("E#","REQ"),1,ASUMB("E#","IDX"),0)=ASUMB("E#","IDX")
+25 ;Write new node
DO WNODE
+26 QUIT
UPDTBO ;EP ;UPDATE BACKORDER MASTER
+1 IF $GET(ASUMB("E#","REQ"))=""
QUIT
+2 IF $GET(ASUMB("E#","IDX"))=""
QUIT
+3 IF ASUMB("VOU")'=$PIECE(ASUMB(1),U,2)
SET $PIECE(ASUMB(1),U,2)=ASUMB("VOU")
+4 IF ASUMB("QTYB/O")'=$PIECE(ASUMB(1),U,3)
Begin DoDot:1
+5 ;Kill old quantity cross references before setting new quantity
DO KFAC^ASUMBOIO
DO KAC^ASUMBOIO
+6 SET $PIECE(ASUMB(1),U,3)=ASUMB("QTYB/O")
End DoDot:1
+7 IF ASUMB("QTYAJ")'=$PIECE(ASUMB(1),U,6)
SET $PIECE(ASUMB(1),U,6)=ASUMB("QTYAJ")
+8 IF ASUMB("ACC")'=$PIECE(ASUMB(1),U,7)
SET $PIECE(ASUMB(1),U,7)=ASUMB("ACC")
+9 IF ASUMB("QTYISS")'=$PIECE(ASUMB(1),U,15)
SET $PIECE(ASUMB(1),U,15)=ASUMB("QTYISS")
+10 IF ASUMB("FPN")'=$PIECE(ASUMB(1),U,17)
SET $PIECE(ASUMB(1),U,17)=ASUMB("FPN")
+11 IF ASUMB("DTPR")'=$PIECE(ASUMB(1),U,18)
SET $PIECE(ASUMB(1),U,18)=ASUMB("DTPR")
WNODE ;EP ;
+1 SET ^ASUMB(ASUMB("E#","REQ"),1,ASUMB("E#","IDX"),1)=ASUMB(1)
SET $PIECE(^ASUMB(ASUMB("E#","REQ"),0),U,3)=ASUMB("E#","IDX")
XRF ;
+1 SET DA=ASUMB("E#","IDX")
SET DA(1)=ASUMB("E#","REQ")
SET DIK="^ASUMB("_DA(1)_",1,"
+2 ;New quantity cross references will be created here
DO IX^DIK
KILL DA,DIK
+3 QUIT
REQADD(X) ;EP ; DIRECT USER ADD -MUST HAVE IEN FOR SUBSTATION
+1 ;Error conditions passed back in 'Y'
+2 ; -3 : No Index Master found for Index # add requested for
+3 ; -7 : IEN not for Area signed into KERNEL with (DUZ 2)
+4 ; -8 : Failed IEN edit
+5 ; -10 : Station IEN Index to be added to not in ASUMS variable
+6 IF $LENGTH(X)=4
SET X=$GET(ASUL(2,"E#","SST"))_X
+7 ;Not for Area Signed on as
IF $EXTRACT(X,1,2)'=ASUL(1,"AR","AP")
SET Y=-7
QUIT
+8 ;Failed IEN edit
IF X'?9N
SET Y=-8
QUIT
+9 ;Requsitioner already on file
IF $DATA(^ASUMB(X,0))
SET Y=0
QUIT
+10 SET ASUMB("E#","REQ")=X
+11 SET ^ASUMB(X,0)=X
+12 SET ^ASUMB(X,1,0)="^9002035.01PA"
+13 ;Add one to the count of Requsitioners
+14 SET $PIECE(^ASUMB(0),U,4)=$PIECE(^ASUMB(0),U,4)+1
+15 ;Set last Requsitioner updated piece
+16 SET $PIECE(^ASUMB(ASUMB("E#","REQ"),1,0),U,3)=X
+17 SET DA=X
+18 SET DIK="^ASUMB("
+19 DO IX^DIK
KILL DIK,DA
+20 QUIT
IDXADD(X) ;EP ; DIRECT INDEX ADD -MUST HAVE IEN FOR REQ
+1 ;Requsitioner IEN not available
IF $GET(ASUMB("E#","REQ"))=""
SET Y=-11
QUIT
+2 IF X'?1N.N
DO DIX^ASUMDIRM(.X)
IF Y<0
QUIT
+3 SET ASUMB("E#","IDX")=X
+4 ;IDX already on file
IF $DATA(^ASUMB(ASUMB("E#","REQ"),1,X,0))
SET Y=0
QUIT
+5 SET ^ASUMB(ASUMB("E#","REQ"),1,X,0)=X
+6 ;Set up new entry from issue transaction
DO WRITEBO^ASUMBOIO
+7 ;Add one to the count of IDX for this Requsitioner
SET $PIECE(^ASUMB(ASUMB("E#","REQ"),1,0),U,4)=$PIECE(^ASUMB(ASUMB("E#","REQ"),1,0),U,4)+1
+8 ;Set last IDX updated piece
SET $PIECE(^ASUMB(ASUMB("E#","REQ"),1,0),U,3)=X
+9 SET DA=X
SET DA(1)=ASUMB("E#","REQ")
+10 SET DIK="^ASUMB(DA(1),1,"
+11 DO IX^DIK
KILL DIK,DA
+12 QUIT
REQ(X) ;EP ; DIRECT USER LOOKUP -MUST HAVE IEN FOR SUBSTATION
+1 ;;This routine provides for the lookup of a Backorder record for a
+2 ;;Requsitioner and Index number. Since the Backorder file is primary
+3 ;;key is DINUM (has the exact same internal entry number) as an entry
+4 ;;in the EQUSITIONER TABLE, and that is based on SUB STATION & USER
+5 ;;codes, a Sub Station table lookup must have been made before calling
+6 ;;this User table lookup. If the actual internal entry number is being
+7 ;;passed, verification of a back order for that ien is determined.
+8 IF X'?9N
DO REQ^ASULDIRR(.X)
IF Y<0
QUIT
+9 IF $DATA(^ASUMB(X,0))
Begin DoDot:1
+10 ;Record found for input parameter
SET (Y,ASUMB("E#","REQ"))=X
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 ;IEN to use for LAYGO call
SET ASUMB("E#","REQ")=X
+13 ;No record found for Input parameter
SET Y=0
End DoDot:1
+14 QUIT
IDX(X) ;EP ; DIRECT INDEX LOOKUP -MUST HAVE IEN FOR REQ
+1 ;Usr IEN not passed
IF $GET(ASUMB("E#","REQ"))=""
SET Y=-11
QUIT
+2 IF X?1N.N
DO DIX^ASUMDIRM(.X)
IF Y<0
QUIT
+3 IF $DATA(^ASUMB(ASUMB("E#","REQ"),1,X,0))
Begin DoDot:1
+4 ;S (Y,ASUMB("E#","IDX"))=X ;Record found for input parameter
+5 ;WAR 5/4/99
SET Y=X
+6 ;WAR 5/4/99
SET ASUVOU=$PIECE($GET(^ASUMB(ASUMB("E#","REQ"),1,X,1)),U,2)
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 ;IEN to use for LAYGO call
SET ASUMB("E#","IDX")=X
+9 ;No record found for Input parameter
SET Y=0
End DoDot:1
+10 QUIT
KFAC ;EP; KILL FACILITY
+1 NEW X,Y
+2 IF $GET(DA)=""
SET DA=$GET(ASUMB("E#","IDX"))
+3 IF $GET(DA(1))=""
SET DA=$GET(ASUMB("E#","REQ"))
+4 IF $GET(DA)=""
QUIT
IF $GET(DA(1))=""
QUIT
+5 IF '$DATA(ASUMB(1))
Begin DoDot:1
+6 IF $DATA(D)
IF D[U
SET ASUMB(1)=D
QUIT
+7 SET ASUMB(1)=^ASUMB(DA(1),1,DA,1)
+8 SET $PIECE(ASUMB(1),U,3)=$PIECE(ASUMB(1),U,3)+$PIECE(^ASUMB(DA(1),1,DA,1),U,15)
End DoDot:1
+9 KILL ^ASUMB("AC",DA,$PIECE(ASUMB(1),U,3),DA(1),DA)
+10 IF $GET(ASUMB("E#","REQ"))=""
KILL ASUMB(1)
+11 QUIT
KAC ;EP; KILL ACCOUNT
+1 NEW X,Y
+2 IF $GET(DA)=""
SET DA=$GET(ASUMB("E#","IDX"))
+3 IF $GET(DA(1))=""
SET DA=$GET(ASUMB("E#","REQ"))
+4 IF $GET(DA)=""
QUIT
IF $GET(DA(1))=""
QUIT
+5 IF '$DATA(ASUMB(1))
Begin DoDot:1
+6 IF $DATA(D)
IF D[U
SET ASUMB(1)=D
QUIT
+7 SET ASUMB(1)=^ASUMB(DA(1),1,DA,1)
+8 SET $PIECE(ASUMB(1),U,3)=$PIECE(ASUMB(1),U,3)+$PIECE(^ASUMB(DA(1),1,DA,0),U,15)
End DoDot:1
+9 DO QTY
+10 KILL ^ASUMB(DA(1),1,"AC",DA_ASUMB("B/OQ"),DA)
+11 IF $GET(ASUMB("E#","REQ"))=""
KILL ASUMB(1)
+12 QUIT
SFAC ;EP ; SET FOR FACILITY
+1 NEW X,Y
+2 IF $GET(DA)=""
SET DA=$GET(ASUMB("E#","IDX"))
+3 IF $GET(DA(1))=""
SET DA=$GET(ASUMB("E#","REQ"))
+4 IF $GET(DA)=""
QUIT
IF $GET(DA(1))=""
QUIT
+5 IF '$DATA(ASUMB(1))
SET ASUMB(1)=^ASUMB(DA(1),1,DA,1)
+6 SET ^ASUMB("AC",DA,$PIECE(ASUMB(1),U,3),DA(1),DA)=""
+7 IF $GET(ASUMB("E#","IDX"))=""
KILL ASUMB
+8 QUIT
SAC ;EP ; SET FOR ACCOUNT
+1 NEW X,Y
+2 IF $GET(DA)=""
SET DA=$GET(ASUMB("E#","IDX"))
+3 IF $GET(DA(1))=""
SET DA=$GET(ASUMB("E#","REQ"))
+4 IF $GET(DA)=""
QUIT
IF $GET(DA(1))=""
QUIT
+5 IF '$DATA(ASUMB(1))
SET ASUMB(1)=^ASUMB(DA(1),1,DA,1)
+6 DO QTY
+7 SET ^ASUMB(DA(1),1,"AC",DA_ASUMB("B/OQ"),DA)=""
+8 IF $GET(ASUMB("E#","IDX"))=""
KILL ASUMB
+9 QUIT
QTY ;EP -GET PROPER LENGTH ON QUANTITY
+1 ;;This routine left zero fills the quantity being backored.
+2 SET X=$PIECE(ASUMB(1),U,4)*.000001
+3 IF $LENGTH($PIECE(X,".",2))<6
SET Y=1_$PIECE(X,".",2)
SET Y=Y*1000000
SET X="."_$EXTRACT(Y,2,7)
+4 SET ASUMB("B/OQ")=$TRANSLATE(X,".","*")
+5 QUIT
