BLRP41UP ; IHS/OIT/MKK - INTERMEC PC41 UID Barcoded Print ;DEC 09, 2008 8:30 AM
;;5.2;IHS LABORATORY;**1025**;NOV 01, 1997
;
; Prints Labels with UID barcoded, NOT, repeat
; NOT, the Accession's Number barcoded
;
; Cloned from BLRLABLC
;
EN ; EP
S:$D(ZTQUEUED) ZTREQ="@"
N I1,J
NEW BLRURG
;
S X=0 X ^%ZOSF("RM")
S:'$L($G(LRRB)) LRRB=""
S BLRURG="" ;IHS/DIR TUC/AAB 03/23/98
S J=0
S LRTXT=""
S 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 ; EP
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:"")
;
NEW LRAPTR,LRSUB
S LRSUB=$P($G(LRACC)," ",1)
S LRAPTR=+$O(^LRO(68,"B",LRSUB,""))
I LRAPTR>0&(+$P($G(^LRO(68,LRAPTR,0)),"^",15)) D BAR Q
I LRAPTR>0&('+$P($G(^LRO(68,LRAPTR,0)),"^",15)) D PRT Q
;
I $D(LRBAR) D BAR Q ;IHS/MJL 3/18/99
;
D PRT
K BLRURG
;
Q
;
BAR ; EP - Barcode label; UID Barcoded
;
NEW PROVSTR,FORMFEED
S PROVSTR=$$PROVN($G(LRAA),$G(LRAD),$G(LRAN)) ; Provider Function
;
W *2,"R",*3 ; Exit Program Mode
;
W *2,!,*27,"E3",*24,!,$$TESTSVAR($G(LRTXT)),*3 ; Test(s) (01)
W *2,!,$G(LRTOP),*3 ; Tube top/specimen (02)
W *2,!,"Ord#:"_$G(LRCE),*3 ; Order Number (03)
W *2,!,"UID:"_$G(LRUID),*3 ; UID String (04)
W *2,!,$$LRDSHRT(LRDAT),*3 ; Date (05)
W *2,!,$G(HRCN),*3 ; Health Record Number (06)
W *2,!,$$LOCVAR(LRLLOC,LRRB),*3 ; Location (07)
W *2,!,$G(PNM),*3 ; Patient Name (08)
W *2,!,$$BLRURG(LRURG0),*3 ; Urgency (09)
W *2,!,$TR($J($G(LRUID),10)," ","0"),*3 ; UID Bar Coded [ZF] (10)
W *2,!,"Sex:"_$G(SEX),*3 ; Sex (11)
W *2,!,"Prov:"_PROVSTR,*3 ; Provider (12)
W *2,!,$$DOBSTR(DOB),*3 ; Date of Birth (13)
;
W *2,*23,*15,"S30",*12,*3 ; End WITH Form Feed
;W *2,*23,*15,"S30",*3 ; End WITHOUT Form Feed
;
Q
;
PRT ; EP - plain label..no barcode
;
NEW PROVSTR,FORMFEED
S PROVSTR=$$PROVN($G(LRAA),$G(LRAD),$G(LRAN)) ; Provider Function
;
W *2,"R",*3 ; Exit Program Mode
;
W *2,!,*27,"E2",*24,!,$$TESTSVAR($G(LRTXT)),*3 ; Test(s) (01)
W *2,!,$G(LRTOP),*3 ; Tube top/specimen (02)
W *2,!,"Ord#:",$G(LRCE),*3 ; Order Number (03)
W *2,!,"UID:",$G(LRUID),*3 ; UID String (04)
W *2,!,$$LRDSHRT($G(LRDAT)),*3 ; Date (05)
W *2,!,$G(HRCN),*3 ; Health Record Number (06)
W *2,!,$$LOCVAR($G(LRLLOC),$G(LRRB)),*3 ; Location (07)
W *2,!,$G(PNM),*3 ; Patient Name (08)
W *2,!,$$BLRURG(LRURG0),*3 ; Urgency (09)
W *2,!,"Sex:",$G(SEX),*3 ; Sex (10)
W *2,!,"Prov:",PROVSTR,*3 ; Provider (11)
W *2,!,$$DOBSTR($G(DOB)),*3 ; Date of Birth (12)
;
W *2,*23,*15,"S30",*12,*3 ; End WITH Form Feed
;W *2,*23,*15,"S30",*3 ; End WITHOUT Form Feed
;
Q
;
; Test(s) variable
TESTSVAR(LRTXT) ;
NEW TESTSVAR
S TESTSVAR=$E($G(LRTXT),1,32)
I $L($G(LRTXT))>32 S TESTSVAR=$E($G(LRTXT),1,29)_"..."
Q TESTSVAR
;
; Urgency variable
BLRURG(LRURG0) ;
NEW BLRURG
S BLRURG="N/A" ; Make sure BLRURG has something in it
I $G(LRURG0)'="" S BLRURG=$E($P(^LAB(62.05,LRURG0,0),U,1),1,4) ;IHS/DIR TUC/AAB 03/23/98
Q BLRURG
;
; Make certain DOB has something in it
DOBSTR(DOB) ;
I DOB="XX/XX/XXXX" Q "DoB:"_DOB ; If TEST DoB
;
NEW FMDOB
; Data in VADM array initialized by LRU routine
S FMDOB=+$G(VADM(3))
I FMDOB<1 Q "DoB:"_DOB
;
Q "DoB:"_$$FMTE^XLFDT(FMDOB,"5DZ") ; Return MM/DD/CCYY as DOB
;
; Make certain date string has a 2-digit year
LRDSHRT(LRDAT) ;
I LRDAT="XX/XX/XX" Q LRDAT_" XX:XX" ; Test Date string
;
NEW LRDSHRT
S LRDSHRT=$G(LRDAT)
I $L($P($P(LRDAT,"/",3)," ",1))>2 D
. S LRDSHRT=$P(LRDAT,"/",1,2)_"/"_$E($P(LRDAT,"/",3),3,$L(LRDAT))
Q LRDSHRT
;
; Make certain provider name has data
PROVN(LRAA,LRAD,LRAN) ;
I +$G(LRAA)=0!(+$G(LRAD)=0) Q "TEST,PROVIDER"
;
NEW PROVN ; Provider Name
NEW PTR ; Provider Pointer
;
S PROVN=""
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)
Q $E(PROVN,1,18)
;
; Location variable
LOCVAR(LRLLOC,LRRB) ;
NEW LOCVAR
S LOCVAR="L:"_$E($G(LRLLOC),1,7)
I $L(LRRB)>0 S LOCVAR=LOCVAR_" B:"_LRRB
Q LOCVAR
BLRP41UP ; IHS/OIT/MKK - INTERMEC PC41 UID Barcoded Print ;DEC 09, 2008 8:30 AM
+1 ;;5.2;IHS LABORATORY;**1025**;NOV 01, 1997
+2 ;
+3 ; Prints Labels with UID barcoded, NOT, repeat
+4 ; NOT, the Accession's Number barcoded
+5 ;
+6 ; Cloned from BLRLABLC
+7 ;
EN ; EP
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 NEW I1,J
+3 NEW BLRURG
+4 ;
+5 SET X=0
XECUTE ^%ZOSF("RM")
+6 IF '$LENGTH($GET(LRRB))
SET LRRB=""
+7 ;IHS/DIR TUC/AAB 03/23/98
SET BLRURG=""
+8 SET J=0
+9 SET LRTXT=""
+10 SET FLAG=0
+11 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_";"
+12 ;
FLAG ; EP
+1 IF FLAG=0
SET LRDTXT=LRTXT
IF FLAG=1
SET LRDTXT=".............."
+2 SET LRLPNM=$PIECE(PNM,",",1)
SET LRLPNM=LRLPNM_$SELECT($LENGTH(LRLPNM)<18:","_$EXTRACT($PIECE(PNM,",",2),1),1:"")
+3 ;
+4 NEW LRAPTR,LRSUB
+5 SET LRSUB=$PIECE($GET(LRACC)," ",1)
+6 SET LRAPTR=+$ORDER(^LRO(68,"B",LRSUB,""))
+7 IF LRAPTR>0&(+$PIECE($GET(^LRO(68,LRAPTR,0)),"^",15))
DO BAR
QUIT
+8 IF LRAPTR>0&('+$PIECE($GET(^LRO(68,LRAPTR,0)),"^",15))
DO PRT
QUIT
+9 ;
+10 ;IHS/MJL 3/18/99
IF $DATA(LRBAR)
DO BAR
QUIT
+11 ;
+12 DO PRT
+13 KILL BLRURG
+14 ;
+15 QUIT
+16 ;
BAR ; EP - Barcode label; UID Barcoded
+1 ;
+2 NEW PROVSTR,FORMFEED
+3 ; Provider Function
SET PROVSTR=$$PROVN($GET(LRAA),$GET(LRAD),$GET(LRAN))
+4 ;
+5 ; Exit Program Mode
WRITE *2,"R",*3
+6 ;
+7 ; Test(s) (01)
WRITE *2,!,*27,"E3",*24,!,$$TESTSVAR($GET(LRTXT)),*3
+8 ; Tube top/specimen (02)
WRITE *2,!,$GET(LRTOP),*3
+9 ; Order Number (03)
WRITE *2,!,"Ord#:"_$GET(LRCE),*3
+10 ; UID String (04)
WRITE *2,!,"UID:"_$GET(LRUID),*3
+11 ; Date (05)
WRITE *2,!,$$LRDSHRT(LRDAT),*3
+12 ; Health Record Number (06)
WRITE *2,!,$GET(HRCN),*3
+13 ; Location (07)
WRITE *2,!,$$LOCVAR(LRLLOC,LRRB),*3
+14 ; Patient Name (08)
WRITE *2,!,$GET(PNM),*3
+15 ; Urgency (09)
WRITE *2,!,$$BLRURG(LRURG0),*3
+16 ; UID Bar Coded [ZF] (10)
WRITE *2,!,$TRANSLATE($JUSTIFY($GET(LRUID),10)," ","0"),*3
+17 ; Sex (11)
WRITE *2,!,"Sex:"_$GET(SEX),*3
+18 ; Provider (12)
WRITE *2,!,"Prov:"_PROVSTR,*3
+19 ; Date of Birth (13)
WRITE *2,!,$$DOBSTR(DOB),*3
+20 ;
+21 ; End WITH Form Feed
WRITE *2,*23,*15,"S30",*12,*3
+22 ;W *2,*23,*15,"S30",*3 ; End WITHOUT Form Feed
+23 ;
+24 QUIT
+25 ;
PRT ; EP - plain label..no barcode
+1 ;
+2 NEW PROVSTR,FORMFEED
+3 ; Provider Function
SET PROVSTR=$$PROVN($GET(LRAA),$GET(LRAD),$GET(LRAN))
+4 ;
+5 ; Exit Program Mode
WRITE *2,"R",*3
+6 ;
+7 ; Test(s) (01)
WRITE *2,!,*27,"E2",*24,!,$$TESTSVAR($GET(LRTXT)),*3
+8 ; Tube top/specimen (02)
WRITE *2,!,$GET(LRTOP),*3
+9 ; Order Number (03)
WRITE *2,!,"Ord#:",$GET(LRCE),*3
+10 ; UID String (04)
WRITE *2,!,"UID:",$GET(LRUID),*3
+11 ; Date (05)
WRITE *2,!,$$LRDSHRT($GET(LRDAT)),*3
+12 ; Health Record Number (06)
WRITE *2,!,$GET(HRCN),*3
+13 ; Location (07)
WRITE *2,!,$$LOCVAR($GET(LRLLOC),$GET(LRRB)),*3
+14 ; Patient Name (08)
WRITE *2,!,$GET(PNM),*3
+15 ; Urgency (09)
WRITE *2,!,$$BLRURG(LRURG0),*3
+16 ; Sex (10)
WRITE *2,!,"Sex:",$GET(SEX),*3
+17 ; Provider (11)
WRITE *2,!,"Prov:",PROVSTR,*3
+18 ; Date of Birth (12)
WRITE *2,!,$$DOBSTR($GET(DOB)),*3
+19 ;
+20 ; End WITH Form Feed
WRITE *2,*23,*15,"S30",*12,*3
+21 ;W *2,*23,*15,"S30",*3 ; End WITHOUT Form Feed
+22 ;
+23 QUIT
+24 ;
+25 ; Test(s) variable
TESTSVAR(LRTXT) ;
+1 NEW TESTSVAR
+2 SET TESTSVAR=$EXTRACT($GET(LRTXT),1,32)
+3 IF $LENGTH($GET(LRTXT))>32
SET TESTSVAR=$EXTRACT($GET(LRTXT),1,29)_"..."
+4 QUIT TESTSVAR
+5 ;
+6 ; Urgency variable
BLRURG(LRURG0) ;
+1 NEW BLRURG
+2 ; Make sure BLRURG has something in it
SET BLRURG="N/A"
+3 ;IHS/DIR TUC/AAB 03/23/98
IF $GET(LRURG0)'=""
SET BLRURG=$EXTRACT($PIECE(^LAB(62.05,LRURG0,0),U,1),1,4)
+4 QUIT BLRURG
+5 ;
+6 ; Make certain DOB has something in it
DOBSTR(DOB) ;
+1 ; If TEST DoB
IF DOB="XX/XX/XXXX"
QUIT "DoB:"_DOB
+2 ;
+3 NEW FMDOB
+4 ; Data in VADM array initialized by LRU routine
+5 SET FMDOB=+$GET(VADM(3))
+6 IF FMDOB<1
QUIT "DoB:"_DOB
+7 ;
+8 ; Return MM/DD/CCYY as DOB
QUIT "DoB:"_$$FMTE^XLFDT(FMDOB,"5DZ")
+9 ;
+10 ; Make certain date string has a 2-digit year
LRDSHRT(LRDAT) ;
+1 ; Test Date string
IF LRDAT="XX/XX/XX"
QUIT LRDAT_" XX:XX"
+2 ;
+3 NEW LRDSHRT
+4 SET LRDSHRT=$GET(LRDAT)
+5 IF $LENGTH($PIECE($PIECE(LRDAT,"/",3)," ",1))>2
Begin DoDot:1
+6 SET LRDSHRT=$PIECE(LRDAT,"/",1,2)_"/"_$EXTRACT($PIECE(LRDAT,"/",3),3,$LENGTH(LRDAT))
End DoDot:1
+7 QUIT LRDSHRT
+8 ;
+9 ; Make certain provider name has data
PROVN(LRAA,LRAD,LRAN) ;
+1 IF +$GET(LRAA)=0!(+$GET(LRAD)=0)
QUIT "TEST,PROVIDER"
+2 ;
+3 ; Provider Name
NEW PROVN
+4 ; Provider Pointer
NEW PTR
+5 ;
+6 SET PROVN=""
+7 IF $GET(LRAA)'=""&($GET(LRAD)'="")&($GET(LRAN)'="")
Begin DoDot:1
+8 SET PTR=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",8)
+9 IF $GET(PTR)'=""
SET PROVN=$PIECE($GET(^VA(200,PTR,0)),"^",1)
End DoDot:1
+10 QUIT $EXTRACT(PROVN,1,18)
+11 ;
+12 ; Location variable
LOCVAR(LRLLOC,LRRB) ;
+1 NEW LOCVAR
+2 SET LOCVAR="L:"_$EXTRACT($GET(LRLLOC),1,7)
+3 IF $LENGTH(LRRB)>0
SET LOCVAR=LOCVAR_" B:"_LRRB
+4 QUIT LOCVAR
