ASUV4AL ; IHS/ITSC/LMH -RPT ADJUSTMENT DOC ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine creates the Physical Inventory Adjustments Documents
;report.
D:'$D(DT) ^XBKVAR S %H=$H D YX^%DTC S ASUK("RUN","DT")=$P(Y,"@") K X,Y,%H
D:'$D(IO(0)) HOME^%ZIS
S %DT="T",X="NOW" D ^%DT S ASUV("DT")=Y
D CLS^ASUUHDG
I $G(ASUL(2,"STA","E#"))']"" D STA^ASUV0NT I $D(DTOUT)!($D(DUOUT)) G EXIT
S DIC("A")="PRINT RPT 37C 'ADJUSTMENT DOCUMENT' FOR WHAT ACCOUNT?"
S DIC="9002039.09",DIC(0)="AMEZQ"
D ^DIC K DIC
I $D(DTOUT)!($D(DUOUT)) Q
Q:'$D(Y) Q:Y=""
I Y>0 D
.S ASUMV("ACC")=$P(Y,U),ASUMV("E#","ASA")=ASUL(2,"STA","E#")_ASUMV("ACC")
.D ACC^ASULDIRF(ASUMV("ACC"))
E D
.S ASUMV("E#","ASA")=ASUL(2,"STA","E#")
G:ASUMV("E#","ASA")="" EXIT
I $D(^ASUMV(ASUMV("E#","ASA"),0)) D
.D ACCOUNT^ASUV9IMR
E D G EXIT
.W !!,"NO INVENTORY IS ACTIVE FOR ACCOUNT ",ASUMV("ACC")," ",ASUL(9,"ACC","NM")
.S DIR(0)="E" D ^DIR K DIR
S ASUV("ASA")=ASUMV("E#","ASA")
S ASUF=$G(ASUF)
I ASUF=2 D
.S ASUF=0,ASUMV("MODE")=3
E D
.S ASUV("MSG",1)="YOU HAVE REQUESTED AN ADJUSTMENT DOCUMENT BUT "
.D ASUV3AN0^ASUV3AN
G:ASUF EXIT
D ASUV4AL0
I '$D(IO) D HOME^%ZIS
I '$D(DUZ(2)) W !,"Report must be run from Kernel option" G EXIT
I '$D(ASUL(1,"AR","AP")) D SETAREA^ASULARST
S ASUV("ASA")=ASUMV("E#","ASA")
S ZTRTN="ASUV4AL1^ASUV4AL",ZTDESC="SAMS INVENTORY ADJUSTMENTS LIST" D O^ASUUZIS
I POP S IOP=$I D ^%ZIS G EXIT
I ASUK(ASUK("PTR"),"Q") K IOP,POP,ZTDESC,ZTRTN,ZTSK,ASUK(ASUK("PTR")),ASUK("PTR"),ASUK("PTR-Q") G EXIT
D ASUV4AL1
EXIT ;
K ASUU(11),ASUC,ASUR,ASUSAV,ASUF,ASUMS,ASUMV,ASUV,ASUMX
K DTOUT,DUOUT,ZTRTN,ZTDESC,X,Y,X1
D:$D(ASUK("PTR")) C^ASUUZIS
Q
ASUV4AL0 ;ADJUSTMENT DOCUMENT SORT
K ^ASUV("AJ")
S ASUMV("E#","SLC")=0
F S ASUMV("E#","SLC")=$O(^ASUMV(ASUMV("E#","ASA"),1,ASUMV("E#","SLC"))) Q:ASUMV("E#","SLC")'?1N.N D
.S ASUMV("E#","INDX")=0
.F S ASUMV("E#","INDX")=$O(^ASUMV(ASUMV("E#","ASA"),1,ASUMV("E#","SLC"),1,ASUMV("E#","INDX"))) Q:ASUMV("E#","INDX")'?1N.N D
..Q:$P(^ASUMV(ASUMV("E#","ASA"),1,ASUMV("E#","SLC"),1,ASUMV("E#","INDX"),0),U,7)=0
..S ASUL(2,"STA","E#")=$P(^ASUMV(ASUMV("E#","ASA"),1,ASUMV("E#","SLC"),1,ASUMV("E#","INDX"),0),U,2)
..S ^ASUV("AJ",ASUMV("E#","ASA"),ASUMV("E#","INDX"))=ASUMV("E#","SLC")
Q
ASUV4AL1 ;
S ASUMV("E#","ASA")=ASUV("ASA")
D U^ASUUZIS
S (ASUC("PG"),ASUC("LN"))=0
S (ASUC("OVR","VAL"),ASUC("OVR","LI"))=0
S (ASUC("SHT","VAL"),ASUC("SHT","LI"))=0
I '$D(^ASUV("AJ",ASUMV("E#","ASA"))) D G FLAGIT
.D ACCOUNT^ASUV9IMR
.S Y=ASUMV("INVBEG") X ^DD("DD") S ASUV("DTPRNT")=Y K Y
.D HEADING
.W !!,"NO ADJUSTMENTS TO BE MADE FOR ACCOUNT '",ASUMV("ACC"),"' -",ASUL(9,"ACC","NM")," INVENTORY"
S ASUMV("E#","SLC")=""
D ACCOUNT^ASUV9IMR
S Y=ASUMV("INVBEG") X ^DD("DD") S ASUV("DTPRNT")=Y K Y
S ASUMV("E#","INDX")=""
D:ASUC("LN")<1 HEADING
F ASUU(11)=1:1 S ASUMV("E#","INDX")=$O(^ASUV("AJ",ASUMV("E#","ASA"),ASUMV("E#","INDX"))) Q:ASUMV("E#","INDX")'?1N.N D
.S ASUMV("E#","SLC")=^ASUV("AJ",ASUMV("E#","ASA"),ASUMV("E#","INDX"))
.D STORLOC^ASUV9IMR
.D:ASUC("LN")>55 HEADING
.D INDEX^ASUV9IMR
.Q:ASUMV("IDX")["*" ;MASTER HAS BEEN DELETED
.S ASUV("CNT","LST")=$S(ASUMV("CNT","2ND"):ASUMV("CNT","2ND"),1:ASUMV("CNT","1ST"))
.S ASUV("ADJUST VAL")=$FN(ASUMV("QTY","DIF")*ASUMV("U/C"),"",2)
.D READ^ASUMXDIO
.S ASUMS("E#","IDX")=$O(^ASUMS(ASUL(2,"STA","E#"),1,"B",ASUMV("IDX"),""))
.W !?1,$J(ASUU(11),3),?6,$E(ASUMX("IDX"),1,5),".",$E(ASUMX("IDX"),6,6)
.W ?14,$E(ASUMX("DESC",1),1,20),?35,ASUMX("AR U/I"),?37,$J($FN(ASUMV("U/C"),",",2),6)
.S ASUT="GEN ADJ"
.S ASUT(ASUT,"VAL")=ASUV("ADJUST VAL")
.I ASUMV("QTY","DIF")<1 D
..S ASUT("TRCD")=37
..S ASUT(ASUT,"QTY")=(ASUMV("QTY","DIF")*-1)
..S:ASUT(ASUT,"VAL")<0 ASUT(ASUT,"VAL")=(ASUT(ASUT,"VAL")*-1)
..D ASUV4AL3
..W ?62,$J(ASUMV("QTY","DIF"),6),?68,$J($FN(ASUV("ADJUST VAL"),",",2),10)
..S ASUC("SHT","VAL")=ASUC("SHT","VAL")+ASUV("ADJUST VAL"),ASUC("SHT","LI")=ASUC("SHT","LI")+1
.E D
..S ASUT("TRCD")=27
..S ASUT(ASUT,"QTY")=ASUMV("QTY","DIF")
..D ASUV4AL3
..W ?45,$J(ASUMV("QTY","DIF"),6),?52,$J($FN(ASUV("ADJUST VAL"),",",2),10)
..S ASUC("OVR","VAL")=ASUC("OVR","VAL")+ASUV("ADJUST VAL"),ASUC("OVR","LI")=ASUC("OVR","LI")+1
.D SEPERATE
.S ASUC("LN")=ASUC("LN")+2
D:ASUC("LN")>7 FOOTING
FLAGIT ;
U IO(0) D CLS^ASUUHDG
I '$G(ASUF("RPRN")) D FLAGIT4^ASUV3AN
D:$D(ASUK("PTR")) C^ASUUZIS
Q
HEADING ;
D CLS^ASUUHDG S ASUC("PG")=ASUC("PG")+1,ASUC("LN")=7
W "REPORT 37C INVENTORY ADJUSTMENT DOUCMENT DATE: ",ASUK("RUN","DT"),?70," PAGE: ",ASUC("PG")
W !,"AREA: ",ASUL(1,"AR","NM")
W !,"STAT: ",ASUL(2,"STA","NM"),?33,"ACCOUNT : ",ASUL(9,"ACC","NM"),?55,"INV. DATE ",ASUV("DTPRNT")
W !,"VOUCHER NO: ",$E(ASUMV("VOU"),1,2),"-",$E(ASUMV("VOU"),3,4),"-",$E(ASUMV("VOU"),5,8)
W !!,"ITEM INDEX"
W ?34,"U UNIT OVERAGE SHORTAGE"
W !," NO. NUMBER DESCRIPTION"
W ?34," I COST QTY VALUE QTY VALUE"
D SEPERATE
Q
SEPERATE ;
W !,"_______________________________________________________________________________"
Q
S ASUC("LN")=0
W !!?5,"TOTALS: OVERAGES: NO. LI: ",$J(ASUC("OVR","LI"),6),?45," VAL: ",$J($FN(ASUC("OVR","VAL"),",",2),10)
W !?13,"SHORTAGES: NO. LI: ",$J(ASUC("SHT","LI"),6),?45," VAL: ",$J($FN(ASUC("SHT","VAL"),",",2),10)
;I $D(IO("HOME")) HANG 60 ;;ADDED 3/14/95 CSC
Q
ASUV4AL3 ;
Q:$G(ASUF("RPRN"))>0
I '$D(ASUV("TIME")) S ASUV("TIME")=$H G KEY
F I ASUV("TIME")'=$H Q
S ASUV("TIME")=$H
KEY ;
S ASUT(ASUT,"DTE")=$P(ASUV("DT"),".")_"."_$P(ASUV("TIME"),",",2)
S ASUT(ASUT,"TRKY")=ASUT(ASUT,"DTE")_"."_DUZ,ASUF("UPDT")=1,ASUC(0)=0
S ASUT(ASUT,"STA")=ASUL(2,"STA","CD")
S ASUT(ASUT,"VOU")=ASUMV("VOU")
S ASUT(ASUT,"IDX")=ASUMV("IDX")
S ASUC=$G(ASUC)
S ASUT(ASUT,"ENTR BY")=DUZ
S ASUT(ASUT,"DTE")=ASUK("DT","FM")
S ASUT(ASUT,"AR")=ASUL(1,"AR","AP")
S (ASUT(ASUT,"DTP"),ASUT(ASUT,"DTW"))="",ASUT(ASUT,"STATUS")="Y"
S ASUT(ASUT,"PT","AR")=ASUT(ASUT,"AR")
S ASUT(ASUT,"PT","STA")=ASUL(2,"STA","E#")
I ASUT(ASUT,"IDX")]"" D
.S ASUT(ASUT,"PT","IDX")=ASUT(ASUT,"AR")_ASUT(ASUT,"IDX")
E D
.S ASUT(ASUT,"PT","IDX")=""
I $G(ASUT(ASUT,"ACC"))]"" D
.S ASUT(ASUT,"PT","ACC")=ASUT(ASUT,"ACC")
E D
.I ASUT(ASUT,"PT","IDX")]"",$G(ASUL(1,"AR","WHSE"))>0 D
..S ASUT(ASUT,"ACC")=$P($G(^ASUMX(ASUT(ASUT,"PT","IDX"),0)),U,6)
..S ASUT(ASUT,"PT","ACC")=ASUT(ASUT,"ACC")
.E D
..S (ASUT(ASUT,"ACC"),ASUT(ASUT,"PT","ACC"))=""
S DIC=9002036.6,X=ASUT(ASUT,"TRKY"),DIC(0)="L" D ^DIC
I Y<0 D
.W *7,*7,!,"INVENTORY ADJUSTMENT CREATION UNSUCESSFUL",!
E D
.S (DA,ASUHDA)=+Y
.S ASUC=ASUC+1
.S ASUF("SV")=1 D WRITE^ASU0TRWR(DA,6)
;F X=3:1:22 K ASUL(X) ;LMH 6/19/00
K DA,DR,DIC,DIE,ASUMSG,X,Y
K ASUT(ASUT),ASUC(0)
Q
ASUV4AL ; IHS/ITSC/LMH -RPT ADJUSTMENT DOC ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine creates the Physical Inventory Adjustments Documents
+3 ;report.
+4 IF '$DATA(DT)
DO ^XBKVAR
SET %H=$HOROLOG
DO YX^%DTC
SET ASUK("RUN","DT")=$PIECE(Y,"@")
KILL X,Y,%H
+5 IF '$DATA(IO(0))
DO HOME^%ZIS
+6 SET %DT="T"
SET X="NOW"
DO ^%DT
SET ASUV("DT")=Y
+7 DO CLS^ASUUHDG
+8 IF $GET(ASUL(2,"STA","E#"))']""
DO STA^ASUV0NT
IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO EXIT
+9 SET DIC("A")="PRINT RPT 37C 'ADJUSTMENT DOCUMENT' FOR WHAT ACCOUNT?"
+10 SET DIC="9002039.09"
SET DIC(0)="AMEZQ"
+11 DO ^DIC
KILL DIC
+12 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+13 IF '$DATA(Y)
QUIT
IF Y=""
QUIT
+14 IF Y>0
Begin DoDot:1
+15 SET ASUMV("ACC")=$PIECE(Y,U)
SET ASUMV("E#","ASA")=ASUL(2,"STA","E#")_ASUMV("ACC")
+16 DO ACC^ASULDIRF(ASUMV("ACC"))
End DoDot:1
+17 IF '$TEST
Begin DoDot:1
+18 SET ASUMV("E#","ASA")=ASUL(2,"STA","E#")
End DoDot:1
+19 IF ASUMV("E#","ASA")=""
GOTO EXIT
+20 IF $DATA(^ASUMV(ASUMV("E#","ASA"),0))
Begin DoDot:1
+21 DO ACCOUNT^ASUV9IMR
End DoDot:1
+22 IF '$TEST
Begin DoDot:1
+23 WRITE !!,"NO INVENTORY IS ACTIVE FOR ACCOUNT ",ASUMV("ACC")," ",ASUL(9,"ACC","NM")
+24 SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
GOTO EXIT
+25 SET ASUV("ASA")=ASUMV("E#","ASA")
+26 SET ASUF=$GET(ASUF)
+27 IF ASUF=2
Begin DoDot:1
+28 SET ASUF=0
SET ASUMV("MODE")=3
End DoDot:1
+29 IF '$TEST
Begin DoDot:1
+30 SET ASUV("MSG",1)="YOU HAVE REQUESTED AN ADJUSTMENT DOCUMENT BUT "
+31 DO ASUV3AN0^ASUV3AN
End DoDot:1
+32 IF ASUF
GOTO EXIT
+33 DO ASUV4AL0
+34 IF '$DATA(IO)
DO HOME^%ZIS
+35 IF '$DATA(DUZ(2))
WRITE !,"Report must be run from Kernel option"
GOTO EXIT
+36 IF '$DATA(ASUL(1,"AR","AP"))
DO SETAREA^ASULARST
+37 SET ASUV("ASA")=ASUMV("E#","ASA")
+38 SET ZTRTN="ASUV4AL1^ASUV4AL"
SET ZTDESC="SAMS INVENTORY ADJUSTMENTS LIST"
DO O^ASUUZIS
+39 IF POP
SET IOP=$IO
DO ^%ZIS
GOTO EXIT
+40 IF ASUK(ASUK("PTR"),"Q")
KILL IOP,POP,ZTDESC,ZTRTN,ZTSK,ASUK(ASUK("PTR")),ASUK("PTR"),ASUK("PTR-Q")
GOTO EXIT
+41 DO ASUV4AL1
EXIT ;
+1 KILL ASUU(11),ASUC,ASUR,ASUSAV,ASUF,ASUMS,ASUMV,ASUV,ASUMX
+2 KILL DTOUT,DUOUT,ZTRTN,ZTDESC,X,Y,X1
+3 IF $DATA(ASUK("PTR"))
DO C^ASUUZIS
+4 QUIT
ASUV4AL0 ;ADJUSTMENT DOCUMENT SORT
+1 KILL ^ASUV("AJ")
+2 SET ASUMV("E#","SLC")=0
+3 FOR
SET ASUMV("E#","SLC")=$ORDER(^ASUMV(ASUMV("E#","ASA"),1,ASUMV("E#","SLC")))
IF ASUMV("E#","SLC")'?1N.N
QUIT
Begin DoDot:1
+4 SET ASUMV("E#","INDX")=0
+5 FOR
SET ASUMV("E#","INDX")=$ORDER(^ASUMV(ASUMV("E#","ASA"),1,ASUMV("E#","SLC"),1,ASUMV("E#","INDX")))
IF ASUMV("E#","INDX")'?1N.N
QUIT
Begin DoDot:2
+6 IF $PIECE(^ASUMV(ASUMV("E#","ASA"),1,ASUMV("E#","SLC"),1,ASUMV("E#","INDX"),0),U,7)=0
QUIT
+7 SET ASUL(2,"STA","E#")=$PIECE(^ASUMV(ASUMV("E#","ASA"),1,ASUMV("E#","SLC"),1,ASUMV("E#","INDX"),0),U,2)
+8 SET ^ASUV("AJ",ASUMV("E#","ASA"),ASUMV("E#","INDX"))=ASUMV("E#","SLC")
End DoDot:2
End DoDot:1
+9 QUIT
ASUV4AL1 ;
+1 SET ASUMV("E#","ASA")=ASUV("ASA")
+2 DO U^ASUUZIS
+3 SET (ASUC("PG"),ASUC("LN"))=0
+4 SET (ASUC("OVR","VAL"),ASUC("OVR","LI"))=0
+5 SET (ASUC("SHT","VAL"),ASUC("SHT","LI"))=0
+6 IF '$DATA(^ASUV("AJ",ASUMV("E#","ASA")))
Begin DoDot:1
+7 DO ACCOUNT^ASUV9IMR
+8 SET Y=ASUMV("INVBEG")
XECUTE ^DD("DD")
SET ASUV("DTPRNT")=Y
KILL Y
+9 DO HEADING
+10 WRITE !!,"NO ADJUSTMENTS TO BE MADE FOR ACCOUNT '",ASUMV("ACC"),"' -",ASUL(9,"ACC","NM")," INVENTORY"
End DoDot:1
GOTO FLAGIT
+11 SET ASUMV("E#","SLC")=""
+12 DO ACCOUNT^ASUV9IMR
+13 SET Y=ASUMV("INVBEG")
XECUTE ^DD("DD")
SET ASUV("DTPRNT")=Y
KILL Y
+14 SET ASUMV("E#","INDX")=""
+15 IF ASUC("LN")<1
DO HEADING
+16 FOR ASUU(11)=1:1
SET ASUMV("E#","INDX")=$ORDER(^ASUV("AJ",ASUMV("E#","ASA"),ASUMV("E#","INDX")))
IF ASUMV("E#","INDX")'?1N.N
QUIT
Begin DoDot:1
+17 SET ASUMV("E#","SLC")=^ASUV("AJ",ASUMV("E#","ASA"),ASUMV("E#","INDX"))
+18 DO STORLOC^ASUV9IMR
+19 IF ASUC("LN")>55
DO HEADING
+20 DO INDEX^ASUV9IMR
+21 ;MASTER HAS BEEN DELETED
IF ASUMV("IDX")["*"
QUIT
+22 SET ASUV("CNT","LST")=$SELECT(ASUMV("CNT","2ND"):ASUMV("CNT","2ND"),1:ASUMV("CNT","1ST"))
+23 SET ASUV("ADJUST VAL")=$FNUMBER(ASUMV("QTY","DIF")*ASUMV("U/C"),"",2)
+24 DO READ^ASUMXDIO
+25 SET ASUMS("E#","IDX")=$ORDER(^ASUMS(ASUL(2,"STA","E#"),1,"B",ASUMV("IDX"),""))
+26 WRITE !?1,$JUSTIFY(ASUU(11),3),?6,$EXTRACT(ASUMX("IDX"),1,5),".",$EXTRACT(ASUMX("IDX"),6,6)
+27 WRITE ?14,$EXTRACT(ASUMX("DESC",1),1,20),?35,ASUMX("AR U/I"),?37,$JUSTIFY($FNUMBER(ASUMV("U/C"),",",2),6)
+28 SET ASUT="GEN ADJ"
+29 SET ASUT(ASUT,"VAL")=ASUV("ADJUST VAL")
+30 IF ASUMV("QTY","DIF")<1
Begin DoDot:2
+31 SET ASUT("TRCD")=37
+32 SET ASUT(ASUT,"QTY")=(ASUMV("QTY","DIF")*-1)
+33 IF ASUT(ASUT,"VAL")<0
SET ASUT(ASUT,"VAL")=(ASUT(ASUT,"VAL")*-1)
+34 DO ASUV4AL3
+35 WRITE ?62,$JUSTIFY(ASUMV("QTY","DIF"),6),?68,$JUSTIFY($FNUMBER(ASUV("ADJUST VAL"),",",2),10)
+36 SET ASUC("SHT","VAL")=ASUC("SHT","VAL")+ASUV("ADJUST VAL")
SET ASUC("SHT","LI")=ASUC("SHT","LI")+1
End DoDot:2
+37 IF '$TEST
Begin DoDot:2
+38 SET ASUT("TRCD")=27
+39 SET ASUT(ASUT,"QTY")=ASUMV("QTY","DIF")
+40 DO ASUV4AL3
+41 WRITE ?45,$JUSTIFY(ASUMV("QTY","DIF"),6),?52,$JUSTIFY($FNUMBER(ASUV("ADJUST VAL"),",",2),10)
+42 SET ASUC("OVR","VAL")=ASUC("OVR","VAL")+ASUV("ADJUST VAL")
SET ASUC("OVR","LI")=ASUC("OVR","LI")+1
End DoDot:2
+43 DO SEPERATE
+44 SET ASUC("LN")=ASUC("LN")+2
End DoDot:1
+45 IF ASUC("LN")>7
DO FOOTING
FLAGIT ;
+1 USE IO(0)
DO CLS^ASUUHDG
+2 IF '$GET(ASUF("RPRN"))
DO FLAGIT4^ASUV3AN
+3 IF $DATA(ASUK("PTR"))
DO C^ASUUZIS
+4 QUIT
HEADING ;
+1 DO CLS^ASUUHDG
SET ASUC("PG")=ASUC("PG")+1
SET ASUC("LN")=7
+2 WRITE "REPORT 37C INVENTORY ADJUSTMENT DOUCMENT DATE: ",ASUK("RUN","DT"),?70," PAGE: ",ASUC("PG")
+3 WRITE !,"AREA: ",ASUL(1,"AR","NM")
+4 WRITE !,"STAT: ",ASUL(2,"STA","NM"),?33,"ACCOUNT : ",ASUL(9,"ACC","NM"),?55,"INV. DATE ",ASUV("DTPRNT")
+5 WRITE !,"VOUCHER NO: ",$EXTRACT(ASUMV("VOU"),1,2),"-",$EXTRACT(ASUMV("VOU"),3,4),"-",$EXTRACT(ASUMV("VOU"),5,8)
+6 WRITE !!,"ITEM INDEX"
+7 WRITE ?34,"U UNIT OVERAGE SHORTAGE"
+8 WRITE !," NO. NUMBER DESCRIPTION"
+9 WRITE ?34," I COST QTY VALUE QTY VALUE"
+10 DO SEPERATE
+11 QUIT
SEPERATE ;
+1 WRITE !,"_______________________________________________________________________________"
+2 QUIT
+1 SET ASUC("LN")=0
+2 WRITE !!?5,"TOTALS: OVERAGES: NO. LI: ",$JUSTIFY(ASUC("OVR","LI"),6),?45," VAL: ",$JUSTIFY($FNUMBER(ASUC("OVR","VAL"),",",2),10)
+3 WRITE !?13,"SHORTAGES: NO. LI: ",$JUSTIFY(ASUC("SHT","LI"),6),?45," VAL: ",$JUSTIFY($FNUMBER(ASUC("SHT","VAL"),",",2),10)
+4 ;I $D(IO("HOME")) HANG 60 ;;ADDED 3/14/95 CSC
+5 QUIT
ASUV4AL3 ;
+1 IF $GET(ASUF("RPRN"))>0
QUIT
+2 IF '$DATA(ASUV("TIME"))
SET ASUV("TIME")=$HOROLOG
GOTO KEY
+3 FOR
IF ASUV("TIME")'=$HOROLOG
QUIT
+4 SET ASUV("TIME")=$HOROLOG
KEY ;
+1 SET ASUT(ASUT,"DTE")=$PIECE(ASUV("DT"),".")_"."_$PIECE(ASUV("TIME"),",",2)
+2 SET ASUT(ASUT,"TRKY")=ASUT(ASUT,"DTE")_"."_DUZ
SET ASUF("UPDT")=1
SET ASUC(0)=0
+3 SET ASUT(ASUT,"STA")=ASUL(2,"STA","CD")
+4 SET ASUT(ASUT,"VOU")=ASUMV("VOU")
+5 SET ASUT(ASUT,"IDX")=ASUMV("IDX")
+6 SET ASUC=$GET(ASUC)
+7 SET ASUT(ASUT,"ENTR BY")=DUZ
+8 SET ASUT(ASUT,"DTE")=ASUK("DT","FM")
+9 SET ASUT(ASUT,"AR")=ASUL(1,"AR","AP")
+10 SET (ASUT(ASUT,"DTP"),ASUT(ASUT,"DTW"))=""
SET ASUT(ASUT,"STATUS")="Y"
+11 SET ASUT(ASUT,"PT","AR")=ASUT(ASUT,"AR")
+12 SET ASUT(ASUT,"PT","STA")=ASUL(2,"STA","E#")
+13 IF ASUT(ASUT,"IDX")]""
Begin DoDot:1
+14 SET ASUT(ASUT,"PT","IDX")=ASUT(ASUT,"AR")_ASUT(ASUT,"IDX")
End DoDot:1
+15 IF '$TEST
Begin DoDot:1
+16 SET ASUT(ASUT,"PT","IDX")=""
End DoDot:1
+17 IF $GET(ASUT(ASUT,"ACC"))]""
Begin DoDot:1
+18 SET ASUT(ASUT,"PT","ACC")=ASUT(ASUT,"ACC")
End DoDot:1
+19 IF '$TEST
Begin DoDot:1
+20 IF ASUT(ASUT,"PT","IDX")]""
IF $GET(ASUL(1,"AR","WHSE"))>0
Begin DoDot:2
+21 SET ASUT(ASUT,"ACC")=$PIECE($GET(^ASUMX(ASUT(ASUT,"PT","IDX"),0)),U,6)
+22 SET ASUT(ASUT,"PT","ACC")=ASUT(ASUT,"ACC")
End DoDot:2
+23 IF '$TEST
Begin DoDot:2
+24 SET (ASUT(ASUT,"ACC"),ASUT(ASUT,"PT","ACC"))=""
End DoDot:2
End DoDot:1
+25 SET DIC=9002036.6
SET X=ASUT(ASUT,"TRKY")
SET DIC(0)="L"
DO ^DIC
+26 IF Y<0
Begin DoDot:1
+27 WRITE *7,*7,!,"INVENTORY ADJUSTMENT CREATION UNSUCESSFUL",!
End DoDot:1
+28 IF '$TEST
Begin DoDot:1
+29 SET (DA,ASUHDA)=+Y
+30 SET ASUC=ASUC+1
+31 SET ASUF("SV")=1
DO WRITE^ASU0TRWR(DA,6)
End DoDot:1
+32 ;F X=3:1:22 K ASUL(X) ;LMH 6/19/00
+33 KILL DA,DR,DIC,DIE,ASUMSG,X,Y
+34 KILL ASUT(ASUT),ASUC(0)
+35 QUIT
