ASUV3AL.m

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

FOOTING ;

 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 

FOOTING   ;

 +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