in reply to Re: Extracting fields
in thread Extracting fields

Apologies Dave, will be more specific.

I am trying to re-format a medical file that describes 39 000 procedures. Each procedure has sub record types categorised as 10, 20, 30, 40 and 50.

The problem is that rather than having all information relating to a procedure being available in one line, the procedure information has been separated into multiple lines (as below). The first row contains the record 10 number and the procedure number (00001), combined as 1000001 with record 10 information following. The next row has the record 20 number and record 20 information etc.

1000001 01.11.199600.00.00001 A1 1 SN Y
2001.11.200400098.0500073.5500083.35
5001.11.1997Professional attendance being an attendance at
5001.11.1997other than consulting rooms, by a general
5001.11.1997practitioner on not more than 1 patient

I have managed to get all the information related to a procedure onto one line using:

my $text = do {local $/;<DATA>};
$text =~ s/\n(?!\d{7})//g; # remove newline if no new record
my %records = map {split /\s+/, $_, 2 } split /\n/, $text;
print Dumper (\%records);

Which gives:

'1000001' => '01.11.199600.00.00001 A1 1 SN Y2001.11.200400098.0500073.5500083.355001.11.1997Professional attendance being an attendance at5001.11.1997other than consulting rooms, by a general5001.11.1997practitioner on not more than 1 patient',

I am now trying the start of each sub record into it's own field.
The position of sub group data is not consistent between procedure records. Also, the sub records (20-50) are not represented in all procedures.

Replies are listed 'Best First'.
Re^3: Extracting fields
by ikegami (Patriarch) on Oct 22, 2004 at 06:45 UTC

    You didn't clearly express what you wanted as your final structure, so I hope this helps

    my %records;
my $record;

while (<DATA>) {
   chomp;

   my $line = $_;
   s/^(\d\d)//;
   my $subrecord_type = $1;

   if ($subrecord_type == 10) {
      s/^(\d+)\s+//;
      my $procedure_num = $1;
      $records{$procedure_num} = $record = [];
   }

   push(@$record, $line);
}

require Data::Dumper;
print(Data::Dumper::Dumper(\%records));

__DATA__
1000001 01.11.199600.00.00001 A1 1 SN Y
2001.11.200400098.0500073.5500083.35
5001.11.1997Professional attendance being an attendance at
5001.11.1997other than consulting rooms, by a general
5001.11.1997practitioner on not more than 1 patient


output
======

$VAR1 = {
          '00001' => [
                       '1000001 01.11.199600.00.00001 A1 1 SN Y',
                       '2001.11.200400098.0500073.5500083.35',
                       '5001.11.1997Professional attendance being an a
+ttendance at',
                       '5001.11.1997other than consulting rooms, by a 
+general',
                       '5001.11.1997practitioner on not more than 1 pa
+tient',
                     ]
        };

    [download]

    === or maybe ===

    my %records;
my $record;

while (<DATA>) {
   chomp;

   my $line = $_;
   s/^(\d\d)//;
   my $subrecord_type = $1;

   if ($subrecord_type == 10) {
      s/^(\d+)\s+//;
      my $procedure_num = $1;
      $records{$procedure_num} = $record = {};

      s/^(\d\d\.\d\d\.\d\d\d\d)//;
      my $date1 = $1;

      s/^(\d\d\.\d\d\.\d\d\d\d)//;
      my $date2 = $1;

      my (
         $unknown1,
         $unknown2,
         $unknown3,
         $unknown4,
         $unknown5,
      ) = split(/\s+/, $_);

      %$record = (
         date1    => $date1,
         date2    => $date2,
         unknown1 => $unknown1,
         unknown2 => $unknown2,
         unknown3 => $unknown3,
         unknown4 => $unknown4,
         unknown5 => $unknown5,
         20       => [],
         30       => [],
         40       => [],
         50       => [],
      );

      next;
   }

   if ($subrecord_type == 20) {
      s/^(\d\d\.\d\d\.\d\d\d\d)//;
      my $date = $1;

      my (
         $unknown1,
         $unknown2,
         $unknown3,
         $unknown4,
      ) = split(/\./, $_);

      push(@{$record->{20}}, {
         date     => $date,
         unknown1 => $unknown1,
         unknown2 => $unknown2,
         unknown3 => $unknown3,
         unknown4 => $unknown4,
      });

      next;
   }

   if ($subrecord_type == 30) {
      # ...
      next;
   }

   if ($subrecord_type == 40) {
      s/^(\d\d\.\d\d\.\d\d\d\d)//;
      my $date = $1;

      push(@{$record->{40}}, {
         date => $date,
         text => $_,
      });

      next;
   }

   if ($subrecord_type == 50) {
      s/^(\d\d\.\d\d\.\d\d\d\d)//;
      my $date = $1;

      push(@{$record->{50}}, {
         date => $date,
         text => $_,
      });

      next;
   }
}

require Data::Dumper;
print(Data::Dumper::Dumper(\%records));

__DATA__
1000001 01.11.199600.00.00001 A1 1 SN Y
2001.11.200400098.0500073.5500083.35
5001.11.1997Professional attendance being an attendance at
5001.11.1997other than consulting rooms, by a general
5001.11.1997practitioner on not more than 1 patient


output
======

$VAR1 = {
          '00001' => {
                       'date1' => '01.11.1996',
                       'date2' => '00.00.0000',
                       'unknown1' => '1'
                       'unknown2' => 'A1',
                       'unknown3' => '1',
                       'unknown4' => 'SN',
                       'unknown5' => 'Y',
                       '20' => [
                                 {
                                   'date' => '01.11.2004',
                                   'unknown1' => '00098'
                                   'unknown2' => '0500073',
                                   'unknown3' => '5500083',
                                   'unknown4' => '35',
                                 }
                               ],
                       '30' => [],
                       '40' => [],
                       '50' => [
                                 {
                                   'date' => '01.11.1997'
                                   'text' => 'Professional attendance 
+being an attendance at',
                                 },
                                 {
                                   'date' => '01.11.1997'
                                   'text' => 'other than consulting ro
+oms, by a general',
                                 },
                                 {
                                   'date' => '01.11.1997'
                                   'text' => 'practitioner on not more
+ than 1 patient',
                                 }
                               ],
                     }
        };

    [download]
[reply]
[d/l]
[select]
Re^3: Extracting fields
by bobf (Monsignor) on Oct 22, 2004 at 06:23 UTC

    TMTOWTDI, but I would approach this problem using your original data set, before you stripped out the newlines. Based on the code you supplied to do that, it appears each block of procedure records begins with 7 consecutive digits, and the lines in between all begin with 4 digits. If that's the case, you can read in the data one line at a time and process each according to the line type (10, 20, etc), using the lines that begin with 7 digits to indicate the beginning of a new procedure record.

    I'm not sure how you need each line processed or what the desired format is of the parsed data, but here's one way to do it: 

    use strict;
use warnings;

use Data::Dumper;

my ( $recordkey, %data );

while( my $line = <DATA> )
{
    chomp $line;

    if( $line =~ m/^(\d{7})/ )
    {
        # process the first line of a procedure record (type 10)
        $recordkey = $1;
        $data{$recordkey}{10} = $line;
    }
    elsif( $line =~ m/^(\d{2})\d{2}\./ )
    {
        # process types 20, 30, 40, 50
        push( @{ $data{$recordkey}{$1} }, $line );
    }
    else
    {
        # unrecognized line!
    }
}

print Dumper( \%data );

__DATA__
1000001 01.11.199600.00.00001 A1 1 SN Y
2001.11.200400098.0500073.5500083.35
5001.11.1997Professional attendance being an attendance at
5001.11.1997other than consulting rooms, by a general
5001.11.1997practitioner on not more than 1 patient
1000002 01.11.199600.00.00001 A1 1 SN Y
2001.11.200400098.0500073.5500083.35
5001.11.1997Professional attendance being an attendance at
5001.11.1997other than consulting rooms, by a general
5001.11.1997practitioner on not more than 1 patient
1000003 01.11.199600.00.00001 A1 1 SN Y
2001.11.200400098.0500073.5500083.35
5001.11.1997Professional attendance being an attendance at
5001.11.1997other than consulting rooms, by a general
5001.11.1997practitioner on not more than 1 patient

OUTPUT

$VAR1 = {
          '1000001' => {
                         '50' => [
                                   '5001.11.1997Professional attendanc
+e being an attendance at',
                                   '5001.11.1997other than consulting 
+rooms, by a general',
                                   '5001.11.1997practitioner on not mo
+re than 1 patient'
                                 ],
                         '10' => '1000001 01.11.199600.00.00001 A1 1 S
+N Y',
                         '20' => [
                                   '2001.11.200400098.0500073.5500083.
+35'
                                 ]
                       },
          '1000002' => {
                         '50' => [
                                   '5001.11.1997Professional attendanc
+e being an attendance at',
                                   '5001.11.1997other than consulting 
+rooms, by a general',
                                   '5001.11.1997practitioner on not mo
+re than 1 patient'
                                 ],
                         '10' => '1000002 01.11.199600.00.00001 A1 1 S
+N Y',
                         '20' => [
                                   '2001.11.200400098.0500073.5500083.
+35'
                                 ]
                       },
etc...

    [download]
[reply]
[d/l]

In Section Seekers of Perl Wisdom