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

ASUW2STO.m

Go to the documentation of this file. 
  1. ASUW2STO ; IHS/ITSC/LMH -EXTRACT TRANS-CVRT DDPS FORMAT ; 
  1.  ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
  1.  ;;This routine extracts SAMS transactions for export to STORES
  1.  G BEGIN
  1. MO(X) ;EP;
  1.  S ASUP("MO")=X
  1. BEGIN ;EP;FOR RE-EXTRACT
  1.  D:'$D(U) ^XBKVAR
  1.  I '$D(IO(0)) S IOP=$I D ^%ZIS
  1.  S ASUP("TYP")=$G(ASUP("TYP")) S:ASUP("TYP")']"" ASUP("TYP")=0
  1.  S ASUW("TY RUN")=^ASUSITE(1,0)
  1.  ;I $P(ASUW("TY RUN"),U,2)=8 G REXT2^ASUW2ST1
  1.  D:'$D(ASUK("DT","FM")) DATE^ASUUDATE
  1.  S ASUW("DT EXT")=ASUK("DT","FM")
  1.  K ^ASUPDATA ;DFM P1 8/28/98 - Blanket exception for AIB global?
  1. OPNHFS ;EP;FOR RE-EXTRACT
  1.  D TIME^ASUUDATE
  1.  S ASURX="W !,""S.A.M.S. Extract data for STORES Procedure Begun "_ASUK("DT","TIME")_"""" D ^ASUUPLOG
  1.  S ASUW("TY RUN")=^ASUSITE(1,0)
  1.  S ASUW("SV MED")=$P(ASUW("TY RUN"),U,9)
  1.  S ASUW("SV DIR")=$P(ASUW("SV MED"),":",2)
  1.  S ASUW("SV MED")=$P(ASUW("SV MED"),":")
  1.  S ASUL(1,"AR","WHSE")=$G(ASUL(1,"AR","WHSE"))
  1.  I ASUL(1,"AR","WHSE")<3 D ^ASUW2ST1
  1.  S ASUV("PADLN")=""
  1.  S (ASUC(0),ASUC("RECTOT"),ASUC("REC"),ASUC("TOTPRC"))=0
  1.  F ASUG("FL#")=1:1:7 D
  1.  .S ASUC(0)=ASUC(0)+1
  1.  .S ASUG("TRGBL")="^TMP(""ASUW"",$J,"_ASUG("FL#")_",",ASUG("PC#","TR")=1,ASUG("PC#","AR")=2,ASUW("FL","NM")=$P(^ASUT(ASUG("FL#"),0),U)
  1.  .S DIE="^ASUH"
  1.  .S ASURX="W !,""Now Processing "_ASUW("FL","NM")_" Records"",!"
  1.  .D ^ASUUPLOG
  1.  .D ASUW2ST7^ASUW2ST1
  1.  .F  S ASUHDA=$O(@ASUG("E#")) Q:ASUHDA=""  D  ;DFM P1 8/28/98
  1.  ..S DA=ASUHDA,ASUW("XTR-F")=1 ;DFM P1 8/28/98
  1.  ..I ASUL(1,"AR","WHSE")<3 D ASUWXT1
  1.  ..S ASUC("TOTPRC")=ASUC("TOTPRC")+1
  1.  .S ASUC(ASUG("FL#"))=ASUC("RECTOT")-ASUC("REC")
  1.  .S $P(^ASUL(30,ASUG("FL#"),0),U,5)=ASUC(ASUG("FL#")) ;DFM P1 8/28/98
  1.  .S $P(^ASUL(30,ASUG("FL#"),0),U,6)=ASUW("DT EXT") ;DFM P1 8/28/98
  1.  .S ASUC("REC")=ASUC("RECTOT")
  1.  .I ASUL(1,"AR","WHSE")<3 S ASURX="W !,"""_ASUW("FL","NM")_" Record Count : "","_$P(^ASUL(30,ASUG("FL#"),0),U,5) D ^ASUUPLOG
  1.  S ASURX="W !,*7,""Conversion Completed"",*7" D ^ASUUPLOG
  1.  S ASURX="W !,""Total records processed: "","_ASUC("TOTPRC") D ^ASUUPLOG
  1.  I ASUC("RECTOT")=0 D
  1.  .S ASURX="W !,""There were no current records converted"",*7,!"
  1.  .D ^ASUUPLOG
  1.  .I 1
  1.  E  D
  1.  .S ASURX="W !,""Total records converted "","_ASUC("RECTOT")
  1.  .D SETAREA^ASULARST
  1.  .S ^ASUPDATA(0)=$G(ASUK("ASUFAC"))_U_ASUL(1,"AR","NM")_U_ASUW("DT EXT")_U_ASUW("DT EXT")_U_ASUW("DT EXT")_U_U_ASUC("RECTOT")
  1.  .I ASUL(1,"AR","WHSE")<3 D
  1.  ..I ASUP("TYP") S $P(^ASUSITE(1,0),U,8)=ASUW("DT EXT") D LOGNTRY^ASUW2SAM(ASUP("MO"))
  1.  .E  D
  1.  ..S $P(^ASUSITE(1,0),U,8)=ASUW("DT EXT") D LOGNTRY^ASUW2SAM(ASUP("MO"))
  1.  .S XBMED=$S(ASUW("SV MED")]"":ASUW("SV MED"),1:"F") D ASUW2ST9^ASUW2ST1
  1.  I ($G(IOST)'["C-")&($G(ASUK("PTR-Q"))'=1) K DIR S DIR(0)="E" D ^DIR
  1.  D TIME^ASUUDATE
  1.  S ASURX="W !,""S.A.M.S. Extract data for DDPS Procedure Ended "_ASUK("DT","TIME")_"""" D ^ASUUPLOG
  1.  K ASUX,ASULA("X"),ASUU,ASUC,ASUG,ASUT,ASUF("TAPE"),XBGL,XBMED,XBUF
  1.  K DA,DR,DIE,DTOUT,DUOUT,DIROUT
  1.  K ^ASUW(4),^ASUW(5)
  1.  K:$G(ASUP("TYP"))="" ASUV,ASUW
  1.  Q
  1. ASUWXT1 ;Conversion sub-routine
  1.  S (ASUT("OUT"),ASUT(0),ASUW("FIL"))=""
  1.  S ASUG("TRN")=ASUG("TRGBL")_ASUHDA_"," ;DFM P1 8/28/98
  1.  S ASUG("TRN",ASUG("FL#"))=ASUG("TRN")_ASUG("FL#")_")"
  1.  S ASUG("TRN",1)=ASUG("TRN")_1_")"
  1.  S ASUG("TRN",0)=ASUG("TRN")_0_")"
  1.  S:ASUG("FL#")>1 ASUT(ASUG("FL#"))=$G(@ASUG("TRN",ASUG("FL#")))
  1.  S ASUT(0)=@ASUG("TRN",0)
  1.  S ASUT(1)=@ASUG("TRN",1)
  1.  I ASUL(1,"AR","AP")'=$P(ASUT(0),U,ASUG("PC#","AR")) S ASUW("XTR-F")=0 Q
  1.  S ASUT("TRCDE")=$P(ASUT(1),U)
  1.  Q:ASUT("TRCDE")="3J"
  1.  Q:ASUT("TRCDE")=""
  1.  I ASUT("TRCDE")="31" S ASUT("TRCDE")="32",$P(ASUT(1),U)=ASUT("TRCDE")
  1.  S ASUG("FLD","#")=0
  1.  F  S ASUG("FLD","#")=$O(^ASUL(30,ASUG("FL#"),1,1,1,ASUG("FLD","#"))) Q:ASUG("FLD","#")'?1N.N  D  ;DFM P1 8/28/98
  1.  .S ASUW("FLD","CTRL")=^ASUL(30,ASUG("FL#"),1,1,1,ASUG("FLD","#"),0) ;DFM P1 8/28/98
  1.  .S ASUW("FLD","NM")=$P(ASUW("FLD","CTRL"),U)
  1.  .S ASUW("FLD","STRT")=$P(ASUW("FLD","CTRL"),U,2)
  1.  .S ASUW("FLD","LEN","OUT")=$P(ASUW("FLD","CTRL"),U,3)
  1.  .S ASUW("PC#","FLD")=$P(ASUW("FLD","CTRL"),U,4)
  1.  .S ASUW("FLD","TY")=$P(ASUW("FLD","CTRL"),U,5)
  1.  .S ASUW("NODE")=$P(ASUW("FLD","CTRL"),U,6)
  1.  .D ASUWXT3
  1.  D UPDTHIST^ASUW2SAM ;DFM P1 8/28/96
  1.  S ASUC("RECTOT")=ASUC("RECTOT")+1
  1.  S ^ASUPDATA(ASUC("RECTOT"))="ST1"_U_ASUT("OUT")
  1.  S ASUT("OUT")=""
  1.  I $G(ASUK("PTR-Q"))=1 Q
  1.  S X=ASUC("RECTOT")#10
  1.  I X>0 Q
  1.  S X="",X=X_$J("",8-$L(ASUC("RECTOT")))_ASUC("RECTOT")
  1.  S ASURX="W *13,?30,"""_X_"""" D ^ASUUPLOG
  1.  Q
  1. ASUWXT3 ;Determine field Type
  1.  I ASUW("NODE")]"" D
  1.  .S ASUW("PCIN")=$P(ASUT(ASUW("NODE")),U,ASUW("PC#","FLD"))
  1.  E  D
  1.  .S ASUW("PCIN")=""
  1.  I ASUW("FLD","TY")']"" D ALPHA Q
  1.  I ASUW("FLD","TY")["D" D DATE Q
  1.  I ASUW("FLD","TY")["*" D DESC Q
  1.  I ASUW("FLD","TY")["V" D VALUE Q
  1.  I ASUW("FLD","TY")["A" D ALPHA Q
  1.  I ASUW("FLD","TY")["N" D NUM Q
  1.  I ASUW("FLD","TY")["B" D  Q
  1.  .I $E(ASUT("TRCDE"))=3 D
  1.  ..I ASUW("FLD","NM")]"SUB" D  Q
  1.  ...I $E(ASUT("TRCDE"),2)>3 S ASUW("PCIN")=""
  1.  .I ASUW("PCIN")]"" D NUM Q
  1.  .D ALPHA
  1.  D ALPHA
  1.  Q
  1. DATE ;FORMAT FROM VA FILEMAN DATE
  1.  I ASUW("FLD","TY")["4" D
  1.  .I ASUW("PCIN")?7N D  Q
  1.  ..I ASUW("FLD","NM")["EXPIRATION DATE" S ASUW("DT")=$E(ASUW("PCIN"),4,5)_$E(ASUW("PCIN"),2,3) Q
  1.  ..I ASUG("TRGBL")]"(5" S ASUW("DT")=$E(ASUW("PCIN"),2,3)_$E(ASUW("PCIN"),4,5) Q
  1.  ..S ASUW("DT")=$E(ASUW("PCIN"),4,5)_$E(ASUW("PCIN"),2,3)
  1.  .S ASUW("DT")="    "
  1.  E  D
  1.  .I $E(ASUT("TRCDE"))=3 D
  1.  ..I $E(ASUT("TRCDE"),2)?1A S ASUW("PCIN")="" Q
  1.  ..I $E(ASUT("TRCDE"),2)>3 S ASUW("PCIN")=""
  1.  .I ASUW("PCIN")?7N D  Q
  1.  ..S ASUW("DT")=$E(ASUW("PCIN"),4,5)_$E(ASUW("PCIN"),6,7)_$E(ASUW("PCIN"),2,3)
  1.  .S ASUW("DT")="      " Q
  1.  S ASUT("OUT")=ASUT("OUT")_ASUW("DT")
  1.  K ASUW("DT")
  1.  Q
  1. DESC ;DESCRIPTIONS
  1.  S ASUW("FLD","TY")=ASUW("FLD","TY")_"L"
  1.  I ASUW("FLD","TY")["2" D
  1.  .S ASUW("PCIN")=$P(ASUW("PCIN"),"*",2)
  1.  E  D
  1.  .S ASUW("PCIN")=$P(ASUW("PCIN"),"*")
  1. ALPHA ;FILL WITH SPACES
  1.  I ASUG("TRGBL")["(0",ASUW("FLD","NM")="SUB STATION",ASUW("PCIN")="PL" S ASUW("PCIN")=""
  1.  I ASUG("TRGBL")["(2",ASUW("FLD","NM")="FORP CODE",ASUW("PCIN")="P" S ASUW("PCIN")="F"
  1.  I ASUW("FLD","NM")["SUBOBJECT" S ASUW("PCIN")=$P(ASUW("PCIN"),".")_$P(ASUW("PCIN"),".",2)
  1.  I ASUW("FLD","TY")["L" D  ;LEFT JUSTIFY WITH SPACES
  1.  .S ASUW("FLD","LEN","IN")=$L(ASUW("PCIN"))
  1.  .S ASUW("FLD","LEN","PAD")=ASUW("FLD","LEN","OUT")-ASUW("FLD","LEN","IN")
  1.  .I ASUW("FLD","LEN","PAD")<0 D
  1.  ..S ASUW("PCIN")=$E(ASUW("PCIN"),1,ASUW("FLD","LEN","OUT")),ASUW("FIL")=""
  1.  .E  D
  1.  ..S ASUW("FIL")=$J("",ASUW("FLD","LEN","PAD"))
  1.  .S ASUT("OUT")=ASUT("OUT")_ASUW("PCIN")_ASUW("FIL")
  1.  E  D  ;RIGHT JUSTIFY WITH SPACES
  1.  .S ASUW("FIL")=$J(ASUW("PCIN"),ASUW("FLD","LEN","OUT"))
  1.  .S ASUT("OUT")=ASUT("OUT")_ASUW("FIL")
  1.  Q
  1. VALUE ;REMOVE DECIMAL PAD WITH ZEROS
  1.  I $E(ASUT("TRCDE"))=3 D
  1.  .I ASUW("FLD","NM")="VALUE" D  Q
  1.  ..I $E(ASUT("TRCDE"),2)'?1A S ASUW("PCIN")=""  ;Mainframe will compute it's own value on issues, but not reversal issues
  1.  I ASUW("FLD","LEN","OUT")=8 D  ;Value fields
  1.  .I ASUW("PCIN")'?1N.PN D
  1.  ..S ASUW("VAL")="        "
  1.  .E  D
  1.  ..S X=ASUW("PCIN")*.000001,X=$FN(X,"T",8),X=$P(X,".",2),ASUW("VAL")=$E(X,1,8)
  1.  E  D  ;Unit price fields
  1.  .I ASUW("FLD","LEN","OUT")=6 D
  1.  ..I ASUW("PCIN")'?1N.PN D
  1.  ...S ASUW("VAL")="      "
  1.  ..E  D
  1.  ...S X=ASUW("PCIN")*.0001,X=$FN(X,"T",6),X=$P(X,".",2),ASUW("VAL")=$E(X,1,6)
  1.  .E  D
  1.  ..I ASUW("PCIN")'?1N.PN D
  1.  ...S ASUW("VAL")="       "
  1.  ..E  D
  1.  ...S X=ASUW("PCIN")*.00001,X=$FN(X,"T",6),X=$P(X,".",2),ASUW("VAL")=$E(X,1,6)
  1.  S ASUT("OUT")=$G(ASUT("OUT"))_ASUW("VAL")
  1.  K ASUW("VAL")
  1.  Q
  1. NUM ;FILL WITH ZEROS
  1.  I ASUW("FLD","NM")["VOUCH" S ASUW("PCIN")=$TR(ASUW("PCIN"),"-")
  1.  I ASUG("FL#")=4,ASUT("TRCDE")'["D",ASUW("FLD","NM")="ACCOUNT" D
  1.  .S:ASUW("PCIN")'="1" $P(ASUT(4),U,4)="" Q
  1.  .S ASUT("CAT")=$P(ASUT(4),U,4)
  1.  .I ASUT("CAT")'="N"&(ASUT("CAT")'="R") S $P(ASUT(4),U,4)="0"
  1.  .K ASUT("CAT")
  1.  S ASUW("ZROS")=""
  1.  S ASUW("FLD","LEN","IN")=$L(ASUW("PCIN"))
  1.  I ASUW("FLD","LEN","IN")<ASUW("FLD","LEN","OUT") D
  1.  .S ASUU(12)=ASUW("FLD","LEN","OUT")-ASUW("FLD","LEN","IN")
  1.  .F ASUU(10)=1:1:ASUU(12) D
  1.  ..S ASUW("ZROS")=ASUW("ZROS")_0
  1.  ..I ASUU(10)=ASUU(12) S ASUW("PCIN")=ASUW("ZROS")_ASUW("PCIN")
  1.  ;WAR 10/13/99 added next line for Stat. Mst records (5's) remove "."
  1.  I ASUW("FLD","NM")["LEAD TIME MONTHS" S ASUW("PCIN")=$TR(ASUW("PCIN"),".")
  1.  ;WAR 10/13/99 added next line for Index Mst records (4's) remove "."
  1.  I ASUW("FLD","NM")["OBJECT SUB OBJECT" S ASUW("PCIN")=$TR(ASUW("PCIN"),".")
  1.  I ASUG("TRGBL")["ASUT(2",ASUW("FLD","NM")="FORP CODE",ASUW("PCIN")["F" S ASUW("PCIN")=""
  1.  I ASUW("FLD","TY")["L" S ASUT("OUT")=ASUT("OUT")_ASUW("PCIN")_ASUW("ZROS") Q
  1.  S ASUT("OUT")=ASUT("OUT")_ASUW("PCIN") S ASUW("ZROS")=""
  1.  Q