--- /dev/null
+#! /usr/bin/perl
+
+use warnings;
+use strict;
+
+while (<>) {
+ chomp;
+ my @names = split /;\s*/;
+ @names = sort {length $b <=> length $a } @names;
+ # pick the longest name
+ my $name = $names[0];
+ # strip out long parenthetical statements
+ $name =~ s/[\[\(][^\]\)]{10,}[\]\)]//g;
+ $name =~ s/(\s)\s+/$1/g;
+ print $name,qq(\n);
+}