BLRLABLA ; IHS/DIR/MKK - INTERMEC 4100 2 LABEL PRINT BARCODE/PLAIN 10:16 ;
;;5.2;LR;**1001,1006,1007,1009,1018,1019**;MAR 25, 2005
;;5.2;LR;**1001,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
;
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 IHS/ITSC/MKK
; Make certain DOB has something in it
NEW DOBSTR ; Date Of Birth STRing
S DOBSTR=" DoB:"
I $G(DOB)'="" D ; If DoB exists, get
. S X=DOB S %DT="" D ^%DT
. S DOBSTR=" DoB:"_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700)
;
; Make certain date string has a 2-digit year
NEW LRDSHRT ; LaboRatory SHort date
S LRDSHRT=LRDAT
I $L($P($P(LRDAT,"/",3)," ",1))>2 D
. S LRDSHRT=$P(LRDAT,"/",1,2)_"/"_$E($P(LRDAT,"/",3),3,$L(LRDAT))
;
; Get Provider Name from NEW PERSON file, if it exists
NEW PROVN ; Provider Name
S PROVN="" ; Initialize
NEW PTR ; Provider Pointer
I $G(LRAA)'=""&($G(LRAD)'="")&($G(LRAN)'="") D
. S PTR=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",8)
. I $G(PTR)'="" S PROVN=$P($G(^VA(200,PTR,0)),"^",1)
;
; Location variable
NEW LOCVAR ; Location String
S LOCVAR="W:"_$E($G(LRLLOC),1,7)
I $G(LRRB)'="" S LOCVAR=LOCVAR_" B:"_LRRB ; If Bed variable exists, get it
;
NEW TESTSVAR ; TEST(S) VARiable
S TESTSVAR=$E($G(LRTXT),1,32)
I $L($G(LRTXT))>31 S TESTSVAR=TESTSVAR_"..."
;
; Urgency variable
S BLRURG="" ; Intialize
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
;
W *2,"R",*3
W *2,*27,"E3",*24,!,TESTSVAR,*3 ; (01) Test(s)
W *2,!,LRTOP,*3 ; (02) Collection sample - tube top/specimen
W *2,!,"Order#:",LRCE,*3 ; (03) Order Number
W *2,!,LRACC,*3 ; (04) Accession String
W *2,!,LRDSHRT,*3 ; (05) Date
W *2,!,HRCN,*3 ; (06) Health Record Number
W *2,!,LOCVAR,*3 ; (07) Location
W *2,!,$E(PNM,1,27),*3 ; (08) Patient Name
W *2,!,BLRURG,*3 ; (09) Urgency
W *2,!,$E("0000",$L(LRAN),4)_LRAN,*3 ; (10) Accession Number -- Bar Coded
W *2,*23,*15,"S30",*12,*3
;
K BLRURG ;IHS/DIR TUC/AAB 03/23/98
;----- END IHS MODIFICATIONS LR*5.2*1018 IHS/ITSC/MKK
Q
PRT ;plain label..no barcode
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 IHS/ITSC/MKK
; Make certain DOB has something in it
NEW DOBSTR ; Date Of Birth STRing
S DOBSTR="XX/XX/XX" ; Initialize to nonsense
I $G(DOB)'="" D ; If something there, set to real date
. S X=$G(DOB)
. S %DT=""
. D ^%DT
. S DOBSTR=" DoB:"_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700)
;
; Make certain date string has a 2-digit year
NEW LRDSHRT ; LaboRatory SHort date
S LRDSHRT=LRDAT ; Initialize
I $L($P($P(LRDAT,"/",3)," ",1))>2 D
. S LRDSHRT=$P(LRDAT,"/",1,2)_"/"_$E($P(LRDAT,"/",3),3,$L(LRDAT))
;
; Make certain provider name has data
NEW PROVN ; Provider Name
S PROVN="" ; Initialize
NEW PTR ; Provider Pointer
I $G(LRAA)'=""&($G(LRAD)'="")&($G(LRAN)'="") D
. S PTR=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",8)
. I $G(PTR)'="" S PROVN=$P($G(^VA(200,PTR,0)),"^",1)
;
; Location variable
NEW LOCVAR ; LOCation VARiable
S LOCVAR="W:"_$E(LRLLOC,1,7)
I $L(LRRB)>0 S LOCVAR=LOCVAR_" B:"_LRRB ; If Bed variable exists, get it
;
NEW TESTSVAR ; TEST(S) VARiable
S TESTSVAR=$E(LRTXT,1,32)
I $L(LRTXT)>31 S TESTSVAR=TESTSVAR_"..."
;
; Urgency variable
S BLRURG="" ; Initialize
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
;
;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 IHS/ITSC/MKK
; Using $G in case any of the variables are null -- an issue with testing labels
W *2,"R",*3
W *2,*27,"E2",*24,!,$G(TESTSVAR),*3 ; Test(s)
W *2,!,$G(LRTOP),*3 ; Collection sample - tube top/specimen
W *2,!,"Order#:",$G(LRCE),*3 ; Order Number
W *2,!,$G(LRACC),*3 ; Accession string
W *2,!,$G(LRDSHRT),*3 ; Date
W *2,!,$G(HRCN),*3 ; Health Record Number
W *2,!,$G(LOCVAR),*3 ; Location
W *2,!,$G(PNM),*3 ; Patient Name
W *2,!,$G(BLRURG),*3 ; Urgency
W *2,!,"Sex:",$G(SEX),*3 ; Sex
W *2,!,"Prov:"_$E($G(PROVN),1,18),*3 ; Provider
W *2,!,$G(DOBSTR),*3 ; Date of Birth
;----- END IHS MODIFICATIONS LR*5.2*1019 IHS/ITSC/MKK
;
W *2,*23,*15,"S30",*12,*3
;----- END IHS MODIFICATIONS LR*5.2*1018 IHS/ITSC/MKK
Q
BLRLABLA ; IHS/DIR/MKK - INTERMEC 4100 2 LABEL PRINT BARCODE/PLAIN 10:16 ;
+1 ;;5.2;LR;**1001,1006,1007,1009,1018,1019**;MAR 25, 2005
+2 ;;5.2;LR;**1001,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_";"
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 ;
+2 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 IHS/ITSC/MKK
+3 ; Make certain DOB has something in it
+4 ; Date Of Birth STRing
NEW DOBSTR
+5 SET DOBSTR=" DoB:"
+6 ; If DoB exists, get
IF $GET(DOB)'=""
Begin DoDot:1
+7 SET X=DOB
SET %DT=""
DO ^%DT
+8 SET DOBSTR=" DoB:"_$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_($EXTRACT(Y,1,3)+1700)
End DoDot:1
+9 ;
+10 ; Make certain date string has a 2-digit year
+11 ; LaboRatory SHort date
NEW LRDSHRT
+12 SET LRDSHRT=LRDAT
+13 IF $LENGTH($PIECE($PIECE(LRDAT,"/",3)," ",1))>2
Begin DoDot:1
+14 SET LRDSHRT=$PIECE(LRDAT,"/",1,2)_"/"_$EXTRACT($PIECE(LRDAT,"/",3),3,$LENGTH(LRDAT))
End DoDot:1
+15 ;
+16 ; Get Provider Name from NEW PERSON file, if it exists
+17 ; Provider Name
NEW PROVN
+18 ; Initialize
SET PROVN=""
+19 ; Provider Pointer
NEW PTR
+20 IF $GET(LRAA)'=""&($GET(LRAD)'="")&($GET(LRAN)'="")
Begin DoDot:1
+21 SET PTR=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",8)
+22 IF $GET(PTR)'=""
SET PROVN=$PIECE($GET(^VA(200,PTR,0)),"^",1)
End DoDot:1
+23 ;
+24 ; Location variable
+25 ; Location String
NEW LOCVAR
+26 SET LOCVAR="W:"_$EXTRACT($GET(LRLLOC),1,7)
+27 ; If Bed variable exists, get it
IF $GET(LRRB)'=""
SET LOCVAR=LOCVAR_" B:"_LRRB
+28 ;
+29 ; TEST(S) VARiable
NEW TESTSVAR
+30 SET TESTSVAR=$EXTRACT($GET(LRTXT),1,32)
+31 IF $LENGTH($GET(LRTXT))>31
SET TESTSVAR=TESTSVAR_"..."
+32 ;
+33 ; Urgency variable
+34 ; Intialize
SET BLRURG=""
+35 ;IHS/DIR TUC/AAB 03/23/98
SET LRURG0=$GET(LRURG0)
IF LRURG0'=""
SET BLRURG=$EXTRACT($PIECE(^LAB(62.05,LRURG0,0),U,1),1,4)
+36 ;
+37 WRITE *2,"R",*3
+38 ; (01) Test(s)
WRITE *2,*27,"E3",*24,!,TESTSVAR,*3
+39 ; (02) Collection sample - tube top/specimen
WRITE *2,!,LRTOP,*3
+40 ; (03) Order Number
WRITE *2,!,"Order#:",LRCE,*3
+41 ; (04) Accession String
WRITE *2,!,LRACC,*3
+42 ; (05) Date
WRITE *2,!,LRDSHRT,*3
+43 ; (06) Health Record Number
WRITE *2,!,HRCN,*3
+44 ; (07) Location
WRITE *2,!,LOCVAR,*3
+45 ; (08) Patient Name
WRITE *2,!,$EXTRACT(PNM,1,27),*3
+46 ; (09) Urgency
WRITE *2,!,BLRURG,*3
+47 ; (10) Accession Number -- Bar Coded
WRITE *2,!,$EXTRACT("0000",$LENGTH(LRAN),4)_LRAN,*3
+48 WRITE *2,*23,*15,"S30",*12,*3
+49 ;
+50 ;IHS/DIR TUC/AAB 03/23/98
KILL BLRURG
+51 ;----- END IHS MODIFICATIONS LR*5.2*1018 IHS/ITSC/MKK
+52 QUIT
PRT ;plain label..no barcode
+1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018 IHS/ITSC/MKK
+2 ; Make certain DOB has something in it
+3 ; Date Of Birth STRing
NEW DOBSTR
+4 ; Initialize to nonsense
SET DOBSTR="XX/XX/XX"
+5 ; If something there, set to real date
IF $GET(DOB)'=""
Begin DoDot:1
+6 SET X=$GET(DOB)
+7 SET %DT=""
+8 DO ^%DT
+9 SET DOBSTR=" DoB:"_$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_($EXTRACT(Y,1,3)+1700)
End DoDot:1
+10 ;
+11 ; Make certain date string has a 2-digit year
+12 ; LaboRatory SHort date
NEW LRDSHRT
+13 ; Initialize
SET LRDSHRT=LRDAT
+14 IF $LENGTH($PIECE($PIECE(LRDAT,"/",3)," ",1))>2
Begin DoDot:1
+15 SET LRDSHRT=$PIECE(LRDAT,"/",1,2)_"/"_$EXTRACT($PIECE(LRDAT,"/",3),3,$LENGTH(LRDAT))
End DoDot:1
+16 ;
+17 ; Make certain provider name has data
+18 ; Provider Name
NEW PROVN
+19 ; Initialize
SET PROVN=""
+20 ; Provider Pointer
NEW PTR
+21 IF $GET(LRAA)'=""&($GET(LRAD)'="")&($GET(LRAN)'="")
Begin DoDot:1
+22 SET PTR=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",8)
+23 IF $GET(PTR)'=""
SET PROVN=$PIECE($GET(^VA(200,PTR,0)),"^",1)
End DoDot:1
+24 ;
+25 ; Location variable
+26 ; LOCation VARiable
NEW LOCVAR
+27 SET LOCVAR="W:"_$EXTRACT(LRLLOC,1,7)
+28 ; If Bed variable exists, get it
IF $LENGTH(LRRB)>0
SET LOCVAR=LOCVAR_" B:"_LRRB
+29 ;
+30 ; TEST(S) VARiable
NEW TESTSVAR
+31 SET TESTSVAR=$EXTRACT(LRTXT,1,32)
+32 IF $LENGTH(LRTXT)>31
SET TESTSVAR=TESTSVAR_"..."
+33 ;
+34 ; Urgency variable
+35 ; Initialize
SET BLRURG=""
+36 ;IHS/DIR TUC/AAB 03/23/98
SET LRURG0=$GET(LRURG0)
IF LRURG0'=""
SET BLRURG=$EXTRACT($PIECE(^LAB(62.05,LRURG0,0),U,1),1,4)
+37 ;
+38 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 IHS/ITSC/MKK
+39 ; Using $G in case any of the variables are null -- an issue with testing labels
+40 WRITE *2,"R",*3
+41 ; Test(s)
WRITE *2,*27,"E2",*24,!,$GET(TESTSVAR),*3
+42 ; Collection sample - tube top/specimen
WRITE *2,!,$GET(LRTOP),*3
+43 ; Order Number
WRITE *2,!,"Order#:",$GET(LRCE),*3
+44 ; Accession string
WRITE *2,!,$GET(LRACC),*3
+45 ; Date
WRITE *2,!,$GET(LRDSHRT),*3
+46 ; Health Record Number
WRITE *2,!,$GET(HRCN),*3
+47 ; Location
WRITE *2,!,$GET(LOCVAR),*3
+48 ; Patient Name
WRITE *2,!,$GET(PNM),*3
+49 ; Urgency
WRITE *2,!,$GET(BLRURG),*3
+50 ; Sex
WRITE *2,!,"Sex:",$GET(SEX),*3
+51 ; Provider
WRITE *2,!,"Prov:"_$EXTRACT($GET(PROVN),1,18),*3
+52 ; Date of Birth
WRITE *2,!,$GET(DOBSTR),*3
+53 ;----- END IHS MODIFICATIONS LR*5.2*1019 IHS/ITSC/MKK
+54 ;
+55 WRITE *2,*23,*15,"S30",*12,*3
+56 ;----- END IHS MODIFICATIONS LR*5.2*1018 IHS/ITSC/MKK
+57 QUIT
