ASUV1PL ; IHS/ITSC/LMH -RPT 37 PHYSICAL INVENTORY LIST ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine creates report 37 - Physical Inventory 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 XIT1
S DIC("A")="PRINT RPT 37 'PHYSICAL INVENTORY LIST' FOR WHAT ACCOUNT? "
S DIC="9002039.09",DIC(0)="AMEZQ"
D ^DIC K DIC
I $D(DTOUT)!($D(DUOUT)) G XIT1
K DIR
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 XIT1
G:ASUMV("E#","ASA")="" XIT1
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")=1
E D
.S ASUV("MSG",1)="YOU HAVE REQUESTED AN INVENTORY LIST BUT "
.D CKINIT^ASUV1PN K ASURX
G:ASUF XIT1
D ASUV1PL0
I '$D(IO) D HOME^%ZIS
I '$D(DUZ(2)) W !,"Report must be run from Kernel option" D PAZ^ASUURHDR Q
S ZTRTN="PSER^ASUV1PL",ZTDESC="SAMS PHYSICAL INVENTORY 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 XIT1
PSER ;EP;FOR TASKMAN QUEUE OF PRINT
D U^ASUUZIS
S (ASUC("PG"),ASUC("LN"))=0
D ACCOUNT^ASUV9IMR
S ASUMV("E#","SLC")=""
F S ASUMV("E#","SLC")=$O(^ASUV("IL",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("IL",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 !?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 $G(ASUK(ASUK("PTR"),"S")) D C^ASUUZIS
I '$G(ASUF("RPRN")) U IO(0) D FLAGIT1^ASUV1PN
XIT1 ;
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 37 PHYSICAL INVENTORY 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 : ",ASUMV("SL NM")
W !!,"SLC INDEX",?51,"U INVENTORY"
W !," ORD/NSN NUMBER DESCRIPTION",?53,"I COUNT"
D SEPERATE
Q
SEPERATE ;
W !,"_______________________________________________________________________________"
Q
D:ASUC("LN")>55 HEADING
W !!?5,"INVENTORY RECORDER:",?50,"DATE:"
W !?25,"SIGNATURE/TITLE"
W !!?5,"INVENTORY COUNTER:",?50,"DATE:"
W !?25,"SIGNATURE/TITLE"
S ASUC("LN")=0
Q
ASUV1PL0 ;
K ^ASUV("IL")
S ASUMV("E#","SLC")=""
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")']""
..S ^ASUV("IL",ASUMV("E#","ASA"),ASUMV("E#","SLC"),ASUMV("E#","INDX"))=""
Q
ASUV1PL ; IHS/ITSC/LMH -RPT 37 PHYSICAL INVENTORY LIST ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine creates report 37 - Physical Inventory 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 XIT1
+7 SET DIC("A")="PRINT RPT 37 'PHYSICAL INVENTORY 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 XIT1
+11 KILL DIR
+12 IF '$DATA(Y)
QUIT
IF Y=""
QUIT
+13 IF Y>0
Begin DoDot:1
+14 SET ASUMV("ACC")=$PIECE(Y,U)
SET ASUMV("E#","ASA")=ASUL(2,"STA","E#")_ASUMV("ACC")
+15 DO ACC^ASULDIRF(ASUMV("ACC"))
End DoDot:1
+16 IF '$TEST
GOTO XIT1
+17 IF ASUMV("E#","ASA")=""
GOTO XIT1
+18 IF $DATA(^ASUMV(ASUMV("E#","ASA"),0))
Begin DoDot:1
+19 DO ACCOUNT^ASUV9IMR
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 WRITE !!,"NO INVENTORY ACTIVE FOR ACCOUNT ",ASUMV("ACC")," ",ASUL(9,"ACC","NM")
+22 SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+23 SET ASUV("ASA")=ASUMV("E#","ASA")
+24 SET ASUF=$GET(ASUF)
+25 IF ASUF=2
Begin DoDot:1
+26 SET ASUF=0
SET ASUMV("MODE")=1
End DoDot:1
+27 IF '$TEST
Begin DoDot:1
+28 SET ASUV("MSG",1)="YOU HAVE REQUESTED AN INVENTORY LIST BUT "
+29 DO CKINIT^ASUV1PN
KILL ASURX
End DoDot:1
+30 IF ASUF
GOTO XIT1
+31 DO ASUV1PL0
+32 IF '$DATA(IO)
DO HOME^%ZIS
+33 IF '$DATA(DUZ(2))
WRITE !,"Report must be run from Kernel option"
DO PAZ^ASUURHDR
QUIT
+34 SET ZTRTN="PSER^ASUV1PL"
SET ZTDESC="SAMS PHYSICAL INVENTORY 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 XIT1
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
SET ASUMV("E#","SLC")=$ORDER(^ASUV("IL",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("IL",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 !?2,ASUV("ORD#"),?20,ASUMX("DESC",2)
+19 DO SEPERATE
+20 SET ASUC("LN")=ASUC("LN")+3
End DoDot:2
+21 IF ASUC("LN")>7
DO FOOTING
End DoDot:1
+22 IF ASUC("LN")>7
DO FOOTING
+23 IF $GET(ASUK(ASUK("PTR"),"S"))
DO C^ASUUZIS
+24 IF '$GET(ASUF("RPRN"))
USE IO(0)
DO FLAGIT1^ASUV1PN
XIT1 ;
+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 37 PHYSICAL INVENTORY 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 : ",ASUMV("SL NM")
+5 WRITE !!,"SLC INDEX",?51,"U INVENTORY"
+6 WRITE !," ORD/NSN NUMBER DESCRIPTION",?53,"I COUNT"
+7 DO SEPERATE
+8 QUIT
SEPERATE ;
+1 WRITE !,"_______________________________________________________________________________"
+2 QUIT
+1 IF ASUC("LN")>55
DO HEADING
+2 WRITE !!?5,"INVENTORY RECORDER:",?50,"DATE:"
+3 WRITE !?25,"SIGNATURE/TITLE"
+4 WRITE !!?5,"INVENTORY COUNTER:",?50,"DATE:"
+5 WRITE !?25,"SIGNATURE/TITLE"
+6 SET ASUC("LN")=0
+7 QUIT
ASUV1PL0 ;
+1 KILL ^ASUV("IL")
+2 SET ASUMV("E#","SLC")=""
+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 SET ^ASUV("IL",ASUMV("E#","ASA"),ASUMV("E#","SLC"),ASUMV("E#","INDX"))=""
End DoDot:2
End DoDot:1
+9 QUIT
