source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRLABELB.m@ 1801

Last change on this file since 1801 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 3.1 KB
Line 
1LRLABELB ;DALOI/JMC - 10 PART LABELS FOR THE INTERMEC 3000/4000 PRINTER ;8/29/94 12:36
2 ;;5.2;LAB SERVICE;**161,218**;Sep 27, 1994
3 ;This routine is used in conjunction with the Intermec program routine
4 ;LRBARB to print a ten part 2.5X4.0 inch label.
5 ;
6 N CR,ETX,J,LF,LRFMT,LRLPNM,LRTXT,STX,X
7 ;
8 S LRTXT=$$LRTXT^LRLABLD(.LRTS,32)
9 I LRTXT[";" S LRDTXT=".............."
10 E S LRDTXT=LRTXT
11 ;
12 S LRLPNM=$P(PNM,",",1),LRLPNM=LRLPNM_$S($L(LRLPNM)<18:","_$E($P(PNM,",",2),1),1:"")
13 ;
14 S LRFMT=11+$G(LRBAR(+$G(LRAA))) ; Set specific symbology.
15 I LRFMT<13 D BAR
16 I LRFMT>12 D BAR1
17 ;
18 D TERM^LRLABELA
19 ;
20 Q
21 ;
22BAR ; Barcode label - accession number barcoded (old style).
23 ;
24 D INIT^LRLABELA(12)
25 ;
26 W STX,LRACC,CR,LRDAT,CR,LRTOP,CR,$E(PNM,1,27),CR,SSN,CR,ETX
27 W STX,"W:",$E(LRLLOC,1,9),CR,ETX
28 W STX,LRBARID,CR,ETX
29 W STX,"Order #",LRCE,CR,$E(LRTXT,1,20) W:$L(LRTXT)>20 "..." W CR,ETX
30 ;
31 ; accession urgency
32 I $G(LRURG0)=1 W STX,"STAT",CR,ETX
33 E W STX,LF,CR,ETX
34 ;
35 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
36 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
37 W STX,LRACC,CR,LRDAT,CR,LRTOP,CR,$E(PNM,1,27),CR,SSN,CR,"W:",$E(LRLLOC,1,9),CR,ETX
38 W STX,"Order #",LRCE,CR,LRTXT,CR,ETX
39 ;
40 ; accession urgency
41 I $P(LRURGA,"^",2),$L($P(LRURGA,"^")) W STX,$P(LRURGA,"^"),CR,ETX
42 E W STX,LF,CR,ETX
43 ;
44 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
45 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
46 ;
47 Q
48 ;
49BAR1 ; Barcode label (handles multiple symbologies/ specimen UID).
50 ;
51 D INIT^LRLABELA(13)
52 ;
53 W STX,LRACC,CR,LRDAT,CR,LRTOP,CR,$E(PNM,1,21),CR,SSN,CR,ETX
54 ;
55 ; Patient location/room bed
56 W STX,"W:",LRLLOC,$S($L(LRRB):"/"_LRRB,1:""),CR,ETX
57 ;
58 ; Human-readable ID
59 W STX,LRBARID,CR,ETX
60 ;
61 ; Patient info
62 W STX,$S($G(LRINFW)="":LF,1:LRINFW),CR,ETX
63 W STX,"Order #",LRCE,CR,LRTXT,CR,ETX
64 ;
65 D URGENCY^LRLABELA
66 ;
67 W STX,LRACC,CR,LRDAT,CR,LRACC,CR,$E(PNM,1,14),CR,SSN,CR,LRDAT,CR,ETX
68 W STX,$S($P(LRTXT,";",1)'="":$E($P(LRTXT,";",1),1,10),1:$E(LRDTXT,1,10)),CR,ETX
69 W STX,LRACC,CR,LRDAT,CR,LRACC,CR,$E(PNM,1,14),CR,SSN,CR,LRDAT,CR,ETX
70 W STX,$S($P(LRTXT,";",2)'="":$P(LRTXT,";",2),1:LRDTXT),CR,ETX
71 W STX,$E(PNM,1,21),CR,SSN,CR,ETX
72 ;
73 ; Patient location/room bed
74 W STX,"W:",LRLLOC,$S($L(LRRB):"/"_LRRB,1:""),CR,ETX
75 ;
76 ; Human-readable ID
77 W STX,LRBARID,CR,ETX
78 ;
79 ; Patient info
80 W STX,$S($G(LRINFW)="":LF,1:LRINFW),CR,ETX
81 ;
82 W STX,LRTOP,CR,LRACC,CR,LRDAT,CR,"Order #",LRCE,CR,LRTXT,CR,ETX
83 ;
84 D URGENCY^LRLABELA
85 ;
86 W STX,LRACC,CR,LRDAT,CR,LRACC,CR,$E(PNM,1,14),CR,SSN,CR,LRDAT,CR,ETX
87 W STX,$S($P(LRTXT,";",3)'="":$P(LRTXT,";",3),1:LRDTXT),CR,ETX
88 W STX,LRACC,CR,LRDAT,CR,LRACC,CR,$E(PNM,1,14),CR,SSN,CR,LRDAT,CR,ETX
89 W STX,$S($P(LRTXT,";",4)'="":$P(LRTXT,";",4),1:LRDTXT),CR,ETX
90 ;
91 ; Print appropriate barcode symbology
92 W STX
93 F J=13:1:15 D
94 . ; Skip symbology
95 . I J'=LRFMT W LF,CR,LF,CR Q
96 . ; specimen identifier to barcode on left label.
97 . W LRBARID,CR
98 . ; specimen identifier to barcode on right label.
99 . W LRBARID,CR
100 W ETX
101 ;
102 Q
Note: See TracBrowser for help on using the repository browser.