LRLABELA.m

LRLABELA ;DALOI/JMC - INTERMEC 4100 1X2 LABEL PRINT BARCODE/PLAIN ;10/20/93  10:16

 ;;5.2;LAB SERVICE;**161,218**;Sep 27, 1994

 ;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

 ;

EN ;

 N CR,ETX,J,LRFMT,LRTXT,STX,X

 S LRRB=$G(LRRB)

 ;

 ; Set specific symbology.

 S LRFMT=3+$G(LRBAR(+$G(LRAA)))

 ;

 S LRTXT=$$LRTXT^LRLABLD(.LRTS,$S(LRFMT=4:25,1:32))

 ;

 I LRFMT=3 D PRT

 I LRFMT=4 D BAR

 I LRFMT>4 D BAR1

 ;

 D TERM

 Q

 ;

PRT ;plain label..no barcode

 ;

 D INIT(LRFMT)

 ;

 W STX,LRTXT,CR,ETX

 W STX,"Order #",LRCE,CR,"W:"_$E(LRLLOC,1,9)_" B:"_LRRB,CR,ETX

 W STX,SSN,CR,PNM,CR,LRTOP,CR,LRDAT,CR,LRACC,CR,ETX

 ;

 ; Determine if accession urgency printed normally or in reverse letters

 I $P(LRURGA,"^",2),$L($P(LRURGA,"^")) W STX,$P(LRURGA,"^"),CR,ETX

 E  W STX,$C(10),CR,ETX

 ;

 Q

 ;

BAR ;barcode label..accession number barcoded (old style)

 ;

 D INIT(LRFMT)

 ;

 W STX,LRTXT,CR,ETX

 W STX,LRTOP,CR,"Order #",LRCE,CR,LRACC,CR,LRDAT,CR,SSN,CR,ETX

 W STX,$S($L(LRRB):"B:"_LRRB,1:"W:"_$E(LRLLOC,1,9)),CR,ETX

 W STX,$E(PNM,1,27),CR,ETX

 ;

 ; Determine if accession urgency printed normally or in reverse letters

 I $G(LRURG0)=1 W STX,"STAT",CR,ETX

 E  W STX,LF,CR,ETX

 ;

 W STX,LRBARID,CR,ETX

 ;

 Q

 ;

 ;

BAR1 ; Barcode label (handles multiple barcode symbologies).

 ;

 D INIT(5)

 ;

 W STX,PNM,CR,SSN,CR,"W:"_LRLLOC,$S($L(LRRB):"/"_LRRB,1:""),CR,ETX

 ;

 ; Human-readable ID

 W STX,LRBARID,CR,ETX

 ;

 ; Patient info

 W STX,$S($G(LRINFW)="":LF,1:LRINFW),CR,ETX

 ;

 ; Order date/accession

 W STX,LRDAT,CR,LRACC,CR,ETX

 ;

 ; Order #/specimen top

 W STX,"Order #",LRCE,CR,LRTOP,CR,ETX

 ;

 ; Test list

 W STX,LRTXT,CR,ETX

 ;

 D URGENCY

 ;

 ; Bar code specimen identifier

 W STX

 F J=5:1:7 D

 . I J'=LRFMT W LF,CR Q  ; Skip symbology.

 . W LRBARID,CR

 W ETX

 ;

 Q

 ;

INIT(LRFMT) ; Initialize label

 ; Call with LRFMT = format to access on printer

 ; Called above, LRLABELB, LRLABELC, LRBLJLA1

 ;

 S STX=$C(2),ETX=$C(3),LF=$C(10),CR=$C(13)

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

 ;

 ; Put printer in advanced mode.

 W STX,$C(27),"C",ETX

 W STX,"R",ETX

 W STX,$C(27),"E",LRFMT,$C(24),ETX

 ;

 Q

 ;

TERM ; Terminate and print label

 ; Called above, LRLABELB, LRLABELC, LRBLJLA1

 ;

 W STX,$C(23,15),"S30",$C(12),ETX

 ;

 Q

 ;

URGENCY ; Print urgency based on settings.

 ; Called above, LRLABELB, LRLABELC

 ;

 I $P(LRURGA,"^",2),$L($P(LRURGA,"^")) D  Q

 . ; Reverse field

 . I $P(LRURGA,"^",2)=2 W STX,LF,CR,$P(LRURGA,"^"),CR,ETX Q

 . ; Normal field

 . W STX,$P(LRURGA,"^"),CR,LF,CR,ETX

 ;

 ; No urgency

 W STX,LF,CR,LF,CR,ETX

 ;

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LRLABELA   2755     printed  Feb 18, 2025@23:41:50                                                                                                                                                                                                    Page 2

LRLABELA  ;DALOI/JMC - INTERMEC 4100 1X2 LABEL PRINT BARCODE/PLAIN ;10/20/93  10:16

 +1       ;;5.2;LAB SERVICE;**161,218**;Sep 27, 1994

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

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

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

 +5       ;

EN        ;

 +1        NEW CR,ETX,J,LRFMT,LRTXT,STX,X

 +2        SET LRRB=$GET(LRRB)

 +3       ;

 +4       ; Set specific symbology.

 +5        SET LRFMT=3+$GET(LRBAR(+$GET(LRAA)))

 +6       ;

 +7        SET LRTXT=$$LRTXT^LRLABLD(.LRTS,$SELECT(LRFMT=4:25,1:32))

 +8       ;

 +9        IF LRFMT=3

               DO PRT

 +10       IF LRFMT=4

               DO BAR

 +11       IF LRFMT>4

               DO BAR1

 +12      ;

 +13       DO TERM

 +14       QUIT 

 +15      ;

PRT       ;plain label..no barcode

 +1       ;

 +2        DO INIT(LRFMT)

 +3       ;

 +4        WRITE STX,LRTXT,CR,ETX

 +5        WRITE STX,"Order #",LRCE,CR,"W:"_$EXTRACT(LRLLOC,1,9)_" B:"_LRRB,CR,ETX

 +6        WRITE STX,SSN,CR,PNM,CR,LRTOP,CR,LRDAT,CR,LRACC,CR,ETX

 +7       ;

 +8       ; Determine if accession urgency printed normally or in reverse letters

 +9        IF $PIECE(LRURGA,"^",2)

               IF $LENGTH($PIECE(LRURGA,"^"))

                   WRITE STX,$PIECE(LRURGA,"^"),CR,ETX

 +10      IF '$TEST

               WRITE STX,$CHAR(10),CR,ETX

 +11      ;

 +12       QUIT 

 +13      ;

BAR       ;barcode label..accession number barcoded (old style)

 +1       ;

 +2        DO INIT(LRFMT)

 +3       ;

 +4        WRITE STX,LRTXT,CR,ETX

 +5        WRITE STX,LRTOP,CR,"Order #",LRCE,CR,LRACC,CR,LRDAT,CR,SSN,CR,ETX

 +6        WRITE STX,$SELECT($LENGTH(LRRB):"B:"_LRRB,1:"W:"_$EXTRACT(LRLLOC,1,9)),CR,ETX

 +7        WRITE STX,$EXTRACT(PNM,1,27),CR,ETX

 +8       ;

 +9       ; Determine if accession urgency printed normally or in reverse letters

 +10       IF $GET(LRURG0)=1

               WRITE STX,"STAT",CR,ETX

 +11      IF '$TEST

               WRITE STX,LF,CR,ETX

 +12      ;

 +13       WRITE STX,LRBARID,CR,ETX

 +14      ;

 +15       QUIT 

 +16      ;

 +17      ;

BAR1      ; Barcode label (handles multiple barcode symbologies).

 +1       ;

 +2        DO INIT(5)

 +3       ;

 +4        WRITE STX,PNM,CR,SSN,CR,"W:"_LRLLOC,$SELECT($LENGTH(LRRB):"/"_LRRB,1:""),CR,ETX

 +5       ;

 +6       ; Human-readable ID

 +7        WRITE STX,LRBARID,CR,ETX

 +8       ;

 +9       ; Patient info

 +10       WRITE STX,$SELECT($GET(LRINFW)="":LF,1:LRINFW),CR,ETX

 +11      ;

 +12      ; Order date/accession

 +13       WRITE STX,LRDAT,CR,LRACC,CR,ETX

 +14      ;

 +15      ; Order #/specimen top

 +16       WRITE STX,"Order #",LRCE,CR,LRTOP,CR,ETX

 +17      ;

 +18      ; Test list

 +19       WRITE STX,LRTXT,CR,ETX

 +20      ;

 +21       DO URGENCY

 +22      ;

 +23      ; Bar code specimen identifier

 +24       WRITE STX

 +25       FOR J=5:1:7

               Begin DoDot:1

 +26      ; Skip symbology.

                   IF J'=LRFMT

                       WRITE LF,CR

                       QUIT 

 +27               WRITE LRBARID,CR

               End DoDot:1

 +28       WRITE ETX

 +29      ;

 +30       QUIT 

 +31      ;

INIT(LRFMT) ; Initialize label

 +1       ; Call with LRFMT = format to access on printer

 +2       ; Called above, LRLABELB, LRLABELC, LRBLJLA1

 +3       ;

 +4        SET STX=$CHAR(2)

           SET ETX=$CHAR(3)

           SET LF=$CHAR(10)

           SET CR=$CHAR(13)

 +5        SET X=0

           XECUTE ^%ZOSF("RM")

 +6       ;

 +7       ; Put printer in advanced mode.

 +8        WRITE STX,$CHAR(27),"C",ETX

 +9        WRITE STX,"R",ETX

 +10       WRITE STX,$CHAR(27),"E",LRFMT,$CHAR(24),ETX

 +11      ;

 +12       QUIT 

 +13      ;

TERM      ; Terminate and print label

 +1       ; Called above, LRLABELB, LRLABELC, LRBLJLA1

 +2       ;

 +3        WRITE STX,$CHAR(23,15),"S30",$CHAR(12),ETX

 +4       ;

 +5        QUIT 

 +6       ;

URGENCY   ; Print urgency based on settings.

 +1       ; Called above, LRLABELB, LRLABELC

 +2       ;

 +3        IF $PIECE(LRURGA,"^",2)

               IF $LENGTH($PIECE(LRURGA,"^"))

                   Begin DoDot:1

 +4       ; Reverse field

 +5                    IF $PIECE(LRURGA,"^",2)=2

                           WRITE STX,LF,CR,$PIECE(LRURGA,"^"),CR,ETX

                           QUIT 

 +6       ; Normal field

 +7                    WRITE STX,$PIECE(LRURGA,"^"),CR,LF,CR,ETX

                   End DoDot:1

                   QUIT 

 +8       ;

 +9       ; No urgency

 +10       WRITE STX,LF,CR,LF,CR,ETX

 +11      ;

 +12       QUIT