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

LRLABLD.m

Go to the documentation of this file.
  1. LRLABLD ;DALOI/TGA/JMC - LABELS ON DEMAND ; 08/29/16@12:21pm
  1. ;;5.2;LAB SERVICE;**65,161,218,465**;Sep 27, 1994;Build 25
  1. ;CHY/RTW/JAH added LR*5.2*465 institution extra labels selection
  1. ENT ;
  1. ; Called by LROE
  1. S U="^"
  1. D PSET
  1. S LRLABLIO=IO
  1. S LRAA=0
  1. F S LRAA=$O(LRLBL(LRAA)) Q:LRAA<1 D EN2
  1. K LRBAR,LRBAR1,LRBAR0,LRBARID,LREND,LRI,LRN,LROK,LRURG,LRURG0,LRURGA
  1. I $D(ZTQUEUED) S ZTREQ="@"
  1. E D PKILL^%ZISP
  1. Q
  1. ;
  1. EN2 ;
  1. D LBLTYP
  1. D LRBAR
  1. S LRAN=0
  1. F S LRAN=$O(LRLBL(LRAA,LRAN)) Q:LRAN<1 D
  1. . N LRRB,LRLLOC
  1. . S X=LRLBL(LRAA,LRAN),LRSN=+X,LRAD=$P(X,U,2),LRODT=$P(X,U,3),LRRB=$P(X,U,4),LRLLOC=$P(X,U,5),LRACC=$P(X,U,6),LRCE=$P(X,U,7)
  1. . D GO
  1. Q
  1. ;
  1. GO ; From above, LRLABXT, LRPHLIS1
  1. Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
  1. S LRDAT=$TR($$FMTE^XLFDT($P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U),"2MZ"),"@"," ") ; Date/time with "@" --> " "
  1. S LRTJ=$P($G(^LRO(69,LRODT,1,LRSN,0)),U,3)
  1. S LRTJDATA=$G(^LAB(62,+LRTJ,0))
  1. S LRTOP=$P(LRTJDATA,U,3),S1=$P(LRTJDATA,U,4),S2=$P(LRTJDATA,U,5)
  1. I LRTOP="" D
  1. . S LRTOP=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0))
  1. . I LRTOP>0 D
  1. . . S T=$P($G(^LAB(62,+$P(LRTOP,U,2),0)),U,1)
  1. . . S LRTOP=$P($G(^LAB(61,+LRTOP,0)),U,1),LRTOP=T_$S(LRTOP'=T:" "_LRTOP,1:"")
  1. . . S LRTJDATA=$G(^LAB(62,+LRTJ,0)),S1=$P(LRTJDATA,U,4),S2=$P(LRTJDATA,U,5)
  1. S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
  1. S DFN=$P(^LR(LRDFN,0),U,3),LRDPF=$P(^(0),U,2),LRINFW=$P($G(^LR(LRDFN,.091)),U,1)
  1. D PT^LRX Q:LREND
  1. D UID,BARID
  1. K LRTS,LRURG
  1. ;
  1. ; LRXL--use extra labels for the test but if the user is signed into
  1. ; a division where extra labels are defined for that test by Institution
  1. ; then use the Institution Extra Labels instead. If there are multiple
  1. ; test for this accession then accumulate the Extra Labels/Institution
  1. ; Extra Labels for each test.
  1. ;
  1. S LRTVOL=0,LRURG0=9,LRXL=0
  1. S T=0
  1. F S T=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,T)) Q:T<1 D
  1. . S LRTV=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,T,0))
  1. . I LRTV,$P(LRTV,U,2)<49 D
  1. . . S LRVOL=0
  1. . . S:$P(LRTV,U,2)=1 LRURG=1
  1. . . I $P(LRTV,U,2),$P(LRTV,U,2)<LRURG0 S LRURG0=$P(LRTV,U,2)
  1. . . F LRSSP=0:0 S LRSSP=$O(^LAB(60,+LRTV,3,LRSSP)) Q:LRSSP<1 I LRTJ=+^(LRSSP,0) S LRVOL=$P(^(0),U,4),LRTVOL=LRTVOL+LRVOL
  1. . . S LRTS(T)=$P($G(^LAB(60,+LRTV,.1)),U,1)
  1. . . ;
  1. . . ; save off extra labels for this lab test but only use if nothing
  1. . . ; at the institution extra labels
  1. . . N UPDTTEST,LRXLTST
  1. . . S UPDTTEST=1,LRXLTST=0
  1. . . S LRXLTST=+$P($G(^LAB(60,+LRTV,0)),U,15)
  1. . . ; if there is extra labels specified for this user's division and it isn't null
  1. . . ; then overide the VistA instance value for extra labels
  1. . . I $D(^LAB(60,+LRTV,13,"B",DUZ(2))) D
  1. . . . N LRK,LRIXK
  1. . . . S LRK=$O(^LAB(60,+LRTV,13,"B",DUZ(2),0))
  1. . . . I LRK>0 S LRIXK=$P($G(^LAB(60,+LRTV,13,LRK,0)),"^",2)
  1. . . . I LRIXK'="" D
  1. . . . . S LRXL=LRXL+LRIXK
  1. . . . . S UPDTTEST=0
  1. . .; update extra labels with Extra Labels for test if nothing was found for the institution.
  1. . . I UPDTTEST S LRXL=LRXL+LRXLTST
  1. ;
  1. S LRN=$S(+S1=0:1,1:LRTVOL\S1+$S(LRTVOL#S1:1,LRTVOL=0:1,1:0))+LRXL
  1. Q:LRN<1
  1. S LRURGA=$$URGA(LRURG0)
  1. F LRI=1:1:LRN D
  1. . S I=LRI,N=LRN ; Label routines use "I" and "N"
  1. . N LRI,LRN
  1. . S LRPREF=$S(S2="":"",LRTVOL>S2:"LARGE ",1:"SMALL "),LRTVOL=LRTVOL-S1
  1. . D @LRLABEL
  1. D KVA^VADPT
  1. Q
  1. ;
  1. UID ; Set up variables for unique id.
  1. ; Called by above, LRLABLD0, LRPHLIS1
  1. ; LRUID = unique id number of accession
  1. I $G(LRAA),$G(LRAD),$G(LRAN) S LRUID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^") ;Get unique identifier
  1. E S LRUID=""
  1. Q
  1. ;
  1. BARID ; Set up variables for barcoding
  1. ; LRBARID = number to be barcoded on label, based on accession area setup in file #68.
  1. ; If no accession # or UID - sets LRBARID=""
  1. ; Called by LRLABLD0, LRPHLIS1
  1. N LRX
  1. S LRX=$G(^LRO(68,+$G(LRAA),.4)) ; Barcode info from accession file.
  1. S LRBARID=""
  1. I $L($G(LRUID)),$P(LRX,"^",2)="L" S LRBARID=LRUID Q ; Barcode UID
  1. I $G(LRAN)>0,LRBARID="" D
  1. . S LRBARID=LRAN ; Barcode accession number
  1. . I $P(LRX,"^",3) S LRBARID=$$RJ^XLFSTR(LRBARID,$P(LRX,"^",3),"0") ; Pad barcode number
  1. Q
  1. ;
  1. LBLTYP ; Determine label routine to use.
  1. ; Sets LRLABEL to label print routine (label^routine).
  1. ; Called by above, LRLABLD0, LRLABLIO, LRLABXOL, LRLABXT, LRPHLIS1
  1. ;
  1. N LRLBLDEV
  1. ;
  1. ; Default label routine
  1. S LRLABEL="^LRLABEL"_$P($G(^LAB(69.9,1,3)),U,3)
  1. S LRLBLDEV=$O(^LAB(69.9,1,3.6,"B",+$G(IOS),0))
  1. I LRLBLDEV D
  1. . S LRLBLDEV(0)=$G(^LAB(69.9,1,3.6,LRLBLDEV,0))
  1. . ; default accession area for characteristics.
  1. . I '$G(LRAA),$P(LRLBLDEV(0),"^",6) S LRAA=$P(LRLBLDEV(0),"^",6)
  1. ;
  1. ; Site's local accession area label routine.
  1. I $G(LRAA)>0,$L($P(^LRO(68,LRAA,.4),"^",5)) D Q
  1. . S LRLABEL=$P(^LRO(68,LRAA,.4),"^",4,5)
  1. ;
  1. ; This device not defined in file #69.9.
  1. I LRLBLDEV<1 Q
  1. ;
  1. ; Site's designated local label routine.
  1. I $L($P(LRLBLDEV(0),"^",5)) D Q
  1. . S LRLABEL=$P(LRLBLDEV(0),"^",4,5)
  1. ;
  1. ; Intermec 3000/4000 printer
  1. I $P(LRLBLDEV(0),"^",2)=1 D
  1. . I $P(LRLBLDEV(0),"^",3)=1 S LRLABEL="^LRLABELC" Q ; 1x3 label
  1. . I $P(LRLBLDEV(0),"^",3)=2 S LRLABEL="^LRLABELA" Q ; 1x2 label
  1. . I $P(LRLBLDEV(0),"^",3)=3 S LRLABEL="^LRLABELB" Q ; 10 part label
  1. ;
  1. ; Zebra ZPL II compatible printer
  1. I $P(LRLBLDEV(0),"^",2)=2 D
  1. . I $P(LRLBLDEV(0),"^",3)=1 S LRLABEL="^LRLABELG" Q ; 1x3 label
  1. . I $P(LRLBLDEV(0),"^",3)=2 S LRLABEL="^LRLABELD" Q ; 1x2 label
  1. . I $P(LRLBLDEV(0),"^",3)=3 S LRLABEL="^LRLABELE" Q ; 10 part label
  1. ;
  1. Q
  1. ;
  1. ;
  1. PSET ; Setup special printer variables - barcode on/barcode off
  1. ; Called by above, LRLABXOL, LRLABXT, LRPHLIS1
  1. ;
  1. ; Cleanup first
  1. D PKILL^%ZISP
  1. ;
  1. ; Set variables
  1. I IOST(0) D PSET^%ZISP
  1. ;
  1. S LRBAR0=$G(IOBAROFF)
  1. S LRBAR1=$G(IOBARON)
  1. ;
  1. Q
  1. ;
  1. ;
  1. URGA(X) ; Determine urgency abbreviation to print on label
  1. ; Input X = pointer to Urgency #62.05 file
  1. ; Returns Y = urgency abbreviation^display type if turned on
  1. ; Called by above, LRLABELF, LRLABLD0, LRLABLIO, LRPHLIS1
  1. N Y
  1. S Y=""
  1. I '$G(X) Q Y
  1. S X(0)=$G(^LAB(62.05,X,0))
  1. S Y=$P(X(0),"^",7)_"^"_$P(X(0),"^",6)
  1. Q Y
  1. ;
  1. LRTXT(LRTLST,LRLEN) ; Parse test list to print on label.
  1. ; Builds a string of test names concatentated using ";" to the maximum
  1. ; length (LRLEN) specified. Terminates list with "..." if exceeds length
  1. ; specified.
  1. ; Call with
  1. ; LRTLST = array containing name of test to parse
  1. ; LRLEN = length of test string to return (default=35)
  1. ;
  1. ; Returns LRTXT = variable containing concatenated test list.
  1. ;
  1. ; Called from LRLABEL, LRLABEL1, LRLABEL2, LRLABEL3, LRLABEL5, LRLABEL6,
  1. ; LRLABELA, LRLABELB, LRLABELC, LRLABELD, LRLABELE
  1. ;
  1. N I,J,LRTXT,X,Y
  1. I '$G(LRLEN) S LRLEN=35
  1. S J=0,LRTXT=""
  1. F S J=$O(LRTLST(J)) Q:J<1!($L(LRTXT)>LRLEN) D
  1. . S X=LRTLST(J)_$S($O(LRTLST(J)):";",1:"") ; Add ";" if more tests
  1. . S LRTXT=LRTXT_X
  1. I $L(LRTXT)>LRLEN D
  1. . S Y=$L(LRTXT,";")
  1. . F I=Y:-1:1 S X=$P(LRTXT,";",1,I) I $L(X)<(LRLEN-2) Q
  1. . S LRTXT=$E(X,1,(LRLEN-3))_"..."
  1. Q LRTXT
  1. ;
  1. LRBAR ; Setup LRBAR array if barcodes for this accession area
  1. ; Called by above, LRLABLD0, LRLABLIO, LRLABXT, LRPHIS1
  1. I $G(LRAA)<1 Q ; Pointer not valid.
  1. I $P($G(^LRO(68,LRAA,0)),U,15) S LRBAR(LRAA)=+$P($G(^LRO(68,LRAA,0)),U,15)
  1. Q