BLRLABLC ; IHS/DIR/FJE - INTERMEC 7421 LABEL PRINT BARCODE/PLAIN 10:16 ;
;;5.2;LR;**1006,1007,1009,1018,1022**;September 20, 2007
;;5.2;LR;**1006,1007,1009**;Mar 7, 2001
;;5.2;LAB SERVICE;;Sep 27, 1994
;;V5.1;LAB;;04/11/91 11:06
;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
;LRLABELA may have to be renamed LRLABEL6
;The code S X=0 X ^%ZOSF("RM") is needed to replace the U IO:0 which
;works with MSM but not DSM
;
EN S:$D(ZTQUEUED) ZTREQ="@"
N I1,J
S X=0 X ^%ZOSF("RM")
S:'$L($G(LRRB)) LRRB=""
S BLRURG="" ;IHS/DIR TUC/AAB 03/23/98
S J=0,LRTXT="",FLAG=0 F I1=1:1 S J=$O(LRTS(J)) Q:J<1 I ($L(LRTXT)+$L(LRTS(J))'>24) S LRTXT=LRTXT_LRTS(J) S:$O(LRTS(J))>0 FLAG=1,LRTXT=LRTXT_";"
;
FLAG S:FLAG=0 LRDTXT=LRTXT S:FLAG=1 LRDTXT=".............."
S LRLPNM=$P(PNM,",",1),LRLPNM=LRLPNM_$S($L(LRLPNM)<18:","_$E($P(PNM,",",2),1),1:"")
I $D(LRBAR) D BAR Q ;IHS/MJL 3/18/99
D PRT K BLRURG
;Q:'$D(LRBAR)!('$D(LRBAR($G(LRAA))))
Q ;IHS/DIR TUC/AAB 03/23/98
;
BAR ;barcode label..accession number barcoded
; --- IHS/OIT/MKK -- Total rewrite
NEW DOBSTR ; Date of Birth String
S DOBSTR="DOB:"
I $G(DOB)'="" D
. S X=$G(DOB) D DT^DILF(,X,.Y)
. ; I Y>0 S DOBSTR=DOBSTR_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700) ;IHS/DIR/FJE 10/08/99
. I Y>0 S DOBSTR=DOBSTR_$$FMTE^XLFDT(Y,"5DZ")
;
S BLRURG="" ; URGENCY
S LRURG0=$G(LRURG0)
I LRURG0'="" S BLRURG=$E($P(^LAB(62.05,LRURG0,0),U,1),1,4) ;IHS/DIR TUC/AAB 03/23/98
;
NEW LOCSTR ; LOCATION (WARD & BED)
S LOCSTR="W:"_$E($G(LRLLOC),1,7)
I $G(LRRB)'="" S LOCSTR=LOCSTR_" B:"_LRRB
;
NEW TESTSTR ; Lab Test(s) String
S TESTSTR=$E($G(LRTXT),1,32)
I $L($G(LRTXT))>32 S TESTSTR=TESTSTR_"..."
;
; NOTE: Using the $G function to ensure UNDEFINED variables
; don't cause problems.
W *2,"R",*3
W *2,*27,"E3",*24,!,$G(TESTSTR),*3 ; Lab Test(s)
W *2,!,$G(LRTOP),*3 ; Top/Specimen
W *2,!,"Order#:",$G(LRCE),*3 ; Order Number
W *2,!,$G(LRACC),*3 ; Accession String
W *2,!,$G(LRDAT),*3 ; Date
W *2,!,$G(HRCN),*3 ; Health Record Number
W *2,!,LOCSTR,*3 ; Location String
W *2,!,$E($G(PNM),1,27),*3 ; Patient Name
W *2,!,$G(BLRURG),*3 ; Urgency
W *2,!,$E("0000",$L($G(LRAN)),4)_$G(LRAN),*3 ; Barcoded Accession Number
W *2,*23,*15,"S30",*12,*3
;
K BLRURG ;IHS/DIR TUC/AAB 03/23/98
Q
;
PRT ; plain label..no barcode
; --- IHS/OIT/MKK -- Total rewrite
NEW DOBSTR ; Date of Birth String
S DOBSTR="DOB:"
I $G(DOB)'="" D
. S X=$G(DOB) D DT^DILF(,X,.Y)
. ; I Y>0 S DOBSTR=DOBSTR_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700) ;IHS/DIR/FJE 10/08/99
. I Y>0 S DOBSTR=DOBSTR_$$FMTE^XLFDT(Y,"5DZ")
;
S BLRURG="" ; URGENCY
S LRURG0=$G(LRURG0)
I LRURG0'="" S BLRURG=$E($P(^LAB(62.05,LRURG0,0),U,1),1,4) ;IHS/DIR TUC/AAB 03/23/98
;
NEW LOCSTR ; LOCATION (WARD & BED)
S LOCSTR="W:"_$E($G(LRLLOC),1,7)
I $G(LRRB)'="" S LOCSTR=LOCSTR_" B:"_LRRB
;
NEW TESTSTR ; Lab Test(s) String
S TESTSTR=$E($G(LRTXT),1,32)
I $L($G(LRTXT))>32 S TESTSTR=TESTSTR_"..."
;
; NOTE: Using the $G function to ensure UNDEFINED variables
; don't cause problems.
W *2,"R",*3
W *2,*27,"E2",*24,!,$G(TESTSTR),*3 ; TEST
W *2,!,"Order#:",$G(LRCE),*3 ; ORDER #
W *2,!,$G(LOCSTR),*3 ; LOCATION (WARD & BED)
W *2,!,$G(HRCN),*3 ; HRCN
W *2,!,$G(DOBSTR),*3 ; DOB
W *2,!,$E($G(PNM),1,27),*3 ; PATIENT NAME
W *2,!,$G(LRTOP),*3 ; TOP/SPECIMEN
W *2,!,$G(LRDAT),*3 ; DATE
W *2,!,$G(LRACC),*3 ; ACCESSION
W *2,!,$G(BLRURG),*3 ; URGENCY
W *2,*23,*15,"S30",*12,*3
Q
BLRLABLC ; IHS/DIR/FJE - INTERMEC 7421 LABEL PRINT BARCODE/PLAIN 10:16 ;
+1 ;;5.2;LR;**1006,1007,1009,1018,1022**;September 20, 2007
+2 ;;5.2;LR;**1006,1007,1009**;Mar 7, 2001
+3 ;;5.2;LAB SERVICE;;Sep 27, 1994
+4 ;;V5.1;LAB;;04/11/91 11:06
+5 ;This routine is used in conjunction with the Intermec program routine
+6 ;LRBARA to print a two label accession label for accession areas which
+7 ;have their BAR CODE PRINT field set to YES
+8 ;LRLABELA may have to be renamed LRLABEL6
+9 ;The code S X=0 X ^%ZOSF("RM") is needed to replace the U IO:0 which
+10 ;works with MSM but not DSM
+11 ;
EN IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 NEW I1,J
+2 SET X=0
XECUTE ^%ZOSF("RM")
+3 IF '$LENGTH($GET(LRRB))
SET LRRB=""
+4 ;IHS/DIR TUC/AAB 03/23/98
SET BLRURG=""
+5 SET J=0
SET LRTXT=""
SET FLAG=0
FOR I1=1:1
SET J=$ORDER(LRTS(J))
IF J<1
QUIT
IF ($LENGTH(LRTXT)+$LENGTH(LRTS(J))'>24)
SET LRTXT=LRTXT_LRTS(J)
IF $ORDER(LRTS(J))>0
SET FLAG=1
SET LRTXT=LRTXT_";"
+6 ;
FLAG IF FLAG=0
SET LRDTXT=LRTXT
IF FLAG=1
SET LRDTXT=".............."
+1 SET LRLPNM=$PIECE(PNM,",",1)
SET LRLPNM=LRLPNM_$SELECT($LENGTH(LRLPNM)<18:","_$EXTRACT($PIECE(PNM,",",2),1),1:"")
+2 ;IHS/MJL 3/18/99
IF $DATA(LRBAR)
DO BAR
QUIT
+3 DO PRT
KILL BLRURG
+4 ;Q:'$D(LRBAR)!('$D(LRBAR($G(LRAA))))
+5 ;IHS/DIR TUC/AAB 03/23/98
QUIT
+6 ;
BAR ;barcode label..accession number barcoded
+1 ; --- IHS/OIT/MKK -- Total rewrite
+2 ; Date of Birth String
NEW DOBSTR
+3 SET DOBSTR="DOB:"
+4 IF $GET(DOB)'=""
Begin DoDot:1
+5 SET X=$GET(DOB)
DO DT^DILF(,X,.Y)
+6 ; I Y>0 S DOBSTR=DOBSTR_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700) ;IHS/DIR/FJE 10/08/99
+7 IF Y>0
SET DOBSTR=DOBSTR_$$FMTE^XLFDT(Y,"5DZ")
End DoDot:1
+8 ;
+9 ; URGENCY
SET BLRURG=""
+10 SET LRURG0=$GET(LRURG0)
+11 ;IHS/DIR TUC/AAB 03/23/98
IF LRURG0'=""
SET BLRURG=$EXTRACT($PIECE(^LAB(62.05,LRURG0,0),U,1),1,4)
+12 ;
+13 ; LOCATION (WARD & BED)
NEW LOCSTR
+14 SET LOCSTR="W:"_$EXTRACT($GET(LRLLOC),1,7)
+15 IF $GET(LRRB)'=""
SET LOCSTR=LOCSTR_" B:"_LRRB
+16 ;
+17 ; Lab Test(s) String
NEW TESTSTR
+18 SET TESTSTR=$EXTRACT($GET(LRTXT),1,32)
+19 IF $LENGTH($GET(LRTXT))>32
SET TESTSTR=TESTSTR_"..."
+20 ;
+21 ; NOTE: Using the $G function to ensure UNDEFINED variables
+22 ; don't cause problems.
+23 WRITE *2,"R",*3
+24 ; Lab Test(s)
WRITE *2,*27,"E3",*24,!,$GET(TESTSTR),*3
+25 ; Top/Specimen
WRITE *2,!,$GET(LRTOP),*3
+26 ; Order Number
WRITE *2,!,"Order#:",$GET(LRCE),*3
+27 ; Accession String
WRITE *2,!,$GET(LRACC),*3
+28 ; Date
WRITE *2,!,$GET(LRDAT),*3
+29 ; Health Record Number
WRITE *2,!,$GET(HRCN),*3
+30 ; Location String
WRITE *2,!,LOCSTR,*3
+31 ; Patient Name
WRITE *2,!,$EXTRACT($GET(PNM),1,27),*3
+32 ; Urgency
WRITE *2,!,$GET(BLRURG),*3
+33 ; Barcoded Accession Number
WRITE *2,!,$EXTRACT("0000",$LENGTH($GET(LRAN)),4)_$GET(LRAN),*3
+34 WRITE *2,*23,*15,"S30",*12,*3
+35 ;
+36 ;IHS/DIR TUC/AAB 03/23/98
KILL BLRURG
+37 QUIT
+38 ;
PRT ; plain label..no barcode
+1 ; --- IHS/OIT/MKK -- Total rewrite
+2 ; Date of Birth String
NEW DOBSTR
+3 SET DOBSTR="DOB:"
+4 IF $GET(DOB)'=""
Begin DoDot:1
+5 SET X=$GET(DOB)
DO DT^DILF(,X,.Y)
+6 ; I Y>0 S DOBSTR=DOBSTR_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700) ;IHS/DIR/FJE 10/08/99
+7 IF Y>0
SET DOBSTR=DOBSTR_$$FMTE^XLFDT(Y,"5DZ")
End DoDot:1
+8 ;
+9 ; URGENCY
SET BLRURG=""
+10 SET LRURG0=$GET(LRURG0)
+11 ;IHS/DIR TUC/AAB 03/23/98
IF LRURG0'=""
SET BLRURG=$EXTRACT($PIECE(^LAB(62.05,LRURG0,0),U,1),1,4)
+12 ;
+13 ; LOCATION (WARD & BED)
NEW LOCSTR
+14 SET LOCSTR="W:"_$EXTRACT($GET(LRLLOC),1,7)
+15 IF $GET(LRRB)'=""
SET LOCSTR=LOCSTR_" B:"_LRRB
+16 ;
+17 ; Lab Test(s) String
NEW TESTSTR
+18 SET TESTSTR=$EXTRACT($GET(LRTXT),1,32)
+19 IF $LENGTH($GET(LRTXT))>32
SET TESTSTR=TESTSTR_"..."
+20 ;
+21 ; NOTE: Using the $G function to ensure UNDEFINED variables
+22 ; don't cause problems.
+23 WRITE *2,"R",*3
+24 ; TEST
WRITE *2,*27,"E2",*24,!,$GET(TESTSTR),*3
+25 ; ORDER #
WRITE *2,!,"Order#:",$GET(LRCE),*3
+26 ; LOCATION (WARD & BED)
WRITE *2,!,$GET(LOCSTR),*3
+27 ; HRCN
WRITE *2,!,$GET(HRCN),*3
+28 ; DOB
WRITE *2,!,$GET(DOBSTR),*3
+29 ; PATIENT NAME
WRITE *2,!,$EXTRACT($GET(PNM),1,27),*3
+30 ; TOP/SPECIMEN
WRITE *2,!,$GET(LRTOP),*3
+31 ; DATE
WRITE *2,!,$GET(LRDAT),*3
+32 ; ACCESSION
WRITE *2,!,$GET(LRACC),*3
+33 ; URGENCY
WRITE *2,!,$GET(BLRURG),*3
+34 WRITE *2,*23,*15,"S30",*12,*3
+35 QUIT
