ASUV3AL ; IHS/ITSC/LMH -INITIAL INVENTORY OVER/SHORT LIST ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine creates the Inventory Over/Short List 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
D CLS^ASUUHDG
I $G(ASUL(2,"STA","E#"))']"" D STA^ASUV0NT I $D(DTOUT)!($D(DUOUT)) G EXIT
S DIC("A")=" PRINT RPT 37B 'OVERAGE/SHORTAGE LIST' FOR WHAT ACCOUNT? "
S DIC="9002039.09",DIC(0)="AMEZQ"
D ^DIC K DIC
I $D(DTOUT)!($D(DUOUT)) G EXIT
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 G EXIT
G:ASUMV("E#","ASA")="" EXIT
I $D(^ASUMV(ASUMV("E#","ASA"),0)) D
.D ACCOUNT^ASUV9IMR
E D Q
.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 OVERAGE/SHORTAGE LIST BUT "
.D ASUV2RN0^ASUV2RN
G:ASUF EXIT
D ASUV3AL0
I '$D(IO) D HOME^%ZIS
I '$D(DUZ(2)) W !,"Report must be run from Kernel option" Q
I '$D(ASUL(1,"AR","AP")) D SETAREA^ASULARST
S ZTRTN="PSER^ASUV3AL",ZTDESC="SAMS OVER/SHORT LIST" D O^ASUUZIS
I POP S IOP=$I D ^%ZIS Q
I ASUK(ASUK("PTR"),"Q") K IOP,POP,ZTDESC,ZTRTN,ZTSK,ASUK(ASUK("PTR")),ASUK("PTR"),ASUK("PTR-Q") G EXIT
PSER ;EP;FOR TASKMAN QUEUE OF PRINT
D U^ASUUZIS
S (ASUC("PG"),ASUC("LN"))=0
S ASUMV("E#","SLC")=""
I ASUL(2,"STA","E#")'=ASUL(2,"STA","CD") S X=ASUL(1,"AR","E#"),(ASUL(2,"STA","CD"),X1)=$P(^ASUMS(ASUL(2,"STA","E#"),0),U) D STAT^ASULARST
S ASUMV("E#","INDX")=""
D:ASUC("LN")<1 HEADING
F S ASUMV("E#","INDX")=$O(^ASUV("OS",ASUMV("E#","ASA"),ASUMV("E#","INDX"))) Q:ASUMV("E#","INDX")'?1N.N D
.S ASUMV("E#","SLC")=^ASUV("OS",ASUMV("E#","ASA"),ASUMV("E#","INDX"))
.D ^ASUV9IMR
.D:ASUC("LN")>55 HEADING
.S ASUV("CNT","LST")=$S(ASUMV("CNT","2ND"):ASUMV("CNT","2ND"),1:ASUMV("CNT","1ST"))
.S ASUV("VALO/S")=ASUMV("QTY","DIF")*ASUMV("U/C")
.I ASUV("VALO/S")<25,ASUV("VALO/S")'<-25 D Q
..S ASUMV("CNT-ENT")=3 D INDEX^ASUV9IMW ;CHANGE TO UPDATE AS ADJUSTED
.D READ^ASUMXDIO
.S ASUMS("E#","IDX")=$O(^ASUMS(ASUL(2,"STA","E#"),1,"B",ASUMX("E#","IDX"),""))
.S ASUMS("ORD#")=$P(^ASUMS(ASUL(2,"STA","E#"),1,ASUMS("E#","IDX"),0),U,3)
.S ASUV("ORD#")=$S(ASUMS("ORD#")'=" ":ASUMS("ORD#"),1:ASUMX("NSN"))
.W !?1,ASUMV("SLC"),?8,$E(ASUMX("IDX"),1,5),".",$E(ASUMX("IDX"),6,6)
.W ?20,ASUMX("DESC",1),?52,ASUMX("AR U/I"),?56,$J(ASUMV("U/C"),6)
.W ?63,$J(ASUMV("QTY","STAM"),6),?70,$J(ASUV("CNT","LST"),6)
.W !?2,ASUV("ORD#"),?20,ASUMX("DESC",2)
.W !?5,$S(ASUMV("QTY","DIF")<0:"SHT",1:"OVR"),?11,"QTY: ",$FN(ASUMV("QTY","DIF"),"-,")
.W ?25,"VAL: ",$FN(ASUV("VALO/S"),"-,",2),?40,"RSCH/ADJ MASTER QUANTITY:"
.W !?1,"REMARKS:",!!
.D SEPERATE
.S ASUC("LN")=ASUC("LN")+7
D:ASUC("LN")>7 FOOTING
I $G(ASUK(ASUK("PTR"),"S")) D C^ASUUZIS
I '$G(ASUF("RPRN")) U IO(0) D FLAGIT3^ASUV2RN
EXIT ;
K ASUC,ASUR,ASUF,ASUMS,ASUMV,ASUV,ASUMX
K DTOUT,DUOUT,ZTRTN,ZTDESC,X,Y,X1
D:$D(ASUK("PTR")) C^ASUUZIS
Q
HEADING ;
D CLS^ASUUHDG S ASUC("PG")=ASUC("PG")+1,ASUC("LN")=7
W "REPORT 37B INITIAL INVENTORY OVERAGE/SHORTAGE LIST DATE: ",ASUK("RUN","DT"),?70," PAGE: ",ASUC("PG")
W !,"AREA: ",ASUL(1,"AR","E#")," ",ASUL(1,"AR","NM")
W !,"STAT: ",ASUL(2,"STA","CD")," ",ASUL(2,"STA","NM"),?35,"ACCOUNT : ",ASUL(9,"ACC","NM")
W !!,"SLC INDEX",?52,"U UNIT RECORD INV"
W !," ORD/NSN NUMBER DESCRIPTION",?53,"I COST BALANCE QTY"
D SEPERATE
Q
SEPERATE ;
W !,"_______________________________________________________________________________"
Q
S ASUC("LN")=0
Q
ASUV3AL0 ;
K ^ASUV("OS")
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
..D ^ASUV9IMR
..I ASUMV("QTY","DIF")<2,ASUMV("QTY","DIF")'<-1 D Q
...S ASUMV("CNT-ENT")=3 D INDEX^ASUV9IMW
..S ^ASUV("OS",ASUMV("E#","ASA"),ASUMV("E#","INDX"))=ASUMV("E#","SLC")
Q
ASUV3AL ; IHS/ITSC/LMH -INITIAL INVENTORY OVER/SHORT LIST ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine creates the Inventory Over/Short List Report
+3 IF '$DATA(DT)
DO ^XBKVAR
SET %H=$HOROLOG
DO YX^%DTC
SET ASUK("RUN","DT")=$PIECE(Y,"@")
KILL X,Y,%H
+4 IF '$DATA(IO(0))
DO HOME^%ZIS
+5 DO CLS^ASUUHDG
+6 IF $GET(ASUL(2,"STA","E#"))']""
DO STA^ASUV0NT
IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO EXIT
+7 SET DIC("A")=" PRINT RPT 37B 'OVERAGE/SHORTAGE LIST' FOR WHAT ACCOUNT? "
+8 SET DIC="9002039.09"
SET DIC(0)="AMEZQ"
+9 DO ^DIC
KILL DIC
+10 IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO EXIT
+11 IF '$DATA(Y)
QUIT
IF Y=""
QUIT
+12 IF Y>0
Begin DoDot:1
+13 SET ASUMV("ACC")=$PIECE(Y,U)
SET ASUMV("E#","ASA")=ASUL(2,"STA","E#")_ASUMV("ACC")
+14 DO ACC^ASULDIRF(ASUMV("ACC"))
End DoDot:1
+15 IF '$TEST
GOTO EXIT
+16 IF ASUMV("E#","ASA")=""
GOTO EXIT
+17 IF $DATA(^ASUMV(ASUMV("E#","ASA"),0))
Begin DoDot:1
+18 DO ACCOUNT^ASUV9IMR
End DoDot:1
+19 IF '$TEST
Begin DoDot:1
+20 WRITE !!,"NO INVENTORY IS ACTIVE FOR ACCOUNT '",ASUMV("ACC"),"' -",ASUL(9,"ACC","NM")
+21 SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+22 SET ASUV("ASA")=ASUMV("E#","ASA")
+23 SET ASUF=$GET(ASUF)
+24 IF ASUF=2
Begin DoDot:1
+25 SET ASUF=0
SET ASUMV("MODE")=3
End DoDot:1
+26 IF '$TEST
Begin DoDot:1
+27 SET ASUV("MSG",1)="YOU HAVE REQUESTED AN OVERAGE/SHORTAGE LIST BUT "
+28 DO ASUV2RN0^ASUV2RN
End DoDot:1
+29 IF ASUF
GOTO EXIT
+30 DO ASUV3AL0
+31 IF '$DATA(IO)
DO HOME^%ZIS
+32 IF '$DATA(DUZ(2))
WRITE !,"Report must be run from Kernel option"
QUIT
+33 IF '$DATA(ASUL(1,"AR","AP"))
DO SETAREA^ASULARST
+34 SET ZTRTN="PSER^ASUV3AL"
SET ZTDESC="SAMS OVER/SHORT LIST"
DO O^ASUUZIS
+35 IF POP
SET IOP=$IO
DO ^%ZIS
QUIT
+36 IF ASUK(ASUK("PTR"),"Q")
KILL IOP,POP,ZTDESC,ZTRTN,ZTSK,ASUK(ASUK("PTR")),ASUK("PTR"),ASUK("PTR-Q")
GOTO EXIT
PSER ;EP;FOR TASKMAN QUEUE OF PRINT
+1 DO U^ASUUZIS
+2 SET (ASUC("PG"),ASUC("LN"))=0
+3 SET ASUMV("E#","SLC")=""
+4 IF ASUL(2,"STA","E#")'=ASUL(2,"STA","CD")
SET X=ASUL(1,"AR","E#")
SET (ASUL(2,"STA","CD"),X1)=$PIECE(^ASUMS(ASUL(2,"STA","E#"),0),U)
DO STAT^ASULARST
+5 SET ASUMV("E#","INDX")=""
+6 IF ASUC("LN")<1
DO HEADING
+7 FOR
SET ASUMV("E#","INDX")=$ORDER(^ASUV("OS",ASUMV("E#","ASA"),ASUMV("E#","INDX")))
IF ASUMV("E#","INDX")'?1N.N
QUIT
Begin DoDot:1
+8 SET ASUMV("E#","SLC")=^ASUV("OS",ASUMV("E#","ASA"),ASUMV("E#","INDX"))
+9 DO ^ASUV9IMR
+10 IF ASUC("LN")>55
DO HEADING
+11 SET ASUV("CNT","LST")=$SELECT(ASUMV("CNT","2ND"):ASUMV("CNT","2ND"),1:ASUMV("CNT","1ST"))
+12 SET ASUV("VALO/S")=ASUMV("QTY","DIF")*ASUMV("U/C")
+13 IF ASUV("VALO/S")<25
IF ASUV("VALO/S")'<-25
Begin DoDot:2
+14 ;CHANGE TO UPDATE AS ADJUSTED
SET ASUMV("CNT-ENT")=3
DO INDEX^ASUV9IMW
End DoDot:2
QUIT
+15 DO READ^ASUMXDIO
+16 SET ASUMS("E#","IDX")=$ORDER(^ASUMS(ASUL(2,"STA","E#"),1,"B",ASUMX("E#","IDX"),""))
+17 SET ASUMS("ORD#")=$PIECE(^ASUMS(ASUL(2,"STA","E#"),1,ASUMS("E#","IDX"),0),U,3)
+18 SET ASUV("ORD#")=$SELECT(ASUMS("ORD#")'=" ":ASUMS("ORD#"),1:ASUMX("NSN"))
+19 WRITE !?1,ASUMV("SLC"),?8,$EXTRACT(ASUMX("IDX"),1,5),".",$EXTRACT(ASUMX("IDX"),6,6)
+20 WRITE ?20,ASUMX("DESC",1),?52,ASUMX("AR U/I"),?56,$JUSTIFY(ASUMV("U/C"),6)
+21 WRITE ?63,$JUSTIFY(ASUMV("QTY","STAM"),6),?70,$JUSTIFY(ASUV("CNT","LST"),6)
+22 WRITE !?2,ASUV("ORD#"),?20,ASUMX("DESC",2)
+23 WRITE !?5,$SELECT(ASUMV("QTY","DIF")<0:"SHT",1:"OVR"),?11,"QTY: ",$FNUMBER(ASUMV("QTY","DIF"),"-,")
+24 WRITE ?25,"VAL: ",$FNUMBER(ASUV("VALO/S"),"-,",2),?40,"RSCH/ADJ MASTER QUANTITY:"
+25 WRITE !?1,"REMARKS:",!!
+26 DO SEPERATE
+27 SET ASUC("LN")=ASUC("LN")+7
End DoDot:1
+28 IF ASUC("LN")>7
DO FOOTING
+29 IF $GET(ASUK(ASUK("PTR"),"S"))
DO C^ASUUZIS
+30 IF '$GET(ASUF("RPRN"))
USE IO(0)
DO FLAGIT3^ASUV2RN
EXIT ;
+1 KILL ASUC,ASUR,ASUF,ASUMS,ASUMV,ASUV,ASUMX
+2 KILL DTOUT,DUOUT,ZTRTN,ZTDESC,X,Y,X1
+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 37B INITIAL INVENTORY OVERAGE/SHORTAGE LIST DATE: ",ASUK("RUN","DT"),?70," PAGE: ",ASUC("PG")
+3 WRITE !,"AREA: ",ASUL(1,"AR","E#")," ",ASUL(1,"AR","NM")
+4 WRITE !,"STAT: ",ASUL(2,"STA","CD")," ",ASUL(2,"STA","NM"),?35,"ACCOUNT : ",ASUL(9,"ACC","NM")
+5 WRITE !!,"SLC INDEX",?52,"U UNIT RECORD INV"
+6 WRITE !," ORD/NSN NUMBER DESCRIPTION",?53,"I COST BALANCE QTY"
+7 DO SEPERATE
+8 QUIT
SEPERATE ;
+1 WRITE !,"_______________________________________________________________________________"
+2 QUIT
+1 SET ASUC("LN")=0
+2 QUIT
ASUV3AL0 ;
+1 KILL ^ASUV("OS")
+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 DO ^ASUV9IMR
+7 IF ASUMV("QTY","DIF")<2
IF ASUMV("QTY","DIF")'<-1
Begin DoDot:3
+8 SET ASUMV("CNT-ENT")=3
DO INDEX^ASUV9IMW
End DoDot:3
QUIT
+9 SET ^ASUV("OS",ASUMV("E#","ASA"),ASUMV("E#","INDX"))=ASUMV("E#","SLC")
End DoDot:2
End DoDot:1
+10 QUIT
