LRLABELC ;SLC/RAF - INTERMEC 4100 1X3 LABEL PRINT BARCODE/PLAIN ;10/20/93 10:16
;;5.2;LAB SERVICE;**161**;Sep 27, 1994
;This routine is used in conjunction with the Intermec program routine
;LRBARC to print a 1X3 accession label.
;
EN ;
N CR,ETX,J,LF,LRFMT,LRTXT,STX,X
S LRRB=$G(LRRB)
S LRTXT=$$LRTXT^LRLABLD(.LRTS,35)
S LRFMT=7+$G(LRBAR(+$G(LRAA)),0)
I LRFMT=7 D PRT
I LRFMT=8 D BAR
I LRFMT>8 D BAR1
Q
;
PRT ; Plain label..no barcode
D INIT^LRLABELA(LRFMT)
W STX,$E(PNM,1,30)," ",$P(SSN,"-",3),CR,ETX
W STX,$E(LRINFW,1,20)," ORD:",$G(LRCE),CR,ETX
W STX,LRTXT,CR,ETX
W STX,LRACC
I $P(LRURGA,"^",2),$L(LRURGA,"^") W " <",$P(LRURGA,"^"),"> "
W " LOC:",LRLLOC,CR,ETX
W STX,LRTOP," ",LRPREF,CR,ETX
D TERM^LRLABELA
Q
;
BAR ; Barcode label (old style)
D INIT^LRLABELA(LRFMT)
W STX,$E(PNM,1,30)," ",$P(SSN,"-",3),CR,ETX
W STX,$E(LRINFW,1,20)," ORD:",$G(LRCE),CR,ETX
W STX,LRTXT,CR,ETX
W STX,LRACC
I $P(LRURGA,"^",2),$L(LRURGA,"^") W " <",$P(LRURGA,"^"),"> "
W " LOC:",LRLLOC,CR,ETX
W STX,$E(LRACC,1,2),CR,ETX
W STX,LRBARID,CR,ETX
D TERM^LRLABELA
Q
;
BAR1 ; Barcode label (multiple symbologies)
D INIT^LRLABELA(9)
W STX,PNM,CR,SSN,CR,ETX ; Patient name/SSN
W STX,"W:"_$E(LRLLOC,1,9),$S($L(LRRB):" B:"_LRRB,1:""),CR,ETX ; Location
W STX,LRBARID,CR,ETX ; Human-readable ID.
W STX,LRDAT,CR,LRACC,CR,ETX ; Date/Accession
W STX,"Order# ",LRCE,CR,LRTOP,CR,ETX ; Order #/Tube Top
W STX,LRTXT,CR,ETX ; Tests
D URGENCY^LRLABELA ; Accession urgency
W STX
F J=9:1:11 D
. I J'=LRFMT W LF,CR Q ; Skip symbology
. W LRBARID,CR ; Number to barcode.
W ETX
D TERM^LRLABELA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLABELC 1668 printed Sep 23, 2025@19:51:39 Page 2
LRLABELC ;SLC/RAF - INTERMEC 4100 1X3 LABEL PRINT BARCODE/PLAIN ;10/20/93 10:16
+1 ;;5.2;LAB SERVICE;**161**;Sep 27, 1994
+2 ;This routine is used in conjunction with the Intermec program routine
+3 ;LRBARC to print a 1X3 accession label.
+4 ;
EN ;
+1 NEW CR,ETX,J,LF,LRFMT,LRTXT,STX,X
+2 SET LRRB=$GET(LRRB)
+3 SET LRTXT=$$LRTXT^LRLABLD(.LRTS,35)
+4 SET LRFMT=7+$GET(LRBAR(+$GET(LRAA)),0)
+5 IF LRFMT=7
DO PRT
+6 IF LRFMT=8
DO BAR
+7 IF LRFMT>8
DO BAR1
+8 QUIT
+9 ;
PRT ; Plain label..no barcode
+1 DO INIT^LRLABELA(LRFMT)
+2 WRITE STX,$EXTRACT(PNM,1,30)," ",$PIECE(SSN,"-",3),CR,ETX
+3 WRITE STX,$EXTRACT(LRINFW,1,20)," ORD:",$GET(LRCE),CR,ETX
+4 WRITE STX,LRTXT,CR,ETX
+5 WRITE STX,LRACC
+6 IF $PIECE(LRURGA,"^",2)
IF $LENGTH(LRURGA,"^")
WRITE " <",$PIECE(LRURGA,"^"),"> "
+7 WRITE " LOC:",LRLLOC,CR,ETX
+8 WRITE STX,LRTOP," ",LRPREF,CR,ETX
+9 DO TERM^LRLABELA
+10 QUIT
+11 ;
BAR ; Barcode label (old style)
+1 DO INIT^LRLABELA(LRFMT)
+2 WRITE STX,$EXTRACT(PNM,1,30)," ",$PIECE(SSN,"-",3),CR,ETX
+3 WRITE STX,$EXTRACT(LRINFW,1,20)," ORD:",$GET(LRCE),CR,ETX
+4 WRITE STX,LRTXT,CR,ETX
+5 WRITE STX,LRACC
+6 IF $PIECE(LRURGA,"^",2)
IF $LENGTH(LRURGA,"^")
WRITE " <",$PIECE(LRURGA,"^"),"> "
+7 WRITE " LOC:",LRLLOC,CR,ETX
+8 WRITE STX,$EXTRACT(LRACC,1,2),CR,ETX
+9 WRITE STX,LRBARID,CR,ETX
+10 DO TERM^LRLABELA
+11 QUIT
+12 ;
BAR1 ; Barcode label (multiple symbologies)
+1 DO INIT^LRLABELA(9)
+2 ; Patient name/SSN
WRITE STX,PNM,CR,SSN,CR,ETX
+3 ; Location
WRITE STX,"W:"_$EXTRACT(LRLLOC,1,9),$SELECT($LENGTH(LRRB):" B:"_LRRB,1:""),CR,ETX
+4 ; Human-readable ID.
WRITE STX,LRBARID,CR,ETX
+5 ; Date/Accession
WRITE STX,LRDAT,CR,LRACC,CR,ETX
+6 ; Order #/Tube Top
WRITE STX,"Order# ",LRCE,CR,LRTOP,CR,ETX
+7 ; Tests
WRITE STX,LRTXT,CR,ETX
+8 ; Accession urgency
DO URGENCY^LRLABELA
+9 WRITE STX
+10 FOR J=9:1:11
Begin DoDot:1
+11 ; Skip symbology
IF J'=LRFMT
WRITE LF,CR
QUIT
+12 ; Number to barcode.
WRITE LRBARID,CR
End DoDot:1
+13 WRITE ETX
+14 DO TERM^LRLABELA
+15 QUIT
