ASUJBTCH ; IHS/ITSC/LMH -SCREENMAN FOR DATA ENTRY ; [ 07/17/2000 9:10 AM ]
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine will be used to process transactions already entred
D:'$D(U) ^XBKVAR D:'$D(ASUK) ^ASUVAR I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) Q
I $G(ASUL(1,"AR","STA1"))]"" D
.D STA^ASULARST(ASUL(1,"AR","STA1"))
.W !!,"Process transactions for Station: ",ASUL(2,"STA","NM")," - Code: ",ASUL(2,"STA","CD"),!
S ASUSB=1
F ASUJ=4,5 W !,"Processing ",$P(^ASUT(ASUJ,0),U)," Master Add transactions" D
.D PTRSET(ASUJ)
.S ASUV("E#")=0 I '$D(^ASUT(ASUJ,"C","Y")) S ASUC("TRN")=0 D DCOUNT Q
.F ASUC("TRN")=0:1 S ASUV("E#")=$O(^ASUT(ASUJ,"C","Y",ASUV("E#"))) Q:ASUV("E#")']"" D
..S ASUT=0,ASUHDA=ASUV("E#") D TRRD Q:$G(ASUT)']"" D
...I ASUT("TRCD")["A" D
....D UPDT
...E D
....S ASUC("TRN")=$G(ASUC("TRN"))-1
.D DCOUNT
F ASUJ=4,5 W !,"Processing ",$P(^ASUT(ASUJ,0),U)," Master Change transactions" D
.S ASUV("E#")=0 I '$D(^ASUT(ASUJ,"C","Y")) S ASUC("TRN")=0 D DCOUNT Q
.F ASUC("TRN")=0:1 S ASUV("E#")=$O(^ASUT(ASUJ,"C","Y",ASUV("E#"))) Q:ASUV("E#")']"" D
..S ASUT=0,ASUHDA=ASUV("E#") D TRRD Q:$G(ASUT)']"" D
...I ASUT("TRCD")["C" D
....D UPDT
...E D
....S ASUC("TRN")=$G(ASUC("TRN"))-1
.D DCOUNT
F ASUJ=5 W !,"Processing ",$P(^ASUT(ASUJ,0),U)," Station User Level Change transactions" D
.S ASUV("E#")=0 I '$D(^ASUT(ASUJ,"C","Y")) S ASUC("TRN")=0 D DCOUNT Q
.F ASUC("TRN")=0:1 S ASUV("E#")=$O(^ASUT(ASUJ,"C","Y",ASUV("E#"))) Q:ASUV("E#")']"" D
..S ASUT=0,ASUHDA=ASUV("E#") D TRRD Q:$G(ASUT)']"" D
...I ASUT("TRCD")["B" D
....D UPDT
...E D
....S ASUC("TRN")=$G(ASUC("TRN"))-1
.D DCOUNT
F ASUJ=1,2,3,6,7 D PTRSET(ASUJ)
F ASUJ1=1,"2T",2,6,"3T",3,7 S ASUJ=$E(ASUJ1) W !,"Processing ",$P(^ASUT(ASUJ,0),U),$S($E(ASUJ1,2)="T":" Transfer ",1:"")," Debit transactions" D
.S ASUV("E#")=0 I '$D(^ASUT(ASUJ,"C","Y")) S ASUC("TRN")=0 D DCOUNT Q
.F ASUC("TRN")=0:1 S ASUV("E#")=$O(^ASUT(ASUJ,"C","Y",ASUV("E#"))) Q:ASUV("E#")']"" D
..S ASUT=0,ASUHDA=ASUV("E#") D TRRD Q:$G(ASUT)']"" D
...I ASUJ1="2T",ASUL(11,"TRN","TYPE")'=8 S ASUC("TRN")=$G(ASUC("TRN"))-1 Q
...I ASUJ1="3T",ASUL(11,"TRN","TYPE")'=9 S ASUC("TRN")=$G(ASUC("TRN"))-1 Q
...I ASUT(ASUT,"SIGN")=1 D
....D UPDT
...E D
....S ASUC("TRN")=$G(ASUC("TRN"))-1
.D DCOUNT
F ASUJ1=1,"2T",2,6,"3T","3I",3,7 S ASUJ=$E(ASUJ1) W !,"Processing ",$P(^ASUT(ASUJ,0),U),$S($E(ASUJ1,2)="T":" Transfer ",$E(ASUJ1,2)="I":" Post Posted ",1:"")," Credit transactions" D
.I ASUJ1="3T"
.S ASUV("E#")=0 I '$D(^ASUT(ASUJ,"C","Y")) S ASUC("TRN")=0 D DCOUNT Q
.F ASUC("TRN")=0:1 S ASUV("E#")=$O(^ASUT(ASUJ,"C","Y",ASUV("E#"))) Q:ASUV("E#")']"" D
..S ASUT=0,ASUHDA=ASUV("E#") D TRRD Q:$G(ASUT)']"" D
...I ASUJ1="2T",ASUL(11,"TRN","TYPE")'=8 S ASUC("TRN")=$G(ASUC("TRN"))-1 Q
...I ASUJ1="3T",ASUL(11,"TRN","TYPE")'=9 S ASUC("TRN")=$G(ASUC("TRN"))-1 Q
...I ASUJ1="3I",ASUT(ASUT,"PST")'="I" S ASUC("TRN")=$G(ASUC("TRN"))-1 Q
...I ASUT(ASUT,"SIGN")=-1 D
....D UPDT
...E D
....S ASUC("TRN")=$G(ASUC("TRN"))-1
.D DCOUNT
F ASUJ=5,4 W !,"Processing ",$P(^ASUT(ASUJ,0),U)," Master Delete transactions" D
.S ASUV("E#")=0 I '$D(^ASUT(ASUJ,"C","Y")) S ASUC("TRN")=0 D DCOUNT Q
.F ASUC("TRN")=0:1 S ASUV("E#")=$O(^ASUT(ASUJ,"C","Y",ASUV("E#"))) Q:ASUV("E#")']"" D
..S ASUT=0,ASUHDA=ASUV("E#") D TRRD Q:$G(ASUT)']"" D
...I ASUT("TRCD")["D" D
....D UPDT
...E D
....S ASUC("TRN")=$G(ASUC("TRN"))-1
.D DCOUNT
W !!,$FN(ASUC("TOT"),",")," Total Records processed."
K ASUC,ASUT,ASUJ,ASUMX,ASUMS,ASUMK,ASUV
Q
DCOUNT ;
W !?15," Count=",$J($FN(ASUC("TRN"),","),10) S ASUC("TOT")=$G(ASUC("TOT"))+ASUC("TRN")
Q
UPDT ;EP ;Update masters
S ASUJ("RTN")=ASUJ_$E($G(ASUT),1,2)
I $G(ASUJ)']""!($G(ASUT)']"")!($G(ASUT("TRCD"))']"") S ASUC("TRN")=$G(ASUC("TRN"))-1 Q
S ASUV("ASUT")=ASUT,ASUV("TRCD")=ASUT("TRCD")
S ASUJ("FILE")=9002036_"."_ASUJ
S ASUJ("GLOB")="^ASUT("_ASUJ_","
S DIE="9002036."_ASUJ,DA=ASUHDA
W !?5,ASUHDA," ",ASUT("TRCD"),$J($G(ASUT(ASUT,"IDX")),8),$J($G(ASUT(ASUT,"VOU")),12),!," Editing:"
D CKFLD
I $G(DDSSAVE)=1 D
.S DDSSAVE=""
.I ASUJ=1 D ^ASU1DUPD Q
.I ASUJ=2 D ^ASU2RUPD Q
.I ASUJ=3 D Q
..I $E(ASUT("TRCD"),2)?1N D
...I ASUT("TRCD")=32 D ^ASU3IUPD Q
...I ASUT("TRCD")=33 D ^ASU3IUPD Q
...D TXFIS^ASU3IUPD
..E D
...D RVIS^ASU3IUPD
.I ASUJ=4 D ^ASU4XUPD Q
.I ASUJ=5 D ^ASU5SUPD Q
.I ASUJ=6 D ^ASU6JUPD Q
.I ASUJ=7 D ^ASU7DUPD
E D
.I $G(E)=0 Q
.D MREJ K E,DDSERROR S DDSSAVE=0,DDSERROR=99
I $G(ASUF("ERR"))>0 S DDSSAVE=0,DDSERROR=ASUF("ERR")
E S DDSSAVE=1
I $G(DDSSAVE)=1 W " UDOK"
E W " NOUD" Q:DDSERROR=99 D MREJ
S DDSSAVE=0 K E,Z,DDSERROR,ASUF("ERR")
Q
MREJ ;
S X=ASUJ("GLOB")_ASUHDA_")" M ^ASUTR(ASUJ,ASUHDA)=@(X)
W !?5,"Reject/move to ^ASUTR ERR=",$G(DDSERROR)
S DIK=ASUJ("GLOB"),DA=ASUHDA D ^DIK
Q
TRRD ;EP ;Read transactions
D READ^ASU0TRRD(.ASUHDA,.ASUJ) Q
Q
PTRSET(F) ;
N C,R
S R=0 F C=1:1 S R=$O(^ASUT(F,R)) Q:R'?1N.N D
.D READ^ASU0TRRD(R,F)
.D WRITE^ASU0TRWR(R,F)
Q
CKFLD ;EP ;Validate fields for batch processing
;N E I ASUT(ASUT,"AR")=ASUL(1,"AR","AP"),ASUT(ASUT,"STA")=ASUL(2,"STA","CD") D
N E I ASUT(ASUT,"AR")=ASUL(1,"AR","AP") D
.D @(ASUJ)
.I $G(E)>0 D
..S DDSSAVE=0 W " EDBD"
.E D
..S DDSSAVE=1 W " EDOK"
E D
.W " Transaction not for YOUR Area/Station - Not Edited" S DDSSAVE=0,E=0
Q
1 ;Due in validation
N F,M,P,R,X
S M="E" F P="R^IDX","R^PON","R^QTY","R^VAL" D VLD(.P) Q:$G(E)>0
Q:$G(E)>0
S M="R",P="R^SSA" D VLD(.P) Q:$G(E)>0
S M="D",P="R^DTE" D VLD(.P)
Q
2 ;Receipt validation
N F,M,P,R,X
S M="E" F P="R^VOU",$S(ASUT("TRCD")=22:"R",1:"")_"^PON","R^QTY","R^VAL","R^FPN" D VLD(.P) Q:$G(E)>0
Q:$G(E)>0
S M="R",P="R^SSA" D VLD(.P) Q:$G(E)>0
S M="F",P="R^SRC" D VLD(.P) Q:$G(E)>0
S M="D" F P="^DTX","R^DTE" D VLD(.P) Q:$G(E)>0
Q
3 ;Issue validation
N F,M,P,R,X
S M="E" F P="R^IDX","R^VOU","^PST","R^QTYR",$S($E(ASUT("TRCD"),2)=2:"R",1:"")_"^FPN","^RTP" D VLD(.P) Q:$G(E)>0
Q:$G(E)>0
S M="R" F P="R^SST","R^USR" D VLD(.P) Q:$G(E)>0
Q:$G(E)>0
S M="AN" F F="^CTG","^RQN" D VLD(.P) Q:$G(E)>0
Q:$G(E)>0
S M="D",P="R^DTE" D VLD(.P)
Q
4 ;Index validation
N F,M,P,R,X
S M="E" F P="R^IDX","A^NSN" D VLD(.P) Q:$G(E)>0
Q:$G(E)>0
S M="F" F P="C^ACC","A^SSO","A^CAT" D VLD(.P) Q:$G(E)>0
Q:$G(E)>0
S M="N",P="^BCD" D VLD(.P) Q:$G(E)>0
S M="A",P="^AUI" D VLD(.P) Q:$G(E)>0
S M="A",P="A^DESC" D VLD(.P) Q:$G(E)>0
S M="D",P="R^DTE" D VLD(.P)
Q
5 ;Station validation
N F,M,P,R,X
S M="E" F P="R^IDX","^VEN","^ORD","A^EOQ" D VLD(.P) Q:$G(E)>0
Q:$G(E)>0
S M="F",P="A^SRC" D VLD(.P) Q:$G(E)>0
S M="R",P="^SLC" D VLD(.P) Q:$G(E)>0
I ASUT("TRCD")="5B" D Q:$G(E)>0
.S M="R" F P="R^SST","R^USR" D VLD(.P) Q:$G(E)>0
.S M="N",P="R^ULQ" D VLD(.P)
S M="A",P="^SUI" D VLD(.P) Q:$G(E)>0
S M="N" F P="A^UCS","^LTM","^SPQ","A^RPQ" D VLD(.P) Q:$G(E)>0
Q:$G(E)>0
S M="D",P="R^DTE" D VLD(.P)
Q
6 ;Adjustment validation
N F,M,P,R,X
S M="E" F P="R^IDX","R^VOU" D VLD(.P) Q:$G(E)>0
Q:$G(E)>0
S M="N" F P="^QTY","^VAL" D VLD(.P) Q:$G(E)>0
Q:$G(E)>0
S M="D",P="R^DTE" D VLD(.P)
Q
7 ;Direct Issue validation
N F,M,P,R,X
S M="E" F P="^PON","R^VOU" D VLD(.P) Q:$G(E)>0
Q:$G(E)>0
S M="R" F P="R^SST","R^USR" D VLD(.P) Q:$G(E)>0
Q:$G(E)>0
S M="F" F P="R^ACC","R^DSO","^SRC" D VLD(.P) Q:$G(E)>0
Q:$G(E)>0
S M="N" F P="R^QTY","R^VAL" D VLD(.P) Q:$G(E)>0
Q:$G(E)>0
S M="D",P="R^DTE" D VLD(.P)
Q
VLD(P) ;
S F=$P(P,U,2),R=$P(P,U) I R="A" S R=$S($E(ASUT("TRCD"),2)="A":"R",1:"")
S X=$G(ASUT(ASUT,$S(F="SSO":"SOBJ",F="DSO":"SOBJ",F="EOQ":"EOQ TYP",1:F)))
I F="QTYR" S X=ASUT(ASUT,"QTY","REQ")
I X']"" D Q
.I R="R" S E="1^"_F_" a required field is null" W " #",$P(E,U,2),! Q
.W " *",F
D VLDF(.M,.F,.X)
Q
VLDF(M,F,X) ;Validate and save field
N Z I $G(ASUSB)=1 W " ",F
I ASUJ<7,ASUT("TRCD")'="4A",$G(ASUT(ASUT,"PT","IDX"))]"" S ASUMS("E#","IDX")=ASUT(ASUT,"PT","IDX") D ^ASUMXDIO
I ASUJ<7,ASUJ'=4,ASUT("TRCD")'="5A",$G(ASUT(ASUT,"PT","STA"))]"",$G(ASUMS("E#","IDX"))]"",$G(^ASUMX(ASUMS("E#","IDX"),0)) S ASUMS("E#","STA")=$G(ASUL("ST#")) D ^ASUMSTRD
S DDSERROR=""
;I $G(ASUMS("E#","IDX"))&'$G(^ASUMX(ASUMS("E#","IDX"),0)) S M="E" ;CSC
I M="E" D
.S Z="D "_F_"^ASUJVALF(.X,.DDSERROR)" X Z
E D
.S Z="D EN^ASUJVALD(.X,.DDSERROR,.F,.M)" X Z
S E=$G(DDSERROR)
Q
ASUJBTCH ; IHS/ITSC/LMH -SCREENMAN FOR DATA ENTRY ; [ 07/17/2000 9:10 AM ]
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine will be used to process transactions already entred
+3 IF '$DATA(U)
DO ^XBKVAR
IF '$DATA(ASUK)
DO ^ASUVAR
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))
QUIT
+4 IF $GET(ASUL(1,"AR","STA1"))]""
Begin DoDot:1
+5 DO STA^ASULARST(ASUL(1,"AR","STA1"))
+6 WRITE !!,"Process transactions for Station: ",ASUL(2,"STA","NM")," - Code: ",ASUL(2,"STA","CD"),!
End DoDot:1
+7 SET ASUSB=1
+8 FOR ASUJ=4,5
WRITE !,"Processing ",$PIECE(^ASUT(ASUJ,0),U)," Master Add transactions"
Begin DoDot:1
+9 DO PTRSET(ASUJ)
+10 SET ASUV("E#")=0
IF '$DATA(^ASUT(ASUJ,"C","Y"))
SET ASUC("TRN")=0
DO DCOUNT
QUIT
+11 FOR ASUC("TRN")=0:1
SET ASUV("E#")=$ORDER(^ASUT(ASUJ,"C","Y",ASUV("E#")))
IF ASUV("E#")']""
QUIT
Begin DoDot:2
+12 SET ASUT=0
SET ASUHDA=ASUV("E#")
DO TRRD
IF $GET(ASUT)']""
QUIT
Begin DoDot:3
+13 IF ASUT("TRCD")["A"
Begin DoDot:4
+14 DO UPDT
End DoDot:4
+15 IF '$TEST
Begin DoDot:4
+16 SET ASUC("TRN")=$GET(ASUC("TRN"))-1
End DoDot:4
End DoDot:3
End DoDot:2
+17 DO DCOUNT
End DoDot:1
+18 FOR ASUJ=4,5
WRITE !,"Processing ",$PIECE(^ASUT(ASUJ,0),U)," Master Change transactions"
Begin DoDot:1
+19 SET ASUV("E#")=0
IF '$DATA(^ASUT(ASUJ,"C","Y"))
SET ASUC("TRN")=0
DO DCOUNT
QUIT
+20 FOR ASUC("TRN")=0:1
SET ASUV("E#")=$ORDER(^ASUT(ASUJ,"C","Y",ASUV("E#")))
IF ASUV("E#")']""
QUIT
Begin DoDot:2
+21 SET ASUT=0
SET ASUHDA=ASUV("E#")
DO TRRD
IF $GET(ASUT)']""
QUIT
Begin DoDot:3
+22 IF ASUT("TRCD")["C"
Begin DoDot:4
+23 DO UPDT
End DoDot:4
+24 IF '$TEST
Begin DoDot:4
+25 SET ASUC("TRN")=$GET(ASUC("TRN"))-1
End DoDot:4
End DoDot:3
End DoDot:2
+26 DO DCOUNT
End DoDot:1
+27 FOR ASUJ=5
WRITE !,"Processing ",$PIECE(^ASUT(ASUJ,0),U)," Station User Level Change transactions"
Begin DoDot:1
+28 SET ASUV("E#")=0
IF '$DATA(^ASUT(ASUJ,"C","Y"))
SET ASUC("TRN")=0
DO DCOUNT
QUIT
+29 FOR ASUC("TRN")=0:1
SET ASUV("E#")=$ORDER(^ASUT(ASUJ,"C","Y",ASUV("E#")))
IF ASUV("E#")']""
QUIT
Begin DoDot:2
+30 SET ASUT=0
SET ASUHDA=ASUV("E#")
DO TRRD
IF $GET(ASUT)']""
QUIT
Begin DoDot:3
+31 IF ASUT("TRCD")["B"
Begin DoDot:4
+32 DO UPDT
End DoDot:4
+33 IF '$TEST
Begin DoDot:4
+34 SET ASUC("TRN")=$GET(ASUC("TRN"))-1
End DoDot:4
End DoDot:3
End DoDot:2
+35 DO DCOUNT
End DoDot:1
+36 FOR ASUJ=1,2,3,6,7
DO PTRSET(ASUJ)
+37 FOR ASUJ1=1,"2T",2,6,"3T",3,7
SET ASUJ=$EXTRACT(ASUJ1)
WRITE !,"Processing ",$PIECE(^ASUT(ASUJ,0),U),$SELECT($EXTRACT(ASUJ1,2)="T":" Transfer ",1:"")," Debit transactions"
Begin DoDot:1
+38 SET ASUV("E#")=0
IF '$DATA(^ASUT(ASUJ,"C","Y"))
SET ASUC("TRN")=0
DO DCOUNT
QUIT
+39 FOR ASUC("TRN")=0:1
SET ASUV("E#")=$ORDER(^ASUT(ASUJ,"C","Y",ASUV("E#")))
IF ASUV("E#")']""
QUIT
Begin DoDot:2
+40 SET ASUT=0
SET ASUHDA=ASUV("E#")
DO TRRD
IF $GET(ASUT)']""
QUIT
Begin DoDot:3
+41 IF ASUJ1="2T"
IF ASUL(11,"TRN","TYPE")'=8
SET ASUC("TRN")=$GET(ASUC("TRN"))-1
QUIT
+42 IF ASUJ1="3T"
IF ASUL(11,"TRN","TYPE")'=9
SET ASUC("TRN")=$GET(ASUC("TRN"))-1
QUIT
+43 IF ASUT(ASUT,"SIGN")=1
Begin DoDot:4
+44 DO UPDT
End DoDot:4
+45 IF '$TEST
Begin DoDot:4
+46 SET ASUC("TRN")=$GET(ASUC("TRN"))-1
End DoDot:4
End DoDot:3
End DoDot:2
+47 DO DCOUNT
End DoDot:1
+48 FOR ASUJ1=1,"2T",2,6,"3T","3I",3,7
SET ASUJ=$EXTRACT(ASUJ1)
WRITE !,"Processing ",$PIECE(^ASUT(ASUJ,0),U),$SELECT($EXTRACT(ASUJ1,2)="T":" Transfer ",$EXTRACT(ASUJ1,2)="I":" Post Posted ",1:"")," Credit transactions"
Begin DoDot:1
+49 IF ASUJ1="3T"
+50 SET ASUV("E#")=0
IF '$DATA(^ASUT(ASUJ,"C","Y"))
SET ASUC("TRN")=0
DO DCOUNT
QUIT
+51 FOR ASUC("TRN")=0:1
SET ASUV("E#")=$ORDER(^ASUT(ASUJ,"C","Y",ASUV("E#")))
IF ASUV("E#")']""
QUIT
Begin DoDot:2
+52 SET ASUT=0
SET ASUHDA=ASUV("E#")
DO TRRD
IF $GET(ASUT)']""
QUIT
Begin DoDot:3
+53 IF ASUJ1="2T"
IF ASUL(11,"TRN","TYPE")'=8
SET ASUC("TRN")=$GET(ASUC("TRN"))-1
QUIT
+54 IF ASUJ1="3T"
IF ASUL(11,"TRN","TYPE")'=9
SET ASUC("TRN")=$GET(ASUC("TRN"))-1
QUIT
+55 IF ASUJ1="3I"
IF ASUT(ASUT,"PST")'="I"
SET ASUC("TRN")=$GET(ASUC("TRN"))-1
QUIT
+56 IF ASUT(ASUT,"SIGN")=-1
Begin DoDot:4
+57 DO UPDT
End DoDot:4
+58 IF '$TEST
Begin DoDot:4
+59 SET ASUC("TRN")=$GET(ASUC("TRN"))-1
End DoDot:4
End DoDot:3
End DoDot:2
+60 DO DCOUNT
End DoDot:1
+61 FOR ASUJ=5,4
WRITE !,"Processing ",$PIECE(^ASUT(ASUJ,0),U)," Master Delete transactions"
Begin DoDot:1
+62 SET ASUV("E#")=0
IF '$DATA(^ASUT(ASUJ,"C","Y"))
SET ASUC("TRN")=0
DO DCOUNT
QUIT
+63 FOR ASUC("TRN")=0:1
SET ASUV("E#")=$ORDER(^ASUT(ASUJ,"C","Y",ASUV("E#")))
IF ASUV("E#")']""
QUIT
Begin DoDot:2
+64 SET ASUT=0
SET ASUHDA=ASUV("E#")
DO TRRD
IF $GET(ASUT)']""
QUIT
Begin DoDot:3
+65 IF ASUT("TRCD")["D"
Begin DoDot:4
+66 DO UPDT
End DoDot:4
+67 IF '$TEST
Begin DoDot:4
+68 SET ASUC("TRN")=$GET(ASUC("TRN"))-1
End DoDot:4
End DoDot:3
End DoDot:2
+69 DO DCOUNT
End DoDot:1
+70 WRITE !!,$FNUMBER(ASUC("TOT"),",")," Total Records processed."
+71 KILL ASUC,ASUT,ASUJ,ASUMX,ASUMS,ASUMK,ASUV
+72 QUIT
DCOUNT ;
+1 WRITE !?15," Count=",$JUSTIFY($FNUMBER(ASUC("TRN"),","),10)
SET ASUC("TOT")=$GET(ASUC("TOT"))+ASUC("TRN")
+2 QUIT
UPDT ;EP ;Update masters
+1 SET ASUJ("RTN")=ASUJ_$EXTRACT($GET(ASUT),1,2)
+2 IF $GET(ASUJ)']""!($GET(ASUT)']"")!($GET(ASUT("TRCD"))']"")
SET ASUC("TRN")=$GET(ASUC("TRN"))-1
QUIT
+3 SET ASUV("ASUT")=ASUT
SET ASUV("TRCD")=ASUT("TRCD")
+4 SET ASUJ("FILE")=9002036_"."_ASUJ
+5 SET ASUJ("GLOB")="^ASUT("_ASUJ_","
+6 SET DIE="9002036."_ASUJ
SET DA=ASUHDA
+7 WRITE !?5,ASUHDA," ",ASUT("TRCD"),$JUSTIFY($GET(ASUT(ASUT,"IDX")),8),$JUSTIFY($GET(ASUT(ASUT,"VOU")),12),!," Editing:"
+8 DO CKFLD
+9 IF $GET(DDSSAVE)=1
Begin DoDot:1
+10 SET DDSSAVE=""
+11 IF ASUJ=1
DO ^ASU1DUPD
QUIT
+12 IF ASUJ=2
DO ^ASU2RUPD
QUIT
+13 IF ASUJ=3
Begin DoDot:2
+14 IF $EXTRACT(ASUT("TRCD"),2)?1N
Begin DoDot:3
+15 IF ASUT("TRCD")=32
DO ^ASU3IUPD
QUIT
+16 IF ASUT("TRCD")=33
DO ^ASU3IUPD
QUIT
+17 DO TXFIS^ASU3IUPD
End DoDot:3
+18 IF '$TEST
Begin DoDot:3
+19 DO RVIS^ASU3IUPD
End DoDot:3
End DoDot:2
QUIT
+20 IF ASUJ=4
DO ^ASU4XUPD
QUIT
+21 IF ASUJ=5
DO ^ASU5SUPD
QUIT
+22 IF ASUJ=6
DO ^ASU6JUPD
QUIT
+23 IF ASUJ=7
DO ^ASU7DUPD
End DoDot:1
+24 IF '$TEST
Begin DoDot:1
+25 IF $GET(E)=0
QUIT
+26 DO MREJ
KILL E,DDSERROR
SET DDSSAVE=0
SET DDSERROR=99
End DoDot:1
+27 IF $GET(ASUF("ERR"))>0
SET DDSSAVE=0
SET DDSERROR=ASUF("ERR")
+28 IF '$TEST
SET DDSSAVE=1
+29 IF $GET(DDSSAVE)=1
WRITE " UDOK"
+30 IF '$TEST
WRITE " NOUD"
IF DDSERROR=99
QUIT
DO MREJ
+31 SET DDSSAVE=0
KILL E,Z,DDSERROR,ASUF("ERR")
+32 QUIT
MREJ ;
+1 SET X=ASUJ("GLOB")_ASUHDA_")"
MERGE ^ASUTR(ASUJ,ASUHDA)=@(X)
+2 WRITE !?5,"Reject/move to ^ASUTR ERR=",$GET(DDSERROR)
+3 SET DIK=ASUJ("GLOB")
SET DA=ASUHDA
DO ^DIK
+4 QUIT
TRRD ;EP ;Read transactions
+1 DO READ^ASU0TRRD(.ASUHDA,.ASUJ)
QUIT
+2 QUIT
PTRSET(F) ;
+1 NEW C,R
+2 SET R=0
FOR C=1:1
SET R=$ORDER(^ASUT(F,R))
IF R'?1N.N
QUIT
Begin DoDot:1
+3 DO READ^ASU0TRRD(R,F)
+4 DO WRITE^ASU0TRWR(R,F)
End DoDot:1
+5 QUIT
CKFLD ;EP ;Validate fields for batch processing
+1 ;N E I ASUT(ASUT,"AR")=ASUL(1,"AR","AP"),ASUT(ASUT,"STA")=ASUL(2,"STA","CD") D
+2 NEW E
IF ASUT(ASUT,"AR")=ASUL(1,"AR","AP")
Begin DoDot:1
+3 DO @(ASUJ)
+4 IF $GET(E)>0
Begin DoDot:2
+5 SET DDSSAVE=0
WRITE " EDBD"
End DoDot:2
+6 IF '$TEST
Begin DoDot:2
+7 SET DDSSAVE=1
WRITE " EDOK"
End DoDot:2
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 WRITE " Transaction not for YOUR Area/Station - Not Edited"
SET DDSSAVE=0
SET E=0
End DoDot:1
+10 QUIT
1 ;Due in validation
+1 NEW F,M,P,R,X
+2 SET M="E"
FOR P="R^IDX","R^PON","R^QTY","R^VAL"
DO VLD(.P)
IF $GET(E)>0
QUIT
+3 IF $GET(E)>0
QUIT
+4 SET M="R"
SET P="R^SSA"
DO VLD(.P)
IF $GET(E)>0
QUIT
+5 SET M="D"
SET P="R^DTE"
DO VLD(.P)
+6 QUIT
2 ;Receipt validation
+1 NEW F,M,P,R,X
+2 SET M="E"
FOR P="R^VOU",$SELECT(ASUT("TRCD")=22:"R",1:"")_"^PON","R^QTY","R^VAL","R^FPN"
DO VLD(.P)
IF $GET(E)>0
QUIT
+3 IF $GET(E)>0
QUIT
+4 SET M="R"
SET P="R^SSA"
DO VLD(.P)
IF $GET(E)>0
QUIT
+5 SET M="F"
SET P="R^SRC"
DO VLD(.P)
IF $GET(E)>0
QUIT
+6 SET M="D"
FOR P="^DTX","R^DTE"
DO VLD(.P)
IF $GET(E)>0
QUIT
+7 QUIT
3 ;Issue validation
+1 NEW F,M,P,R,X
+2 SET M="E"
FOR P="R^IDX","R^VOU","^PST","R^QTYR",$SELECT($EXTRACT(ASUT("TRCD"),2)=2:"R",1:"")_"^FPN","^RTP"
DO VLD(.P)
IF $GET(E)>0
QUIT
+3 IF $GET(E)>0
QUIT
+4 SET M="R"
FOR P="R^SST","R^USR"
DO VLD(.P)
IF $GET(E)>0
QUIT
+5 IF $GET(E)>0
QUIT
+6 SET M="AN"
FOR F="^CTG","^RQN"
DO VLD(.P)
IF $GET(E)>0
QUIT
+7 IF $GET(E)>0
QUIT
+8 SET M="D"
SET P="R^DTE"
DO VLD(.P)
+9 QUIT
4 ;Index validation
+1 NEW F,M,P,R,X
+2 SET M="E"
FOR P="R^IDX","A^NSN"
DO VLD(.P)
IF $GET(E)>0
QUIT
+3 IF $GET(E)>0
QUIT
+4 SET M="F"
FOR P="C^ACC","A^SSO","A^CAT"
DO VLD(.P)
IF $GET(E)>0
QUIT
+5 IF $GET(E)>0
QUIT
+6 SET M="N"
SET P="^BCD"
DO VLD(.P)
IF $GET(E)>0
QUIT
+7 SET M="A"
SET P="^AUI"
DO VLD(.P)
IF $GET(E)>0
QUIT
+8 SET M="A"
SET P="A^DESC"
DO VLD(.P)
IF $GET(E)>0
QUIT
+9 SET M="D"
SET P="R^DTE"
DO VLD(.P)
+10 QUIT
5 ;Station validation
+1 NEW F,M,P,R,X
+2 SET M="E"
FOR P="R^IDX","^VEN","^ORD","A^EOQ"
DO VLD(.P)
IF $GET(E)>0
QUIT
+3 IF $GET(E)>0
QUIT
+4 SET M="F"
SET P="A^SRC"
DO VLD(.P)
IF $GET(E)>0
QUIT
+5 SET M="R"
SET P="^SLC"
DO VLD(.P)
IF $GET(E)>0
QUIT
+6 IF ASUT("TRCD")="5B"
Begin DoDot:1
+7 SET M="R"
FOR P="R^SST","R^USR"
DO VLD(.P)
IF $GET(E)>0
QUIT
+8 SET M="N"
SET P="R^ULQ"
DO VLD(.P)
End DoDot:1
IF $GET(E)>0
QUIT
+9 SET M="A"
SET P="^SUI"
DO VLD(.P)
IF $GET(E)>0
QUIT
+10 SET M="N"
FOR P="A^UCS","^LTM","^SPQ","A^RPQ"
DO VLD(.P)
IF $GET(E)>0
QUIT
+11 IF $GET(E)>0
QUIT
+12 SET M="D"
SET P="R^DTE"
DO VLD(.P)
+13 QUIT
6 ;Adjustment validation
+1 NEW F,M,P,R,X
+2 SET M="E"
FOR P="R^IDX","R^VOU"
DO VLD(.P)
IF $GET(E)>0
QUIT
+3 IF $GET(E)>0
QUIT
+4 SET M="N"
FOR P="^QTY","^VAL"
DO VLD(.P)
IF $GET(E)>0
QUIT
+5 IF $GET(E)>0
QUIT
+6 SET M="D"
SET P="R^DTE"
DO VLD(.P)
+7 QUIT
7 ;Direct Issue validation
+1 NEW F,M,P,R,X
+2 SET M="E"
FOR P="^PON","R^VOU"
DO VLD(.P)
IF $GET(E)>0
QUIT
+3 IF $GET(E)>0
QUIT
+4 SET M="R"
FOR P="R^SST","R^USR"
DO VLD(.P)
IF $GET(E)>0
QUIT
+5 IF $GET(E)>0
QUIT
+6 SET M="F"
FOR P="R^ACC","R^DSO","^SRC"
DO VLD(.P)
IF $GET(E)>0
QUIT
+7 IF $GET(E)>0
QUIT
+8 SET M="N"
FOR P="R^QTY","R^VAL"
DO VLD(.P)
IF $GET(E)>0
QUIT
+9 IF $GET(E)>0
QUIT
+10 SET M="D"
SET P="R^DTE"
DO VLD(.P)
+11 QUIT
VLD(P) ;
+1 SET F=$PIECE(P,U,2)
SET R=$PIECE(P,U)
IF R="A"
SET R=$SELECT($EXTRACT(ASUT("TRCD"),2)="A":"R",1:"")
+2 SET X=$GET(ASUT(ASUT,$SELECT(F="SSO":"SOBJ",F="DSO":"SOBJ",F="EOQ":"EOQ TYP",1:F)))
+3 IF F="QTYR"
SET X=ASUT(ASUT,"QTY","REQ")
+4 IF X']""
Begin DoDot:1
+5 IF R="R"
SET E="1^"_F_" a required field is null"
WRITE " #",$PIECE(E,U,2),!
QUIT
+6 WRITE " *",F
End DoDot:1
QUIT
+7 DO VLDF(.M,.F,.X)
+8 QUIT
VLDF(M,F,X) ;Validate and save field
+1 NEW Z
IF $GET(ASUSB)=1
WRITE " ",F
+2 IF ASUJ<7
IF ASUT("TRCD")'="4A"
IF $GET(ASUT(ASUT,"PT","IDX"))]""
SET ASUMS("E#","IDX")=ASUT(ASUT,"PT","IDX")
DO ^ASUMXDIO
+3 IF ASUJ<7
IF ASUJ'=4
IF ASUT("TRCD")'="5A"
IF $GET(ASUT(ASUT,"PT","STA"))]""
IF $GET(ASUMS("E#","IDX"))]""
IF $GET(^ASUMX(ASUMS("E#","IDX"),0))
SET ASUMS("E#","STA")=$GET(ASUL("ST#"))
DO ^ASUMSTRD
+4 SET DDSERROR=""
+5 ;I $G(ASUMS("E#","IDX"))&'$G(^ASUMX(ASUMS("E#","IDX"),0)) S M="E" ;CSC
+6 IF M="E"
Begin DoDot:1
+7 SET Z="D "_F_"^ASUJVALF(.X,.DDSERROR)"
XECUTE Z
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 SET Z="D EN^ASUJVALD(.X,.DDSERROR,.F,.M)"
XECUTE Z
End DoDot:1
+10 SET E=$GET(DDSERROR)
+11 QUIT
