- 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 Feb 18, 2025@23:41:52 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
