LRLABELB ;DALOI/JMC - 10 PART LABELS FOR THE INTERMEC 3000/4000 PRINTER ;8/29/94 12:36
;;5.2;LAB SERVICE;**161,218**;Sep 27, 1994
;This routine is used in conjunction with the Intermec program routine
;LRBARB to print a ten part 2.5X4.0 inch label.
;
N CR,ETX,J,LF,LRFMT,LRLPNM,LRTXT,STX,X
;
S LRTXT=$$LRTXT^LRLABLD(.LRTS,32)
I LRTXT[";" S LRDTXT=".............."
E S LRDTXT=LRTXT
;
S LRLPNM=$P(PNM,",",1),LRLPNM=LRLPNM_$S($L(LRLPNM)<18:","_$E($P(PNM,",",2),1),1:"")
;
S LRFMT=11+$G(LRBAR(+$G(LRAA))) ; Set specific symbology.
I LRFMT<13 D BAR
I LRFMT>12 D BAR1
;
D TERM^LRLABELA
;
Q
;
BAR ; Barcode label - accession number barcoded (old style).
;
D INIT^LRLABELA(12)
;
W STX,LRACC,CR,LRDAT,CR,LRTOP,CR,$E(PNM,1,27),CR,SSN,CR,ETX
W STX,"W:",$E(LRLLOC,1,9),CR,ETX
W STX,LRBARID,CR,ETX
W STX,"Order #",LRCE,CR,$E(LRTXT,1,20) W:$L(LRTXT)>20 "..." W CR,ETX
;
; accession urgency
I $G(LRURG0)=1 W STX,"STAT",CR,ETX
E W STX,LF,CR,ETX
;
W STX,LRACC,CR,LRTOP,CR,LRACC,CR,LRLPNM,CR,SSN,CR,LRDAT,CR,$S($P(LRTXT,";",1)'="":$P(LRTXT,";",1),1:LRDTXT),CR,ETX
W STX,LRACC,CR,LRTOP,CR,LRACC,CR,LRLPNM,CR,SSN,CR,LRDAT,CR,$S($P(LRTXT,";",2)'="":$P(LRTXT,";",2),1:LRDTXT),CR,ETX
W STX,LRACC,CR,LRDAT,CR,LRTOP,CR,$E(PNM,1,27),CR,SSN,CR,"W:",$E(LRLLOC,1,9),CR,ETX
W STX,"Order #",LRCE,CR,LRTXT,CR,ETX
;
; accession urgency
I $P(LRURGA,"^",2),$L($P(LRURGA,"^")) W STX,$P(LRURGA,"^"),CR,ETX
E W STX,LF,CR,ETX
;
W STX,LRACC,CR,LRTOP,CR,LRACC,CR,LRLPNM,CR,SSN,CR,LRDAT,CR,$S($P(LRTXT,";",1)'="":$P(LRTXT,";",1),1:LRDTXT),CR,ETX
W STX,LRACC,CR,LRTOP,CR,LRACC,CR,LRLPNM,CR,SSN,CR,LRDAT,CR,$S($P(LRTXT,";",2)'="":$P(LRTXT,";",2),1:LRDTXT),CR,ETX
;
Q
;
BAR1 ; Barcode label (handles multiple symbologies/ specimen UID).
;
D INIT^LRLABELA(13)
;
W STX,LRACC,CR,LRDAT,CR,LRTOP,CR,$E(PNM,1,21),CR,SSN,CR,ETX
;
; Patient location/room bed
W STX,"W:",LRLLOC,$S($L(LRRB):"/"_LRRB,1:""),CR,ETX
;
; Human-readable ID
W STX,LRBARID,CR,ETX
;
; Patient info
W STX,$S($G(LRINFW)="":LF,1:LRINFW),CR,ETX
W STX,"Order #",LRCE,CR,LRTXT,CR,ETX
;
D URGENCY^LRLABELA
;
W STX,LRACC,CR,LRDAT,CR,LRACC,CR,$E(PNM,1,14),CR,SSN,CR,LRDAT,CR,ETX
W STX,$S($P(LRTXT,";",1)'="":$E($P(LRTXT,";",1),1,10),1:$E(LRDTXT,1,10)),CR,ETX
W STX,LRACC,CR,LRDAT,CR,LRACC,CR,$E(PNM,1,14),CR,SSN,CR,LRDAT,CR,ETX
W STX,$S($P(LRTXT,";",2)'="":$P(LRTXT,";",2),1:LRDTXT),CR,ETX
W STX,$E(PNM,1,21),CR,SSN,CR,ETX
;
; Patient location/room bed
W STX,"W:",LRLLOC,$S($L(LRRB):"/"_LRRB,1:""),CR,ETX
;
; Human-readable ID
W STX,LRBARID,CR,ETX
;
; Patient info
W STX,$S($G(LRINFW)="":LF,1:LRINFW),CR,ETX
;
W STX,LRTOP,CR,LRACC,CR,LRDAT,CR,"Order #",LRCE,CR,LRTXT,CR,ETX
;
D URGENCY^LRLABELA
;
W STX,LRACC,CR,LRDAT,CR,LRACC,CR,$E(PNM,1,14),CR,SSN,CR,LRDAT,CR,ETX
W STX,$S($P(LRTXT,";",3)'="":$P(LRTXT,";",3),1:LRDTXT),CR,ETX
W STX,LRACC,CR,LRDAT,CR,LRACC,CR,$E(PNM,1,14),CR,SSN,CR,LRDAT,CR,ETX
W STX,$S($P(LRTXT,";",4)'="":$P(LRTXT,";",4),1:LRDTXT),CR,ETX
;
; Print appropriate barcode symbology
W STX
F J=13:1:15 D
. ; Skip symbology
. I J'=LRFMT W LF,CR,LF,CR Q
. ; specimen identifier to barcode on left label.
. W LRBARID,CR
. ; specimen identifier to barcode on right label.
. W LRBARID,CR
W ETX
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLABELB 3323 printed Apr 09, 2024@21:09:53 Page 2
LRLABELB ;DALOI/JMC - 10 PART LABELS FOR THE INTERMEC 3000/4000 PRINTER ;8/29/94 12:36
+1 ;;5.2;LAB SERVICE;**161,218**;Sep 27, 1994
+2 ;This routine is used in conjunction with the Intermec program routine
+3 ;LRBARB to print a ten part 2.5X4.0 inch label.
+4 ;
+5 NEW CR,ETX,J,LF,LRFMT,LRLPNM,LRTXT,STX,X
+6 ;
+7 SET LRTXT=$$LRTXT^LRLABLD(.LRTS,32)
+8 IF LRTXT[";"
SET LRDTXT=".............."
+9 IF '$TEST
SET LRDTXT=LRTXT
+10 ;
+11 SET LRLPNM=$PIECE(PNM,",",1)
SET LRLPNM=LRLPNM_$SELECT($LENGTH(LRLPNM)<18:","_$EXTRACT($PIECE(PNM,",",2),1),1:"")
+12 ;
+13 ; Set specific symbology.
SET LRFMT=11+$GET(LRBAR(+$GET(LRAA)))
+14 IF LRFMT<13
DO BAR
+15 IF LRFMT>12
DO BAR1
+16 ;
+17 DO TERM^LRLABELA
+18 ;
+19 QUIT
+20 ;
BAR ; Barcode label - accession number barcoded (old style).
+1 ;
+2 DO INIT^LRLABELA(12)
+3 ;
+4 WRITE STX,LRACC,CR,LRDAT,CR,LRTOP,CR,$EXTRACT(PNM,1,27),CR,SSN,CR,ETX
+5 WRITE STX,"W:",$EXTRACT(LRLLOC,1,9),CR,ETX
+6 WRITE STX,LRBARID,CR,ETX
+7 WRITE STX,"Order #",LRCE,CR,$EXTRACT(LRTXT,1,20)
if $LENGTH(LRTXT)>20
WRITE "..."
WRITE CR,ETX
+8 ;
+9 ; accession urgency
+10 IF $GET(LRURG0)=1
WRITE STX,"STAT",CR,ETX
+11 IF '$TEST
WRITE STX,LF,CR,ETX
+12 ;
+13 WRITE STX,LRACC,CR,LRTOP,CR,LRACC,CR,LRLPNM,CR,SSN,CR,LRDAT,CR,$SELECT($PIECE(LRTXT,";",1)'="":$PIECE(LRTXT,";",1),1:LRDTXT),CR,ETX
+14 WRITE STX,LRACC,CR,LRTOP,CR,LRACC,CR,LRLPNM,CR,SSN,CR,LRDAT,CR,$SELECT($PIECE(LRTXT,";",2)'="":$PIECE(LRTXT,";",2),1:LRDTXT),CR,ETX
+15 WRITE STX,LRACC,CR,LRDAT,CR,LRTOP,CR,$EXTRACT(PNM,1,27),CR,SSN,CR,"W:",$EXTRACT(LRLLOC,1,9),CR,ETX
+16 WRITE STX,"Order #",LRCE,CR,LRTXT,CR,ETX
+17 ;
+18 ; accession urgency
+19 IF $PIECE(LRURGA,"^",2)
IF $LENGTH($PIECE(LRURGA,"^"))
WRITE STX,$PIECE(LRURGA,"^"),CR,ETX
+20 IF '$TEST
WRITE STX,LF,CR,ETX
+21 ;
+22 WRITE STX,LRACC,CR,LRTOP,CR,LRACC,CR,LRLPNM,CR,SSN,CR,LRDAT,CR,$SELECT($PIECE(LRTXT,";",1)'="":$PIECE(LRTXT,";",1),1:LRDTXT),CR,ETX
+23 WRITE STX,LRACC,CR,LRTOP,CR,LRACC,CR,LRLPNM,CR,SSN,CR,LRDAT,CR,$SELECT($PIECE(LRTXT,";",2)'="":$PIECE(LRTXT,";",2),1:LRDTXT),CR,ETX
+24 ;
+25 QUIT
+26 ;
BAR1 ; Barcode label (handles multiple symbologies/ specimen UID).
+1 ;
+2 DO INIT^LRLABELA(13)
+3 ;
+4 WRITE STX,LRACC,CR,LRDAT,CR,LRTOP,CR,$EXTRACT(PNM,1,21),CR,SSN,CR,ETX
+5 ;
+6 ; Patient location/room bed
+7 WRITE STX,"W:",LRLLOC,$SELECT($LENGTH(LRRB):"/"_LRRB,1:""),CR,ETX
+8 ;
+9 ; Human-readable ID
+10 WRITE STX,LRBARID,CR,ETX
+11 ;
+12 ; Patient info
+13 WRITE STX,$SELECT($GET(LRINFW)="":LF,1:LRINFW),CR,ETX
+14 WRITE STX,"Order #",LRCE,CR,LRTXT,CR,ETX
+15 ;
+16 DO URGENCY^LRLABELA
+17 ;
+18 WRITE STX,LRACC,CR,LRDAT,CR,LRACC,CR,$EXTRACT(PNM,1,14),CR,SSN,CR,LRDAT,CR,ETX
+19 WRITE STX,$SELECT($PIECE(LRTXT,";",1)'="":$EXTRACT($PIECE(LRTXT,";",1),1,10),1:$EXTRACT(LRDTXT,1,10)),CR,ETX
+20 WRITE STX,LRACC,CR,LRDAT,CR,LRACC,CR,$EXTRACT(PNM,1,14),CR,SSN,CR,LRDAT,CR,ETX
+21 WRITE STX,$SELECT($PIECE(LRTXT,";",2)'="":$PIECE(LRTXT,";",2),1:LRDTXT),CR,ETX
+22 WRITE STX,$EXTRACT(PNM,1,21),CR,SSN,CR,ETX
+23 ;
+24 ; Patient location/room bed
+25 WRITE STX,"W:",LRLLOC,$SELECT($LENGTH(LRRB):"/"_LRRB,1:""),CR,ETX
+26 ;
+27 ; Human-readable ID
+28 WRITE STX,LRBARID,CR,ETX
+29 ;
+30 ; Patient info
+31 WRITE STX,$SELECT($GET(LRINFW)="":LF,1:LRINFW),CR,ETX
+32 ;
+33 WRITE STX,LRTOP,CR,LRACC,CR,LRDAT,CR,"Order #",LRCE,CR,LRTXT,CR,ETX
+34 ;
+35 DO URGENCY^LRLABELA
+36 ;
+37 WRITE STX,LRACC,CR,LRDAT,CR,LRACC,CR,$EXTRACT(PNM,1,14),CR,SSN,CR,LRDAT,CR,ETX
+38 WRITE STX,$SELECT($PIECE(LRTXT,";",3)'="":$PIECE(LRTXT,";",3),1:LRDTXT),CR,ETX
+39 WRITE STX,LRACC,CR,LRDAT,CR,LRACC,CR,$EXTRACT(PNM,1,14),CR,SSN,CR,LRDAT,CR,ETX
+40 WRITE STX,$SELECT($PIECE(LRTXT,";",4)'="":$PIECE(LRTXT,";",4),1:LRDTXT),CR,ETX
+41 ;
+42 ; Print appropriate barcode symbology
+43 WRITE STX
+44 FOR J=13:1:15
Begin DoDot:1
+45 ; Skip symbology
+46 IF J'=LRFMT
WRITE LF,CR,LF,CR
QUIT
+47 ; specimen identifier to barcode on left label.
+48 WRITE LRBARID,CR
+49 ; specimen identifier to barcode on right label.
+50 WRITE LRBARID,CR
End DoDot:1
+51 WRITE ETX
+52 ;
+53 QUIT
