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 |
|