- LRLABEL4 ; IHS/DIR/FJE - Facit T-410 2X1 ; [ 03/22/2000 1:37 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
- LRLABEL4 ; IHS/DIR/FJE - Facit T-410 2X1 ; [ 03/22/2000 1:37 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
