- BLRLABLF ; IHS/HQT/MJL - Bar Code label printer Facit T-410 2X1 ;
- ;;5.2;LR;**1010**;MAR 01, 2001
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;MAXM - check digit disabled, variable length=11
- ;CX5 - check digit disabled,no spaces,fixed length=4+1 for check digit
- ;Open tag is called from TERMINAL TYPE file 3.2,terminal type=P-FACIT T410
- ;
- ST ;
- N X,Y
- S IOP=ION,U="^",(BLRURG,BLRACC)="" D ^%ZIS U IO
- S BLRAN=$G(LRAN)
- W "^D2",*13
- W $E($G(PNM),1,28),*13
- W $G(SEX),*13
- W $G(HRCN),*13
- W "DOB:",*13
- S X=$G(DOB) D ^%DT
- W $E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700),*13 ;IHS/DIR/FJE 7/12/99 FIX DOB FOR LOCAL LABEL RTN
- W $E($G(LRLLOC),1,7),*13
- S BLRLEN=$L($P(LRACC," ",3)) I BLRLEN<4 F BLRII=1:1:4-BLRLEN S BLRACC=BLRACC_"0"
- S LRACC=$G(LRACC),BLRACC=BLRACC_$P(LRACC," ",3)
- W BLRACC,*13
- W "CDT:",*13
- S BLRDAT=$TR($G(LRDAT)," ","@") W BLRDAT,*13
- W $G(LRTOP),*13
- W $G(LRCE),*13
- W LRACC,*13
- W "PR:",*13
- I '$D(LRDOC),$G(LRAA),$G(LRAD),$G(LRAN) N LRDOC D
- .S LRDOC=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,8)
- .S:LRDOC LRDOC=$P(^VA(200,LRDOC,0),U)
- W $E($G(LRDOC),1,15),*13 ;FJE UNDEF FIX 6/18/98 ADDED $G OF LRDOC
- S LRURG0=$G(LRURG0) I LRURG0'="" S BLRURG=$E($P(^LAB(62.05,LRURG0,0),U,1),1,2)
- W BLRURG,*13
- S BLRII=0,BLRTST="" F S BLRII=$O(LRTS(BLRII)) Q:BLRII="" S BLRT=$E(LRTS(BLRII),1,7) S BLRTST=BLRTST_BLRT_","
- S BLRTST=$E(BLRTST,1,43) I $E(BLRTST,$L(BLRTST))="," S BLRTST=$E(BLRTST,1,$L(BLRTST)-1)
- W BLRTST,*13
- W "^D3",*13
- K BLRDAT,BLRT,BLRTST,BLRURG,BLRACC,BLRLEN,BLRII
- Q
- ;
- OPEN ;
- U IO
- W "^A22^D45",*13
- W "^A49^D91",*13
- W "^AB00000000^D23",*13
- W "^AB00000000^D24",*13
- W "^AB10001011^D21",*13
- W "^AB00000000^D22",*13
- W "^A3^D97",*13
- W "^A85^D95",*13
- W "^A0^D39",*13
- W "^D57",*13
- W "17,660,206,,24,30,0,1,10",*13
- W "1,220,160,28,1,2",*13 ;NAME
- W "2,587,160,1,1,2",*13 ;SEX
- W "3,220,140,6,1,2",*13 ;HRCN
- W "4,320,140,4,1,2",*13 ;DOB:
- W "5,380,140,10,1,2",*13 ;DOB /FJE 7/12/99
- W "6,520,140,7,1,2",*13 ;LOCATION
- W "7,370,58,5,1,2",*13 ;READABLE ACCESSION NUMBER
- W "7,320,82,5,16,2,,,2,60",*13 ;BAR CODED ACCESSION NUMBER
- W "8,220,37,4,1,1",*13 ;CDT:
- W "9,272,37,16,1,1",*13 ;COLLECTION DATE /FJE 7/12/99
- W "10,450,37,5,1,1",*13 ;COLLECTION SAMPLE
- W "11,520,37,7,1,1",*13 ;ORDER NUMBER
- W "12,220,20,15,1,1",*13 ;ACCESSION NUMBER
- W "13,370,20,3,1,1",*13 ;PR:
- W "14,402,20,15,1,1",*13 ;PROVIDER
- W "15,580,20,2,1,1",*13 ;URGENCY
- W "16,220,0,43,1,1",*13 ;TESTS
- W "^D56",*13
- ;
- Q
- BLRLABLF ; IHS/HQT/MJL - Bar Code label printer Facit T-410 2X1 ;
- +1 ;;5.2;LR;**1010**;MAR 01, 2001
- +2 ;;5.2;LR;;NOV 01, 1997
- +3 ;
- +4 ;MAXM - check digit disabled, variable length=11
- +5 ;CX5 - check digit disabled,no spaces,fixed length=4+1 for check digit
- +6 ;Open tag is called from TERMINAL TYPE file 3.2,terminal type=P-FACIT T410
- +7 ;
- ST ;
- +1 NEW X,Y
- +2 SET IOP=ION
- SET U="^"
- SET (BLRURG,BLRACC)=""
- DO ^%ZIS
- USE IO
- +3 SET BLRAN=$GET(LRAN)
- +4 WRITE "^D2",*13
- +5 WRITE $EXTRACT($GET(PNM),1,28),*13
- +6 WRITE $GET(SEX),*13
- +7 WRITE $GET(HRCN),*13
- +8 WRITE "DOB:",*13
- +9 SET X=$GET(DOB)
- DO ^%DT
- +10 ;IHS/DIR/FJE 7/12/99 FIX DOB FOR LOCAL LABEL RTN
- WRITE $EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_($EXTRACT(Y,1,3)+1700),*13
- +11 WRITE $EXTRACT($GET(LRLLOC),1,7),*13
- +12 SET BLRLEN=$LENGTH($PIECE(LRACC," ",3))
- IF BLRLEN<4
- FOR BLRII=1:1:4-BLRLEN
- SET BLRACC=BLRACC_"0"
- +13 SET LRACC=$GET(LRACC)
- SET BLRACC=BLRACC_$PIECE(LRACC," ",3)
- +14 WRITE BLRACC,*13
- +15 WRITE "CDT:",*13
- +16 SET BLRDAT=$TRANSLATE($GET(LRDAT)," ","@")
- WRITE BLRDAT,*13
- +17 WRITE $GET(LRTOP),*13
- +18 WRITE $GET(LRCE),*13
- +19 WRITE LRACC,*13
- +20 WRITE "PR:",*13
- +21 IF '$DATA(LRDOC)
- IF $GET(LRAA)
- IF $GET(LRAD)
- IF $GET(LRAN)
- NEW LRDOC
- Begin DoDot:1
- +22 SET LRDOC=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,8)
- +23 IF LRDOC
- SET LRDOC=$PIECE(^VA(200,LRDOC,0),U)
- End DoDot:1
- +24 ;FJE UNDEF FIX 6/18/98 ADDED $G OF LRDOC
- WRITE $EXTRACT($GET(LRDOC),1,15),*13
- +25 SET LRURG0=$GET(LRURG0)
- IF LRURG0'=""
- SET BLRURG=$EXTRACT($PIECE(^LAB(62.05,LRURG0,0),U,1),1,2)
- +26 WRITE BLRURG,*13
- +27 SET BLRII=0
- SET BLRTST=""
- FOR
- SET BLRII=$ORDER(LRTS(BLRII))
- IF BLRII=""
- QUIT
- SET BLRT=$EXTRACT(LRTS(BLRII),1,7)
- SET BLRTST=BLRTST_BLRT_","
- +28 SET BLRTST=$EXTRACT(BLRTST,1,43)
- IF $EXTRACT(BLRTST,$LENGTH(BLRTST))=","
- SET BLRTST=$EXTRACT(BLRTST,1,$LENGTH(BLRTST)-1)
- +29 WRITE BLRTST,*13
- +30 WRITE "^D3",*13
- +31 KILL BLRDAT,BLRT,BLRTST,BLRURG,BLRACC,BLRLEN,BLRII
- +32 QUIT
- +33 ;
- OPEN ;
- +1 USE IO
- +2 WRITE "^A22^D45",*13
- +3 WRITE "^A49^D91",*13
- +4 WRITE "^AB00000000^D23",*13
- +5 WRITE "^AB00000000^D24",*13
- +6 WRITE "^AB10001011^D21",*13
- +7 WRITE "^AB00000000^D22",*13
- +8 WRITE "^A3^D97",*13
- +9 WRITE "^A85^D95",*13
- +10 WRITE "^A0^D39",*13
- +11 WRITE "^D57",*13
- +12 WRITE "17,660,206,,24,30,0,1,10",*13
- +13 ;NAME
- WRITE "1,220,160,28,1,2",*13
- +14 ;SEX
- WRITE "2,587,160,1,1,2",*13
- +15 ;HRCN
- WRITE "3,220,140,6,1,2",*13
- +16 ;DOB:
- WRITE "4,320,140,4,1,2",*13
- +17 ;DOB /FJE 7/12/99
- WRITE "5,380,140,10,1,2",*13
- +18 ;LOCATION
- WRITE "6,520,140,7,1,2",*13
- +19 ;READABLE ACCESSION NUMBER
- WRITE "7,370,58,5,1,2",*13
- +20 ;BAR CODED ACCESSION NUMBER
- WRITE "7,320,82,5,16,2,,,2,60",*13
- +21 ;CDT:
- WRITE "8,220,37,4,1,1",*13
- +22 ;COLLECTION DATE /FJE 7/12/99
- WRITE "9,272,37,16,1,1",*13
- +23 ;COLLECTION SAMPLE
- WRITE "10,450,37,5,1,1",*13
- +24 ;ORDER NUMBER
- WRITE "11,520,37,7,1,1",*13
- +25 ;ACCESSION NUMBER
- WRITE "12,220,20,15,1,1",*13
- +26 ;PR:
- WRITE "13,370,20,3,1,1",*13
- +27 ;PROVIDER
- WRITE "14,402,20,15,1,1",*13
- +28 ;URGENCY
- WRITE "15,580,20,2,1,1",*13
- +29 ;TESTS
- WRITE "16,220,0,43,1,1",*13
- +30 WRITE "^D56",*13
- +31 ;
- +32 QUIT
