Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ASUMBOIO

ASUMBOIO.m

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