LRLABLD ;DALOI/TGA/JMC - LABELS ON DEMAND ; 5/22/87 20:42
;;5.2;LR;**1018,1030**;NOV 01, 1997
;;5.2;LAB SERVICE;**65,161,218**;Sep 27, 1994
;
ENT ;
; Called by LROE
S U="^"
D PSET
S LRLABLIO=IO
S LRAA=0
F S LRAA=$O(LRLBL(LRAA)) Q:LRAA<1 D EN2
K LRBAR,LRBAR1,LRBAR0,LRBARID,LREND,LRI,LRN,LROK,LRURG,LRURG0,LRURGA
I $D(ZTQUEUED) S ZTREQ="@"
E D PKILL^%ZISP
Q
;
EN2 ;
D LBLTYP
D LRBAR
S LRAN=0
F S LRAN=$O(LRLBL(LRAA,LRAN)) Q:LRAN<1 D
. N LRRB,LRLLOC
. 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)
. D GO
Q
;
GO ; From above, LRLABXT, LRPHLIS1
Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
;
Q:+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))<1 ; IHS/OIT/MKK - LR*5.2*1030
;
S LRDAT=$TR($$FMTE^XLFDT($P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U),"2MZ"),"@"," ") ; Date/time with "@" --> " "
S LRTJ=$P($G(^LRO(69,LRODT,1,LRSN,0)),U,3)
S LRTJDATA=$G(^LAB(62,+LRTJ,0))
S LRTOP=$P(LRTJDATA,U,3),S1=$P(LRTJDATA,U,4),S2=$P(LRTJDATA,U,5)
I LRTOP="" D
. S LRTOP=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0))
. I LRTOP>0 D
. . S T=$P($G(^LAB(62,+$P(LRTOP,U,2),0)),U,1)
. . S LRTOP=$P($G(^LAB(61,+LRTOP,0)),U,1),LRTOP=T_$S(LRTOP'=T:" "_LRTOP,1:"")
. . S LRTJDATA=$G(^LAB(62,+LRTJ,0)),S1=$P(LRTJDATA,U,4),S2=$P(LRTJDATA,U,5)
S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
S DFN=$P(^LR(LRDFN,0),U,3),LRDPF=$P(^(0),U,2),LRINFW=$P($G(^LR(LRDFN,.091)),U,1)
D PT^LRX Q:LREND
D UID,BARID
K LRTS,LRURG
S LRTVOL=0,LRURG0=9,LRXL=0
S T=0
F S T=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,T)) Q:T<1 D
. S LRTV=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,T,0))
. I LRTV,$P(LRTV,U,2)<49 D
. . S LRVOL=0
. . S:$P(LRTV,U,2)=1 LRURG=1
. . I $P(LRTV,U,2),$P(LRTV,U,2)<LRURG0 S LRURG0=$P(LRTV,U,2)
. . 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
. . S LRTS(T)=$P($G(^LAB(60,+LRTV,.1)),U,1)
. . S LRXL=LRXL+$P($G(^LAB(60,+LRTV,0)),U,15)
S LRN=$S(+S1=0:1,1:LRTVOL\S1+$S(LRTVOL#S1:1,LRTVOL=0:1,1:0))+LRXL
Q:LRN<1
S LRURGA=$$URGA(LRURG0)
F LRI=1:1:LRN D
. S I=LRI,N=LRN ; Label routines use "I" and "N"
. N LRI,LRN
. S LRPREF=$S(S2="":"",LRTVOL>S2:"LARGE ",1:"SMALL "),LRTVOL=LRTVOL-S1
. D @LRLABEL
D KVA^VADPT
Q
;
UID ; Set up variables for unique id.
; Called by above, LRLABLD0, LRPHLIS1
; LRUID = unique id number of accession
I $G(LRAA),$G(LRAD),$G(LRAN) S LRUID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^") ;Get unique identifier
E S LRUID=""
Q
;
BARID ; Set up variables for barcoding
; LRBARID = number to be barcoded on label, based on accession area setup in file #68.
; If no accession # or UID - sets LRBARID=""
; Called by LRLABLD0, LRPHLIS1
N LRX
S LRX=$G(^LRO(68,+$G(LRAA),.4)) ; Barcode info from accession file.
S LRBARID=""
I $L($G(LRUID)),$P(LRX,"^",2)="L" S LRBARID=LRUID Q ; Barcode UID
I $G(LRAN)>0,LRBARID="" D
. S LRBARID=LRAN ; Barcode accession number
. I $P(LRX,"^",3) S LRBARID=$$RJ^XLFSTR(LRBARID,$P(LRX,"^",3),"0") ; Pad barcode number
Q
;
LBLTYP ; Determine label routine to use.
; Sets LRLABEL to label print routine (label^routine).
; Called by above, LRLABLD0, LRLABLIO, LRLABXOL, LRLABXT, LRPHLIS1
;
N LRLBLDEV
;
; Default label routine
S LRLABEL="^LRLABEL"_$P($G(^LAB(69.9,1,3)),U,3)
S LRLBLDEV=$O(^LAB(69.9,1,3.6,"B",+$G(IOS),0))
I LRLBLDEV D
. S LRLBLDEV(0)=$G(^LAB(69.9,1,3.6,LRLBLDEV,0))
. ; default accession area for characteristics.
. I '$G(LRAA),$P(LRLBLDEV(0),"^",6) S LRAA=$P(LRLBLDEV(0),"^",6)
;
; Site's local accession area label routine.
I $G(LRAA)>0,$L($P(^LRO(68,LRAA,.4),"^",5)) D Q
. S LRLABEL=$P(^LRO(68,LRAA,.4),"^",4,5)
;
; This device not defined in file #69.9.
I LRLBLDEV<1 Q
;
; Site's designated local label routine.
I $L($P(LRLBLDEV(0),"^",5)) D Q
. S LRLABEL=$P(LRLBLDEV(0),"^",4,5)
;
; Intermec 3000/4000 printer
I $P(LRLBLDEV(0),"^",2)=1 D
. I $P(LRLBLDEV(0),"^",3)=1 S LRLABEL="^LRLABELC" Q ; 1x3 label
. I $P(LRLBLDEV(0),"^",3)=2 S LRLABEL="^LRLABELA" Q ; 1x2 label
. I $P(LRLBLDEV(0),"^",3)=3 S LRLABEL="^LRLABELB" Q ; 10 part label
;
; Zebra ZPL II compatible printer
I $P(LRLBLDEV(0),"^",2)=2 D
. I $P(LRLBLDEV(0),"^",3)=1 S LRLABEL="^LRLABELG" Q ; 1x3 label
. I $P(LRLBLDEV(0),"^",3)=2 S LRLABEL="^LRLABELD" Q ; 1x2 label
. I $P(LRLBLDEV(0),"^",3)=3 S LRLABEL="^LRLABELE" Q ; 10 part label
;
Q
;
;
PSET ; Setup special printer variables - barcode on/barcode off
; Called by above, LRLABXOL, LRLABXT, LRPHLIS1
;
; Cleanup first
D PKILL^%ZISP
;
; Set variables
I IOST(0) D PSET^%ZISP
;
S LRBAR0=$G(IOBAROFF)
S LRBAR1=$G(IOBARON)
;
Q
;
;
URGA(X) ; Determine urgency abbreviation to print on label
; Input X = pointer to Urgency #62.05 file
; Returns Y = urgency abbreviation^display type if turned on
; Called by above, LRLABELF, LRLABLD0, LRLABLIO, LRPHLIS1
N Y
S Y=""
I '$G(X) Q Y
S X(0)=$G(^LAB(62.05,X,0))
S Y=$P(X(0),"^",7)_"^"_$P(X(0),"^",6)
Q Y
;
LRTXT(LRTLST,LRLEN) ; Parse test list to print on label.
; Builds a string of test names concatentated using ";" to the maximum
; length (LRLEN) specified. Terminates list with "..." if exceeds length
; specified.
; Call with
; LRTLST = array containing name of test to parse
; LRLEN = length of test string to return (default=35)
;
; Returns LRTXT = variable containing concatenated test list.
;
; Called from LRLABEL, LRLABEL1, LRLABEL2, LRLABEL3, LRLABEL5, LRLABEL6,
; LRLABELA, LRLABELB, LRLABELC, LRLABELD, LRLABELE
;
N I,J,LRTXT,X,Y
I '$G(LRLEN) S LRLEN=35
S J=0,LRTXT=""
F S J=$O(LRTLST(J)) Q:J<1!($L(LRTXT)>LRLEN) D
. S X=LRTLST(J)_$S($O(LRTLST(J)):";",1:"") ; Add ";" if more tests
. S LRTXT=LRTXT_X
I $L(LRTXT)>LRLEN D
. S Y=$L(LRTXT,";")
. F I=Y:-1:1 S X=$P(LRTXT,";",1,I) I $L(X)<(LRLEN-2) Q
. S LRTXT=$E(X,1,(LRLEN-3))_"..."
Q LRTXT
;
LRBAR ; Setup LRBAR array if barcodes for this accession area
; Called by above, LRLABLD0, LRLABLIO, LRLABXT, LRPHIS1
I $G(LRAA)<1 Q ; Pointer not valid.
I $P($G(^LRO(68,LRAA,0)),U,15) S LRBAR(LRAA)=+$P($G(^LRO(68,LRAA,0)),U,15)
Q
LRLABLD ;DALOI/TGA/JMC - LABELS ON DEMAND ; 5/22/87 20:42
+1 ;;5.2;LR;**1018,1030**;NOV 01, 1997
+2 ;;5.2;LAB SERVICE;**65,161,218**;Sep 27, 1994
+3 ;
ENT ;
+1 ; Called by LROE
+2 SET U="^"
+3 DO PSET
+4 SET LRLABLIO=IO
+5 SET LRAA=0
+6 FOR
SET LRAA=$ORDER(LRLBL(LRAA))
IF LRAA<1
QUIT
DO EN2
+7 KILL LRBAR,LRBAR1,LRBAR0,LRBARID,LREND,LRI,LRN,LROK,LRURG,LRURG0,LRURGA
+8 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+9 IF '$TEST
DO PKILL^%ZISP
+10 QUIT
+11 ;
EN2 ;
+1 DO LBLTYP
+2 DO LRBAR
+3 SET LRAN=0
+4 FOR
SET LRAN=$ORDER(LRLBL(LRAA,LRAN))
IF LRAN<1
QUIT
Begin DoDot:1
+5 NEW LRRB,LRLLOC
+6 SET X=LRLBL(LRAA,LRAN)
SET LRSN=+X
SET LRAD=$PIECE(X,U,2)
SET LRODT=$PIECE(X,U,3)
SET LRRB=$PIECE(X,U,4)
SET LRLLOC=$PIECE(X,U,5)
SET LRACC=$PIECE(X,U,6)
SET LRCE=$PIECE(X,U,7)
+7 DO GO
End DoDot:1
+8 QUIT
+9 ;
GO ; From above, LRLABXT, LRPHLIS1
+1 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
QUIT
+2 ;
+3 ; IHS/OIT/MKK - LR*5.2*1030
IF +$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3))<1
QUIT
+4 ;
+5 ; Date/time with "@" --> " "
SET LRDAT=$TRANSLATE($$FMTE^XLFDT($PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U),"2MZ"),"@"," ")
+6 SET LRTJ=$PIECE($GET(^LRO(69,LRODT,1,LRSN,0)),U,3)
+7 SET LRTJDATA=$GET(^LAB(62,+LRTJ,0))
+8 SET LRTOP=$PIECE(LRTJDATA,U,3)
SET S1=$PIECE(LRTJDATA,U,4)
SET S2=$PIECE(LRTJDATA,U,5)
+9 IF LRTOP=""
Begin DoDot:1
+10 SET LRTOP=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0))
+11 IF LRTOP>0
Begin DoDot:2
+12 SET T=$PIECE($GET(^LAB(62,+$PIECE(LRTOP,U,2),0)),U,1)
+13 SET LRTOP=$PIECE($GET(^LAB(61,+LRTOP,0)),U,1)
SET LRTOP=T_$SELECT(LRTOP'=T:" "_LRTOP,1:"")
+14 SET LRTJDATA=$GET(^LAB(62,+LRTJ,0))
SET S1=$PIECE(LRTJDATA,U,4)
SET S2=$PIECE(LRTJDATA,U,5)
End DoDot:2
End DoDot:1
+15 SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
+16 SET DFN=$PIECE(^LR(LRDFN,0),U,3)
SET LRDPF=$PIECE(^(0),U,2)
SET LRINFW=$PIECE($GET(^LR(LRDFN,.091)),U,1)
+17 DO PT^LRX
IF LREND
QUIT
+18 DO UID
DO BARID
+19 KILL LRTS,LRURG
+20 SET LRTVOL=0
SET LRURG0=9
SET LRXL=0
+21 SET T=0
+22 FOR
SET T=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,T))
IF T<1
QUIT
Begin DoDot:1
+23 SET LRTV=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,T,0))
+24 IF LRTV
IF $PIECE(LRTV,U,2)<49
Begin DoDot:2
+25 SET LRVOL=0
+26 IF $PIECE(LRTV,U,2)=1
SET LRURG=1
+27 IF $PIECE(LRTV,U,2)
IF $PIECE(LRTV,U,2)<LRURG0
SET LRURG0=$PIECE(LRTV,U,2)
+28 FOR LRSSP=0:0
SET LRSSP=$ORDER(^LAB(60,+LRTV,3,LRSSP))
IF LRSSP<1
QUIT
IF LRTJ=+^(LRSSP,0)
SET LRVOL=$PIECE(^(0),U,4)
SET LRTVOL=LRTVOL+LRVOL
+29 SET LRTS(T)=$PIECE($GET(^LAB(60,+LRTV,.1)),U,1)
+30 SET LRXL=LRXL+$PIECE($GET(^LAB(60,+LRTV,0)),U,15)
End DoDot:2
End DoDot:1
+31 SET LRN=$SELECT(+S1=0:1,1:LRTVOL\S1+$SELECT(LRTVOL#S1:1,LRTVOL=0:1,1:0))+LRXL
+32 IF LRN<1
QUIT
+33 SET LRURGA=$$URGA(LRURG0)
+34 FOR LRI=1:1:LRN
Begin DoDot:1
+35 ; Label routines use "I" and "N"
SET I=LRI
SET N=LRN
+36 NEW LRI,LRN
+37 SET LRPREF=$SELECT(S2="":"",LRTVOL>S2:"LARGE ",1:"SMALL ")
SET LRTVOL=LRTVOL-S1
+38 DO @LRLABEL
End DoDot:1
+39 DO KVA^VADPT
+40 QUIT
+41 ;
UID ; Set up variables for unique id.
+1 ; Called by above, LRLABLD0, LRPHLIS1
+2 ; LRUID = unique id number of accession
+3 ;Get unique identifier
IF $GET(LRAA)
IF $GET(LRAD)
IF $GET(LRAN)
SET LRUID=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
+4 IF '$TEST
SET LRUID=""
+5 QUIT
+6 ;
BARID ; Set up variables for barcoding
+1 ; LRBARID = number to be barcoded on label, based on accession area setup in file #68.
+2 ; If no accession # or UID - sets LRBARID=""
+3 ; Called by LRLABLD0, LRPHLIS1
+4 NEW LRX
+5 ; Barcode info from accession file.
SET LRX=$GET(^LRO(68,+$GET(LRAA),.4))
+6 SET LRBARID=""
+7 ; Barcode UID
IF $LENGTH($GET(LRUID))
IF $PIECE(LRX,"^",2)="L"
SET LRBARID=LRUID
QUIT
+8 IF $GET(LRAN)>0
IF LRBARID=""
Begin DoDot:1
+9 ; Barcode accession number
SET LRBARID=LRAN
+10 ; Pad barcode number
IF $PIECE(LRX,"^",3)
SET LRBARID=$$RJ^XLFSTR(LRBARID,$PIECE(LRX,"^",3),"0")
End DoDot:1
+11 QUIT
+12 ;
LBLTYP ; Determine label routine to use.
+1 ; Sets LRLABEL to label print routine (label^routine).
+2 ; Called by above, LRLABLD0, LRLABLIO, LRLABXOL, LRLABXT, LRPHLIS1
+3 ;
+4 NEW LRLBLDEV
+5 ;
+6 ; Default label routine
+7 SET LRLABEL="^LRLABEL"_$PIECE($GET(^LAB(69.9,1,3)),U,3)
+8 SET LRLBLDEV=$ORDER(^LAB(69.9,1,3.6,"B",+$GET(IOS),0))
+9 IF LRLBLDEV
Begin DoDot:1
+10 SET LRLBLDEV(0)=$GET(^LAB(69.9,1,3.6,LRLBLDEV,0))
+11 ; default accession area for characteristics.
+12 IF '$GET(LRAA)
IF $PIECE(LRLBLDEV(0),"^",6)
SET LRAA=$PIECE(LRLBLDEV(0),"^",6)
End DoDot:1
+13 ;
+14 ; Site's local accession area label routine.
+15 IF $GET(LRAA)>0
IF $LENGTH($PIECE(^LRO(68,LRAA,.4),"^",5))
Begin DoDot:1
+16 SET LRLABEL=$PIECE(^LRO(68,LRAA,.4),"^",4,5)
End DoDot:1
QUIT
+17 ;
+18 ; This device not defined in file #69.9.
+19 IF LRLBLDEV<1
QUIT
+20 ;
+21 ; Site's designated local label routine.
+22 IF $LENGTH($PIECE(LRLBLDEV(0),"^",5))
Begin DoDot:1
+23 SET LRLABEL=$PIECE(LRLBLDEV(0),"^",4,5)
End DoDot:1
QUIT
+24 ;
+25 ; Intermec 3000/4000 printer
+26 IF $PIECE(LRLBLDEV(0),"^",2)=1
Begin DoDot:1
+27 ; 1x3 label
IF $PIECE(LRLBLDEV(0),"^",3)=1
SET LRLABEL="^LRLABELC"
QUIT
+28 ; 1x2 label
IF $PIECE(LRLBLDEV(0),"^",3)=2
SET LRLABEL="^LRLABELA"
QUIT
+29 ; 10 part label
IF $PIECE(LRLBLDEV(0),"^",3)=3
SET LRLABEL="^LRLABELB"
QUIT
End DoDot:1
+30 ;
+31 ; Zebra ZPL II compatible printer
+32 IF $PIECE(LRLBLDEV(0),"^",2)=2
Begin DoDot:1
+33 ; 1x3 label
IF $PIECE(LRLBLDEV(0),"^",3)=1
SET LRLABEL="^LRLABELG"
QUIT
+34 ; 1x2 label
IF $PIECE(LRLBLDEV(0),"^",3)=2
SET LRLABEL="^LRLABELD"
QUIT
+35 ; 10 part label
IF $PIECE(LRLBLDEV(0),"^",3)=3
SET LRLABEL="^LRLABELE"
QUIT
End DoDot:1
+36 ;
+37 QUIT
+38 ;
+39 ;
PSET ; Setup special printer variables - barcode on/barcode off
+1 ; Called by above, LRLABXOL, LRLABXT, LRPHLIS1
+2 ;
+3 ; Cleanup first
+4 DO PKILL^%ZISP
+5 ;
+6 ; Set variables
+7 IF IOST(0)
DO PSET^%ZISP
+8 ;
+9 SET LRBAR0=$GET(IOBAROFF)
+10 SET LRBAR1=$GET(IOBARON)
+11 ;
+12 QUIT
+13 ;
+14 ;
URGA(X) ; Determine urgency abbreviation to print on label
+1 ; Input X = pointer to Urgency #62.05 file
+2 ; Returns Y = urgency abbreviation^display type if turned on
+3 ; Called by above, LRLABELF, LRLABLD0, LRLABLIO, LRPHLIS1
+4 NEW Y
+5 SET Y=""
+6 IF '$GET(X)
QUIT Y
+7 SET X(0)=$GET(^LAB(62.05,X,0))
+8 SET Y=$PIECE(X(0),"^",7)_"^"_$PIECE(X(0),"^",6)
+9 QUIT Y
+10 ;
LRTXT(LRTLST,LRLEN) ; Parse test list to print on label.
+1 ; Builds a string of test names concatentated using ";" to the maximum
+2 ; length (LRLEN) specified. Terminates list with "..." if exceeds length
+3 ; specified.
+4 ; Call with
+5 ; LRTLST = array containing name of test to parse
+6 ; LRLEN = length of test string to return (default=35)
+7 ;
+8 ; Returns LRTXT = variable containing concatenated test list.
+9 ;
+10 ; Called from LRLABEL, LRLABEL1, LRLABEL2, LRLABEL3, LRLABEL5, LRLABEL6,
+11 ; LRLABELA, LRLABELB, LRLABELC, LRLABELD, LRLABELE
+12 ;
+13 NEW I,J,LRTXT,X,Y
+14 IF '$GET(LRLEN)
SET LRLEN=35
+15 SET J=0
SET LRTXT=""
+16 FOR
SET J=$ORDER(LRTLST(J))
IF J<1!($LENGTH(LRTXT)>LRLEN)
QUIT
Begin DoDot:1
+17 ; Add ";" if more tests
SET X=LRTLST(J)_$SELECT($ORDER(LRTLST(J)):";",1:"")
+18 SET LRTXT=LRTXT_X
End DoDot:1
+19 IF $LENGTH(LRTXT)>LRLEN
Begin DoDot:1
+20 SET Y=$LENGTH(LRTXT,";")
+21 FOR I=Y:-1:1
SET X=$PIECE(LRTXT,";",1,I)
IF $LENGTH(X)<(LRLEN-2)
QUIT
+22 SET LRTXT=$EXTRACT(X,1,(LRLEN-3))_"..."
End DoDot:1
+23 QUIT LRTXT
+24 ;
LRBAR ; Setup LRBAR array if barcodes for this accession area
+1 ; Called by above, LRLABLD0, LRLABLIO, LRLABXT, LRPHIS1
+2 ; Pointer not valid.
IF $GET(LRAA)<1
QUIT
+3 IF $PIECE($GET(^LRO(68,LRAA,0)),U,15)
SET LRBAR(LRAA)=+$PIECE($GET(^LRO(68,LRAA,0)),U,15)
+4 QUIT
