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

ASU4XUPD.m

Go to the documentation of this file. 
  1. ASU4XUPD ; IHS/ITSC/LMH -POST INDEX ITEM ; 
  1.  ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
  1.  ;This routine provides logic to add, change and delete SAMS INDEX
  1.  ;master records to/from the database
  1.  S:$G(DDSREFT)']"" DDSREFT=$G(ASUV("DDSREFT"))
  1.  I $E(ASUT,3)="A" D
  1.  .D DIX^ASUMDIRA(.ASUT) ;Add Index Master
  1.  .S DIE=9002036.4
  1.  .;B
  1.  .D PUT^DDSVAL(DIE,.DA,.05,ASUT(ASUT,"PT","IDX"),"","I")
  1.  .;D WRITE^ASUMXDIO ;Update Index Master from Variables
  1.  I $E(ASUT,3)="C" D
  1.  .S:ASUT(ASUT,"DTS")]"" ASUMX("ESTB")=ASUT(ASUT,"DTS")
  1.  .S:ASUT(ASUT,"DESC")]"" ASUMX("DESC")=ASUT(ASUT,"DESC")
  1.  .S:ASUT(ASUT,"AR U/I")]"" ASUMX("AR U/I")=ASUT(ASUT,"AR U/I")
  1.  .S:ASUT(ASUT,"NSN")]"" ASUMX("NSN")=ASUT(ASUT,"NSN")
  1.  .S:ASUT(ASUT,"BCD")]"" ASUMX("BCD")=ASUT(ASUT,"BCD")
  1.  .I ASUT(ASUT,"ACC")]"" D
  1.  ..I ASUMX("ACC")'=ASUT(ASUT,"ACC") D
  1.  ...D ACCHANGE S ASUMX("ACC")=ASUT(ASUT,"ACC")
  1.  .E  D
  1.  ..S ASUT(ASUT,"ACC")=ASUMX("ACC")
  1.  .S:ASUT(ASUT,"SOBJ")]"" ASUMX("SOBJ")=ASUT(ASUT,"SOBJ")
  1.  .S:ASUT(ASUT,"CAT")]"" ASUMX("CAT")=ASUT(ASUT,"CAT")
  1.  .D WRITE^ASUMXDIO ;Update Index Master from Variables
  1.  I $E(ASUT,3)="D" D
  1.  .S ASUT(ASUT,"ACC")=ASUMX("ACC")
  1.  .S ASUMX("DELDS")=ASUMX("DESC")
  1.  .S ASUMX("DELDT")=ASUK("DT","FM")
  1.  .S ASUMS("E#","STA")=0,ASUMX("DELIX")=ASUMX("IDX"),ASUMX("IDX")=999999
  1.  .S:ASUMX("DELDS")']"" ASUMX("DELDS")=$P(ASUMX(2),U,2)
  1.  .K ^ASUMX("B",ASUMX("DELIX"),ASUMX("E#","IDX"))
  1.  .K ^ASUMX("S",ASUMX("DELDS"),ASUMX("E#","IDX"))
  1.  .S ASUMX("DESC")=""
  1.  .D WRITE^ASUMXDIO ;Update Index Master
  1.  D ^ASUJHIST ;Move transaction to History file
  1.  Q
  1. XSSO ;EP;Stock Sub Object table
  1.  N DIC
  1.  S:$D(ASUL(9,"ACC")) DIC("S")="I $P(^(0),U,2)=ASUL(9,""ACC"")" D XTBL^ASUJHELP(3) Q
  1.  S DDSERROR=1 Q
  1. CKDELSTA ;EP;
  1.  F  S ASUMS("E#","STA")=$O(^ASUMS(ASUMS("E#","STA"))) Q:ASUMS("E#","STA")=""  D  Q:$D(DDSERROR)  ;Loop through all Stations
  1.  .I $G(^ASUMS(ASUMS("E#","STA"),1,ASUMX("E#","IDX"),0))']"" Q  ;Index being deleted not used by this station
  1.  .I $P(^ASUMS(ASUMS("E#","STA"),1,ASUMX("E#","IDX"),0),U)[999999 Q
  1.  .;Index record still being used by this station
  1.  .W *7 D MSG^ASUJHELP("Delete Unsucessful - STATION MASTER ON FILE") S DDSERROR=1 ;DSD P1 9/1/98
  1.  Q
  1. REUSEIX ;
  1.  ;;This sub routine is involked whenever a new INDEX MASTER is being
  1.  ;;added.  It checks to see if the Index Number being assigned has
  1.  ;;previously been used and the item deleted.  In that case and it has
  1.  ;;been 3 years or more since the number was used, it may be re-assigned
  1.  ;;to the new item.  Otherwise, the add is rejected and must be
  1.  ;;redone using a different index number.
  1.  I ASUK("DT","YRMO")<$P(^ASUMX(ASUMX("E#","IDX"),2),U,3)+30000 D  Q
  1.  .;Old Index number has not expired -must wait 3 years after deletion
  1.  .W *7 D MSG^ASUJHELP("Delete Unsucessful DEL INDEX not expired (less than 3 years since deleted)") ;DFM P1 9/1/98
  1.  .S DDSERROR=2
  1.  ;Old Index number may be re-used for new item
  1.  K DA
  1.  ;Remove old entry for Index # in Index Master
  1.  S (DA,Y)=ASUMX("E#","IDX"),DIK="^ASUMX(" D ^DIK
  1.  ;Remove old entries for Index # in Station Masters
  1.  ;DA(1) (Station IEN) Will be pointer to Station table: format
  1.  ;    2 digit accounting point and (Stop loop if not correct area)
  1.  ;    3 digit station code
  1.  ;    total 5 digits
  1.  S DA(1)=0
  1.  F  S DA(1)=$O(^ASUMS(DA(1))) Q:DA(1)'?5N  Q:$E(DA(1),1,2)'=ASUL(1,"AR","AP")  D
  1.  .S DIK="^ASUMS("_DA(1)_"," D ^DIK
  1.  ;Remove old entries for Index # in Issue Book (Requsitioner) Masters
  1.  ;DA(1) (Requsitioner IEN) Will be pointer to Requsitioner table: format
  1.  ;    2 digit accounting point (Stop loop if not correct area)
  1.  ;    3 digit station code and
  1.  ;    4 digit User code (run through algorythm)
  1.  ;    total 9 digits
  1.  S DA(1)=0
  1.  F  S DA(1)=$O(^ASUMK(DA(1))) Q:DA(1)'?9N  Q:$E(DA(1),1,2)'=ASUL(1,"AR","AP")  D
  1.  .S DIK="^ASUMK("_DA(1)_"," D ^DIK
  1.  ;Although the Back Order file also points to the Index Master, It is
  1.  ;being assumed that the old Index number could not have been deleted
  1.  ;if there were still backorders against it, so no effort will be made
  1.  ;to check for and delete items in that file with this Index # IEN
  1.  Q
  1. ACCHANGE ;
  1.  ;;This sub routine generates  ADJUSTMENT transactions based on
  1.  ;;an INDEX MASTER CHANGE transaction which changes the account code.
  1.  ;;The adjustments are required to move the related STATION MASTER
  1.  ;;record balances from one account to another.
  1.  S ASUSV("STA")=$G(ASUMS("STA"))
  1.  F  S ASUV("STA")=$O(^ASUMS("B",$G(ASUV("STA")))) Q:ASUV("STA")=""  S ASUMS("E#","STA")=$O(^ASUMS("B",ASUV("STA"),"")) D L3727
  1.  S ASUV("STA")=ASUSV("STA")
  1.  Q
  1. L3727 ;
  1.  S ASUMS("E#","IDX")=ASUMX("E#","IDX")
  1.  S ASUMS(0)=$G(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"),0))
  1.  Q:ASUMS(0)']""
  1.  D MI^ASUMSTRD
  1.  S ASUV("QTY",1)=ASUMS("QTY","O/H")
  1.  S ASUV("QTY",2)=ASUMS("D/I","QTY-TOT"),ASUV("QTY",3)=ASUV("QTY",2)*-1
  1.  S ASUT("GAJ","AR")=ASUT(ASUT,"AR")
  1.  S ASUT("GAJ","STA")=$E(ASUV("STA"),4,5)
  1.  S ASUT("GAJ","IDX")=ASUT(ASUT,"IDX")
  1.  S ASUT("GAJ","ACC")=ASUT(ASUT,"ACC")
  1.  S ASUT("GAJ","QTY")=ASUMS("QTY","O/H")
  1.  S ASUT("GAJ","VAL")=ASUMS("VAL","O/H")
  1.  S ASUT("GAJ","VOU")=$E(ASUK("DT","FYMO"),1,2)_$E(ASUK("DT","FYMO"),3,4)_"2737"
  1.  S (ASUSV("TRCD"),ASUT("TRCD"))="27"
  1.  S ASUM("TRTYP")="REGULAR"
  1.  S ASUT="GAJ"
  1.  S ASUT("GAJ","ACC")=ASUMX("ACC")
  1.  S (ASUSV("TRCD"),ASUT("TRCD"))="37",ASUV("QTY",2)=ASUV("QTY",3)
  1.  S ASUT="IXC"
  1.  K ASUT("GAJ"),ASUV("QTY")
  1.  D MIKF^ASUMSTRD
  1.  S (ASUSV("TRCD"),ASUT("TRCD"))="4C"
  1.  Q
  1. CKIDX ;
  1.  I Y=-9 D REUSEIX Q:$G(Y)=-9  Q:$D(DDSERROR)
  1.  Q