ASURO26B ; IHS/ITSC/LMH - WAREHOUSE BIN LABEL REPORT 26B ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine prints report #26 Warehouse Bin labels
Q ;WAR 5/21/99
D B0 I '$D(ASUR("26B")) D KIL Q
;
;Kill line variables
K ASU1(1),ASU1(2),ASU1(3),ASUR(4)
;
K %ZIS,IOP,IO("Q") S %ZIS="QM" D ^%ZIS I POP W !,"No device selected or report queued." G KIL
I $D(IO("Q")) K IO("Q") S ZTIO=ION K ZTSAVE,ZTDTH,ZTSK S ZTRTN="QUE^ASURO26B",ZTSAVE("DUZ*")="",ZTSAVE("ASUR(""HEAD"")")="",ZTSAVE("ASURO26B(")="",ZTDTH=$H D ^%ZTLOAD W !,"Queued" G KIL
;
QUE ;EP; for task man
;Go build ^XTMP("ASUR","R26B"
D EN1
D KIL U IO
W !!,"REPORT N0. 26B WAREHOUSE BIN LABELS"
W !,ASUR("HEAD"),!!!
;Run output then quit
S ASUC=0
F S ASURD(1)=$O(^XTMP("ASUR","R26B",$G(ASURD(1)))) Q:ASURD(1)="" D
.F S ASURD(2)=$O(^XTMP("ASUR","R26B",ASURD(1),$G(ASURD(2)))) Q:ASURD(2)="" D
..F S ASURD(3)=$O(^XTMP("ASUR","R26B",ASURD(1),ASURD(2),$G(ASURD(3)))) Q:ASURD(3)="" D
...F S ASURD(4)=$O(^XTMP("ASUR","R26B",ASURD(1),ASURD(2),ASURD(3),$G(ASURD(4)))) Q:ASURD(4)="" D
....F S ASURD(5)=$O(^XTMP("ASUR","R26B",ASURD(1),ASURD(2),ASURD(3),ASURD(4),$G(ASURD(5)))) Q:ASURD(5)="" S ASUR("26B","DATA")=^(ASURD(5)) S ASUC=ASUC+1 D B3
I $D(ASU1(1)),$D(ASU1(2)),$D(ASU1(3)) D PL
D KIL,PAZ^ASUURHDR,^%ZISC
Q
PL ;Print out label
;
;LINE 1
W !,"INDEX # ",$P(ASU1(1),U,2),?25,"SLC: ",$P(ASU1(1),U,3)
W ?42,"INDEX # ",$P(ASU1(1),U,4),?67,"SLC: ",$P(ASU1(1),U,5)
W ?82,"INDEX # ",$P(ASU1(1),U,6),?107,"SLC: ",$P(ASU1(1),U,7)
;
;LINE 2
W !,"UNIT OF ISS: ",$J($P(ASU1(2),U,2),2),?25,"RPQ: ",$P(ASU1(2),U,3)
W ?42,"UNIT OF ISS: ",$P(ASU1(2),U,4),?67,"RPQ: ",$P(ASU1(2),U,5)
W ?82,"UNIT OF ISS: ",$P(ASU1(2),U,6),?107,"RPQ: ",$P(ASU1(2),U,7)
;
;LINE 3
W !,"DESC: ",$P(ASU1(3),U,2),?42,"DESC: ",$P(ASU1(3),U,3),?82,"DESC: ",$P(ASU1(3),U,4)
;
;LINE 4
W !?6,$P(ASUR(4),U,2),?48,$P(ASUR(4),U,3),?88,$P(ASUR(4),U,4),!!
Q
KIL ;Kill variables
K ASURD,ASUR("26B"),ASUC
Q
B3 ;Build 3 labels accross
;Label stock is designed to print 3 across. This is hard coded in
;and if the stock changes, the code must be changed
S ASU1(1)=$G(ASU1(1))_U_ASURD(5)_U_ASURD(4)
S ASU1(2)=$G(ASU1(2))_U_$P(ASUR("26B","DATA"),U)_U_$P(ASUR("26B","DATA"),U,4)
S ASU1(3)=$G(ASU1(3))_U_$P(ASUR("26B","DATA"),U,2)
S ASUR(4)=$G(ASUR(4))_U_$P(ASUR("26B","DATA"),U,3)
I ASUC=3 D PL S ASUC=0 K ASUR Q
Q
B0 ;
K ^XTMP("ASUR","R26B"),ASUR
S ^XTMP("ASUR","R26B",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
S DIR("A")="Print WareHouse Bin Labels for"
S DIR(0)="S^1:ACCOUNT 1;3:ACCOUNT 3;5:ALL OTHER ACCOUNTS;7:STORAGE LOCATION CODES;9:ALL BIN LABELS^S ASUR(""26B"",""ASK"")=Y"
D ^DIR I $D(DIRUT)!($D(DIROUT))!(X="^") D KILL Q
S ASUR("HEAD")=$S(Y=1:"ACCOUNT 1",Y=3:"ACCOUNT 3",Y=5:"ALL OTHER ACCOUNTS",1:"ALL BIN LABELS")
;
I ASUR("26B","ASK")=7 D
.S DIC=9002039.1,DIC(0)="AEQZ",DIC("A")="SELECT STORAGE LOCATION CODE : " D ^DIC I Y<0 D KILL Q
.S ASUR("26B","ASK")=$P(Y(0),U),ASUR("HEAD")="SLC: "_$P(Y(0),U)
Q
EN1 ;EP Entry to build ^XTMP("ASUR","R26B"
F ASUMS("E#","STA")=0:0 S ASUMS("E#","STA")=$O(^ASUMS(ASUMS("E#","STA"))) Q:'ASUMS("E#","STA") D
.F ASUMS("E#","IDX")=0:0 S ASUMS("E#","IDX")=$O(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"))) Q:'ASUMS("E#","IDX") D
..D ^ASUMSTRD Q:ASUF("DLIDX")=1
..D ARE^ASULARST(ASUMS("AR"))
..D STA^ASULARST(ASUMS("STA"))
..D IDX^ASUMXDIO(ASUMS("E#","IDX")) S ASUR("IDX")=$E(ASUMX("IDX"),1,5)_"."_$E(ASUMX("IDX"),6)
..D ACC^ASULDIRF(ASUMX("ACC"))
..I ASUR("26B","ASK")=9 D SORT Q
..I ASUR("26B","ASK")=ASUMX("ACC") D SORT Q
..I ASUR("26B","ASK")=ASUMS("SLC") D SORT Q
KILL ;
K ASUR("26B")
Q
SORT ;Build sort global
S X=ASUMX("AR U/I")_U_ASUMX("DESC",1)_U_ASUMX("DESC",2)_U_ASUMS("RPQ")
S:ASUMS("SLC")']"" ASUMS("SLC")=" "
S ^XTMP("ASUR","R26B",ASUL(1,"AR","AP")_"-"_ASUL(1,"AR","NM"),ASUL(2,"STA","CD")_"-"_ASUL(2,"STA","NM"),ASUMX("ACC"),ASUMS("SLC"),ASUR("IDX"))=X
Q
ASURO26B ; IHS/ITSC/LMH - WAREHOUSE BIN LABEL REPORT 26B ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine prints report #26 Warehouse Bin labels
+3 ;WAR 5/21/99
QUIT
+4 DO B0
IF '$DATA(ASUR("26B"))
DO KIL
QUIT
+5 ;
+6 ;Kill line variables
+7 KILL ASU1(1),ASU1(2),ASU1(3),ASUR(4)
+8 ;
+9 KILL %ZIS,IOP,IO("Q")
SET %ZIS="QM"
DO ^%ZIS
IF POP
WRITE !,"No device selected or report queued."
GOTO KIL
+10 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTIO=ION
KILL ZTSAVE,ZTDTH,ZTSK
SET ZTRTN="QUE^ASURO26B"
SET ZTSAVE("DUZ*")=""
SET ZTSAVE("ASUR(""HEAD"")")=""
SET ZTSAVE("ASURO26B(")=""
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
WRITE !,"Queued"
GOTO KIL
+11 ;
QUE ;EP; for task man
+1 ;Go build ^XTMP("ASUR","R26B"
+2 DO EN1
+3 DO KIL
USE IO
+4 WRITE !!,"REPORT N0. 26B WAREHOUSE BIN LABELS"
+5 WRITE !,ASUR("HEAD"),!!!
+6 ;Run output then quit
+7 SET ASUC=0
+8 FOR
SET ASURD(1)=$ORDER(^XTMP("ASUR","R26B",$GET(ASURD(1))))
IF ASURD(1)=""
QUIT
Begin DoDot:1
+9 FOR
SET ASURD(2)=$ORDER(^XTMP("ASUR","R26B",ASURD(1),$GET(ASURD(2))))
IF ASURD(2)=""
QUIT
Begin DoDot:2
+10 FOR
SET ASURD(3)=$ORDER(^XTMP("ASUR","R26B",ASURD(1),ASURD(2),$GET(ASURD(3))))
IF ASURD(3)=""
QUIT
Begin DoDot:3
+11 FOR
SET ASURD(4)=$ORDER(^XTMP("ASUR","R26B",ASURD(1),ASURD(2),ASURD(3),$GET(ASURD(4))))
IF ASURD(4)=""
QUIT
Begin DoDot:4
+12 FOR
SET ASURD(5)=$ORDER(^XTMP("ASUR","R26B",ASURD(1),ASURD(2),ASURD(3),ASURD(4),$GET(ASURD(5))))
IF ASURD(5)=""
QUIT
SET ASUR("26B","DATA")=^(ASURD(5))
SET ASUC=ASUC+1
DO B3
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 IF $DATA(ASU1(1))
IF $DATA(ASU1(2))
IF $DATA(ASU1(3))
DO PL
+14 DO KIL
DO PAZ^ASUURHDR
DO ^%ZISC
+15 QUIT
PL ;Print out label
+1 ;
+2 ;LINE 1
+3 WRITE !,"INDEX # ",$PIECE(ASU1(1),U,2),?25,"SLC: ",$PIECE(ASU1(1),U,3)
+4 WRITE ?42,"INDEX # ",$PIECE(ASU1(1),U,4),?67,"SLC: ",$PIECE(ASU1(1),U,5)
+5 WRITE ?82,"INDEX # ",$PIECE(ASU1(1),U,6),?107,"SLC: ",$PIECE(ASU1(1),U,7)
+6 ;
+7 ;LINE 2
+8 WRITE !,"UNIT OF ISS: ",$JUSTIFY($PIECE(ASU1(2),U,2),2),?25,"RPQ: ",$PIECE(ASU1(2),U,3)
+9 WRITE ?42,"UNIT OF ISS: ",$PIECE(ASU1(2),U,4),?67,"RPQ: ",$PIECE(ASU1(2),U,5)
+10 WRITE ?82,"UNIT OF ISS: ",$PIECE(ASU1(2),U,6),?107,"RPQ: ",$PIECE(ASU1(2),U,7)
+11 ;
+12 ;LINE 3
+13 WRITE !,"DESC: ",$PIECE(ASU1(3),U,2),?42,"DESC: ",$PIECE(ASU1(3),U,3),?82,"DESC: ",$PIECE(ASU1(3),U,4)
+14 ;
+15 ;LINE 4
+16 WRITE !?6,$PIECE(ASUR(4),U,2),?48,$PIECE(ASUR(4),U,3),?88,$PIECE(ASUR(4),U,4),!!
+17 QUIT
KIL ;Kill variables
+1 KILL ASURD,ASUR("26B"),ASUC
+2 QUIT
B3 ;Build 3 labels accross
+1 ;Label stock is designed to print 3 across. This is hard coded in
+2 ;and if the stock changes, the code must be changed
+3 SET ASU1(1)=$GET(ASU1(1))_U_ASURD(5)_U_ASURD(4)
+4 SET ASU1(2)=$GET(ASU1(2))_U_$PIECE(ASUR("26B","DATA"),U)_U_$PIECE(ASUR("26B","DATA"),U,4)
+5 SET ASU1(3)=$GET(ASU1(3))_U_$PIECE(ASUR("26B","DATA"),U,2)
+6 SET ASUR(4)=$GET(ASUR(4))_U_$PIECE(ASUR("26B","DATA"),U,3)
+7 IF ASUC=3
DO PL
SET ASUC=0
KILL ASUR
QUIT
+8 QUIT
B0 ;
+1 KILL ^XTMP("ASUR","R26B"),ASUR
+2 SET ^XTMP("ASUR","R26B",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
+3 SET DIR("A")="Print WareHouse Bin Labels for"
+4 SET DIR(0)="S^1:ACCOUNT 1;3:ACCOUNT 3;5:ALL OTHER ACCOUNTS;7:STORAGE LOCATION CODES;9:ALL BIN LABELS^S ASUR(""26B"",""ASK"")=Y"
+5 DO ^DIR
IF $DATA(DIRUT)!($DATA(DIROUT))!(X="^")
DO KILL
QUIT
+6 SET ASUR("HEAD")=$SELECT(Y=1:"ACCOUNT 1",Y=3:"ACCOUNT 3",Y=5:"ALL OTHER ACCOUNTS",1:"ALL BIN LABELS")
+7 ;
+8 IF ASUR("26B","ASK")=7
Begin DoDot:1
+9 SET DIC=9002039.1
SET DIC(0)="AEQZ"
SET DIC("A")="SELECT STORAGE LOCATION CODE : "
DO ^DIC
IF Y<0
DO KILL
QUIT
+10 SET ASUR("26B","ASK")=$PIECE(Y(0),U)
SET ASUR("HEAD")="SLC: "_$PIECE(Y(0),U)
End DoDot:1
+11 QUIT
EN1 ;EP Entry to build ^XTMP("ASUR","R26B"
+1 FOR ASUMS("E#","STA")=0:0
SET ASUMS("E#","STA")=$ORDER(^ASUMS(ASUMS("E#","STA")))
IF 'ASUMS("E#","STA")
QUIT
Begin DoDot:1
+2 FOR ASUMS("E#","IDX")=0:0
SET ASUMS("E#","IDX")=$ORDER(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX")))
IF 'ASUMS("E#","IDX")
QUIT
Begin DoDot:2
+3 DO ^ASUMSTRD
IF ASUF("DLIDX")=1
QUIT
+4 DO ARE^ASULARST(ASUMS("AR"))
+5 DO STA^ASULARST(ASUMS("STA"))
+6 DO IDX^ASUMXDIO(ASUMS("E#","IDX"))
SET ASUR("IDX")=$EXTRACT(ASUMX("IDX"),1,5)_"."_$EXTRACT(ASUMX("IDX"),6)
+7 DO ACC^ASULDIRF(ASUMX("ACC"))
+8 IF ASUR("26B","ASK")=9
DO SORT
QUIT
+9 IF ASUR("26B","ASK")=ASUMX("ACC")
DO SORT
QUIT
+10 IF ASUR("26B","ASK")=ASUMS("SLC")
DO SORT
QUIT
End DoDot:2
End DoDot:1
KILL ;
+1 KILL ASUR("26B")
+2 QUIT
SORT ;Build sort global
+1 SET X=ASUMX("AR U/I")_U_ASUMX("DESC",1)_U_ASUMX("DESC",2)_U_ASUMS("RPQ")
+2 IF ASUMS("SLC")']""
SET ASUMS("SLC")=" "
+3 SET ^XTMP("ASUR","R26B",ASUL(1,"AR","AP")_"-"_ASUL(1,"AR","NM"),ASUL(2,"STA","CD")_"-"_ASUL(2,"STA","NM"),ASUMX("ACC"),ASUMS("SLC"),ASUR("IDX"))=X
+4 QUIT
