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

BLRIPLZP.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ; Total Rewrite
  1.  ; For IPL capable printers only.  NO BINARY CODE VERSION.
  1.  ; Accession Number & BARCODE 39 ONLY.
  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 "<STX>R<ETX>"                                        ; "Exit" Program Mode
  1.  ;
  1.  W "<STX><ESC>E3<CAN><ETX>"                             ; Format 3 -- Barcode
  1.  W "<STX><CR>"_$$TESTSVAR($G(LRTXT))_"<ETX>"            ; Test(s)              (01)
  1.  W "<STX><CR>","Prov:"_$G(PROVSTR)_"<ETX>"              ; Provider             (02)
  1.  W "<STX><CR>"_$G(LRTOP)_"<ETX>"                        ; Top/Specimen         (03)
  1.  W "<STX><CR>"_$G(LRACC)_"<ETX>"                        ; ACCESSION String     (04)
  1.  W "<STX><CR>"_$$LRDSHRT($G(LRDAT))_"<ETX>"             ; Date/Time            (05)
  1.  W "<STX><CR>"_ZFLRAN_"<ETX>"                           ; Acces # - BarCode 39 (06)
  1.  W "<STX><CR>Ord#:"_$G(LRCE)_"<ETX>"                    ; Order Number         (07)
  1.  W "<STX><CR>"_$$LOCVAR($G(LRLLOC),$G(LRRB))_"<ETX>"    ; Location             (08)
  1.  W "<STX><CR>"_$G(HRCN)_"<ETX>"                         ; Health Record Number (09)
  1.  W "<STX><CR>"_$$DOBSTR($G(DOB))_"<ETX>"                ; Date of Birth        (10)
  1.  W "<STX><CR>"_$$BLRURG($G(LRURG0))_"<ETX>"             ; Urgency              (11)
  1.  W "<STX><CR>"_$E($G(PNM),1,27)_"<ETX>"                 ; Patient Name         (12)
  1.  W "<STX><CR>Sex:"_$G(SEX)_"<ETX>"                      ; Sex                  (13)
  1.  ;
  1.  ; W "<STX><ETB><SI>S30<FF><ETX>"                         ; Ending WITH Form Feed
  1.  W "<STX><ETB><SI>S30<ETX>"                             ; Ending 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 "<STX>R<ETX>"                                        ; "Exit" Program Mode
  1.  W "<STX><ESC>E2<CAN><ETX>"                             ; Format 2 -- Plain
  1.  W "<STX><CR>"_$$TESTSVAR($G(LRTXT))_"<ETX>"            ; Test(s)              (01)
  1.  W "<STX><CR>"_$G(LRTOP)_"<ETX>"                        ; Top/Specimen         (02)
  1.  W "<STX><CR>"_$$LOCVAR($G(LRLLOC),$G(LRRB))_"<ETX>"    ; Location             (03)
  1.  W "<STX><CR>Prov:"_$G(PROVSTR)_"<ETX>"                 ; Provider             (04)
  1.  W "<STX><CR>"_$$LRDSHRT($G(LRDAT))_"<ETX>"             ; Date/Time            (05)
  1.  W "<STX><CR>"_$G(LRACC)_"<ETX>"                        ; Accession String     (06)
  1.  W "<STX><CR>Ord#:"_$G(LRCE)_"<ETX>"                    ; Order Number         (07)
  1.  W "<STX><CR>Sex:"_$G(SEX)_"<ETX>"                      ; Sex                  (08)
  1.  W "<STX><CR>"_$$BLRURG(LRURG0)_"<ETX>"                 ; Urgency              (09)
  1.  W "<STX><CR>"_$G(HRCN)_"<ETX>"                         ; Health Record Number (10)
  1.  W "<STX><CR>"_$$DOBSTR($G(DOB))_"<ETX>"                ; Date of Birth        (11)
  1.  W "<STX><CR>"_$E($G(PNM),1,32)_"<ETX>"                 ; Patient Name         (12)
  1.  ;
  1.  ; W "<STX><ETB><SI>S30<FF><ETX>"                         ; Ending WITH Form Feed
  1.  W "<STX><ETB><SI>S30<ETX>"                             ; Ending WITHOUT Form Feed
  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