The issue I suspect is with the untainted file I'm trying to manipulate to upload file from other directories in lines 171-176. I'm able to upload file in lines 168-169 but not the opposite.

The error message tells you the issue is $destination_filename is tainted

Looking how you build it, I am horrified to see

    my $user_id = "";
    foreach my $key (sort keys(%ENV)) {
      if ($key =~ /QUERY_STRING/) {
        push(@ts_dir,$ENV{$key});
        #print "$ENV{$key}<p>";
      }
      elsif ($key =~ /IWUSER/) {
        $user_id = $ENV{$key};
        #print "$user_id<p>";
      }
    }
[download]

That is the craziest thing I've seen in a long time :)

Part of your confusion stems from skipping perlintro, so

Drop what you're doing and read perlintro (or Tutorials) please!

Then replace that loop with

my @ts_dir = $ENV{QUERY_STRING};
my $user_id = $ENV{IWUSER};
[download]

The other part is you're not quite sure what it should do, so it does too much

You should document your subroutines

What input the subroutines takes

what output it produces

what effects it has / what actions it performs (copy file)

After you're done with perlintro, read http://search.cpan.org/dist/CGI.pm/lib/CGI.pm#Accessing_the_temp_files_directly

And reduce save_file to this

#!I:\Interwoven\TeamSite\iw-perl\bin\iwperl -T --
use strict;
use warnings;
use diagnostics;
use CGI;
use CGI::Carp qw(fatalsToBrowser warningsToBrowser set_message);
use File::Copy qw/ copy /;
Main( @ARGV );
exit( 0 );
sub Main {
    set_message("It's not a bug, it's a feature!");
    local $CGI::POST_MAX = 1024 * 100;  # maximum upload filesize is 1
+00K
    my $q = CGI->new;
    print $q->header;
    warningsToBrowser(1);
    
    print buildForm( $q );

    if (  !$q->param('filename') && $q->cgi_error() ) {
        ...
    } else {
        save_file($q);
    }
    print $q->end_html;
}


sub save_file {
    my( $q ) = @_;
    my $filename    = $query->param('uploaded_file');
    
    my $destination_filename = File::Spec->catfile( $hardcoded_destina
+tion_directory, WashFilename( $filename  ) );

    copy( $filename->handle, $destination_filename  ) or die "Copy to 
+( $destination_filename) failed: $!";
}
[download]

WashFilename should create a new (normalized) filename, not warn about dots and other things (action instead of talk)

Something like this (save as WashFilename-test.pl)

for my $testfn (
    "a/b/c",
    'a\b\c',
    'a:b:c',
    "a[!{(\205)}!].ext",
    "a.ext",
    ){
    printf "( %s )\n\t(%s)\n\n", $testfn , WashFilename( $testfn );
}

sub WashFilename {
    use File::Basename;
    my $basename = basename( shift );
#~     $basename =~ s/[^a-zA-Z0-9]//g; # remove everything except a-z 
+A-Z 0-9
    $basename = join '', $basename =~ m/([.a-zA-Z0-9])/g; # untainted 
+, only use a-z A-Z 0-9 and dot
    # basename is now, hopefully, file.ext
    ## so to ensure uniqueness, we adulterate it :)
    my $id = $$.'-'.time;
    my( $file, $ext ) = split /\./, $basename, 2 ;
    return join '.', grep defined, $file, $id, $ext;
}
__END__
( a/b/c )
        (c.1272-1316599567)

( a\b\c )
        (c.1272-1316599567)

( a:b:c )
        (c.1272-1316599567)

( a[!{(à)}!].ext )
        (a.1272-1316599567.ext)

( a.ext )
        (a.1272-1316599567.ext)
[download]

for my $testfn (
    "a/b/c",
    'a\b\c',
    'a:b:c',
    "a[!{(\205)}!].ext",
    "a.ext",
    ){
    printf "( %s )\n\t(%s)\n\n", $testfn , WashFilename( $testfn );
}

sub WashFilename {
    use File::Basename;
    my $basename = basename( shift );
    my $id = $$.'-'.time;
    my( $file, $ext ) = map { unpack 'h*',$_ } split /\./, $basename, 
+2 ;
    return join '.', grep defined, $file, $id, $ext;
}
__END__
( a/b/c )
        (36.3924-1316599650)

( a\b\c )
        (36.3924-1316599650)

( a:b:c )
        (36.3924-1316599650)

( a[!{(à)}!].ext )
        (16b512b7825892d712d5.3924-1316599650.568747)

( a.ext )
        (16.3924-1316599650.568747)
[download]

You would benefit greatly from reading http://learn.perl.org/books/beginning-perl/

And maybe Modern Perl: the free book

That is all I have time for, it only took ~3 hours :)