LRLABELA ;DALOI/JMC - INTERMEC 4100 1X2 LABEL PRINT BARCODE/PLAIN ;10/20/93 10:16
;;5.2;LAB SERVICE;**161,218**;Sep 27, 1994
;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
;
EN ;
N CR,ETX,J,LRFMT,LRTXT,STX,X
S LRRB=$G(LRRB)
;
; Set specific symbology.
S LRFMT=3+$G(LRBAR(+$G(LRAA)))
;
S LRTXT=$$LRTXT^LRLABLD(.LRTS,$S(LRFMT=4:25,1:32))
;
I LRFMT=3 D PRT
I LRFMT=4 D BAR
I LRFMT>4 D BAR1
;
D TERM
Q
;
PRT ;plain label..no barcode
;
D INIT(LRFMT)
;
W STX,LRTXT,CR,ETX
W STX,"Order #",LRCE,CR,"W:"_$E(LRLLOC,1,9)_" B:"_LRRB,CR,ETX
W STX,SSN,CR,PNM,CR,LRTOP,CR,LRDAT,CR,LRACC,CR,ETX
;
; Determine if accession urgency printed normally or in reverse letters
I $P(LRURGA,"^",2),$L($P(LRURGA,"^")) W STX,$P(LRURGA,"^"),CR,ETX
E W STX,$C(10),CR,ETX
;
Q
;
BAR ;barcode label..accession number barcoded (old style)
;
D INIT(LRFMT)
;
W STX,LRTXT,CR,ETX
W STX,LRTOP,CR,"Order #",LRCE,CR,LRACC,CR,LRDAT,CR,SSN,CR,ETX
W STX,$S($L(LRRB):"B:"_LRRB,1:"W:"_$E(LRLLOC,1,9)),CR,ETX
W STX,$E(PNM,1,27),CR,ETX
;
; Determine if accession urgency printed normally or in reverse letters
I $G(LRURG0)=1 W STX,"STAT",CR,ETX
E W STX,LF,CR,ETX
;
W STX,LRBARID,CR,ETX
;
Q
;
;
BAR1 ; Barcode label (handles multiple barcode symbologies).
;
D INIT(5)
;
W STX,PNM,CR,SSN,CR,"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
;
; Order date/accession
W STX,LRDAT,CR,LRACC,CR,ETX
;
; Order #/specimen top
W STX,"Order #",LRCE,CR,LRTOP,CR,ETX
;
; Test list
W STX,LRTXT,CR,ETX
;
D URGENCY
;
; Bar code specimen identifier
W STX
F J=5:1:7 D
. I J'=LRFMT W LF,CR Q ; Skip symbology.
. W LRBARID,CR
W ETX
;
Q
;
INIT(LRFMT) ; Initialize label
; Call with LRFMT = format to access on printer
; Called above, LRLABELB, LRLABELC, LRBLJLA1
;
S STX=$C(2),ETX=$C(3),LF=$C(10),CR=$C(13)
S X=0 X ^%ZOSF("RM")
;
; Put printer in advanced mode.
W STX,$C(27),"C",ETX
W STX,"R",ETX
W STX,$C(27),"E",LRFMT,$C(24),ETX
;
Q
;
TERM ; Terminate and print label
; Called above, LRLABELB, LRLABELC, LRBLJLA1
;
W STX,$C(23,15),"S30",$C(12),ETX
;
Q
;
URGENCY ; Print urgency based on settings.
; Called above, LRLABELB, LRLABELC
;
I $P(LRURGA,"^",2),$L($P(LRURGA,"^")) D Q
. ; Reverse field
. I $P(LRURGA,"^",2)=2 W STX,LF,CR,$P(LRURGA,"^"),CR,ETX Q
. ; Normal field
. W STX,$P(LRURGA,"^"),CR,LF,CR,ETX
;
; No urgency
W STX,LF,CR,LF,CR,ETX
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLABELA 2755 printed Dec 13, 2024@02:15:57 Page 2
LRLABELA ;DALOI/JMC - INTERMEC 4100 1X2 LABEL PRINT BARCODE/PLAIN ;10/20/93 10:16
+1 ;;5.2;LAB SERVICE;**161,218**;Sep 27, 1994
+2 ;This routine is used in conjunction with the Intermec program routine
+3 ;LRBARA to print a two label accession label for accession areas which
+4 ;have their BAR CODE PRINT field set to YES
+5 ;
EN ;
+1 NEW CR,ETX,J,LRFMT,LRTXT,STX,X
+2 SET LRRB=$GET(LRRB)
+3 ;
+4 ; Set specific symbology.
+5 SET LRFMT=3+$GET(LRBAR(+$GET(LRAA)))
+6 ;
+7 SET LRTXT=$$LRTXT^LRLABLD(.LRTS,$SELECT(LRFMT=4:25,1:32))
+8 ;
+9 IF LRFMT=3
DO PRT
+10 IF LRFMT=4
DO BAR
+11 IF LRFMT>4
DO BAR1
+12 ;
+13 DO TERM
+14 QUIT
+15 ;
PRT ;plain label..no barcode
+1 ;
+2 DO INIT(LRFMT)
+3 ;
+4 WRITE STX,LRTXT,CR,ETX
+5 WRITE STX,"Order #",LRCE,CR,"W:"_$EXTRACT(LRLLOC,1,9)_" B:"_LRRB,CR,ETX
+6 WRITE STX,SSN,CR,PNM,CR,LRTOP,CR,LRDAT,CR,LRACC,CR,ETX
+7 ;
+8 ; Determine if accession urgency printed normally or in reverse letters
+9 IF $PIECE(LRURGA,"^",2)
IF $LENGTH($PIECE(LRURGA,"^"))
WRITE STX,$PIECE(LRURGA,"^"),CR,ETX
+10 IF '$TEST
WRITE STX,$CHAR(10),CR,ETX
+11 ;
+12 QUIT
+13 ;
BAR ;barcode label..accession number barcoded (old style)
+1 ;
+2 DO INIT(LRFMT)
+3 ;
+4 WRITE STX,LRTXT,CR,ETX
+5 WRITE STX,LRTOP,CR,"Order #",LRCE,CR,LRACC,CR,LRDAT,CR,SSN,CR,ETX
+6 WRITE STX,$SELECT($LENGTH(LRRB):"B:"_LRRB,1:"W:"_$EXTRACT(LRLLOC,1,9)),CR,ETX
+7 WRITE STX,$EXTRACT(PNM,1,27),CR,ETX
+8 ;
+9 ; Determine if accession urgency printed normally or in reverse letters
+10 IF $GET(LRURG0)=1
WRITE STX,"STAT",CR,ETX
+11 IF '$TEST
WRITE STX,LF,CR,ETX
+12 ;
+13 WRITE STX,LRBARID,CR,ETX
+14 ;
+15 QUIT
+16 ;
+17 ;
BAR1 ; Barcode label (handles multiple barcode symbologies).
+1 ;
+2 DO INIT(5)
+3 ;
+4 WRITE STX,PNM,CR,SSN,CR,"W:"_LRLLOC,$SELECT($LENGTH(LRRB):"/"_LRRB,1:""),CR,ETX
+5 ;
+6 ; Human-readable ID
+7 WRITE STX,LRBARID,CR,ETX
+8 ;
+9 ; Patient info
+10 WRITE STX,$SELECT($GET(LRINFW)="":LF,1:LRINFW),CR,ETX
+11 ;
+12 ; Order date/accession
+13 WRITE STX,LRDAT,CR,LRACC,CR,ETX
+14 ;
+15 ; Order #/specimen top
+16 WRITE STX,"Order #",LRCE,CR,LRTOP,CR,ETX
+17 ;
+18 ; Test list
+19 WRITE STX,LRTXT,CR,ETX
+20 ;
+21 DO URGENCY
+22 ;
+23 ; Bar code specimen identifier
+24 WRITE STX
+25 FOR J=5:1:7
Begin DoDot:1
+26 ; Skip symbology.
IF J'=LRFMT
WRITE LF,CR
QUIT
+27 WRITE LRBARID,CR
End DoDot:1
+28 WRITE ETX
+29 ;
+30 QUIT
+31 ;
INIT(LRFMT) ; Initialize label
+1 ; Call with LRFMT = format to access on printer
+2 ; Called above, LRLABELB, LRLABELC, LRBLJLA1
+3 ;
+4 SET STX=$CHAR(2)
SET ETX=$CHAR(3)
SET LF=$CHAR(10)
SET CR=$CHAR(13)
+5 SET X=0
XECUTE ^%ZOSF("RM")
+6 ;
+7 ; Put printer in advanced mode.
+8 WRITE STX,$CHAR(27),"C",ETX
+9 WRITE STX,"R",ETX
+10 WRITE STX,$CHAR(27),"E",LRFMT,$CHAR(24),ETX
+11 ;
+12 QUIT
+13 ;
TERM ; Terminate and print label
+1 ; Called above, LRLABELB, LRLABELC, LRBLJLA1
+2 ;
+3 WRITE STX,$CHAR(23,15),"S30",$CHAR(12),ETX
+4 ;
+5 QUIT
+6 ;
URGENCY ; Print urgency based on settings.
+1 ; Called above, LRLABELB, LRLABELC
+2 ;
+3 IF $PIECE(LRURGA,"^",2)
IF $LENGTH($PIECE(LRURGA,"^"))
Begin DoDot:1
+4 ; Reverse field
+5 IF $PIECE(LRURGA,"^",2)=2
WRITE STX,LF,CR,$PIECE(LRURGA,"^"),CR,ETX
QUIT
+6 ; Normal field
+7 WRITE STX,$PIECE(LRURGA,"^"),CR,LF,CR,ETX
End DoDot:1
QUIT
+8 ;
+9 ; No urgency
+10 WRITE STX,LF,CR,LF,CR,ETX
+11 ;
+12 QUIT
