vdw/trunk/WOU_SIS_Util.pm

package WOU_SIS_Util;

# Banner SIS Utilities
#
# Subs in this package that use DBI expect to be passed a database handle
# ($dbh) that has been granted the appropriate roles by WOU_Secure.pm.
#
# Jeremy Hickerson, 3/15/2002

use strict;

BEGIN {
    use Exporter   ();
    use vars       qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

    # set the version for version checking
    $VERSION     = 1.00;
    @ISA         = qw(Exporter);
    @EXPORT      = qw(&xtvxxxx_desc &pass_cobol_params &db_login
                      &already_sent_letter &term_acyr &ahist_level &term_last_year
                      &date_last_year &state_name &like2re &ssn2pidm &vnum2pidm
                      &next_fall);
    %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
    @EXPORT_OK   = qw( );

    ( grep /gen\$com/i, @INC ) || unshift @INC, "gen\$com";
}

use vars @EXPORT_OK;
use subs qw(xtvxxxx_desc pass_cobol_params db_login already_sent_letter
            term_acyr ahist_level term_last_year date_last_year state_name like2re 
            ssn2pidm vnum2pidm next_fall);
use DBI;
use WOU_Secure;


# ============================================================================
#                             Package-Level Stuff
# ============================================================================

my (%glbh_sth_xtvxxxx_desc, @row);

my %glb_prepared_sql;  # Hash that holds $sth's for prepared sql;
                       # helps performance.  Entries are of the form:
               # ( "sth_qry_acyr" => $sth_qry_acyr, ... )

my ($sth_qry_acyr, $sth_qry_state_name, $sth_qry_ssn2pidm1, $sth_qry_ssn2pidm2,
    $sth_qry_vnum2pidm);


# ============================================================================
#                                Routines
# ============================================================================
 
# better (for performance) to make xtvxxxx_desc lookups available as separate
# routines rather than joining them in to sgbstdn, etc.  Calling program
# can call them on (probably) smaller population.
sub xtvxxxx_desc {
    my ($dbh, $tbl_name, $code) = @_;

    # make sure below only executes once per package instance per tbl_name
    if (! exists $glbh_sth_xtvxxxx_desc{$tbl_name} ) {
        $glbh_sth_xtvxxxx_desc{$tbl_name} = $dbh->prepare(
        "select $tbl_name" . "_desc " .
        "from $tbl_name where $tbl_name" . "_code = '$code'");
    }

    ($glbh_sth_xtvxxxx_desc{$tbl_name} )->execute;

    @row = ($glbh_sth_xtvxxxx_desc{$tbl_name} )->fetchrow_array;

    if (@row) { return $row[0] }

    return "Unknown";  # fall-through, code not in xtvxxxx
}


sub pass_cobol_params {
    my ($program, $uid, $passwd, $one_up_no, $rh_parms) = @_;

    my ($job, $parm_no, $parm_name);

    my $dbh = db_login($uid, $passwd, $program);

    $job = sis_object($program);

    my $sth_ins_gjbprun = $dbh->prepare( q{
    insert into gjbprun(gjbprun_job,
                gjbprun_one_up_no,
                gjbprun_number,
                gjbprun_activity_date,
                gjbprun_value)
    values(  upper(?),
        ?,
        ?,
        sysdate,
        ? ) } );

    my $sth_ins_gjbprun_dyn = $dbh->prepare( q{
    insert into gjbprun(gjbprun_job,
                gjbprun_one_up_no,
                gjbprun_number,
                gjbprun_activity_date,
                gjbprun_label,
                gjbprun_value)
    values(  upper(?),
        ?,
        ?,
        sysdate,
        ?,
        ? ) } );

    # put program params in gjbprun table
    foreach $parm_no ( keys %{$rh_parms} ) {
        if ($parm_no ne "88") {
            $sth_ins_gjbprun->execute($job, $one_up_no, $parm_no,
                                  $rh_parms->{$parm_no} );
        }
    else {  # "dynamic" params
        foreach $parm_name (keys %{$rh_parms->{$parm_no} } ) {
                $sth_ins_gjbprun_dyn->execute(
            $job, $one_up_no, $parm_no, $parm_name,
            $rh_parms->{$parm_no}->{$parm_name} );
            }
    }
    }

    $dbh->disconnect;
}


sub db_login {
    my ($uid, $passwd, $program, $rh_params) = @_;

    my $dbh = DBI->connect("dbi:Oracle:", $uid, $passwd, $rh_params)
    or die "$!:  Can't connect to DB";

    # convert VMS full path of this file to SIS Object
    my $sis_object = sis_object($program);

    # set security role for user in SIS Database
    if (! gwrsecp($dbh, $sis_object) ) {
    $dbh->disconnect;
    die "$!:  User $uid not allowed to run $sis_object";
    }
    return $dbh;
}


sub already_sent_letter {

    my ($dbh, $pidm, $term, $module, $sys_ind, $letr, $update_mail) = @_;

    my ($date_printed, $rowid);

    $update_mail = defined($update_mail) ? uc($update_mail) : "U";
                                                          # default is "Update"

    my $sql_qry_gurmail =
        "select gurmail_date_printed, \
            gurmail.rowid \
    from gurmail \
        where gurmail_pidm = $pidm        and \
          gurmail_term_code = '$term'   and \
          gurmail_module_code = '$module' and \
          gurmail_system_ind = '$sys_ind'  and \
          gurmail_letr_code = '$letr'\n";  # jhjh

    my $sth_qry_gurmail = $dbh->prepare($sql_qry_gurmail);

    $sth_qry_gurmail->execute;

    my @row = $sth_qry_gurmail->fetchrow_array;

    if (@row) { 
        ($date_printed, $rowid) = @row;
        if ($date_printed) {  # already sent letter
            return 1;
        }
    else {
        if ($update_mail ne "A") {  # if not "Audit" mode
        $dbh->do("update gurmail \
              set gurmail_date_printed = sysdate \
              where gurmail.rowid = '$rowid'");
            }
            return 0;
    }
    }

    else {
        if ($update_mail ne "A") {  # if not "Audit" mode
        # create gurmail record for new letter
        $dbh->do( "\
        INSERT INTO GURMAIL ( GURMAIL_PIDM, \
                      gurmail_term_code, \
                      gurmail_module_code, \
                      GURMAIL_SYSTEM_IND, \
                      GURMAIL_LETR_CODE, \
                      GURMAIL_DATE_INIT, \
                      GURMAIL_USER, \
                      GURMAIL_PUB_GEN, \
                      GURMAIL_ORIG_IND, \
                      GURMAIL_ACTIVITY_DATE, \
                      gurmail_date_printed) \
    \
        values ( $pidm, \
             '$term', \
             '$module', \
             '$sys_ind', \
             '$letr', \
             TO_DATE(TO_CHAR(SYSDATE,'DD-MON-YYYY HH24:MI:SS'), \
                 'DD-MON-YYYY HH24:MI:SS'), \
             USER, \
             'G', \
             'S', \
             SYSDATE, \
             sysdate)" );
        }

        return 0;
    }
}


sub term_acyr {
    my ($dbh, $term) = @_;

    my ($acyr, @row);

    # for performance we will only prepare repeated sql once
    if (exists $glb_prepared_sql{"sth_qry_acyr"} ) {
        $sth_qry_acyr = $glb_prepared_sql{"sth_qry_acyr"};
    }
    else {
        $sth_qry_acyr = $dbh->prepare( q{
            select stvacyr_desc from stvacyr where stvacyr_code = ?} );

        $glb_prepared_sql{"sth_qry_acyr"} =  $sth_qry_acyr;
    }

    if (defined($term) ) {
        $acyr = substr( substr($term, 0, 4), 2, 2);
    $acyr .= sprintf("%.2i", $acyr + 1);

    $sth_qry_acyr->execute($acyr);
    @row = $sth_qry_acyr->fetchrow_array;

    if (@row) {
        return $row[0];
    }  # otherwise fall-through
    }

    return "Unknown";  # fall-through
}


sub term_last_year{
    my $term = shift;

    return (substr($term, 0, 4) - 1) . substr($term, 4, 2);

}


sub date_last_year{
    my $date = shift;
       # date must be formatted mm/dd/yyyy, output will be in same format

    return substr($date, 0, 6) . (substr($date, 6, 4) - 1);

}


sub ahist_level {

    my $level = shift;

    $level =~ s/NG|PB/GR/ || $level =~ s/PN|NU|NA/UG/;

    return $level;
}


sub state_name{
    my ($dbh, $stat_code) = @_;

    my ($state_name);

    # for performance we will only prepare repeated sql once
    if (exists $glb_prepared_sql{"sth_qry_state_name"} ) {
        $sth_qry_state_name = $glb_prepared_sql{"sth_qry_state_name"};
    }
    else {
        $sth_qry_state_name = $dbh->prepare( q{
            select stvstat_desc from stvstat where stvstat_code = ? } );

        $glb_prepared_sql{"sth_qry_state_name"} =  $sth_qry_state_name;
    }

    $sth_qry_state_name->execute($stat_code);

    ($state_name) = $sth_qry_state_name->fetchrow_array;

    return $state_name ? $state_name : "";
}


sub like2re {

    my ($str, $word, $negative);
    $negative = 0;

    # stop on LIKE for LIKE/NOT LIKE
    while ( ($word = shift) !~ /^like$/i ) {
        if ($word =~ /^not$/i) {
            $negative = 1;
        }
        else { $str .= $word . "," }  # replace whitespace w/ comma's just like the
                                      # parser does
    }
    $str .= $word . ",";  # add LIKE to $str

    $word = shift;  # $word now holds the SQL LIKE expression


    # if LIKE expr contains SQL % wildcard, then turn into perl reg exp
    if ( $word =~ /'(.*%.*)'/i ) {

        $word = $1;
        $str =~ s/like,$/=~,/i;

        $negative && ( $str =~ s/=~/!~/ );

        $word =~ s/^([^%])/\^$1/;
        $word =~ s/([^%])$/$1\$/;
        $word =~ s/%/\.\*/g;
        $word = "/" . $word . "/";
        
    }

    # otherwise turn like into "="  ( we will turn "=" into "eq" in get_data(),
    # this sub is used by the obj_srvr yacc parser)
    else {
        $str =~ s/like,$/=,/i;
    }

    $str .= $word;

    return $str;

}


sub ssn2pidm {

    my ($dbh, $ssn) = @_;

    my $pidm;

    # for performance we will only prepare repeated sql once
    if (exists $glb_prepared_sql{"sth_qry_ssn2pidm1"} ) {
        $sth_qry_ssn2pidm1 = $glb_prepared_sql{"sth_qry_ssn2pidm1"};
        $sth_qry_ssn2pidm2 = $glb_prepared_sql{"sth_qry_ssn2pidm2"};
    }
    else {
        $sth_qry_ssn2pidm1 = $dbh->prepare( q{
        select spbpers_pidm
        from spbpers
        where spbpers_ssn = ? } );

        $glb_prepared_sql{"sth_qry_ssn2pidm1"} =  $sth_qry_ssn2pidm1;


        $sth_qry_ssn2pidm2 = $dbh->prepare( q{
        select spriden_pidm
        from spriden
        where spriden_id = ? and
              spriden_change_ind = 'I' } );

        $glb_prepared_sql{"sth_qry_ssn2pidm2"} =  $sth_qry_ssn2pidm2;
    }

    $sth_qry_ssn2pidm1->execute($ssn);

    ($pidm) = $sth_qry_ssn2pidm1->fetchrow_array;

    if ( !defined($pidm) ) {

        $sth_qry_ssn2pidm2->execute($ssn);

        ($pidm) = $sth_qry_ssn2pidm2->fetchrow_array;
    }

    return $pidm;
}


sub vnum2pidm {

    my ($dbh, $vnum) = @_;

    my $pidm;

    # for performance we will only prepare repeated sql once
    if (exists $glb_prepared_sql{"sth_qry_vnum2pidm"} ) {
        $sth_qry_vnum2pidm = $glb_prepared_sql{"sth_qry_vnum2pidm"};
    }
    else {
        $sth_qry_vnum2pidm = $dbh->prepare( q{
        select spriden_pidm
        from spriden
        where spriden_id = ? and
              spriden_change_ind is null } );

        $glb_prepared_sql{"sth_qry_vnum2pidm"} =  $sth_qry_vnum2pidm;
    }

    $sth_qry_vnum2pidm->execute($vnum);

    ($pidm) = $sth_qry_vnum2pidm->fetchrow_array;

    return $pidm;
}


sub next_fall {

    my $term = shift;

    # return next fall from any term during the year
    return substr($term + 100, 0, 4) . "01";
}

# ============================================================================
#                               Subroutines
# ============================================================================

return 1;


1	dpavlin	1	package WOU_SIS_Util;
2
3			# Banner SIS Utilities
4			#
5			# Subs in this package that use DBI expect to be passed a database handle
6			# ($dbh) that has been granted the appropriate roles by WOU_Secure.pm.
7			#
8			# Jeremy Hickerson, 3/15/2002
9
10			use strict;
11
12			BEGIN {
13			use Exporter ();
14			use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
15
16			# set the version for version checking
17			$VERSION = 1.00;
18			@ISA = qw(Exporter);
19			@EXPORT = qw(&xtvxxxx_desc &pass_cobol_params &db_login
20			&already_sent_letter &term_acyr &ahist_level &term_last_year
21			&date_last_year &state_name &like2re &ssn2pidm &vnum2pidm
22			&next_fall);
23			%EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ],
24			@EXPORT_OK = qw( );
25
26			( grep /gen\$com/i, @INC ) \|\| unshift @INC, "gen\$com";
27			}
28
29			use vars @EXPORT_OK;
30			use subs qw(xtvxxxx_desc pass_cobol_params db_login already_sent_letter
31			term_acyr ahist_level term_last_year date_last_year state_name like2re
32			ssn2pidm vnum2pidm next_fall);
33			use DBI;
34			use WOU_Secure;
35
36
37			# ============================================================================
38			# Package-Level Stuff
39			# ============================================================================
40
41			my (%glbh_sth_xtvxxxx_desc, @row);
42
43			my %glb_prepared_sql; # Hash that holds $sth's for prepared sql;
44			# helps performance. Entries are of the form:
45			# ( "sth_qry_acyr" => $sth_qry_acyr, ... )
46
47			my ($sth_qry_acyr, $sth_qry_state_name, $sth_qry_ssn2pidm1, $sth_qry_ssn2pidm2,
48			$sth_qry_vnum2pidm);
49
50
51			# ============================================================================
52			# Routines
53			# ============================================================================
54
55			# better (for performance) to make xtvxxxx_desc lookups available as separate
56			# routines rather than joining them in to sgbstdn, etc. Calling program
57			# can call them on (probably) smaller population.
58			sub xtvxxxx_desc {
59			my ($dbh, $tbl_name, $code) = @_;
60
61			# make sure below only executes once per package instance per tbl_name
62			if (! exists $glbh_sth_xtvxxxx_desc{$tbl_name} ) {
63			$glbh_sth_xtvxxxx_desc{$tbl_name} = $dbh->prepare(
64			"select $tbl_name" . "_desc " .
65			"from $tbl_name where $tbl_name" . "_code = '$code'");
66			}
67
68			($glbh_sth_xtvxxxx_desc{$tbl_name} )->execute;
69
70			@row = ($glbh_sth_xtvxxxx_desc{$tbl_name} )->fetchrow_array;
71
72			if (@row) { return $row[0] }
73
74			return "Unknown"; # fall-through, code not in xtvxxxx
75			}
76
77
78			sub pass_cobol_params {
79			my ($program, $uid, $passwd, $one_up_no, $rh_parms) = @_;
80
81			my ($job, $parm_no, $parm_name);
82
83			my $dbh = db_login($uid, $passwd, $program);
84
85			$job = sis_object($program);
86
87			my $sth_ins_gjbprun = $dbh->prepare( q{
88			insert into gjbprun(gjbprun_job,
89			gjbprun_one_up_no,
90			gjbprun_number,
91			gjbprun_activity_date,
92			gjbprun_value)
93			values( upper(?),
94			?,
95			?,
96			sysdate,
97			? ) } );
98
99			my $sth_ins_gjbprun_dyn = $dbh->prepare( q{
100			insert into gjbprun(gjbprun_job,
101			gjbprun_one_up_no,
102			gjbprun_number,
103			gjbprun_activity_date,
104			gjbprun_label,
105			gjbprun_value)
106			values( upper(?),
107			?,
108			?,
109			sysdate,
110			?,
111			? ) } );
112
113			# put program params in gjbprun table
114			foreach $parm_no ( keys %{$rh_parms} ) {
115			if ($parm_no ne "88") {
116			$sth_ins_gjbprun->execute($job, $one_up_no, $parm_no,
117			$rh_parms->{$parm_no} );
118			}
119			else { # "dynamic" params
120			foreach $parm_name (keys %{$rh_parms->{$parm_no} } ) {
121			$sth_ins_gjbprun_dyn->execute(
122			$job, $one_up_no, $parm_no, $parm_name,
123			$rh_parms->{$parm_no}->{$parm_name} );
124			}
125			}
126			}
127
128			$dbh->disconnect;
129			}
130
131
132			sub db_login {
133			my ($uid, $passwd, $program, $rh_params) = @_;
134
135			my $dbh = DBI->connect("dbi:Oracle:", $uid, $passwd, $rh_params)
136			or die "$!: Can't connect to DB";
137
138			# convert VMS full path of this file to SIS Object
139			my $sis_object = sis_object($program);
140
141			# set security role for user in SIS Database
142			if (! gwrsecp($dbh, $sis_object) ) {
143			$dbh->disconnect;
144			die "$!: User $uid not allowed to run $sis_object";
145			}
146			return $dbh;
147			}
148
149
150			sub already_sent_letter {
151
152			my ($dbh, $pidm, $term, $module, $sys_ind, $letr, $update_mail) = @_;
153
154			my ($date_printed, $rowid);
155
156			$update_mail = defined($update_mail) ? uc($update_mail) : "U";
157			# default is "Update"
158
159			my $sql_qry_gurmail =
160			"select gurmail_date_printed, \
161			gurmail.rowid \
162			from gurmail \
163			where gurmail_pidm = $pidm and \
164			gurmail_term_code = '$term' and \
165			gurmail_module_code = '$module' and \
166			gurmail_system_ind = '$sys_ind' and \
167			gurmail_letr_code = '$letr'\n"; # jhjh
168
169			my $sth_qry_gurmail = $dbh->prepare($sql_qry_gurmail);
170
171			$sth_qry_gurmail->execute;
172
173			my @row = $sth_qry_gurmail->fetchrow_array;
174
175			if (@row) {
176			($date_printed, $rowid) = @row;
177			if ($date_printed) { # already sent letter
178			return 1;
179			}
180			else {
181			if ($update_mail ne "A") { # if not "Audit" mode
182			$dbh->do("update gurmail \
183			set gurmail_date_printed = sysdate \
184			where gurmail.rowid = '$rowid'");
185			}
186			return 0;
187			}
188			}
189
190			else {
191			if ($update_mail ne "A") { # if not "Audit" mode
192			# create gurmail record for new letter
193			$dbh->do( "\
194			INSERT INTO GURMAIL ( GURMAIL_PIDM, \
195			gurmail_term_code, \
196			gurmail_module_code, \
197			GURMAIL_SYSTEM_IND, \
198			GURMAIL_LETR_CODE, \
199			GURMAIL_DATE_INIT, \
200			GURMAIL_USER, \
201			GURMAIL_PUB_GEN, \
202			GURMAIL_ORIG_IND, \
203			GURMAIL_ACTIVITY_DATE, \
204			gurmail_date_printed) \
205			\
206			values ( $pidm, \
207			'$term', \
208			'$module', \
209			'$sys_ind', \
210			'$letr', \
211			TO_DATE(TO_CHAR(SYSDATE,'DD-MON-YYYY HH24:MI:SS'), \
212			'DD-MON-YYYY HH24:MI:SS'), \
213			USER, \
214			'G', \
215			'S', \
216			SYSDATE, \
217			sysdate)" );
218			}
219
220			return 0;
221			}
222			}
223
224
225			sub term_acyr {
226			my ($dbh, $term) = @_;
227
228			my ($acyr, @row);
229
230			# for performance we will only prepare repeated sql once
231			if (exists $glb_prepared_sql{"sth_qry_acyr"} ) {
232			$sth_qry_acyr = $glb_prepared_sql{"sth_qry_acyr"};
233			}
234			else {
235			$sth_qry_acyr = $dbh->prepare( q{
236			select stvacyr_desc from stvacyr where stvacyr_code = ?} );
237
238			$glb_prepared_sql{"sth_qry_acyr"} = $sth_qry_acyr;
239			}
240
241			if (defined($term) ) {
242			$acyr = substr( substr($term, 0, 4), 2, 2);
243			$acyr .= sprintf("%.2i", $acyr + 1);
244
245			$sth_qry_acyr->execute($acyr);
246			@row = $sth_qry_acyr->fetchrow_array;
247
248			if (@row) {
249			return $row[0];
250			} # otherwise fall-through
251			}
252
253			return "Unknown"; # fall-through
254			}
255
256
257			sub term_last_year{
258			my $term = shift;
259
260			return (substr($term, 0, 4) - 1) . substr($term, 4, 2);
261
262			}
263
264
265			sub date_last_year{
266			my $date = shift;
267			# date must be formatted mm/dd/yyyy, output will be in same format
268
269			return substr($date, 0, 6) . (substr($date, 6, 4) - 1);
270
271			}
272
273
274			sub ahist_level {
275
276			my $level = shift;
277
278			$level =~ s/NG\|PB/GR/ \|\| $level =~ s/PN\|NU\|NA/UG/;
279
280			return $level;
281			}
282
283
284			sub state_name{
285			my ($dbh, $stat_code) = @_;
286
287			my ($state_name);
288
289			# for performance we will only prepare repeated sql once
290			if (exists $glb_prepared_sql{"sth_qry_state_name"} ) {
291			$sth_qry_state_name = $glb_prepared_sql{"sth_qry_state_name"};
292			}
293			else {
294			$sth_qry_state_name = $dbh->prepare( q{
295			select stvstat_desc from stvstat where stvstat_code = ? } );
296
297			$glb_prepared_sql{"sth_qry_state_name"} = $sth_qry_state_name;
298			}
299
300			$sth_qry_state_name->execute($stat_code);
301
302			($state_name) = $sth_qry_state_name->fetchrow_array;
303
304			return $state_name ? $state_name : "";
305			}
306
307
308			sub like2re {
309
310			my ($str, $word, $negative);
311			$negative = 0;
312
313			# stop on LIKE for LIKE/NOT LIKE
314			while ( ($word = shift) !~ /^like$/i ) {
315			if ($word =~ /^not$/i) {
316			$negative = 1;
317			}
318			else { $str .= $word . "," } # replace whitespace w/ comma's just like the
319			# parser does
320			}
321			$str .= $word . ","; # add LIKE to $str
322
323			$word = shift; # $word now holds the SQL LIKE expression
324
325
326			# if LIKE expr contains SQL % wildcard, then turn into perl reg exp
327			if ( $word =~ /'(.%.)'/i ) {
328
329			$word = $1;
330			$str =~ s/like,$/=~,/i;
331
332			$negative && ( $str =~ s/=~/!~/ );
333
334			$word =~ s/^([^%])/\^$1/;
335			$word =~ s/([^%])$/$1\$/;
336			$word =~ s/%/\.\*/g;
337			$word = "/" . $word . "/";
338
339			}
340
341			# otherwise turn like into "=" ( we will turn "=" into "eq" in get_data(),
342			# this sub is used by the obj_srvr yacc parser)
343			else {
344			$str =~ s/like,$/=,/i;
345			}
346
347			$str .= $word;
348
349			return $str;
350
351			}
352
353
354			sub ssn2pidm {
355
356			my ($dbh, $ssn) = @_;
357
358			my $pidm;
359
360			# for performance we will only prepare repeated sql once
361			if (exists $glb_prepared_sql{"sth_qry_ssn2pidm1"} ) {
362			$sth_qry_ssn2pidm1 = $glb_prepared_sql{"sth_qry_ssn2pidm1"};
363			$sth_qry_ssn2pidm2 = $glb_prepared_sql{"sth_qry_ssn2pidm2"};
364			}
365			else {
366			$sth_qry_ssn2pidm1 = $dbh->prepare( q{
367			select spbpers_pidm
368			from spbpers
369			where spbpers_ssn = ? } );
370
371			$glb_prepared_sql{"sth_qry_ssn2pidm1"} = $sth_qry_ssn2pidm1;
372
373
374			$sth_qry_ssn2pidm2 = $dbh->prepare( q{
375			select spriden_pidm
376			from spriden
377			where spriden_id = ? and
378			spriden_change_ind = 'I' } );
379
380			$glb_prepared_sql{"sth_qry_ssn2pidm2"} = $sth_qry_ssn2pidm2;
381			}
382
383			$sth_qry_ssn2pidm1->execute($ssn);
384
385			($pidm) = $sth_qry_ssn2pidm1->fetchrow_array;
386
387			if ( !defined($pidm) ) {
388
389			$sth_qry_ssn2pidm2->execute($ssn);
390
391			($pidm) = $sth_qry_ssn2pidm2->fetchrow_array;
392			}
393
394			return $pidm;
395			}
396
397
398			sub vnum2pidm {
399
400			my ($dbh, $vnum) = @_;
401
402			my $pidm;
403
404			# for performance we will only prepare repeated sql once
405			if (exists $glb_prepared_sql{"sth_qry_vnum2pidm"} ) {
406			$sth_qry_vnum2pidm = $glb_prepared_sql{"sth_qry_vnum2pidm"};
407			}
408			else {
409			$sth_qry_vnum2pidm = $dbh->prepare( q{
410			select spriden_pidm
411			from spriden
412			where spriden_id = ? and
413			spriden_change_ind is null } );
414
415			$glb_prepared_sql{"sth_qry_vnum2pidm"} = $sth_qry_vnum2pidm;
416			}
417
418			$sth_qry_vnum2pidm->execute($vnum);
419
420			($pidm) = $sth_qry_vnum2pidm->fetchrow_array;
421
422			return $pidm;
423			}
424
425
426			sub next_fall {
427
428			my $term = shift;
429
430			# return next fall from any term during the year
431			return substr($term + 100, 0, 4) . "01";
432			}
433
434			# ============================================================================
435			# Subroutines
436			# ============================================================================
437
438			return 1;
439
440