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