File Coverage

blib/lib/UMLS/Interface/CuiFinder.pm
Criterion Covered Total %
statement 107 2560 4.1
branch 11 888 1.2
condition 3 477 0.6
subroutine 11 102 10.7
pod 0 1 0.0
total 132 4028 3.2


line stmt bran cond sub pod time code
1             # UMLS::Interface::CuiFinder
2             # (Last Updated $Id: CuiFinder.pm,v 1.80 2016/01/07 22:49:33 btmcinnes Exp $)
3             #
4             # Perl module that provides a perl interface to the
5             # Unified Medical Language System (UMLS)
6             #
7             # Copyright (c) 2004-2011,
8             #
9             # Bridget T. McInnes, University of Minnesota, Twin Cities
10             # bthomson at cs.umn.edu
11             #
12             # Siddharth Patwardhan, University of Utah, Salt Lake City
13             # sidd at cs.utah.edu
14             #
15             # Serguei Pakhomov, University of Minnesota, Twin Cities
16             # pakh0002 at umn.edu
17             #
18             # Ted Pedersen, University of Minnesota, Duluth
19             # tpederse at d.umn.edu
20             #
21             # Ying Liu, University of Minnesota, Twin Cities
22             # liux0935 at umn.edu
23             #
24             # This program is free software; you can redistribute it and/or
25             # modify it under the terms of the GNU General Public License
26             # as published by the Free Software Foundation; either version 2
27             # of the License, or (at your option) any later version.
28             #
29             # This program is distributed in the hope that it will be useful,
30             # but WITHOUT ANY WARRANTY; without even the implied warranty of
31             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
32             # GNU General Public License for more details.
33             #
34             # You should have received a copy of the GNU General Public License
35             # along with this program; if not, write to
36             #
37             # The Free Software Foundation, Inc.,
38             # 59 Temple Place - Suite 330,
39             # Boston, MA 02111-1307, USA.
40              
41             package UMLS::Interface::CuiFinder;
42              
43 24     24   122 use Fcntl;
  24         43  
  24         7050  
44 24     24   125 use strict;
  24         45  
  24         516  
45 24     24   119 use warnings;
  24         43  
  24         862  
46 24     24   121 use DBI;
  24         37  
  24         1013  
47 24     24   115 use bytes;
  24         43  
  24         111  
48              
49 24     24   18192 use Digest::SHA1 qw(sha1 sha1_hex sha1_base64);
  24         18602  
  24         673504  
50              
51             # error handling variables
52             my $errorhandler = "";
53             my $pkg = "UMLS::Interface::CuiFinder";
54              
55             # debug variables
56             local(*DEBUG_FILE);
57              
58             # global variables
59             my $debug = 0;
60             my $umlsRoot = "C0000000";
61             my $version = "";
62              
63             # list of allowable sources
64             my $sources = "";
65             my %sabHash = ();
66             my %sabnamesHash = ();
67             my $sabstring = "";
68              
69             # list of allowable relations
70             my $relations = "";
71             my $childRelations = "";
72             my $parentRelations = "";
73             my $relstring = "";
74             my $relastring = "";
75              
76             # upper level taxonomy
77             my %parentTaxonomyArray = ();
78             my %childTaxonomyArray = ();
79              
80             # list of interested cuis - default is
81             # all given the specified set of sources
82             # and relations.
83             my %cuiListHash = ();
84              
85             # initialize the semantic groups and relations hash
86             my %semanticGroups = ();
87             my %semanticRelations = ();
88              
89             # database
90             my $indexDB = "umlsinterfaceindex";
91             my $umlsinterface = $ENV{UMLSINTERFACE_CONFIGFILE_DIR};
92              
93             # table names
94             my $tableName = "";
95             my $intrinsicTable = "";
96             my $parentTable = "";
97             my $childTable = "";
98             my $tableFile = "";
99             my $intrinsicTableHuman= "";
100             my $parentTableHuman = "";
101             my $childTableHuman = "";
102             my $tableNameHuman = "";
103             my $configFile = "";
104             my $childFile = "";
105             my $parentFile = "";
106             my $infoTable = "";
107             my $infoTableHuman = "";
108             my $cacheTable = "";
109             my $cacheTableHuman = "";
110              
111             # flags and options
112             my $umlsall = 0;
113             my $sabdef_umlsall = 0;
114             my $option_verbose = 0;
115             my $option_cuilist = 0;
116             my $option_t = 0;
117             my $option_config = 0;
118             my $defflag = 0;
119              
120             # definition containers
121             my $sabdefsources = "";
122             my %relDefHash = ();
123             my %sabDefHash = ();
124             my $reldefstring = "";
125             my $sabdefstring = "";
126             my $reladefchildren = "";
127             my $reladefparents = "";
128              
129             my %parameters = ();
130              
131             ######################################################################
132             # functions to initialize the package
133             ######################################################################
134              
135             # method to create a new UMLS::Interface object
136             # input : $parameters <- reference to a hash
137             # output: $self
138             sub new {
139              
140 22     22 0 60 my $self = {};
141 22         53 my $className = shift;
142 22         45 my $params = shift;
143              
144             # bless the object.
145 22         51 bless($self, $className);
146              
147 22         111 $self->_initializeGlobalVariables();
148              
149             # initialize error handler
150 22         94 $errorhandler = UMLS::Interface::ErrorHandler->new();
151 22 50       103 if(! defined $errorhandler) {
152 0         0 print STDERR "The error handler did not get passed properly.\n";
153 0         0 exit;
154             }
155              
156             # initialize the object.
157 22         97 $self->_initialize($params);
158              
159             # set the semantic groups
160 0         0 $self->_setSemanticGroups();
161              
162 0         0 return $self;
163             }
164              
165             # method to re-initialize the UMLS::Interface parameters
166             sub _reConfig {
167              
168 0     0   0 my $self = shift;
169 0         0 my $params = shift;
170              
171 0         0 my $function = "_reConfig";
172 0         0 &_debug($function);
173              
174             # re initialize the global variables
175 0         0 $self->_initializeGlobalVariables();
176              
177             # initialize the object.
178 0         0 $self->_initialize($params);
179              
180 0         0 return $self;
181            
182            
183             }
184             # method to initialize the UMLS::Interface global variables
185             sub _initializeGlobalVariables {
186            
187 22     22   53 my $self = shift;
188              
189 22         64 my $function = "_initializeGlobalVariables";
190 22         98 &_debug($function);
191            
192             # global variables
193 22         40 $debug = 0;
194 22         60 $version = "";
195              
196             # list of allowable sources
197 22         58 $sources = "";
198 22         54 %sabHash = ();
199 22         59 %sabnamesHash = ();
200 22         56 $sabstring = "";
201              
202             # list of allowable relations
203 22         52 $relations = "";
204 22         48 $childRelations = "";
205 22         47 $parentRelations = "";
206 22         47 $relstring = "";
207 22         47 $relastring = "";
208              
209             # upper level taxonomy
210 22         58 %parentTaxonomyArray = ();
211 22         54 %childTaxonomyArray = ();
212              
213             # list of interested cuis - default is
214             # all given the specified set of sources
215             # and relations.
216 22         52 %cuiListHash = ();
217              
218              
219             # table names
220 22         53 $tableName = "";
221 22         47 $parentTable = "";
222 22         57 $intrinsicTable = "";
223 22         59 $childTable = "";
224 22         49 $tableFile = "";
225 22         42 $intrinsicTableHuman= "";
226 22         46 $parentTableHuman = "";
227 22         50 $childTableHuman = "";
228 22         44 $tableNameHuman = "";
229 22         52 $configFile = "";
230 22         54 $childFile = "";
231 22         42 $parentFile = "";
232 22         45 $infoTable = "";
233 22         49 $infoTableHuman = "";
234 22         47 $cacheTable = "";
235 22         45 $cacheTableHuman = "";
236              
237             # flags and options
238 22         46 $umlsall = 0;
239 22         44 $option_verbose = 0;
240 22         38 $option_cuilist = 0;
241 22         40 $option_t = 0;
242 22         41 $option_config = 0;
243              
244             # definition containers
245 22         50 $sabdefsources = "";
246 22         57 %relDefHash = ();
247 22         52 %sabDefHash = ();
248 22         50 $reldefstring = "";
249 22         51 $sabdefstring = "";
250 22         43 $reladefchildren = "";
251 22         50 $reladefparents = "";
252 22         56 %parameters = ();
253              
254             }
255              
256             # method to initialize the UMLS::Interface object.
257             # input : $parameters <- reference to a hash
258             # output:
259             sub _initialize {
260              
261 22     22   49 my $self = shift;
262 22         54 my $params = shift;
263              
264 22         43 my $function = "_initialize";
265 22         70 &_debug($function);
266              
267             # check self
268 22 50 33     196 if(!defined $self || !ref $self) {
269 0         0 $errorhandler->_error($pkg, $function, "", 2);
270             }
271              
272              
273 22 50       81 $params = {} if(!defined $params);
274              
275             # get some of the parameters
276 22         60 my $config = $params->{'config'};
277 22         54 my $cuilist = $params->{'cuilist'};
278 22         50 my $database = $params->{'database'};
279              
280             # to store the database object
281 22         117 my $db = $self->_setDatabase($params);
282            
283             # set up the options
284 0         0 $self->_setOptions($params);
285              
286             # check that all of the tables required exist in the db
287 0         0 $self->_checkTablesExist();
288              
289             # set the version information
290 0         0 $self->_setVersion();
291              
292             # set the configuration
293 0         0 $self->_config($config);
294            
295             # set the umls interface configuration variable
296 0         0 $self->_setEnvironmentVariable();
297              
298             # set the table and file names for indexing
299 0         0 $self->_setConfigurationFile();
300              
301             # set the configfile
302 0         0 $self->_setConfigFile();
303              
304             # load the cuilist if it has been defined
305 0         0 $self->_loadCuiList($cuilist);
306              
307             # create the index database
308 0         0 $self->_createIndexDB();
309              
310             # connect to the index database
311 0         0 $self->_connectIndexDB();
312              
313             # set the upper level taxonomy
314 0         0 $self->_setUpperLevelTaxonomy();
315              
316             # set the cache tables
317 0         0 $self->_setCacheTable();
318             }
319              
320             # this function returns the umls root
321             # input :
322             # output: $string <- string containing the root
323             sub _root {
324              
325 0     0   0 return $umlsRoot;
326             }
327              
328             # this function sets the upper level taxonomy between
329             # the sources and the root UMLS node
330             # input :
331             # output:
332             sub _setCacheTable {
333              
334 0     0   0 my $self = shift;
335              
336 0         0 my $function = "_setCacheTable";
337 0         0 &_debug($function);
338              
339             # check self
340 0 0 0     0 if(!defined $self || !ref $self) {
341 0         0 $errorhandler->_error($pkg, $function, "", 2);
342             }
343              
344             # set the sourceDB handler
345 0         0 my $sdb = $self->{'sdb'};
346 0 0       0 if(!$sdb) { $errorhandler->_error($pkg, $function, "Error with sdb.", 3); }
  0         0  
347              
348             # check if the cache table exists
349             # if does just return otherwise create it
350 0 0       0 if($self->_checkTableExists($cacheTable)) {
351 0         0 return;
352             }
353             else {
354             # create cache table
355 0         0 $sdb->do("CREATE TABLE IF NOT EXISTS $cacheTable (CUI1 char(8), CUI2 char(8), LENGTH char(8))");
356 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
357             # store the name in the table index
358 0         0 $sdb->do("INSERT INTO tableindex (TABLENAME, HEX) VALUES ('$cacheTableHuman', '$cacheTable')");
359 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
360             }
361             }
362              
363             # this function sets the upper level taxonomy between
364             # the sources and the root UMLS node
365             # input :
366             # output:
367             sub _setUpperLevelTaxonomy {
368              
369 0     0   0 my $self = shift;
370              
371 0         0 my $function = "_setUpperLevelTaxonomy";
372 0         0 &_debug($function);
373              
374             # check self
375 0 0 0     0 if(!defined $self || !ref $self) {
376 0         0 $errorhandler->_error($pkg, $function, "", 2);
377             }
378              
379             # set the sourceDB handler
380 0         0 my $sdb = $self->{'sdb'};
381 0 0       0 if(!$sdb) { $errorhandler->_error($pkg, $function, "Error with sdb.", 3); }
  0         0  
382              
383             # check if the taxonomy is already set
384 0         0 my $ckeys = keys %childTaxonomyArray;
385 0         0 my $pkeys = keys %parentTaxonomyArray;
386 0 0       0 if($pkeys > 0) { return; }
  0         0  
387              
388             # check if the parent and child tables exist and
389             # if they do just return otherwise create them
390 0 0 0     0 if($self->_checkTableExists($childTable) and
391             $self->_checkTableExists($parentTable)) {
392 0         0 $self->_loadTaxonomyArrays();
393 0         0 return;
394             }
395             else {
396 0         0 $self->_createTaxonomyTables();
397             }
398              
399             # if the parent and child files exist just load them into the database
400 0 0 0     0 if( (-e $childFile) and (-e $parentFile) ) {
401 0         0 $self->_loadTaxonomyTables();
402             }
403             # otherwise we need to create them
404             else {
405 0         0 $self->_createUpperLevelTaxonomy();
406             }
407             }
408              
409             # this function creates the upper level taxonomy between the
410             # the sources and the root UMLS node
411             # this function creates the upper level taxonomy between the
412             # the sources and the root UMLS node
413             # input :
414             # output:
415             sub _createUpperLevelTaxonomy {
416              
417 0     0   0 my $self = shift;
418              
419 0         0 my $function = "_createUpperLevelTaxonomy";
420 0         0 &_debug($function);
421              
422             # check self
423 0 0 0     0 if(!defined $self || !ref $self) {
424 0         0 $errorhandler->_error($pkg, $function, "", 2);
425             }
426              
427             # set the index DB handler
428 0         0 my $sdb = $self->{'sdb'};
429 0 0       0 if(!$sdb) { $errorhandler->_error($pkg, $function, "Error with sdb.", 3); }
  0         0  
430              
431             # set up the database
432 0         0 my $db = $self->{'db'};
433 0 0       0 if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0         0  
434              
435             # open the parent and child files to store the upper level
436             # taxonomy information if the verbose option is defined
437 0 0       0 if($option_verbose) {
438 0 0       0 open(CHD, ">$childFile") || die "Could not open $childFile\n";
439 0 0       0 open(PAR, ">$parentFile") || die "Could not open $parentFile\n";
440             }
441              
442 0         0 foreach my $sab (sort keys %sabnamesHash) {
443              
444             # get the sab's cui
445 0         0 my $sab_cui = $self->_getSabCui($sab);
446            
447             # select all the CUIs from MRREL
448 0         0 my $allCuis = $self->_getCuis($sab);
449              
450             # select all the CUI1s from MRREL that have a parent link
451             # if a parent relation exists
452 0         0 my $parCuis = "";
453 0         0 my %parCuisHash = ();
454 0 0       0 if( !($parentRelations=~/\(\)/) ) {
455 0         0 $parCuis = $db->selectcol_arrayref("select CUI1 from MRREL where ($parentRelations) and (SAB=\'$sab\') and SUPPRESS='N'");
456 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
457              
458             # load the cuis that have a parent into a temporary hash
459 0         0 foreach my $cui (@{$parCuis}) { $parCuisHash{$cui}++; }
  0         0  
  0         0  
460             }
461              
462             # load the cuis that do not have a parent into the parent
463             # and chilren taxonomy for the upper level
464 0         0 foreach my $cui (@{$allCuis}) {
  0         0  
465              
466             # if the cui has a parent move on
467 0 0       0 if(exists $parCuisHash{$cui}) { next; }
  0         0  
468              
469             # already seen this cui so move on
470 0 0       0 if(exists $parentTaxonomyArray{$cui}) { next; }
  0         0  
471              
472              
473 0 0       0 if($sab_cui eq $cui) { next; }
  0         0  
474              
475 0         0 push @{$parentTaxonomyArray{$cui}}, $sab_cui;
  0         0  
476 0         0 push @{$childTaxonomyArray{$sab_cui}}, $cui;
  0         0  
477              
478 0         0 $sdb->do("INSERT INTO $parentTable (CUI1, CUI2) VALUES ('$cui', '$sab_cui')");
479 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
480              
481 0         0 $sdb->do("INSERT INTO $childTable (CUI1, CUI2) VALUES ('$sab_cui', '$cui')");
482 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
483              
484             # print this information to the parent and child
485             # file is the verbose option has been set
486 0 0       0 if($option_verbose) {
487 0         0 print PAR "$cui $sab_cui\n";
488 0         0 print CHD "$sab_cui $cui\n";
489             }
490             }
491              
492             # add the sab cuis to the parent and children Taxonomy
493 0         0 push @{$parentTaxonomyArray{$sab_cui}}, $umlsRoot;
  0         0  
494 0         0 push @{$childTaxonomyArray{$umlsRoot}}, $sab_cui;
  0         0  
495              
496             # print it to the table if the verbose option is set
497 0 0       0 if($option_verbose) {
498 0         0 print PAR "$sab_cui $umlsRoot\n";
499 0         0 print CHD "$umlsRoot $sab_cui\n";
500             }
501              
502             # store this information in the database
503 0         0 $sdb->do("INSERT INTO $parentTable (CUI1, CUI2) VALUES ('$sab_cui', '$umlsRoot')");
504 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
505              
506 0         0 $sdb->do("INSERT INTO $childTable (CUI1, CUI2) VALUES ('$umlsRoot', '$sab_cui')");
507 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
508             }
509              
510             # close the parent and child tables if opened
511 0 0       0 if($option_verbose) { close PAR; close CHD; }
  0         0  
  0         0  
512              
513             # print out some information
514 0         0 my $pkey = keys %parentTaxonomyArray;
515 0         0 my $ckey = keys %childTaxonomyArray;
516              
517 0 0       0 if($debug) {
518 0         0 print STDERR "Taxonomy is set:\n";
519 0         0 print STDERR " parentTaxonomyArray: $pkey\n";
520 0         0 print STDERR " childTaxonomyArray: $ckey\n\n";
521             }
522             }
523              
524             # this function creates the taxonomy tables if they don't
525             # already exist in the umlsinterfaceindex database
526             # input :
527             # output:
528             sub _createTaxonomyTables {
529              
530 0     0   0 my $self = shift;
531              
532 0         0 my $function = "_createTaxonomyTables";
533 0         0 &_debug($function);
534              
535             # check self
536 0 0 0     0 if(!defined $self || !ref $self) {
537 0         0 $errorhandler->_error($pkg, $function, "", 2);
538             }
539              
540             # set the index DB handler
541 0         0 my $sdb = $self->{'sdb'};
542 0 0       0 if(!$sdb) { $errorhandler->_error($pkg, $function, "Error with sdb.", 3); }
  0         0  
543              
544             # create intrinsic table
545 0         0 $sdb->do("CREATE TABLE IF NOT EXISTS $intrinsicTable (CUI char(8), LEAVES int, SUBSUMERS int, INDEX(CUI))");
546 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
547              
548             # create parent table
549 0         0 $sdb->do("CREATE TABLE IF NOT EXISTS $parentTable (CUI1 char(8), CUI2 char(8))");
550 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
551              
552             # create child table
553 0         0 $sdb->do("CREATE TABLE IF NOT EXISTS $childTable (CUI1 char(8), CUI2 char(8))");
554 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
555              
556             # create info table
557 0         0 $sdb->do("CREATE TABLE IF NOT EXISTS $infoTable (ITEM char(8), INFO char(8))");
558 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
559              
560             # create the index table if it doesn't already exist
561 0         0 $sdb->do("CREATE TABLE IF NOT EXISTS tableindex (TABLENAME blob(1000000), HEX char(41))");
562 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
563              
564             # add them to the index table
565 0         0 $sdb->do("INSERT INTO tableindex (TABLENAME, HEX) VALUES ('$intrinsicTableHuman', '$intrinsicTable')");
566 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
567 0         0 $sdb->do("INSERT INTO tableindex (TABLENAME, HEX) VALUES ('$parentTableHuman', '$parentTable')");
568 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
569 0         0 $sdb->do("INSERT INTO tableindex (TABLENAME, HEX) VALUES ('$childTableHuman', '$childTable')");
570 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
571 0         0 $sdb->do("INSERT INTO tableindex (TABLENAME, HEX) VALUES ('$infoTableHuman', '$infoTable')");
572 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
573             }
574              
575             # this function loads the taxonomy tables if the
576             # configuration files exist for them
577             # input :
578             # output:
579             sub _loadTaxonomyTables {
580              
581 0     0   0 my $self = shift;
582              
583 0         0 my $function = "_loadTaxonomyTables";
584 0         0 &_debug($function);
585              
586             # check self
587 0 0 0     0 if(!defined $self || !ref $self) {
588 0         0 $errorhandler->_error($pkg, $function, "", 2);
589             }
590              
591             # set the index DB handler
592 0         0 my $sdb = $self->{'sdb'};
593 0 0       0 if(!$sdb) { $errorhandler->_error($pkg, $function, "Error with sdb.", 3); }
  0         0  
594              
595 0 0       0 open(PAR, $parentFile) || die "Could not open $parentFile\n";
596 0 0       0 open(CHD, $childFile) || die "Could not open $childFile\n";
597              
598             # load parent table
599 0         0 while() {
600 0         0 chomp;
601 0 0       0 if($_=~/^\s*$/) { next; }
  0         0  
602 0         0 my ($cui1, $cui2) = split/\s+/;
603              
604 0         0 my $arrRef = $sdb->do("INSERT INTO $parentTable (CUI1, CUI2) VALUES ('$cui1', '$cui2')");
605 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
606             }
607              
608             # load child table
609 0         0 while() {
610 0         0 chomp;
611 0 0       0 if($_=~/^\s*$/) { next; }
  0         0  
612 0         0 my ($cui1, $cui2) = split/\s+/;
613 0         0 my $arrRef = $sdb->do("INSERT INTO $childTable (CUI1, CUI2) VALUES ('$cui1', '$cui2')");
614 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
615             }
616 0         0 close PAR; close CHD;
  0         0  
617             }
618              
619             # this function sets the taxonomy arrays
620             # input :
621             # output:
622             sub _loadTaxonomyArrays {
623              
624 0     0   0 my $self = shift;
625              
626 0         0 my $function = "_loadTaxonomyArrays";
627 0         0 &_debug($function);
628              
629             # check self
630 0 0 0     0 if(!defined $self || !ref $self) {
631 0         0 $errorhandler->_error($pkg, $function, "", 2);
632             }
633              
634             # set the index DB handler
635 0         0 my $sdb = $self->{'sdb'};
636 0 0       0 if(!$sdb) { $errorhandler->_error($pkg, $function, "Error with sdb.", 3); }
  0         0  
637              
638             # set the parent taxonomy
639 0         0 my $sql = qq{ SELECT CUI1, CUI2 FROM $parentTable};
640 0         0 my $sth = $sdb->prepare( $sql );
641 0         0 $sth->execute();
642 0         0 my($cui1, $cui2);
643 0         0 $sth->bind_columns( undef, \$cui1, \$cui2 );
644 0         0 while( $sth->fetch() ) {
645 0         0 push @{$parentTaxonomyArray{$cui1}}, $cui2;
  0         0  
646             }
647 0         0 $errorhandler->_checkDbError($pkg, $function, $sth);
648 0         0 $sth->finish();
649              
650             # set the child taxonomy
651 0         0 $sql = qq{ SELECT CUI1, CUI2 FROM $childTable};
652 0         0 $sth = $sdb->prepare( $sql );
653 0         0 $sth->execute();
654 0         0 $sth->bind_columns( undef, \$cui1, \$cui2 );
655 0         0 while( $sth->fetch() ) {
656 0         0 push @{$childTaxonomyArray{$cui1}}, $cui2;
  0         0  
657             }
658 0         0 $errorhandler->_checkDbError($pkg, $function, $sth);
659 0         0 $sth->finish();
660             }
661              
662             # function checks to see if a given table exists
663             # input : $table <- string
664             # output: 0 | 1 <- integers
665             sub _checkTableExists {
666              
667 0     0   0 my $self = shift;
668 0         0 my $table = shift;
669              
670 0         0 my $function = "_checkTableExists";
671 0         0 &_debug($function);
672              
673             # check self
674 0 0 0     0 if(!defined $self || !ref $self) {
675 0         0 $errorhandler->_error($pkg, $function, "", 2);
676             }
677              
678 0 0       0 if(!defined $table) {
679 0         0 $errorhandler->_error($pkg, $function, "Error with input variable \$table.", 4);
680             }
681              
682             # check that the database exists
683 0         0 my $sdb = $self->{'sdb'};
684 0 0       0 if(!$sdb) { $errorhandler->_error($pkg, $function, "Error with sdb.", 3); }
  0         0  
685              
686             # set an execute the query to show all of the tables
687 0         0 my $sth = $sdb->prepare("show tables");
688 0         0 $sth->execute();
689 0         0 $errorhandler->_checkDbError($pkg, $function, $sth);
690              
691 0         0 my $t = "";
692 0         0 my %tables = ();
693 0         0 while(($t) = $sth->fetchrow()) {
694 0         0 $tables{lc($t)} = 1;
695             }
696 0         0 $sth->finish();
697              
698 0 0       0 if(! (exists$tables{lc($table)})) { return 0; }
  0         0  
699 0         0 else { return 1; }
700              
701             }
702              
703             # connect the database to the source db that holds
704             # the path tables for user specified source(s) and
705             # relation(s)
706             # input :
707             # output: $sdb <- reference to the database
708             sub _connectIndexDB {
709              
710 0     0   0 my $self = shift;
711              
712 0         0 my $function = "_connectIndexDB";
713 0         0 &_debug($function);
714              
715             # check self
716 0 0 0     0 if(!defined $self || !ref $self) {
717 0         0 $errorhandler->_error($pkg, $function, "", 2);
718             }
719              
720 0         0 my $sdb = "";
721 0 0       0 if(defined $self->{'username'}) {
722              
723 0         0 my $username = $self->{'username'};
724 0         0 my $password = $self->{'password'};
725 0         0 my $hostname = $self->{'hostname'};
726 0         0 my $socket = $self->{'socket'};
727              
728 0         0 eval{$sdb = DBI->connect("DBI:mysql:database=$indexDB;mysql_socket=$socket;host=$hostname",
  0         0  
729             $username, $password,
730             {RaiseError => 1, PrintError => 1, AutoCommit => 0 });};
731              
732 0 0       0 if($@) { $errorhandler->_error($pkg, $function, "No database to connect to", 1); }
  0         0  
733             }
734             else {
735 0         0 my $dsn = "DBI:mysql:$indexDB;mysql_read_default_group=client;";
736 0         0 eval{$sdb = DBI->connect($dsn);};
  0         0  
737 0 0       0 if($@) { $errorhandler->_error($pkg, $function, "No database to connect to", 1); }
  0         0  
738             }
739              
740 0         0 $errorhandler->_checkDbError($pkg, $function, $sdb);
741              
742             # set database parameters
743 0         0 $sdb->{'mysql_enable_utf8'} = 1;
744 0         0 $sdb->do('SET NAMES utf8');
745 0         0 $sdb->{mysql_auto_reconnect} = 1;
746              
747 0         0 $self->{'sdb'} = $sdb;
748              
749 0         0 return $sdb;
750             }
751              
752             # return the database connection to the umlsinterfaceindex
753             # input :
754             # output: $sdb <- database handler
755             sub _getIndexDB {
756 0     0   0 my $self = shift;
757              
758 0         0 my $function = "_getIndexDB";
759 0         0 &_debug($function);
760              
761             # check self
762 0 0 0     0 if(!defined $self || !ref $self) {
763 0         0 $errorhandler->_error($pkg, $function, "", 2);
764             }
765              
766             # get the databawse
767 0         0 my $sdb = $self->{'sdb'};
768 0 0       0 if(!$sdb) { $errorhandler->_error($pkg, $function, "Error with sdb.", 3); }
  0         0  
769              
770             # return the database
771 0         0 return $sdb;
772             }
773              
774             # return the database connection to the umls database
775             # input :
776             # output: $db <- database handler
777             sub _getDB {
778 0     0   0 my $self = shift;
779              
780 0         0 my $function = "_getDB";
781 0         0 &_debug($function);
782              
783             # check self
784 0 0 0     0 if(!defined $self || !ref $self) {
785 0         0 $errorhandler->_error($pkg, $function, "", 2);
786             }
787              
788             # get the databawse
789 0         0 my $db = $self->{'db'};
790 0 0       0 if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0         0  
791              
792             # return the database
793 0         0 return $db;
794             }
795              
796             # this function creates the umlsinterfaceindex database connection
797             # input :
798             # output:
799             sub _createIndexDB {
800              
801 0     0   0 my $self = shift;
802              
803 0         0 my $function = "_createIndexDB";
804 0         0 &_debug($function);
805              
806             # check self
807 0 0 0     0 if(!defined $self || !ref $self) {
808 0         0 $errorhandler->_error($pkg, $function, "", 2);
809             }
810              
811             # check that the database exists
812 0         0 my $db = $self->{'db'};
813 0 0       0 if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0         0  
814              
815             # show all of the databases
816 0         0 my $sth = $db->prepare("show databases");
817 0         0 $sth->execute();
818 0         0 $errorhandler->_checkDbError($pkg, $function, $sth);
819              
820             # get all the databases in mysql
821 0         0 my $database = "";
822 0         0 my %databases = ();
823 0         0 while(($database) = $sth->fetchrow()) {
824 0         0 $databases{$database}++;
825             }
826 0         0 $sth->finish();
827              
828             # removing any spaces that may have been
829             # introduced in while creating its name
830 0         0 $indexDB=~s/\s+//g;
831              
832             # if the database doesn't exist create it
833 0 0       0 if(! (exists $databases{$indexDB})) {
834 0         0 $db->do("create database $indexDB");
835 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
836             }
837             }
838              
839             # gets the DUI of a given CUI
840             # input: $concept -> string containing the cui
841             # output: $dui -> string containing the dui
842             sub _getDUI {
843            
844 0     0   0 my $self = shift;
845 0         0 my $concept = shift;
846            
847 0         0 my $function = "_getDUI";
848            
849             # check input values
850 0 0 0     0 if(!defined $self || !ref $self) {
851 0         0 $errorhandler->_error($pkg, $function, "", 2);
852             }
853            
854             # check parameters
855 0 0       0 if(!defined $concept) {
856 0         0 $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
857             }
858            
859             # set the database
860 0         0 my $db = $self->{'db'};
861 0 0       0 if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0         0  
862              
863 0         0 my $duis = $db->selectcol_arrayref("select SDUI from MRCONSO where CUI=\'$concept\' and SAB=\'MSH\'");
864            
865 0         0 my $dui = shift @{$duis};
  0         0  
866              
867 0         0 return $dui;
868             }
869              
870              
871             # checks to see if a concept is in the CuiList
872             # input : $concept -> string containing the cui
873             # output: 1|0 -> indicating if the cui is in the cuilist
874             sub _inCuiList {
875              
876 0     0   0 my $self = shift;
877 0         0 my $concept = shift;
878              
879 0         0 my $function = "_inCuiList";
880              
881             # check input vluaes
882 0 0 0     0 if(!defined $self || !ref $self) {
883 0         0 $errorhandler->_error($pkg, $function, "", 2);
884             }
885              
886             # check parameters
887 0 0       0 if(!defined $concept) {
888 0         0 $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
889             }
890              
891 0 0       0 if(exists $cuiListHash{$concept}) { return 1; }
  0         0  
892 0         0 else { return 0; }
893             }
894              
895              
896             # if the cuilist option is specified load the information
897             # input : $cuilist <- file containing the list of cuis
898             # output:
899             sub _loadCuiList {
900              
901 0     0   0 my $self = shift;
902 0         0 my $cuilist = shift;
903              
904 0         0 my $function = "_loadCuiList";
905              
906             # check the input values
907 0 0 0     0 if(!defined $self || !ref $self) {
908 0         0 $errorhandler->_error($pkg, $function, "", 2);
909             }
910              
911 0 0       0 if(defined $cuilist) {
912 0 0       0 open(CUILIST, $cuilist) || die "Could not open the cuilist file: $cuilist\n";
913 0         0 while() {
914 0         0 chomp;
915              
916 0 0       0 if(! ($errorhandler->_validCui($_)) ) {
917 0         0 $errorhandler->_error($pkg, $function, "Incorrect input value ($_) in cuilist.", 6);
918             }
919              
920 0         0 $cuiListHash{$_}++;
921             }
922             }
923             }
924              
925             # create the configuration file
926             # input :
927             # output:
928             sub _setConfigFile {
929              
930 0     0   0 my $self = shift;
931              
932 0 0       0 if($option_verbose) {
933              
934 0         0 my $function = "_setConfigFile";
935 0         0 &_debug($function);
936              
937 0 0 0     0 if(!defined $self || !ref $self) {
938 0         0 $errorhandler->_error($pkg, $function, "", 2);
939             }
940              
941 0 0       0 if(! (-e $configFile)) {
942              
943 0 0       0 open(CONFIG, ">$configFile") ||
944             die "Could not open configuration file: $configFile\n";
945              
946 0         0 my @sarray = ();
947 0         0 my @rarray = ();
948              
949 0         0 print CONFIG "SAB :: include ";
950 0         0 while($sources=~/=\'(.*?)\'/g) { push @sarray, $1; }
  0         0  
951 0         0 my $slist = join ", ", @sarray;
952 0         0 print CONFIG "$slist\n";
953              
954 0         0 print CONFIG "REL :: include ";
955 0         0 while($relations=~/=\'(.*?)\'/g) { push @rarray, $1; }
  0         0  
956 0         0 my $rlist = join ", ", @rarray;
957 0         0 print CONFIG "$rlist\n";
958              
959 0         0 close CONFIG;
960              
961 0         0 my $temp = chmod 0777, $configFile;
962             }
963             }
964             }
965              
966              
967             # set the table and file names that store the upper level taxonomy and path information
968             # input :
969             # output:
970             sub _setConfigurationFile {
971              
972 0     0   0 my $self = shift;
973              
974 0         0 my $function = "_setConfigurationFile";
975 0         0 &_debug($function);
976              
977             # check self
978 0 0 0     0 if(!defined $self || !ref $self) {
979 0         0 $errorhandler->_error($pkg, $function, "", 2);
980             }
981              
982             # get the database name that we are using
983 0         0 my $database = $self->{'database'};
984              
985             # set appropriate version output
986 0         0 my $ver = $version;
987 0         0 $ver=~s/-/_/g;
988              
989             # set table and upper level relations files as well the
990             # output of the configuration information for the user
991 0         0 $childFile = "$umlsinterface/$ver";
992 0         0 $parentFile = "$umlsinterface/$ver";
993 0         0 $tableFile = "$umlsinterface/$ver";
994              
995 0         0 $configFile = "$umlsinterface/$ver";
996              
997 0         0 $tableName = "$ver";
998 0         0 $intrinsicTable= "$ver";
999 0         0 $parentTable = "$ver";
1000 0         0 $childTable = "$ver";
1001 0         0 $infoTable = "$ver";
1002 0         0 $cacheTable = "$ver";
1003              
1004 0         0 my $output = "";
1005 0         0 $output .= "UMLS-Interface Configuration Information\n";
1006              
1007 0         0 my $saboutput = "";
1008 0         0 my %sabs = ();
1009 0 0       0 if($defflag == 1) {
1010 0         0 $output .= " Sources (SABDEF):\n";
1011 0         0 foreach my $sab (sort keys %sabDefHash) { $saboutput .= " $sab\n"; }
  0         0  
1012             }
1013             else {
1014 0         0 $output .= " Sources (SAB):\n";
1015 0         0 foreach my $sab (sort keys %sabnamesHash) { $saboutput .= " $sab\n"; }
  0         0  
1016             }
1017            
1018              
1019 0         0 foreach my $sab (sort keys %sabnamesHash) {
1020 0         0 $tableFile .= "_$sab";
1021 0         0 $childFile .= "_$sab";
1022 0         0 $parentFile .= "_$sab";
1023 0         0 $configFile .= "_$sab";
1024 0         0 $tableName .= "_$sab";
1025 0         0 $intrinsicTable.= "_$sab";
1026 0         0 $parentTable .= "_$sab";
1027 0         0 $childTable .= "_$sab";
1028 0         0 $cacheTable .= "_$sab";
1029 0         0 $infoTable .= "_$sab";
1030             }
1031              
1032 0 0       0 if($umlsall) {
1033 0         0 $output .= " UMLS_ALL\n";
1034             }
1035             else {
1036 0         0 $output .= $saboutput;
1037             }
1038              
1039             # seperate the RELs and the RELAs from $relations
1040 0         0 my %rels = (); my %relas = ();
  0         0  
1041              
1042              
1043 0 0       0 if($defflag == 1) {
1044 0         0 $output .= " Relations (RELDEF):\n";
1045 0         0 foreach my $rel (sort keys %relDefHash) { $rels{$rel}++; }
  0         0  
1046             }
1047             else {
1048 0         0 $output .= " Relations (REL):\n";
1049 0         0 while($relations=~/=\'(.*?)\'/g) {
1050 0         0 my $rel = $1;
1051 0 0       0 if($rel=~/[a-z\_]+/) { $relas{$rel}++; }
  0         0  
1052 0         0 else { $rels{$rel}++; }
1053             }
1054             }
1055              
1056 0         0 foreach my $rel (sort keys %rels) {
1057 0         0 $tableFile .= "_$rel";
1058 0         0 $childFile .= "_$rel";
1059 0         0 $parentFile .= "_$rel";
1060 0         0 $configFile .= "_$rel";
1061 0         0 $tableName .= "_$rel";
1062 0         0 $intrinsicTable.= "_$rel";
1063 0         0 $parentTable .= "_$rel";
1064 0         0 $childTable .= "_$rel";
1065 0         0 $cacheTable .= "_$rel";
1066 0         0 $infoTable .= "_$rel";
1067              
1068 0         0 $output .= " $rel\n";
1069             }
1070              
1071 0         0 my $rak = keys %relas;
1072 0 0       0 if($rak > 0) {
1073 0 0       0 if($defflag == 1) {
1074 0         0 $output .= " Relations (RELADEF):\n";
1075             }
1076             else {
1077 0         0 $output .= " Relations (RELA):\n";
1078             }
1079             }
1080 0         0 foreach my $rel (sort keys %relas) {
1081 0         0 $tableFile .= "_$rel";
1082 0         0 $childFile .= "_$rel";
1083 0         0 $parentFile .= "_$rel";
1084 0         0 $configFile .= "_$rel";
1085 0         0 $tableName .= "_$rel";
1086 0         0 $intrinsicTable.= "_$rel";
1087 0         0 $parentTable .= "_$rel";
1088 0         0 $childTable .= "_$rel";
1089 0         0 $cacheTable .= "_$rel";
1090 0         0 $infoTable .= "_$rel";
1091              
1092 0         0 $output .= " $rel\n";
1093             }
1094              
1095 0         0 $tableFile .= "_table";
1096 0         0 $childFile .= "_child";
1097 0         0 $parentFile .= "_parent";
1098 0         0 $configFile .= "_config";
1099 0         0 $tableName .= "_table";
1100 0         0 $intrinsicTable.= "_intrinsic";
1101 0         0 $parentTable .= "_parent";
1102 0         0 $childTable .= "_child";
1103 0         0 $cacheTable .= "_cache";
1104 0         0 $infoTable .= "_info";
1105              
1106             # convert the databases to the hex name
1107             # and store the human readable form
1108 0         0 $tableNameHuman = $tableName;
1109 0         0 $intrinsicTableHuman = $intrinsicTable;
1110 0         0 $childTableHuman = $childTable;
1111 0         0 $cacheTableHuman = $cacheTable;
1112 0         0 $parentTableHuman = $parentTable;
1113 0         0 $infoTableHuman = $infoTable;
1114              
1115 0         0 $tableName = "a" . sha1_hex($tableNameHuman);
1116 0         0 $intrinsicTable = "a" . sha1_hex($intrinsicTableHuman);
1117 0         0 $childTable = "a" . sha1_hex($childTableHuman);
1118 0         0 $parentTable = "a" . sha1_hex($parentTableHuman);
1119 0         0 $infoTable = "a" . sha1_hex($infoTableHuman);
1120 0         0 $cacheTable = "a" . sha1_hex($cacheTableHuman);
1121              
1122 0 0       0 if($option_verbose) {
1123 0         0 $output .= " Configuration file:\n";
1124 0         0 $output .= " $configFile\n";
1125             }
1126              
1127 0         0 $output .= " Database: \n";
1128 0         0 $output .= " $database ($version)\n\n";
1129              
1130 0 0       0 if($option_t == 0) {
1131 0 0       0 if($option_config) {
1132 0         0 print STDERR "$output\n";
1133             }
1134             else {
1135 0         0 print STDERR "UMLS-Interface Configuration Information:\n";
1136 0         0 print STDERR "(Default Information - no config file)\n\n";
1137 0         0 print STDERR " Sources (SAB):\n";
1138 0         0 print STDERR " MSH\n";
1139 0         0 print STDERR " Relations (REL):\n";
1140 0         0 print STDERR " PAR\n";
1141 0         0 print STDERR " CHD\n\n";
1142 0         0 print STDERR " Sources (SABDEF):\n";
1143 0         0 print STDERR " UMLS_ALL\n";
1144 0         0 print STDERR " Relations (RELDEF):\n";
1145 0         0 print STDERR " UMLS_ALL\n";
1146             }
1147             }
1148             }
1149              
1150             # set the configuration environment variable
1151             # input :
1152             # output:
1153             sub _setEnvironmentVariable {
1154              
1155 0     0   0 my $self = shift;
1156              
1157 0         0 my $function = "_setEnvironmentVariable";
1158 0         0 &_debug($function);
1159              
1160             # check self
1161 0 0 0     0 if(!defined $self || !ref $self) {
1162 0         0 $errorhandler->_error($pkg, $function, "", 2);
1163             }
1164              
1165 0 0       0 if($option_verbose) {
1166 0 0       0 if(! (defined $umlsinterface) ) {
1167 0         0 my $answerFlag = 0;
1168 0         0 my $interfaceFlag = 0;
1169              
1170 0         0 while(! ($interfaceFlag) ) {
1171              
1172 0         0 print STDERR "The UMLSINTERFACE_CONFIGFILE_DIR environment\n";
1173 0         0 print STDERR "variable has not been defined yet. Please \n";
1174 0         0 print STDERR "enter a location that the UMLS-Interface can\n";
1175 0         0 print STDERR "use to store its configuration files:\n";
1176              
1177 0         0 $umlsinterface = ; chomp $umlsinterface;
  0         0  
1178              
1179 0         0 while(! ($answerFlag)) {
1180 0         0 print STDERR " Is $umlsinterface the correct location? ";
1181 0         0 my $answer = ; chomp $answer;
  0         0  
1182 0 0       0 if($answer=~/[Yy]/) {
1183 0         0 $answerFlag = 1;
1184 0         0 $interfaceFlag = 1;
1185             }
1186             else {
1187 0         0 print STDERR "Please entire in location:\n";
1188 0         0 $umlsinterface = ; chomp $umlsinterface;
  0         0  
1189             }
1190             }
1191              
1192 0 0       0 if(! (-e $umlsinterface) ) {
1193 0         0 system "mkdir -m 777 $umlsinterface";
1194             }
1195              
1196 0         0 print STDERR "Please set the UMLSINTERFACE_CONFIGFILE_DIR variable:\n\n";
1197 0         0 print STDERR "It can be set in csh as follows:\n\n";
1198 0         0 print STDERR " setenv UMLSINTERFACE_CONFIGFILE_DIR $umlsinterface\n\n";
1199 0         0 print STDERR "And in bash shell:\n\n";
1200 0         0 print STDERR " export UMLSINTERFACE_CONFIGFILE_DIR=$umlsinterface\n\n";
1201 0         0 print STDERR "Thank you!\n\n";
1202             }
1203             }
1204             }
1205             else {
1206 0         0 $umlsinterface = "";
1207             }
1208             }
1209              
1210             # sets the relations, parentRelations and childRelations
1211             # variables from the information in the config file
1212             # input : $includerelkeys <- integer
1213             # : $excluderelkeys <- integer
1214             # : $includerel <- reference to hash
1215             # : $excluderel <- reference to hash
1216             # output:
1217             sub _setRelations {
1218              
1219 0     0   0 my $self = shift;
1220 0         0 my $includerelkeys = shift;
1221 0         0 my $excluderelkeys = shift;
1222 0         0 my $includerel = shift;
1223 0         0 my $excluderel = shift;
1224              
1225 0         0 my $function = "_setRelations";
1226 0         0 &_debug($function);
1227              
1228             # check self
1229 0 0 0     0 if(!defined $self || !ref $self) {
1230 0         0 $errorhandler->_error($pkg, $function, "", 2);
1231             }
1232              
1233             # check the parameters
1234 0 0 0     0 if(!(defined $includerelkeys) || !(defined $excluderelkeys) ||
      0        
      0        
1235             !(defined $includerel) || !(defined $excluderel)) {
1236 0         0 $errorhandler->_error($pkg, $function, "REL variables not defined.", 4);
1237             }
1238              
1239 0 0 0     0 if($includerelkeys <= 0 && $excluderelkeys <=0) { return; }
  0         0  
1240              
1241             # if the umls all option is set clear out the the includerel hash and
1242             # add the umlsall to the exclude. This way all should be included since
1243             # there will never be a source called UMLS_ALL - this is a bit of a dirty
1244             # swap but I think it will simplify the code and work
1245 0 0       0 if(exists ${$includerel}{"UMLS_ALL"}) {
  0         0  
1246 0         0 $includerel = ""; $includerelkeys = 0;
  0         0  
1247 0         0 ${$excluderel}{"UMLS_ALL"} = 1; $excluderelkeys = 1;
  0         0  
  0         0  
1248              
1249             }
1250              
1251             # set the database
1252 0         0 my $db = $self->{'db'};
1253 0 0       0 if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0         0  
1254              
1255 0         0 $parentRelations = "(";
1256 0         0 $childRelations = "(";
1257 0         0 $relations = "(";
1258              
1259             # get the relations
1260 0         0 my @array = ();
1261 0 0       0 if($includerelkeys > 0) {
1262 0         0 @array = keys %{$includerel};
  0         0  
1263             }
1264             else {
1265              
1266 0         0 my $arrRef = $db->selectcol_arrayref("select distinct REL from MRREL");
1267 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
1268 0         0 @array = @{$arrRef};
  0         0  
1269             }
1270              
1271              
1272 0         0 my $relcount = 0;
1273 0         0 my @parents = ();
1274 0         0 my @children = ();
1275 0         0 foreach my $rel (@array) {
1276              
1277 0         0 $relcount++;
1278              
1279             # if we are excluding check to see if this one should be excluded
1280 0 0 0     0 if( ($excluderelkeys > 0) and (exists ${$excluderel}{$rel}) ) { next; }
  0         0  
  0         0  
1281              
1282             # otherwise store the relation in the relations variable
1283 0 0       0 if($relcount == ($#array+1)) { $relations .= "REL=\'$rel\'"; }
  0         0  
1284 0         0 else { $relations .= "REL=\'$rel\' or "; }
1285              
1286             # put it in its proper parent or child array
1287 0 0       0 if ($rel=~/(PAR|RB)/) { push @parents, $rel; }
  0 0       0  
1288 0         0 elsif($rel=~/(CHD|RN)/) { push @children, $rel; }
1289 0         0 else { push @parents, $rel; push @children, $rel; }
  0         0  
1290              
1291             }
1292              
1293             # set the parentRelations and childRelations variables
1294 0 0       0 if($#parents >= 0) {
1295 0         0 for my $i (0..($#parents-1)) {
1296 0         0 $parentRelations .= "REL=\'$parents[$i]\' or ";
1297 0         0 } $parentRelations .= "REL=\'$parents[$#parents]\'";
1298             }
1299 0 0       0 if($#children >= 0) {
1300 0         0 for my $i (0..($#children-1)) {
1301 0         0 $childRelations .= "REL=\'$children[$i]\' or ";
1302 0         0 } $childRelations .= "REL=\'$children[$#children]\'";
1303             }
1304              
1305 0         0 $parentRelations .= ") ";
1306 0         0 $childRelations .= ") ";
1307 0         0 $relations .= ") ";
1308              
1309             }
1310              
1311             # sets the source variables from the information in the config file
1312             # input : $includesabdefkeys <- integer
1313             # : $excludesabdefkeys <- integer
1314             # : $includedefsab <- reference to hash
1315             # : $excludedefsab <- reference to hash
1316             # output:
1317             sub _setSabDef {
1318              
1319 0     0   0 my $self = shift;
1320 0         0 my $includesabdefkeys = shift;
1321 0         0 my $excludesabdefkeys = shift;
1322 0         0 my $includesabdef = shift;
1323 0         0 my $excludesabdef = shift;
1324              
1325 0         0 my $function = "_setSabDef";
1326 0         0 &_debug($function);
1327              
1328             # check self
1329 0 0 0     0 if(!defined $self || !ref $self) {
1330 0         0 $errorhandler->_error($pkg, $function, "", 2);
1331             }
1332              
1333             # check the parameters are defined
1334 0 0 0     0 if(!(defined $includesabdefkeys) || !(defined $excludesabdefkeys) ||
      0        
      0        
1335             !(defined $includesabdef) || !(defined $excludesabdef)) {
1336 0         0 $errorhandler->_error($pkg, $function, "SAB variables not defined", 4);
1337             }
1338              
1339 0 0 0     0 if($includesabdefkeys <= 0 && $excludesabdefkeys <=0) { return; }
  0         0  
1340              
1341 0         0 $sabdef_umlsall = 0;
1342              
1343             # if the umls all option is set clear out the the includesabdef hash and
1344             # add the umlsall to the exclude. This way all should be included since
1345             # there will never be a source called UMLS_ALL - this is a bit of a dirty
1346             # swap but I think it will simplify the code and work
1347 0 0       0 if(exists ${$includesabdef}{"UMLS_ALL"}) {
  0         0  
1348 0         0 $includesabdef = ""; $includesabdefkeys = 0;
  0         0  
1349 0         0 ${$excludesabdef}{"UMLS_ALL"} = 1; $excludesabdefkeys = 1;
  0         0  
  0         0  
1350 0         0 $sabdef_umlsall = 1;
1351             }
1352              
1353             # check that the db is defined
1354 0         0 my $db = $self->{'db'};
1355 0 0       0 if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0         0  
1356              
1357             # get the sabs
1358 0         0 my @array = ();
1359 0 0       0 if($includesabdefkeys > 0) {
1360 0         0 @array = keys %{$includesabdef};
  0         0  
1361             }
1362             else {
1363 0         0 my $arrRef = $db->selectcol_arrayref("select distinct SAB from MRREL");
1364 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
1365 0         0 @array = @{$arrRef};
  0         0  
1366             }
1367              
1368             # get the sabs
1369 0         0 my $sabcount = 0; my @sabarray = ();
  0         0  
1370 0         0 foreach my $sab (@array) {
1371 0         0 $sabcount++;
1372              
1373             # if we are excluding check to see if this sab can be included
1374 0 0 0     0 if(($excludesabdefkeys > 0) and (exists ${$excludesabdef}{$sab})) { next; }
  0         0  
  0         0  
1375              
1376             # otherwise store it in the sabdef hash and store it in the array
1377 0         0 push @sabarray, "SAB=\'$sab\'";
1378              
1379 0         0 $sabDefHash{$sab}++;
1380             }
1381              
1382 0 0       0 if(!$sabdef_umlsall) {
1383 0         0 my $string = join " or ", @sabarray;
1384 0         0 $sabdefsources = "( $string )";
1385             }
1386             }
1387              
1388             # sets the relations, parentRelations and childRelations
1389             # variables from the information in the config file
1390             # input : $includereldefkeys <- integer
1391             # : $excludereldefkeys <- integer
1392             # : $includereldef <- reference to hash
1393             # : $excludereldef <- reference to hash
1394             # output:
1395             sub _setRelDef {
1396              
1397 0     0   0 my $self = shift;
1398 0         0 my $includereldefkeys = shift;
1399 0         0 my $excludereldefkeys = shift;
1400 0         0 my $includereldef = shift;
1401 0         0 my $excludereldef = shift;
1402              
1403 0         0 my $function = "_setRelDef";
1404 0         0 &_debug($function);
1405              
1406             # check self
1407 0 0 0     0 if(!defined $self || !ref $self) {
1408 0         0 $errorhandler->_error($pkg, $function, "", 2);
1409             }
1410              
1411             # check the parameters are defined
1412 0 0 0     0 if(!(defined $includereldefkeys) || !(defined $excludereldefkeys) ||
      0        
      0        
1413             !(defined $includereldef) || !(defined $excludereldef)) {
1414 0         0 $errorhandler->_error($pkg, $function, "RELDEF variables not defined.", 4);
1415             }
1416              
1417 0 0 0     0 if($includereldefkeys <= 0 && $excludereldefkeys <=0) { return; }
  0         0  
1418              
1419             # if the umls all option is set clear out the the includereldef hash and
1420             # add the umlsall to the exclude. This way all should be included since
1421             # there will never be a source called UMLS_ALL - this is a bit of a dirty
1422             # swap but I think it will simplify the code and work
1423 0 0       0 if(exists ${$includereldef}{"UMLS_ALL"}) {
  0         0  
1424 0         0 $includereldef = ""; $includereldefkeys = 0;
  0         0  
1425 0         0 ${$excludereldef}{"UMLS_ALL"} = 1; $excludereldefkeys = 1;
  0         0  
  0         0  
1426             }
1427              
1428             # set the database
1429 0         0 my $db = $self->{'db'};
1430 0 0       0 if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0         0  
1431              
1432             # get the relations
1433 0         0 my @array = ();
1434 0 0       0 if($includereldefkeys > 0) {
1435 0         0 @array = keys %{$includereldef};
  0         0  
1436             }
1437             else {
1438              
1439 0         0 my $arrRef = $db->selectcol_arrayref("select distinct REL from MRREL");
1440 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
1441 0         0 @array = @{$arrRef};
  0         0  
1442             }
1443              
1444 0         0 my $relcount = 0;
1445              
1446 0         0 foreach my $rel (@array) {
1447              
1448 0         0 $relcount++;
1449              
1450             # if we are excluding check to see if this one should be excluded
1451 0 0 0     0 if( ($excludereldefkeys > 0) and (exists ${$excludereldef}{$rel}) ) { next; }
  0         0  
  0         0  
1452              
1453             # otherwise store the relation in the reldef hash
1454 0         0 $relDefHash{$rel}++;
1455             }
1456              
1457              
1458             # now add the TERM and CUI which are not actual relations but should be in
1459             # the relDefHash if in the includereldef or not in the excludereldef or
1460             # nothing has been defined
1461 0 0       0 if($includereldefkeys > 0) {
    0          
1462 0 0       0 if(exists ${$includereldef}{"TERM"}) { $relDefHash{"TERM"}++; }
  0         0  
  0         0  
1463 0 0       0 if(exists ${$includereldef}{"CUI"}) { $relDefHash{"CUI"}++; }
  0         0  
  0         0  
1464 0 0       0 if(exists ${$includereldef}{"ST"}) { $relDefHash{"ST"}++; }
  0         0  
  0         0  
1465             }
1466             elsif($excludereldefkeys > 0) {
1467 0 0       0 if(! exists ${$excludereldef}{"TERM"}) { $relDefHash{"TERM"}++; }
  0         0  
  0         0  
1468 0 0       0 if(! exists ${$excludereldef}{"CUI"}) { $relDefHash{"CUI"}++; }
  0         0  
  0         0  
1469 0 0       0 if(! exists ${$excludereldef}{"ST"}) { $relDefHash{"ST"}++; }
  0         0  
  0         0  
1470             }
1471             else {
1472 0         0 $relDefHash{"TERM"}++; $relDefHash{"CUI"}++; $relDefHash{"ST"}++;
  0         0  
  0         0  
1473             }
1474             }
1475              
1476             # sets the variables for using the entire umls rather than just a subset
1477             # input :
1478             # output:
1479             sub _setSabUmlsAll {
1480              
1481 0     0   0 my $self = shift;
1482              
1483 0         0 my $function = "_setSabUmlsAll";
1484 0         0 &_debug($function);
1485              
1486             # check input value
1487 0 0 0     0 if(!defined $self || !ref $self) {
1488 0         0 $errorhandler->_error($pkg, $function, "", 2);
1489             }
1490              
1491             # set the database
1492 0         0 my $db = $self->{'db'};
1493 0 0       0 if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0         0  
1494              
1495 0         0 my $arrRef = $db->selectcol_arrayref("select distinct SAB from MRREL where $relations");
1496 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
1497              
1498 0         0 foreach my $sab (@{$arrRef}) {
  0         0  
1499 0         0 my $cui = $self->_getSabCui($sab);
1500              
1501 0         0 $sabnamesHash{$sab}++;
1502 0         0 $sabHash{$cui}++;
1503             }
1504             }
1505              
1506             # sets the source variables from the information in the config file
1507             # input : $includesabkeys <- integer
1508             # : $excludesabkeys <- integer
1509             # : $includesab <- reference to hash
1510             # : $excludesab <- reference to hash
1511             # output:
1512             sub _setSabs {
1513              
1514 0     0   0 my $self = shift;
1515 0         0 my $includesabkeys = shift;
1516 0         0 my $excludesabkeys = shift;
1517 0         0 my $includesab = shift;
1518 0         0 my $excludesab = shift;
1519              
1520 0         0 my $function = "_setSabs";
1521 0         0 &_debug($function);
1522              
1523             # check input value
1524 0 0 0     0 if(!defined $self || !ref $self) {
1525 0         0 $errorhandler->_error($pkg, $function, "", 2);
1526             }
1527              
1528             # check the parameters are defined
1529 0 0 0     0 if(!(defined $includesabkeys) || !(defined $excludesabkeys) ||
      0        
      0        
1530             !(defined $includesab) || !(defined $excludesab)) {
1531 0         0 $errorhandler->_error($pkg, $function, "SAB variables not defined.", 4);
1532             }
1533              
1534             # return if no sab or rel options were in the config file
1535 0 0 0     0 if($includesabkeys <= 0 && $excludesabkeys <=0) { return; }
  0         0  
1536              
1537             # initialize the sources
1538 0         0 $sources = "";
1539              
1540             # if the umls all option is set clear out the the includesab hash and
1541             # add the umlsall to the exclude. This way all should be included since
1542             # there will never be a source called UMLS_ALL - this is a bit of a dirty
1543             # swap but I think it will simplify the code and work
1544 0 0       0 if(exists ${$includesab}{"UMLS_ALL"}) {
  0         0  
1545 0         0 $includesab = ""; $includesabkeys = 0;
  0         0  
1546 0         0 ${$excludesab}{"UMLS_ALL"} = 1; $excludesabkeys = 1;
  0         0  
  0         0  
1547 0         0 $umlsall = 1;
1548 0         0 $sources = "UMLS_ALL";
1549             }
1550              
1551             # check that the db is defined
1552             # set the database
1553 0         0 my $db = $self->{'db'};
1554 0 0       0 if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0         0  
1555              
1556             # get the sabs
1557 0         0 my @array = ();
1558 0 0       0 if($includesabkeys > 0) {
1559 0         0 @array = keys %{$includesab};
  0         0  
1560             }
1561             else {
1562 0         0 my $arrRef = $db->selectcol_arrayref("select distinct SAB from MRREL where $relations");
1563 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
1564 0         0 @array = @{$arrRef};
  0         0  
1565             }
1566              
1567 0         0 my $sabcount = 0;
1568 0         0 foreach my $sab (@array) {
1569              
1570 0         0 $sabcount++;
1571              
1572             # if we are excluding check to see if this sab can be included
1573 0 0 0     0 if(($excludesabkeys > 0) and (exists ${$excludesab}{$sab})) { next; }
  0         0  
  0         0  
1574              
1575             # include the sab in the sources variable
1576 0 0       0 if($sabcount == ($#array+1)) { $sources .="SAB=\'$sab\'"; }
  0         0  
1577 0         0 else { $sources .="SAB=\'$sab\' or "; }
1578              
1579             # get the sabs cui
1580 0         0 my $cui = $self->_getSabCui($sab);
1581              
1582             # store the sabs cui and name information
1583 0         0 $sabnamesHash{$sab}++;
1584 0         0 $sabHash{$cui}++;
1585             }
1586             }
1587              
1588             # sets the rela variables from the information in the config file
1589             # input : $includerelakeys <- integer
1590             # : $excluderelakeys <- integer
1591             # : $includerela <- reference to hash
1592             # : $excluderela <- reference to hash
1593             # output:
1594             sub _setRelas {
1595              
1596 0     0   0 my $self = shift;
1597 0         0 my $includerelakeys = shift;
1598 0         0 my $excluderelakeys = shift;
1599 0         0 my $includerela = shift;
1600 0         0 my $excluderela = shift;
1601              
1602 0         0 my $function = "_setRelas";
1603 0         0 &_debug($function);
1604              
1605             # check the input values
1606 0 0 0     0 if(!defined $self || !ref $self) {
1607 0         0 $errorhandler->_error($pkg, $function, "", 2);
1608             }
1609              
1610             # check the parameters are defined
1611 0 0 0     0 if(!(defined $includerelakeys) || !(defined $excluderelakeys) ||
      0        
      0        
1612             !(defined $includerela) || !(defined $excluderela)) {
1613 0         0 $errorhandler->_error($pkg, $function, "RELA variables not defined.", 4);
1614             }
1615              
1616             # if no relas were specified just return
1617 0 0 0     0 if($includerelakeys <= 0 && $excluderelakeys <=0) { return }
  0         0  
1618              
1619             # set the database
1620 0         0 my $db = $self->{'db'};
1621 0 0       0 if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0         0  
1622              
1623             # initalize the hash tables that will hold children and parent relas
1624 0         0 my %childrelas = ();
1625 0         0 my %parentrelas = ();
1626              
1627             # set the parent relations
1628 0         0 my $prelations = "";
1629 0 0       0 if($relations=~/PAR/) {
    0          
1630 0 0       0 if($relations=~/RB/) {
1631 0         0 $prelations = "(REL='PAR') or (REL='RB')";
1632 0         0 } else { $prelations = "(REL='PAR')"; }
1633 0         0 } elsif($relations=~/RB/) { $prelations = "(REL='RB')"; }
1634              
1635             # set the child relations
1636 0         0 my $crelations = "";
1637 0 0       0 if($relations=~/CHD/) {
    0          
1638 0 0       0 if($relations=~/RN/) {
1639 0         0 $crelations = "(REL='CHD') or (REL='RN')";
1640 0         0 } else { $crelations = "(REL='CHD')"; }
1641 0         0 } elsif($relations=~/RB/) { $crelations = "(REL='RN')"; }
1642              
1643             # get the rela relations that exist for the given set of sources and
1644             # relations for the children relations that are specified in the config
1645 0         0 my $sth = "";
1646 0 0       0 if($umlsall) {
1647 0         0 $sth = $db->prepare("select distinct RELA from MRREL where $crelations");
1648 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
1649             }
1650             else {
1651 0         0 $sth = $db->prepare("select distinct RELA from MRREL where $crelations and ($sources)");
1652 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
1653             }
1654 0         0 $sth->execute();
1655 0         0 $errorhandler->_checkDbError($pkg, $function, $sth);
1656              
1657             # get all the relas for the children
1658 0         0 my $crela = "";
1659 0         0 while(($crela) = $sth->fetchrow()) {
1660 0 0       0 if(defined $crela) {
1661 0 0       0 if($crela ne "NULL") {
1662 0         0 $childrelas{$crela}++;
1663             }
1664             }
1665             }
1666 0         0 $sth->finish();
1667              
1668 0         0 my $crelakeys = keys %childrelas;
1669 0 0       0 if($crelakeys <= 0) {
1670 0         0 $errorhandler->_error($pkg,
1671             $function,
1672             "There are no RELA relations for the given sources/relations.",
1673             5);
1674             }
1675              
1676              
1677             # get the rela relations that exist for the given set of sources and
1678             # relations for the children relations that are specified in the config
1679 0 0       0 if($umlsall) {
1680 0         0 $sth = $db->prepare("select distinct RELA from MRREL where $prelations");
1681 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
1682             }
1683             else {
1684 0         0 $sth = $db->prepare("select distinct RELA from MRREL where $prelations and ($sources)");
1685 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
1686             }
1687 0         0 $sth->execute();
1688 0         0 $errorhandler->_checkDbError($pkg, $function, $sth);
1689              
1690             # get all the relas for the parents
1691 0         0 my $prela = "";
1692 0         0 while(($prela) = $sth->fetchrow()) {
1693 0 0       0 if(defined $prela) {
1694 0 0       0 if($prela ne "NULL") {
1695 0         0 $parentrelas{$prela}++;
1696             }
1697             }
1698             }
1699 0         0 $sth->finish();
1700              
1701 0         0 my $prelakeys = keys %parentrelas;
1702 0 0       0 if($prelakeys <= 0) {
1703 0         0 $errorhandler->_error($pkg,
1704             $function,
1705             "There are no RELA relations for the given sources.",
1706             5);
1707             }
1708              
1709             # uses the relas that are set in the includrelakeys or excluderelakeys
1710 0         0 my @array = ();
1711 0 0       0 if($includerelakeys > 0) {
1712 0         0 @array = keys %{$includerela};
  0         0  
1713             }
1714             else {
1715              
1716 0         0 my $arrRef =
1717             $db->selectcol_arrayref("select distinct RELA from MRREL where ($sources) and $prelations and $crelations");
1718 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
1719 0         0 @array = @{$arrRef};
  0         0  
1720 0         0 shift @array;
1721             }
1722              
1723 0         0 my @crelas = ();
1724 0         0 my @prelas = ();
1725 0         0 my $relacount = 0;
1726              
1727 0         0 my @newrelations = ();
1728              
1729 0         0 foreach my $r (@array) {
1730              
1731 0         0 $relacount++;
1732              
1733 0 0 0     0 if( ($excluderelakeys > 0) and (exists ${$excluderela}{$r}) ) { next; }
  0         0  
  0         0  
1734              
1735 0         0 push @newrelations, "RELA=\'$r\'";
1736              
1737 0 0       0 if(exists $childrelas{$r}) { push @crelas, "RELA=\'$r\'"; }
  0 0       0  
1738 0         0 elsif(exists $parentrelas{$r}) { push @prelas, "RELA=\'$r\'"; }
1739             else {
1740 0         0 my $errorstring = "RELA relation ($r) does not exist for the given sources/relations.";
1741 0         0 $errorhandler->_error($pkg, $function, $errorstring, 5);
1742             }
1743             }
1744              
1745 0 0       0 if($#newrelations >= 0) {
1746 0         0 my $string = join " or ", @newrelations;
1747              
1748 0         0 $relations .= "and ( $string )";
1749              
1750 0         0 my $crelasline = join " or ", @crelas;
1751 0         0 my $prelasline = join " or ", @prelas;
1752              
1753             # set the parent relations
1754 0 0       0 if($parentRelations=~/PAR/) {
1755 0         0 $parentRelations=~s/REL='PAR'/\(REL='PAR' and \($prelasline\)\)/g;
1756 0         0 $relations=~s/REL='PAR'/\(REL='PAR' and \($prelasline\)\)/g;
1757             }
1758 0 0       0 if($parentRelations=~/RB/) {
1759 0         0 $parentRelations=~s/REL='RB'/\(REL='RB' and \($prelasline\)\)/g;
1760 0         0 $relations=~s/REL='RB'/\(REL='RB' and \($prelasline\)\)/g;
1761             }
1762             # set the child relations
1763 0 0       0 if($childRelations=~/CHD/) {
1764 0         0 $childRelations=~s/REL='CHD'/\(REL='CHD' and \($crelasline\)\)/g;
1765 0         0 $relations=~s/REL='CHD'/\(REL='CHD' and \($crelasline\)\)/g;
1766             }
1767 0 0       0 if($childRelations=~/RN/) {
1768 0         0 $childRelations=~s/REL='RN'/\(REL='RN' and \($crelasline\)\)/g;
1769 0         0 $relations=~s/REL='RN'/\(REL='RN' and \($crelasline\)\)/g;
1770             }
1771             }
1772             }
1773              
1774             # sets the reladef variables from the information in the config file
1775             # input : $includereladefkeys <- integer
1776             # : $excludereladefkeys <- integer
1777             # : $includereladef <- reference to hash
1778             # : $excludereladef <- reference to hash
1779             # output:
1780             sub _setRelaDef {
1781              
1782 0     0   0 my $self = shift;
1783 0         0 my $includereladefkeys = shift;
1784 0         0 my $excludereladefkeys = shift;
1785 0         0 my $includereladef = shift;
1786 0         0 my $excludereladef = shift;
1787              
1788 0         0 my $function = "_setRelaDef";
1789 0         0 &_debug($function);
1790              
1791             # check the input values
1792 0 0 0     0 if(!defined $self || !ref $self) {
1793 0         0 $errorhandler->_error($pkg, $function, "", 2);
1794             }
1795              
1796             # check the parameters are defined
1797 0 0 0     0 if(!(defined $includereladefkeys) || !(defined $excludereladefkeys) ||
      0        
      0        
1798             !(defined $includereladef) || !(defined $excludereladef)) {
1799 0         0 $errorhandler->_error($pkg, $function, "RELADEF variables not defined.", 4);
1800             }
1801              
1802             # if no relas were specified just return
1803 0 0 0     0 if($includereladefkeys <= 0 && $excludereladefkeys <=0) { return; }
  0         0  
1804              
1805             # set the database
1806 0         0 my $db = $self->{'db'};
1807 0 0       0 if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0         0  
1808              
1809             # initalize the hash tables that will hold children and parent relas
1810 0         0 my %childrelas = ();
1811 0         0 my %parentrelas = ();
1812              
1813             # set the parent relations
1814 0         0 my $prelations = "";
1815 0 0       0 if($reldefstring=~/PAR/) {
    0          
1816 0 0       0 if($reldefstring=~/RB/) {
1817 0         0 $prelations = "(REL='PAR') or (REL='RB')";
1818 0         0 } else { $prelations = "(REL='PAR')"; }
1819 0         0 } elsif($reldefstring=~/RB/) { $prelations = "(REL='RB')"; }
1820              
1821             # set the child relations
1822 0         0 my $crelations = "";
1823 0 0       0 if($reldefstring=~/CHD/) {
    0          
1824 0 0       0 if($reldefstring=~/RN/) {
1825 0         0 $crelations = "(REL='CHD') or (REL='RN')";
1826 0         0 } else { $crelations = "(REL='CHD')"; }
1827 0         0 } elsif($reldefstring=~/RB/) { $crelations = "(REL='RN')"; }
1828              
1829             # get the rela relations that exist for the given set of sources and
1830             # relations for the children relations that are specified in the config
1831 0         0 my $sth = "";
1832 0 0       0 if($umlsall) {
1833 0         0 $sth = $db->prepare("select distinct RELA from MRREL where $crelations");
1834 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
1835             }
1836             else {
1837 0         0 $sth = $db->prepare("select distinct RELA from MRREL where $crelations and ($sabdefsources)");
1838 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
1839             }
1840 0         0 $sth->execute();
1841 0         0 $errorhandler->_checkDbError($pkg, $function, $sth);
1842              
1843             # get all the relas for the children
1844 0         0 my $crela = "";
1845 0         0 while(($crela) = $sth->fetchrow()) {
1846 0 0       0 if(defined $crela) {
1847 0 0       0 if($crela ne "NULL") {
1848 0         0 $childrelas{$crela}++;
1849             }
1850             }
1851             }
1852 0         0 $sth->finish();
1853              
1854 0         0 my $crelakeys = keys %childrelas;
1855 0 0       0 if($crelakeys <= 0) {
1856 0         0 $errorhandler->_error($pkg,
1857             $function,
1858             "There are no RELA relations for the given sources/relations.",
1859             5);
1860             }
1861              
1862             # get the rela relations that exist for the given set of sources and
1863             # relations for the children relations that are specified in the config
1864 0 0       0 if($umlsall) {
1865 0         0 $sth = $db->prepare("select distinct RELA from MRREL where $prelations");
1866 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
1867             }
1868             else {
1869 0         0 $sth = $db->prepare("select distinct RELA from MRREL where $prelations and ($sabdefsources)");
1870 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
1871             }
1872 0         0 $sth->execute();
1873 0         0 $errorhandler->_checkDbError($pkg, $function, $sth);
1874              
1875             # get all the relas for the parents
1876 0         0 my $prela = "";
1877 0         0 while(($prela) = $sth->fetchrow()) {
1878 0 0       0 if(defined $prela) {
1879 0 0       0 if($prela ne "NULL") {
1880 0         0 $parentrelas{$prela}++;
1881             }
1882             }
1883             }
1884 0         0 $sth->finish();
1885              
1886 0         0 my $prelakeys = keys %parentrelas;
1887 0 0       0 if($prelakeys <= 0) {
1888 0         0 $errorhandler->_error($pkg,
1889             $function,
1890             "There are no RELA relations for the given sources.",
1891             5);
1892             }
1893              
1894             # uses the relas that are set in the includrelakeys or excludereladefkeys
1895 0         0 my @array = ();
1896 0 0       0 if($includereladefkeys > 0) {
1897 0         0 @array = keys %{$includereladef};
  0         0  
1898             }
1899             else {
1900              
1901 0         0 my $arrRef =
1902             $db->selectcol_arrayref("select distinct RELA from MRREL where ($sources) and $prelations and $crelations");
1903 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
1904 0         0 @array = @{$arrRef};
  0         0  
1905 0         0 shift @array;
1906             }
1907              
1908 0         0 my @crelas = ();
1909 0         0 my @prelas = ();
1910 0         0 my $relacount = 0;
1911              
1912 0         0 my @newrelations = ();
1913              
1914 0         0 foreach my $r (@array) {
1915              
1916 0         0 $relacount++;
1917              
1918 0 0 0     0 if( ($excludereladefkeys > 0) and (exists ${$excludereladef}{$r}) ) { next; }
  0         0  
  0         0  
1919              
1920 0         0 push @newrelations, "RELA=\'$r\'";
1921              
1922 0 0       0 if(exists $childrelas{$r}) { push @crelas, "RELA=\'$r\'"; }
  0 0       0  
1923 0         0 elsif(exists $parentrelas{$r}) { push @prelas, "RELA=\'$r\'"; }
1924             else {
1925 0         0 my $errorstring = "RELA relation ($r) does not exist for the given sources/relations.";
1926 0         0 $errorhandler->_error($pkg, $function, $errorstring, 5);
1927             }
1928             }
1929              
1930 0 0       0 if($#newrelations >= 0) {
1931 0         0 my $string = join " or ", @newrelations;
1932              
1933 0         0 $relations .= "and ( $string )";
1934              
1935 0         0 $reladefchildren = join " or ", @crelas;
1936 0         0 $reladefparents = join " or ", @prelas;
1937             }
1938             }
1939              
1940             # This sets the sources that are to be used. These sources
1941             # are found in the config file. The defaults are:
1942             # input : $file <- string
1943             # output:
1944             sub _config {
1945              
1946 0     0   0 my $self = shift;
1947 0         0 my $file = shift;
1948              
1949 0         0 my $function = "_config";
1950 0         0 &_debug($function);
1951              
1952             # check self
1953 0 0 0     0 if(!defined $self || !ref $self) {
1954 0         0 $errorhandler->_error($pkg, $function, "", 2);
1955             }
1956              
1957 0         0 my %includesab = (); my %excludesab = ();
  0         0  
1958 0         0 my %includerel = (); my %excluderel = ();
  0         0  
1959 0         0 my %includerela = (); my %excluderela = ();
  0         0  
1960 0         0 my %includereldef = (); my %excludereldef = ();
  0         0  
1961 0         0 my %includesabdef = (); my %excludesabdef = ();
  0         0  
1962 0         0 my %includereladef = (); my %excludereladef = ();
  0         0  
1963              
1964 0         0 my %check = ();
1965              
1966 0 0       0 if(defined $file) {
1967 0 0       0 open(FILE, $file) || die "Could not open configuration file: $file\n";
1968 0         0 while() {
1969 0         0 chomp;
1970             # if blank line skip
1971 0 0       0 if($_=~/^\s*$/) { next; }
  0         0  
1972              
1973 0 0       0 if($_=~/([A-Z]+)\s*\:\:\s*(include|exclude)\s+(.*)/) {
1974              
1975 0         0 my $type = $1;
1976 0         0 my $det = $2;
1977 0         0 my $list = $3;
1978              
1979             # catch what types are in the config file for checking
1980             # right now the checking is pretty simple but I think
1981             # in the future as others get added it might be more
1982             # extensive
1983 0         0 $check{$type}++;
1984              
1985 0         0 my @array = split/\s*\,\s*/, $list;
1986 0         0 foreach my $element (@array) {
1987              
1988 0         0 $element=~s/^\s+//g; $element=~s/\s+$//g;
  0         0  
1989 0 0 0     0 if( $type eq "SAB" and $det eq "include") { $includesab{$element}++;
  0 0 0     0  
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
1990 0         0 $sabstring = $_;
1991 0         0 $parameters{"SAB"}++;
1992             }
1993 0         0 elsif($type eq "SAB" and $det eq "exclude") { $excludesab{$element}++;
1994 0         0 $sabstring = $_;
1995 0         0 $parameters{"SAB"}++;
1996             }
1997 0         0 elsif($type eq "REL" and $det eq "include") { $includerel{$element}++;
1998 0         0 $relstring = $_;
1999 0         0 $parameters{"REL"}++;
2000             }
2001 0         0 elsif($type eq "REL" and $det eq "exclude") { $excluderel{$element}++;
2002 0         0 $relstring = $_;
2003 0         0 $parameters{"REL"}++;
2004             }
2005 0         0 elsif($type eq "RELA" and $det eq "include") { $includerela{$element}++;
2006 0         0 $relastring = $_;
2007 0         0 $parameters{"RELA"}++;
2008             }
2009 0         0 elsif($type eq "RELA" and $det eq "exclude") { $excluderela{$element}++;
2010 0         0 $relastring = $_;
2011 0         0 $parameters{"RELA"}++;
2012             }
2013 0         0 elsif($type eq "RELDEF" and $det eq "include") { $includereldef{$element}++;
2014 0         0 $reldefstring = $_;
2015 0         0 $parameters{"RELDEF"}++;
2016             }
2017 0         0 elsif($type eq "RELDEF" and $det eq "exclude") { $excludereldef{$element}++;
2018 0         0 $reldefstring = $_;
2019 0         0 $parameters{"RELDEF"}++;
2020             }
2021 0         0 elsif($type eq "SABDEF" and $det eq "include") { $includesabdef{$element}++;
2022 0         0 $sabdefstring = $_;
2023 0         0 $parameters{"SABDEF"}++;
2024             }
2025 0         0 elsif($type eq "SABDEF" and $det eq "exclude") { $excludesabdef{$element}++;
2026 0         0 $sabdefstring = $_;
2027 0         0 $parameters{"SABDEF"}++;
2028             }
2029 0         0 elsif($type eq "RELADEF" and $det eq "include"){ $includereladef{$element}++;
2030 0         0 $parameters{"RELADEF"}++;
2031             }
2032 0         0 elsif($type eq "RELADEF" and $det eq "exclude"){ $excludereladef{$element}++;
2033 0         0 $parameters{"RELADEF"}++;
2034             }
2035             }
2036             }
2037             else {
2038 0         0 $errorhandler->_error($pkg, $function, "Format not correct ($_)", 5);
2039             }
2040             }
2041             }
2042              
2043              
2044            
2045             # check about the UMLS_ALL option in RELA and RELADEF
2046             # this is the default so just remove them - it is here
2047             # for the user not really for us
2048 0 0       0 if(exists $includerela{"UMLS_ALL"}) { %includerela = (); }
  0         0  
2049 0 0       0 if(exists $includereladef{"UMLS_ALL"}) { %includereladef = (); }
  0         0  
2050              
2051 0         0 my $includesabkeys = keys %includesab;
2052 0         0 my $excludesabkeys = keys %excludesab;
2053 0         0 my $includerelkeys = keys %includerel;
2054 0         0 my $excluderelkeys = keys %excluderel;
2055 0         0 my $includerelakeys = keys %includerela;
2056 0         0 my $excluderelakeys = keys %excluderela;
2057 0         0 my $includereldefkeys = keys %includereldef;
2058 0         0 my $excludereldefkeys = keys %excludereldef;
2059 0         0 my $includesabdefkeys = keys %includesabdef;
2060 0         0 my $excludesabdefkeys = keys %excludesabdef;
2061 0         0 my $includereladefkeys = keys %includereladef;
2062 0         0 my $excludereladefkeys = keys %excludereladef;
2063              
2064             # check for errors
2065 0 0 0     0 if( (!exists $check{"SAB"} && exists $check{"REL"}) ||
      0        
      0        
2066             (!exists $check{"REL"} && exists $check{"SAB"}) ) {
2067 0         0 $errorhandler->_error($pkg,
2068             $function,
2069             "Configuration file must include both REL and SAB information.",
2070             5);
2071             }
2072 0 0 0     0 if( (!exists $check{"SABDEF"} && exists $check{"RELDEF"}) ||
      0        
      0        
2073             (!exists $check{"RELDEF"} && exists $check{"SABDEF"}) ) {
2074 0         0 $errorhandler->_error($pkg,
2075             $function,
2076             "Configuration file must include both RELDEF and SABDEF information.",
2077             5);
2078             }
2079 0 0 0     0 if($includesabkeys > 0 && $excludesabkeys > 0) {
2080 0         0 $errorhandler->_error($pkg,
2081             $function,
2082             "Configuration file can not have an include and exclude list of sources.",
2083             5);
2084             }
2085 0 0 0     0 if($includerelkeys > 0 && $excluderelkeys > 0) {
2086 0         0 $errorhandler->_error($pkg,
2087             $function,
2088             "Configuration file can not have an include and exclude list of relations.",
2089             5);
2090             }
2091 0 0 0     0 if( ($includerelkeys <= 0 && $excluderelkeys <= 0) &&
      0        
      0        
2092             ($includerelakeys > 0 || $excluderelakeys > 0) ) {
2093 0         0 $errorhandler->_error($pkg,
2094             $function,
2095             "The relations (REL) must be specified if using the rela relations (RELA).",
2096             5);
2097             }
2098 0 0 0     0 if( ($includereldefkeys <= 0 && $excludereldefkeys <= 0) &&
      0        
      0        
2099             ($includereladefkeys > 0 || $excludereladefkeys > 0) ) {
2100 0         0 $errorhandler->_error($pkg,
2101             $function,
2102             "The relations (RELDEF) must be specified if using the rela relations (RELADEF).",
2103             5);
2104             }
2105              
2106              
2107             # set the defaults
2108 0 0 0     0 if($includerelkeys <= 0 && $excluderelkeys <= 0) {
2109 0         0 $includesab{"MSH"}++;
2110 0         0 $includerel{"PAR"}++;
2111 0         0 $includerel{"CHD"}++;
2112              
2113 0         0 $sabstring = "SAB :: include MSH";
2114 0         0 $relstring = "REL :: include CHD, PAR";
2115              
2116 0         0 $includerelkeys = keys %includerel;
2117 0         0 $includesabkeys = keys %includesab;
2118             }
2119              
2120             # set the defaults
2121 0 0 0     0 if($includereldefkeys <= 0 && $excludereldefkeys <= 0) {
2122            
2123 0         0 $includesabdef{"UMLS_ALL"}++;
2124 0         0 $includereldef{"UMLS_ALL"}++;
2125              
2126 0         0 $sabdefstring = "SAB :: include UMLS_ALL";
2127 0         0 $reldefstring = "REL :: include UMLS_ALL";
2128              
2129 0         0 $includereldefkeys = keys %includereldef;
2130 0         0 $includesabdefkeys = keys %includesabdef;
2131            
2132             }
2133             else {
2134 0         0 $defflag = 1;
2135             }
2136              
2137             # The order matters here so don't mess with it! The relations have to be set
2138             # prior to the sabs and both need to be set prior to the relas.
2139              
2140             # set the relations
2141 0         0 $self->_setRelations($includerelkeys, $excluderelkeys, \%includerel, \%excluderel);
2142              
2143             # set the sabs
2144 0         0 $self->_setSabs($includesabkeys, $excludesabkeys, \%includesab, \%excludesab);
2145              
2146             # set the relas as long as there exists a PAR/CHD or RB/RN relation
2147 0 0       0 if($relations=~/(PAR|CHD|RB|RN)/) {
2148 0         0 $self->_setRelas($includerelakeys, $excluderelakeys, \%includerela, \%excluderela);
2149             }
2150             else {
2151 0 0 0     0 if(($includerelkeys > 0 || $excluderelkeys > 0) &&
      0        
      0        
2152             ($includerelakeys > 0 || $excluderelakeys > 0) ) {
2153 0         0 $errorhandler->_error($pkg,
2154             $function,
2155             "The rela relations (RELA) can only be used with the PAR/CHD or RB/RN relations (REL).",
2156             5);
2157             }
2158             }
2159              
2160             # set the sabs for the CUI and extended definitions
2161 0         0 $self->_setSabDef($includesabdefkeys, $excludesabdefkeys, \%includesabdef, \%excludesabdef);
2162              
2163             # set the rels for the extended definition
2164 0         0 $self->_setRelDef($includereldefkeys, $excludereldefkeys, \%includereldef, \%excludereldef);
2165              
2166             # set the relas for the extended definition
2167 0 0       0 if($reldefstring=~/(PAR|CHD|RB|RN)/) {
2168 0         0 $self->_setRelaDef($includereladefkeys, $excludereladefkeys, \%includereladef, \%excludereladef);
2169             }
2170             else {
2171 0 0 0     0 if(($includereldefkeys > 0 || $excludereldefkeys > 0) &&
      0        
      0        
2172             ($includereladefkeys > 0 || $excludereladefkeys > 0) ) {
2173 0         0 $errorhandler->_error($pkg,
2174             $function,
2175             "The rela relations (RELADEF) can only be used with the PAR/CHD or RB/RN relations (RELDEF).",
2176             5);
2177             }
2178             }
2179              
2180             # now at this point everything that is set with the names are set
2181             # if though SABDEF has been set without SAB then use SABDEF
2182             # similarity if SABREL has been set without REL then use SABREL
2183             # set the relations - this is done right now to extract terms and
2184             # and such from the umls - I don't really like how this is done but
2185             # it will be okay for right now. It would be nice to have them
2186             # completely seperate. Doing it this way though allows for the REL,
2187             # SAB, RELDEF and SABDEF to all be specified - again order matters here.
2188              
2189             #if($includerelkeys == 0 && $excluderelkeys == 0) {
2190             # $self->_setRelations($includereldefkeys, $excludereldefkeys, \%includereldef, \%excludereldef);
2191             #}
2192             #if($includesabkeys == 0 && $excludesabkeys == 0) {
2193             # $self->_setSabs($includesabdefkeys, $excludesabdefkeys, \%includesabdef, \%excludesabdef);
2194             #}
2195             #if($includerelkeys == 0 && $excluderelkeys == 0) {
2196             # if($relations=~/(PAR|CHD|RB|RN)/) {
2197             # $self->_setRelas($includereladefkeys, $excludereladefkeys, \%includereladef, \%excludereladef);
2198             # }
2199             #}
2200              
2201 0 0       0 if($debug) {
2202 0 0       0 if($umlsall) { print STDERR "SOURCE : UMLS_ALL\n"; }
  0         0  
2203 0         0 else { print STDERR "SOURCE : $sources\n"; }
2204 0         0 print STDERR "RELATIONS: $relations\n";
2205 0         0 print STDERR "PARENTS : $parentRelations\n";
2206 0         0 print STDERR "CHILDREN : $childRelations\n\n";
2207 0 0       0 if($sabdefsources eq "") {
2208 0         0 print STDERR "SABDEF : UMLS_ALL\n";
2209             }
2210             else {
2211 0         0 print STDERR "SABDEF : $sabdefsources\n";
2212             }
2213 0         0 my $reldefrelations = "UMLS_ALL";
2214 0 0       0 if($reldefstring ne "") {
2215 0         0 $reldefstring=~/RELDEF :: include ([A-Z0-9\, ]+)/;
2216 0         0 $reldefrelations = $1;
2217             }
2218 0         0 print STDERR "RELDEF : $reldefrelations\n";
2219 0         0 print STDERR "SAB : $sources\n";
2220 0         0 print STDERR "REL : $relations\n";
2221             }
2222             }
2223              
2224             # returns the SAB from the configuratino file
2225             # input :
2226             # output: $string <- containing SAB line from config file
2227             sub _getSabString {
2228 0     0   0 my $self = shift;
2229              
2230 0         0 return $sabstring;
2231             }
2232              
2233             # returns the REL from the configuratino file
2234             # input :
2235             # output: $string <- containing REL line from config file
2236             sub _getRelString {
2237 0     0   0 my $self = shift;
2238              
2239 0         0 return $relstring;
2240             }
2241              
2242             # returns the RELA from the configuratino file
2243             # input :
2244             # output: $string <- containing RELA line from config file
2245             sub _getRelaString {
2246 0     0   0 my $self = shift;
2247              
2248 0         0 return $relastring;
2249             }
2250              
2251             # returns the SABDEF from the configuratino file
2252             # input :
2253             # output: $string <- containing SABDEF line from config file
2254             sub _getSabDefString {
2255 0     0   0 my $self = shift;
2256              
2257 0         0 return $sabdefstring;
2258             }
2259              
2260             # returns the RELDEF from the configuratino file
2261             # input :
2262             # output: $string <- containing RELDEF line from config file
2263             sub _getRelDefString {
2264 0     0   0 my $self = shift;
2265              
2266 0         0 return $reldefstring;
2267             }
2268              
2269              
2270              
2271             # set the version
2272             # input :
2273             # output:
2274             sub _setVersion {
2275              
2276 0     0   0 my $self = shift;
2277              
2278 0         0 my $function = "_setVersion";
2279 0         0 &_debug($function);
2280              
2281             # check self
2282 0 0 0     0 if(!defined $self || !ref $self) {
2283 0         0 $errorhandler->_error($pkg, $function, "", 2);
2284             }
2285              
2286             # set the database
2287 0         0 my $db = $self->{'db'};
2288 0 0       0 if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0         0  
2289              
2290             # get the verstion information
2291 0         0 my $arrRef = $db->selectcol_arrayref("select EXPL from MRDOC where VALUE = \'mmsys.version\'");
2292 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
2293              
2294             # check that it was returned
2295 0 0       0 if(scalar(@{$arrRef}) < 1) {
  0         0  
2296 0         0 $errorhandler->_error($pkg, $function, "No version info in table MRDOC.", 7);
2297             }
2298              
2299 0         0 ($version) = @{$arrRef};
  0         0  
2300             }
2301              
2302              
2303             # check if the UMLS tables required all exist
2304             # input :
2305             # output:
2306             sub _checkTablesExist {
2307              
2308 0     0   0 my $self = shift;
2309              
2310 0         0 my $function = "_checkTablesExist";
2311 0         0 &_debug($function);
2312              
2313             # check self
2314 0 0 0     0 if(!defined $self || !ref $self) {
2315 0         0 $errorhandler->_error($pkg, $function, "", 2);
2316             }
2317              
2318             # set up the database
2319 0         0 my $db = $self->{'db'};
2320 0 0       0 if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0         0  
2321              
2322             # check if the tables exist...
2323 0         0 my $sth = $db->prepare("show tables");
2324 0         0 $sth->execute();
2325 0         0 $errorhandler->_checkDbError($pkg, $function, $sth);
2326              
2327 0         0 my $table = "";
2328 0         0 my %tables = ();
2329 0         0 while(($table) = $sth->fetchrow()) {
2330 0         0 $tables{$table} = 1;
2331             }
2332 0         0 $sth->finish();
2333              
2334 0 0 0     0 if(!defined $tables{"MRCONSO"} and !defined $tables{"mrconso"}) {
2335 0         0 $errorhandler->_error($pkg, $function, "Table MRCONSO not found in database", 7);
2336             }
2337 0 0 0     0 if(!defined $tables{"MRDEF"} and !defined $tables{"mrdef"}) {
2338 0         0 $errorhandler->_error($pkg, $function, "Table MRDEF not found in database", 7);
2339             }
2340 0 0 0     0 if(!defined $tables{"SRDEF"} and !defined $tables{"srdef"}) {
2341 0         0 $errorhandler->_error($pkg, $function, "Table SRDEF not found in database", 7);
2342             }
2343 0 0 0     0 if(!defined $tables{"MRREL"} and !defined $tables{"mrrel"}) {
2344 0         0 $errorhandler->_error($pkg, $function, "Table MRREL not found in database", 7);
2345             }
2346 0 0 0     0 if(!defined $tables{"MRDOC"} and !defined $tables{"mrdoc"}) {
2347 0         0 $errorhandler->_error($pkg, $function, "Table MRDEC not found in database", 7);
2348             }
2349 0 0 0     0 if(!defined $tables{"MRSAB"} and !defined $tables{"mrsab"}) {
2350 0         0 $errorhandler->_error($pkg, $function, "Table MRSAB not found in database", 7);
2351             }
2352             }
2353              
2354             # method to set the global parameter options
2355             # input : $params <- reference to a hash
2356             # output:
2357             sub _setOptions {
2358 0     0   0 my $self = shift;
2359 0         0 my $params = shift;
2360              
2361 0         0 my $function = "_setOptions";
2362 0         0 &_debug($function);
2363              
2364             # check self
2365 0 0 0     0 if(!defined $self || !ref $self) {
2366 0         0 $errorhandler->_error($pkg, $function, "", 2);
2367             }
2368              
2369             # check the params
2370 0 0       0 $params = {} if(!defined $params);
2371              
2372             # get all the parameters
2373 0         0 my $verbose = $params->{'verbose'};
2374 0         0 my $cuilist = $params->{'cuilist'};
2375 0         0 my $t = $params->{'t'};
2376 0         0 my $debugoption = $params->{'debug'};
2377 0         0 my $config = $params->{'config'};
2378              
2379 0 0       0 if(defined $t) {
2380 0         0 $option_t = 1;
2381             }
2382              
2383 0         0 my $output = "";
2384              
2385 0 0 0     0 if(defined $verbose || defined $cuilist ||
      0        
      0        
2386             defined $debugoption || defined $config) {
2387 0         0 $output .= "\nCuiFinder User Options: \n";
2388             }
2389              
2390             # check the debug option
2391 0 0       0 if(defined $debugoption) {
2392 0         0 $debug = 1;
2393 0         0 $output .= " --debug";
2394             }
2395              
2396             # check if verbose run has been identified
2397 0 0       0 if(defined $verbose) {
2398 0         0 $option_verbose = 1;
2399 0         0 $output .= " --verbose option set\n";
2400             }
2401              
2402              
2403             # check if the cuilist option has been set
2404 0 0       0 if(defined $cuilist) {
2405 0         0 $option_cuilist = 1;
2406 0         0 $output .= " --cuilist option set\n";
2407             }
2408              
2409             # check if the config file is set
2410 0 0       0 if(defined $config) {
2411 0         0 $option_config = 1;
2412 0         0 $output .= " --config option set\n";
2413             }
2414              
2415 0 0       0 if($option_t == 0) {
2416 0         0 print STDERR "$output\n\n";
2417             }
2418             }
2419              
2420             # method to set the umlsinterface index database
2421             # input : $params <- reference to a hash
2422             # output:
2423             sub _setDatabase {
2424              
2425 22     22   46 my $self = shift;
2426 22         49 my $params = shift;
2427              
2428 22         44 my $function = "_setDatabase";
2429 22         76 &_debug($function);
2430              
2431             # check self
2432 22 50 33     166 if(!defined $self || !ref $self) {
2433 0         0 $errorhandler->_error($pkg, $function, "", 2);
2434             }
2435              
2436             # check the params
2437 22 50       126 $params = {} if(!defined $params);
2438              
2439             # get the database connection parameters
2440 22         59 my $database = $params->{'database'};
2441 22         55 my $hostname = $params->{'hostname'};
2442 22         63 my $socket = $params->{'socket'};
2443 22         57 my $port = $params->{'port'};
2444 22         49 my $username = $params->{'username'};
2445 22         64 my $password = $params->{'password'};
2446              
2447             # set up defaults if the options were not passed
2448 22 50       83 if(! defined $database) { $database = "umls"; }
  22         58  
2449 22 50       103 if(! defined $socket) { $socket = "/var/run/mysqld/mysqld.sock"; }
  22         57  
2450 22 50       94 if(! defined $hostname) { $hostname = "localhost"; }
  22         56  
2451              
2452             # initialize the database handler
2453 22         54 my $db = "";
2454              
2455             # create the database object...
2456 22 50 33     141 if(defined $username and defined $password) {
2457 0 0       0 if($debug) { print STDERR "Connecting with username and password\n"; }
  0         0  
2458 0         0 $db = DBI->connect("DBI:mysql:database=$database;mysql_socket=$socket;host=$hostname",$username, $password, {RaiseError => 0});
2459             }
2460             else {
2461 22 50       96 if($debug) { print STDERR "Connecting using the my.cnf file\n"; }
  0         0  
2462 22         54 my $dsn = "DBI:mysql:umls;mysql_read_default_group=client;";
2463 22         213 $db = DBI->connect($dsn);
2464             }
2465              
2466             # check if there is an error
2467 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
2468              
2469             # check that the db exists
2470 0 0       0 if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0         0  
2471              
2472             # set database parameters
2473 0         0 $db->{'mysql_enable_utf8'} = 1;
2474 0         0 $db->do('SET NAMES utf8');
2475 0         0 $db->{mysql_auto_reconnect} = 1;
2476              
2477             # set the self parameters
2478 0         0 $self->{'db'} = $db;
2479 0         0 $self->{'username'} = $username;
2480 0         0 $self->{'password'} = $password;
2481 0         0 $self->{'hostname'} = $hostname;
2482 0         0 $self->{'socket'} = $socket;
2483 0         0 $self->{'database'} = $database;
2484              
2485             # return the database handler
2486 0         0 return $db;
2487             }
2488              
2489             # returns the parameters set in the configuration file
2490             # input:
2491             # output : $hash <- reference to hash containing parameters in the
2492             # configuration file - if there was not config
2493             # file the hash is empty and defaults are being
2494             # use
2495             sub _getConfigParameters {
2496 0     0   0 my $self = shift;
2497              
2498 0         0 my $function = "_getConfigParameters";
2499              
2500 0         0 return \%parameters;
2501             }
2502              
2503             # returns all of the cuis given the specified set of sources
2504             # and relations defined in the configuration file
2505             # input : $sab <- string containing a source
2506             # output: $array <- reference to array of cuis
2507             sub _getCuis {
2508              
2509 0     0   0 my $self = shift;
2510 0         0 my $sab = shift;
2511              
2512 0         0 my $function = "_getCuis";
2513             #&_debug($function);
2514              
2515             # check self
2516 0 0 0     0 if(!defined $self || !ref $self) {
2517 0         0 $errorhandler->_error($pkg, $function, "", 2);
2518             }
2519              
2520             # check input variables
2521 0 0       0 if(!$sab) { $errorhandler->_error($pkg, $function, "Error with input variable \$sab.", 4); }
  0         0  
2522              
2523             # set up the database
2524 0         0 my $db = $self->{'db'};
2525 0 0       0 if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0         0  
2526              
2527             # NOTE: it is quicker to get all the CUI1s and then all of the CUI2 and then merge
2528             # rather than try to get them all together in a single query.
2529             # get all of the CUI1s
2530 0         0 my $allCui1 = $db->selectcol_arrayref("select CUI1 from MRREL where ($relations) and (SAB=\'$sab\') and SUPPRESS='N'\;");
2531 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
2532              
2533             # get all of the CUI1s
2534 0         0 my $allCui2 = $db->selectcol_arrayref("select CUI2 from MRREL where ($relations) and (SAB=\'$sab\')and SUPPRESS='N'");
2535 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
2536              
2537             # merge and return them
2538 0         0 my @allCuis = (@{$allCui1}, @{$allCui2});
  0         0  
  0         0  
2539              
2540 0         0 return \@allCuis;
2541             }
2542              
2543             # Takes as input a SAB and returns its corresponding
2544             # UMLS CUI. Keep in mind this is the root cui not
2545             # the version cui that is returned. The information
2546             # for this is obtained from the MRSAB table
2547             # input : $sab <- string containing source
2548             # output: $cui <- string containing cui
2549             sub _getSabCui {
2550 0     0   0 my $self = shift;
2551 0         0 my $sab = shift;
2552              
2553 0         0 my $function = "_getSabCui";
2554              
2555             # check self
2556 0 0 0     0 if(!defined $self || !ref $self) {
2557 0         0 $errorhandler->_error($pkg, $function, "", 2);
2558             }
2559              
2560             # check input variables
2561 0 0       0 if(!$sab) { $errorhandler->_error($pkg, $function, "Error with input variable \$sab.", 4); }
  0         0  
2562              
2563             # set up the database
2564 0         0 my $db = $self->{'db'};
2565 0 0       0 if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0         0  
2566              
2567             # if the sab is umls all
2568 0 0       0 if($sab eq "UMLS_ALL") {
2569 0         0 return $umlsRoot;
2570             }
2571              
2572 0         0 my $arrRef = $db->selectcol_arrayref("select distinct RCUI from MRSAB where RSAB='$sab' and SABIN='Y'");
2573 0         0 $errorhandler->_checkDbError($pkg, $function, $db);
2574              
2575 0 0       0 if(scalar(@{$arrRef}) < 1) {
  0         0  
2576 0         0 $errorhandler->_error($pkg, $function, "SAB ($sab) does not exist in your current UMLS view.", 7);
2577             }
2578              
2579 0 0       0 if(scalar(@{$arrRef}) > 1) {
  0         0  
2580 0         0 $errorhandler->_error($pkg, $function, "Internal error: Duplicate concept rows.", 7);
2581             }
2582              
2583 0         0 return (pop @{$arrRef});
  0         0  
2584             }
2585              
2586              
2587             # method to destroy the created object.
2588             # input :
2589             # output:
2590             sub _disconnect {
2591 0     0   0 my $self = shift;
2592              
2593 0         0 my $function = "_disconnect";
2594              
2595             # check self
2596 0 0 0     0 if(!defined $self || !ref $self) {
2597 0         0 $errorhandler->_error($pkg, $function, "", 2);
2598             }
2599              
2600 0 0       0 if($self) {
2601 0         0 my $db = $self->{'db'};
2602 0 0       0 $db->disconnect() if($db);
2603             }
2604             }
2605              
2606             # returns the version of the UMLS currently being used
2607             # input :
2608             # output: $version <- string containing version
2609             sub _version {
2610              
2611 0     0   0 return $version;
2612             }
2613              
2614             # print out the function name to standard error
2615             # input : $function <- string containing function name
2616             # output:
2617             sub _debug {
2618 66     66   126 my $function = shift;
2619 66 50       208 if($debug) { print STDERR "In UMLS::Interface::CuiFinder::$function\n"; }
  0            
2620             }
2621              
2622             ######################################################################
2623             # functions to obtain information about the cuis
2624             ######################################################################
2625              
2626             # Method to check if a concept ID exists in the database.
2627             # input : $concept <- string containing a cui
2628             # output: $bool <- string indicating if the cui exists
2629             sub _exists {
2630              
2631 0     0     my $self = shift;
2632 0           my $concept = shift;
2633              
2634 0           my $function = "_exists";
2635              
2636             # check self
2637 0 0 0       if(!defined $self || !ref $self) {
2638 0           $errorhandler->_error($pkg, $function, "", 2);
2639             }
2640              
2641             # check parameter exists
2642 0 0         if(!defined $concept) {
2643 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
2644             }
2645              
2646             # check if valid concept
2647 0 0         if(! ($errorhandler->_validCui($concept)) ) {
2648 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
2649             }
2650              
2651             # check if root
2652 0 0         if($concept eq $umlsRoot) { return 1; }
  0            
2653              
2654             # check if a sab
2655 0 0         if(exists $sabHash{$concept}) { return 1; }
  0            
2656              
2657             # set up database
2658 0           my $db = $self->{'db'};
2659 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
2660              
2661             # get the concept
2662 0           my $arrRef = "";
2663 0 0         if($umlsall) {
2664 0           $arrRef = $db->selectcol_arrayref("select distinct CUI from MRCONSO where CUI='$concept'");
2665             }
2666             else {
2667 0           $arrRef = $db->selectcol_arrayref("select distinct CUI from MRCONSO where CUI='$concept' and $sources");
2668             }
2669              
2670             # check the database for errors
2671 0           $errorhandler->_checkDbError($pkg, $function, $db);
2672              
2673             # get the count
2674 0           my $count = scalar(@{$arrRef});
  0            
2675              
2676 0 0         return 1 if($count); return 0;
  0            
2677             }
2678              
2679             # method that returns a list of concepts (@concepts) related
2680             # to a concept $concept through a relation $rel
2681             # input : $concept <- string containing cui
2682             # $rel <- string containing a relation
2683             # output: $array <- reference to an array of cuis
2684             sub _getRelated {
2685              
2686 0     0     my $self = shift;
2687 0           my $concept = shift;
2688 0           my $rel = shift;
2689              
2690 0           my $function = "_getRelated";
2691 0           &_debug($function);
2692              
2693             # check self
2694 0 0 0       if(!defined $self || !ref $self) {
2695 0           $errorhandler->_error($pkg, $function, "", 2);
2696             }
2697              
2698             # check parameter exists
2699 0 0         if(!defined $concept) {
2700 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
2701             }
2702              
2703 0 0         if(!defined $rel) {
2704 0           $errorhandler->_error($pkg, $function, "Error with input variable \$rel.", 4);
2705             }
2706              
2707             # check if valid concept
2708 0 0         if(! ($errorhandler->_validCui($concept)) ) {
2709 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
2710             }
2711              
2712             # set up database
2713 0           my $db = $self->{'db'};
2714 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
2715              
2716             # return all the relations 'rel' for cui 'concept'
2717 0           my $arrRef = "";
2718 0 0         if($umlsall) {
2719 0           $arrRef = $db->selectcol_arrayref("select distinct CUI2 from MRREL where CUI1='$concept' and REL='$rel' and CUI2!='$concept'");
2720             }
2721             else {
2722 0           $arrRef = $db->selectcol_arrayref("select distinct CUI2 from MRREL where CUI1='$concept' and REL='$rel' and ($sources) and CUI2!='$concept'");
2723             }
2724              
2725             # check for errors
2726 0           $errorhandler->_checkDbError($pkg, $function, $db);
2727              
2728 0           return $arrRef;
2729             }
2730              
2731             # method that returns the preferred term of a cui from the UMLS
2732             # input : $concept <- string containing cui
2733             # output: $string <- string containing the preferred term
2734             sub _getAllPreferredTerm {
2735 0     0     my $self = shift;
2736 0           my $concept = shift;
2737              
2738 0           my $function = "_getAllPreferredTerm";
2739              
2740             # check self
2741 0 0 0       if(!defined $self || !ref $self) {
2742 0           $errorhandler->_error($pkg, $function, "", 2);
2743             }
2744              
2745             # check parameter exists
2746 0 0         if(!defined $concept) {
2747 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
2748             }
2749              
2750             # check if valid concept
2751 0 0         if(! ($errorhandler->_validCui($concept)) ) {
2752 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
2753             }
2754              
2755             # set the return hash
2756 0           my %retHash = ();
2757              
2758             # if the concept is the root return the root string
2759 0 0         if($concept eq $umlsRoot) {
2760 0           $retHash{"**UMLS ROOT**"}++;
2761 0           my @array = keys(%retHash);
2762 0           return \@array;
2763             }
2764              
2765             # set the database
2766 0           my $db = $self->{'db'};
2767 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
2768              
2769             # get the strings associated to the CUI
2770 0           my $arrRef = $db->selectcol_arrayref("select distinct STR from MRCONSO where CUI='$concept' and TS='P' and LAT='ENG'");
2771              
2772             # check the database for errors
2773 0           $errorhandler->_checkDbError($pkg, $function, $db);
2774              
2775             # clean up the strings a bit and lower case them
2776 0           my $term = "";
2777 0           foreach my $tr (@{$arrRef}) {
  0            
2778 0           $tr =~ s/^\s+//;
2779 0           $tr =~ s/\s+$//;
2780 0           $tr =~ s/\s+/ /g;
2781 0           $term = $tr;
2782             }
2783              
2784             # return the strings
2785 0           return $term;
2786             }
2787              
2788             # method that returns the preferred term of a cui from
2789             # sources specified in the configuration file
2790             # input : $concept <- string containing cui
2791             # output: $string <- string containing the preferred term
2792             sub _getPreferredTerm {
2793 0     0     my $self = shift;
2794 0           my $concept = shift;
2795              
2796 0           my $function = "_getPreferredTerm";
2797              
2798             # check self
2799 0 0 0       if(!defined $self || !ref $self) {
2800 0           $errorhandler->_error($pkg, $function, "", 2);
2801             }
2802              
2803             # check parameter exists
2804 0 0         if(!defined $concept) {
2805 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
2806             }
2807              
2808             # check if valid concept
2809 0 0         if(! ($errorhandler->_validCui($concept)) ) {
2810 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
2811             }
2812              
2813             # set the return hash
2814 0           my %retHash = ();
2815              
2816             # if the concept is the root return the root string
2817 0 0         if($concept eq $umlsRoot) {
2818 0           $retHash{"**UMLS ROOT**"}++;
2819 0           my @array = keys(%retHash);
2820 0           return \@array;
2821             }
2822              
2823             # set the database
2824 0           my $db = $self->{'db'};
2825 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
2826              
2827             # get the strings associated to the CUI
2828 0           my $arrRef = "";
2829 0 0         if($umlsall) {
2830 0           $arrRef = $db->selectcol_arrayref("select distinct STR from MRCONSO where CUI='$concept' and TS='P' and LAT='ENG'");
2831             }
2832             else {
2833 0           $arrRef = $db->selectcol_arrayref("select distinct STR from MRCONSO where CUI='$concept' and TS='P' and ($sources or SAB='SRC') and LAT='ENG'");
2834             }
2835              
2836             # check the database for errors
2837 0           $errorhandler->_checkDbError($pkg, $function, $db);
2838              
2839              
2840             # clean up the strings a bit and lower case them
2841 0           my $term = "";
2842 0           foreach my $tr (@{$arrRef}) {
  0            
2843 0           $tr =~ s/^\s+//;
2844 0           $tr =~ s/\s+$//;
2845 0           $tr =~ s/\s+/ /g;
2846 0           $term = $tr;
2847             }
2848            
2849             # return the strings
2850 0           return $term;
2851             }
2852              
2853              
2854              
2855             # method that maps terms to cuis in the sources specified in
2856             # in the configuration file by the user using the SAB parameter
2857             # input : $concept <- string containing cui
2858             # output: $array <- reference to an array of terms (strings)
2859             sub _getTermList {
2860 0     0     my $self = shift;
2861 0           my $concept = shift;
2862              
2863 0           my $function = "_getTermList";
2864              
2865             # check self
2866 0 0 0       if(!defined $self || !ref $self) {
2867 0           $errorhandler->_error($pkg, $function, "", 2);
2868             }
2869              
2870             # check parameter exists
2871 0 0         if(!defined $concept) {
2872 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
2873             }
2874              
2875             # check if valid concept
2876 0 0         if(! ($errorhandler->_validCui($concept)) ) {
2877 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
2878             }
2879              
2880             # set the return hash
2881 0           my %retHash = ();
2882              
2883             # if the concept is the root return the root string
2884 0 0         if($concept eq $umlsRoot) {
2885 0           $retHash{"**UMLS ROOT**"}++;
2886 0           my @array = keys(%retHash);
2887 0           return \@array;
2888             }
2889              
2890             # set the database
2891 0           my $db = $self->{'db'};
2892 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
2893              
2894             # get the strings associated to the CUI
2895 0           my $arrRef = "";
2896 0 0         if($umlsall) {
2897 0           $arrRef = $db->selectcol_arrayref("select distinct STR from MRCONSO where CUI='$concept'");
2898             }
2899             else {
2900 0           $arrRef = $db->selectcol_arrayref("select distinct STR from MRCONSO where CUI='$concept' and ($sources or SAB='SRC')");
2901             }
2902              
2903             # check the database for errors
2904 0           $errorhandler->_checkDbError($pkg, $function, $db);
2905              
2906             # clean up the strings a bit and lower case them
2907 0           foreach my $tr (@{$arrRef}) {
  0            
2908 0           $tr =~ s/^\s+//;
2909 0           $tr =~ s/\s+$//;
2910 0           $tr =~ s/\s+/ /g;
2911 0           $retHash{lc($tr)} = 1;
2912             }
2913              
2914 0           my @array = keys(%retHash);
2915              
2916             # return the strings
2917 0           return \@array;
2918             }
2919              
2920             # method that maps terms to cuis in the sources specified in
2921             # in the configuration file by the user using the SABDEF parameter
2922             # input : $concept <- string containing cui
2923             # output: $array <- reference to an array of terms
2924             sub _getDefTermList {
2925 0     0     my $self = shift;
2926 0           my $concept = shift;
2927              
2928 0           my $function = "_getTermList";
2929              
2930             # check self
2931 0 0 0       if(!defined $self || !ref $self) {
2932 0           $errorhandler->_error($pkg, $function, "", 2);
2933             }
2934              
2935             # check parameter exists
2936 0 0         if(!defined $concept) {
2937 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
2938             }
2939              
2940             # check if valid concept
2941 0 0         if(! ($errorhandler->_validCui($concept)) ) {
2942 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
2943             }
2944              
2945             # set the return hash
2946 0           my %retHash = ();
2947              
2948             # if the concept is the root return the root string
2949 0 0         if($concept eq $umlsRoot) {
2950 0           $retHash{"**UMLS ROOT**"}++;
2951 0           my @array = keys(%retHash);
2952 0           return \@array;
2953             }
2954              
2955             # set the database
2956 0           my $db = $self->{'db'};
2957 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
2958              
2959             # get the strings associated to the CUI
2960 0           my $arrRef = "";
2961 0 0         if($sabdef_umlsall) {
2962 0           $arrRef = $db->selectcol_arrayref("select distinct STR from MRCONSO where CUI='$concept'");
2963             }
2964             else {
2965 0           $arrRef = $db->selectcol_arrayref("select distinct STR from MRCONSO where CUI='$concept' and ($sabdefsources or SAB='SRC')");
2966             }
2967              
2968             # check the database for errors
2969 0           $errorhandler->_checkDbError($pkg, $function, $db);
2970              
2971             # clean up the strings a bit and lower case them
2972 0           foreach my $tr (@{$arrRef}) {
  0            
2973 0           $tr =~ s/^\s+//;
2974 0           $tr =~ s/\s+$//;
2975 0           $tr =~ s/\s+/ /g;
2976 0           $retHash{lc($tr)} = 1;
2977             }
2978              
2979             # return the strings
2980 0           my @array = keys(%retHash);
2981 0           return \@array;
2982             }
2983              
2984             # method that maps terms to cuis in the sources specified in
2985             # in the configuration file by the user
2986             # input : $concept <- string containing cui
2987             # output: $array <- reference to an array of terms and their sources
2988             sub _getTermSabList {
2989 0     0     my $self = shift;
2990 0           my $concept = shift;
2991              
2992 0           my $function = "_getTermSabList";
2993 0           &_debug($function);
2994              
2995             # check self
2996 0 0 0       if(!defined $self || !ref $self) {
2997 0           $errorhandler->_error($pkg, $function, "", 2);
2998             }
2999              
3000             # check parameter exists
3001 0 0         if(!defined $concept) {
3002 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
3003             }
3004              
3005             # check if valid concept
3006 0 0         if(! ($errorhandler->_validCui($concept)) ) {
3007 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
3008             }
3009              
3010             # initialize the return hash
3011 0           my %retHash = ();
3012              
3013             # if the concept is the root return the root string
3014 0 0         if($concept eq $umlsRoot) {
3015 0           $retHash{"**UMLS ROOT**"}++;
3016 0           my @array = keys(%retHash);
3017 0           return \@array;
3018             }
3019              
3020             # otherwise, set up the db
3021 0           my $db = $self->{'db'};
3022 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3023             # get all of the strings with their corresponding sab
3024 0           my %strhash = (); my $sql = "";
  0            
3025 0 0         if($sabdef_umlsall) {
3026 0           $sql = qq{ select STR, SAB from MRCONSO where CUI='$concept' };
3027             }
3028             else {
3029 0           $sql = qq{select STR, SAB from MRCONSO where CUI='$concept' and ($sabdefsources or SAB='SRC') };
3030             }
3031 0           my $sth = $db->prepare( $sql );
3032 0           $sth->execute();
3033 0           my($str, $sab);
3034 0           $sth->bind_columns( undef, \$str, \$sab );
3035 0           while( $sth->fetch() ) {
3036 0           $str =~ s/^\s+//;
3037 0           $str =~ s/\s+$//;
3038 0           $str =~ s/\s+/ /g;
3039 0           $str = lc($str);
3040 0           my $item = "$sab : $str";
3041 0           $retHash{$item}++;
3042             }
3043              
3044 0           $errorhandler->_checkDbError($pkg, $function, $sth);
3045 0           $sth->finish();
3046              
3047             # return keys
3048 0           my @array = keys(%retHash);
3049 0           return \@array;
3050             }
3051              
3052              
3053             # method to map terms to any concept in the umls
3054             # input : $concept <- string containing cui
3055             # output: $array <- reference to an array containing terms (strings)
3056             sub _getAllTerms {
3057 0     0     my $self = shift;
3058 0           my $concept = shift;
3059              
3060 0           my $function = "_getAllTerms";
3061 0           &_debug($function);
3062              
3063             # check self
3064 0 0 0       if(!defined $self || !ref $self) {
3065 0           $errorhandler->_error($pkg, $function, "", 2);
3066             }
3067              
3068             # check parameter exists
3069 0 0         if(!defined $concept) {
3070 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
3071             }
3072              
3073             # check if valid concept
3074 0 0         if(! ($errorhandler->_validCui($concept)) ) {
3075 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
3076             }
3077              
3078             # initialize the return hash
3079 0           my %retHash = ();
3080              
3081             # if the concept is the root return the root string
3082 0 0         if($concept eq $umlsRoot) {
3083 0           $retHash{"**UMLS ROOT**"}++;
3084 0           my @array = keys(%retHash);
3085 0           return \@array;
3086             }
3087              
3088             # otherwise, set up the db
3089 0           my $db = $self->{'db'};
3090 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3091              
3092             # get all of the strings with their corresponding sab
3093 0           my %strhash = ();
3094 0           my $sql = qq{ select STR, SAB from MRCONSO where CUI='$concept' };
3095 0           my $sth = $db->prepare( $sql );
3096 0           $sth->execute();
3097 0           my($str, $sab);
3098 0           $sth->bind_columns( undef, \$str, \$sab );
3099 0           while( $sth->fetch() ) {
3100 0           $str =~ s/^\s+//;
3101 0           $str =~ s/\s+$//;
3102 0           $str =~ s/\s+/ /g;
3103 0           $str = lc($str);
3104 0           push @{$strhash{$str}}, $sab;
  0            
3105             }
3106 0           $errorhandler->_checkDbError($pkg, $function, $sth);
3107 0           $sth->finish();
3108              
3109             # set the output
3110 0           foreach my $str (sort keys %strhash) {
3111 0           my $sabs = join ", ", @{$strhash{$str}};
  0            
3112 0           my $index = "$str - $sabs";
3113 0           $retHash{$index}++;
3114             }
3115              
3116 0           my @array = keys(%retHash);
3117            
3118 0           return \@array;
3119             }
3120              
3121             # method to map CUIs to a terms in the sources and the relations
3122             # specified in the configuration file by SAB and REL
3123             # input : $term <- string containing a term
3124             # output: $array <- reference to an array containing cuis
3125             sub _getConceptList {
3126              
3127 0     0     my $self = shift;
3128 0           my $term = shift;
3129              
3130 0           my $function = "_getConceptList";
3131 0           &_debug($function);
3132              
3133             # check self
3134 0 0 0       if(!defined $self || !ref $self) {
3135 0           $errorhandler->_error($pkg, $function, "", 2);
3136             }
3137              
3138             # check parameter exists
3139 0 0         if(!defined $term) {
3140 0           $errorhandler->_error($pkg, $function, "Error with input variable \$term.", 4);
3141             }
3142              
3143             # check that the ' are escaped if exist
3144 0           $term=~s/\\?\'/\\\'/;
3145              
3146             # set up the database
3147 0           my $db = $self->{'db'};
3148 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3149              
3150             # get the cuis
3151 0           my $arrRef = "";
3152              
3153 0 0         if($umlsall) {
    0          
3154 0           $arrRef = $db->selectcol_arrayref("select distinct CUI from MRCONSO where STR='$term'");
3155             }
3156             elsif($sources ne "") {
3157              
3158 0           $arrRef = $db->selectcol_arrayref("select distinct CUI from MRCONSO where STR='$term' and ($sources)");
3159             }
3160             else {
3161 0           $errorhandler->_error($pkg, $function, "Error with sources from configuration file.", 5);
3162             }
3163             # check for database errors
3164 0           $errorhandler->_checkDbError($pkg, $function, $db);
3165              
3166 0           return $arrRef;
3167             }
3168              
3169             # method to map CUIs to a terms in the sources and the relations
3170             # specified in the configuration file by SABDEF and RELDEF
3171             # input : $term <- string containing a term
3172             # output: $array <- reference to an array containing cuis
3173             sub _getDefConceptList {
3174              
3175 0     0     my $self = shift;
3176 0           my $term = shift;
3177              
3178 0           my $function = "_getDefConceptList";
3179              
3180             # check self
3181 0 0 0       if(!defined $self || !ref $self) {
3182 0           $errorhandler->_error($pkg, $function, "", 2);
3183             }
3184              
3185             # check parameter exists
3186 0 0         if(!defined $term) {
3187 0           $errorhandler->_error($pkg, $function, "Error with input variable \$term.", 4);
3188             }
3189              
3190             # check that the ' are escaped if exist
3191 0           $term=~s/\\?\'/\\\'/;
3192              
3193             # set up the database
3194 0           my $db = $self->{'db'};
3195 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3196              
3197             # get the cuis
3198 0           my $arrRef = "";
3199            
3200 0 0         if($sabdef_umlsall) {
    0          
3201 0           $arrRef = $db->selectcol_arrayref("select distinct CUI from MRCONSO where STR='$term'");
3202             }
3203             elsif($sabdefsources ne "") {
3204 0           $arrRef = $db->selectcol_arrayref("select distinct CUI from MRCONSO where STR='$term' and ($sabdefsources)");
3205             }
3206             else {
3207 0           $errorhandler->_error($pkg, $function, "Error with sources from configuration file.", 5);
3208             }
3209             # check for database errors
3210 0           $errorhandler->_checkDbError($pkg, $function, $db);
3211              
3212 0           return $arrRef;
3213             }
3214              
3215             # method to map CUIs to a terms using the CUIs in the
3216             # entire UMLS not just the sources in the config file
3217             # input : $term <- string containing a term
3218             # output: $array <- reference to an array containing cuis
3219             sub _getAllConcepts {
3220              
3221 0     0     my $self = shift;
3222 0           my $term = shift;
3223              
3224 0           my $function = "_getAllConcepts";
3225              
3226             # check self
3227 0 0 0       if(!defined $self || !ref $self) {
3228 0           $errorhandler->_error($pkg, $function, "", 2);
3229             }
3230              
3231             # check parameter exists
3232 0 0         if(!defined $term) {
3233 0           $errorhandler->_error($pkg, $function, "Error with input variable \$term.", 4);
3234             }
3235              
3236             # check that the ' are escaped if exist
3237 0           $term=~s/\\?\'/\\\'/;
3238              
3239             # set up the database
3240 0           my $db = $self->{'db'};
3241 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3242              
3243             # get the cuis
3244 0           my $arrRef = $db->selectcol_arrayref("select distinct CUI from MRCONSO where STR='$term'");
3245              
3246             # check for database errors
3247 0           $errorhandler->_checkDbError($pkg, $function, $db);
3248              
3249 0           return $arrRef;
3250             }
3251              
3252             # method returns all the compounds in the sources
3253             # specified in the configuration file
3254             # input:
3255             # output: $hash <- reference to a hash containing cuis
3256             sub _getCompounds {
3257              
3258 0     0     my $self = shift;
3259              
3260 0           my $function = "_getCompounds";
3261 0           &_debug($function);
3262              
3263             # check self
3264 0 0 0       if(!defined $self || !ref $self) {
3265 0           $errorhandler->_error($pkg, $function, "", 2);
3266             }
3267              
3268             # set up the database
3269 0           my $db = $self->{'db'};
3270 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3271              
3272             # initialize return hash
3273 0           my %compounds = ();
3274              
3275             # get strings in the MRCONSO table
3276 0 0         if($umlsall) {
3277             # get all the terms from the MRCONSO table
3278 0           my $strs = $db->selectcol_arrayref("select distinct STR from MRCONSO");
3279 0           $errorhandler->_checkDbError($pkg, $function, $db);
3280              
3281             # loop through the terms and add the ones that have more than one word to the hash
3282 0           foreach my $str (@{$strs}) {
  0            
3283 0           my @array = split/\s+/, $str;
3284 0 0         if($#array > 0) {
3285 0           $compounds{$str} = 0;
3286             }
3287             }
3288             }
3289             else {
3290              
3291             # for each of the sabs in the configuratinon file get strings
3292 0           foreach my $sab (sort keys %sabnamesHash) {
3293            
3294             # get the cuis for that sab
3295 0           my $strs = $db->selectcol_arrayref("select distinct STR from MRCONSO where SAB=\'$sab\'");
3296 0           $errorhandler->_checkDbError($pkg, $function, $db);
3297            
3298             # loop through the terms and add the ones that have more than one word to the hash
3299 0           foreach my $str (@{$strs}) {
  0            
3300 0           my @array = split/\s+/, $str;
3301 0 0         if($#array > 0) {
3302 0           $compounds{$str} = 0;
3303             }
3304             }
3305             }
3306             }
3307            
3308 0           return \%compounds;
3309             }
3310              
3311              
3312             # method returns all of the cuis in the sources
3313             # specified in the configuration file
3314             # input :
3315             # output: $hash <- reference to a hash containing cuis
3316             sub _getCuiList {
3317              
3318 0     0     my $self = shift;
3319              
3320 0           my $function = "_getCuiList";
3321 0           &_debug($function);
3322              
3323             # check self
3324 0 0 0       if(!defined $self || !ref $self) {
3325 0           $errorhandler->_error($pkg, $function, "", 2);
3326             }
3327              
3328             # if this has already been done just return the stored cuiListHash
3329 0           my $elements = keys %cuiListHash;
3330 0 0         if($elements > 0) {
3331 0           return \%cuiListHash;
3332             }
3333              
3334             # otherwise, set up the database
3335 0           my $db = $self->{'db'};
3336 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3337              
3338             # get the sabs in the config file
3339 0           my @sabs = ();
3340 0 0         if($umlsall) {
3341 0           my $s = $db->selectcol_arrayref("select distinct SAB from MRREL");
3342 0           $errorhandler->_checkDbError($pkg, $function, $db);
3343 0           @sabs = @{$s};
  0            
3344             }
3345             else {
3346 0           foreach my $sab (sort keys %sabnamesHash) { push @sabs, $sab; }
  0            
3347             }
3348              
3349             # initialize the cui list hash
3350 0           %cuiListHash = ();
3351              
3352             # for each of the sabs in the configuratino file
3353 0           foreach my $sab (@sabs) {
3354              
3355             # get the cuis for that sab
3356 0           my $cuis = $self->_getCuis($sab);
3357              
3358             # add the cuis to the hash
3359 0           foreach my $cui (@{$cuis}) { $cuiListHash{$cui} = 0 };
  0            
  0            
3360             }
3361              
3362             # add upper level taxonomy
3363 0           foreach my $cui (sort keys %parentTaxonomyArray) { $cuiListHash{$cui} = 0; }
  0            
3364 0           foreach my $cui (sort keys %childTaxonomyArray) { $cuiListHash{$cui} = 0; }
  0            
3365              
3366 0           return \%cuiListHash;
3367             }
3368              
3369             # returns the cuis from a specified source
3370             # input : $sab <- string contain the sources abbreviation
3371             # output: $array <- reference to an array containing cuis
3372             sub _getCuisFromSource {
3373              
3374 0     0     my $self = shift;
3375 0           my $sab = shift;
3376              
3377 0           my $function = "_getCuisFromSource";
3378 0           &_debug($function);
3379              
3380             # check self
3381 0 0 0       if(!defined $self || !ref $self) {
3382 0           $errorhandler->_error($pkg, $function, "", 2);
3383             }
3384              
3385             # get the cuis from the specified source
3386 0           my $arrRef = $self->_getCuis($sab);
3387              
3388 0           return ($arrRef);
3389             }
3390              
3391             # returns all of the sources specified that contain the given cui
3392             # input : $concept <- string containing the cui
3393             # output: $array <- reference to an array contain the sources (abbreviations)
3394             sub _getSab {
3395              
3396 0     0     my $self = shift;
3397 0           my $concept = shift;
3398              
3399 0           my $function = "_getSab";
3400              
3401             # check self
3402 0 0 0       if(!defined $self || !ref $self) {
3403 0           $errorhandler->_error($pkg, $function, "", 2);
3404             }
3405              
3406             # check parameter exists
3407 0 0         if(!defined $concept) {
3408 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
3409             }
3410              
3411             # check if valid concept
3412 0 0         if(! ($errorhandler->_validCui($concept)) ) {
3413 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
3414             }
3415              
3416             # connect to the database
3417 0           my $db = $self->{'db'};
3418 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3419              
3420             # select all the sources from the mrconso table
3421 0           my $arrRef = $db->selectcol_arrayref("select distinct SAB from MRCONSO where CUI='$concept'");
3422              
3423             # check the database for errors
3424 0           $errorhandler->_checkDbError($pkg, $function, $db);
3425              
3426 0           return $arrRef;
3427             }
3428              
3429             # returns the child relations
3430             # input :
3431             # output: $string <- containing the child relations
3432             sub _getChildRelations {
3433 0     0     my $self = shift;
3434              
3435 0           return $childRelations;
3436             }
3437             # returns the parent relations
3438             # input :
3439             # output: $string <- containing the parent relations
3440             sub _getParentRelations {
3441 0     0     my $self = shift;
3442              
3443 0           return $parentRelations;
3444             }
3445              
3446              
3447             # returns the children of a concept - the relations that
3448             # are considered children are predefined by the user.
3449             # the default are the RN and CHD relations
3450             # input : $concept <- string containing a cui
3451             # output: $array <- reference to an array containing a list of cuis
3452             sub _getChildren {
3453              
3454 0     0     my $self = shift;
3455 0           my $concept = shift;
3456              
3457 0           my $function = "_getChildren";
3458             #&_debug($function);
3459              
3460             # check self
3461 0 0 0       if(!defined $self || !ref $self) {
3462 0           $errorhandler->_error($pkg, $function, "", 2);
3463             }
3464              
3465             # check parameter exists
3466 0 0         if(!defined $concept) {
3467 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
3468             }
3469              
3470             # check if valid concept
3471 0 0         if(! ($errorhandler->_validCui($concept)) ) {
3472 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
3473             }
3474              
3475             # connect to the database
3476 0           my $db = $self->{'db'};
3477 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3478              
3479             # if the concept is the umls root node cui return
3480             # the source's cuis
3481 0 0         if($concept eq $umlsRoot) {
3482 0           my @array = (keys %sabHash);
3483 0           return \@array;
3484             }
3485              
3486             # otherwise everything is normal so return its children
3487             else {
3488 0           my $arrRef = "";
3489 0 0         if($umlsall) {
3490 0           $arrRef = $db->selectcol_arrayref("select distinct CUI2 from MRREL where CUI1='$concept' and ($childRelations) and CUI2!='$concept' and SUPPRESS='N'");
3491             }
3492             else {
3493 0           $arrRef = $db->selectcol_arrayref("select distinct CUI2 from MRREL where CUI1='$concept' and ($childRelations) and ($sources) and CUI2!='$concept' and SUPPRESS='N'");
3494             }
3495              
3496             # check the database for errors
3497 0           $errorhandler->_checkDbError($pkg, $function, $db);
3498              
3499             # add the children in the upper taxonomy
3500 0           my @array = ();
3501 0 0         if(exists $childTaxonomyArray{$concept}) {
3502 0           @array = (@{$childTaxonomyArray{$concept}}, @{$arrRef});
  0            
  0            
3503             }
3504             else {
3505 0           @array = @{$arrRef};
  0            
3506             }
3507 0           return \@array;
3508             }
3509             }
3510              
3511              
3512             # returns the parents of a concept - the relations that
3513             # are considered parents are predefined by the user.
3514             # the default are the PAR and RB relations.
3515             # input : $concept <- string containing cui
3516             # outupt: $array <- reference to an array containing a list of cuis
3517             sub _getParents {
3518              
3519 0     0     my $self = shift;
3520 0           my $concept = shift;
3521              
3522 0           my $function = "_getParents";
3523              
3524             # check self
3525 0 0 0       if(!defined $self || !ref $self) {
3526 0           $errorhandler->_error($pkg, $function, "", 2);
3527             }
3528              
3529             # check parameter exists
3530 0 0         if(!defined $concept) {
3531 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
3532             }
3533              
3534             # check if valid concept
3535 0 0         if(! ($errorhandler->_validCui($concept)) ) {
3536 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
3537             }
3538              
3539             # connect to the database
3540 0           my $db = $self->{'db'};
3541 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3542              
3543             # if the cui is a root return an empty array
3544 0 0 0       if($concept eq $umlsRoot) {
    0          
3545 0           my @returnarray = ();
3546 0           return \@returnarray; # empty array
3547             }
3548             # if the cui is a source cui but not a root return the umls root
3549             elsif( (exists $sabHash{$concept}) and ($concept ne $umlsRoot)) {
3550 0           my @returnarray = ();
3551 0           push @returnarray, $umlsRoot;
3552 0           return \@returnarray;
3553             }
3554             # otherwise everything is normal so return its parents
3555             else {
3556 0           my $arrRef = "";
3557 0 0         if($umlsall) {
3558 0           $arrRef = $db->selectcol_arrayref("select distinct CUI2 from MRREL where CUI1='$concept' and ($parentRelations) and CUI2!='$concept' and SUPPRESS='N'");
3559             }
3560             else {
3561 0           $arrRef = $db->selectcol_arrayref("select distinct CUI2 from MRREL where CUI1='$concept' and ($parentRelations) and ($sources) and CUI2!='$concept' and SUPPRESS='N'");
3562             }
3563              
3564             # check the database for errors
3565 0           $errorhandler->_checkDbError($pkg, $function, $db);
3566              
3567             # add the parents in the upper taxonomy
3568 0           my @array = ();
3569 0 0         if(exists $parentTaxonomyArray{$concept}) {
3570 0           @array = (@{$parentTaxonomyArray{$concept}}, @{$arrRef});
  0            
  0            
3571             }
3572             else {
3573 0           @array = @{$arrRef};
  0            
3574             }
3575 0           return \@array;
3576             }
3577             }
3578              
3579             # returns the relations of a concept given a specified source
3580             # input : $concept <- string containing a cui
3581             # output: $array <- reference to an array containing strings of relations
3582             sub _getRelations {
3583              
3584 0     0     my $self = shift;
3585 0           my $concept = shift;
3586              
3587 0           my $function = "_getRelations";
3588 0           &_debug($function);
3589              
3590             # check self
3591 0 0 0       if(!defined $self || !ref $self) {
3592 0           $errorhandler->_error($pkg, $function, "", 2);
3593             }
3594              
3595             # check parameter exists
3596 0 0         if(!defined $concept) {
3597 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
3598             }
3599              
3600             # check if valid concept
3601 0 0         if(! ($errorhandler->_validCui($concept)) ) {
3602 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
3603             }
3604              
3605             # connect to the database
3606 0           my $db = $self->{'db'};
3607 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3608              
3609             # get the relations
3610 0           my $arrRef = "";
3611 0 0         if($umlsall) {
3612 0           $arrRef = $db->selectcol_arrayref("select distinct REL from MRREL where (CUI1='$concept' or CUI2='$concept') and CUI1!=CUI2");
3613             }
3614             else {
3615 0           $arrRef = $db->selectcol_arrayref("select distinct REL from MRREL where (CUI1='$concept' or CUI2='$concept') and ($sources) and CUI1!=CUI2");
3616             }
3617              
3618             # check the database for errors
3619 0           $errorhandler->_checkDbError($pkg, $function, $db);
3620              
3621 0           return $arrRef;
3622             }
3623              
3624             # returns the relations and its source between two concepts
3625             # input : $concept1 <- string containing a cui
3626             # : $concept2 <- string containing a cui
3627             # output: $array <- reference to an array containing the relations
3628             sub _getRelationsBetweenCuis {
3629              
3630 0     0     my $self = shift;
3631 0           my $concept1 = shift;
3632 0           my $concept2 = shift;
3633              
3634 0           my $function = "_getRelationBetweenCuis";
3635 0           &_debug($function);
3636              
3637             # check self
3638 0 0 0       if(!defined $self || !ref $self) {
3639 0           $errorhandler->_error($pkg, $function, "", 2);
3640             }
3641              
3642             # check parameter exists
3643 0 0         if(!defined $concept1) {
3644 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept1.", 4);
3645             }
3646 0 0         if(!defined $concept2) {
3647 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept2.", 4);
3648             }
3649              
3650             # check if valid concept
3651 0 0         if(! ($errorhandler->_validCui($concept1)) ) {
3652 0           $errorhandler->_error($pkg, $function, "Concept ($concept1) is not valid.", 6);
3653             }
3654 0 0         if(! ($errorhandler->_validCui($concept2)) ) {
3655 0           $errorhandler->_error($pkg, $function, "Concept ($concept2) is not valid.", 6);
3656             }
3657             # connect to the database
3658 0           my $db = $self->{'db'};
3659 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3660              
3661 0           my @array = ();
3662              
3663 0 0         if($concept1 eq $umlsRoot) {
3664 0           push @array, "CHD (source)";
3665 0           return \@array;
3666             }
3667              
3668             # get the relations
3669 0           my $sql = "";
3670 0 0         if($umlsall) {
3671 0           $sql = qq{ select distinct REL, SAB from MRREL where (CUI1='$concept1' and CUI2='$concept2') and ($relations)};
3672             }
3673             else {
3674 0           $sql = qq{ select distinct REL, SAB from MRREL where (CUI1='$concept1' and CUI2='$concept2') and ($sources) and ($relations)};
3675             }
3676              
3677 0           my $sth = $db->prepare( $sql );
3678 0           $sth->execute();
3679 0           $errorhandler->_checkDbError($pkg, $function, $sth);
3680              
3681 0           my($rel, $sab);
3682 0           $sth->bind_columns( undef, \$rel, \$sab );
3683 0           while( $sth->fetch() ) {
3684 0           my $str = "$rel ($sab)";
3685 0           push @array, $str;
3686 0           } $sth->finish();
3687              
3688 0           return \@array;
3689             }
3690              
3691             # checks to see a concept is forbidden
3692             # input : $concept <- string containing a cui
3693             # output: $string <- integer indicating true or false
3694             sub _forbiddenConcept {
3695              
3696 0     0     my $self = shift;
3697 0           my $concept = shift;
3698              
3699 0           my $function = "_forbiddenConcept";
3700              
3701             # check self
3702 0 0 0       if(!defined $self || !ref $self) {
3703 0           $errorhandler->_error($pkg, $function, "", 2);
3704             }
3705              
3706             # check parameter exists
3707 0 0         if(!defined $concept) {
3708 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
3709             }
3710              
3711             # check if valid concept
3712 0 0         if(! ($errorhandler->_validCui($concept)) ) {
3713 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
3714             }
3715              
3716             # if concept is one of the following just return
3717             #C1274012|Ambiguous concept (inactive concept)
3718 0 0         if($concept=~/C1274012/) { return 1; }
  0            
3719             #C1274013|Duplicate concept (inactive concept)
3720 0 0         if($concept=~/C1274013/) { return 1; }
  0            
3721             #C1276325|Reason not stated concept (inactive concept)
3722 0 0         if($concept=~/C1276325/) { return 1; }
  0            
3723             #C1274014|Outdated concept (inactive concept)
3724 0 0         if($concept=~/C1274014/) { return 1; }
  0            
3725             #C1274015|Erroneous concept (inactive concept)
3726 0 0         if($concept=~/C1274015/) { return 1; }
  0            
3727             #C1274021|Moved elsewhere (inactive concept)
3728 0 0         if($concept=~/C1274021/) { return 1; }
  0            
3729             #C1443286|unapproved attribute
3730 0 0         if($concept=~/C1443286/) { return 1; }
  0            
3731             #C1274012|non-current concept - ambiguous
3732 0 0         if($concept=~/C1274012/) { return 1; }
  0            
3733             #C2733115|limited status concept
3734 0 0         if($concept=~/C2733115/) { return 1; }
  0            
3735              
3736 0           return 0;
3737             }
3738              
3739             # Subroutine to get the semantic type's tui of a concept
3740             # input : $cui <- string containing a concept
3741             # output: $array <- reference to an array containing the semantic
3742             # type's TUIs associated with the concept
3743             sub _getSt {
3744              
3745 0     0     my $self = shift;
3746 0           my $concept = shift;
3747              
3748 0           my $function = "_getSt";
3749 0           &_debug($function);
3750              
3751             # check self
3752 0 0 0       if(!defined $self || !ref $self) {
3753 0           $errorhandler->_error($pkg, $function, "", 2);
3754             }
3755              
3756             # check parameter exists
3757 0 0         if(!defined $concept) {
3758 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
3759             }
3760              
3761             # check if valid concept
3762 0 0         if(! ($errorhandler->_validCui($concept)) ) {
3763 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
3764             }
3765              
3766             # set the database
3767 0           my $db = $self->{'db'};
3768 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3769              
3770             # get the TUI
3771 0           my $arrRef = $db->selectcol_arrayref("select TUI from MRSTY where CUI=\'$concept\'");
3772              
3773             # check for database errors
3774 0           $errorhandler->_checkDbError($pkg, $function, $db);
3775              
3776 0           return $arrRef;
3777             }
3778              
3779             # subroutine to get the relation(s) between two semantic types
3780             # input : $st1 <- semantic type abbreviation
3781             # $st2 <- semantic type abbreviation
3782             # output: $array <- reference to an array of semantic relation(s)
3783             sub _getSemanticRelation {
3784              
3785 0     0     my $self = shift;
3786 0           my $st1 = shift;
3787 0           my $st2 = shift;
3788              
3789 0           my $function = "_getSemanticRelation";
3790 0           &_debug($function);
3791              
3792             # check self
3793 0 0 0       if(!defined $self || !ref $self) {
3794 0           $errorhandler->_error($pkg, $function, "", 2);
3795             }
3796            
3797             # check input
3798 0 0         if(!defined $st1) {
3799 0           $errorhandler->_error($pkg, $function, "Error with input variable \$st1.", 4);
3800             }
3801 0 0         if(!defined $st2) {
3802 0           $errorhandler->_error($pkg, $function, "Error with input variable \$st2.", 4);
3803             }
3804              
3805             # set the database
3806 0           my $db = $self->{'db'};
3807 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3808              
3809 0           my $string1 = $self->_getStString($st1);
3810 0           my $string2 = $self->_getStString($st2);
3811              
3812             # get the string associated with the semantic type
3813 0           my $arrRef = $db->selectcol_arrayref("select distinct RL from SRSTR where STY_RL1=\'$string1\' and STY_RL2=\'$string2\'");
3814              
3815             # check database errors
3816 0           $errorhandler->_checkDbError($pkg, $function, $db);
3817              
3818 0           my @rarray = shift @{$arrRef};
  0            
3819 0           return \@rarray;;
3820             }
3821              
3822             # subroutine to get the name of a semantic type given its abbreviation
3823             # input : $st <- string containing the abbreviation of the semantic type
3824             # output: $string <- string containing the full name of the semantic type
3825             sub _getStString {
3826              
3827 0     0     my $self = shift;
3828 0           my $st = shift;
3829              
3830 0           my $function = "_getStString";
3831 0           &_debug($function);
3832              
3833             # check self
3834 0 0 0       if(!defined $self || !ref $self) {
3835 0           $errorhandler->_error($pkg, $function, "", 2);
3836             }
3837              
3838             # check parameter exists
3839 0 0         if(!defined $st) {
3840 0           $errorhandler->_error($pkg, $function, "Error with input variable \$st.", 4);
3841             }
3842              
3843             # set the database
3844 0           my $db = $self->{'db'};
3845 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3846              
3847             # get the string associated with the semantic type
3848 0           my $arrRef = $db->selectcol_arrayref("select STY_RL from SRDEF where ABR=\'$st\'");
3849              
3850             # check database errors
3851 0           $errorhandler->_checkDbError($pkg, $function, $db);
3852              
3853 0           return (shift @{$arrRef});
  0            
3854             }
3855              
3856              
3857             # subroutine to get the name of a semantic type given its TUI (UI)
3858             # input : $tui <- string containing the semantic type's TUI
3859             # output: $string <- string containing the semantic type's abbreviation
3860             sub _getStAbr {
3861              
3862 0     0     my $self = shift;
3863 0           my $tui = shift;
3864              
3865 0           my $function = "_getStAbr";
3866 0           &_debug($function);
3867              
3868             # check self
3869 0 0 0       if(!defined $self || !ref $self) {
3870 0           $errorhandler->_error($pkg, $function, "", 2);
3871             }
3872              
3873             # check parameter exists
3874 0 0         if(!defined $tui) {
3875 0           $errorhandler->_error($pkg, $function, "Error with input variable \$tui.", 4);
3876             }
3877              
3878             # if tui is the root return ROOT
3879 0 0         if($tui eq "T000") {
3880 0           return "ST ROOT";
3881             }
3882              
3883             # set the database
3884 0           my $db = $self->{'db'};
3885 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3886              
3887             # obtain the abbreviation
3888 0           my $arrRef = $db->selectcol_arrayref("select ABR from SRDEF where UI=\'$tui\'");
3889              
3890             # check database errors
3891 0           $errorhandler->_checkDbError($pkg, $function, $db);
3892              
3893 0           return (shift @{$arrRef});
  0            
3894             }
3895              
3896              
3897             # subroutine to get the name of a semantic type's TUI given its abbrevation
3898             # input : $string <- string containing the semantic type's abbreviation
3899             # output: $tui <- string containing the semantic type's TUI
3900             sub _getStTui {
3901              
3902 0     0     my $self = shift;
3903 0           my $abbrev = shift;
3904              
3905 0           my $function = "_getStTui";
3906 0           &_debug($function);
3907              
3908             # check self
3909 0 0 0       if(!defined $self || !ref $self) {
3910 0           $errorhandler->_error($pkg, $function, "", 2);
3911             }
3912              
3913             # check parameter exists
3914 0 0         if(!defined $abbrev) {
3915 0           $errorhandler->_error($pkg, $function, "Error with input variable \$abbrev.", 4);
3916             }
3917              
3918             # set the database
3919 0           my $db = $self->{'db'};
3920 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3921              
3922             # obtain the abbreviation
3923 0           my $arrRef = $db->selectcol_arrayref("select UI from SRDEF where ABR=\'$abbrev\'");
3924              
3925             # check database errors
3926 0           $errorhandler->_checkDbError($pkg, $function, $db);
3927              
3928 0           return (shift @{$arrRef});
  0            
3929             }
3930              
3931              
3932             # subroutine to get the definition of a given TUI
3933             # input : $st <- string containing the semantic type's abbreviation
3934             # output: $string <- string containing the semantic type's definition
3935             sub _getStDef {
3936              
3937 0     0     my $self = shift;
3938 0           my $st = shift;
3939              
3940 0           my $function = "_getStDef";
3941 0           &_debug($function);
3942              
3943             # check self
3944 0 0 0       if(!defined $self || !ref $self) {
3945 0           $errorhandler->_error($pkg, $function, "", 2);
3946             }
3947              
3948             # check parameter exists
3949 0 0         if(!defined $st) {
3950 0           $errorhandler->_error($pkg, $function, "Error with input variable \$st.", 4);
3951             }
3952              
3953             # set the database
3954 0           my $db = $self->{'db'};
3955 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
3956              
3957             # get the definition
3958 0           my $arrRef = $db->selectcol_arrayref("select DEF from SRDEF where ABR=\'$st\'");
3959              
3960             # check database errors
3961 0           $errorhandler->_checkDbError($pkg, $function, $db);
3962              
3963 0           return $arrRef;
3964             }
3965              
3966             # method returns the semantic group(s) associated with the concept
3967             # input : $concept <- string containing a cui
3968             # output: $array <- reference to an array containing semantic groups
3969             sub _getSemanticGroup {
3970 0     0     my $self = shift;
3971 0           my $concept = shift;
3972              
3973 0           my $function = "_getSemanticGroup";
3974 0           &_debug($function);
3975              
3976             # check self
3977 0 0 0       if(!defined $self || !ref $self) {
3978 0           $errorhandler->_error($pkg, $function, "", 2);
3979             }
3980              
3981             # check parameter exists
3982 0 0         if(!defined $concept) {
3983 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
3984             }
3985              
3986 0           my $sts = $self->_getSt($concept);
3987            
3988 0           my %groups = ();
3989 0           foreach my $st (@{$sts}) {
  0            
3990 0           my $abr = $self->_getStAbr($st);
3991 0           my $string = $self->_getStString($abr);
3992 0           foreach my $group (@{$semanticGroups{$string}}) {
  0            
3993 0           $groups{$group}++;
3994             }
3995             }
3996            
3997 0           my @array = ();
3998 0           foreach my $group (sort keys %groups) { push @array, $group; }
  0            
3999            
4000 0           return \@array;
4001             }
4002              
4003             # method returns the semantic group(s) associated with a semantic type
4004             # input : $st <- string containing a st
4005             # output: $array <- reference to an array containing semantic groups
4006             sub _stGetSemanticGroup {
4007 0     0     my $self = shift;
4008 0           my $st = shift;
4009              
4010 0           my $function = "_stGetSemanticGroup";
4011 0           &_debug($function);
4012              
4013             # check self
4014 0 0 0       if(!defined $self || !ref $self) {
4015 0           $errorhandler->_error($pkg, $function, "", 2);
4016             }
4017 0           my %groups = ();
4018              
4019 0           my $string = $self->_getStString($st);
4020              
4021 0           foreach my $group (@{$semanticGroups{$string}}) {
  0            
4022 0           $groups{$group}++;
4023             }
4024            
4025 0           my @array = ();
4026 0           foreach my $group (sort keys %groups) { push @array, $group; }
  0            
4027            
4028 0           return \@array;
4029             }
4030              
4031              
4032             # method returns the semantic group(s) associated with the concept
4033             # input : $st <- string containing a semantic type abbreviation
4034             # output: $array <- reference to an array containing semantic groups
4035             sub _getSemanticGroupOfSt {
4036 0     0     my $self = shift;
4037 0           my $st = shift;
4038              
4039 0           my $function = "_getSemanticGroupOfSt";
4040 0           &_debug($function);
4041              
4042             # check self
4043 0 0 0       if(!defined $self || !ref $self) {
4044 0           $errorhandler->_error($pkg, $function, "", 2);
4045             }
4046              
4047             # check parameter exists
4048 0 0         if(!defined $st) {
4049 0           $errorhandler->_error($pkg, $function, "Error with input variable \$st.", 4);
4050             }
4051            
4052 0           my $string = $self->_getStString($st);
4053              
4054 0           my %groups = ();
4055 0           foreach my $group (@{$semanticGroups{$string}}) {
  0            
4056 0           $groups{$group}++;
4057             }
4058            
4059 0           my @array = ();
4060 0           foreach my $group (sort keys %groups) { push @array, $group; }
  0            
4061            
4062 0           return \@array;
4063             }
4064              
4065            
4066             # method that returns a list of concepts (@concepts) related
4067             # to a concept $concept through a relation $rel
4068             # input : $concept <- string containing cui
4069             # $rel <- string containing a relation
4070             # output: $array <- reference to an array of cuis
4071             sub _getExtendedRelated {
4072              
4073 0     0     my $self = shift;
4074 0           my $concept = shift;
4075 0           my $rel = shift;
4076              
4077 0           my $function = "_getExtendedRelated";
4078 0           &_debug($function);
4079              
4080             # check self
4081 0 0 0       if(!defined $self || !ref $self) {
4082 0           $errorhandler->_error($pkg, $function, "", 2);
4083             }
4084              
4085             # check parameter exists
4086 0 0         if(!defined $concept) {
4087 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
4088             }
4089              
4090 0 0         if(!defined $rel) {
4091 0           $errorhandler->_error($pkg, $function, "Error with input variable \$rel.", 4);
4092             }
4093              
4094             # check if valid concept
4095 0 0         if(! ($errorhandler->_validCui($concept)) ) {
4096 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
4097             }
4098              
4099             # set up database
4100 0           my $db = $self->{'db'};
4101 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
4102              
4103             # check if sources are specified and it is not umlsall
4104 0           my $optional = "";
4105 0 0         if(!$umlsall) {
4106 0 0         if($sabdefsources ne "") {
4107 0           $optional = " and ($sabdefsources)";
4108             }
4109             }
4110             # if the relations is either a parent or a child add the reladefparents if specified
4111 0 0 0       if( ($rel=~/PAR|RB/) && ($reladefparents ne "") ) {
4112 0           $optional .= " and ($reladefparents)";
4113             }
4114 0 0 0       if( ($rel=~/CHD|RN/) && ($reladefchildren ne "") ) {
4115 0           $optional .= " and ($reladefchildren)";
4116             }
4117             # return all the relations 'rel' for cui 'concept'
4118 0           my $arrRef = $db->selectcol_arrayref("select distinct CUI2 from MRREL where CUI1='$concept' and REL='$rel' and CUI2!='$concept' $optional");
4119              
4120             # check for errors
4121 0           $errorhandler->_checkDbError($pkg, $function, $db);
4122              
4123 0           return $arrRef;
4124             }
4125              
4126             # subroutine to get the extended definition of a concept from
4127             # the concept and its surrounding relations as specified in the
4128             # the configuration file.
4129             # input : $concept <- string containing a cui
4130             # output: $array <- reference to an array containing the definitions
4131             sub _getExtendedDefinition {
4132              
4133 0     0     my $self = shift;
4134 0           my $concept = shift;
4135              
4136 0           my $function = "_getExtendedDefinition";
4137              
4138             # check self
4139 0 0 0       if(!defined $self || !ref $self) {
4140 0           $errorhandler->_error($pkg, $function, "", 2);
4141             }
4142              
4143             # check parameter exists
4144 0 0         if(!defined $concept) {
4145 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
4146             }
4147              
4148             # check if valid concept
4149 0 0         if(! ($errorhandler->_validCui($concept)) ) {
4150 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
4151             }
4152              
4153             # get database
4154 0           my $db = $self->{'db'};
4155 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
4156              
4157 0           my $sabflag = 1;
4158              
4159 0           my @defs = ();
4160              
4161 0           my $dkeys = keys %relDefHash;
4162              
4163 0 0 0       if( ($dkeys <= 0) or (exists $relDefHash{"ST"}) ) {
4164 0           my $sts = $self->_getSt($concept);
4165 0           foreach my $st (@{$sts}) {
  0            
4166 0           my $abr = $self->_getStAbr($st);
4167 0           my $def = $self->_getStDef($abr);
4168 0           my $str = "$concept ST $abr STDEF : @{$def}";
  0            
4169 0           push @defs, $str;
4170             }
4171             }
4172 0 0 0       if( ($dkeys <= 0) or (exists $relDefHash{"PAR"}) ) {
4173 0           my $parents = $self->_getExtendedRelated($concept, "PAR");
4174 0           foreach my $parent (@{$parents}) {
  0            
4175 0           my $odefs = $self->_getCuiDef($parent, $sabflag);
4176 0           foreach my $d (@{$odefs}) {
  0            
4177 0           my @darray = split/\s+/, $d;
4178 0           my $sab = shift @darray;
4179 0           my $def = "$concept PAR $parent $sab : " . (join " ", @darray);
4180 0           push @defs, $def;
4181             }
4182             }
4183             }
4184 0 0 0       if( ($dkeys <= 0) or (exists $relDefHash{"CHD"}) ) {
4185 0           my $children = $self->_getExtendedRelated($concept, "CHD");
4186 0           foreach my $child (@{$children}) {
  0            
4187 0           my $odefs = $self->_getCuiDef($child, $sabflag);
4188 0           foreach my $d (@{$odefs}) {
  0            
4189 0           my @darray = split/\s+/, $d;
4190 0           my $sab = shift @darray;
4191 0           my $def = "$concept CHD $child $sab : " . (join " ", @darray);
4192 0           push @defs, $def;
4193             }
4194             }
4195             }
4196 0 0 0       if( ($dkeys <= 0) or (exists $relDefHash{"SIB"}) ) {
4197 0           my $siblings = $self->_getExtendedRelated($concept, "SIB");
4198 0           foreach my $sib (@{$siblings}) {
  0            
4199 0           my $odefs = $self->_getCuiDef($sib, $sabflag);
4200 0           foreach my $d (@{$odefs}) {
  0            
4201 0           my @darray = split/\s+/, $d;
4202 0           my $sab = shift @darray;
4203 0           my $def = "$concept SIB $sib $sab : " . (join " ", @darray);
4204 0           push @defs, $def;
4205             }
4206             }
4207             }
4208 0 0 0       if( ($dkeys <= 0) or (exists $relDefHash{"SYN"}) ) {
4209 0           my $syns = $self->_getExtendedRelated($concept, "SYN");
4210 0           foreach my $syn (@{$syns}) {
  0            
4211 0           my $odefs = $self->_getCuiDef($syn, $sabflag);
4212 0           foreach my $d (@{$odefs}) {
  0            
4213 0           my @darray = split/\s+/, $d;
4214 0           my $sab = shift @darray;
4215 0           my $def = "$concept SYN $syn $sab : " . (join " ", @darray);
4216 0           push @defs, $def;
4217             }
4218             }
4219             }
4220 0 0 0       if( ($dkeys <= 0) or (exists $relDefHash{"RB"}) ) {
4221 0           my $rbs = $self->_getExtendedRelated($concept, "RB");
4222 0           foreach my $rb (@{$rbs}) {
  0            
4223 0           my $odefs = $self->_getCuiDef($rb, $sabflag);
4224 0           foreach my $d (@{$odefs}) {
  0            
4225 0           my @darray = split/\s+/, $d;
4226 0           my $sab = shift @darray;
4227 0           my $def = "$concept RB $rb $sab : " . (join " ", @darray);
4228 0           push @defs, $def;
4229             }
4230             }
4231             }
4232 0 0 0       if( ($dkeys <= 0) or (exists $relDefHash{"RN"}) ) {
4233 0           my $rns = $self->_getExtendedRelated($concept, "RN");
4234 0           foreach my $rn (@{$rns}) {
  0            
4235 0           my $odefs = $self->_getCuiDef($rn, $sabflag);
4236 0           foreach my $d (@{$odefs}) {
  0            
4237 0           my @darray = split/\s+/, $d;
4238 0           my $sab = shift @darray;
4239 0           my $def = "$concept RN $rn $sab : " . (join " ", @darray);
4240 0           push @defs, $def;
4241             }
4242             }
4243             }
4244 0 0 0       if( ($dkeys <= 0) or (exists $relDefHash{"RO"}) ) {
4245 0           my $ros = $self->_getExtendedRelated($concept, "RO");
4246 0           foreach my $ro (@{$ros}) {
  0            
4247 0           my $odefs = $self->_getCuiDef($ro, $sabflag);
4248 0           foreach my $d (@{$odefs}) {
  0            
4249 0           my @darray = split/\s+/, $d;
4250 0           my $sab = shift @darray;
4251 0           my $def = "$concept RO $ro $sab : " . (join " ", @darray);
4252 0           push @defs, $def;
4253             }
4254             }
4255             }
4256 0 0 0       if( ($dkeys <= 0) or (exists $relDefHash{"CUI"}) ) {
4257 0           my $odefs = $self->_getCuiDef($concept, $sabflag);
4258 0           foreach my $d (@{$odefs}) {
  0            
4259 0           my @darray = split/\s+/, $d;
4260 0           my $sab = shift @darray;
4261 0           my $def = "$concept CUI $concept $sab : " . (join " ", @darray);
4262 0           push @defs, $def;
4263             }
4264             }
4265 0 0 0       if( ($dkeys <= 0) or (exists $relDefHash{"TERM"}) ) {
4266 0           my $odefs = $self->_getTermSabList($concept);
4267 0           foreach my $item (@{$odefs}) {
  0            
4268 0           my ($sab, $term) = split/\s*\:\s*/, $item;
4269 0           my $def = "$concept TERM $concept $sab : $term";
4270 0           push @defs, $def;
4271             }
4272             }
4273 0           return \@defs;
4274             }
4275              
4276             # subroutine to get a CUIs definition
4277             # input : $concept <- string containing a cui
4278             # output: $array <- reference to an array of definitions (strings)
4279             sub _getCuiDef {
4280              
4281 0     0     my $self = shift;
4282 0           my $concept = shift;
4283 0           my $sabflag = shift;
4284              
4285 0           my $function = "_getCuiDef";
4286              
4287             # check self
4288 0 0 0       if(!defined $self || !ref $self) {
4289 0           $errorhandler->_error($pkg, $function, "", 2);
4290             }
4291              
4292             # check parameter exists
4293 0 0         if(!defined $concept) {
4294 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
4295             }
4296              
4297             # check if valid concept
4298 0 0         if(! ($errorhandler->_validCui($concept)) ) {
4299 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
4300             }
4301              
4302             # get database
4303 0           my $db = $self->{'db'};
4304 0 0         if(!$db) { $errorhandler->_error($pkg, $function, "Error with db.", 3); }
  0            
4305              
4306             # set the query
4307 0           my $sql = "";
4308              
4309 0 0         if($sabdefsources ne "") {
4310 0           $sql = qq{ SELECT DEF, SAB FROM MRDEF WHERE CUI=\'$concept\' and ($sabdefsources) };
4311             }
4312             else {
4313 0           $sql = qq{ SELECT DEF, SAB FROM MRDEF WHERE CUI=\'$concept\' };
4314             }
4315              
4316             # get the information from the database
4317 0           my $sth = $db->prepare( $sql );
4318 0           $sth->execute();
4319 0           $errorhandler->_checkDbError($pkg, $function, $sth);
4320              
4321             # set the output variable
4322 0           my($def, $sab);
4323 0           my @defs = ();
4324 0           $sth->bind_columns( undef, \$def, \$sab );
4325 0           while( $sth->fetch() ) {
4326 0 0         if(defined $sabflag) { push @defs, "$sab $def"; }
  0            
4327 0           else { push @defs, $def; }
4328 0           } $sth->finish();
4329              
4330 0           return \@defs;
4331             }
4332              
4333              
4334             # returns the table names in both human readable and hex form
4335             # input :
4336             # output: $hash <- reference to a hash containin the table
4337             # names in human readable and hex form
4338             sub _returnTableNames {
4339 0     0     my $self = shift;
4340              
4341 0           my $function = "_returnTableNames";
4342              
4343             # check self
4344 0 0 0       if(!defined $self || !ref $self) {
4345 0           $errorhandler->_error($pkg, $function, "", 2);
4346             }
4347              
4348             # set the output variable
4349 0           my %hash = ();
4350 0           $hash{$parentTableHuman} = $parentTable;
4351 0           $hash{$childTableHuman} = $childTable;
4352 0           $hash{$intrinsicTableHuman} = $intrinsicTable;
4353 0           $hash{$tableNameHuman} = $tableName;
4354 0           $hash{$cacheTableHuman} = $cacheTable;
4355              
4356 0           return \%hash;
4357             }
4358              
4359             # sets the semantic groups
4360             # input:
4361             # output:
4362             sub _setSemanticGroups {
4363              
4364 0     0     %semanticGroups = ();
4365              
4366 0           push @{$semanticGroups{"Activity"}}, "Activities & Behaviors";
  0            
4367 0           push @{$semanticGroups{"Behavior"}}, "Activities & Behaviors";
  0            
4368 0           push @{$semanticGroups{"Daily or Recreational Activity"}}, "Activities & Behaviors";
  0            
4369 0           push @{$semanticGroups{"Event"}}, "Activities & Behaviors";
  0            
4370 0           push @{$semanticGroups{"Governmental or Regulatory Activity"}}, "Activities & Behaviors";
  0            
4371 0           push @{$semanticGroups{"Individual Behavior"}}, "Activities & Behaviors";
  0            
4372 0           push @{$semanticGroups{"Machine Activity"}}, "Activities & Behaviors";
  0            
4373 0           push @{$semanticGroups{"Occupational Activity"}}, "Activities & Behaviors";
  0            
4374 0           push @{$semanticGroups{"Social Behavior"}}, "Activities & Behaviors";
  0            
4375 0           push @{$semanticGroups{"Anatomical Structure"}}, "Anatomy";
  0            
4376 0           push @{$semanticGroups{"Body Location or Region"}}, "Anatomy";
  0            
4377 0           push @{$semanticGroups{"Body Part, Organ, or Organ Component"}}, "Anatomy";
  0            
4378 0           push @{$semanticGroups{"Body Space or Junction"}}, "Anatomy";
  0            
4379 0           push @{$semanticGroups{"Body Substance"}}, "Anatomy";
  0            
4380 0           push @{$semanticGroups{"Body System"}}, "Anatomy";
  0            
4381 0           push @{$semanticGroups{"Cell"}}, "Anatomy";
  0            
4382 0           push @{$semanticGroups{"Cell Component"}}, "Anatomy";
  0            
4383 0           push @{$semanticGroups{"Embryonic Structure"}}, "Anatomy";
  0            
4384 0           push @{$semanticGroups{"Fully Formed Anatomical Structure"}}, "Anatomy";
  0            
4385 0           push @{$semanticGroups{"Tissue"}}, "Anatomy";
  0            
4386 0           push @{$semanticGroups{"Amino Acid, Peptide, or Protein"}}, "Chemicals & Drugs";
  0            
4387 0           push @{$semanticGroups{"Antibiotic"}}, "Chemicals & Drugs";
  0            
4388 0           push @{$semanticGroups{"Biologically Active Substance"}}, "Chemicals & Drugs";
  0            
4389 0           push @{$semanticGroups{"Biomedical or Dental Material"}}, "Chemicals & Drugs";
  0            
4390 0           push @{$semanticGroups{"Carbohydrate"}}, "Chemicals & Drugs";
  0            
4391 0           push @{$semanticGroups{"Chemical"}}, "Chemicals & Drugs";
  0            
4392 0           push @{$semanticGroups{"Chemical Viewed Functionally"}}, "Chemicals & Drugs";
  0            
4393 0           push @{$semanticGroups{"Chemical Viewed Structurally"}}, "Chemicals & Drugs";
  0            
4394 0           push @{$semanticGroups{"Clinical Drug"}}, "Chemicals & Drugs";
  0            
4395 0           push @{$semanticGroups{"Eicosanoid"}}, "Chemicals & Drugs";
  0            
4396 0           push @{$semanticGroups{"Element, Ion, or Isotope"}}, "Chemicals & Drugs";
  0            
4397 0           push @{$semanticGroups{"Enzyme"}}, "Chemicals & Drugs";
  0            
4398 0           push @{$semanticGroups{"Hazardous or Poisonous Substance"}}, "Chemicals & Drugs";
  0            
4399 0           push @{$semanticGroups{"Hormone"}}, "Chemicals & Drugs";
  0            
4400 0           push @{$semanticGroups{"Immunologic Factor"}}, "Chemicals & Drugs";
  0            
4401 0           push @{$semanticGroups{"Indicator, Reagent, or Diagnostic Aid"}}, "Chemicals & Drugs";
  0            
4402 0           push @{$semanticGroups{"Inorganic Chemical"}}, "Chemicals & Drugs";
  0            
4403 0           push @{$semanticGroups{"Lipid"}}, "Chemicals & Drugs";
  0            
4404 0           push @{$semanticGroups{"Neuroreactive Substance or Biogenic Amine"}}, "Chemicals & Drugs";
  0            
4405 0           push @{$semanticGroups{"Nucleic Acid, Nucleoside, or Nucleotide"}}, "Chemicals & Drugs";
  0            
4406 0           push @{$semanticGroups{"Organic Chemical"}}, "Chemicals & Drugs";
  0            
4407 0           push @{$semanticGroups{"Organophosphorus Compound"}}, "Chemicals & Drugs";
  0            
4408 0           push @{$semanticGroups{"Pharmacologic Substance"}}, "Chemicals & Drugs";
  0            
4409 0           push @{$semanticGroups{"Receptor"}}, "Chemicals & Drugs";
  0            
4410 0           push @{$semanticGroups{"Steroid"}}, "Chemicals & Drugs";
  0            
4411 0           push @{$semanticGroups{"Vitamin"}}, "Chemicals & Drugs";
  0            
4412 0           push @{$semanticGroups{"Classification"}}, "Concepts & Ideas";
  0            
4413 0           push @{$semanticGroups{"Conceptual Entity"}}, "Concepts & Ideas";
  0            
4414 0           push @{$semanticGroups{"Functional Concept"}}, "Concepts & Ideas";
  0            
4415 0           push @{$semanticGroups{"Group Attribute"}}, "Concepts & Ideas";
  0            
4416 0           push @{$semanticGroups{"Idea or Concept"}}, "Concepts & Ideas";
  0            
4417 0           push @{$semanticGroups{"Intellectual Product"}}, "Concepts & Ideas";
  0            
4418 0           push @{$semanticGroups{"Language"}}, "Concepts & Ideas";
  0            
4419 0           push @{$semanticGroups{"Qualitative Concept"}}, "Concepts & Ideas";
  0            
4420 0           push @{$semanticGroups{"Quantitative Concept"}}, "Concepts & Ideas";
  0            
4421 0           push @{$semanticGroups{"Regulation or Law"}}, "Concepts & Ideas";
  0            
4422 0           push @{$semanticGroups{"Spatial Concept"}}, "Concepts & Ideas";
  0            
4423 0           push @{$semanticGroups{"Temporal Concept"}}, "Concepts & Ideas";
  0            
4424 0           push @{$semanticGroups{"Drug Delivery Device"}}, "Devices";
  0            
4425 0           push @{$semanticGroups{"Medical Device"}}, "Devices";
  0            
4426 0           push @{$semanticGroups{"Research Device"}}, "Devices";
  0            
4427 0           push @{$semanticGroups{"Acquired Abnormality"}}, "Disorders";
  0            
4428 0           push @{$semanticGroups{"Anatomical Abnormality"}}, "Disorders";
  0            
4429 0           push @{$semanticGroups{"Cell or Molecular Dysfunction"}}, "Disorders";
  0            
4430 0           push @{$semanticGroups{"Congenital Abnormality"}}, "Disorders";
  0            
4431 0           push @{$semanticGroups{"Disease or Syndrome"}}, "Disorders";
  0            
4432 0           push @{$semanticGroups{"Experimental Model of Disease"}}, "Disorders";
  0            
4433 0           push @{$semanticGroups{"Finding"}}, "Disorders";
  0            
4434 0           push @{$semanticGroups{"Injury or Poisoning"}}, "Disorders";
  0            
4435 0           push @{$semanticGroups{"Mental or Behavioral Dysfunction"}}, "Disorders";
  0            
4436 0           push @{$semanticGroups{"Neoplastic Process"}}, "Disorders";
  0            
4437 0           push @{$semanticGroups{"Pathologic Function"}}, "Disorders";
  0            
4438 0           push @{$semanticGroups{"Sign or Symptom"}}, "Disorders";
  0            
4439 0           push @{$semanticGroups{"Amino Acid Sequence"}}, "Genes & Molecular Sequences";
  0            
4440 0           push @{$semanticGroups{"Carbohydrate Sequence"}}, "Genes & Molecular Sequences";
  0            
4441 0           push @{$semanticGroups{"Gene or Genome"}}, "Genes & Molecular Sequences";
  0            
4442 0           push @{$semanticGroups{"Molecular Sequence"}}, "Genes & Molecular Sequences";
  0            
4443 0           push @{$semanticGroups{"Nucleotide Sequence"}}, "Genes & Molecular Sequences";
  0            
4444 0           push @{$semanticGroups{"Geographic Area"}}, "Geographic Areas";
  0            
4445 0           push @{$semanticGroups{"Age Group"}}, "Living Beings";
  0            
4446 0           push @{$semanticGroups{"Amphibian"}}, "Living Beings";
  0            
4447 0           push @{$semanticGroups{"Animal"}}, "Living Beings";
  0            
4448 0           push @{$semanticGroups{"Archaeon"}}, "Living Beings";
  0            
4449 0           push @{$semanticGroups{"Bacterium"}}, "Living Beings";
  0            
4450 0           push @{$semanticGroups{"Bird"}}, "Living Beings";
  0            
4451 0           push @{$semanticGroups{"Eukaryote"}}, "Living Beings";
  0            
4452 0           push @{$semanticGroups{"Family Group"}}, "Living Beings";
  0            
4453 0           push @{$semanticGroups{"Fish"}}, "Living Beings";
  0            
4454 0           push @{$semanticGroups{"Fungus"}}, "Living Beings";
  0            
4455 0           push @{$semanticGroups{"Group"}}, "Living Beings";
  0            
4456 0           push @{$semanticGroups{"Human"}}, "Living Beings";
  0            
4457 0           push @{$semanticGroups{"Mammal"}}, "Living Beings";
  0            
4458 0           push @{$semanticGroups{"Organism"}}, "Living Beings";
  0            
4459 0           push @{$semanticGroups{"Patient or Disabled Group"}}, "Living Beings";
  0            
4460 0           push @{$semanticGroups{"Plant"}}, "Living Beings";
  0            
4461 0           push @{$semanticGroups{"Population Group"}}, "Living Beings";
  0            
4462 0           push @{$semanticGroups{"Professional or Occupational Group"}}, "Living Beings";
  0            
4463 0           push @{$semanticGroups{"Reptile"}}, "Living Beings";
  0            
4464 0           push @{$semanticGroups{"Vertebrate"}}, "Living Beings";
  0            
4465 0           push @{$semanticGroups{"Virus"}}, "Living Beings";
  0            
4466 0           push @{$semanticGroups{"Entity"}}, "Objects";
  0            
4467 0           push @{$semanticGroups{"Food"}}, "Objects";
  0            
4468 0           push @{$semanticGroups{"Manufactured Object"}}, "Objects";
  0            
4469 0           push @{$semanticGroups{"Physical Object"}}, "Objects";
  0            
4470 0           push @{$semanticGroups{"Substance"}}, "Objects";
  0            
4471 0           push @{$semanticGroups{"Biomedical Occupation or Discipline"}}, "Occupations";
  0            
4472 0           push @{$semanticGroups{"Occupation or Discipline"}}, "Occupations";
  0            
4473 0           push @{$semanticGroups{"Health Care Related Organization"}}, "Organizations";
  0            
4474 0           push @{$semanticGroups{"Organization"}}, "Organizations";
  0            
4475 0           push @{$semanticGroups{"Professional Society"}}, "Organizations";
  0            
4476 0           push @{$semanticGroups{"Self-help or Relief Organization"}}, "Organizations";
  0            
4477 0           push @{$semanticGroups{"Biologic Function"}}, "Phenomena";
  0            
4478 0           push @{$semanticGroups{"Environmental Effect of Humans"}}, "Phenomena";
  0            
4479 0           push @{$semanticGroups{"Human-caused Phenomenon or Process"}}, "Phenomena";
  0            
4480 0           push @{$semanticGroups{"Laboratory or Test Result"}}, "Phenomena";
  0            
4481 0           push @{$semanticGroups{"Natural Phenomenon or Process"}}, "Phenomena";
  0            
4482 0           push @{$semanticGroups{"Phenomenon or Process"}}, "Phenomena";
  0            
4483 0           push @{$semanticGroups{"Cell Function"}}, "Physiology";
  0            
4484 0           push @{$semanticGroups{"Clinical Attribute"}}, "Physiology";
  0            
4485 0           push @{$semanticGroups{"Genetic Function"}}, "Physiology";
  0            
4486 0           push @{$semanticGroups{"Mental Process"}}, "Physiology";
  0            
4487 0           push @{$semanticGroups{"Molecular Function"}}, "Physiology";
  0            
4488 0           push @{$semanticGroups{"Organism Attribute"}}, "Physiology";
  0            
4489 0           push @{$semanticGroups{"Organism Function"}}, "Physiology";
  0            
4490 0           push @{$semanticGroups{"Organ or Tissue Function"}}, "Physiology";
  0            
4491 0           push @{$semanticGroups{"Physiologic Function"}}, "Physiology";
  0            
4492 0           push @{$semanticGroups{"Diagnostic Procedure"}}, "Procedures";
  0            
4493 0           push @{$semanticGroups{"Educational Activity"}}, "Procedures";
  0            
4494 0           push @{$semanticGroups{"Health Care Activity"}}, "Procedures";
  0            
4495 0           push @{$semanticGroups{"Laboratory Procedure"}}, "Procedures";
  0            
4496 0           push @{$semanticGroups{"Molecular Biology Research Technique"}}, "Procedures";
  0            
4497 0           push @{$semanticGroups{"Research Activity"}}, "Procedures";
  0            
4498 0           push @{$semanticGroups{"Therapeutic or Preventive Procedure"}}, "Procedures";
  0            
4499             }
4500              
4501             # removes the configuration tables
4502             # input :
4503             # output:
4504             sub _dropConfigTable {
4505              
4506 0     0     my $self = shift;
4507              
4508 0           my $function = "_dropConfigTable";
4509 0           &_debug($function);
4510              
4511             # check self
4512 0 0 0       if(!defined $self || !ref $self) {
4513 0           $errorhandler->_error($pkg, $function, "", 2);
4514             }
4515              
4516             # connect to the database
4517 0           my $sdb = $self->_connectIndexDB();
4518 0 0         if(!$sdb) { $errorhandler->_error($pkg, $function, "Error with sdb.", 3); }
  0            
4519              
4520             # show all of the tables
4521 0           my $sth = $sdb->prepare("show tables");
4522 0           $sth->execute();
4523 0           $errorhandler->_checkDbError($pkg, $function, $sth);
4524              
4525             # get all the tables in mysql
4526 0           my $table = "";
4527 0           my %tables = ();
4528 0           while(($table) = $sth->fetchrow()) {
4529 0           $tables{$table}++;
4530             }
4531 0           $sth->finish();
4532              
4533 0 0         if(exists $tables{$intrinsicTable}) {
4534 0           $sdb->do("drop table $intrinsicTable");
4535 0           $errorhandler->_checkDbError($pkg, $function, $sdb);
4536             }
4537 0 0         if(exists $tables{$parentTable}) {
4538 0           $sdb->do("drop table $parentTable");
4539 0           $errorhandler->_checkDbError($pkg, $function, $sdb);
4540             }
4541 0 0         if(exists $tables{$childTable}) {
4542 0           $sdb->do("drop table $childTable");
4543 0           $errorhandler->_checkDbError($pkg, $function, $sdb);
4544             }
4545 0 0         if(exists $tables{$cacheTable}) {
4546 0           $sdb->do("drop table $cacheTable");
4547 0           $errorhandler->_checkDbError($pkg, $function, $sdb);
4548             }
4549 0 0         if(exists $tables{$tableName}) {
4550 0           $sdb->do("drop table $tableName");
4551 0           $errorhandler->_checkDbError($pkg, $function, $sdb);
4552             }
4553 0 0         if(exists $tables{$infoTable}) {
4554 0           $sdb->do("drop table $infoTable");
4555 0           $errorhandler->_checkDbError($pkg, $function, $sdb);
4556             }
4557 0 0         if(exists $tables{"tableindex"}) {
4558              
4559 0           $sdb->do("delete from tableindex where HEX='$intrinsicTable'");
4560 0           $errorhandler->_checkDbError($pkg, $function, $sdb);
4561              
4562 0           $sdb->do("delete from tableindex where HEX='$parentTable'");
4563 0           $errorhandler->_checkDbError($pkg, $function, $sdb);
4564              
4565 0           $sdb->do("delete from tableindex where HEX='$childTable'");
4566 0           $errorhandler->_checkDbError($pkg, $function, $sdb);
4567              
4568 0           $sdb->do("delete from tableindex where HEX='$cacheTable'");
4569 0           $errorhandler->_checkDbError($pkg, $function, $sdb);
4570              
4571 0           $sdb->do("delete from tableindex where HEX='$tableName'");
4572 0           $errorhandler->_checkDbError($pkg, $function, $sdb);
4573              
4574 0           $sdb->do("delete from tableindex where HEX='$infoTable'");
4575 0           $errorhandler->_checkDbError($pkg, $function, $sdb);
4576             }
4577             }
4578              
4579             # removes the configuration files
4580             # input :
4581             # output:
4582             sub _removeConfigFiles {
4583              
4584 0     0     my $self = shift;
4585              
4586 0           my $function = "_removeConfigFiles";
4587 0           &_debug($function);
4588              
4589             # check self
4590 0 0 0       if(!defined $self || !ref $self) {
4591 0           $errorhandler->_error($pkg, $function, "", 2);
4592             }
4593              
4594             # remove the files
4595 0 0         if(-e $tableFile) {
4596 0           system "rm $tableFile";
4597             }
4598 0 0         if(-e $childFile) {
4599 0           system "rm $childFile";
4600             }
4601 0 0         if(-e $parentFile) {
4602 0           system "rm $parentFile";
4603             }
4604 0 0         if(-e $configFile) {
4605 0           system "rm $configFile";
4606             }
4607              
4608             }
4609              
4610             # checks to see if the cui is in the parent taxonomy
4611             # input : $concept <- string containing a cui
4612             # output: $bool <- indicating if the cui exists in
4613             # the upper level taxonamy
4614             sub _inParentTaxonomy {
4615              
4616 0     0     my $self = shift;
4617 0           my $concept = shift;
4618              
4619 0           my $function = "_inParentTaxonomy";
4620 0           &_debug($function);
4621              
4622             # check self
4623 0 0 0       if(!defined $self || !ref $self) {
4624 0           $errorhandler->_error($pkg, $function, "", 2);
4625             }
4626              
4627             # check parameter exists
4628 0 0         if(!defined $concept) {
4629 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
4630             }
4631              
4632             # check if valid concept
4633 0 0         if(! ($errorhandler->_validCui($concept)) ) {
4634 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
4635             }
4636              
4637 0 0         if(exists $parentTaxonomyArray{$concept}) { return 1; }
  0            
4638 0           else { return 0; }
4639             }
4640              
4641             # checks to see if the cui is in the child taxonomy
4642             # input : $concept <- string containing a cui
4643             # output: $bool <- indicating if the cui exists in
4644             # the upper level taxonamy
4645             sub _inChildTaxonomy {
4646              
4647 0     0     my $self = shift;
4648 0           my $concept = shift;
4649              
4650 0           my $function = "_inChildTaxonomy";
4651 0           &_debug($function);
4652              
4653             # check self
4654 0 0 0       if(!defined $self || !ref $self) {
4655 0           $errorhandler->_error($pkg, $function, "", 2);
4656             }
4657              
4658             # check parameter exists
4659 0 0         if(!defined $concept) {
4660 0           $errorhandler->_error($pkg, $function, "Error with input variable \$concept.", 4);
4661             }
4662              
4663             # check if valid concept
4664 0 0         if(! ($errorhandler->_validCui($concept)) ) {
4665 0           $errorhandler->_error($pkg, $function, "Concept ($concept) is not valid.", 6);
4666             }
4667              
4668 0 0         if(exists $childTaxonomyArray{$concept}) { return 1; }
  0            
4669 0           else { return 0; }
4670             }
4671              
4672              
4673             # function to create a timestamp
4674             # input :
4675             # output: $string <- containing the time stamp
4676             sub _timeStamp {
4677              
4678 0     0     my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
4679              
4680 0           $year += 1900;
4681 0           $mon++;
4682 0           my $d = sprintf("%4d%2.2d%2.2d",$year,$mon,$mday);
4683 0           my $t = sprintf("%2.2d%2.2d%2.2d",$hour,$min,$sec);
4684              
4685 0           my $stamp = $d . $t;
4686              
4687 0           return $stamp;
4688             }
4689              
4690             # function to get the time
4691             # input :
4692             # output: $string <- containing the time
4693             sub _printTime {
4694 0     0     my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
4695              
4696 0           $year += 1900;
4697 0           $mon++;
4698              
4699 0           my $d = sprintf("%4d%2.2d%2.2d",$year,$mon,$mday);
4700 0           my $t = sprintf("%2.2d%2.2d%2.2d",$hour,$min,$sec);
4701              
4702 0           print STDERR "$t\n";
4703              
4704             }
4705              
4706             # return the file name containing the index table
4707             sub _getTableFile {
4708              
4709 0     0     return $tableFile;
4710             }
4711              
4712              
4713             # return the table name in the index - this is the hex
4714             sub _getTableName {
4715              
4716 0     0     return $tableName;
4717             }
4718              
4719             # return the table name in the index in human form
4720             sub _getTableNameHuman {
4721              
4722 0     0     return $tableNameHuman;
4723             }
4724              
4725             sub _getCacheTableName {
4726 0     0     return $cacheTable;
4727             }
4728              
4729             sub _getCacheTableNameHuman{
4730 0     0     return $cacheTableHuman;
4731             }
4732              
4733             sub _getInfoTableName {
4734 0     0     return $infoTable;
4735             }
4736              
4737             sub _getInfoTableNameHuman {
4738 0     0     return $infoTableHuman;
4739             }
4740              
4741             sub _getIntrinsicTableName {
4742 0     0     return $intrinsicTable;
4743             }
4744              
4745             sub _getIntrinsicTableNameHuman {
4746 0     0     return $intrinsicTableHuman;
4747             }
4748              
4749             1;
4750              
4751              
4752              
4753              
4754             __END__