BLRIPLZP ; IHS/OIT/MKK - INTERMEC IPL ACCESSION NUMBER Barcode 39 Lab Label Print ; [ 04/04/2009 8:30 AM ]
;;5.2;IHS LABORATORY;**1030**;NOV 01, 1997
;
; Total Rewrite
; For IPL capable printers only. NO BINARY CODE VERSION.
; Accession Number & BARCODE 39 ONLY.
;
; Cloned from pieces of BLRIPLUP & BLRLABLZ
;
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
;
D PRT
;
Q
;
BAR ; EP - Barcode label; Accession # Barcoded
NEW PROVSTR,FORMFEED,ZFLRAN
;
S PROVSTR=$$PROVN($G(LRAA),$G(LRAD),$G(LRAN)) ; Provider Function
S ZFLRAN=$E("0000",$L(LRAN),4)_$G(LRAN) ; Zero-Fill Accession #
;
W "<STX>R<ETX>" ; "Exit" Program Mode
;
W "<STX><ESC>E3<CAN><ETX>" ; Format 3 -- Barcode
W "<STX><CR>"_$$TESTSVAR($G(LRTXT))_"<ETX>" ; Test(s) (01)
W "<STX><CR>","Prov:"_$G(PROVSTR)_"<ETX>" ; Provider (02)
W "<STX><CR>"_$G(LRTOP)_"<ETX>" ; Top/Specimen (03)
W "<STX><CR>"_$G(LRACC)_"<ETX>" ; ACCESSION String (04)
W "<STX><CR>"_$$LRDSHRT($G(LRDAT))_"<ETX>" ; Date/Time (05)
W "<STX><CR>"_ZFLRAN_"<ETX>" ; Acces # - BarCode 39 (06)
W "<STX><CR>Ord#:"_$G(LRCE)_"<ETX>" ; Order Number (07)
W "<STX><CR>"_$$LOCVAR($G(LRLLOC),$G(LRRB))_"<ETX>" ; Location (08)
W "<STX><CR>"_$G(HRCN)_"<ETX>" ; Health Record Number (09)
W "<STX><CR>"_$$DOBSTR($G(DOB))_"<ETX>" ; Date of Birth (10)
W "<STX><CR>"_$$BLRURG($G(LRURG0))_"<ETX>" ; Urgency (11)
W "<STX><CR>"_$E($G(PNM),1,27)_"<ETX>" ; Patient Name (12)
W "<STX><CR>Sex:"_$G(SEX)_"<ETX>" ; Sex (13)
;
; W "<STX><ETB><SI>S30<FF><ETX>" ; Ending WITH Form Feed
W "<STX><ETB><SI>S30<ETX>" ; Ending 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 "<STX>R<ETX>" ; "Exit" Program Mode
W "<STX><ESC>E2<CAN><ETX>" ; Format 2 -- Plain
W "<STX><CR>"_$$TESTSVAR($G(LRTXT))_"<ETX>" ; Test(s) (01)
W "<STX><CR>"_$G(LRTOP)_"<ETX>" ; Top/Specimen (02)
W "<STX><CR>"_$$LOCVAR($G(LRLLOC),$G(LRRB))_"<ETX>" ; Location (03)
W "<STX><CR>Prov:"_$G(PROVSTR)_"<ETX>" ; Provider (04)
W "<STX><CR>"_$$LRDSHRT($G(LRDAT))_"<ETX>" ; Date/Time (05)
W "<STX><CR>"_$G(LRACC)_"<ETX>" ; Accession String (06)
W "<STX><CR>Ord#:"_$G(LRCE)_"<ETX>" ; Order Number (07)
W "<STX><CR>Sex:"_$G(SEX)_"<ETX>" ; Sex (08)
W "<STX><CR>"_$$BLRURG(LRURG0)_"<ETX>" ; Urgency (09)
W "<STX><CR>"_$G(HRCN)_"<ETX>" ; Health Record Number (10)
W "<STX><CR>"_$$DOBSTR($G(DOB))_"<ETX>" ; Date of Birth (11)
W "<STX><CR>"_$E($G(PNM),1,32)_"<ETX>" ; Patient Name (12)
;
; W "<STX><ETB><SI>S30<FF><ETX>" ; Ending WITH Form Feed
W "<STX><ETB><SI>S30<ETX>" ; Ending WITHOUT Form Feed
;
Q
;
TESTSVAR(LRTXT) ; EP -- Test(s) variable
NEW TESTSVAR
S TESTSVAR=$E($G(LRTXT),1,32)
I $L($G(LRTXT))>32 S TESTSVAR=$E($G(LRTXT),1,29)_"..."
Q TESTSVAR
;
BLRURG(LRURG0) ; EP -- Urgency variable
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
;
DOBSTR(DOB) ; EP -- Make certain DOB has something in it
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
;
LRDSHRT(LRDAT) ; EP -- Make certain date string has a 2-digit year
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
;
PROVN(LRAA,LRAD,LRAN) ; EP -- Make certain provider name has data
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)
;
LOCVAR(LRLLOC,LRRB) ; EP -- Location variable
NEW LOCVAR
S LOCVAR="L:"_$E($G(LRLLOC),1,7)
I $L(LRRB)>0 S LOCVAR=LOCVAR_" B:"_LRRB
Q LOCVAR
BLRIPLZP ; IHS/OIT/MKK - INTERMEC IPL ACCESSION NUMBER Barcode 39 Lab Label Print ; [ 04/04/2009 8:30 AM ]
+1 ;;5.2;IHS LABORATORY;**1030**;NOV 01, 1997
+2 ;
+3 ; Total Rewrite
+4 ; For IPL capable printers only. NO BINARY CODE VERSION.
+5 ; Accession Number & BARCODE 39 ONLY.
+6 ;
+7 ; Cloned from pieces of BLRIPLUP & BLRLABLZ
+8 ;
EN ; EP
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 NEW I1,J
+3 NEW BLRURG
+4 ;
+5 ; S X=0 X ^%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 IF $DATA(LRBAR)
DO BAR
QUIT
+11 ;
+12 DO PRT
+13 ;
+14 QUIT
+15 ;
BAR ; EP - Barcode label; Accession # Barcoded
+1 NEW PROVSTR,FORMFEED,ZFLRAN
+2 ;
+3 ; Provider Function
SET PROVSTR=$$PROVN($GET(LRAA),$GET(LRAD),$GET(LRAN))
+4 ; Zero-Fill Accession #
SET ZFLRAN=$EXTRACT("0000",$LENGTH(LRAN),4)_$GET(LRAN)
+5 ;
+6 ; "Exit" Program Mode
WRITE "<STX>R<ETX>"
+7 ;
+8 ; Format 3 -- Barcode
WRITE "<STX><ESC>E3<CAN><ETX>"
+9 ; Test(s) (01)
WRITE "<STX><CR>"_$$TESTSVAR($GET(LRTXT))_"<ETX>"
+10 ; Provider (02)
WRITE "<STX><CR>","Prov:"_$GET(PROVSTR)_"<ETX>"
+11 ; Top/Specimen (03)
WRITE "<STX><CR>"_$GET(LRTOP)_"<ETX>"
+12 ; ACCESSION String (04)
WRITE "<STX><CR>"_$GET(LRACC)_"<ETX>"
+13 ; Date/Time (05)
WRITE "<STX><CR>"_$$LRDSHRT($GET(LRDAT))_"<ETX>"
+14 ; Acces # - BarCode 39 (06)
WRITE "<STX><CR>"_ZFLRAN_"<ETX>"
+15 ; Order Number (07)
WRITE "<STX><CR>Ord#:"_$GET(LRCE)_"<ETX>"
+16 ; Location (08)
WRITE "<STX><CR>"_$$LOCVAR($GET(LRLLOC),$GET(LRRB))_"<ETX>"
+17 ; Health Record Number (09)
WRITE "<STX><CR>"_$GET(HRCN)_"<ETX>"
+18 ; Date of Birth (10)
WRITE "<STX><CR>"_$$DOBSTR($GET(DOB))_"<ETX>"
+19 ; Urgency (11)
WRITE "<STX><CR>"_$$BLRURG($GET(LRURG0))_"<ETX>"
+20 ; Patient Name (12)
WRITE "<STX><CR>"_$EXTRACT($GET(PNM),1,27)_"<ETX>"
+21 ; Sex (13)
WRITE "<STX><CR>Sex:"_$GET(SEX)_"<ETX>"
+22 ;
+23 ; W "<STX><ETB><SI>S30<FF><ETX>" ; Ending WITH Form Feed
+24 ; Ending WITHOUT Form Feed
WRITE "<STX><ETB><SI>S30<ETX>"
+25 ;
+26 QUIT
+27 ;
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 "<STX>R<ETX>"
+6 ; Format 2 -- Plain
WRITE "<STX><ESC>E2<CAN><ETX>"
+7 ; Test(s) (01)
WRITE "<STX><CR>"_$$TESTSVAR($GET(LRTXT))_"<ETX>"
+8 ; Top/Specimen (02)
WRITE "<STX><CR>"_$GET(LRTOP)_"<ETX>"
+9 ; Location (03)
WRITE "<STX><CR>"_$$LOCVAR($GET(LRLLOC),$GET(LRRB))_"<ETX>"
+10 ; Provider (04)
WRITE "<STX><CR>Prov:"_$GET(PROVSTR)_"<ETX>"
+11 ; Date/Time (05)
WRITE "<STX><CR>"_$$LRDSHRT($GET(LRDAT))_"<ETX>"
+12 ; Accession String (06)
WRITE "<STX><CR>"_$GET(LRACC)_"<ETX>"
+13 ; Order Number (07)
WRITE "<STX><CR>Ord#:"_$GET(LRCE)_"<ETX>"
+14 ; Sex (08)
WRITE "<STX><CR>Sex:"_$GET(SEX)_"<ETX>"
+15 ; Urgency (09)
WRITE "<STX><CR>"_$$BLRURG(LRURG0)_"<ETX>"
+16 ; Health Record Number (10)
WRITE "<STX><CR>"_$GET(HRCN)_"<ETX>"
+17 ; Date of Birth (11)
WRITE "<STX><CR>"_$$DOBSTR($GET(DOB))_"<ETX>"
+18 ; Patient Name (12)
WRITE "<STX><CR>"_$EXTRACT($GET(PNM),1,32)_"<ETX>"
+19 ;
+20 ; W "<STX><ETB><SI>S30<FF><ETX>" ; Ending WITH Form Feed
+21 ; Ending WITHOUT Form Feed
WRITE "<STX><ETB><SI>S30<ETX>"
+22 ;
+23 QUIT
+24 ;
TESTSVAR(LRTXT) ; EP -- Test(s) variable
+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 ;
BLRURG(LRURG0) ; EP -- Urgency variable
+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 ;
DOBSTR(DOB) ; EP -- Make certain DOB has something in it
+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 ;
LRDSHRT(LRDAT) ; EP -- Make certain date string has a 2-digit year
+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 ;
PROVN(LRAA,LRAD,LRAN) ; EP -- Make certain provider name has data
+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 ;
LOCVAR(LRLLOC,LRRB) ; EP -- Location variable
+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
