# DN1
###################################
# General finch2 library (db info)
###################################

#warn "Using local version of finch2_general.pm\n";

use strict;

package check;
 
sub additive_combo {

    my ($pkg, $dbh, $add) = @_;
    my ($id_add, $desc);

    if (! defined $add->{'A'}){
	$add->{'A'} = 0;
    }

    if (! defined $add->{'B'}){
	$add->{'B'} = 0;
    }

    if (! defined $add->{'C'}){
	$add->{'C'} = 0;
    }

    if (! defined $add->{'D'}){
	$add->{'D'} = 0;
    }

    if (! defined $add->{'E'}){
	$add->{'E'} = 0;
    }

    if (! defined $add->{'F'}){
	$add->{'F'} = 0;
    }

    if (! defined $add->{'G'}){
	$add->{'G'} = 0;
    }
    
    if (! defined $add->{'H'}){
	$add->{'H'} = 0;
    }

    if (! defined $add->{'dGTP'}){
	$add->{'dGTP'} = 0;
    }

    if (! defined $add->{'M'}){
	$add->{'M'} = 0;
    }

    if (! defined $add->{'BDT:dGTP4:1'}){
	$add->{'BDT:dGTP4:1'} = 0;
    }

    if ( ($add->{'A'} == 0) && ($add->{'B'} == 0) && ($add->{'C'} == 0) && ($add->{'D'} == 0) && ($add->{'E'} == 0) && ($add->{'F'} == 0) && ($add->{'G'} == 0) && ($add->{'H'} == 0) && ($add->{'dGTP'} == 0) && ($add->{'M'} == 0) && ($add->{'BDT:dGTP4:1'} == 0) ){
	$id_add = 0;
	$desc = '';
    } else {
    
	my $st = "
select id_additive, description
from additive
where A = $add->{'A'}
and B = $add->{'B'}
and C = $add->{'C'}
and D = $add->{'D'}
and E = $add->{'E'}
and F = $add->{'F'}
and G = $add->{'G'}
and H = $add->{'H'}
and dGTP = $add->{'dGTP'}
and M = $add->{'M'}
and BDT_DGTP_4_1 = $add->{'BDT:dGTP4:1'}
";

	my $sth = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
	$sth->execute || die "ERROR:$DBI::errstr";
	($id_add, $desc) = $sth->fetchrow();


    }
    return ($id_add, $desc);
}






sub projectname_in_db {
    my ($pkg, $dbh, $p) = @_;
    my $st = "select projectname from PROJECT where projectname  = '$p'";
    my $sth = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth->execute || die "ERROR:$DBI::errstr";
    my $check = $sth->fetchrow();
    $sth->finish;
    if ($check){
	return 1;
    } else {
	return 0;
    }
}

sub team_account {
    my ($pkg, $dbh, $w) = @_;
    my $st = "select teamacct from team where teamacct = \'$w\'";
    my $sth = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth->execute || die "ERROR:$DBI::errstr";
    my $curr_acct = $sth->fetchrow();
    $sth->finish;
    if ($curr_acct ne ''){
	return 1;
    } else {
	return 0;
    }
}

sub team_is_ok_2_submit {
    my ($pkg, $dbh, $p, $t) = @_;
    my $st = "
select teamname 
from project_owner
where projectname = \'$p\'
and teamname = \'$t\' 
and owner_type = 4
";
    my $sth = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth->execute || die "ERROR:$DBI::errstr";
    my ($teamname) = $sth->fetchrow();
    $sth->finish;
    if ($teamname){
	return 1;
    } else {
	return 0;
    }
}

sub costcode {
    my ($pkg, $dbh, $c) = @_;
    my $st = "
select ID_COSTCODE from costcode where ID_COSTCODE = \'$c\'
";
    my $sth = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth->execute || die "ERROR:$DBI::errstr";
    my ($cc) = $sth->fetchrow();
    $sth->finish;
    if ($cc){
	return 1;
    } else {
	return 0;
    }
}


#Needs to be added for use by the mapping interface - october 2002
#sub check_for_lock {
#    my ($pkg, $dbh2, $id_team_finserv) = @_;
#    
#    #checks if it can lock the finishing service
#    #if not it finds out who has locked it and roll's back
#    #if no one has it it rollback and exits and gets the lock
#    #the standard way with no NOWAIT.
#    eval { 
#	my $stat = "select * 
#from fin_team_finservice 
#where id_team_finserv = ? 
#for update NOWAIT";
#	my $sth = $dbh2->prepare($stat) || die "ERROR:$DBI::errstr";
#	$sth->bind_param(1,$id_team_finserv);
#	$sth->execute || die "ERROR:$DBI::errstr";
#	$sth->finish;
#	print "checking execution of the eval\n";
#    };
#
#    if ($@=~ /ORA-00054: resource busy and acquire with NOWAIT specified/){
#	print "Error - $@\n";
#	my $stat2 = "select a.osuser,'yes' 
#from v\$session a, v\$locked_object b, all_objects c 
#where a.type = 'USER' 
#and a.sid = b.session_id 
#and b.object_id = c.object_id 
#and c.object_name = 'FIN_TEAM_FINSERVICE'";
#	
#	
#	my $sth2 = $dbh2->prepare($stat2) || die "ERROR:$DBI::errstr";
#	$sth2->execute || die "ERROR:$DBI::errstr";
#	my ($user,$ans) = $sth2->fetchrow();
#	$sth2->finish;
#	$dbh2->rollback();
#	return ($user,$ans);
#    } else {
#	print "in this area\n";
#	$dbh2->rollback();
#	return;
#    }
#
#}


package get;



sub ext_db_info {
    my ($pkg, $dbh, $project) = @_;
    my $st = "
select EXT_DATABASE, EXT_PROJECT
from  PROJECT
where  PROJECTNAME = \'$project\'
";

    my $sth = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth->execute || die "ERROR:$DBI::errstr";
    my ($ext_database, $ext_project) = $sth->fetchrow();
    $sth->finish;
    return ($ext_database, $ext_project);
}


# dn1 added external_primers, finmethod and id_robot to select
sub auto_finserv_info {
    my ($pkg, $dbh, $finserv) = @_;
    my $st = "
select email, fsname, team, external_primers, finmethod, id_robot
from fin_finservice 
where (finmethod = 'Auto' or finmethod = 'Robot')
and id_team_finserv = \'$finserv\'";
    my $sth = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth->execute || die "ERROR:$DBI::errstr";
    my ($email, $fsname, $team, $ext_primers, $finmethod, $id_robot) = $sth->fetchrow();
    $sth->finish;
    return ($email, $fsname, $team, $ext_primers, $finmethod, $id_robot);
}

sub finserv_info {
    my ($pkg, $dbh, $finserv) = @_;
    my $st = "
select team, finmethod
from fin_finservice 
where id_team_finserv = \'$finserv\'";
    my $sth = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth->execute || die "ERROR:$DBI::errstr";
    my ($team, $finmethod) = $sth->fetchrow();
    $sth->finish;
    return ($team, $finmethod);
}



sub teamcostcodes {
    my ($pkg, $teamname, $dbh, $who) =  @_;

    my $statement;
    if ($teamname == '60'){
        $statement = "select id_costcode from costcode where cost_team != 58 and cost_team in (select teamname from team_person_role where id_person in (select id_person from person where email = \'$who\'))";
    } else {
        $statement = "select id_costcode from costcode where COST_TEAM = \'$teamname\'"; 
    }

    my $sthcost = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sthcost->execute || die "ERROR:$DBI::errstr";
    my $C;
    my @cost;
    while($C = $sthcost->fetchrow()){
        push @cost,$C;
    }
    $sthcost->finish();
    return (\@cost);
}

sub today {
    my ($pkg, $dbh) = @_;
    my $statement = "select to_char(sysdate,'dd-Mon-YYYY') from dual";
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my $t = $sth1->fetchrow();
    $sth1->finish();
    return ($t);
}


sub valid_rowcols_for_96 {
    my ($pkg, $dbh) = @_;
    my $statement = "
select id_map, maprow, mapcol
from rowcol_map
where format = 96
order by id_map asc
";

    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($id, $row, $col);
    my %hash;
    my %hash2;
    while ( ($id, $row, $col) = $sth1->fetchrow() ){
	my $rowcol = "$row"."$col";
	$hash{$rowcol} = $id;
	$hash2{$id} = $rowcol;
    }
    $sth1->finish();

    return (\%hash, \%hash2);
}

sub id_scsp2cutdownprotocol {
    
    my ($pkg, $dbh) = @_;
    my $statement = "
select distinct c.id_protocol, c.name
from seqchem_seqprotocol a, seqchemistry b, seqprotocol c
where a.id_seqchem = b.id_seqchem
and a.id_protocol = c.id_protocol
and b.is_finservice = 1
order by 2
";
    
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($id, $name);
    my %hash;
    while ( ($id, $name) = $sth1->fetchrow() ){
	my ($machine) = $name =~ /^(\w+)-/;
	$hash{$id} = $machine;
    }
    $sth1->finish();
    return (\%hash);
}



sub old_id_seqchem_and_suffix {
    my ($pkg, $dbh) = @_;
    my %hash;
    
    my $suffix_seqchem = "
select suffix, id_seqchem
from seqchem
where finservice = 1
";

    my $sth1 = $dbh->prepare($suffix_seqchem) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($suffix, $id_seqchem);
    while ( ($suffix, $id_seqchem) = $sth1->fetchrow) {
	
	# take the '.' off the suffix
	$suffix =~ s/^.//;

	$hash{$suffix} = $id_seqchem;
    }
    return \%hash;
}



sub backwards_compatible_chems {
    my ($pkg, $dbh) = @_;
    my %hash;

    my $old_seqchem_s = "
select id_seqchem
from seqchem
where finservice = 1
and suffix = ?
";
    my $sth2 = $dbh->prepare($old_seqchem_s) || die "ERROR:$DBI::errstr";
    
    my $statement = "
select b.id_scsp, a.suffix
from seqchemistry a, seqchem_seqprotocol b
where a.id_seqchem = b.id_seqchem
and a.is_finservice = 1
order by 1
";
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($id_scsp, $suffix);
    while ( ($id_scsp, $suffix) = $sth1->fetchrow) {
	$sth2->bind_param(1, $suffix);
	$sth2->execute || die "ERROR:$DBI::errstr";
	my $id_seqchem;
	my $count = 0;
	while ($id_seqchem = $sth2->fetchrow){
	    $count++;
	    $hash{$id_scsp} = $id_seqchem;
	}
	if ($count > 1){
	    # There is more than 1 old-style finishing suffix that matches
	    warn "id_scsp $id_scsp suffix $suffix id_seqchem $id_seqchem\n";
	    die "Error (a) trying to determine backwards compatibility of chemistries. Contact Bug!\n";
	}
	if ($count == 0){
	    # There are no old_style finishing suffixes that match
	    warn "id_scsp $id_scsp suffix $suffix id_seqchem $id_seqchem\n";
	    #die "Error (b) trying to determine backwards compatibility of chemistries. Contact Bug!\n";
	    # Nb. This check should be disabled over time as the new chemistry model grows
            $hash{$id_scsp} = '';
	}

    }
    $sth1->finish();
    $sth2->finish();
    return (\%hash);

}




sub valid_chems {
    my ($pkg, $dbh) = @_;
    my $statement = "
select a.id_scsp
from seqchem_seqprotocol a, seqchemistry b
where a.id_seqchem = b.id_seqchem
and b.is_finservice = 1
";

    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($id);
    my %hash;
    while ( ($id) = $sth1->fetchrow() ){
	$hash{$id}++;
    }
    $sth1->finish();
    return (\%hash);
}


sub valid_chems_which_require_custom_oligos {
    my ($pkg, $dbh) = @_;
    my $statement = "
select distinct a.id_scsp
from seqchem_seqprotocol a, seqchemistry b, pt_vector c
where a.id_seqchem = b.id_seqchem
and b.id_ptv = c.id_ptv
and c.primername = 'CUSTOM'
and b.is_finservice = 1
order by 1
";
    
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($id);
    my %hash;
    while ( ($id) = $sth1->fetchrow() ){
	$hash{$id}++;
    }
    $sth1->finish();
    return (\%hash);
}



sub chem2suffix_mapping {
    my ($pkg, $dbh) = @_;
    my $statement = "
select a.id_scsp, b.suffix
from seqchem_seqprotocol a, seqchemistry b
where a.id_seqchem = b.id_seqchem
order by a.id_seqchem
";

    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($id, $su);
    my %hash;
    while ( ($id, $su) = $sth1->fetchrow() ){
	# take the '.' off suffix
	$su =~ s/.//;
	$hash{$id} = $su;
    }
    $sth1->finish();
    return (\%hash);
}



# dn1 new
sub valid_suffix_list {
    my ($pkg, $dbh) = @_;
    my $statement = "
select distinct suffix
from seqchemistry
where is_finservice = 1
order by 1
";
    
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($su);
    my %hash;
    while ( ($su) = $sth1->fetchrow() ){
	# take the '.' off suffix
	$su =~ s/.//;
	$hash{$su} = "1";
    }
    $sth1->finish();
    return (\%hash);
}




sub name_to_id_protocol {
    my ($pkg, $dbh) = @_;
    my $statement = "
select a.id_protocol, a.name 
from seqprotocol a, seqchem_seqprotocol b, seqchemistry c
where a.id_protocol = b.id_protocol
and b.id_seqchem = c.id_seqchem
and c.is_finservice = 1
order by 2, 1
";

    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($id_dict, $description, $new_description, $BDT_GTP_description);
    my %hash;
    while ( ($id_dict, $description) = $sth1->fetchrow() ){
	# eg. protocol -> ABI-F1C (.f1c) : get rid of whitespace onwards
	$description =~ s/\s+.+//g;
	$hash{$description} = $id_dict;
	$new_description = "$description"."DGTP";
	$hash{$new_description} = $id_dict;

#new kva addn
        $BDT_GTP_description = "$description"."BDTdGTP41";
        $hash{$BDT_GTP_description} = $id_dict;
#

    }
    $sth1->finish();
    return (\%hash);
}




sub list_of_protocols {
    my ($pkg, $dbh) = @_;
    my $statement = "
select a.id_protocol, a.name 
from seqprotocol a, seqchem_seqprotocol b, seqchemistry c
where a.id_protocol = b.id_protocol
and b.id_seqchem = c.id_seqchem
and c.is_finservice = 1
order by 2, 1
";

    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($id_dict, $description);
    my %hash;
    while ( ($id_dict, $description) = $sth1->fetchrow() ){
	$hash{$description} = $id_dict;
    }
    $sth1->finish();
    return (\%hash);
}

sub seqchems_wrt_protocol {
    
    my ($pkg, $dbh, $id_protocol) = @_;
    my $statement = "
select distinct seqchemistry.id_seqchem 
from seqchem_seqprotocol, seqchemistry
where seqchem_seqprotocol.id_seqchem = seqchemistry.id_seqchem
and id_protocol = \'$id_protocol\'
and is_finservice = 1
";


    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my @a;
    my $s;
    while ( $s = $sth1->fetchrow() ){
	push @a, "$s";
	push @a, ",";
    }
    pop @a;
    $sth1->finish();
    return (\@a);
}

sub list_of_dyesets {
    my ($pkg, $dbh, $id_seqchems) = @_;
    my $statement = "
select dyeset.id_dyeset, dyeset.name
from seqchemistry, dyeset
where seqchemistry.id_dyeset = dyeset.id_dyeset
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_finservice = 1
";

    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($id_dict, $description);
    my %hash;
    while ( ($id_dict, $description) = $sth1->fetchrow() ){
	$hash{$description} = $id_dict;
    }
    $sth1->finish();
    return (\%hash);
}


sub seqchems_wrt_dyeset {
    my ($pkg, $dbh, $id_dyeset, $id_seqchems) = @_;
    my $statement = "
select distinct id_seqchem
from seqchemistry 
where id_dyeset = \'$id_dyeset\'
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_finservice = 1
";


    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my @a;
    my $s;
    while ( $s = $sth1->fetchrow() ){
	push @a, "$s";
	push @a, ",";
    }
    pop @a;
    $sth1->finish();
    return (\@a);
}

sub list_of_directions {
    my ($pkg, $dbh, $id_seqchems) = @_;
    
    my $statement = "
select distinct pt_vector.is_fwd
from pt_vector, seqchemistry
where seqchemistry.id_ptv = pt_vector.id_ptv
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_finservice = 1
";

   
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my $id;
    my %hash;
    while ( ($id) = $sth1->fetchrow() ){
	my $description;
	if ($id == 1){
	    $description = 'Forward';
	} else {
	    $description = 'Reverse';
	}
	$hash{$description} = $id;
    }
    $sth1->finish();
    return (\%hash);
}


sub seqchems_wrt_direction {
    my ($pkg, $dbh, $direction, $id_seqchems) = @_;
    
    my $statement = "
select distinct id_seqchem
from seqchemistry, pt_vector
where seqchemistry.id_ptv = pt_vector.id_ptv
and pt_vector.is_fwd = \'$direction\'
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_finservice = 1
";


    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my @a;
    my $s;
    while ( $s = $sth1->fetchrow() ){
	push @a, "$s";
	push @a, ",";
    }
    pop @a;
    $sth1->finish();
    return (\@a);
}


sub list_of_terms {
    my ($pkg, $dbh, $id_seqchems) = @_;
    my $statement = "
select distinct seqchemistry.is_primer
from seqchemistry
where seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_finservice = 1
";


    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my $id;
    my %hash;
    while ( ($id) = $sth1->fetchrow() ){
	my $description;
	if ($id == 1){
	    $description = 'Primer';
	} else {
	    $description = 'Terminator';
	}
	$hash{$description} = $id;
    }
    $sth1->finish();
    return (\%hash);
}


sub seqchems_wrt_term {
    my ($pkg, $dbh, $term, $id_seqchems) = @_;
    my $statement = "
select distinct id_seqchem
from seqchemistry 
where seqchemistry.is_primer = \'$term\'
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_finservice = 1
";


    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my @a;
    my $s;
    while ( $s = $sth1->fetchrow() ){
	push @a, "$s";
	push @a, ",";
    }
    pop @a;
    $sth1->finish();
    return (\@a);
}



sub list_of_vectors {
    my ($pkg, $dbh, $id_seqchems) = @_;
    
    my $statement = "
select distinct pt_vector.vectorname
from pt_vector, seqchemistry
where seqchemistry.id_ptv = pt_vector.id_ptv
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_finservice = 1
";


    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my $description;
    my $id = 0;
    my %hash;
    while ( ($description) = $sth1->fetchrow() ){
	$id++;
	$hash{$description} = $id;
    }
    $sth1->finish();
    return (\%hash);
}


sub seqchems_wrt_vector {
    my ($pkg, $dbh, $vectorname, $id_seqchems) = @_;
    
    my $statement = "
select distinct id_seqchem
from seqchemistry, pt_vector
where seqchemistry.id_ptv = pt_vector.id_ptv
and pt_vector.vectorname = \'$vectorname\' 
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_finservice = 1
";


    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my @a;
    my $s;
    while ( $s = $sth1->fetchrow() ){
	push @a, "$s";
	push @a, ",";
    }
    pop @a;
    $sth1->finish();
    return (\@a);
}

sub list_of_primers {
    my ($pkg, $dbh, $id_seqchems) = @_;

    my $statement = "
select distinct pt_vector.primername
from pt_vector, seqchemistry
where seqchemistry.id_ptv = pt_vector.id_ptv
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_finservice = 1
";


    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my $description;
    my $id = 0;
    my %hash;
    while ( ($description) = $sth1->fetchrow() ){
	$id++;
	$hash{$description} = $id;
    }
    $sth1->finish();
    return (\%hash);
}

sub seqchems_wrt_primer {
    my ($pkg, $dbh, $primername, $id_seqchems) = @_;

        my $statement = "
select distinct id_seqchem
from seqchemistry, pt_vector
where seqchemistry.id_ptv = pt_vector.id_ptv
and pt_vector.primername = \'$primername\' 
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_finservice = 1
";


    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my @a;
    my $s;
    while ( $s = $sth1->fetchrow() ){
	push @a, "$s";
	push @a, ",";
    }
    pop @a;
    $sth1->finish();
    return (\@a);
}

sub list_of_pcrs {
    my ($pkg, $dbh, $id_seqchems) = @_;
    my $statement = "
select distinct seqchemistry.is_pcr
from seqchemistry
where seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_finservice = 1
";
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my $id;
    my %hash;
    while ( ($id) = $sth1->fetchrow() ){
	my $description;
	if ($id == 1){
	    $description = 'Yes';
	} else {
	    $description = 'No';
	}
	$hash{$description} = $id;
    }
    $sth1->finish();
    return (\%hash);
}

sub seqchems_wrt_pcr {
    my ($pkg, $dbh, $pcr, $id_seqchems) = @_;
    my $statement = "
select distinct id_seqchem
from seqchemistry 
where seqchemistry.is_pcr = \'$pcr\'
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_finservice = 1
";


    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my @a;
    my $s;
    while ( $s = $sth1->fetchrow() ){
	push @a, "$s";
	push @a, ",";
    }
    pop @a;
    $sth1->finish();
    return (\@a);
}

sub suffix_from_seqchem {
    my ($pkg, $dbh, $id_seqchems) = @_;
    my $statement = "
select distinct suffix
from seqchemistry 
where seqchemistry.id_seqchem =  \'$id_seqchems->[0]\'
and seqchemistry.is_finservice = 1
";


    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my $s = $sth1->fetchrow();
    return ($s);
}

sub id_scsp_wrt_id_seqchem_and_id_protocol {
    my ($pkg, $dbh, $id_seqchems, $id_protocol) = @_;
    my $statement = "
select id_scsp
from seqchem_seqprotocol 
where id_seqchem =  \'$id_seqchems->[0]\'
and id_protocol = \'$id_protocol\'
";


    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my $s = $sth1->fetchrow();
    return ($s);   
}


sub seq_info_from_id_scsp {
    my ($pkg, $dbh, $id) = @_;

    my $statement = "
select seqprotocol.name, seqchem_lookup.old_id, decode(pt_vector.is_fwd, 1, 'Forward', 'Reverse'), decode(seqchemistry.is_primer, 1, 'Primer', 'Terminator'), seqchemistry.suffix, pt_vector.primername, pt_vector.vectorname,dyeset.name, seqchemistry.is_westpav, decode(seqchemistry.is_pcr, 1, 'Yes', 'No') 
from seqchem_seqprotocol, seqprotocol, seqchemistry, dyeset, pt_vector, seqchem_lookup
where seqchemistry.id_ptv = pt_vector.id_ptv
and seqchem_seqprotocol.id_scsp = seqchem_lookup.id_scsp(+)
and seqchem_seqprotocol.id_protocol = seqprotocol.id_protocol
and seqchem_seqprotocol.id_seqchem = seqchemistry.id_seqchem
and seqchemistry.id_dyeset = dyeset.id_dyeset
and seqchem_seqprotocol.id_scsp = ?
and seqchemistry.is_finservice = 1
";


    my $sth = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth->execute($id) || die "ERROR:$DBI::errstr";
    my ($protocol, $seqchem, $dir, $primer, $suffix, $primername, $vectorname, $dyeset, $wp, $pcr) = $sth->fetchrow();
    $sth->finish;

#    if ($dir == 1){
#	$dir = "Forward";
#    } else {
#	$dir = "Reverse";
#    }

#    if ($primer == 1){
#	$primer = "Primer";
#    } else {
#	$primer = "Terminator";
#    }

#    if ($pcr == 1){
#	$pcr = "Yes";
#    } else {
#	$pcr = "No";
#    }

    return($protocol, $seqchem, $dir, $primer, $suffix, $primername, $vectorname, $dyeset, $wp, $pcr);
}


# dn1 new sub
sub DGTP_additives {
    my ($pkg, $dbh) = @_;
    my $st = "select id_additive, description from additive where DGTP = 1";
    my $sth = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth->execute || die "ERROR:$DBI::errstr";
    my ($id_dict, $desc);
    my %hash;
    while ( ($id_dict, $desc) = $sth->fetchrow() ){
	$hash{$id_dict} = $desc;
    }
    return \%hash;
}
# new sub

# kva new sub
sub BDT_DGTP_additives {
    my ($pkg, $dbh) = @_;
    my $st = "select id_additive, description from additive where BDT_DGTP_4_1 = 1";
    my $sth = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth->execute || die "ERROR:$DBI::errstr";
    my ($id_dict, $desc);
    my %hash;
    while ( ($id_dict, $desc) = $sth->fetchrow() ){
	$hash{$id_dict} = $desc;
    }
    return \%hash;
}
# new sub

sub valid_additives {
    my ($pkg, $dbh) = @_;
    my $st = "select id_additive, description from additive";
    my $sth = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth->execute || die "ERROR:$DBI::errstr";
    my ($id_dict, $desc);
    my %hash;
    while ( ($id_dict, $desc) = $sth->fetchrow() ){
	$hash{$id_dict} = $desc;
    }
    return \%hash;
}

sub possible_additives {
    my ($pkg, $dbh) = @_;
    
    # will do for now
    my @additives = ('A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'M', 'dGTP', 'BDT:dGTP4:1');


    return \@additives;
}


sub old_runtypes {

    # Don't think old style runtypes are now
    # relevant. Limit choice for now

    my ($pkg, $dbh) = @_;
#    my $statement = "select id_runtype, description from RUNTYPE";
#    my $sth = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";  
#    $sth->execute || die "ERROR:$DBI::errstr";
    my %hash;
#    my ($id_run, $desc);
#    while ( ($id_run, $desc) = $sth->fetchrow) {
#	$hash{$id_run} = $desc;
#    }
#    $sth->finish;

    #Need a 'Don't care' choice here as well
    $hash{0} = "No Preference";
    
    return (\%hash);
}

sub new_session_id {
    my ($pkg, $dbh) = @_;
    my $statement_id = "select seq_session.nextval from dual";
    my $sth_id = $dbh->prepare($statement_id) || die "ERROR:$DBI::errstr";
    $sth_id->execute || die "ERROR:$DBI::errstr";
    my $session_id = $sth_id->fetchrow();
    $sth_id->finish;
    return ($session_id);
}


sub info_on_project {
    my ($pkg, $dbh, $p) = @_;
    my $st = "
select distinct clone.speciesname, chromosomedict.chromosome
from chromosomedict, clone, clone_project
where clone.chromosome = chromosomedict.id_dict(+)
and clone.clonename = clone_project.clonename
and clone_project.projectname  = '$p'
";
    my $sth = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth->execute || die "ERROR:$DBI::errstr";
    my ($currprojectspecies, $currprojectchr) = $sth->fetchrow();
    $sth->finish;
    if ($currprojectspecies eq ''){ $currprojectspecies = 'Cannot determine'};
    if ($currprojectchr eq ''){ $currprojectchr = 'Cannot determine'};
    return ($currprojectspecies, $currprojectchr);
}

sub id_person_from_person {
    my ($pkg, $dbh, $p) = @_;
    my $st = "select id_person from person where email = '$p' and iscurrent = 1";
    my $sth = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth->execute || die "ERROR:$DBI::errstr";
    my $id_person = $sth->fetchrow();
    $sth->finish;
    return ($id_person);
}

sub id_person2id_role {
    my ($pkg, $dbh, $id_person, $mw, $label_f) = @_;
    my $statement = "select id_role, teamname from team_person_role where id_person = $id_person and iscurrent = 1 and roletype = 'Finishing'";
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($id_role, $teamname);
    my $c = 0;
    my @possibles;
    my %hash;
    while ( ($id_role, $teamname)  = $sth1->fetchrow() ){
	$c++;
	$hash{$teamname} = $id_role; 
    }
    $sth1->finish();
    
    my @possibles = (keys %hash);
    
    if ($c == 0){
	$id_role = 'Not a finishing';
    } elsif ($c > 1){
	##################################################################
	# The user must decide for whom they are working in this session
	##################################################################
	my $choice;
	my $win = $mw->Toplevel;
	$win->focusForce;
	$win->grab;
	$win->configure (-title => "Finishing team selector");
	my $frame = $win->Frame();
	my $label = $frame->Label(-text => "Who are you currently working for ?", -font => $label_f);
	$label->pack(-side=> 'top');
	my $scrllist = $frame->ScrlListbox (
					    -bg => 'lemonchiffon1',
					    -scrollbars => 'e',
					    -label => "You can choose from the following.",
					    -font => $label_f,
					    -height => 5,
					    -width => 30
					    );
	$scrllist->bind ('<Double-Button-1>' => sub { 
	    $choice = $scrllist->get('active');
	    if ($choice eq ''){
		return;
	    }
	    $id_role = $hash{$choice};
	    $teamname = $choice;
	    $win->destroy();
	});

	$scrllist->pack(-side => 'left', -expand => 1, -fill => 'both');
	$scrllist->insert('end', @possibles);
	$frame->pack;
	$frame->waitWindow;
    } else {
	my @array = %hash;
	$id_role = $array[1];
	$teamname = $array[0];
    }

    return ($id_role, $teamname);
}


sub special_id_person2id_role {
    my ($pkg, $dbh, $id_person, $mw, $label_f) = @_;
    my $statement = "select id_role, teamname from team_person_role where id_person = $id_person and iscurrent = 1 and roletype = 'Finishing'";
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($id_role, $teamname);
    my $c = 0;
    my @possibles;
    my %hash;
    while ( ($id_role, $teamname)  = $sth1->fetchrow() ){
	
#Check wether they have a userid and/or suid wrapper, 
#if not the related team is removed from the option list.
	my $newtnm = 'team'.$teamname;
	my $info = (getpwnam($newtnm))[0];
	if ($info){
	    if (-e '/nfs/gels2/gels//capminder/launch/launch_as_'.$newtnm){
		$c++;
		$hash{$teamname} = $id_role; 
	    }
	}
	
    }
    $sth1->finish();
    
    my @possibles = (keys %hash);
    
    if ($c == 0){
	$id_role = 'Not a finishing';
    } elsif ($c > 1){
	##################################################################
	# The user must decide for whom they are working in this session
	##################################################################
	my $choice;
	my $win = $mw->Toplevel;
	$win->focusForce;
	$win->grab;
	$win->configure (-title => "Finishing team selector");
	my $frame = $win->Frame();
	my $label = $frame->Label(-text => "Who are you currently working for ?", -font => $label_f);
	$label->pack(-side=> 'top');
	my $scrllist = $frame->ScrlListbox (
					    -bg => 'lemonchiffon1',
					    -scrollbars => 'e',
					    -label => "You can choose from the following.",
					    -font => $label_f,
					    -height => 5,
					    -width => 30
					    );
	$scrllist->bind ('<Double-Button-1>' => sub { 
	    $choice = $scrllist->get('active');
	    if ($choice eq ''){
		return;
	    }
	    $id_role = $hash{$choice};
	    $teamname = $choice;
	    $win->destroy();
	});

	$scrllist->pack(-side => 'left', -expand => 1, -fill => 'both');
	$scrllist->insert('end', @possibles);
	$frame->pack;
	$frame->waitWindow;
    } else {
	my @array = %hash;
	$id_role = $array[1];
	$teamname = $array[0];
    }

    return ($id_role, $teamname);
}


sub current_team_owner {
    my ($pkg, $dbh, $p) = @_;
    my $st = "
select teamname 
from project_owner
where projectname = \'$p\' 
and iscurrent = 1
";
    my $sth = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth->execute || die "ERROR:$DBI::errstr";
    my ($teamname) = $sth->fetchrow();
    $sth->finish;
    return ($teamname);
}



sub id_team_finserv_options_for_team {
    my ($pkg, $dbh, $t) = @_;
    my @return;

    my $st = "select distinct id_team_finserv
from fin_team_finservice 
where teamname = \'$t\'
";
    my $sth1 = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($id);
    while ( ($id) = $sth1->fetchrow() ){
	push @return, $id;
    }
    $sth1->finish();
    return \@return;
}




sub submission_options_for_team {
    my ($pkg, $dbh, $t) = @_;
    my @return;

    # Tables team_finservice and finservice
    # duplicated for now as we have 2 versions
    # of finch/owl running

    my $st = "select distinct b.fsname, b.id_team_finserv, b.id_robot
from fin_team_finservice a, fin_finservice b 
where a.id_team_finserv = b.id_team_finserv
and a.teamname = \'$t\'
";


#    my $st = "
#select distinct b.fsname, b.id_team_finserv, b.id_robot
#from team_finservice a, finservice b 
#where a.id_team_finserv = b.id_team_finserv
#and a.teamname = \'$t\'
#";


    my $sth1 = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($fsname, $id, $robot);
     while ( ($fsname, $id, $robot) = $sth1->fetchrow() ){
	 my $cat = "$fsname"."_id_"."$id";
	 push @return, $cat;
     }
    $sth1->finish();

    return \@return;
    
}

sub submission_options_for_team_project {
    my ($pkg, $dbh, $t, $p) = @_;
    my @return;

    # Tables team_finservice and finservice
    # duplicated for now as we have 2 versions
    # of finch/owl running

#    my $st = "
#select distinct b.fsname, b.id_team_finserv, b.id_robot
#from team_finservice a, finservice b 
#where a.id_team_finserv = b.id_team_finserv
#and a.teamname = \'$t\'
#";

    my $st = "
select distinct b.fsname, b.id_team_finserv, b.id_robot
from fin_team_finservice a, fin_finservice b 
where a.id_team_finserv = b.id_team_finserv
and a.teamname = \'$t\'
";

    my $sth1 = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($fsname, $id, $robot);
    while ( ($fsname, $id, $robot) = $sth1->fetchrow() ){
	# If this is a finishing service which supplies a robot
	# then we must ensure that the project in question is actually
	# on the robot
	if ($robot) {
	    my $rs = "
select projectname, id_robot, date_unloaded
from robot_project
where projectname = \'$p\'
and id_robot = $robot
";
	    my $sth2 = $dbh->prepare($rs) || die "ERROR:$DBI::errstr";
	    $sth2->execute || die "ERROR:$DBI::errstr";
	    my ($projectname, $id_robot, $date_unloaded);
	    ($projectname, $id_robot, $date_unloaded) = $sth2->fetchrow();
	    $sth2->finish;
	    
	    if ( (defined $projectname) && (! defined $date_unloaded) ){
		my $cat = "$fsname"."_id_"."$id";
		push @return, $cat;
	    }


	} else {
	    my $cat = "$fsname"."_id_"."$id";
	    push @return, $cat;
	}

    }
    $sth1->finish;

    return \@return;
}



# New section
sub spanning_primers {
    my ($pkg, $dbh) = @_;

    # We may be able to tune this further
    my $st = "
select
distinct fr.id_primer
from
finish_batch fb,
finish_request fr,
fin_finservice ffs
where fb.id_fbatch = fr.id_fbatch
and fb.id_team_finserv = ffs.id_team_finserv
and fr.id_frequest > 1293090
and exists (
        select 1
        from frequest_status f
        where f.iscurrent = 1
        and f.status = 1
        and fr.id_frequest = f.id_frequest)
and exists (
        select 1
        from primer_status g
        where g.iscurrent = 1
        and g.status = 4
        and fr.id_primer = g.id_primer)
and ffs.external_primers = 1
order by fr.id_primer
";
    my $sth = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth->execute || die "ERROR:$DBI::errstr";
    my @primers;
    my ($id_primer);
    while (($id_primer)= $sth->fetchrow()){
	push @primers, $id_primer;
    }
    $sth->finish();
    return (\@primers);
}



sub blocks {

    # dn1 $status
    my ($pkg, $dbh, $request_view, $id_role, $ID_TEAM_FINSERV, $primersort, $pstatus) = @_;

    unless ($pstatus){
	$pstatus = 4;
    }

    warn "\t Looking at a current primer_status value of $pstatus\n";
    
####################################
#Only lock the finservice if it isn't a private finisher.
#to be added into the mix at the end of october 2002
#    
#    unless ($request_view =~ /private finisher/){
#	warn "\t Locking the team finishing service.\n";
#	
#	my $lock_statement = "select * from fin_team_finservice where id_team_finserv = ? FOR UPDATE";
#	my $sth_lock;
#	$sth_lock = $dbh->prepare($lock_statement);
#	$sth_lock->bind_param(1,$ID_TEAM_FINSERV);
#	$sth_lock->execute();
#	$sth_lock->finish();
#    }
###################################
    

    # Get a list of DGTP containing additive-combos
    my $DGTP_adds = get->DGTP_additives($dbh);

# kva new
    # Get a list of 4:1 mix BDT:DGTP
    my $BDT_DGTP_adds = get->BDT_DGTP_additives($dbh);
#

    my @datacollector;
    my ($statement1, $statement2, $statement3, $order_by);

    
    #######################################################################
    # We are now also collecting the batchdate (but we do not order on it)
    #######################################################################
    $statement1 = "
select to_char(b.batchdate, 'YYYYMMDDHH24MISS'), b.projectname, e.email, g.name, decode(a.id_runtype, NULL,'NULL',a.id_runtype), a.id_frequest, a.id_primer, a.id_additive
from finish_request a, finish_batch b, team_person_role d, person e, seqchem_seqprotocol f, seqprotocol g, seqchemistry h, primer i
where
a.id_primer = i.id_primer(+)
and a.id_fbatch = b.id_fbatch
and d.id_person = e.id_person
and d.id_role = b.finisher
and a.id_scsp = f.id_scsp
and f.id_protocol = g.id_protocol
and f.id_seqchem = h.id_seqchem
and h.is_finservice = 1
and a.id_frequest >= 680523
";


    if ($request_view =~ /private finisher/){
	$statement2 = "and b.finisher = \'$id_role\'";
    } else { 
	$statement2 = "";
    }
    
    $statement3 = "
and b.id_team_finserv = \'$ID_TEAM_FINSERV\' 
and exists (
	select 1
	from frequest_status f
	where f.iscurrent = 1
	and f.status = 1		
	and a.id_frequest = f.id_frequest)
and 
     (a.id_primer is NULL or exists (
                                     select 1
                                     from primer_status g
                                     where g.iscurrent = 1
                                     and g.status = $pstatus
                                     and a.id_primer = g.id_primer))
";

    if ($primersort eq 'yes'){

	$order_by = "order by e.email, b.projectname, 5, g.name, i.primername, a.platename, a.rowletter, a.colnum, a.iteration, a.id_additive";

    } else {

	$order_by = "order by e.email, b.projectname, 5, g.name, a.platename, a.rowletter, a.colnum, a.iteration, a.id_additive";
    }

    my $statement = "$statement1"."$statement2"."$statement3"." $order_by";


####################################

    my $sth_id = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth_id->execute || die "ERROR:$DBI::errstr";

    # DDD
    my ($batchdate, $projectname, $email, $protocol, $id_runtype, $id_frequest, $id_primer, $id_additive);

    my $protocol_title;
    my %phash;
    my $gtp;

    # DDD
    my $lastblock;
    my $lastdate;
    my %check_date;
    
    my %thash;

    while (($batchdate, $projectname, $email, $protocol, $id_runtype, $id_frequest, $id_primer, $id_additive)= $sth_id->fetchrow()){

	# eg. protocol -> ABI-F1C (.f1c) : get rid of whitespace onwards
	$protocol =~ s/\s+.+//g;

	# Is this request a 'DGTP' ?
	if ( defined $DGTP_adds->{$id_additive} ){
	    $gtp = "DGTP";
	} 
        #kva new
        #is this request a 'BDT DGTP 4:1 MIX'?
        elsif (defined $BDT_DGTP_adds->{$id_additive} ){
            $gtp = "BDTdGTP41";
	} else {
	    $gtp = "";
	}
	
	# The title (used as a key in our hash) changes depending on whether the request
	# is a 'DGTP'
	
	# DDD
	$protocol_title = "$batchdate" . "__" . "$projectname"."__"."$email"."__"."COUNT_UNKNOWN_YET" . "__"."$protocol"."$gtp"."-"."$id_runtype";


	#########################################################
	# Is this the same 'block' but with a different date ?
	# We should store in %phash, the oldest date for a block
	# that we see !
	#########################################################

	# Some projects have '-' within their names; the old pattern-match
	# was hence missing some of the block information off !
	# eg. 20010716111608__tryp1-pcrs__chc__COUNT_UNKNOWN_YET__3700-S1Y-NULL
	my ($p_date, $p_block) = $protocol_title =~ /^(\d+)__(\S+)/;
	#my ($p_date, $p_block) = $protocol_title =~ /^(\d+)__(\w+-\w+-\w+)/;

	
	if ( defined $check_date{$p_block} ) {
	    # check this value isn't smaller
	    if ( $p_date < $check_date{$p_block} ){
		$check_date{$p_block} = $p_date;
	    }
	} else {
	    $check_date{$p_block} = $p_date;
	}

	$protocol_title = "$p_block";
	
	push @{$thash{$protocol_title}}, $id_frequest;
    }	


#    my $capture = Data::Dumper::Dumper(\%thash);
#    warn "------------------------------------------\n";
#    warn "$capture\n";                        
#    warn "------------------------------------------\n";


    # Now attach the correct date to the start of each block
    foreach my $add_date (keys %thash){
	my $protocol_title = "$check_date{$add_date}" . "__" . "$add_date";
	foreach my $frequest ( @{$thash{$add_date}} ){
	    push @{$phash{$protocol_title}}, $frequest;
	}
    }
    
#    my $capture = Data::Dumper::Dumper(\%phash);
#    warn "------------------------------------------\n";
#    warn "$capture\n";                        
#    warn "------------------------------------------\n";
	

    warn "\n";

    my $total_count = 0;
    my $block_count = 0;
    foreach my $ph (sort keys %phash){
	
	$block_count++;

        # Remove the date
        my $title = $ph;
        $title =~ s/^\d+__//;
	my $old_title = $title;

	my $iter;
	my @requests;
	my $count = 0;
	foreach my $freq ( @{$phash{$ph}} ){
	    my @info = ("$freq");
	    $requests[$count] = [@info];
	    $count++;
	    $total_count++;
	}

	$title =~ s/COUNT_UNKNOWN_YET/$count/;

	warn "$check_date{$old_title} is the earliest submisssion date in block $title\n";

	$iter = {
	    "block" => "$title",
	    "contents" => [@requests]
	    };
	push @datacollector, $iter;
    }

    warn "\nBlock count; $block_count\n";

    return ($total_count, \@datacollector);
}





######################################################
# A hack to cope with team 21's 'special' platenaming
######################################################
sub hack_blocks {

    die "This code needs to be synch-d with the new FIFO version of sub blocks\nSee dn1 !\n";

    warn "inside hack_blocks\n";

    # dn1 $status
    my ($pkg, $dbh, $request_view, $id_role, $ID_TEAM_FINSERV, $primersort, $pstatus) = @_;

    unless ($pstatus){
	$pstatus = 4;
    }

    warn "\t Looking at a current primer_status value of $pstatus\n";
   

#######################################
#Only lock the finservice if it isn't a private finisher.
#to be added into the mix at the end of october 2002
#    
#    unless ($request_view =~ /private finisher/){
#	
#	warn "\t Locking the team finishing service.\n";
#	
#	my $lock_statement = "select * from fin_team_finservice where id_team_finserv = ? FOR UPDATE";
#	my $sth_lock;
#	$sth_lock = $dbh->prepare($lock_statement);
#	$sth_lock->bind_param(1,$ID_TEAM_FINSERV);
#	$sth_lock->execute();
#	$sth_lock->finish();
#   }
#
######################################

    # Get a list of DGTP containing additive-combos
    my $DGTP_adds = get->DGTP_additives($dbh);

# kva new
    # Get a list of 4:1 mix BDT:DGTP
    my $BDT_DGTP_adds = get->BDT_DGTP_additives($dbh);
#

    my @datacollector;
    my ($statement1, $statement2, $statement3, $order_by);


    $statement1 = "
select b.projectname, e.email, g.name, decode(a.id_runtype, NULL,'NULL',a.id_runtype), a.id_frequest, a.id_primer, a.id_additive
from finish_request a, finish_batch b, team_person_role d, person e, seqchem_seqprotocol f, seqprotocol g, seqchemistry h, primer i
where
a.id_primer = i.id_primer(+)
and a.id_fbatch = b.id_fbatch
and d.id_person = e.id_person
and d.id_role = b.finisher
and a.id_scsp = f.id_scsp
and f.id_protocol = g.id_protocol
and f.id_seqchem = h.id_seqchem
and h.is_finservice = 1
and a.id_frequest >= 680523
";


    if ($request_view =~ /private finisher/){
	$statement2 = "and b.finisher = \'$id_role\'";
    } else { 
	$statement2 = "";
    }
    
    $statement3 = "
and b.id_team_finserv = \'$ID_TEAM_FINSERV\' 
and exists (
	select 1
	from frequest_status f
	where f.iscurrent = 1
	and f.status = 1		
	and a.id_frequest = f.id_frequest)
and 
     (a.id_primer is NULL or exists (
                                     select 1
                                     from primer_status g
                                     where g.iscurrent = 1
                                     and g.status = $pstatus
                                     and a.id_primer = g.id_primer))
";

    if ($primersort eq 'yes'){
	$order_by = "order by 2, 1, 4, 3, i.primername, a.platename, a.rowletter, a.colnum, a.iteration, a.id_additive";

    } else {
	$order_by = "order by 2, 1, 4, 3, a.platename, a.rowletter, a.colnum, a.iteration, a.id_additive";
    }

    my $statement = "$statement1"."$statement2"."$statement3"." $order_by";

    my $sth_id = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth_id->execute || die "ERROR:$DBI::errstr";
    my ($projectname, $email, $protocol, $id_runtype, $id_frequest, $id_primer, $id_additive);

    my $protocol_title;
    my %phash;
    my $gtp;
    while (($projectname, $email, $protocol, $id_runtype, $id_frequest, $id_primer, $id_additive)= $sth_id->fetchrow()){

	# eg. protocol -> ABI-F1C (.f1c) : get rid of whitespace onwards
	$protocol =~ s/\s+.+//g;

	# Is this request a 'DGTP' ?
	if ( defined $DGTP_adds->{$id_additive} ){
	    $gtp = "DGTP";
	} 
#kva new
        #is this request a 'BDT DGTP 4:1 MIX'?
        elsif (defined $BDT_DGTP_adds->{$id_additive} ){
            $gtp = "BDTdGTP41";
	}else {
	    $gtp = "";
	}
	
	# The title (used as a key in our hash) changes depending on whether the request
	# is a 'DGTP'
	$protocol_title = "$projectname"."__"."$email"."__"."COUNT_UNKNOWN_YET"
	                                           ."__"."$protocol"."$gtp"."-"."$id_runtype";
	push @{$phash{$protocol_title}}, $id_frequest;
	
    }	
    


    # dn1: We need to go from id_frequest to the request-name
    my $get_req = "
select distinct d.platename, d.rowletter, d.colnum, i.suffix,
d.iteration, g.primername 
from finish_request d, primer g, seqchem_seqprotocol h, seqchemistry i 
where d.id_primer = g.id_primer(+)
and d.id_scsp = h.id_scsp
and h.id_seqchem = i.id_seqchem 
and d.id_frequest = ?
";
    my $sth_gr = $dbh->prepare($get_req) || die "ERROR:$DBI::errstr";



    # We now need to recreate our old-style @datacollector in order
    # to fit in with existing code.
    #    array [  hash { 'block' => 'PROJECT2__auto__96__3700-S1Y-NULL',
    #		'contents' => array [
    #                           	array [
    #					id_frequest
    #				],

    my $total_count = 0;
    foreach my $ph (keys %phash){
	my $title;
	my $iter;
	my @requests;
	my $count = 0;
	
	# dn1
	my %temp_hash;
	my @temp_array;

	foreach my $freq ( @{$phash{$ph}} ){

	    

	    # dn1
	    $sth_gr->bind_param(1, $freq);
	    $sth_gr->execute || die "ERROR:$DBI::errstr";
	    my ($platename, $rowletter, $colnum, $suffix, $iteration, $primername) = $sth_gr->fetchrow();
	    my $sample_info = "$platename" . "$rowletter" . "$colnum" . "$suffix" . "$iteration" . "$primername";
	    warn "$freq :: $sample_info\n";
	    if (defined $temp_hash{$sample_info}){
		die "CONTACT BUG ! DUPLICATE SAMPLENAMES DETECTED WHILST COLLECTING BLOCK ENTRIES IN HACK_BLOCKS !\n";
	    } else {
		$temp_hash{$sample_info} = $freq;
		push @temp_array, $sample_info;
	    }
	    



	    my @info = ("$freq");
	    $requests[$count] = [@info];
	    $count++;
	    $total_count++;
	}
	
	$title = $ph;
	$title =~ s/COUNT_UNKNOWN_YET/$count/;



	my @reordered_temp_array;
	###############################################################################
	# Need to re-order @temp_array; The following is taken from David Harper's
	# sortreads.pl !uses a nasty TEMP file and a unix sort !
	###############################################################################
	my $tmpfile = "/tmp/sortreads.$$";
	die "Unable to open temporary file $tmpfile" unless open(TMP, "> $tmpfile");
	warn "Parsing names ...\n\n";
	foreach my $line (@temp_array){

	    my ($stem, $clone, $letter, $digit, $letter2, $digit2, $suffix) = 
		$line =~ /^(LM)(\d+)([A-Z]{1})(\d+)?([a-z]{1})(\d+)\.(\S+)/;
	    $digit = 0 unless $digit;
	    printf TMP "%s %s %s %s %s %s %s\n",
	    $stem, $clone, $letter, $digit, $letter2, $digit2, $suffix;

	}
	close(TMP);
	
	warn "\n\nSorting names ...\n\n";
	
	open(TMP, "sort -b -k2n -k4n -k3 -k5 -k6n $tmpfile |");
	
	while (<TMP>) {
	    my ($stem, $clone, $letter, $digit, $letter2, $digit2, $suffix) = split;
	    print $stem,$clone,$letter;
	    print $digit if $digit;
	    print $letter2,$digit2,'.',$suffix,"\n";

	    my $got;
	    if ($digit){
		$got = "$stem" . "$clone" . "$letter" . "$digit" . "$letter2" . "$digit2" . "." . "$suffix";
	    } else {
		$got = "$stem" . "$clone" . "$letter" . "$letter2" . "$digit2" . "." . "$suffix";
	    }

	    # need to push an array(a) into the array(b) for some daft reason !
	    # we need to go from read_name back to id_frequest

	    my @new_info = ("$temp_hash{$got}");
	    push @reordered_temp_array, [@new_info];
	    
	}

	unlink($tmpfile);
        ###############################################################################
	


	# dn1
	$iter = {
	    "block" => "$title",
	    "contents" => [@reordered_temp_array]
	    };


	push @datacollector, $iter;
    }

    
    # dn1
    $sth_gr->finish();


    return ($total_count, \@datacollector);
}

#############################################################
#############################################################







sub maps {

    my ($pkg, $dbh, $time, $ID_TEAM_FINSERV, $fsname, $who, $mode) = @_;
    
    my @RETURNMAPS = ();
    
    # limited options for the moment
    if ($time ne 'all'){
	$time = 'all';
    }

    # If the finservice.finmethod entry for this ID_TEAM_FINSERV is 'Private'
    # then we must also use mapplate_status.operator to get at the relevant
    # maps. -> for now just look if $fsname matches 'private'.

    my $statement;
    
    # Grab Created-maps these will include robot test pool maps for now
    if (($mode == 5) || ($mode == 7) || ($mode == 10) || ($mode == 11)){

	if ($fsname =~ /private/){
	    $statement = "
select mapplate.ID_MAPPLATE, mapplate.PLATE_FORMAT, mapplate.ID_RUNTYPE, seqprotocol.NAME
from mapplate, mapplate_status, seqprotocol
where mapplate.id_mapplate = mapplate_status.id_mapplate
and mapplate.id_protocol = seqprotocol.id_protocol
and  mapplate_status.status in ($mode)
and mapplate_status.iscurrent = 1
and mapplate.ID_TEAM_FINSERV = \'$ID_TEAM_FINSERV\'
and mapplate_status.operator = \'$who\'
";
	} else {
	    $statement = "
select mapplate.ID_MAPPLATE, mapplate.PLATE_FORMAT, mapplate.ID_RUNTYPE, seqprotocol.NAME
from mapplate, mapplate_status, seqprotocol
where mapplate.id_mapplate = mapplate_status.id_mapplate
and mapplate.id_protocol = seqprotocol.id_protocol
and mapplate_status.status in ($mode)
and mapplate_status.iscurrent = 1
and mapplate.ID_TEAM_FINSERV = \'$ID_TEAM_FINSERV\'
";  
	}
    } else {
	die "Cannot handle any mode other than 10 or 11 at present !\n";
    }


    my $sth = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth->execute || die "ERROR:$DBI::errstr";
    my ($ID_MAPPLATE, $PLATE_FORMAT, $ID_RUNTYPE, $PROTOCOL);
    while (($ID_MAPPLATE, $PLATE_FORMAT, $ID_RUNTYPE, $PROTOCOL) = $sth->fetchrow()){

	# eg. protocol -> ABI-F1C (.f1c) : get rid of whitespace onwards
	$PROTOCOL =~ s/\s+.+//g;

	if ($ID_RUNTYPE eq ''){
	    $ID_RUNTYPE = 'NULL';
	}

	# For each of the maps which we grab from the database; it would be useful to 
	# also have the date of CREATION and the PLATE_FORMAT
	my $statement_d;
	if (($mode == 5) || ($mode == 7) || ($mode == 10) || ($mode == 11)){
	    $statement_d = "
select mapplate_status.STATUSDATE, mapplate.PLATE_FORMAT
from mapplate_status, mapplate 
where mapplate_status.id_mapplate = mapplate.id_mapplate
and mapplate_status.ID_MAPPLATE = \'$ID_MAPPLATE\'
and mapplate_status.STATUS  = \'$mode\'
and mapplate_status.ISCURRENT = 1
"; 
	} else {
	    die "Cannot handle any mode other than 10 or 11 at present !\n";
	}


	my $sth_d = $dbh->prepare($statement_d) || die "ERROR:$DBI::errstr";
	$sth_d->execute || die "ERROR:$DBI::errstr";
	my ($STATUSDATE, $PLATE_FORMAT) = $sth_d->fetchrow();
	$sth_d->finish;

	my $map = "$ID_MAPPLATE" . "_" . "$PROTOCOL" . "-" . "$ID_RUNTYPE" . " " . "  $STATUSDATE". " " . "$PLATE_FORMAT well";
	
	push @RETURNMAPS, $map;
    }
    $sth->finish;

    return(\@RETURNMAPS);
}









sub printmap_struct {
    my ($pkg, $dbh, $map_select_blocks) = @_;

    my @map_select_blocks = @$map_select_blocks;

    my @printmap_struct = (); # what we return
    my $this_block_count;
    my $last_block;
    my $this_block;
    my $from_MAPROW;
    my $from_MAPCOL;
    my @array_array2 = ();


    # Find out the total number of samples on this map
    my $statement_c = "
select count (id_frequest)
from request_map
where ID_MAPPLATE = ?
";
    my $sth_c = $dbh->prepare($statement_c) || die "ERROR:$DBI::errstr";

    # Find out the plate-format
    my $statement_f = "
select PLATE_FORMAT from mapplate
where ID_MAPPLATE = ?
";
    my $sth_f = $dbh->prepare($statement_f) || die "ERROR:$DBI::errstr";
    
    # Go through the individual-entries for a map
    my $statement_e = "
select a.ID_FREQUEST, a.ID_MAP, b.MAPROW, b.MAPCOL
from request_map a, rowcol_map b
where a.id_map = b.id_map
and a.ID_MAPPLATE = ?
order by 2
";
    my $sth_e = $dbh->prepare($statement_e) || die "ERROR:$DBI::errstr";


    # What project is this sample from >?<
    my $statement_p = "
select a.projectname 
from finish_batch a, finish_request b
where a.id_fbatch = b.id_fbatch
and b.id_frequest = ?
";
    my $sth_p = $dbh->prepare($statement_p) || die "ERROR:$DBI::errstr";

    # What finisher is this request from >?<
    my $statement_fin = "
select a.email
from person a, team_person_role b, finish_batch c, finish_request d
where c.id_fbatch = d.id_fbatch
and c.finisher = b.id_role
and b.id_person = a.id_person
and d.id_frequest = ?
";
    my $sth_fin = $dbh->prepare($statement_fin) || die "ERROR:$DBI::errstr";
    
    # ROW COL info from id_mappplate
    my $statement_rc = "
select MAPROW, MAPCOL
from rowcol_map
where ID_MAP = ?
";
    my $sth_rc = $dbh->prepare($statement_rc) || die "ERROR:$DBI::errstr";

    

    # Go through the selected maps
    foreach my $map (@map_select_blocks){

	my @mapinfo = ();

	$last_block = 'None';
	$this_block = 'First-block';
	$from_MAPROW = 'a';
	$from_MAPCOL = '1';
	my $sample_count = 1; 
	$this_block_count = 0;
	my @array_array = ();
	my @array = ();
	
	my ($ID_MAPPLATE, $PROTOCOL, $ID_RUNTYPE);
	# split $map (eg. 109593_ABI-S1C-NULL) up into ID_MAPPLATE PROTOCOL ID_RUNTYPE

	if ($map =~ /^(\d+)_(\w+-\w+)-(\w+)\s+/){
	    $ID_MAPPLATE = $1;
	    $PROTOCOL = $2;
	    $ID_RUNTYPE = $3;
	} else {
	    die "Something is wrong parsing $map ! \n";
	}


	# Find out the total number of samples on this map
	$sth_c->bind_param(1, $ID_MAPPLATE);
	$sth_c->execute || die "ERROR:$DBI::errstr";
	my $total = $sth_c->fetchrow();


	# Find out the plate-format
	$sth_f->bind_param(1, $ID_MAPPLATE);
	$sth_f->execute || die "ERROR:$DBI::errstr";
	my $PLATE_FORMAT = $sth_f->fetchrow();


	# Go through the individual-entries for this map
	$sth_e->bind_param(1, $ID_MAPPLATE);
	$sth_e->execute || die "ERROR:$DBI::errstr";
	my ($ID_FREQUEST, $ID_MAP, $MAPROW, $MAPCOL);
	
	my $coordinates;
	while (($ID_FREQUEST, $ID_MAP, $MAPROW, $MAPCOL) = $sth_e->fetchrow()){
	    
	    my @orders;
	    push @orders, $ID_FREQUEST;
	    push @orders, $MAPROW;
	    push @orders, $MAPCOL;
	    push @array_array2, [@orders];
	    
	    # what project is this sample from ?
	    $sth_p->bind_param(1, $ID_FREQUEST);
	    $sth_p->execute|| die "ERROR:$DBI::errstr";
	    my ($PROJECTNAME) = $sth_p->fetchrow();
	    
	    # what finisher is this request from >?<
	    $sth_fin->bind_param(1, $ID_FREQUEST);
	    $sth_fin->execute|| die "ERROR:$DBI::errstr";
	    my ($EMAIL) = $sth_fin->fetchrow();

	    
	    $this_block = "$PROJECTNAME" . "_" . "$EMAIL";
	    if ($sample_count == 1){
		$last_block = $this_block;
	    }
	    $sample_count++;
	    $this_block_count++;
	    
	    # Code to populate our data-structure
	    if (($this_block ne $last_block) || ($sample_count > $total)){
		# ie. we have changed to a new block
		# by this point we should know all we need to
		# go into @array
		
		# Note; if $this_block ne $last_block is TRUE $MAPROW and $MAPCOL should be 1 coordinate less
		if ($this_block ne $last_block){
		    $this_block_count--;
		    my $new_ID_MAP = ($ID_MAP-1);
		    # work out new row-col values from $new_ID_MAP
		    my ($new_MAPROW, $new_MAPCOL);
		    $sth_rc->bind_param(1, $new_ID_MAP);
		    $sth_rc->execute|| die "ERROR:$DBI::errstr";
		    ($new_MAPROW, $new_MAPCOL) = $sth_rc->fetchrow();

		    $coordinates = "$from_MAPROW" . "$from_MAPCOL" . "-" . "$new_MAPROW" . "$new_MAPCOL";

		    push @array, $coordinates;
		    push @array, $last_block;
		    push @array, 1;
		    push @array, $this_block_count;

		    push @array_array, [@array];
		    @array = ();
		    $this_block_count = 1;
		    
		} else {
		    $coordinates = "$from_MAPROW" . "$from_MAPCOL" . "-" . "$MAPROW" . "$MAPCOL";
		    push @array, $coordinates;
		    push @array, $last_block;
		    push @array, 1;
		    push @array, $this_block_count;
		    push @array_array, [@array];
		    @array = ();
		}

		# We need to remember the start-coordinates for the new-block
		$from_MAPROW = $MAPROW;
		$from_MAPCOL = $MAPCOL;

	    } # if (($this_block ne $last_block) || ($sample_count > $total)){

	    $last_block = $this_block;
	}

	# TRAP A NASTY EVENT
	if (($this_block_count) == 1 && ($total != 1)){
	    # we have missed a block on the end of a map containing 1 sample
	    # ARG ! unless this map contains only 1 block, containing 1 sample
	     
	    $coordinates = "$from_MAPROW" . "$from_MAPCOL" . "-" . "$MAPROW" . "$MAPCOL";
	    # we have seen a new block
	    # we must record the rowcol for the old block
	    push @array, $coordinates;
	    push @array, $last_block;
	    push @array, 1;
	    push @array, $this_block_count;
	    push @array_array, [@array];
	    @array = ();
	}

	# foreach map we need to create an entry in our
	# datastructure; @printmap_struct              
	my $comment = "$PROTOCOL" . "$ID_RUNTYPE";
	my $hash = {
	    "map_name" => "$ID_MAPPLATE", 
	    "format" => "$PLATE_FORMAT",
	    "comment" => "$comment",
	    "mapinfo" => [@array_array],
	    "map_reads" => [@array_array2]
	    };
	@array_array2 = ();
	push @printmap_struct, $hash;

    } # end of foreach map 
    # finish all statements
    $sth_c->finish(); 
    $sth_f->finish(); 
    $sth_e->finish(); 
    $sth_p->finish(); 
    $sth_fin->finish(); 
    $sth_rc->finish();

    return(\@printmap_struct);
}

sub current_mapplate_status {
    my ($pkg, $dbh, $id) = @_;
    my $st = "
select status
from mapplate_status
where ID_MAPPLATE = \'$id\'
and iscurrent = 1
";


    my $sth = $dbh->prepare($st) || die "ERROR:$DBI::errstr";
    $sth->execute || die "ERROR:$DBI::errstr";
    my $status = $sth->fetchrow();
    $sth->finish();
    return ($status);
}

#kva addition - to get list of team projects
sub team_projects {
    my ($pkg, $dbh, $team) = @_;
    
    my $s = "
select projectname 
from project_owner 
where teamname = ? 
and iscurrent = 1 
and owner_type = 4
order by projectname";
    
    my $sth1 = $dbh->prepare($s) || die "ERROR:$DBI::errstr";
    $sth1->execute($team) || die "ERROR:$DBI::errstr";
    my $proj;
    my @list_projs;
    while($proj = $sth1->fetchrow()){
	push @list_projs,$proj;
    }
    $sth1->finish();
    
    return(\@list_projs);
}

sub team_list {
    my ($pkg, $dbh, $team) = @_;
    
    my $finisher;
    my @list_o_finishers;
    my $statement = "select p.email 
from person p, team_person_role tpr
where p.id_person = tpr.id_person 
and tpr.iscurrent = 1 
and tpr.roletype = 'Finishing'
and tpr.teamname = ?
and p.iscurrent = 1
order by p.email";
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr"; 
    $sth1->execute($team) || die "ERROR:$DBI::errstr";
    while($finisher = $sth1->fetchrow()){
	push @list_o_finishers,$finisher;
    }
    $sth1->finish();

    return(\@list_o_finishers);
}


package update;

sub project_owner {
    my ($pkg, $dbh, $p, $t) = @_;
    my $s = "
update project_owner
set iscurrent = 0, owned_to = sysdate
where projectname = \'$p\'
and iscurrent = 1
";
    my $sth1 = $dbh->prepare($s) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    $sth1->finish();

    my $s2 = "
insert into project_owner (PROJECTNAME, TEAMNAME, OWNED_FROM, OWNER_TYPE, ISCURRENT)
values('$p\', \'$t\', sysdate, 4, 1)
";
    
    my $sth2 = $dbh->prepare($s2) || die "ERROR:$DBI::errstr";
    $sth2->execute || die "ERROR:$DBI::errstr";
    $sth2->finish();
}

package upd;

sub to_zero_current_mapplate {
    my ($pkg, $dbh, $id) = @_;
    my $s = "
update mapplate_status
set iscurrent = 0
where iscurrent = 1
and ID_MAPPLATE  = \'$id\'
";
    
    my $sth1 = $dbh->prepare($s) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    $sth1->finish();
}


sub mapplate_status {
    my ($pkg, $dbh, $prog, $who, $session_id, $map_id, $status_id) = @_;
    my $s = "
insert into mapplate_status (ID_MAPPLATE, STATUS, STATUSDATE, ISCURRENT, SESSIONID, PROGRAM, OPERATOR)
values (\'$map_id\', \'$status_id\', sysdate, '1', \'$session_id\', \'$prog\', \'$who\')
";

    my $sth1 = $dbh->prepare($s) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    $sth1->finish();
}

package process;

sub change_finservice {

    my($pkg,$dbh,$CHANGE_FSNAME,$ID_FNSV,$samps)=@_;
    
    my %BLOCK_SAMPLES=%$samps;
    my %BATCH_SAMPLES;
    my %BATCH_BLOCKS;
    
    #Make a hash of the finish_batch with the related finish_request entries.
    my $stat1;
    my $sth1;
    foreach my $key (sort keys %BLOCK_SAMPLES){
	my $list = join(',',@{$BLOCK_SAMPLES{$key}});
	$stat1 = "select id_fbatch,id_frequest from finish_request where id_frequest in ($list)";
	$sth1 = $dbh->prepare($stat1);
	$sth1->execute();
	my ($batch,$freq); 
	while (($batch,$freq) = $sth1->fetchrow()){
	    push(@{$BATCH_SAMPLES{$batch}},$freq);
	    unless ($BATCH_BLOCKS{$batch}){
		$BATCH_BLOCKS{$batch}=$key;
	    }
	}
    }
    
#where the number of active samples related to a batch
#is equal to the amount of samples in the block
#only the finishbatch.ID_TEAM_FINSERV will require
#updating. If the samples are found to be more
#in the related finish batch than those in the
#block, then the required sampleS will have to be
#assigned to a new finish batch which will be a 
#duplicate of the original but linked to a new
#finservice.
    
    
    my $stat2 = "select count(*) 
from finish_request 
where id_fbatch = ? 
and id_frequest in (select id_frequest 
from frequest_status 
where iscurrent = 1 
and status != 2)";
    my $sth2 = $dbh->prepare($stat2);
    
    #update existing finish_batch where required.
    my $upd_fbth = "update finish_batch set id_team_finserv = ? where id_fbatch = ?";
    my $sth_fbth = $dbh->prepare($upd_fbth);
    
    #insert new finish_batch where required.
    #and new finish_batch status.
    my $get_gnewfbth = "select SEQ_FBATCH.NEXTVAL from dual";
    my $sth_gnewfbth = $dbh->prepare($get_gnewfbth);
    
    my $ins_inewfbth = "insert into finish_batch (select ?,sysdate,PROJECTNAME,FINISHER,?,ID_AUTO,PRIMERS_PICKED,RESEQS_PICKED from finish_batch where id_fbatch = ?)";
    my $sth_inewfbth = $dbh->prepare($ins_inewfbth);

    my $ins_inewfbthstat = "insert into fbatch_status (select ?,STATUS,ISCURRENT,sysdate,SESSIONID,PROGRAM,OPERATOR from fbatch_status where id_fbatch = ?)";
    my $sth_inewfbthstat = $dbh->prepare($ins_inewfbthstat);

    #update the finish_requests to link to the
    #new finish_batch.
    my $upd_frequest = "update finish_request set id_fbatch = ? where id_frequest = ?";
    my $sth_frequest = $dbh->prepare($upd_frequest);
    
    foreach my $key (sort keys %BATCH_SAMPLES){
	$sth2->execute($key);
	my $freq_count = $sth2->fetchrow();
	my $block_count= scalar(@{$BATCH_SAMPLES{$key}});
	
	if ($freq_count eq $block_count){
	    main::update("For block $BATCH_BLOCKS{$key}, batch id $key the id_finserv will be altered to $CHANGE_FSNAME."); 
	      $sth_fbth->bind_param(1,$ID_FNSV);
	      $sth_fbth->bind_param(2,$key);
	      $sth_fbth->execute;
	  } else {
	      main::update("For block $BATCH_BLOCKS{$key}, batch id $key, a new batch will be made attached to $CHANGE_FSNAME, as there are still other samples attached to this finish batch.");
		$sth_gnewfbth->execute;
		my $new_fbatch = $sth_gnewfbth->fetchrow();
		
		#make new finish batch and status entry
		main::update("New finish_batch ID is $new_fbatch");
		$sth_inewfbth->bind_param(1,$new_fbatch);
		$sth_inewfbth->bind_param(2,$ID_FNSV);
		$sth_inewfbth->bind_param(3,$key);
		$sth_inewfbth->execute;

		$sth_inewfbthstat->bind_param(1,$new_fbatch);
		$sth_inewfbthstat->bind_param(2,$key);
		$sth_inewfbthstat->execute;

		#update the existing finish_requests to be attached
		#to the new finish_batch.
		foreach my $frequest (sort @{$BATCH_SAMPLES{$key}}){
		    $sth_frequest->bind_param(1,$new_fbatch);    
		    $sth_frequest->bind_param(2,$frequest);    
		    $sth_frequest->execute;
		}
	    }
    }
    
    
    $sth1->finish();
    $sth2->finish();
    $sth_fbth->finish();
    $sth_gnewfbth->finish();
    $sth_inewfbth->finish();
    $sth_inewfbthstat->finish();
    $sth_frequest->finish();
    
    
}


1;


