BLRLABLE ; IHS/DIR/FJE - INTERMEC 4100 2 LABEL PRINT BARCODE/PLAIN 10:16 ; [ 10/12/1999 12:08 PM ]
;;5.2;LR;**1006,1007,1009**;MAR 1, 1999
;;5.2;LR;**1001**;FEB 1, 1998
;;MODIFIED 10/12/99 BY FJEVANS PER REQUEST
;;ADDS PROVIDER FIXED FOR SSMARIE
;
;;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
;LRBARA to print a two label accession label for accession areas which
;have their BAR CODE PRINT field set to YES
;LRLABELA may have to be renamed LRLABEL6
;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=""
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:'$D(LRBAR)!('$D(LRBAR($G(LRAA))))
Q
BAR ;barcode label..accession number barcoded
W *2,"R",*3
W *2,*27,"E3",*24,!,$E(LRTXT,1,32) W:$L(LRTXT)>32 "..." W *3
W *2,!,LRTOP,!,"O#:",LRCE,!,LRACC,!,LRDAT,!,HRCN,!,"W:"_$E(LRLLOC,1,9),*3
W *2,!,$E(PNM,1,27),*3
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,!,$E("0000",$L(LRAN),4)_LRAN,*3
I '$D(LRDOC),$G(LRAA),$G(LRAD),$G(LRAN) D
. S LRDOC=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,8)
. S:LRDOC LRDOC=$P($G(^VA(200,LRDOC,0)),U)
S LRDOC=$G(LRDOC)
W *2,!,LRDOC,*3
S X=$G(DOB) D ^%DT
W *2,!,$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700),*3
W *2,*23,*15,"S30",*12,*3
K BLRURG
Q
PRT ;plain label..no barcode
W *2,"R",*3
W *2,*27,"E2",*24,!,$E(LRTXT,1,32) W:$L(LRTXT)>32 "..." W *3
W *2,!,"O#:",LRCE,!,"W:"_$E(LRLLOC,1,9),*3
S X=$G(DOB) D ^%DT
W *2,!,HRCN,!,"DOB:"_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700),*3
W *2,!,PNM,!,LRTOP,!,LRDAT,!,LRACC,*3
S LRURG0=$G(LRURG0) I LRURG0'="" S BLRURG=$E($P(^LAB(62.05,LRURG0,0),U,1),1,4)
W *2,!,BLRURG,*3
I '$D(LRDOC),$G(LRAA),$G(LRAD),$G(LRAN) D
. S LRDOC=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,8)
. S:LRDOC LRDOC=$P($G(^VA(200,LRDOC,0)),U)
S LRDOC=$G(LRDOC)
W *2,!,LRDOC,*3
W *2,*23,*15,"S30",*12,*3
Q
BLRLABLE ; IHS/DIR/FJE - INTERMEC 4100 2 LABEL PRINT BARCODE/PLAIN 10:16 ; [ 10/12/1999 12:08 PM ]
+1 ;;5.2;LR;**1006,1007,1009**;MAR 1, 1999
+2 ;;5.2;LR;**1001**;FEB 1, 1998
+3 ;;MODIFIED 10/12/99 BY FJEVANS PER REQUEST
+4 ;;ADDS PROVIDER FIXED FOR SSMARIE
+5 ;
+6 ;;5.2;LAB SERVICE;;Sep 27, 1994
+7 ;;V5.1;LAB;;04/11/91 11:06
+8 ;This routine is used in conjunction with the Intermec program routine
+9 ;LRBARA to print a two label accession label for accession areas which
+10 ;have their BAR CODE PRINT field set to YES
+11 ;LRLABELA may have to be renamed LRLABEL6
+12 ;The code S X=0 X ^%ZOSF("RM") is needed to replace the U IO:0 which
+13 ;works with MSM but not DSM
+14 ;
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 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 ;Q:'$D(LRBAR)!('$D(LRBAR($G(LRAA))))
+5 QUIT
BAR ;barcode label..accession number barcoded
+1 WRITE *2,"R",*3
+2 WRITE *2,*27,"E3",*24,!,$EXTRACT(LRTXT,1,32)
IF $LENGTH(LRTXT)>32
WRITE "..."
WRITE *3
+3 WRITE *2,!,LRTOP,!,"O#:",LRCE,!,LRACC,!,LRDAT,!,HRCN,!,"W:"_$EXTRACT(LRLLOC,1,9),*3
+4 WRITE *2,!,$EXTRACT(PNM,1,27),*3
+5 SET LRURG0=$GET(LRURG0)
IF LRURG0'=""
SET BLRURG=$EXTRACT($PIECE(^LAB(62.05,LRURG0,0),U,1),1,4)
+6 WRITE *2,!,BLRURG,*3
+7 WRITE *2,!,$EXTRACT("0000",$LENGTH(LRAN),4)_LRAN,*3
+8 IF '$DATA(LRDOC)
IF $GET(LRAA)
IF $GET(LRAD)
IF $GET(LRAN)
Begin DoDot:1
+9 SET LRDOC=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,8)
+10 IF LRDOC
SET LRDOC=$PIECE($GET(^VA(200,LRDOC,0)),U)
End DoDot:1
+11 SET LRDOC=$GET(LRDOC)
+12 WRITE *2,!,LRDOC,*3
+13 SET X=$GET(DOB)
DO ^%DT
+14 WRITE *2,!,$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_($EXTRACT(Y,1,3)+1700),*3
+15 WRITE *2,*23,*15,"S30",*12,*3
+16 KILL BLRURG
+17 QUIT
PRT ;plain label..no barcode
+1 WRITE *2,"R",*3
+2 WRITE *2,*27,"E2",*24,!,$EXTRACT(LRTXT,1,32)
IF $LENGTH(LRTXT)>32
WRITE "..."
WRITE *3
+3 WRITE *2,!,"O#:",LRCE,!,"W:"_$EXTRACT(LRLLOC,1,9),*3
+4 SET X=$GET(DOB)
DO ^%DT
+5 WRITE *2,!,HRCN,!,"DOB:"_$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_($EXTRACT(Y,1,3)+1700),*3
+6 WRITE *2,!,PNM,!,LRTOP,!,LRDAT,!,LRACC,*3
+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 IF '$DATA(LRDOC)
IF $GET(LRAA)
IF $GET(LRAD)
IF $GET(LRAN)
Begin DoDot:1
+10 SET LRDOC=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,8)
+11 IF LRDOC
SET LRDOC=$PIECE($GET(^VA(200,LRDOC,0)),U)
End DoDot:1
+12 SET LRDOC=$GET(LRDOC)
+13 WRITE *2,!,LRDOC,*3
+14 WRITE *2,*23,*15,"S30",*12,*3
+15 QUIT
