Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRLABEL4

LRLABEL4.m

Go to the documentation of this file.
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