ASUV2RL ; IHS/ITSC/LMH -RPT RE-COUNT INVENTORY LIST ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine creates the Physical Inventory Re-count List.
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 37A 'INVENTORY RE-COUNT 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 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")=2
E D
.S ASUV("MSG",1)="YOU HAVE REQUESTED A RE-COUNT LIST BUT "
.D ASUV1PN0^ASUV1PN
G:ASUF EXIT
D ASUV2RL0
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^ASUV2RL",ZTDESC="SAMS RE-COUNT INVENTORY LIST" D O^ASUUZIS
I POP S IOP=$I D ^%ZIS Q
I 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
D ACCOUNT^ASUV9IMR
S ASUMV("E#","SLC")=""
F ASUC(1)=0:1 S ASUMV("E#","SLC")=$O(^ASUV("RL",ASUMV("E#","ASA"),ASUMV("E#","SLC"))) Q:ASUMV("E#","SLC")'?1N.N D
.D STORLOC^ASUV9IMR
.D:ASUC("LN")<1 HEADING
.S ASUMV("E#","INDX")=""
.F S ASUMV("E#","INDX")=$O(^ASUV("RL",ASUMV("E#","ASA"),ASUMV("E#","SLC"),ASUMV("E#","INDX"))) Q:ASUMV("E#","INDX")'?1N.N D
..D INDEX^ASUV9IMR
..Q:ASUMV("IDX")["*" ;MASTER HAS BEEN DELETED
..D:ASUC("LN")>55 HEADING
..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),?20,ASUMX("DESC",1),?51,ASUMX("AR U/I")
..W ?55,$J(ASUMV("QTY","STAM"),7),?63,$J(ASUMV("CNT","1ST"),7)
..W !?2,ASUV("ORD#"),?20,ASUMX("DESC",2)
..D SEPERATE
..S ASUC("LN")=ASUC("LN")+3
.D:ASUC("LN")>7 FOOTING
D:ASUC("LN")>7 FOOTING
I ASUC("1")=0 D HEADING W !,"NO ITEMS TO BE RECOUNTED -ALL MATCHED FIRST COUNT",! D SEPERATE,FOOTING
I $G(ASUK(ASUK("PTR"),"S")) D C^ASUUZIS
I '$G(ASUF("RPRN")) U IO(0) D FLAGIT2^ASUV1PN
EXIT ;
K ASUC,ASUR,ASUF,ASUMS,ASUMV,ASUV,ASUMX
K DTOUT,DUOUT,ZTDESC,ZTRTN,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 NO. 37A INVENTORY RECOUNT LISTING 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"),?60,"SLC : ",$G(ASUMV("SL NM"))
W !!,"SLC INDEX",?52,"U RECORD FIRST RECOUNT"
W !," ORD/NSN NUMBER DESCRIPTION",?53,"I BALANCE COUNT QUANTITY"
D SEPERATE
Q
SEPERATE ;
W !,"_______________________________________________________________________________"
Q
D:ASUC("LN")>56 HEADING
W !!?5,"RECOUNTERS:",?50,"DATE:"
W !?25,"SIGNATURE/TITLE"
W !!?50,"DATE:"
W !?25,"SIGNATURE/TITLE"
S ASUC("LN")=0
Q
ASUV2RL0 ;SORT
K ^ASUV("RL")
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
..Q:ASUMV("STA")']""
..Q:ASUMV("QTY","DIF")=0
..S ^ASUV("RL",ASUMV("E#","ASA"),ASUMV("E#","SLC"),ASUMV("E#","INDX"))=""
Q
ASUV2RL ; IHS/ITSC/LMH -RPT RE-COUNT INVENTORY LIST ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine creates the Physical Inventory Re-count List.
+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 37A 'INVENTORY RE-COUNT 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 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")=2
End DoDot:1
+26 IF '$TEST
Begin DoDot:1
+27 SET ASUV("MSG",1)="YOU HAVE REQUESTED A RE-COUNT LIST BUT "
+28 DO ASUV1PN0^ASUV1PN
End DoDot:1
+29 IF ASUF
GOTO EXIT
+30 DO ASUV2RL0
+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^ASUV2RL"
SET ZTDESC="SAMS RE-COUNT INVENTORY LIST"
DO O^ASUUZIS
+35 IF POP
SET IOP=$IO
DO ^%ZIS
QUIT
+36 IF 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 DO ACCOUNT^ASUV9IMR
+4 SET ASUMV("E#","SLC")=""
+5 FOR ASUC(1)=0:1
SET ASUMV("E#","SLC")=$ORDER(^ASUV("RL",ASUMV("E#","ASA"),ASUMV("E#","SLC")))
IF ASUMV("E#","SLC")'?1N.N
QUIT
Begin DoDot:1
+6 DO STORLOC^ASUV9IMR
+7 IF ASUC("LN")<1
DO HEADING
+8 SET ASUMV("E#","INDX")=""
+9 FOR
SET ASUMV("E#","INDX")=$ORDER(^ASUV("RL",ASUMV("E#","ASA"),ASUMV("E#","SLC"),ASUMV("E#","INDX")))
IF ASUMV("E#","INDX")'?1N.N
QUIT
Begin DoDot:2
+10 DO INDEX^ASUV9IMR
+11 ;MASTER HAS BEEN DELETED
IF ASUMV("IDX")["*"
QUIT
+12 IF ASUC("LN")>55
DO HEADING
+13 DO READ^ASUMXDIO
+14 SET ASUMS("E#","IDX")=$ORDER(^ASUMS(ASUL(2,"STA","E#"),1,"B",ASUMX("E#","IDX"),""))
+15 SET ASUMS("ORD#")=$PIECE(^ASUMS(ASUL(2,"STA","E#"),1,ASUMS("E#","IDX"),0),U,3)
+16 SET ASUV("ORD#")=$SELECT(ASUMS("ORD#")'=" ":ASUMS("ORD#"),1:ASUMX("NSN"))
+17 WRITE !?1,ASUMV("SLC"),?8,$EXTRACT(ASUMX("IDX"),1,5),".",$EXTRACT(ASUMX("IDX"),6,6),?20,ASUMX("DESC",1),?51,ASUMX("AR U/I")
+18 WRITE ?55,$JUSTIFY(ASUMV("QTY","STAM"),7),?63,$JUSTIFY(ASUMV("CNT","1ST"),7)
+19 WRITE !?2,ASUV("ORD#"),?20,ASUMX("DESC",2)
+20 DO SEPERATE
+21 SET ASUC("LN")=ASUC("LN")+3
End DoDot:2
+22 IF ASUC("LN")>7
DO FOOTING
End DoDot:1
+23 IF ASUC("LN")>7
DO FOOTING
+24 IF ASUC("1")=0
DO HEADING
WRITE !,"NO ITEMS TO BE RECOUNTED -ALL MATCHED FIRST COUNT",!
DO SEPERATE
DO FOOTING
+25 IF $GET(ASUK(ASUK("PTR"),"S"))
DO C^ASUUZIS
+26 IF '$GET(ASUF("RPRN"))
USE IO(0)
DO FLAGIT2^ASUV1PN
EXIT ;
+1 KILL ASUC,ASUR,ASUF,ASUMS,ASUMV,ASUV,ASUMX
+2 KILL DTOUT,DUOUT,ZTDESC,ZTRTN,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 NO. 37A INVENTORY RECOUNT LISTING 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"),?60,"SLC : ",$GET(ASUMV("SL NM"))
+5 WRITE !!,"SLC INDEX",?52,"U RECORD FIRST RECOUNT"
+6 WRITE !," ORD/NSN NUMBER DESCRIPTION",?53,"I BALANCE COUNT QUANTITY"
+7 DO SEPERATE
+8 QUIT
SEPERATE ;
+1 WRITE !,"_______________________________________________________________________________"
+2 QUIT
+1 IF ASUC("LN")>56
DO HEADING
+2 WRITE !!?5,"RECOUNTERS:",?50,"DATE:"
+3 WRITE !?25,"SIGNATURE/TITLE"
+4 WRITE !!?50,"DATE:"
+5 WRITE !?25,"SIGNATURE/TITLE"
+6 SET ASUC("LN")=0
+7 QUIT
ASUV2RL0 ;SORT
+1 KILL ^ASUV("RL")
+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("STA")']""
QUIT
+8 IF ASUMV("QTY","DIF")=0
QUIT
+9 SET ^ASUV("RL",ASUMV("E#","ASA"),ASUMV("E#","SLC"),ASUMV("E#","INDX"))=""
End DoDot:2
End DoDot:1
+10 QUIT
