ASUCOHKP ; IHS/ITSC/LMH -UPDATE HOUSEKEEPING ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine initializes necessary files/variables before any update
;run. (Housekeeping)
S ASUP("CKT")=+$G(ASUP("CKT"))
;WAR 6/25/99 REM'D NEXT LINE & ADDED NEXT LINES
;S ASUP("CKT")=1 D SETST^ASUCOSTS
S ASUP("CKT")=1
I $G(ASUK("HDG","MENU"))["DAILY" S ASUP("CKT")=""
D SETST^ASUCOSTS
D DATE^ASUUDATE,TIME^ASUUDATE
S ASURX="W !,""S.A.M.S. Closeout Housekeeping Procedure Begun "_ASUK("DT","TIME")_"""" D ^ASUUPLOG
D:$G(ASUN("TYP"))']"" ^ASUURANG
S:+($G(ASUP("CKP")))=0 ASUP("CKP")=1
I ASUP("CKP")=1 D ;Clear deleted masters
.D IBMCLR Q:$G(ASUP("HLT"))>0 S ASUP("CKP")=2 D SETSP^ASUCOSTS
I ASUP("CKP")=2 D ;Clear report files
.D RPTCLR Q:$G(ASUP("HLT"))>0 S ASUP("CKP")=3 D SETSP^ASUCOSTS
I ASUP("CKP")=3 D ;Get beginning balances
.D BALANCE Q:$G(ASUP("HLT"))>0 S ASUP("CKP")=0 D SETSP^ASUCOSTS
D DATE^ASUUDATE,TIME^ASUUDATE
S ASURX="W !,""S.A.M.S. Closeout Housekeeping Procedure Ended "_ASUK("DT","TIME")_"""" D ^ASUUPLOG
Q
IBMCLR ;CLEAR ISSUE BOOK MASTERS FOR PREVIOUSLY DELETED RECORDS
D:'$D(U) ^XBKVAR
S ASURX="W !?3,""Removing Deleted Indexes from Issue Book Masters File""" D ^ASUUPLOG
K ASUMX S ASUMX("IDX")=""
F S ASUMX("IDX")=$O(^ASUMX("B",999999,ASUMX("IDX"))) Q:ASUMX("IDX")']"" Q:ASUMX("IDX")["999999" D ;Look at all deleted index masters
.S ASUMK("SST")=$O(^ASUMK("C",ASUMX("IDX"),"")) ;Find first Sub Station using deleted index
.Q:ASUMK("SST")']"" ;No Substations using this index
.S ASUMK("SST")=ASUMK("SST")-1 ;Begin with first substation
.F S ASUMK("SST")=$O(^ASUMK("C",ASUMX("IDX"),ASUMK("SST"))) Q:ASUMK("SST")']"" D
..S ASUMK("REQ")="" S ASUMK("REQ")=$O(^ASUMK("C",ASUMX("IDX"),ASUMK("SST"),ASUMK("REQ"))) Q:ASUMK("SST")']"" D ;Find all requsitioners
...S ASUC("CLRX")=$G(ASUC("CLRX"))+1
...F X=0,1,2 K ^ASUMK(ASUMK("SST"),1,ASUMK("REQ"),1,ASUMX("IDX"),X)
...K ^ASUMK(ASUMK("SST"),1,ASUMK("REQ"),1,"B",ASUMX("IDX"),ASUMX("IDX"))
...K ^ASUMK("C",ASUMX("IDX"),ASUMK("SST"),ASUMK("REQ"),ASUMX("IDX"))
...S ASUC("IDX")=$P(^ASUMK(ASUMK("SST"),1,ASUMK("REQ"),1,0),U,4)
...S ASUC("IDX")=ASUC("IDX")-1
...S $P(^ASUMK(ASUMK("SST"),1,ASUMK("REQ"),1,0),U,4)=ASUC("IDX")
...I ASUC("IDX")=0 D
....S X=$O(^ASUMK(ASUMK("SST"),1,ASUMK("REQ"),1,0))
....Q:X]""
....S ASUC("CLRU")=$G(ASUC("CLRU"))+1
....K ^ASUMK(ASUMK("SST"),1,ASUMK("REQ"))
....K ^ASUMK(ASUMK("SST"),1,"B",ASUMK("REQ"),ASUMK("REQ"))
....S ASUC("REQ")=$P(^ASUMK(ASUMK("SST"),1,0),U,4)
....S ASUC("REQ")=ASUC("REQ")-1
....S $P(^ASUMK(ASUMK("SST"),1,0),U,4)=ASUC("REQ")
....I ASUC("REQ")=0 D
.....I X']"" S ASURX="W !,""Sub Station "_ASUMK("SST")_" may be deleted""" D ^ASUUPLOG
S ASURX="W !?10,"_+($G(ASUC("CLRX")))_","" Issue Book Index Master Records Cleared""" D ^ASUUPLOG
S ASURX="W !?10,"_+($G(ASUC("CLRU")))_","" Issue Book User Master Records Cleared""" D ^ASUUPLOG
K ASUC("CLRX"),ASUC("IDX"),ASUMK,ASURX
Q
S ASUV("IDX")="" ;K ^ASUD("DIX")
F S ASUV("IDX")=$O(^ASUMX("D",ASUV("IDX"))) Q:ASUV("IDX")']"" D
.S ASUMX("E#","IDX")=$O(^ASUMX("D",ASUV("IDX"),""))
.Q:$P(^ASUMX(ASUMX("E#","IDX"),2),U,3)]""
.D READ^ASUMXDIO S ASUMX("DELDT")=ASUK("DT","FM") D WRITE^ASUMXDIO
.;S ^ASUD("DIX",ASUMX("E#","IDX"))=""
RPTCLR ;UPDATE CLEAR REPORT GLOBALS
;This sub-routine clears the XTMP globals which contain pointers to
;data to be placed on the reports to be created for this closeout.
S ASURX="W !?3,""Clearing Report and Beginning Balance Files""" D ^ASUUPLOG
K ^XTMP("ASUMA")
S ASUV("RDT")=$E(ASUK("DT","FM"),1,5)+100_"01"_U_ASUK("DT","FM") S ^XTMP("ASUMA",0)=ASUV("RDT")
N X F X="70","7I","71","72","73","01","07","08","09","10A","10","11","13" D
.S X="R"_X K ^XTMP("ASUR",X) S ^XTMP("ASUR",X,0)=ASUV("RDT")
I $G(ASUP("TYP"))=1,$G(ASUP("OLIB"))]"" D VOUCHER
Q
VOUCHER ;RESET VOUCHER NUMBER
S $P(^ASUSITE(1,1),U,8)=$P(^ASUSITE(1,3),U,8)
Q
BALANCE ;UPDATE ACTIVE/INACTIVE OPENING BALANCE FILE AND REPORT 1 BALANCES
D SELSTA,LOADDAY
D ^ASUMCUPD
Q
SELSTA ;
S (ASUC("STA"),ASUC("ACT"))=0
S (ASUMX("E#","IDX"),ASUMS("E#","STA"))=0
S ASURX="W !?3,""Getting Beginning Balances (R11) and Counts (R1)""" D ^ASUUPLOG
I $G(ASUL(2,"STA","E#"))]"" S ASUMS("E#","STA")=ASUL(2,"STA","E#") D MSTLOOP Q
F S ASUMS("E#","STA")=$O(^ASUMS(ASUMS("E#","STA"))) Q:ASUMS("E#","STA")'?5N D MSTLOOP
Q
MSTLOOP ;
K ^XTMP("ASUMA")
S ASURX="W !?3,""Cataloging All Masters""" D ^ASUUPLOG
S ASUMS("E#","IDX")=0
F S ASUMS("E#","IDX")=$O(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"))) Q:ASUMS("E#","IDX")'?8N D
.I $P(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"),0),U)[999999 Q ;Deleted master
.S ASUMX("E#","IDX")=ASUMS("E#","IDX")
.D ^ASUMXDIO,^ASUMSTRD ;Read Index and Station masters
.S ^XTMP("ASUMA",ASUMS("E#","STA"),ASUL(9,"ACG"),ASUMS("E#","IDX"))=""
.S ^TMP("ASUMC",$J,ASUL(9,"ACC"),ASUMS("E#","IDX"))=""
Q
LOADDAY ;
S ASURX="W !?3,""Getting Today's Master Beginning Balances""" D ^ASUUPLOG
S ASUMS("E#","STA")=ASUL(2,"STA","E#")
D:$G(ASUN("TYP"))']"" RANGE^ASUURANG(1)
D LOAD(.ASUN)
Q
LOAD(Y) ;EP; LOAD BEGINNING BALANCES
S Y("ACC")=0
F S Y("ACC")=$O(^XTMP("ASUMA",ASUMS("E#","STA"),Y("ACC"))) Q:Y("ACC")']"" D
.S Y("IDX")=0
.F S Y("IDX")=$O(^XTMP("ASUMA",ASUMS("E#","STA"),Y("ACC"),Y("IDX"))) Q:Y("IDX")']"" D
..N X S X=^XTMP("ASUMA",ASUMS("E#","STA"),Y("ACC"),Y("IDX"))
..I Y("B#")]"" D
...I $D(^ASUH("I",Y("IDX"),Y("B#"))) S Y=Y("B#")
...E S Y=$O(^ASUH("I",Y("IDX"),Y("B#"))) ;First tran today
..E S Y=""
..I Y]"",Y'>Y("E#") S X="A",X("DA")=Y
..E S X="I"
..I Y("B#")]"" D
...S Y=$O(^ASUH("I",Y("IDX"),Y("B#")),-1) ;Most recent tran
..E S Y=""
..I Y]"" S ASUFB=1
..E S ASUFB=0 S:X="A" Y=$G(X("DA"))
..I Y?1N.N D
...Q:$P(^ASUH(Y,0),U,3)'=ASUL(2,"STA","E#")
...D READ^ASU0TRRD(.Y,"H")
...Q:ASUT("TYPE")=7 ;Direct issue - not masters
...S X("VAL")=(+ASUT(ASUT,"MST","VAL"))
...S X("QTY")=(+ASUT(ASUT,"MST","QTY"))
...S X("D/I")=(+ASUT(ASUT,"MST","D/I"))
...S X("ACC")=ASUT(ASUT,"ACC")
...I ASUFB=0 D ;First of current day's transaction being used
....Q:ASUT("TYPE")=4 Q:ASUT("TYPE")=5 ;Index and Station masters - no effect on balance
....I ASUT("TYPE")=1 S X("D/I")=X("D/I")-(ASUT(ASUT,"QTY")*ASUT(ASUT,"SIGN")) Q ;Due in - due in quantity effected
....I ASUT("TYPE")=3 S X("QTY")=X("QTY")-(ASUT(ASUT,"QTY","ISS")*ASUT(ASUT,"SIGN")),X("VAL")=X("VAL")-(ASUT(ASUT,"VAL")*ASUT(ASUT,"SIGN")) Q ;Issue - Quantity and Value effected
....S X("QTY")=X("QTY")-(ASUT(ASUT,"QTY")*ASUT(ASUT,"SIGN")),X("VAL")=X("VAL")-(ASUT(ASUT,"VAL")*ASUT(ASUT,"SIGN")) ;Receipt,Adjustments and Transfers - Quantity and Value effected
..E D
...K ASUMS,ASUMX D IDX^ASUMXDIO(Y("IDX")),READ^ASUMSTRD(Y("IDX"))
...S X("VAL")=+ASUMS("VAL","O/H"),X("QTY")=+ASUMS("QTY","O/H"),X("D/I")=+ASUMS("D/I","QTY-TOT"),X("ACC")=$G(ASUMX("ACC")) ;Save balances from Station master
..I Y("TYP")="1" D
...S X=X_U_$G(X("VAL"))_U_$G(X("QTY"))_U_$G(X("D/I"))_U_$S($G(X("ACC"))]"":X("ACC"),1:Y("ACC"))_U_$G(X("DA"))_U_$G(ASUFB)
...S ^XTMP("ASUMA",ASUMS("E#","STA"),ASUL(9,"ACG"),Y("IDX"))=X
..E D
...S ^TMP("ASUMC",$J,ASUL(9,"ACC"),Y("IDX"))=$G(X("VAL"))
Q
ASUCOHKP ; IHS/ITSC/LMH -UPDATE HOUSEKEEPING ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine initializes necessary files/variables before any update
+3 ;run. (Housekeeping)
+4 SET ASUP("CKT")=+$GET(ASUP("CKT"))
+5 ;WAR 6/25/99 REM'D NEXT LINE & ADDED NEXT LINES
+6 ;S ASUP("CKT")=1 D SETST^ASUCOSTS
+7 SET ASUP("CKT")=1
+8 IF $GET(ASUK("HDG","MENU"))["DAILY"
SET ASUP("CKT")=""
+9 DO SETST^ASUCOSTS
+10 DO DATE^ASUUDATE
DO TIME^ASUUDATE
+11 SET ASURX="W !,""S.A.M.S. Closeout Housekeeping Procedure Begun "_ASUK("DT","TIME")_""""
DO ^ASUUPLOG
+12 IF $GET(ASUN("TYP"))']""
DO ^ASUURANG
+13 IF +($GET(ASUP("CKP")))=0
SET ASUP("CKP")=1
+14 ;Clear deleted masters
IF ASUP("CKP")=1
Begin DoDot:1
+15 DO IBMCLR
IF $GET(ASUP("HLT"))>0
QUIT
SET ASUP("CKP")=2
DO SETSP^ASUCOSTS
End DoDot:1
+16 ;Clear report files
IF ASUP("CKP")=2
Begin DoDot:1
+17 DO RPTCLR
IF $GET(ASUP("HLT"))>0
QUIT
SET ASUP("CKP")=3
DO SETSP^ASUCOSTS
End DoDot:1
+18 ;Get beginning balances
IF ASUP("CKP")=3
Begin DoDot:1
+19 DO BALANCE
IF $GET(ASUP("HLT"))>0
QUIT
SET ASUP("CKP")=0
DO SETSP^ASUCOSTS
End DoDot:1
+20 DO DATE^ASUUDATE
DO TIME^ASUUDATE
+21 SET ASURX="W !,""S.A.M.S. Closeout Housekeeping Procedure Ended "_ASUK("DT","TIME")_""""
DO ^ASUUPLOG
+22 QUIT
IBMCLR ;CLEAR ISSUE BOOK MASTERS FOR PREVIOUSLY DELETED RECORDS
+1 IF '$DATA(U)
DO ^XBKVAR
+2 SET ASURX="W !?3,""Removing Deleted Indexes from Issue Book Masters File"""
DO ^ASUUPLOG
+3 KILL ASUMX
SET ASUMX("IDX")=""
+4 ;Look at all deleted index masters
FOR
SET ASUMX("IDX")=$ORDER(^ASUMX("B",999999,ASUMX("IDX")))
IF ASUMX("IDX")']""
QUIT
IF ASUMX("IDX")["999999"
QUIT
Begin DoDot:1
+5 ;Find first Sub Station using deleted index
SET ASUMK("SST")=$ORDER(^ASUMK("C",ASUMX("IDX"),""))
+6 ;No Substations using this index
IF ASUMK("SST")']""
QUIT
+7 ;Begin with first substation
SET ASUMK("SST")=ASUMK("SST")-1
+8 FOR
SET ASUMK("SST")=$ORDER(^ASUMK("C",ASUMX("IDX"),ASUMK("SST")))
IF ASUMK("SST")']""
QUIT
Begin DoDot:2
+9 ;Find all requsitioners
SET ASUMK("REQ")=""
SET ASUMK("REQ")=$ORDER(^ASUMK("C",ASUMX("IDX"),ASUMK("SST"),ASUMK("REQ")))
IF ASUMK("SST")']""
QUIT
Begin DoDot:3
+10 SET ASUC("CLRX")=$GET(ASUC("CLRX"))+1
+11 FOR X=0,1,2
KILL ^ASUMK(ASUMK("SST"),1,ASUMK("REQ"),1,ASUMX("IDX"),X)
+12 KILL ^ASUMK(ASUMK("SST"),1,ASUMK("REQ"),1,"B",ASUMX("IDX"),ASUMX("IDX"))
+13 KILL ^ASUMK("C",ASUMX("IDX"),ASUMK("SST"),ASUMK("REQ"),ASUMX("IDX"))
+14 SET ASUC("IDX")=$PIECE(^ASUMK(ASUMK("SST"),1,ASUMK("REQ"),1,0),U,4)
+15 SET ASUC("IDX")=ASUC("IDX")-1
+16 SET $PIECE(^ASUMK(ASUMK("SST"),1,ASUMK("REQ"),1,0),U,4)=ASUC("IDX")
+17 IF ASUC("IDX")=0
Begin DoDot:4
+18 SET X=$ORDER(^ASUMK(ASUMK("SST"),1,ASUMK("REQ"),1,0))
+19 IF X]""
QUIT
+20 SET ASUC("CLRU")=$GET(ASUC("CLRU"))+1
+21 KILL ^ASUMK(ASUMK("SST"),1,ASUMK("REQ"))
+22 KILL ^ASUMK(ASUMK("SST"),1,"B",ASUMK("REQ"),ASUMK("REQ"))
+23 SET ASUC("REQ")=$PIECE(^ASUMK(ASUMK("SST"),1,0),U,4)
+24 SET ASUC("REQ")=ASUC("REQ")-1
+25 SET $PIECE(^ASUMK(ASUMK("SST"),1,0),U,4)=ASUC("REQ")
+26 IF ASUC("REQ")=0
Begin DoDot:5
+27 IF X']""
SET ASURX="W !,""Sub Station "_ASUMK("SST")_" may be deleted"""
DO ^ASUUPLOG
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+28 SET ASURX="W !?10,"_+($GET(ASUC("CLRX")))_","" Issue Book Index Master Records Cleared"""
DO ^ASUUPLOG
+29 SET ASURX="W !?10,"_+($GET(ASUC("CLRU")))_","" Issue Book User Master Records Cleared"""
DO ^ASUUPLOG
+30 KILL ASUC("CLRX"),ASUC("IDX"),ASUMK,ASURX
+31 QUIT
+32 ;K ^ASUD("DIX")
SET ASUV("IDX")=""
+33 FOR
SET ASUV("IDX")=$ORDER(^ASUMX("D",ASUV("IDX")))
IF ASUV("IDX")']""
QUIT
Begin DoDot:1
+34 SET ASUMX("E#","IDX")=$ORDER(^ASUMX("D",ASUV("IDX"),""))
+35 IF $PIECE(^ASUMX(ASUMX("E#","IDX"),2),U,3)]""
QUIT
+36 DO READ^ASUMXDIO
SET ASUMX("DELDT")=ASUK("DT","FM")
DO WRITE^ASUMXDIO
+37 ;S ^ASUD("DIX",ASUMX("E#","IDX"))=""
End DoDot:1
RPTCLR ;UPDATE CLEAR REPORT GLOBALS
+1 ;This sub-routine clears the XTMP globals which contain pointers to
+2 ;data to be placed on the reports to be created for this closeout.
+3 SET ASURX="W !?3,""Clearing Report and Beginning Balance Files"""
DO ^ASUUPLOG
+4 KILL ^XTMP("ASUMA")
+5 SET ASUV("RDT")=$EXTRACT(ASUK("DT","FM"),1,5)+100_"01"_U_ASUK("DT","FM")
SET ^XTMP("ASUMA",0)=ASUV("RDT")
+6 NEW X
FOR X="70","7I","71","72","73","01","07","08","09","10A","10","11","13"
Begin DoDot:1
+7 SET X="R"_X
KILL ^XTMP("ASUR",X)
SET ^XTMP("ASUR",X,0)=ASUV("RDT")
End DoDot:1
+8 IF $GET(ASUP("TYP"))=1
IF $GET(ASUP("OLIB"))]""
DO VOUCHER
+9 QUIT
VOUCHER ;RESET VOUCHER NUMBER
+1 SET $PIECE(^ASUSITE(1,1),U,8)=$PIECE(^ASUSITE(1,3),U,8)
+2 QUIT
BALANCE ;UPDATE ACTIVE/INACTIVE OPENING BALANCE FILE AND REPORT 1 BALANCES
+1 DO SELSTA
DO LOADDAY
+2 DO ^ASUMCUPD
+3 QUIT
SELSTA ;
+1 SET (ASUC("STA"),ASUC("ACT"))=0
+2 SET (ASUMX("E#","IDX"),ASUMS("E#","STA"))=0
+3 SET ASURX="W !?3,""Getting Beginning Balances (R11) and Counts (R1)"""
DO ^ASUUPLOG
+4 IF $GET(ASUL(2,"STA","E#"))]""
SET ASUMS("E#","STA")=ASUL(2,"STA","E#")
DO MSTLOOP
QUIT
+5 FOR
SET ASUMS("E#","STA")=$ORDER(^ASUMS(ASUMS("E#","STA")))
IF ASUMS("E#","STA")'?5N
QUIT
DO MSTLOOP
+6 QUIT
MSTLOOP ;
+1 KILL ^XTMP("ASUMA")
+2 SET ASURX="W !?3,""Cataloging All Masters"""
DO ^ASUUPLOG
+3 SET ASUMS("E#","IDX")=0
+4 FOR
SET ASUMS("E#","IDX")=$ORDER(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX")))
IF ASUMS("E#","IDX")'?8N
QUIT
Begin DoDot:1
+5 ;Deleted master
IF $PIECE(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"),0),U)[999999
QUIT
+6 SET ASUMX("E#","IDX")=ASUMS("E#","IDX")
+7 ;Read Index and Station masters
DO ^ASUMXDIO
DO ^ASUMSTRD
+8 SET ^XTMP("ASUMA",ASUMS("E#","STA"),ASUL(9,"ACG"),ASUMS("E#","IDX"))=""
+9 SET ^TMP("ASUMC",$JOB,ASUL(9,"ACC"),ASUMS("E#","IDX"))=""
End DoDot:1
+10 QUIT
LOADDAY ;
+1 SET ASURX="W !?3,""Getting Today's Master Beginning Balances"""
DO ^ASUUPLOG
+2 SET ASUMS("E#","STA")=ASUL(2,"STA","E#")
+3 IF $GET(ASUN("TYP"))']""
DO RANGE^ASUURANG(1)
+4 DO LOAD(.ASUN)
+5 QUIT
LOAD(Y) ;EP; LOAD BEGINNING BALANCES
+1 SET Y("ACC")=0
+2 FOR
SET Y("ACC")=$ORDER(^XTMP("ASUMA",ASUMS("E#","STA"),Y("ACC")))
IF Y("ACC")']""
QUIT
Begin DoDot:1
+3 SET Y("IDX")=0
+4 FOR
SET Y("IDX")=$ORDER(^XTMP("ASUMA",ASUMS("E#","STA"),Y("ACC"),Y("IDX")))
IF Y("IDX")']""
QUIT
Begin DoDot:2
+5 NEW X
SET X=^XTMP("ASUMA",ASUMS("E#","STA"),Y("ACC"),Y("IDX"))
+6 IF Y("B#")]""
Begin DoDot:3
+7 IF $DATA(^ASUH("I",Y("IDX"),Y("B#")))
SET Y=Y("B#")
+8 ;First tran today
IF '$TEST
SET Y=$ORDER(^ASUH("I",Y("IDX"),Y("B#")))
End DoDot:3
+9 IF '$TEST
SET Y=""
+10 IF Y]""
IF Y'>Y("E#")
SET X="A"
SET X("DA")=Y
+11 IF '$TEST
SET X="I"
+12 IF Y("B#")]""
Begin DoDot:3
+13 ;Most recent tran
SET Y=$ORDER(^ASUH("I",Y("IDX"),Y("B#")),-1)
End DoDot:3
+14 IF '$TEST
SET Y=""
+15 IF Y]""
SET ASUFB=1
+16 IF '$TEST
SET ASUFB=0
IF X="A"
SET Y=$GET(X("DA"))
+17 IF Y?1N.N
Begin DoDot:3
+18 IF $PIECE(^ASUH(Y,0),U,3)'=ASUL(2,"STA","E#")
QUIT
+19 DO READ^ASU0TRRD(.Y,"H")
+20 ;Direct issue - not masters
IF ASUT("TYPE")=7
QUIT
+21 SET X("VAL")=(+ASUT(ASUT,"MST","VAL"))
+22 SET X("QTY")=(+ASUT(ASUT,"MST","QTY"))
+23 SET X("D/I")=(+ASUT(ASUT,"MST","D/I"))
+24 SET X("ACC")=ASUT(ASUT,"ACC")
+25 ;First of current day's transaction being used
IF ASUFB=0
Begin DoDot:4
+26 ;Index and Station masters - no effect on balance
IF ASUT("TYPE")=4
QUIT
IF ASUT("TYPE")=5
QUIT
+27 ;Due in - due in quantity effected
IF ASUT("TYPE")=1
SET X("D/I")=X("D/I")-(ASUT(ASUT,"QTY")*ASUT(ASUT,"SIGN"))
QUIT
+28 ;Issue - Quantity and Value effected
IF ASUT("TYPE")=3
SET X("QTY")=X("QTY")-(ASUT(ASUT,"QTY","ISS")*ASUT(ASUT,"SIGN"))
SET X("VAL")=X("VAL")-(ASUT(ASUT,"VAL")*ASUT(ASUT,"SIGN"))
QUIT
+29 ;Receipt,Adjustments and Transfers - Quantity and Value effected
SET X("QTY")=X("QTY")-(ASUT(ASUT,"QTY")*ASUT(ASUT,"SIGN"))
SET X("VAL")=X("VAL")-(ASUT(ASUT,"VAL")*ASUT(ASUT,"SIGN"))
End DoDot:4
End DoDot:3
+30 IF '$TEST
Begin DoDot:3
+31 KILL ASUMS,ASUMX
DO IDX^ASUMXDIO(Y("IDX"))
DO READ^ASUMSTRD(Y("IDX"))
+32 ;Save balances from Station master
SET X("VAL")=+ASUMS("VAL","O/H")
SET X("QTY")=+ASUMS("QTY","O/H")
SET X("D/I")=+ASUMS("D/I","QTY-TOT")
SET X("ACC")=$GET(ASUMX("ACC"))
End DoDot:3
+33 IF Y("TYP")="1"
Begin DoDot:3
+34 SET X=X_U_$GET(X("VAL"))_U_$GET(X("QTY"))_U_$GET(X("D/I"))_U_$SELECT($GET(X("ACC"))]"":X("ACC"),1:Y("ACC"))_U_$GET(X("DA"))_U_$GET(ASUFB)
+35 SET ^XTMP("ASUMA",ASUMS("E#","STA"),ASUL(9,"ACG"),Y("IDX"))=X
End DoDot:3
+36 IF '$TEST
Begin DoDot:3
+37 SET ^TMP("ASUMC",$JOB,ASUL(9,"ACC"),Y("IDX"))=$GET(X("VAL"))
End DoDot:3
End DoDot:2
End DoDot:1
+38 QUIT
