Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BLRDATAR

BLRDATAR.m

Go to the documentation of this file. 
  1. BLRDATAR ; IHS/OIT/MKK - DATARAY SPECIFIC     ; [ 12/10/2010  10:30 AM ]
  1.  ;;5.2;IHS LABORATORY;**1028**;NOV 01, 1997;Build 46
  1.  ;
  1.  ; Cloned from pieces of BLRIPLUP & BLRLABLZ
  1.  ;
  1. EN ; EP
  1.  S:$D(ZTQUEUED) ZTREQ="@"
  1.  N I1,J
  1.  NEW BLRURG
  1.  ;
  1.  ; S X=0 X ^%ZOSF("RM")
  1.  S:'$L($G(LRRB)) LRRB=""
  1.  S BLRURG=""  ;IHS/DIR TUC/AAB 03/23/98
  1.  S J=0
  1.  S LRTXT=""
  1.  S FLAG=0
  1.  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_";"
  1.  ;
  1. FLAG ; EP
  1.  S:FLAG=0 LRDTXT=LRTXT S:FLAG=1 LRDTXT=".............."
  1.  S LRLPNM=$P(PNM,",",1),LRLPNM=LRLPNM_$S($L(LRLPNM)<18:","_$E($P(PNM,",",2),1),1:"")
  1.  ;
  1.  NEW LRAPTR,LRSUB
  1.  S LRSUB=$P($G(LRACC)," ",1)
  1.  S LRAPTR=+$O(^LRO(68,"B",LRSUB,""))
  1.  I LRAPTR>0&(+$P($G(^LRO(68,LRAPTR,0)),"^",15)) D BAR Q
  1.  I LRAPTR>0&('+$P($G(^LRO(68,LRAPTR,0)),"^",15)) D PRT Q
  1.  ;
  1.  I $D(LRBAR) D BAR Q
  1.  ;
  1.  D PRT
  1.  ;
  1.  Q
  1.  ;
  1. BAR ; EP - Barcode label; Accession # Barcoded
  1.  NEW PROVSTR,FORMFEED,ZFLRAN
  1.  ;
  1.  S PROVSTR=$$PROVN($G(LRAA),$G(LRAD),$G(LRAN))          ; Provider Function
  1.  S ZFLRAN=$E("0000",$L(LRAN),4)_$G(LRAN)                ; Zero-Fill Accession #
  1.  ;
  1.  W "Test(s):",$$TESTSVAR($G(LRTXT)),!              ; Test(s)              (01)
  1.  W "Prov:",$G(PROVSTR),!                           ; Provider             (02)
  1.  W "Top:",$G(LRTOP),!                              ; Top/Specimen         (03)
  1.  W "Accession:",$G(LRACC),!                        ; ACCESSION String     (04)
  1.  W "UID:",$G(LRUID),!                              ; UID                  (05)
  1.  W "Date/Time:",$$LRDSHRT($G(LRDAT)),!             ; Date/Time            (06)
  1.  W "Ord#:",$G(LRCE),!                              ; Order Number         (07)
  1.  W "Location:",$$LOCVAR($G(LRLLOC),$G(LRRB)),!     ; Location             (08)
  1.  W "HRCN:",$G(HRCN),!                              ; Health Record Number (09)
  1.  W $$DOBSTR($G(DOB)),!                             ; Date of Birth        (10)
  1.  W "Urgency:",$$BLRURG($G(LRURG0)),!               ; Urgency              (11)
  1.  W "Pt Name:",$E($G(PNM),1,27),!                   ; Patient Name         (12)
  1.  W "Sex:",$G(SEX),!                                ; Sex                  (13)
  1.  ;
  1.  W !
  1.  ;
  1.  Q
  1.  ;
  1. PRT ; EP - plain label..no barcode
  1.  ;
  1.  NEW PROVSTR,FORMFEED
  1.  S PROVSTR=$$PROVN($G(LRAA),$G(LRAD),$G(LRAN))          ; Provider Function
  1.  ;
  1.  W "Test(s):",$$TESTSVAR($G(LRTXT)),!              ; Test(s)              (01)
  1.  W "Prov:",$G(PROVSTR),!                           ; Provider             (02)
  1.  W "Top:",$G(LRTOP),!                              ; Top/Specimen         (03)
  1.  W "Accession:",$G(LRACC),!                        ; ACCESSION String     (04)
  1.  W "UID:",$G(LRUID),!                              ; UID                  (05)
  1.  W "Date/Time:",$$LRDSHRT($G(LRDAT)),!             ; Date/Time            (06)
  1.  W "Ord#:",$G(LRCE),!                              ; Order Number         (07)
  1.  W "Location:",$$LOCVAR($G(LRLLOC),$G(LRRB)),!     ; Location             (08)
  1.  W "HRCN:",$G(HRCN),!                              ; Health Record Number (09)
  1.  W $$DOBSTR($G(DOB)),!                             ; Date of Birth        (10)
  1.  W "Urgency:",$$BLRURG($G(LRURG0)),!               ; Urgency              (11)
  1.  W "Pt Name:",$E($G(PNM),1,27),!                   ; Patient Name         (12)
  1.  W "Sex:",$G(SEX),!                                ; Sex                  (13)
  1.  ;
  1.  Q
  1.  ;
  1. TESTSVAR(LRTXT) ; EP -- Test(s) variable
  1.  NEW TESTSVAR
  1.  S TESTSVAR=$E($G(LRTXT),1,32)
  1.  I $L($G(LRTXT))>32 S TESTSVAR=$E($G(LRTXT),1,29)_"..."
  1.  Q TESTSVAR
  1.  ;
  1. BLRURG(LRURG0)      ; EP -- Urgency variable
  1.  NEW BLRURG
  1.  S BLRURG="N/A"    ; Make sure BLRURG has something in it
  1.  I $G(LRURG0)'="" S BLRURG=$E($P(^LAB(62.05,LRURG0,0),U,1),1,4)  ;IHS/DIR TUC/AAB 03/23/98
  1.  Q BLRURG
  1.  ;
  1. DOBSTR(DOB) ; EP -- Make certain DOB has something in it
  1.  I DOB="XX/XX/XXXX" Q "DoB:"_DOB    ; If TEST DoB
  1.  ;
  1.  NEW FMDOB
  1.  ; Data in VADM array initialized by LRU routine
  1.  S FMDOB=+$G(VADM(3))
  1.  I FMDOB<1 Q "DoB:"_DOB
  1.  ;
  1.  Q "DoB:"_$$FMTE^XLFDT(FMDOB,"5DZ")       ; Return MM/DD/CCYY as DOB
  1.  ;
  1. LRDSHRT(LRDAT)      ; EP -- Make certain date string has a 2-digit year
  1.  I LRDAT="XX/XX/XX" Q LRDAT_" XX:XX"             ; Test Date string
  1.  ;
  1.  NEW LRDSHRT
  1.  S LRDSHRT=$G(LRDAT)
  1.  I $L($P($P(LRDAT,"/",3)," ",1))>2 D
  1.  . S LRDSHRT=$P(LRDAT,"/",1,2)_"/"_$E($P(LRDAT,"/",3),3,$L(LRDAT))
  1.  Q LRDSHRT
  1.  ;
  1. PROVN(LRAA,LRAD,LRAN)      ; EP -- Make certain provider name has data
  1.  I +$G(LRAA)=0!(+$G(LRAD)=0) Q "TEST,PROVIDER"
  1.  ;
  1.  NEW PROVN                             ; Provider Name
  1.  NEW PTR                               ; Provider Pointer
  1.  ;
  1.  S PROVN=""
  1.  I $G(LRAA)'=""&($G(LRAD)'="")&($G(LRAN)'="")  D
  1.  . S PTR=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",8)
  1.  . I $G(PTR)'="" S PROVN=$P($G(^VA(200,PTR,0)),"^",1)
  1.  Q $E(PROVN,1,18)
  1.  ;
  1. LOCVAR(LRLLOC,LRRB)      ; EP -- Location variable
  1.  NEW LOCVAR
  1.  S LOCVAR="L:"_$E($G(LRLLOC),1,7)
  1.  I $L(LRRB)>0 S LOCVAR=LOCVAR_" B:"_LRRB
  1.  Q LOCVAR