Let no call go unanswered!
The following PERL script recursively searches for files in the directory(s) on
the command line (defaults to the current dir), extracts "interesting" DICOM
info from each, and copies them to a new directory structure based upon
Patient Name and ID
|
---- Study date, ID and description
|
----- Series number and description
|
---- Acquisition number and image number

It is still work-in-progress, and you would probably want to customize it for your own site (at the very least, change where the dicom_hdr program lives), but some may find it useful. You may want to play with the dicom_hdr program to see what useful info is in your files.

Tom




#!/usr/bin/perl -w

#work on current dir unless otherwise noted
@ARGV = qw(.) unless @ARGV;

use File::Find;
use File::Copy;
use Cwd;

sub process_file {

#only want files
return unless -f ;

open (DICOM, "/usr/local/AFNI/src/linux_mdk72/dicom_hdr $_ |") or die "Couldn't run the DICOM header program";
#pull out revelant DICOM fields
while (<DICOM>) {
if (/PAT Patient Name/) {
($a,$b,$patname) = split('/+');
chomp $patname;
}
if (/PAT Patient ID/) {
($a,$b,$patID) = split('/+');
chomp $patID;
}

if (/REL Study ID/) {
($a,$b,$studyID) = split('/+');
chomp $studyID;
}
if (/ID Study Date/) {
($a,$b,$studydate) = split('/+');
chomp $studydate;
}
if (/ID Study Description/) {
($a,$b,$studydesc) = split('/+');
chomp $studydesc;
}


if (/ID Series Description/) {
($a,$b,$serdesc) = split('/+');
chomp $serdesc;
}
if (/REL Series Number/) {
($a,$b,$sernum) = split('/+');
chomp $sernum;
}


if (/REL Acquisition Number/) {
($a,$b,$acq) = split('/+');
chomp $acq;
}
if (/REL Image Number/) {
($a,$b,$image) = split('/+');
chomp $image;
}

}
close (DICOM);

#create subject, study, series, image - strip out any spaces and change carets to underscores
$pat = $patID . "-" . $patname;
$pat =~ s/\s//g;
$pat =~ s/\^/_/g;
$study = $studydate . "-" . $studyID . "-" . $studydesc;
$study =~ s/\s//g;
$study =~ s/\^/_/g;
$series = $sernum . "-" . $serdesc;
$series =~ s/\s//g;
$series =~ s/\^/_/g;

#zeropad acq and image by reversing, adding zeros, re-reversing and taking the last chars
$acq =~ s/\s//g;
$acq =~ s/\^/_/g;
$acq = reverse($acq)."0000000000";
$acq = substr(reverse($acq), -5);
$image =~ s/\s//g;
$image =~ s/\^/_/g;
$image = reverse($image)."0000000000";
$image = substr(reverse($image), -6);
$im = $acq . "-" . $image;

if (! -e $parentdir."/".$pat) {
mkdir($parentdir."/".$pat, 0777) || die "couldn't create a directory for $pat :$!\n";
}
if (! -e $parentdir."/".$pat."/".$study) {
mkdir($parentdir."/".$pat."/".$study, 0777) || die "couldn't create a directory for $study :$!\n";
}
if (! -e $parentdir."/".$pat."/".$study."/".$series) {
mkdir($parentdir."/".$pat."/".$study."/".$series, 0777) || die "couldn't create a directory for $series
:$!\n";
}

copy($parentdir."/".$File::Find::name, $parentdir."/".$pat."/".$study."/".$series."/image-".$im.".IMA") || die
"couldn't copy files $!\n";
# print $fname, " ", $pat, " ", $study, " ", $series," ", $im,"\n";
}

$parentdir = cwd();
find(\&process_file, @ARGV);