BLRDATAR ; IHS/OIT/MKK - DATARAY SPECIFIC ; [ 12/10/2010 10:30 AM ]
;;5.2;IHS LABORATORY;**1028**;NOV 01, 1997;Build 46
;
; 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 "Test(s):",$$TESTSVAR($G(LRTXT)),! ; Test(s) (01)
W "Prov:",$G(PROVSTR),! ; Provider (02)
W "Top:",$G(LRTOP),! ; Top/Specimen (03)
W "Accession:",$G(LRACC),! ; ACCESSION String (04)
W "UID:",$G(LRUID),! ; UID (05)
W "Date/Time:",$$LRDSHRT($G(LRDAT)),! ; Date/Time (06)
W "Ord#:",$G(LRCE),! ; Order Number (07)
W "Location:",$$LOCVAR($G(LRLLOC),$G(LRRB)),! ; Location (08)
W "HRCN:",$G(HRCN),! ; Health Record Number (09)
W $$DOBSTR($G(DOB)),! ; Date of Birth (10)
W "Urgency:",$$BLRURG($G(LRURG0)),! ; Urgency (11)
W "Pt Name:",$E($G(PNM),1,27),! ; Patient Name (12)
W "Sex:",$G(SEX),! ; Sex (13)
;
W !
;
Q
;
PRT ; EP - plain label..no barcode
;
NEW PROVSTR,FORMFEED
S PROVSTR=$$PROVN($G(LRAA),$G(LRAD),$G(LRAN)) ; Provider Function
;
W "Test(s):",$$TESTSVAR($G(LRTXT)),! ; Test(s) (01)
W "Prov:",$G(PROVSTR),! ; Provider (02)
W "Top:",$G(LRTOP),! ; Top/Specimen (03)
W "Accession:",$G(LRACC),! ; ACCESSION String (04)
W "UID:",$G(LRUID),! ; UID (05)
W "Date/Time:",$$LRDSHRT($G(LRDAT)),! ; Date/Time (06)
W "Ord#:",$G(LRCE),! ; Order Number (07)
W "Location:",$$LOCVAR($G(LRLLOC),$G(LRRB)),! ; Location (08)
W "HRCN:",$G(HRCN),! ; Health Record Number (09)
W $$DOBSTR($G(DOB)),! ; Date of Birth (10)
W "Urgency:",$$BLRURG($G(LRURG0)),! ; Urgency (11)
W "Pt Name:",$E($G(PNM),1,27),! ; Patient Name (12)
W "Sex:",$G(SEX),! ; Sex (13)
;
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
BLRDATAR ; IHS/OIT/MKK - DATARAY SPECIFIC ; [ 12/10/2010 10:30 AM ]
+1 ;;5.2;IHS LABORATORY;**1028**;NOV 01, 1997;Build 46
+2 ;
+3 ; Cloned from pieces of BLRIPLUP & BLRLABLZ
+4 ;
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 ; Test(s) (01)
WRITE "Test(s):",$$TESTSVAR($GET(LRTXT)),!
+7 ; Provider (02)
WRITE "Prov:",$GET(PROVSTR),!
+8 ; Top/Specimen (03)
WRITE "Top:",$GET(LRTOP),!
+9 ; ACCESSION String (04)
WRITE "Accession:",$GET(LRACC),!
+10 ; UID (05)
WRITE "UID:",$GET(LRUID),!
+11 ; Date/Time (06)
WRITE "Date/Time:",$$LRDSHRT($GET(LRDAT)),!
+12 ; Order Number (07)
WRITE "Ord#:",$GET(LRCE),!
+13 ; Location (08)
WRITE "Location:",$$LOCVAR($GET(LRLLOC),$GET(LRRB)),!
+14 ; Health Record Number (09)
WRITE "HRCN:",$GET(HRCN),!
+15 ; Date of Birth (10)
WRITE $$DOBSTR($GET(DOB)),!
+16 ; Urgency (11)
WRITE "Urgency:",$$BLRURG($GET(LRURG0)),!
+17 ; Patient Name (12)
WRITE "Pt Name:",$EXTRACT($GET(PNM),1,27),!
+18 ; Sex (13)
WRITE "Sex:",$GET(SEX),!
+19 ;
+20 WRITE !
+21 ;
+22 QUIT
+23 ;
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 ; Test(s) (01)
WRITE "Test(s):",$$TESTSVAR($GET(LRTXT)),!
+6 ; Provider (02)
WRITE "Prov:",$GET(PROVSTR),!
+7 ; Top/Specimen (03)
WRITE "Top:",$GET(LRTOP),!
+8 ; ACCESSION String (04)
WRITE "Accession:",$GET(LRACC),!
+9 ; UID (05)
WRITE "UID:",$GET(LRUID),!
+10 ; Date/Time (06)
WRITE "Date/Time:",$$LRDSHRT($GET(LRDAT)),!
+11 ; Order Number (07)
WRITE "Ord#:",$GET(LRCE),!
+12 ; Location (08)
WRITE "Location:",$$LOCVAR($GET(LRLLOC),$GET(LRRB)),!
+13 ; Health Record Number (09)
WRITE "HRCN:",$GET(HRCN),!
+14 ; Date of Birth (10)
WRITE $$DOBSTR($GET(DOB)),!
+15 ; Urgency (11)
WRITE "Urgency:",$$BLRURG($GET(LRURG0)),!
+16 ; Patient Name (12)
WRITE "Pt Name:",$EXTRACT($GET(PNM),1,27),!
+17 ; Sex (13)
WRITE "Sex:",$GET(SEX),!
+18 ;
+19 QUIT
+20 ;
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
