Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRLABELB

LRLABELB.m

Go to the documentation of this file. 
  1. 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
  1.  ;This routine is used in conjunction with the Intermec program routine
  1.  ;LRBARB to print a ten part 2.5X4.0 inch label.
  1.  ;
  1.  N CR,ETX,J,LF,LRFMT,LRLPNM,LRTXT,STX,X
  1.  ;
  1.  S LRTXT=$$LRTXT^LRLABLD(.LRTS,32)
  1.  I LRTXT[";" S LRDTXT=".............."
  1.  E  S LRDTXT=LRTXT
  1.  ;
  1.  S LRLPNM=$P(PNM,",",1),LRLPNM=LRLPNM_$S($L(LRLPNM)<18:","_$E($P(PNM,",",2),1),1:"")
  1.  ;
  1.  S LRFMT=11+$G(LRBAR(+$G(LRAA))) ; Set specific symbology.
  1.  I LRFMT<13 D BAR
  1.  I LRFMT>12 D BAR1
  1.  ;
  1.  D TERM^LRLABELA
  1.  ;
  1.  Q
  1.  ;
  1. BAR ; Barcode label - accession number barcoded (old style).
  1.  ;
  1.  D INIT^LRLABELA(12)
  1.  ;
  1.  W STX,LRACC,CR,LRDAT,CR,LRTOP,CR,$E(PNM,1,27),CR,SSN,CR,ETX
  1.  W STX,"W:",$E(LRLLOC,1,9),CR,ETX
  1.  W STX,LRBARID,CR,ETX
  1.  W STX,"Order #",LRCE,CR,$E(LRTXT,1,20) W:$L(LRTXT)>20 "..." W CR,ETX
  1.  ;
  1.  ; accession urgency
  1.  I $G(LRURG0)=1 W STX,"STAT",CR,ETX
  1.  E  W STX,LF,CR,ETX
  1.  ;
  1.  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
  1.  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
  1.  W STX,LRACC,CR,LRDAT,CR,LRTOP,CR,$E(PNM,1,27),CR,SSN,CR,"W:",$E(LRLLOC,1,9),CR,ETX
  1.  W STX,"Order #",LRCE,CR,LRTXT,CR,ETX
  1.  ;
  1.  ; accession urgency
  1.  I $P(LRURGA,"^",2),$L($P(LRURGA,"^")) W STX,$P(LRURGA,"^"),CR,ETX
  1.  E  W STX,LF,CR,ETX
  1.  ;
  1.  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
  1.  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
  1.  ;
  1.  Q
  1.  ;
  1. BAR1 ; Barcode label (handles multiple symbologies/ specimen UID).
  1.  ;
  1.  D INIT^LRLABELA(13)
  1.  ;
  1.  W STX,LRACC,CR,LRDAT,CR,LRTOP,CR,$E(PNM,1,21),CR,SSN,CR,ETX
  1.  ;
  1.  ; Patient location/room bed
  1.  W STX,"W:",LRLLOC,$S($L(LRRB):"/"_LRRB,1:""),CR,ETX
  1.  ;
  1.  ; Human-readable ID
  1.  W STX,LRBARID,CR,ETX
  1.  ;
  1.  ; Patient info
  1.  W STX,$S($G(LRINFW)="":LF,1:LRINFW),CR,ETX
  1.  W STX,"Order #",LRCE,CR,LRTXT,CR,ETX
  1.  ;
  1.  D URGENCY^LRLABELA
  1.  ;
  1.  W STX,LRACC,CR,LRDAT,CR,LRACC,CR,$E(PNM,1,14),CR,SSN,CR,LRDAT,CR,ETX
  1.  W STX,$S($P(LRTXT,";",1)'="":$E($P(LRTXT,";",1),1,10),1:$E(LRDTXT,1,10)),CR,ETX
  1.  W STX,LRACC,CR,LRDAT,CR,LRACC,CR,$E(PNM,1,14),CR,SSN,CR,LRDAT,CR,ETX
  1.  W STX,$S($P(LRTXT,";",2)'="":$P(LRTXT,";",2),1:LRDTXT),CR,ETX
  1.  W STX,$E(PNM,1,21),CR,SSN,CR,ETX
  1.  ;
  1.  ; Patient location/room bed
  1.  W STX,"W:",LRLLOC,$S($L(LRRB):"/"_LRRB,1:""),CR,ETX
  1.  ;
  1.  ; Human-readable ID
  1.  W STX,LRBARID,CR,ETX
  1.  ;
  1.  ; Patient info
  1.  W STX,$S($G(LRINFW)="":LF,1:LRINFW),CR,ETX
  1.  ;
  1.  W STX,LRTOP,CR,LRACC,CR,LRDAT,CR,"Order #",LRCE,CR,LRTXT,CR,ETX
  1.  ;
  1.  D URGENCY^LRLABELA
  1.  ;
  1.  W STX,LRACC,CR,LRDAT,CR,LRACC,CR,$E(PNM,1,14),CR,SSN,CR,LRDAT,CR,ETX
  1.  W STX,$S($P(LRTXT,";",3)'="":$P(LRTXT,";",3),1:LRDTXT),CR,ETX
  1.  W STX,LRACC,CR,LRDAT,CR,LRACC,CR,$E(PNM,1,14),CR,SSN,CR,LRDAT,CR,ETX
  1.  W STX,$S($P(LRTXT,";",4)'="":$P(LRTXT,";",4),1:LRDTXT),CR,ETX
  1.  ;
  1.  ; Print appropriate barcode symbology
  1.  W STX
  1.  F J=13:1:15 D
  1.  . ; Skip symbology
  1.  . I J'=LRFMT W LF,CR,LF,CR Q
  1.  . ; specimen identifier to barcode on left label.
  1.  . W LRBARID,CR
  1.  . ; specimen identifier to barcode on right label.
  1.  . W LRBARID,CR
  1.  W ETX
  1.  ;
  1.  Q