BLRLABLD ; IHS/DIR/FJE - INTERMEC 7421 LABEL PRINT BARCODE/PLAIN 10:16 ; [ 03/18/1999 9:09 AM ]
;;5.2;LR;**1006,1007**;MAR 1, 1999
;;5.2;LR;**1001**;FEB 1, 1998
;
;;5.2;LAB SERVICE;;Sep 27, 1994
;;V5.1;LAB;;04/11/91 11:06
;This routine is used in conjunction with the Intermec program routine
;BLRBARD to print a 3 label accession label for accession areas which
;have their BAR CODE PRINT field set to YES
;BLRLABLD may have to be renamed LRLABEL4
;The code S X=0 X ^%ZOSF("RM") is needed to replace the U IO:0 which
;works with MSM but not DSM
;
EN S:$D(ZTQUEUED) ZTREQ="@"
N I1,J
S X=0 X ^%ZOSF("RM")
S:'$L($G(LRRB)) LRRB=""
S BLRURG="" ;IHS/DIR TUC/AAB 03/23/98
S J=0,LRTXT="",FLAG=0 F I1=1:1 S J=$O(LRTS(J)) Q:J<1 I ($L(LRTXT)+$L(LRTS(J))'>24) S LRTXT=LRTXT_LRTS(J) S:$O(LRTS(J))>0 FLAG=1,LRTXT=LRTXT_";"
FLAG S:FLAG=0 LRDTXT=LRTXT S:FLAG=1 LRDTXT=".............."
S LRLPNM=$P(PNM,",",1),LRLPNM=LRLPNM_$S($L(LRLPNM)<18:","_$E($P(PNM,",",2),1),1:"")
I $D(LRBAR) D BAR Q ;IHS/MJL 3/18/99
D PRT K BLRURG
Q
BAR ;barcode label..accession number barcoded
W *2,"R",*3
W *2,*27,"E4",*24,LRACC,*3
W *2,!,LRDAT,!,LRTOP,*3
W *2,!,$E(PNM,1,27),!,HRCN,!,"W:"_$E(LRLLOC,1,7)_" B:"_LRRB,*3
W *2,!,$E("0000",$L(LRAN),4)_LRAN,*3
W *2,!,"Order#:",LRCE,!,$E(LRTXT,1,32) W:$L(LRTXT)>32 "..."
S LRURG0=$G(LRURG0) I LRURG0'="" S BLRURG=$E($P(^LAB(62.05,LRURG0,0),U,1),1,4)
W *2,!,BLRURG,*3
W *2,!,LRACC,*3
W *2,!,LRDAT,*3
W *2,!,LRACC,*3
W *2,!,$E(PNM,1,27),!,HRCN,!,"W:"_$E(LRLLOC,1,7)_" B:"_LRRB,*3
W *2,!,LRDAT,!,$E(LRTXT,1,32) W:$L(LRTXT)>32 "..."
W *2,*23,*15,"S30",*12,*3
K BLRURG
Q
PRT ;plain label..no barcode
W *2,"R",*3
W *2,*27,"E5",*24,!,LRACC,*3
W *2,!,LRDAT,!,LRTOP,*3
S X=$G(DOB) D ^%DT
W *2,!,$E(PNM,1,27),!,HRCN,!,"DOB:"_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3),!,"W:"_$E(LRLLOC,1,7)_" B:"_LRRB,*3
W *2,!,"Order#:",LRCE,!,$E(LRTXT,1,32) W:$L(LRTXT)>32 "..."
S LRURG0=$G(LRURG0) I LRURG0'="" S BLRURG=$E($P(^LAB(62.05,LRURG0,0),U,1),1,4)
W *2,!,BLRURG,*3
W *2,!,LRACC,*3
W *2,!,LRDAT,*3
W *2,!,LRACC,*3
W *2,!,$E(PNM,1,27),!,HRCN,!,"W:"_$E(LRLLOC,1,7)_" B:"_LRRB,*3
W *2,!,LRDAT,!,$E(LRTXT,1,32) W:$L(LRTXT)>32 "..."
W *2,*23,*15,"S30",*12,*3
K BLRURG
Q
BLRLABLD ; IHS/DIR/FJE - INTERMEC 7421 LABEL PRINT BARCODE/PLAIN 10:16 ; [ 03/18/1999 9:09 AM ]
+1 ;;5.2;LR;**1006,1007**;MAR 1, 1999
+2 ;;5.2;LR;**1001**;FEB 1, 1998
+3 ;
+4 ;;5.2;LAB SERVICE;;Sep 27, 1994
+5 ;;V5.1;LAB;;04/11/91 11:06
+6 ;This routine is used in conjunction with the Intermec program routine
+7 ;BLRBARD to print a 3 label accession label for accession areas which
+8 ;have their BAR CODE PRINT field set to YES
+9 ;BLRLABLD may have to be renamed LRLABEL4
+10 ;The code S X=0 X ^%ZOSF("RM") is needed to replace the U IO:0 which
+11 ;works with MSM but not DSM
+12 ;
EN IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 NEW I1,J
+2 SET X=0
XECUTE ^%ZOSF("RM")
+3 IF '$LENGTH($GET(LRRB))
SET LRRB=""
+4 ;IHS/DIR TUC/AAB 03/23/98
SET BLRURG=""
+5 SET J=0
SET LRTXT=""
SET FLAG=0
FOR I1=1:1
SET J=$ORDER(LRTS(J))
IF J<1
QUIT
IF ($LENGTH(LRTXT)+$LENGTH(LRTS(J))'>24)
SET LRTXT=LRTXT_LRTS(J)
IF $ORDER(LRTS(J))>0
SET FLAG=1
SET LRTXT=LRTXT_";"
FLAG IF FLAG=0
SET LRDTXT=LRTXT
IF FLAG=1
SET LRDTXT=".............."
+1 SET LRLPNM=$PIECE(PNM,",",1)
SET LRLPNM=LRLPNM_$SELECT($LENGTH(LRLPNM)<18:","_$EXTRACT($PIECE(PNM,",",2),1),1:"")
+2 ;IHS/MJL 3/18/99
IF $DATA(LRBAR)
DO BAR
QUIT
+3 DO PRT
KILL BLRURG
+4 QUIT
BAR ;barcode label..accession number barcoded
+1 WRITE *2,"R",*3
+2 WRITE *2,*27,"E4",*24,LRACC,*3
+3 WRITE *2,!,LRDAT,!,LRTOP,*3
+4 WRITE *2,!,$EXTRACT(PNM,1,27),!,HRCN,!,"W:"_$EXTRACT(LRLLOC,1,7)_" B:"_LRRB,*3
+5 WRITE *2,!,$EXTRACT("0000",$LENGTH(LRAN),4)_LRAN,*3
+6 WRITE *2,!,"Order#:",LRCE,!,$EXTRACT(LRTXT,1,32)
IF $LENGTH(LRTXT)>32
WRITE "..."
+7 SET LRURG0=$GET(LRURG0)
IF LRURG0'=""
SET BLRURG=$EXTRACT($PIECE(^LAB(62.05,LRURG0,0),U,1),1,4)
+8 WRITE *2,!,BLRURG,*3
+9 WRITE *2,!,LRACC,*3
+10 WRITE *2,!,LRDAT,*3
+11 WRITE *2,!,LRACC,*3
+12 WRITE *2,!,$EXTRACT(PNM,1,27),!,HRCN,!,"W:"_$EXTRACT(LRLLOC,1,7)_" B:"_LRRB,*3
+13 WRITE *2,!,LRDAT,!,$EXTRACT(LRTXT,1,32)
IF $LENGTH(LRTXT)>32
WRITE "..."
+14 WRITE *2,*23,*15,"S30",*12,*3
+15 KILL BLRURG
+16 QUIT
PRT ;plain label..no barcode
+1 WRITE *2,"R",*3
+2 WRITE *2,*27,"E5",*24,!,LRACC,*3
+3 WRITE *2,!,LRDAT,!,LRTOP,*3
+4 SET X=$GET(DOB)
DO ^%DT
+5 WRITE *2,!,$EXTRACT(PNM,1,27),!,HRCN,!,"DOB:"_$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3),!,"W:"_$EXTRACT(LRLLOC,1,7)_" B:"_LRRB,*3
+6 WRITE *2,!,"Order#:",LRCE,!,$EXTRACT(LRTXT,1,32)
IF $LENGTH(LRTXT)>32
WRITE "..."
+7 SET LRURG0=$GET(LRURG0)
IF LRURG0'=""
SET BLRURG=$EXTRACT($PIECE(^LAB(62.05,LRURG0,0),U,1),1,4)
+8 WRITE *2,!,BLRURG,*3
+9 WRITE *2,!,LRACC,*3
+10 WRITE *2,!,LRDAT,*3
+11 WRITE *2,!,LRACC,*3
+12 WRITE *2,!,$EXTRACT(PNM,1,27),!,HRCN,!,"W:"_$EXTRACT(LRLLOC,1,7)_" B:"_LRRB,*3
+13 WRITE *2,!,LRDAT,!,$EXTRACT(LRTXT,1,32)
IF $LENGTH(LRTXT)>32
WRITE "..."
+14 WRITE *2,*23,*15,"S30",*12,*3
+15 KILL BLRURG
+16 QUIT
