BLRLABLD.m

BLRLABLD ; IHS/DIR/FJE - INTERMEC 7421 LABEL PRINT BARCODE/PLAIN 10:16 ; [ 03/18/1999  9:09 AM ]

 ;;5.2;LR;**1006,1007**;MAR 1, 1999

 ;;5.2;LR;**1001**;FEB 1, 1998

 ;

 ;;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

 ;BLRBARD to print a 3 label accession label for accession areas which

 ;have their BAR CODE PRINT field set to YES

 ;BLRLABLD may have to be renamed LRLABEL4

 ;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

BAR ;barcode label..accession number barcoded

 W *2,"R",*3

 W *2,*27,"E4",*24,LRACC,*3

 W *2,!,LRDAT,!,LRTOP,*3

 W *2,!,$E(PNM,1,27),!,HRCN,!,"W:"_$E(LRLLOC,1,7)_" B:"_LRRB,*3

 W *2,!,$E("0000",$L(LRAN),4)_LRAN,*3

 W *2,!,"Order#:",LRCE,!,$E(LRTXT,1,32) W:$L(LRTXT)>32 "..."

 S LRURG0=$G(LRURG0) I LRURG0'="" S BLRURG=$E($P(^LAB(62.05,LRURG0,0),U,1),1,4)

 W *2,!,BLRURG,*3

 W *2,!,LRACC,*3

 W *2,!,LRDAT,*3

 W *2,!,LRACC,*3

 W *2,!,$E(PNM,1,27),!,HRCN,!,"W:"_$E(LRLLOC,1,7)_" B:"_LRRB,*3

 W *2,!,LRDAT,!,$E(LRTXT,1,32) W:$L(LRTXT)>32 "..."

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

 K BLRURG

 Q

PRT ;plain label..no barcode

 W *2,"R",*3

 W *2,*27,"E5",*24,!,LRACC,*3

 W *2,!,LRDAT,!,LRTOP,*3

 S X=$G(DOB) D ^%DT 

 W *2,!,$E(PNM,1,27),!,HRCN,!,"DOB:"_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3),!,"W:"_$E(LRLLOC,1,7)_" B:"_LRRB,*3

 W *2,!,"Order#:",LRCE,!,$E(LRTXT,1,32) W:$L(LRTXT)>32 "..."

 S LRURG0=$G(LRURG0) I LRURG0'="" S BLRURG=$E($P(^LAB(62.05,LRURG0,0),U,1),1,4)

 W *2,!,BLRURG,*3

 W *2,!,LRACC,*3

 W *2,!,LRDAT,*3

 W *2,!,LRACC,*3

 W *2,!,$E(PNM,1,27),!,HRCN,!,"W:"_$E(LRLLOC,1,7)_" B:"_LRRB,*3

 W *2,!,LRDAT,!,$E(LRTXT,1,32) W:$L(LRTXT)>32 "..."

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

 K BLRURG

 Q

BLRLABLD  ; IHS/DIR/FJE - INTERMEC 7421 LABEL PRINT BARCODE/PLAIN 10:16 ; [ 03/18/1999  9:09 AM ]

 +1       ;;5.2;LR;**1006,1007**;MAR 1, 1999

 +2       ;;5.2;LR;**1001**;FEB 1, 1998

 +3       ;

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

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

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

 +7       ;BLRBARD to print a 3 label accession label for accession areas which

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

 +9       ;BLRLABLD may have to be renamed LRLABEL4

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

 +11      ;works with MSM but not DSM

 +12      ;

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_";"

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        QUIT 

BAR       ;barcode label..accession number barcoded

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

 +2        WRITE *2,*27,"E4",*24,LRACC,*3

 +3        WRITE *2,!,LRDAT,!,LRTOP,*3

 +4        WRITE *2,!,$EXTRACT(PNM,1,27),!,HRCN,!,"W:"_$EXTRACT(LRLLOC,1,7)_" B:"_LRRB,*3

 +5        WRITE *2,!,$EXTRACT("0000",$LENGTH(LRAN),4)_LRAN,*3

 +6        WRITE *2,!,"Order#:",LRCE,!,$EXTRACT(LRTXT,1,32)

           IF $LENGTH(LRTXT)>32

               WRITE "..."

 +7        SET LRURG0=$GET(LRURG0)

           IF LRURG0'=""

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

 +8        WRITE *2,!,BLRURG,*3

 +9        WRITE *2,!,LRACC,*3

 +10       WRITE *2,!,LRDAT,*3

 +11       WRITE *2,!,LRACC,*3

 +12       WRITE *2,!,$EXTRACT(PNM,1,27),!,HRCN,!,"W:"_$EXTRACT(LRLLOC,1,7)_" B:"_LRRB,*3

 +13       WRITE *2,!,LRDAT,!,$EXTRACT(LRTXT,1,32)

           IF $LENGTH(LRTXT)>32

               WRITE "..."

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

 +15       KILL BLRURG

 +16       QUIT 

PRT       ;plain label..no barcode

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

 +2        WRITE *2,*27,"E5",*24,!,LRACC,*3

 +3        WRITE *2,!,LRDAT,!,LRTOP,*3

 +4        SET X=$GET(DOB)

           DO ^%DT

 +5        WRITE *2,!,$EXTRACT(PNM,1,27),!,HRCN,!,"DOB:"_$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3),!,"W:"_$EXTRACT(LRLLOC,1,7)_" B:"_LRRB,*3

 +6        WRITE *2,!,"Order#:",LRCE,!,$EXTRACT(LRTXT,1,32)

           IF $LENGTH(LRTXT)>32

               WRITE "..."

 +7        SET LRURG0=$GET(LRURG0)

           IF LRURG0'=""

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

 +8        WRITE *2,!,BLRURG,*3

 +9        WRITE *2,!,LRACC,*3

 +10       WRITE *2,!,LRDAT,*3

 +11       WRITE *2,!,LRACC,*3

 +12       WRITE *2,!,$EXTRACT(PNM,1,27),!,HRCN,!,"W:"_$EXTRACT(LRLLOC,1,7)_" B:"_LRRB,*3

 +13       WRITE *2,!,LRDAT,!,$EXTRACT(LRTXT,1,32)

           IF $LENGTH(LRTXT)>32

               WRITE "..."

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

 +15       KILL BLRURG

 +16       QUIT