- LRLABLD ;DALOI/TGA/JMC - LABELS ON DEMAND ; 08/29/16@12:21pm
- ;;5.2;LAB SERVICE;**65,161,218,465**;Sep 27, 1994;Build 25
- ;CHY/RTW/JAH added LR*5.2*465 institution extra labels selection
- 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))
- 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
- ;
- ; LRXL--use extra labels for the test but if the user is signed into
- ; a division where extra labels are defined for that test by Institution
- ; then use the Institution Extra Labels instead. If there are multiple
- ; test for this accession then accumulate the Extra Labels/Institution
- ; Extra Labels for each test.
- ;
- 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)
- . . ;
- . . ; save off extra labels for this lab test but only use if nothing
- . . ; at the institution extra labels
- . . N UPDTTEST,LRXLTST
- . . S UPDTTEST=1,LRXLTST=0
- . . S LRXLTST=+$P($G(^LAB(60,+LRTV,0)),U,15)
- . . ; if there is extra labels specified for this user's division and it isn't null
- . . ; then overide the VistA instance value for extra labels
- . . I $D(^LAB(60,+LRTV,13,"B",DUZ(2))) D
- . . . N LRK,LRIXK
- . . . S LRK=$O(^LAB(60,+LRTV,13,"B",DUZ(2),0))
- . . . I LRK>0 S LRIXK=$P($G(^LAB(60,+LRTV,13,LRK,0)),"^",2)
- . . . I LRIXK'="" D
- . . . . S LRXL=LRXL+LRIXK
- . . . . S UPDTTEST=0
- . .; update extra labels with Extra Labels for test if nothing was found for the institution.
- . . I UPDTTEST S LRXL=LRXL+LRXLTST
- ;
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLABLD 7261 printed Jan 18, 2025@03:16:46 Page 2
- 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
- +2 ;CHY/RTW/JAH added LR*5.2*465 institution extra labels selection
- 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 ; Date/time with "@" --> " "
- SET LRDAT=$TRANSLATE($$FMTE^XLFDT($PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U),"2MZ"),"@"," ")
- +3 SET LRTJ=$PIECE($GET(^LRO(69,LRODT,1,LRSN,0)),U,3)
- +4 SET LRTJDATA=$GET(^LAB(62,+LRTJ,0))
- +5 SET LRTOP=$PIECE(LRTJDATA,U,3)
- SET S1=$PIECE(LRTJDATA,U,4)
- SET S2=$PIECE(LRTJDATA,U,5)
- +6 IF LRTOP=""
- Begin DoDot:1
- +7 SET LRTOP=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0))
- +8 IF LRTOP>0
- Begin DoDot:2
- +9 SET T=$PIECE($GET(^LAB(62,+$PIECE(LRTOP,U,2),0)),U,1)
- +10 SET LRTOP=$PIECE($GET(^LAB(61,+LRTOP,0)),U,1)
- SET LRTOP=T_$SELECT(LRTOP'=T:" "_LRTOP,1:"")
- +11 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
- +12 SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
- +13 SET DFN=$PIECE(^LR(LRDFN,0),U,3)
- SET LRDPF=$PIECE(^(0),U,2)
- SET LRINFW=$PIECE($GET(^LR(LRDFN,.091)),U,1)
- +14 DO PT^LRX
- if LREND
- QUIT
- +15 DO UID
- DO BARID
- +16 KILL LRTS,LRURG
- +17 ;
- +18 ; LRXL--use extra labels for the test but if the user is signed into
- +19 ; a division where extra labels are defined for that test by Institution
- +20 ; then use the Institution Extra Labels instead. If there are multiple
- +21 ; test for this accession then accumulate the Extra Labels/Institution
- +22 ; Extra Labels for each test.
- +23 ;
- +24 SET LRTVOL=0
- SET LRURG0=9
- SET LRXL=0
- +25 SET T=0
- +26 FOR
- SET T=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,T))
- if T<1
- QUIT
- Begin DoDot:1
- +27 SET LRTV=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,T,0))
- +28 IF LRTV
- IF $PIECE(LRTV,U,2)<49
- Begin DoDot:2
- +29 SET LRVOL=0
- +30 if $PIECE(LRTV,U,2)=1
- SET LRURG=1
- +31 IF $PIECE(LRTV,U,2)
- IF $PIECE(LRTV,U,2)<LRURG0
- SET LRURG0=$PIECE(LRTV,U,2)
- +32 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
- +33 SET LRTS(T)=$PIECE($GET(^LAB(60,+LRTV,.1)),U,1)
- +34 ;
- +35 ; save off extra labels for this lab test but only use if nothing
- +36 ; at the institution extra labels
- +37 NEW UPDTTEST,LRXLTST
- +38 SET UPDTTEST=1
- SET LRXLTST=0
- +39 SET LRXLTST=+$PIECE($GET(^LAB(60,+LRTV,0)),U,15)
- +40 ; if there is extra labels specified for this user's division and it isn't null
- +41 ; then overide the VistA instance value for extra labels
- +42 IF $DATA(^LAB(60,+LRTV,13,"B",DUZ(2)))
- Begin DoDot:3
- +43 NEW LRK,LRIXK
- +44 SET LRK=$ORDER(^LAB(60,+LRTV,13,"B",DUZ(2),0))
- +45 IF LRK>0
- SET LRIXK=$PIECE($GET(^LAB(60,+LRTV,13,LRK,0)),"^",2)
- +46 IF LRIXK'=""
- Begin DoDot:4
- +47 SET LRXL=LRXL+LRIXK
- +48 SET UPDTTEST=0
- End DoDot:4
- End DoDot:3
- +49 ; update extra labels with Extra Labels for test if nothing was found for the institution.
- +50 IF UPDTTEST
- SET LRXL=LRXL+LRXLTST
- End DoDot:2
- End DoDot:1
- +51 ;
- +52 SET LRN=$SELECT(+S1=0:1,1:LRTVOL\S1+$SELECT(LRTVOL#S1:1,LRTVOL=0:1,1:0))+LRXL
- +53 if LRN<1
- QUIT
- +54 SET LRURGA=$$URGA(LRURG0)
- +55 FOR LRI=1:1:LRN
- Begin DoDot:1
- +56 ; Label routines use "I" and "N"
- SET I=LRI
- SET N=LRN
- +57 NEW LRI,LRN
- +58 SET LRPREF=$SELECT(S2="":"",LRTVOL>S2:"LARGE ",1:"SMALL ")
- SET LRTVOL=LRTVOL-S1
- +59 DO @LRLABEL
- End DoDot:1
- +60 DO KVA^VADPT
- +61 QUIT
- +62 ;
- 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