BLRLABEL ; IHS/DIR/FJE - Facit T-410 2X1 ; [ 10/08/1999 1:52 PM ]
;;5.2;BLR;**1008,1009**;JUN 01, 1999
;
;MAXM - check digit disabled, variable length=11
;CX5 - check digit disabled, no spaces, fixed length=9+1 for check digi
ST ;
N I,X,Y
S IOP=ION,U="^",(BLRZURG,BLRZACC)="" D ^%ZIS U IO
S BLRZAN=$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 Y2K 4 DIG YEAR
W $E($G(LRLLOC),1,7),*13
S BLRZLEN=$L($P(LRACC," ",3)) I BLRZLEN<3 F BLRZII=1:1:3-BLRZLEN S BLRZACC=BLRZACC_"0"
S LRACC=$G(LRACC),BLRZACC=$E($P(LRACC," ",1),1,2)_$P(LRACC," ",2)_BLRZACC_$P(LRACC," ",3)
W BLRZACC,*13
W "CDT:",*13
S BLRZDAT=$TR($G(LRDAT)," ","@") W BLRZDAT,*13
W $G(LRTOP),*13
W $G(LRCE),*13
W LRACC,*13
W "PR:",*13
I '$D(LRDOC),$G(LRAA),$G(LRAD),$G(LRAN) 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
S LRURG0=$G(LRURG0) I LRURG0'="" S BLRZURG=$E($P(^LAB(62.05,LRURG0,0),U,1),1,2)
W BLRZURG,*13
S I=0,BLRZTST="" F S I=$O(LRTS(I)) Q:I="" S BLRZT=$E(LRTS(I),1,7) S BLRZTST=BLRZTST_BLRZT_","
S BLRZTST=$E(BLRZTST,1,43) I $E(BLRZTST,$L(BLRZTST))="," S BLRZTST=$E(BLRZTST,1,$L(BLRZTST)-1)
W BLRZTST,*13
W "^D3",*13
K BLRZDAT,BLRZT,BLRZTST,BLRZURG,BLRZACC,BLRZLEN,BLRZII
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 /IHS/DIR/FJE 6/2/99 4 DIG YR DATE
W "6,520,140,7,1,2",*13 ;LOCATION
W "7,340,58,10,1,2",*13 ;READABLE ACCESSION NUMBER
W "7,250,82,10,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 /IHS/DIR/FJE 14 TO 16 FOR YR
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
BLRLABEL ; IHS/DIR/FJE - Facit T-410 2X1 ; [ 10/08/1999 1:52 PM ]
+1 ;;5.2;BLR;**1008,1009**;JUN 01, 1999
+2 ;
+3 ;MAXM - check digit disabled, variable length=11
+4 ;CX5 - check digit disabled, no spaces, fixed length=9+1 for check digi
ST ;
+1 NEW I,X,Y
+2 SET IOP=ION
SET U="^"
SET (BLRZURG,BLRZACC)=""
DO ^%ZIS
USE IO
+3 SET BLRZAN=$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 Y2K 4 DIG YEAR
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 BLRZLEN=$LENGTH($PIECE(LRACC," ",3))
IF BLRZLEN<3
FOR BLRZII=1:1:3-BLRZLEN
SET BLRZACC=BLRZACC_"0"
+13 SET LRACC=$GET(LRACC)
SET BLRZACC=$EXTRACT($PIECE(LRACC," ",1),1,2)_$PIECE(LRACC," ",2)_BLRZACC_$PIECE(LRACC," ",3)
+14 WRITE BLRZACC,*13
+15 WRITE "CDT:",*13
+16 SET BLRZDAT=$TRANSLATE($GET(LRDAT)," ","@")
WRITE BLRZDAT,*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)
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 WRITE $EXTRACT($GET(LRDOC),1,15),*13
+25 SET LRURG0=$GET(LRURG0)
IF LRURG0'=""
SET BLRZURG=$EXTRACT($PIECE(^LAB(62.05,LRURG0,0),U,1),1,2)
+26 WRITE BLRZURG,*13
+27 SET I=0
SET BLRZTST=""
FOR
SET I=$ORDER(LRTS(I))
IF I=""
QUIT
SET BLRZT=$EXTRACT(LRTS(I),1,7)
SET BLRZTST=BLRZTST_BLRZT_","
+28 SET BLRZTST=$EXTRACT(BLRZTST,1,43)
IF $EXTRACT(BLRZTST,$LENGTH(BLRZTST))=","
SET BLRZTST=$EXTRACT(BLRZTST,1,$LENGTH(BLRZTST)-1)
+29 WRITE BLRZTST,*13
+30 WRITE "^D3",*13
+31 KILL BLRZDAT,BLRZT,BLRZTST,BLRZURG,BLRZACC,BLRZLEN,BLRZII
+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 /IHS/DIR/FJE 6/2/99 4 DIG YR DATE
WRITE "5,380,140,10,1,2",*13
+18 ;LOCATION
WRITE "6,520,140,7,1,2",*13
+19 ;READABLE ACCESSION NUMBER
WRITE "7,340,58,10,1,2",*13
+20 ;BAR CODED ACCESSION NUMBER
WRITE "7,250,82,10,16,2,,,2,60",*13
+21 ;CDT:
WRITE "8,220,37,4,1,1",*13
+22 ;COLLECTION DATE /IHS/DIR/FJE 14 TO 16 FOR YR
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
