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

BLRP41UP.m

Go to the documentation of this file. 
  1. BLRP41UP ; IHS/OIT/MKK - INTERMEC PC41 UID Barcoded Print ;DEC 09, 2008 8:30 AM
  1.  ;;5.2;IHS LABORATORY;**1025**;NOV 01, 1997
  1.  ;
  1.  ; Prints Labels with UID barcoded, NOT, repeat
  1.  ; NOT, the Accession's Number barcoded
  1.  ; 
  1.  ; Cloned from BLRLABLC
  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  ;IHS/MJL 3/18/99
  1.  ;
  1.  D PRT
  1.  K BLRURG
  1.  ;
  1.  Q
  1.  ;
  1. BAR ; EP - Barcode label; UID Barcoded
  1.  ;
  1.  NEW PROVSTR,FORMFEED
  1.  S PROVSTR=$$PROVN($G(LRAA),$G(LRAD),$G(LRAN))   ; Provider Function
  1.  ;
  1.  W *2,"R",*3                                     ; Exit Program Mode
  1.  ;
  1.  W *2,!,*27,"E3",*24,!,$$TESTSVAR($G(LRTXT)),*3  ; Test(s)              (01)
  1.  W *2,!,$G(LRTOP),*3                             ; Tube top/specimen    (02)
  1.  W *2,!,"Ord#:"_$G(LRCE),*3                      ; Order Number         (03)
  1.  W *2,!,"UID:"_$G(LRUID),*3                      ; UID String           (04)
  1.  W *2,!,$$LRDSHRT(LRDAT),*3                      ; Date                 (05)
  1.  W *2,!,$G(HRCN),*3                              ; Health Record Number (06)
  1.  W *2,!,$$LOCVAR(LRLLOC,LRRB),*3                 ; Location             (07)
  1.  W *2,!,$G(PNM),*3                               ; Patient Name         (08)
  1.  W *2,!,$$BLRURG(LRURG0),*3                      ; Urgency              (09)
  1.  W *2,!,$TR($J($G(LRUID),10)," ","0"),*3         ; UID Bar Coded [ZF]   (10)
  1.  W *2,!,"Sex:"_$G(SEX),*3                        ; Sex                  (11)
  1.  W *2,!,"Prov:"_PROVSTR,*3                       ; Provider             (12)
  1.  W *2,!,$$DOBSTR(DOB),*3                         ; Date of Birth        (13)
  1.  ;
  1.  W *2,*23,*15,"S30",*12,*3                       ; End WITH Form Feed
  1.  ;W *2,*23,*15,"S30",*3                          ; End WITHOUT Form Feed
  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 *2,"R",*3                                     ; Exit Program Mode
  1.  ;
  1.  W *2,!,*27,"E2",*24,!,$$TESTSVAR($G(LRTXT)),*3  ; Test(s)              (01)
  1.  W *2,!,$G(LRTOP),*3                             ; Tube top/specimen    (02)
  1.  W *2,!,"Ord#:",$G(LRCE),*3                      ; Order Number         (03)
  1.  W *2,!,"UID:",$G(LRUID),*3                      ; UID String           (04)
  1.  W *2,!,$$LRDSHRT($G(LRDAT)),*3                  ; Date                 (05)
  1.  W *2,!,$G(HRCN),*3                              ; Health Record Number (06)
  1.  W *2,!,$$LOCVAR($G(LRLLOC),$G(LRRB)),*3         ; Location             (07)
  1.  W *2,!,$G(PNM),*3                               ; Patient Name         (08)
  1.  W *2,!,$$BLRURG(LRURG0),*3                      ; Urgency              (09)
  1.  W *2,!,"Sex:",$G(SEX),*3                        ; Sex                  (10)
  1.  W *2,!,"Prov:",PROVSTR,*3                       ; Provider             (11)
  1.  W *2,!,$$DOBSTR($G(DOB)),*3                     ; Date of Birth        (12)
  1.  ;
  1.  W *2,*23,*15,"S30",*12,*3                       ; End WITH Form Feed
  1.  ;W *2,*23,*15,"S30",*3                          ; End WITHOUT Form Feed
  1.  ;
  1.  Q
  1.  ;
  1.  ; Test(s) variable
  1. TESTSVAR(LRTXT) ;
  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.  ; Urgency variable
  1. BLRURG(LRURG0)      ;
  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.  ; Make certain DOB has something in it
  1. DOBSTR(DOB) ;
  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.  ; Make certain date string has a 2-digit year
  1. LRDSHRT(LRDAT)      ;
  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.  ; Make certain provider name has data
  1. PROVN(LRAA,LRAD,LRAN)      ;
  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.  ; Location variable
  1. LOCVAR(LRLLOC,LRRB)      ;
  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