| 1 |
package WOU_Person; |
| 2 |
|
| 3 |
# Routines for Banner SIS Person |
| 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/11/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(&get_name &id &get_addr &get_phone &real_ssn &email |
| 20 |
&stu_email &legal_name &term_age); |
| 21 |
%EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ], |
| 22 |
@EXPORT_OK = qw( ); |
| 23 |
|
| 24 |
} |
| 25 |
use vars @EXPORT_OK; |
| 26 |
use subs qw(get_name id get_addr_rowid get_addr get_phone real_ssn email |
| 27 |
stu_email legal_name term_age); |
| 28 |
|
| 29 |
use DBI; |
| 30 |
|
| 31 |
|
| 32 |
# ============================================================================ |
| 33 |
# Package-Level Stuff |
| 34 |
# ============================================================================ |
| 35 |
|
| 36 |
|
| 37 |
my $sth_qry_id; |
| 38 |
my $sth_qry_dual_rowid; |
| 39 |
my $sth_qry_addr_rowid; |
| 40 |
my $sth_qry_addr; |
| 41 |
my $sth_qry_phone; |
| 42 |
my $sth_qry_real_ssn; |
| 43 |
my $sth_qry_term_age; |
| 44 |
|
| 45 |
my $dual_rowid; |
| 46 |
|
| 47 |
# prepare_repeated_sql() will set this global var to 1 after running, to |
| 48 |
# guarantee sql only prepared once per package instance |
| 49 |
my $glb_sql_prepared = 0; |
| 50 |
|
| 51 |
|
| 52 |
# ! jhjh - new subs should use glb_prepared_sql approach, which only |
| 53 |
# prepares the sql if you call the sub. Old subs need to be converted |
| 54 |
# to this, but will use prepare_repeated_sql for now. |
| 55 |
my %glb_prepared_sql; # Hash that holds $sth's for prepared sql; |
| 56 |
# helps performance. Entries are of the form: |
| 57 |
# ( "sth_qry_email" => $sth_qry_email, ... ) |
| 58 |
|
| 59 |
my ($sth_qry_email); |
| 60 |
|
| 61 |
|
| 62 |
# ============================================================================ |
| 63 |
# Routines |
| 64 |
# ============================================================================ |
| 65 |
|
| 66 |
sub get_name { return id(@_) } # changed name to id |
| 67 |
|
| 68 |
|
| 69 |
sub id { |
| 70 |
my ($dbh, $pidm) = @_; |
| 71 |
|
| 72 |
my ($rh_legal_name, $fname, $mname, $lname, @row, $legal_fname, |
| 73 |
$legal_mname, $legal_lname, $full_mname); |
| 74 |
|
| 75 |
prepare_repeated_sql($dbh); # sets global flag after run, so will only |
| 76 |
# execute once per package instance; |
| 77 |
|
| 78 |
$sth_qry_id->execute($pidm); |
| 79 |
@row = $sth_qry_id->fetchrow_array; |
| 80 |
|
| 81 |
$fname = $row[0]; |
| 82 |
$mname = $row[1] ? substr($row[1], 0, 1) : " "; |
| 83 |
$full_mname = $row[1]; |
| 84 |
$lname = substr($row[2], 0, 25); |
| 85 |
|
| 86 |
$rh_legal_name = legal_name($dbh, $pidm); |
| 87 |
|
| 88 |
if (defined($rh_legal_name) ) { |
| 89 |
|
| 90 |
$legal_fname = $rh_legal_name->{fname}; |
| 91 |
$legal_mname = $rh_legal_name->{mname} ? |
| 92 |
substr($rh_legal_name->{mname}, 0, 1) : " "; |
| 93 |
$legal_lname = substr($rh_legal_name->{lname}, 0, 25); |
| 94 |
|
| 95 |
} |
| 96 |
else { |
| 97 |
$legal_fname = $fname; |
| 98 |
$legal_mname = $mname; |
| 99 |
$legal_lname = $lname; |
| 100 |
} |
| 101 |
|
| 102 |
# return ref to anonymous hash |
| 103 |
return { "fname" => $fname, |
| 104 |
"mname" => $mname, |
| 105 |
"full_mname" => $full_mname, |
| 106 |
"lname" => $lname, |
| 107 |
"legal_fname" => $legal_fname, |
| 108 |
"legal_mname" => $legal_mname, |
| 109 |
"legal_lname" => $legal_lname, |
| 110 |
"ssn" => $row[3], # leave this so old programs will still work |
| 111 |
"vnum" => $row[3], # this is what's in the field now |
| 112 |
"confidential" => $row[4], |
| 113 |
"dead" => $row[5], |
| 114 |
"citz" => $row[6], |
| 115 |
"gender" => $row[7], |
| 116 |
"ethn_code" => $row[8], |
| 117 |
"ethnicity" => $row[9], |
| 118 |
"birth_date" => $row[10], |
| 119 |
"age" => $row[11], |
| 120 |
"lgcy" => $row[12], |
| 121 |
"mrtl_code" => $row[13] }; |
| 122 |
} |
| 123 |
|
| 124 |
|
| 125 |
sub legal_name { |
| 126 |
my ($dbh, $pidm) = @_; |
| 127 |
my ($sth_qry_legal_name, $legal_name, $lname, $fname_mi, @fname_mi, |
| 128 |
$word, $fname, $mi); |
| 129 |
|
| 130 |
# for performance we will only prepare repeated sql once |
| 131 |
if (exists $glb_prepared_sql{"sth_qry_legal_name"} ) { |
| 132 |
$sth_qry_legal_name = $glb_prepared_sql{"sth_qry_legal_name"}; |
| 133 |
} |
| 134 |
else { |
| 135 |
$sth_qry_legal_name = $dbh->prepare( q{ |
| 136 |
select spbpers_legal_name |
| 137 |
from spbpers |
| 138 |
where spbpers_pidm = ? } ); |
| 139 |
|
| 140 |
$glb_prepared_sql{"sth_qry_legal_name"} = $sth_qry_legal_name; |
| 141 |
} |
| 142 |
|
| 143 |
$sth_qry_legal_name->execute($pidm); |
| 144 |
|
| 145 |
($legal_name) = $sth_qry_legal_name->fetchrow_array; |
| 146 |
|
| 147 |
# only use if in "last_name, first_name [middle]" format |
| 148 |
( (!defined($legal_name) ) || ($legal_name !~ /.+, .+/ ) ) && return; |
| 149 |
|
| 150 |
# fall-through |
| 151 |
($lname, $fname_mi) = split( /, /, $legal_name); |
| 152 |
|
| 153 |
@fname_mi = split( /\s/, $fname_mi); |
| 154 |
|
| 155 |
foreach $word (@fname_mi) { |
| 156 |
|
| 157 |
if ($word !~ /\.$/) { |
| 158 |
$fname .= " " . $word; |
| 159 |
} |
| 160 |
else { $mi = substr($word, 0, 1); } |
| 161 |
|
| 162 |
$fname =~ s/^\s//g; # trim leading whitespace |
| 163 |
|
| 164 |
} |
| 165 |
|
| 166 |
return { "fname" => $fname, |
| 167 |
"mname" => $mi, |
| 168 |
"lname" => $lname }; |
| 169 |
|
| 170 |
} |
| 171 |
|
| 172 |
|
| 173 |
sub get_addr_rowid { |
| 174 |
my ($dbh, $pidm, $atyp1, $atyp2, $atyp3) = @_; |
| 175 |
|
| 176 |
prepare_repeated_sql($dbh); # sets global flag after run, so will only |
| 177 |
# execute once per package instance; |
| 178 |
|
| 179 |
$sth_qry_addr_rowid->execute($pidm, $atyp1, $atyp2, $atyp3); |
| 180 |
my @row = $sth_qry_addr_rowid->fetchrow_array; |
| 181 |
|
| 182 |
$row[0] eq $dual_rowid && return; # return null if no address |
| 183 |
|
| 184 |
return $row[0]; |
| 185 |
} |
| 186 |
|
| 187 |
sub get_addr { |
| 188 |
my ($dbh, $pidm, $atyp1, $atyp2, $atyp3) = @_; |
| 189 |
|
| 190 |
my $rowid = get_addr_rowid($dbh, $pidm, $atyp1, $atyp2, $atyp3); |
| 191 |
|
| 192 |
prepare_repeated_sql($dbh); # sets global flag after run, so will only |
| 193 |
# execute once per package instance; |
| 194 |
|
| 195 |
if ($rowid) { |
| 196 |
$sth_qry_addr->execute($rowid); |
| 197 |
my @row = $sth_qry_addr->fetchrow_array; |
| 198 |
|
| 199 |
my $nation = $row[7] ? $row[7] : ""; |
| 200 |
my $natn_code = $row[8] ? $row[8] : ""; |
| 201 |
my $county = $row[9] ? $row[9] : ""; |
| 202 |
my $cnty_code = $row[11] ? $row[11] : ""; |
| 203 |
|
| 204 |
# return ref to anonymous hash |
| 205 |
return { "atyp" => $row[0], |
| 206 |
"street" => $row[1], |
| 207 |
"street2" => $row[2], |
| 208 |
"street3" => $row[3], |
| 209 |
"city" => $row[4], |
| 210 |
"state" => $row[5], |
| 211 |
"zip" => $row[6], |
| 212 |
"nation" => $nation, |
| 213 |
"natn_code" => $natn_code, |
| 214 |
"county" => $county, |
| 215 |
"cnty_code" => $cnty_code, |
| 216 |
"state_desc" => $row[10], |
| 217 |
"phone" => get_phone($dbh, $pidm, $row[0] ) }; |
| 218 |
} |
| 219 |
|
| 220 |
# fall-through |
| 221 |
return { "atyp" => "", |
| 222 |
"street" => "NO ADDRESS", |
| 223 |
"street2" => "", |
| 224 |
"street3" => "", |
| 225 |
"city" => "", |
| 226 |
"state" => "", |
| 227 |
"zip" => "", |
| 228 |
"nation" => "", |
| 229 |
"natn_code" => "", |
| 230 |
"county" => "", |
| 231 |
"cnty_code" => "", |
| 232 |
"state_desc" => "", |
| 233 |
"phone" => "NO PHONE" }; |
| 234 |
} |
| 235 |
|
| 236 |
sub get_phone { |
| 237 |
my ($dbh, $pidm, $atyp) = @_; |
| 238 |
|
| 239 |
prepare_repeated_sql($dbh); # sets global flag after run, so will only |
| 240 |
# execute once per package instance; |
| 241 |
|
| 242 |
if ($atyp) { |
| 243 |
$sth_qry_phone->execute($pidm, $atyp); |
| 244 |
my @row = $sth_qry_phone->fetchrow_array; |
| 245 |
|
| 246 |
$row[0] && return $row[0]; |
| 247 |
} |
| 248 |
|
| 249 |
return "NO PHONE"; # fall-through |
| 250 |
} |
| 251 |
|
| 252 |
sub real_ssn { |
| 253 |
my ($dbh, $pidm) = @_; |
| 254 |
|
| 255 |
prepare_repeated_sql($dbh); |
| 256 |
|
| 257 |
$sth_qry_real_ssn->execute($pidm); |
| 258 |
my ($ssn) = $sth_qry_real_ssn->fetchrow_array; |
| 259 |
|
| 260 |
return $ssn; |
| 261 |
|
| 262 |
} |
| 263 |
|
| 264 |
sub email { |
| 265 |
my ($dbh, $pidm, $emal_code) = @_; |
| 266 |
|
| 267 |
my (@row); |
| 268 |
|
| 269 |
# for performance we will only prepare repeated sql once |
| 270 |
if (exists $glb_prepared_sql{"sth_qry_email"} ) { |
| 271 |
$sth_qry_email = $glb_prepared_sql{"sth_qry_email"}; |
| 272 |
} |
| 273 |
else { |
| 274 |
$sth_qry_email = $dbh->prepare( q{ |
| 275 |
select goremal_email_address |
| 276 |
from goremal |
| 277 |
where goremal_pidm = ? and |
| 278 |
goremal_emal_code = ? and |
| 279 |
goremal_status_ind = 'A' and |
| 280 |
upper(goremal_email_address) != 'STUDENT@WOU.EDU' |
| 281 |
order by goremal_preferred_ind desc } ); # 'Y' before 'N' |
| 282 |
|
| 283 |
$glb_prepared_sql{"sth_qry_email"} = $sth_qry_email; |
| 284 |
} |
| 285 |
|
| 286 |
$sth_qry_email->execute($pidm, $emal_code); |
| 287 |
|
| 288 |
@row = $sth_qry_email->fetchrow_array; |
| 289 |
|
| 290 |
return { "pidm" => $pidm, |
| 291 |
"email_address" => $row[0] }; |
| 292 |
} |
| 293 |
|
| 294 |
sub stu_email { |
| 295 |
my ($dbh, $pidm) = @_; |
| 296 |
|
| 297 |
my ($rh_email); |
| 298 |
|
| 299 |
$rh_email = email($dbh, $pidm, "STDN"); |
| 300 |
|
| 301 |
if (! $rh_email->{email_address} ) { |
| 302 |
$rh_email = email($dbh, $pidm, "ADMS"); |
| 303 |
} |
| 304 |
|
| 305 |
return $rh_email; |
| 306 |
} |
| 307 |
|
| 308 |
# term_age() NOTE: $birthdate must be formatted mm/dd/yyyy |
| 309 |
sub term_age { |
| 310 |
my ($dbh, $term, $birthdate) = @_; |
| 311 |
|
| 312 |
my $term_age; |
| 313 |
|
| 314 |
# for performance we will only prepare repeated sql once |
| 315 |
if (exists $glb_prepared_sql{"sth_qry_term_age"} ) { |
| 316 |
$sth_qry_term_age = $glb_prepared_sql{"sth_qry_term_age"}; |
| 317 |
} |
| 318 |
else { |
| 319 |
$sth_qry_term_age = $dbh->prepare( q{ |
| 320 |
select saturn.curr_age(sobptrm_end_date, to_date(?, 'mm/dd/yyyy') ) |
| 321 |
from sobptrm |
| 322 |
where sobptrm_term_code = ? } ); |
| 323 |
|
| 324 |
$glb_prepared_sql{"sth_qry_term_age"} = $sth_qry_term_age; |
| 325 |
} |
| 326 |
|
| 327 |
$sth_qry_term_age->execute($birthdate, $term); |
| 328 |
|
| 329 |
($term_age) = $sth_qry_term_age->fetchrow_array; |
| 330 |
|
| 331 |
return $term_age; |
| 332 |
} |
| 333 |
|
| 334 |
|
| 335 |
# ============================================================================ |
| 336 |
# Subroutines |
| 337 |
# ============================================================================ |
| 338 |
sub prepare_repeated_sql { |
| 339 |
|
| 340 |
# make sure only executes once per package instance |
| 341 |
$glb_sql_prepared && return; |
| 342 |
$glb_sql_prepared = 1; |
| 343 |
|
| 344 |
my ($dbh) = @_; |
| 345 |
|
| 346 |
my $sql_qry_id = |
| 347 |
"select spriden_first_name, \ |
| 348 |
spriden_mi, \ |
| 349 |
spriden_last_name, \ |
| 350 |
spriden_id, \ |
| 351 |
upper(nvl(spbpers_confid_ind, 'N') ), \ |
| 352 |
upper(nvl(spbpers_dead_ind, 'N') ), \ |
| 353 |
spbpers_citz_code, \ |
| 354 |
nvl(spbpers_sex, 'U'), \ |
| 355 |
nvl(spbpers_ethn_code, 'U'), \ |
| 356 |
nvl(stvethn_desc, 'Unknown'), \ |
| 357 |
to_char(spbpers_birth_date, 'mm/dd/yyyy'), \ |
| 358 |
saturn.age(spbpers_birth_date), \ |
| 359 |
spbpers_lgcy_code, \ |
| 360 |
spbpers_mrtl_code \ |
| 361 |
from spriden, \ |
| 362 |
spbpers, \ |
| 363 |
stvethn \ |
| 364 |
where spriden_pidm = ? and \ |
| 365 |
spriden_change_ind is null and \ |
| 366 |
spbpers_pidm (+) = spriden_pidm and \ |
| 367 |
stvethn_code (+) = spbpers_ethn_code"; |
| 368 |
|
| 369 |
my $sql_qry_addr_rowid = "select saturn.order_atyp(?, ?, ?, ?) from dual"; |
| 370 |
|
| 371 |
my $sql_qry_dual_rowid = "select rowid from dual"; |
| 372 |
|
| 373 |
my $sql_qry_addr = q{ |
| 374 |
select spraddr_atyp_code, |
| 375 |
nvl(spraddr_street_line1, 'Unknown'), |
| 376 |
nvl(spraddr_street_line2, ''), |
| 377 |
nvl(spraddr_street_line3, ''), |
| 378 |
spraddr_city, |
| 379 |
nvl(spraddr_stat_code, 'Unknown'), |
| 380 |
nvl(spraddr_zip, 'Unknown'), |
| 381 |
nvl(stvnatn_nation, 'Unknown'), |
| 382 |
spraddr_natn_code, |
| 383 |
stvcnty_desc, |
| 384 |
stvstat_desc, |
| 385 |
spraddr_cnty_code |
| 386 |
from spraddr, |
| 387 |
stvnatn, |
| 388 |
stvcnty, |
| 389 |
stvstat |
| 390 |
where spraddr.rowid = ? and |
| 391 |
stvnatn_code (+)= spraddr_natn_code and |
| 392 |
stvcnty_code (+)= spraddr_cnty_code and |
| 393 |
stvstat_code (+)= spraddr_stat_code }; |
| 394 |
|
| 395 |
my $sql_qry_phone = |
| 396 |
"select '(' || sprtele_phone_area || ')' || \ |
| 397 |
substr(sprtele_phone_number, 1, 3) || '-' || \ |
| 398 |
substr(sprtele_phone_number, 4) \ |
| 399 |
from sprtele \ |
| 400 |
where sprtele_pidm = ? and \ |
| 401 |
sprtele_atyp_code = ?"; |
| 402 |
|
| 403 |
$sth_qry_id = $dbh->prepare($sql_qry_id); |
| 404 |
$sth_qry_dual_rowid = $dbh->prepare($sql_qry_dual_rowid); |
| 405 |
$sth_qry_addr_rowid = $dbh->prepare($sql_qry_addr_rowid); |
| 406 |
$sth_qry_addr = $dbh->prepare($sql_qry_addr); |
| 407 |
$sth_qry_phone = $dbh->prepare($sql_qry_phone); |
| 408 |
|
| 409 |
$sth_qry_real_ssn = $dbh->prepare( q{ select real_ssn(?) from dual } ); |
| 410 |
|
| 411 |
$sth_qry_dual_rowid->execute; |
| 412 |
my @row = $sth_qry_dual_rowid->fetchrow_array; |
| 413 |
$dual_rowid = $row[0]; |
| 414 |
} |
| 415 |
|
| 416 |
return 1; |
| 417 |
|
| 418 |
|
Parent Directory
| 
Revision Log