BLRLABLC.m

BLRLABLC ; IHS/DIR/FJE - INTERMEC 7421 LABEL PRINT BARCODE/PLAIN 10:16 ; 

 ;;5.2;LR;**1006,1007,1009,1018,1022**;September 20, 2007

 ;;5.2;LR;**1006,1007,1009**;Mar 7, 2001

 ;;5.2;LAB SERVICE;;Sep 27, 1994

 ;;V5.1;LAB;;04/11/91 11:06

 ;This routine is used in conjunction with the Intermec program routine

 ;LRBARA to print a two label accession label for accession areas which

 ;have their BAR CODE PRINT field set to YES

 ;LRLABELA may have to be renamed LRLABEL6

 ;The code S X=0 X ^%ZOSF("RM") is needed to replace the U IO:0 which

 ;works with MSM but not DSM

 ;

EN S:$D(ZTQUEUED) ZTREQ="@"

 N I1,J

 S X=0 X ^%ZOSF("RM")

 S:'$L($G(LRRB)) LRRB=""

 S BLRURG=""  ;IHS/DIR TUC/AAB 03/23/98

 S J=0,LRTXT="",FLAG=0 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_";"

 ;

FLAG S:FLAG=0 LRDTXT=LRTXT S:FLAG=1 LRDTXT=".............."

 S LRLPNM=$P(PNM,",",1),LRLPNM=LRLPNM_$S($L(LRLPNM)<18:","_$E($P(PNM,",",2),1),1:"")

 I $D(LRBAR) D BAR Q  ;IHS/MJL 3/18/99

 D PRT K BLRURG

 ;Q:'$D(LRBAR)!('$D(LRBAR($G(LRAA))))

 Q  ;IHS/DIR TUC/AAB 03/23/98

 ;

BAR ;barcode label..accession number barcoded

 ; --- IHS/OIT/MKK -- Total rewrite

 NEW DOBSTR                   ; Date of Birth String

 S DOBSTR="DOB:"

 I $G(DOB)'="" D

 . S X=$G(DOB)  D DT^DILF(,X,.Y)

 . ; I Y>0 S DOBSTR=DOBSTR_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700)  ;IHS/DIR/FJE 10/08/99

 . I Y>0 S DOBSTR=DOBSTR_$$FMTE^XLFDT(Y,"5DZ")

 ;

 S BLRURG=""                  ; URGENCY

 S LRURG0=$G(LRURG0)

 I LRURG0'="" S BLRURG=$E($P(^LAB(62.05,LRURG0,0),U,1),1,4)  ;IHS/DIR TUC/AAB 03/23/98

 ;

 NEW LOCSTR                  ; LOCATION (WARD & BED)

 S LOCSTR="W:"_$E($G(LRLLOC),1,7)

 I $G(LRRB)'="" S LOCSTR=LOCSTR_" B:"_LRRB

 ;

 NEW TESTSTR                  ; Lab Test(s) String

 S TESTSTR=$E($G(LRTXT),1,32)

 I $L($G(LRTXT))>32 S TESTSTR=TESTSTR_"..."

 ;

 ; NOTE: Using the $G function to ensure UNDEFINED variables 

 ;       don't cause problems.

 W *2,"R",*3

 W *2,*27,"E3",*24,!,$G(TESTSTR),*3               ; Lab Test(s)

 W *2,!,$G(LRTOP),*3                              ; Top/Specimen

 W *2,!,"Order#:",$G(LRCE),*3                     ; Order Number

 W *2,!,$G(LRACC),*3                              ; Accession String

 W *2,!,$G(LRDAT),*3                              ; Date

 W *2,!,$G(HRCN),*3                               ; Health Record Number

 W *2,!,LOCSTR,*3                                 ; Location String

 W *2,!,$E($G(PNM),1,27),*3                       ; Patient Name

 W *2,!,$G(BLRURG),*3                             ; Urgency

 W *2,!,$E("0000",$L($G(LRAN)),4)_$G(LRAN),*3     ; Barcoded Accession Number

 W *2,*23,*15,"S30",*12,*3

 ;

 K BLRURG  ;IHS/DIR TUC/AAB 03/23/98

 Q

 ;

PRT ; plain label..no barcode

 ; --- IHS/OIT/MKK -- Total rewrite

 NEW DOBSTR                   ; Date of Birth String

 S DOBSTR="DOB:"

 I $G(DOB)'="" D

 . S X=$G(DOB)  D DT^DILF(,X,.Y)

 . ; I Y>0 S DOBSTR=DOBSTR_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700)  ;IHS/DIR/FJE 10/08/99

 . I Y>0 S DOBSTR=DOBSTR_$$FMTE^XLFDT(Y,"5DZ")

 ;

 S BLRURG=""                  ; URGENCY

 S LRURG0=$G(LRURG0)

 I LRURG0'="" S BLRURG=$E($P(^LAB(62.05,LRURG0,0),U,1),1,4)  ;IHS/DIR TUC/AAB 03/23/98

 ;

 NEW LOCSTR                  ; LOCATION (WARD & BED)

 S LOCSTR="W:"_$E($G(LRLLOC),1,7)

 I $G(LRRB)'="" S LOCSTR=LOCSTR_" B:"_LRRB

 ;

 NEW TESTSTR                  ; Lab Test(s) String

 S TESTSTR=$E($G(LRTXT),1,32)

 I $L($G(LRTXT))>32 S TESTSTR=TESTSTR_"..."

 ;

 ; NOTE: Using the $G function to ensure UNDEFINED variables 

 ;       don't cause problems.

 W *2,"R",*3

 W *2,*27,"E2",*24,!,$G(TESTSTR),*3         ; TEST

 W *2,!,"Order#:",$G(LRCE),*3               ; ORDER #

 W *2,!,$G(LOCSTR),*3                       ; LOCATION (WARD & BED)

 W *2,!,$G(HRCN),*3                         ; HRCN

 W *2,!,$G(DOBSTR),*3                       ; DOB

 W *2,!,$E($G(PNM),1,27),*3                 ; PATIENT NAME

 W *2,!,$G(LRTOP),*3                        ; TOP/SPECIMEN

 W *2,!,$G(LRDAT),*3                        ; DATE

 W *2,!,$G(LRACC),*3                        ; ACCESSION

 W *2,!,$G(BLRURG),*3                       ; URGENCY

 W *2,*23,*15,"S30",*12,*3

 Q

BLRLABLC  ; IHS/DIR/FJE - INTERMEC 7421 LABEL PRINT BARCODE/PLAIN 10:16 ; 

 +1       ;;5.2;LR;**1006,1007,1009,1018,1022**;September 20, 2007

 +2       ;;5.2;LR;**1006,1007,1009**;Mar 7, 2001

 +3       ;;5.2;LAB SERVICE;;Sep 27, 1994

 +4       ;;V5.1;LAB;;04/11/91 11:06

 +5       ;This routine is used in conjunction with the Intermec program routine

 +6       ;LRBARA to print a two label accession label for accession areas which

 +7       ;have their BAR CODE PRINT field set to YES

 +8       ;LRLABELA may have to be renamed LRLABEL6

 +9       ;The code S X=0 X ^%ZOSF("RM") is needed to replace the U IO:0 which

 +10      ;works with MSM but not DSM

 +11      ;

EN         IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +1        NEW I1,J

 +2        SET X=0

           XECUTE ^%ZOSF("RM")

 +3        IF '$LENGTH($GET(LRRB))

               SET LRRB=""

 +4       ;IHS/DIR TUC/AAB 03/23/98

           SET BLRURG=""

 +5        SET J=0

           SET LRTXT=""

           SET FLAG=0

           FOR I1=1:1

               SET J=$ORDER(LRTS(J))

               IF J<1

                   QUIT 

               IF ($LENGTH(LRTXT)+$LENGTH(LRTS(J))'>24)

                   SET LRTXT=LRTXT_LRTS(J)

                   IF $ORDER(LRTS(J))>0

                       SET FLAG=1

                       SET LRTXT=LRTXT_";"

 +6       ;

FLAG       IF FLAG=0

               SET LRDTXT=LRTXT

           IF FLAG=1

               SET LRDTXT=".............."

 +1        SET LRLPNM=$PIECE(PNM,",",1)

           SET LRLPNM=LRLPNM_$SELECT($LENGTH(LRLPNM)<18:","_$EXTRACT($PIECE(PNM,",",2),1),1:"")

 +2       ;IHS/MJL 3/18/99

           IF $DATA(LRBAR)

               DO BAR

               QUIT 

 +3        DO PRT

           KILL BLRURG

 +4       ;Q:'$D(LRBAR)!('$D(LRBAR($G(LRAA))))

 +5       ;IHS/DIR TUC/AAB 03/23/98

           QUIT 

 +6       ;

BAR       ;barcode label..accession number barcoded

 +1       ; --- IHS/OIT/MKK -- Total rewrite

 +2       ; Date of Birth String

           NEW DOBSTR

 +3        SET DOBSTR="DOB:"

 +4        IF $GET(DOB)'=""

               Begin DoDot:1

 +5                SET X=$GET(DOB)

                   DO DT^DILF(,X,.Y)

 +6       ; I Y>0 S DOBSTR=DOBSTR_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700)  ;IHS/DIR/FJE 10/08/99

 +7                IF Y>0

                       SET DOBSTR=DOBSTR_$$FMTE^XLFDT(Y,"5DZ")

               End DoDot:1

 +8       ;

 +9       ; URGENCY

           SET BLRURG=""

 +10       SET LRURG0=$GET(LRURG0)

 +11      ;IHS/DIR TUC/AAB 03/23/98

           IF LRURG0'=""

               SET BLRURG=$EXTRACT($PIECE(^LAB(62.05,LRURG0,0),U,1),1,4)

 +12      ;

 +13      ; LOCATION (WARD & BED)

           NEW LOCSTR

 +14       SET LOCSTR="W:"_$EXTRACT($GET(LRLLOC),1,7)

 +15       IF $GET(LRRB)'=""

               SET LOCSTR=LOCSTR_" B:"_LRRB

 +16      ;

 +17      ; Lab Test(s) String

           NEW TESTSTR

 +18       SET TESTSTR=$EXTRACT($GET(LRTXT),1,32)

 +19       IF $LENGTH($GET(LRTXT))>32

               SET TESTSTR=TESTSTR_"..."

 +20      ;

 +21      ; NOTE: Using the $G function to ensure UNDEFINED variables 

 +22      ;       don't cause problems.

 +23       WRITE *2,"R",*3

 +24      ; Lab Test(s)

           WRITE *2,*27,"E3",*24,!,$GET(TESTSTR),*3

 +25      ; Top/Specimen

           WRITE *2,!,$GET(LRTOP),*3

 +26      ; Order Number

           WRITE *2,!,"Order#:",$GET(LRCE),*3

 +27      ; Accession String

           WRITE *2,!,$GET(LRACC),*3

 +28      ; Date

           WRITE *2,!,$GET(LRDAT),*3

 +29      ; Health Record Number

           WRITE *2,!,$GET(HRCN),*3

 +30      ; Location String

           WRITE *2,!,LOCSTR,*3

 +31      ; Patient Name

           WRITE *2,!,$EXTRACT($GET(PNM),1,27),*3

 +32      ; Urgency

           WRITE *2,!,$GET(BLRURG),*3

 +33      ; Barcoded Accession Number

           WRITE *2,!,$EXTRACT("0000",$LENGTH($GET(LRAN)),4)_$GET(LRAN),*3

 +34       WRITE *2,*23,*15,"S30",*12,*3

 +35      ;

 +36      ;IHS/DIR TUC/AAB 03/23/98

           KILL BLRURG

 +37       QUIT 

 +38      ;

PRT       ; plain label..no barcode

 +1       ; --- IHS/OIT/MKK -- Total rewrite

 +2       ; Date of Birth String

           NEW DOBSTR

 +3        SET DOBSTR="DOB:"

 +4        IF $GET(DOB)'=""

               Begin DoDot:1

 +5                SET X=$GET(DOB)

                   DO DT^DILF(,X,.Y)

 +6       ; I Y>0 S DOBSTR=DOBSTR_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700)  ;IHS/DIR/FJE 10/08/99

 +7                IF Y>0

                       SET DOBSTR=DOBSTR_$$FMTE^XLFDT(Y,"5DZ")

               End DoDot:1

 +8       ;

 +9       ; URGENCY

           SET BLRURG=""

 +10       SET LRURG0=$GET(LRURG0)

 +11      ;IHS/DIR TUC/AAB 03/23/98

           IF LRURG0'=""

               SET BLRURG=$EXTRACT($PIECE(^LAB(62.05,LRURG0,0),U,1),1,4)

 +12      ;

 +13      ; LOCATION (WARD & BED)

           NEW LOCSTR

 +14       SET LOCSTR="W:"_$EXTRACT($GET(LRLLOC),1,7)

 +15       IF $GET(LRRB)'=""

               SET LOCSTR=LOCSTR_" B:"_LRRB

 +16      ;

 +17      ; Lab Test(s) String

           NEW TESTSTR

 +18       SET TESTSTR=$EXTRACT($GET(LRTXT),1,32)

 +19       IF $LENGTH($GET(LRTXT))>32

               SET TESTSTR=TESTSTR_"..."

 +20      ;

 +21      ; NOTE: Using the $G function to ensure UNDEFINED variables 

 +22      ;       don't cause problems.

 +23       WRITE *2,"R",*3

 +24      ; TEST

           WRITE *2,*27,"E2",*24,!,$GET(TESTSTR),*3

 +25      ; ORDER #

           WRITE *2,!,"Order#:",$GET(LRCE),*3

 +26      ; LOCATION (WARD & BED)

           WRITE *2,!,$GET(LOCSTR),*3

 +27      ; HRCN

           WRITE *2,!,$GET(HRCN),*3

 +28      ; DOB

           WRITE *2,!,$GET(DOBSTR),*3

 +29      ; PATIENT NAME

           WRITE *2,!,$EXTRACT($GET(PNM),1,27),*3

 +30      ; TOP/SPECIMEN

           WRITE *2,!,$GET(LRTOP),*3

 +31      ; DATE

           WRITE *2,!,$GET(LRDAT),*3

 +32      ; ACCESSION

           WRITE *2,!,$GET(LRACC),*3

 +33      ; URGENCY

           WRITE *2,!,$GET(BLRURG),*3

 +34       WRITE *2,*23,*15,"S30",*12,*3

 +35       QUIT