#!/usr/bin/perl
#**************************************************************************************************************
#file: deid.pl Original author: M. Douglass 2004
#Last revised: Apr 2009 DeID 1.1
#
#
#_______________________________________________________________________________
#
#deid.pl: De-identification algorithm -- scrubs PHI from free-text medical records
#(e.g. Discharge Summaries and Nursing Notes)
#
#Copyright (C) 2004-2007 Margaret Douglas and Ishna Neamatullah
#
#This code is free software; you can redistribute it and/or modify it under
#the terms of the GNU Library General Public License as published by the Free
#Software Foundation; either version 2 of the License, or (at your option) any
#later version.
#
#This library is distributed in the hope that it will be useful, but WITHOUT ANY
#WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
#PARTICULAR PURPOSE. See the GNU Library General Public License for more
#details.
#
#You should have received a copy of the GNU Library General Public License along
#with this code; if not, write to the Free Software Foundation, Inc., 59
#Temple Place - Suite 330, Boston, MA 02111-1307, USA.
#
#You may contact the author by e-mail or postal mail
#(MIT Room E25-505, Cambridge, MA 02139 USA). For updates to this software,
#please visit PhysioNet (http://www.physionet.org/).
#_______________________________________________________________________________
#
# De-identification Algorithm: Scrubs PHI from free-text medical records
#(e.g. Discharge Summaries and Nursing Notes)
# Original version written by:
# Margaret Douglass (douglass AT alum DOT mit DOT edu)
# William Long (wjl AT mit DOT edu)
# Modified by:
# Ishna Neamatullah (ishna AT alum DOT mit DOT edu) in Sept 5, 2006
# Last modified by:
# Li-wei Lehman (lilehman AT alum DOT mit DOT edu) in April, 2009
#
# Command to run the software:
# perl deid.pl <filename> <config_filename>
#
# Input arguments:
# filename (without extension, where extension must be .text): file to be de-identified
# config_filename: configuration file
#
# Required library file: stat.pm
#
# Output files:
# filename.res: de-identified file
# filename.phi: file containing all PHI locations, used in calculating performance statistics
# filename.info: file containing information useful for debugging
# code performance statistics printed on screen if Gold Standard available for nursing notes (details in README)
#**************************************************************************************************************
#use Stat;
# Declaring some variables for algorithm run configuration
# Variables to switch on/off filter functions
$allfilters = "";
$ssnfilter = "";
$urlfilter = "";
$emailfilter = "";
$telfilter = "";
$unitfilter = "";
$agefilter = "";
$locfilter = "";
$datefilter = "";
$namefilter = "";
$us_state_filter = "";
$ds_specific_filter = ""; #filter for discharge summmary specific patterns
$gs_specific_filter = ""; #filter for gold std specific patterns
my $offset; # positive date shift in number of days
my $comparison = ""; # 1=comparison with gold standard, 0=no comparison with gold standard
# Variables to switch on/off dictionaries/lists
$alllists = "";
$pid_patientname_list = "";
$pid_dateshift_list = "";
$country_list = "";
$company_list = "";
$ethnicity_list = "";
$hospital_list = "";
$doctor_list = "";
$location_list = "";
$local_list = "";
$state_list = "";
use Time::Local;
my ($mday,$mon,$year) = (localtime(time))[3,4,5];
my $shortyear = substr($year,1,4);
my $longyear = '20'.$shortyear;
# Nursing note date as retrieved from the header
my $nn_year;
# Sets whether a de-identified version should be output: 0 = no new version of text output, 1 = fully de-identified version of text output
# Note: Generally keep output_deid_text = 1
$output_deid_text = 1;
#Default date used to de-identify the Gold Std if no default date is specified in the
#config file. You can change the default date by setting the "Default date" variable to
#some other dates (in MM/DD/YYYY format).
$DEFAULT_DATE = "01/01/2000";
#The "Two Digit Year Threshold" is used to determine whether
#to interpret the year as a year in the 1900's or 2000's.
#Must be a 1- or 2-digit number.
#Two digit years > Threshold are interepreted as in the 1900's
#Two digit years <= Threshold are interpreted as in the 2000's
$TWO_DIGIT_YEAR_THRESHOLD = 30;#change this default by setting "Two Digit Year Threshold" in config file.
# "Valid Year Low" and "Valid Year High" (must be 4-digit numbers) are
# used in certain date pattern checking routines to determine if a
# four digit number that appear in a potential
# date pattern is a year or not -- it is a valid year if it is
# in the range of [Valid Year Low, Valid Year High].
$VALID_YEAR_LOW = 1900;
$VALID_YEAR_HIGH = 2030;
my @known_phi;
my @known_first_name;
my @known_last_name;
# Hash that stores PHI information from de-identification
# KEY = (patient number), VALUE = array with each element = (%HASH with KEY = start-end, VALUE = array of types of PHI for the note number/index of the array)
%all_phi;
my %ID;
# Declares some global variables
%lhash = ();
@typename = ();
$ntype = 1;
@extend = ('phrases');
##########################################################################################
# Sets paths to lists and dictionaries in working directory that will be used in this algorithm
$date_shift_file = "shift.txt"; # contains mapping of PID to date offset
$countries_file = "lists/countries_unambig.txt";
$ethnicities_unambig_file = "lists/ethnicities_unambig.txt";
$companies_file = "lists/company_names_unambig.txt";
$companies_ambig_file = "lists/company_names_ambig.txt";
$common_words_file = "dict/common_words.txt";
$medical_words_file = "dict/sno_edited.txt";
$very_common_words_file = "dict/commonest_words.txt";
$female_unambig_file = "lists/female_names_unambig.txt";
$female_ambig_file = "lists/female_names_ambig.txt";
$female_popular_file = "lists/female_names_popular.txt";
$male_unambig_file = "lists/male_names_unambig.txt";
$male_ambig_file = "lists/male_names_ambig.txt";
$male_popular_file = "lists/male_names_popular.txt";
$last_unambig_file = "lists/last_names_unambig.txt";
$last_ambig_file = "lists/last_names_ambig.txt";
$last_popular_file = "lists/last_names_popular.txt";
#$last_name_prefixes_file = "lists/last_name_prefixes.txt";
$doctor_first_unambig_file = "lists/doctor_first_names.txt";
$doctor_last_unambig_file = "lists/doctor_last_names.txt";
$prefixes_unambig_file = "lists/prefixes_unambig.txt";
$locations_unambig_file = "lists/locations_unambig.txt";
$locations_ambig_file = "lists/locations_ambig.txt";
$local_places_ambig_file = "lists/local_places_ambig.txt";
$local_places_unambig_file = "lists/local_places_unambig.txt";
$hospital_file = "lists/stripped_hospitals.txt";
$last_name_prefix_file = "lists/last_name_prefixes.txt";
$patient_file = "lists/pid_patientname.txt"; # contains mapping of PID to patient name
$us_states_file = "lists/us_states.txt";
$us_states_abbre_file = "lists/us_states_abbre.txt";
$more_us_states_abbre_file = "lists/more_us_state_abbreviations.txt";
$us_area_code_file = "lists/us_area_code.txt";
$medical_phrases_file = "dict/medical_phrases.txt";
$unambig_common_words_file = "dict/notes_common.txt";
############################################################################################################
# Declares some arrays of context words that can be used to identify PHI
# Days of the month
@days = ("monday", "tuesday", "wednesday", "thursday", "friday", "saturday", "sunday");
# Titles that precede last names (ignore .'s)
@titles = ("MISTER", "DOCTOR", "DOCTORS", "MISS", "PROF", "PROFESSOR", "REV", "RABBI", "NURSE", "MD", "PRINCESS", "PRINCE", "DEACON", "DEACONESS", "CAREGIVER", "PRACTITIONER", "MR", "MS");
@strict_titles = ("Dr", "DRS", "Mrs"); #treat words after these strict_titles as PHI
%titles = ();
foreach $title (@titles){
$titles{$title} = 1;
}
# Name indicators that precede or follow names
@name_indicators = ("problem","problem:", "proxy", "daughter","daughters", "dtr", "son", "brother","sister", "mother", "mom", "father", "dad", "wife", "husband", "neice", "nephew", "spouse", "partner", "cousin", "aunt", "uncle", "granddaughter", "grandson", "grandmother", "grandmom", "grandfather", "granddad", "relative", "friend", "neighbor", "visitor", "family member", "lawyer", "priest", "rabbi", "coworker", "co-worker", "boyfriend", "girlfriend", "name is", "named", "rrt", "significant other", "jr", "caregiver", "proxys", "friends", "sons", "brothers", "sisters", "sister-in-law", "brother-in-law", "mother-in-law", "father-in-law", "son-in-law", "daughter-in-law", "dtr-in-law", "surname will be", "name will be", "name at discharge will be", "name at discharge is");
# Phrases that precede locations
@location_indicators = ("lives in", "resident of", "lived in", "lives at", "comes from", "called from", "visited from", "arrived from", "returned to");
@employment_indicators_pre = ("employee of", "employed by", "employed at", "CEO of", "manager at", "manager for", "manager of", "works at", "business");
# Hospital indicators that follow hospital names
@hospital_indicators = ("Hospital", "General Hospital", "Gen Hospital", "gen hosp", "hosp", "Medical Center", "Med Center", "Med Ctr", "Rehab", "Clinic", "Rehabilitation", "Campus", "health center", "cancer center", "development center", "community health center", "health and rehabilitation", "Medical", "transferred to", "transferred from", "transfered to", "transfered from");
# Location indicators that follow locations
@loc_indicators_suff = ("city", "town", "beach", "valley","county", "harbor", "ville", "creek", "springs", "mountain", "island", "lake", "lakes", "shore", "garden", "haven", "village", "grove", "hills", "hill", "shire", "cove", "coast", "alley", "street", "terrace", "boulevard", "parkway", "highway", "university", "college", "tower");
# Location indicators that are most likely preceded by locations
@loc_ind_suff_c = ("town", "ville", "harbor", "tower");
# Location indicators that precede locations
#@loc_indicators_pre = ("cape", "fort", "lake", "mount", "santa", "los", "great","east","west","north","south");
@loc_indicators_pre = ("cape", "fort", "lake", "mount", "santa", "los", "east","west","north","south");
@apt_indicators = ("apt", "suite"); #only check these after the street address is found
@street_add_suff = ("park", "drive", "street", "road", "lane", "boulevard", "blvd", "avenue", "highway", "circle","ave", "place", "rd", "st");
#Strict street address suffix: case-sensitive match on the following,
#and will be marked as PHI regardless of ambiguity (common words)
@strict_street_add_suff = ("Park", "Drive", "Street", "Road", "Lane", "Boulevard", "Blvd", "Avenue", "Highway","Ave",,"Rd", "PARK", "DRIVE", "STREET", "ROAD", "LANE", "BOULEVARD", "BLVD", "AVENUE", "HIGHWAY","AVE", "RD");
# Age indicators that follow ages
@age_indicators_suff = ("year old", "y\. o\.", "y\.o\.", "yo", "y", "years old", "year-old", "-year-old", "years-old", "-years-old", "years of age", "yrs of age");
# Age indicators that precede ages
@age_indicators_pre = ("age", "he is", "she is", "patient is");
# Digits, used in identifying ages
@digits = ("one","two","three","four","five","six","seven","eight","nine", "");
# Different variations of the 12 months
@months = ("January", "Jan", "February", "Feb", "March", "Mar", "April", "Apr", "May", "June", "Jun", "July", "Jul", "August", "Aug", "September", "Sept", "Sep", "October", "Oct", "November", "Nov", "December", "Dec");
######################################################################################
# If the correct number of input argument is provided, sets the input and output filenames.
if ($#ARGV == 1) {
$data_file = "$ARGV[0].text"; # data_file: input file
$output_file = "$ARGV[0].phi"; # output_file: file containing PHI locations
$debug_file = "$ARGV[0].info"; # debug_file: file used for debugging, contains PHI and non-PHI locations
$deid_text_file = "$ARGV[0].res"; # deid_text_file: de-identified text file
$gs_file = "$ARGV[0].deid"; # gs_file: Gold Standard of the input file
print "\n*******************************************************************************************************************\n";
print "De-Identification Algorithm: Identifies Protected Health Information (PHI) in Discharge Summaries and Nursing Notes";
print "\n*******************************************************************************************************************\n";
$config_file = $ARGV[1];
open CF, $config_file or die "Cannot open $config_file";
while ($cfline = <CF>) {
chomp $cfline;
if ($cfline =~ /\A[\#]+/){
next;
}
if ($cfline =~ /\bGold\s+standard\s+comparison\s*\=\s*([0-9])/ig) {
$comparison = ($1);
}
#Date default expects MM/DD/YYYY
if ($cfline =~ /\bDate\s+default\s*\=\s*(\d\d)\/(\d\d)\/(\d\d\d\d)/ig) {
my $mm = $1; $dd = $2; $yyyy = $3;
$DEFAULT_DATE = "$mm/$dd/$yyyy";
#print "Default date is $DEFAULT_DATE\n";
}
#The "Two Digit Year Threshold" is used to determine whether
#to interpret the year as a year in the 1900's or 2000's
if ($cfline =~ /\bTwo\s+Digit\s+Year\s+Threshold\s*=\s*(\d{1,2})/ig) {
$TWO_DIGIT_YEAR_THRESHOLD = "$1";
#print "Two Digit Year Threshold is $TWO_DIGIT_YEAR_THRESHOLD\n";
}
if ($cfline =~ /\bDate\s+offset\s*\=\s*([0-9]+)/ig) {
$offset = ($1);
#print "Date offset is $1\n";
}
if ($cfline =~ /\bSSN\s+filter\s*\=\s*([a-z])/ig) {
$ssnfilter = ($1);
}
if ($cfline =~ /\bURL\s+filter\s*\=\s*([a-z])/ig) {
$urlfilter = ($1);
}
if ($cfline =~ /\bEmail\s+filter\s*\=\s*([a-z])/ig) {
$emailfilter = ($1);
}
if ($cfline =~ /\bTelephone\s+filter\s*\=\s*([a-z])/ig) {
$telfilter = ($1);
}
if ($cfline =~ /\bUnit\s+number\s+filter\s*\=\s*([a-z])/ig) {
$unitfilter = ($1);
}
if ($cfline =~ /\bAge\s+filter\s*\=\s*([a-z])/ig) {
$agefilter = ($1);
}
if ($cfline =~ /\bLocation\s+filter\s*\=\s*([a-z])/ig) {
$locfilter = ($1);
}
if ($cfline =~ /\bDate\s+filter\s*\=\s*([a-z])/ig) {
$datefilter = ($1);
}
if ($cfline =~ /\bName\s+filter\s*\=\s*([a-z])/ig) {
$namefilter = ($1);
}
if ($cfline =~ /\bState\s+filter\s*\=\s*([a-z])/ig) {
$us_state_filter = ($1);
}
if ($cfline =~ /\bDS\s+filter\s*\=\s*([a-z])/ig) {
$ds_specific_filter = ($1);
}
if ($cfline =~ /\bGS\s+filter\s*\=\s*([a-z])/ig) {
$gs_specific_filter = ($1);
}
######################################################
#get the config info for dictionaries loading
if ($cfline =~ /\bPID\s+to\s+patient\s+name\s+mapping\s*\=\s*([a-z])/ig) {
$pid_patientname_list = ($1);
}
if ($cfline =~ /\bPID\s+to\s+date\s+offset\s+mapping\s*\=\s*([a-z])/ig) {
$pid_dateshift_list = ($1);
}
if ($cfline =~ /\bCountry\s+names\s*\=\s*([a-z])/ig) {
$country_list = ($1);
}
if ($cfline =~ /\bCompany\s+names\s*\=\s*([a-z])/ig) {
$company_list = ($1);
}
if ($cfline =~ /\bEthnicities\s*\=\s*([a-z])/ig) {
$ethnicity_list = ($1);
}
if ($cfline =~ /\bHospital\s+names\s*\=\s*([a-z])/ig) {
$hospital_list = ($1);
}
if ($cfline =~ /\bLocation\s+names\s*\=\s*([a-z])/ig) {
$location_list = ($1);
}
if ($cfline =~ /\bDoctor\s+names\s*\=\s*([a-z])/ig) {
$doctor_list = ($1);
}
if ($cfline =~ /\bLocalPlaces\s+names\s*\=\s*([a-z])/ig) {
$local_list = ($1);
}
if ($cfline =~ /\bState\s+names\s*\=\s*([a-z])/ig) {
$state_list = ($1);
}
}
}
# Prints an error message on the screen if number of arguments is incorrect
else {
print "\n===========================================================================================";
print "\nError: Wrong number of arguments entered";
print "\nThe algorithm takes 2 arguments:";
print "\n 1. filename (the filename of medical notes, without extension, where extension must be .text)";
print "\n 2. config_filename (the configuration filename)";
print "\nExample (for Gold Standard Comparison): perl deid.pl id deid.config";
print "\nExample (for output mode using Gold Standard): perl deid.pl id deid-output.config";
print "\nFor further documentation, please consult the README.txt file";
print "\n===========================================================================================\n";
exit;
}
# After setting file names and configuring the run, indicates that de-identification has commenced
print "\n\nStarting de-identification (version 1.1) ...\n\n";
#check if we can open the .phi file
open F, ">$output_file" or die "Cannot open $output_file";
close F;
# Calls setup to create some lookup lists in memory
setup();
if ($comparison==1) {
print "Running deid in performance comparison mode.\n";
print "Using PHI locations in $gs_file as comparison. Output files will be:\n";
print "$output_file: the PHI locations found by the code.\n";
print "$debug_file: debug info about the PHI locations.\n";
#check if the gold std file exists
open GS, $gs_file or die "Cannot open $gs_file. Make sure that the gold standard file exists!\n"; # GS = Gold Standard file
close GS;
}
else {
#check if we can open the .res file
open F, ">$deid_text_file" or die "Cannot open $deid_text_file";
close F;
print "Running deid in output mode. Output files will be: \n";
print "$output_file: the PHI locations found by the code.\n";
print "$deid_text_file: the scrubbed text.\n";
print "$debug_file: debug info about the PHI locations.\n";
}
deid();
# Calls function stat() to calculate code performance statistics, if comparison mode = 1
if ($comparison==1) {
require "stat.pm";
&stat($gs_file, $output_file);
}
# End of top level of code
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
sub numerically {
#print "a is $a b is $b\n";
$a <=> $b;
}
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Reads in a file and pushes each line onto an array. Returns the array.
sub preload {
my ($file) = @_;
my @res = ();
open FILE, $file or die "Cannot open file $file";
while ($line = <FILE>) {
chomp $line;
push(@res, uc($line));
}
close FILE;
return @res;
}
# End of preload()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Reads in a file and pushes each line onto an array. Returns the array.
sub preload_uc {
my ($file) = @_;
my @res = ();
open FILE, $file or die "Cannot open file $file";
while ($line = <FILE>) {
chomp $line;
push(@res, uc($line));
}
close FILE;
return @res;
}
# End of preload_uc()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Reads in a file and creates a dictionary that records each line in that file under the given association, by mapping the line to a '1' in the dictionary of the association
sub preload_assoc {
my ($file,$assoc) = @_;
open FILE, $file or die "Cannot open file $file";
while ($line = <FILE>) {
chomp $line;
$$assoc{uc($line)}=1;
}
close FILE;
}
# End of preload_assoc()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Reads in a file and calls setup_hash on each line
sub setup_hash {
my ($file, $tname) = @_;
my @entry;
$typename[$ntype]= $tname;
open FILE, $file or die "Cannot open file $file";
while ($line = <FILE>) {
chomp $line;
&setup_item($ntype,$line);
}
$ntype++;
close FILE;
}
# End of setup_hash()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Reads in a file and calls setup_hash on each line
sub setup_lst_hash {
my ($tname, @hlst) = @_;
$typename[$ntype]= $tname;
foreach $line (@hlst) {
&setup_item($ntype,$line);
}
$ntype++;
}
# End of setup_lst_hash()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
sub setup_item {
my ($type,$line) = @_;
my ($head, @lst) = split (/([^a-zA-Z0-9_\']+)/,uc($line));
my $ix = $type;
if(@lst){
push @extend, [@lst];
$ix = "$type,$#extend";
}
my $entry = $lhash{$head};
if ($entry){
$lhash{$head} .= "|" . $ix;
}
else{$lhash{$head}=$ix;
}
}
# End of setup_item()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
sub typename {
my ($num) = @_;
return($typename[$num]);
}
# End of typename()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Takes in an array of words and compares them with hashes of known PHI. Recognizes and adds PHI using addType().
sub lookhash {
my @txtlst = @_;
my $pos = 0;
my $npos = 0;
my $tl,$ty;
my $txt = 1; # item is text not separator
my $item;
while (@txtlst) {
$item = shift(@txtlst);
$npos = $pos + length($item);
if ($item =~ /([a-zA-Z\']+)/ig) {
if($item){
$item = uc($item);
$tl = $lhash{$item};
#if the term ends with 's, remove it and see if
#there is a match in PHI hash
#if (!($tl) && $item =~/([a-zA-Z\'\-]+)\'s$/ig) {
if (!($tl) && $item =~/([a-zA-Z\']+)\'s$/ig) {
$tl = $lhash {$1};
}
if($tl){
# Compares with known PHI by calling bestmatch()
($xpos, $done, @types)=&bestmatch($tl,@txtlst);
splice(@txtlst,0,$#txtlst-$done);
$npos += $xpos;
foreach $typ (@types){
#print "item $item, adding type $type for position $pos-$npos\n";
#print "type is $typ , key is $pos - $npos \n";
addType("$pos-$npos",$typ);
#print "positions are $pos-$npos, typ is $typ\n";
}
}
} #end if $item
$txt = 0;
} #end if $txt
else {
$txt = 1;
}
$pos = $npos;
}
}
# End of lookhash()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
sub bestmatch {
my ($tl,@txtlst) = @_;
my $pos = 0;
my $bestpos = 0;
my $bestrest = $#txtlst;
my @besttyp = ();
my ($type, $rest, $xpos, @nlst);
foreach $ck (split '\|',$tl) {
($type, $rest) = split ',',$ck;
if($rest) {
($xpos , @nlst) = &matchrest($rest,@txtlst);
if ($xpos) {
if($xpos > $bestpos) {
$bestrest = $#nlst; $bestpos = $xpos;
@besttyp = ($typename[$type]);
}
elsif($xpos == $bestpos) {
push @besttyp,$typename[$type];
}
}
}
elsif ($bestpos == 0) {
push @besttyp,$typename[$type];
}
}
return ($bestpos, $bestrest, @besttyp);
}
# End of bestmatch()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
sub matchrest {
my ($rest, @txtlst) = @_;
my @mlst = @{$extend[$rest]};
my $item;
my $pos = 0;
my $pm = 0;
my $tmppos = 0;
if ($mlst[0] eq '|') {
$pm = 1; shift(@mlst);
}
foreach $i (@mlst) {
if ($i !~ /([a-zA-Z\'\-]+)$/ig){
next;
}
$item = shift(@txtlst);
$pos += length($item);
while ( $#txtlst >= 0 && ($item !~ /([a-zA-Z\'\-]+)/ig)){
$item = shift(@txtlst);
$pos += length ($item);
#print "item is $item, len is $#txtlst";
}
if ($pm ? (uc($item) !~ /$i/) : ($i ne uc($item))) {
#print "pm is $pm, returning zero\n";
return 0;
}
}
return ($pos, @txtlst);
}
# End of matchrest()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: setup()
# Arguments: None
# Returns: None
# Called by: Topmost level of code
# Description: Creates some lookup lists to have in memory
sub setup {
# This part is not necessary
open LP, $last_name_prefix_file or die "Cannot open $last_name_prefix_file";
while ($line = <LP>) {
chomp $line;
$prefixes{uc($line)} = 1;
}
close LP;
#Added to reduce false positives
&setup_hash($medical_phrases_file,"MedicalPhrase");
# Sets up hashes of some PHI lists for direct identification
if ($namefilter =~ /y/) {
&setup_hash($female_unambig_file,"Female First Name (un)");
&setup_hash($female_ambig_file,"Female First Name (ambig)");
&setup_hash($male_unambig_file,"Male First Name (un)");
&setup_hash($male_ambig_file,"Male First Name (ambig)");
&setup_hash($last_unambig_file,"Last Name (un)");
&setup_hash($last_popular_file,"Last Name (popular/ambig)");
&setup_hash($last_ambig_file,"Last Name (ambig)");
&setup_hash($female_popular_file, "Female First Name (popular/ambig)");
&setup_hash($male_popular_file, "Male First Name (popular/ambig)");
if ($doctor_list =~ /y/) {
&setup_hash($doctor_first_unambig_file, "Doctor First Name");
&setup_hash($doctor_last_unambig_file, "Doctor Last Name");
}
}
if ($locfilter =~ /y/) {
if ($location_list =~ /y/) {
&setup_hash($locations_ambig_file,"Location (ambig)");
&setup_hash($locations_unambig_file,"Location (un)");
} else {
@loc_unambig = ();
@more_loc_unambig = ();
@loc_ambig = ();
}
if ($hospital_list =~ /y/) {
&setup_hash($hospital_file,"Hospital");
}
if ($ethnicity_list =~ /y/) {
&setup_hash($ethnicities_unambig_file, "Ethnicity");
}
if ($company_list =~ /y/) {
&setup_hash($companies_file, "Company");
&setup_hash($companies_ambig_file, "Company (ambig)");
}
if ($country_list =~ /y/) {
&setup_hash($countries_file, "Country");
}
if ($local_list =~ /y/){
&setup_hash($local_places_unambig_file, "Location (un)");
&setup_hash($local_places_ambig_file, "Location (ambig)");
}
}
# Preloads PHI in some lists into corresponding arrays
@female_popular = &preload($female_popular_file);
@male_popular = &preload($male_popular_file);
#@last_name_prefixes = &preload_uc($last_name_prefixes_file);
@prefixes_unambig = &preload_uc($prefixes_unambig_file);
if ($hospital_list =~ /y/) {
@hospital = &preload($hospital_file);
} else {@hospital = ();}
if ($state_list =~ /y/){
@us_states = &preload($us_states_file);
@us_states_abbre = &preload($us_states_abbre_file);
@more_us_states_abbre = &preload($more_us_states_abbre_file);
}
# Generates associations between PHI in some lists and PHI categories
&preload_assoc($common_words_file,"common_words");
&preload_assoc($medical_words_file,"common_words");
&preload_assoc($very_common_words_file,"very_common_words");
&preload_assoc($unambig_common_words_file, "unambig_common_words");
&preload_assoc($male_unambig_file, "male_unambig");
&preload_assoc($female_unambig_file, "female_unambig");
&preload_assoc($female_ambig_file, "female_ambig");
&preload_assoc($male_ambig_file, "male_ambig");
&preload_assoc($last_ambig_file, "last_ambig");
&preload_assoc($male_popular_file, "male_popular");
&preload_assoc($female_popular_file, "female_popular");
&preload_assoc($us_area_code_file,"us_area_code");
# Opens debug file for debugging
open D, ">".$debug_file;
close D;
}
# End of setup()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: deid()
# Arguments: None
# Returns: None
# Called by: Topmost level of code
# Description: One of the 2 major branches of the code
# This function takes over de-identification if no performance statistic is required
# Function first loads the patient name list file.
# Then reads the medical text line by line.
# If the line indicates START_OF_RECORD, read the Patient ID (PID), Note ID (NID), (and Note Date if any) info
# Scan for PHI a paragraph at a time
# output PHI locations into .phi file
my $currentID;
my @known_phi;
my @known_first_name;
my @known_last_name;
my %pidPtNames; # key = pid, value = [0] first name [1] last name
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
sub deid {
$allText = "";
$allallText = "";
open DF, $data_file or die "Cannot open $data_file";
my $paraCount = 0;
my $stpos = 0;
my %deids; #key = start index, value = array of (end index, ID)
my %phiTerms; #key = lc(word), value = # of occurrences
my %phiT;
my %phiTT;
my $noteDate;
my $line;
$currentID = 0; #initialize current ID to a non-existent PID 0
# Code runs through text by paragraph so things that extend over lines aren't missed
$para = "";
#load the patient name file
if ($pid_patientname_list =~ /y/) {
open PF, $patient_file or die "Cannot open $patient_file";
while ($pfline = <PF>) {
chomp $pfline;
if ($pfline =~ /((.)+)\|\|\|\|((.)+)\|\|\|\|((.)+)/ig) {
my $pid = $1;
$known_first_names = $3;
$known_last_names = $5;
$pidPtNames{$pid}[0] = $known_first_names;
$pidPtNames{$pid}[1] = $known_last_names;
}# end if pfline = ~ /((.)+)\|\|\|\|((.)+)\|\|\|\|((.)+)/ig)
} # end while $pfline = <PF>
} #end if pid_patient_name_list ~= y
###End loading the patient names
while ($line = <DF>) {
#If this is a new record, set PID, Note ID
#we assume all notes for the same patient go together
if ( $line =~ /\ASTART_OF_RECORD=(([0-9]+)(\|)+([0-9]+)(\|)+(\d\d\/\d\d\/\d{4})?)/) {
# $currentNote = $2;
# $thePT = $4;
# $noteDate =$6; #noteDate is empty in gold std
#print "pt $thePT, currentNote $currentNote\n";
#if it's gold standard, the header contains PID then NID
$currentNote = $4;
$thePT = $2;
$noteDate =$6; #noteDate is empty in gold std
my $label = "Patient $thePT\tNote $currentNote";
open DEST, ">>".$debug_file or die "Cannot open $debug_file";
print DEST "$label\n";
close DEST;
#Gold Standard corpus does not specify note date, so assign a default
#If you would like deid to date shift the notes on a per note basis, make sure you
#specify the record date in the header!
if (length($noteDate) ==0){
#$noteDate="01/01/2020";
$noteDate = $DEFAULT_DATE;
}
#if this is a new patient, set the PID, and lookup patient name
if ($thePT != $currentID) { #This is a new patient!
$currentID = $thePT;
%phiTerms = (); #clear the phiTerms on new pt
# Find the patient name for the current PID
#lookup first and last name of this patient
if ($pid_patientname_list =~ /y/ && exists $pidPtNames{$currentID} ) {
$known_first_names = $pidPtNames{$currentID}[0];
$known_last_names = $pidPtNames{$currentID}[1];
#print "Found patient names, first = $known_first_names last = $known_last_names\n";
if ($known_first_names =~ /([a-z][a-z]+)[\s\-]([a-z][a-z]+)/ig) {
@known_first_name = ($1, $2);}
else {
if ($known_first_names =~ /\b([a-z])(\.?)\s([a-z]+)/ig) {
@known_first_name = ($3);
}
elsif ($known_first_names =~ /\b([a-z][a-z]+)\s([a-z])(\.?)/ig) {
@known_first_name = ($1);
}
else {
@known_first_name = ($known_first_names);
}
}
if ($known_last_names =~ /([a-z][a-z]+)[\s\-]([a-z][a-z]+)/ig) {
@known_last_name = ($1, $2);}
else {
if ($known_last_names =~ /\b([a-z])(\.?)\s([a-z]+)/ig) {
@known_last_name = ($3);
}
elsif ($known_last_names =~ /\b([a-z][a-z]+)\s([a-z])(\.?)/ig) {
@known_last_name = ($1);
}
else {
@known_last_name = ($known_last_names);
}
}
} else { #if no pid/patient name file, just set the first name and last name to null
@known_first_name = ();
@known_last_name = ();
}
} # end if this is a new patient
#output the header to output file
$allText = ""; #reset,
$allallText = ""; #reset
$stpos = 0;
$para = "";
#if output mode, output the header line (with patient and note ID) to .res file
if ($comparison == 0) {
open TF, ">>$deid_text_file" or die "Cannot open $deid_text_file"; #now open in append mode
print TF "\n$line";
close TF;
}
next; #skip to next line
} #end if this is start of a record
else { #else this is not the start of a record, just append the line to the end of the current text
chomp $line;
$allText .= $line."\n";
$allallText .= $line."\n";
#$myline = $line;
#chomp $myline;
#$allText .= $myline."\n";
#$allallText .= $myline."\n";
}
#Look for paragraph separator: if this is a line is entirely non-alphanumeric or
#if it starts with spaces, or if it is an empty line, or if this line marks the end of record,
#then call findPHI() for the current paragraph we have so far.
#If end of record is encoutnered, output the de-id text; else if
#it's not end of record yet, append the line to the paragraph.
# if ( (!($line =~ /[a-zA-Z\d]+/)) || $line =~ /^ +/ || $line eq "" || ($line =~ /\|\|\|\|END_OF_RECORD/) ) {
if ( (!($line =~ /[a-zA-Z\d]+/)) || ($line eq "") || ($line =~ /\|\|\|\|END_OF_RECORD/) ) {
if ($para =~ /\w/ ){ #if para contains alphanumeric
# Calls findPHI() with current paragraph; resulting PHI locations are stored in %phiT
#%phiT = findPHI("Para $paraCount", $date, $stpos, $para);
%phiT = findPHI("Para $paraCount", $noteDate, $stpos, $para);
$paraCount++;
# %phiT is copied over to %phiTT
foreach $x (sort numerically keys %phiT) {
@{$phiTT{$x}} = @{$phiT{$x}};
}
#Sorts keys in %phiT; outputs text accordingly
foreach $k (keys %phiT) {
my ($start, $end) = split '-', $k;
# $deids_end = ${@{$deids{$start}}}[0]; #does not work with perl v5.10
my @deidsval = ${@{$deids{$start}}};
$deids_end = $deidsval[0];
$found = $phiT{$k};
foreach $t (@{$phiT{$k}}) {
}
my $word = lc(substr $allallText, $start, ($end - $start));
#print "Key in PhiT = $k, word = $word\n"; #DEBUG
# if ($end > ${@{$deids{$start}}}[0]) {
if ($end > $deidsval[0]) {
$deids{$start}[0] = $end;
$deids{$start}[1] = $currentID;
$deids{$start}[2] = $noteDate;
}
#############################################################################
#Now remember the PHI terms that are important names for checking for repeated occurrences of PHIs
#PHI Name Tags
#(NI) Name indicators
#(LF) Lastname Firstnames
#(PTitle) plural titles
#(MD) followed by "MD" or "M.D"
#(PRE) checks up to 3 words following "PCP Name" ("PCP", "physician", "provider", "created by", "name");
#(NameIs) followed by pattern "name is"
#(Prefixes) for @prefixes_unambig)
#(STitle) @specific_titles = ("MR", "MISTER", "MS");
#(Titles) @titles
#(NamePattern) all other name patterns in sub name3
#remember all the PHI of type name (strict_titles) and name (indicators)
#print "checking for repeated occurences of PHIs: word is $word, phitype is (@{$phiT{$k}})\n";
if ( ($word !~ /\d/) && ((length $word) > 3) && !(isCommon($word)) &&
( isPHIType( "(NI)", @{$phiT{$k}}) ||
isPHIType( "(PTitle)", (@{$phiT{$k}})) || isPHIType( "(LF)", (@{$phiT{$k}})) ||
isPHIType( "(NamePattern)", (@{$phiT{$k}})) ||
isPHIType( "(MD)", (@{$phiT{$k}})) ||
isPHIType( "(NameIs)", (@{$phiT{$k}})) || isPHIType("(STitle)", (@{$phiT{$k}})) ||
isPHIType("(Titles)", (@{$phiT{$k}}) ))
) {
#$phiTerms{$word}++;
if (!(exists $phiTerms{$word})) {
$phiTerms{$word} = 1;}
else {
$phiTerms{$word} = $phiTerms{$word}+ 1;
}
} #end if
} # end foreach $k (keys %phiT)
} #end if ($para =~ /\W/)
if ($line =~ /\|\|\|\|END_OF_RECORD/ ) {
open DEST, ">>".$debug_file or die "Cannot open $debug_file";
####################################################
#check for repeated occurences of PHIs for this note
while ($allallText =~ /\b([A-Za-z]+)\b/g) {
my $token = $1;
my $start = (length ($`)); #$` is the string preceding what was matched by the last successful match
my $end = $start + length($token);
if (!(exists $deids{$start}) ) {
#if (!(exists ${@{$deids{$start}}}[0])) {
L:
foreach $word (keys %phiTerms) {
if ( (uc($token) eq uc($word)) ) {
$deids{$start}[0] = $end;
$deids{$start}[1] = $currentID;
$deids{$start}[2] = $noteDate;
$term = substr $text, $start, ($end - $start +1);
$outstr = "$start \t $end \t $term \t Name (Repeated Occurrence) \n";
print DEST $outstr;
next L;
} #end if
} # end foreach
} # end if
} # end while
#end checking for repeated occurences of PHIs
close DEST;
#####################################################
##output PHI locations to the .phi file
open OUTF, ">>$output_file" or die "Cannot open $output_file";
print OUTF "\nPatient $currentID\tNote $currentNote";
foreach $k (sort numerically keys %deids) {
my @deidvals = @{$deids{$k}};
$thisend = $deidvals[0];
if ($thisend ){
print OUTF "\n$k\t$k\t$thisend";
}
}
close OUTF;
###output de-ided text to .res file
if ($comparison==0) {
outputText(\%deids, \%phiTT);
}
#now that we have output text for this record, we reset the
#variables to get ready for the next record
$para = "";
$paraCount = 0;
$stpos = 0;
%deids=(); #clear the deid hash
%phiTT=(); #clear the phiTT hash
%phiT=();
$allText = ""; #reset,
$allallText = ""; #reset
} else { # this is not end of record yet ...
my $tmp = length($para);
$stpos += length ($para);
$para = $line.' ';
}
} #end if line starts with empty spaces || empty line || end of record
else { # else this line is still a part of the current paragraph
#$para .= ' '.$line; #just append to end of current paragraph
#$para .= $line.' '; #just append to end of current paragraph
if ($line eq "") {
$para .= "\n";
} else {
$para .= $line.' '; #just append to end of current paragraph
}
}
} #end while ($line=<DF>)
close DF;
}
# End of deid()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: findPHI()
# Arguments: string $label ("Para $paraCount"), string $date (e.g. "yyyy-mm-dd"), int $startIndex (normally 0), string $text (paragraph of text)
# Returns: hash %approved (key=start-end of each PHI, value=PHI types)
# Called by: deid()
# Description: Dispatched from deid() to perform de-identification
# Reads in a paragraph of text and runs the de-identification algorithm on it
sub findPHI {
my ($label, $curr_date, $startIndex, $text) = @_;
# Initializes the hash %phi which stores PHI locations and their PHI types
%phi = (); #key = start-end, value = (type1, type2, ...)
local %end = (); # key = start, value = end (dynamic scope so addType can do it)
if ($text !~ /\w/) {
return %phi;
} #[wjl] skip blank lines
# Splits the text into separate items at spaces
#my @txtlst = split (/([^a-zA-Z0-9_\'\-]+)/,$text); # used by lookhash and appx match
my @txtlst = split (/([^a-zA-Z0-9_\']+)/,$text);
# Performs exact matching with the hashes of PHI lists
&lookhash(@txtlst);
# Initializes hash %phik which stores only start and end indices of each PHI in %phi
%phik = ();
foreach $k (keys %phi) {
($st,$end) = split ('-',$k);
$phik{$st} = $end;
}
# Calls each filter module
if ($datefilter =~ /y/) {
&commonHoliday($text, 0);
&date ($text, $curr_date);
&dateWithContextCheck($text, $curr_date);
&yearWithContextCheck($text, $curr_date);
&seasonYear ($text, 0);
}
if ($telfilter =~ /y/) {
&telephone($text, 0);
&pager ($text, 0);
}
if ($locfilter =~ /y/) {
&wardname($text, 0);
&location1 ($text, 0);
&location2 ($text, 0);
}
if ($emailfilter =~ /y/) {
&email ($text, 0);
}
if ($urlfilter =~ /y/) {
&url ($text, 0);
}
if ($ssnfilter =~ /y/) {
&ssn ($text, 0);
}
if ($agefilter =~ /y/) {
&age ($text, 0);
}
if ($namefilter =~ /y/) {
&name1 ($text, 0);
&name2 ($text, 0);
&name3 ($text, 0);
&knownPatientName($text, 0);
&problem ($text, 0);
&signatureField ($text, 0);
}
if ($unitfilter =~ /y/) {
&mrn ($text, 0);
&unit ($text, 0);
&providerNumber ($text, 0);
}
if ($ds_specific_filter =~ /y/){
#discharge summary specific filters
#filter not enabled for this version
#&dischargeSummarySpecific ($text, 0);
}
# Call new function here >>>>>>>>>>
# Follow format shown here if necessary
# &functionName ($text, 0);
open DEST, ">>".$debug_file or die "Cannot open $debug_file";
#print DEST "$label\n";
# Sub-function: finalPHICheck()
# After findPHI() has performed most PHI checks, goes through the identified PHI before adding them to the final PHI files
my %approved;
my ($startp, $endp) = (0, 0);
my $notAmbig = 0;
my $stg1 = "";
my $stg2 = "";
my $prevAmbig = 0;
my $oldk = "";
my $prevKey = "";
my ($oldstartp, $oldendp,) = (0, 0);
my $oldtext = "";
# Prunes keys and checks whether each PHI is ambiguous or is an indicator (e.g. hospital indicator)
foreach $k (&pruneKeys("phi",$text)) {
($startp, $endp) = split "-", $k;
my $the_word = (substr $text, $startp, ($endp - $startp));
$notAmbig = 0; #so by default, the term is ambiguous
foreach $tt (@{$phi{$k}}){
#if(($tt !~ /ambig/) && ($tt !~ /Indicator/) ) {
if (($tt !~ /ambig/) && ($tt !~ /Indicator/) && ($tt !~ /MedicalPhrase/)) {
#so IF the term matches ANY type that's non-ambiguous, THEN set it as non-ambiguous
$notAmbig = 1; last;}
} #end for each
my $notIndicator = 1; #default to be not an indicator
foreach $tt (@{$phi{$k}}){
if ($tt =~ /Indicator/) {
$notIndicator = 0; last;
}
}
$prevText = (substr $text, $oldstartp, ($oldendp - $oldstartp));
$newText = (substr $text, $startp, ($endp - $startp));
$a = (isType($prevKey, "Male First Name", 1) && ($prevAmbig==1) && (!isCommon($prevText)));
$b = (isType($k, "Last Name", 1) && ($notAmbig==0) && (!isCommon($newText)));
#if (this is ambig) and (previous is ambig) and ...
if ((($notAmbig==0) && ($prevAmbig==1) && (isType($prevKey, "Male First Name", 1) || (isType($prevKey, "Female First Name", 1))) && (!isCommon($prevText)) && (!isCommon($newText)) && ($prevText !~ /\./) && isType($k, "Last Name", 1) && (($startp-$oldendp)<3)) ||
#if (this is not-ambig) and (previous is ambig) and ...
(($notAmbig==1) && ($prevAmbig==1) && (isType($prevKey, "Male First Name", 1) || (isType($prevKey, "Female First Name", 1))) && (!isCommon($prevText)) && (!isCommon($newText)) && ($prevText !~ /\./) && isType($k, "Last Name", 1) && (($startp-$oldendp)<3)) ||
#if (this is not-ambig) and (previous is ambig) and ...
(($notAmbig==1) && ($prevAmbig==1) && isType($prevKey, "Last Name", 1) && (!isCommon($prevText)) && (!isCommon($newText)) && ($prevText !~ /\./) && isType($k, "First Name", 1) && (($startp-$oldendp)<3)) ||
#commented out on 1/31/07
(($notAmbig==0) && ($prevAmbig==0) && (isType($prevKey, "Male First Name", 1) || (isType($prevKey, "Female First Name", 1))) && (!isCommon($prevText)) && (!isCommon($newText)) && ($prevText !~ /\./) && isType($k, "Last Name", 1) && (($startp-$oldendp)<3)) ||
#if (this is ambig) and (previous is not ambig) and ...
(($notAmbig==0) && ($prevAmbig==0) && isType($prevKey, "Last Name", 1) && (!isCommon($prevText)) && (!isCommon($newText)) && ($prevText !~ /\./) && isType($k, "First Name", 1) && (($startp-$oldendp)<3))) {
print DEST ($startIndex + $oldstartp)."\t".($startIndex+$oldendp)."\t".(substr $text, $oldstartp, ($oldendp - $oldstartp +1));
###################
my $oldtext = $text;
my $newKey = ($startIndex + $oldstartp)."-".($startIndex + $oldendp);
###my $text = (substr $text, $oldstartp, ($oldendp - $oldstartp));
foreach $tt (@{$phi{$prevKey}}) {
print DEST "\t$tt";
push @{$approved{$newKey}}, $tt;}
print DEST "\n";
print DEST ($startIndex + $startp)."\t".($startIndex+$endp)."\t".(substr $oldtext, $startp, ($endp - $startp +1));
my $newKey = ($startIndex + $startp)."-".($startIndex + $endp);
###my $text = (substr $oldtext, $startp, ($endp - $startp));
foreach $tt (@{$phi{$k}}) {
print DEST "\t$tt";
push @{$approved{$newKey}}, $tt;
}
print DEST "\n";
}
# If the PHI is not ambiguous and not an indicator, recognizes it as PHI; add it to PHI file
elsif ($notAmbig && $notIndicator) {
###################
print DEST ($startIndex + $startp)."\t".($startIndex+$endp)."\t".(substr $text, $startp, ($endp - $startp +1));
my $newKey = ($startIndex + $startp)."-".($startIndex + $endp);
###my $text = (substr $text, $startp, ($endp - $startp));
foreach $tt (@{$phi{$k}}){
print DEST "\t$tt";
if (($tt !~ /ambig/) && ($tt !~ /Indicator/)) {
push @{$approved{$newKey}}, $tt;
}
}
print DEST "\n";
} # Else ck keys discarded
else {
###################
# Otherwise keeps the remaining PHI as non-PHI
print DEST ($startIndex + $startp)."\t".($startIndex+$endp)."\t# ".(substr $text, $startp, ($endp - $startp +1));
foreach $tt (@{$phi{$k}}) {
print DEST "\t$tt";
}
print DEST "\n";}
# Sets ambiguous variables for current PHI to be recognized as previous PHI for the next round
if ($notAmbig==0) {
$prevAmbig = 1;
$prevKey = $k;
($oldstartp, $oldendp) = split "-", $prevKey;
$oldtext = $text;
}
else {
$prevAmbig = 0;
}
}
close DEST;
# End of sub-function finalPHICheck()
#***********************************************************************************************************
return %approved;
}
# End of findPHI()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: date ()
# Searches for date ranges following formats that appear most frequently in text
sub date {
#$text = $_[0];
my ($text, $date) = @_;
my $year = substr $date, 0, 4;
# Checks if dates should be filtered
if ($datefilter =~ /y/) {
# Searches for the pattern mm/dd-mm/dd where the items are valid dates
while ($text =~ /\b((\d\d?)\/(\d\d?)\-(\d\d?)\/(\d\d?))\b/ig) {
if (isValidDate($2,$3,-1) && isValidDate($4,$5,-1)) {
$date_range = $1;
$start = length($`);
$end = $start + length($date_range);
$key = "$start-$end";
addType($key, "Date range (1)");
}
}
# Searches for mm/dd/yy-mm/dd/yy or mm/dd/yyyy-mm/dd/yyyy where the items are valid dates
while ($text =~ /\b((\d\d?)\/(\d\d?)\/(\d\d|\d\d\d\d)\-(\d\d?)\/(\d\d?)\/(\d\d|\d\d\d\d))\b/ig) {
if (isValidDate($2,$3,$4) && isValidDate($5,$6,$7)) {
$date_range = $1;
$start = length($`);
$end = $start + length($date_range);
$key = "$start-$end";
addType($key, "Date range (2)");
}
}
# Searches for mm/dd-mm/dd/yy or mm/dd-mm/dd/yyyy where the items are valid dates
while ($text =~ /\b((\d\d?)\/(\d\d?)\-(\d\d?)\/(\d\d?)\/(\d\d|\d\d\d\d))\b/ig) {
if (isValidDate($6,$2,$3) && isValidDate($6,$4,$5)) {
$date_range = $1;
$start = length($`);
$end = $start + length($date_range);
$key = "$start-$end";
addType($key, "Date range (3)");
}
}
} #end if date filter is on
# End of sub-function date1()
if ($datefilter =~ /y/) {
# Checks for month/day/year
while ($text =~ /\b(\d\d?)[\-\/](\d\d?)[\-\/](\d\d|\d{4})\b/g) {
my $startI = (length($`));
my $endI = $startI + length($&);
my $key = $startI."-".$endI;
my $first_num = $1;
my $second_num = $2;
my $third_num = $3;
my $beginr = substr $text, ($startI - 2), 2;
my $endr = substr $text, $endI, 2;
if (($beginr !~ /(\|\|)/) && ($endr !~ /(\|\|)/)) {
if (($beginr !~ /\d[\/\.\-]/) && ($endr !~ /\A[\%\/]/) && ($endr !~ /\S\d/)) {
#print "checking M/D/Y, $first_num, $second_num, $third_num\n";
if (isValidDate ($first_num, $second_num, $third_num)) {
addType ($key, "Month/Day/Year");
}
}
}
} #end while
# Checks for month/day/year
while ($text =~ /\b(\d\d?)\.(\d\d?)\.(\d\d|\d{4})\b/g) {
my $startI = (length($`));
my $endI = $startI + length($&);
my $key = $startI."-".$endI;
my $first_num = $1;
my $second_num = $2;
my $third_num = $3;
my $beginr = substr $text, ($startI - 2), 2;
my $endr = substr $text, $endI, 2;
#print "2. checking M/D/Y, $first_num, $second_num, $third_num\n";
if (($beginr !~ /(\|\|)/) && ($endr !~ /(\|\|)/)) {
if (($beginr !~ /\d[\/\.\-]/) && ($endr !~ /\A[\%\/]/) && ($endr !~ /\S\d/)) {
if (isValidDate ($first_num, $second_num, $third_num)) {
addType ($key, "Month/Day/Year");
}
}
}
}
# Checks for day/month/year
while ($text =~ /\b(\d\d?)[\-\/](\d\d?)[\-\/](\d\d|\d{4})\b/g){
my $startI = (length($`));
my $endI = $startI + length($&);
my $key = $startI."-".$endI;
my $first_num = $1;
my $second_num = $2;
my $third_num = $3;
my $beginr = substr $text, ($startI - 2), 2;
my $endr = substr $text, $endI, 2;
if (($beginr !~ /\d[\/\.\-]/) && ($endr !~ /\A[\%\/]/) && ($endr !~ /\S\d/)) {
if (isValidDate ($second_num, $first_num, $third_num)) {
}
}
}
# Checks for year/month/day
while ($text =~ /\b(\d\d|\d{4})[\-\/](\d\d?)[\-\/](\d\d?)\b/g){
my $startI = (length($`));
my $endI = $startI + length($&);
my $key = $startI."-".$endI;
my $yr = $1;
$nn_year = $yr;
my $mo = $2;
my $da = $3;
my $beginr = substr $text, ($startI - 2), 2;
my $endr = substr $text, $endI, 2;
if (($beginr !~ /\d[\/\.\-]/) && ($endr !~ /\A[\%\/]/) && ($endr !~ /\S\d/)) {
if (isValidDate ($mo, $da, $yr) && (($yr>50) || ($yr<6))) {
$prevChars = (substr $text, ($startI-4), 4);
$nextChars = (substr $text, $endI, 11);
if (($prevChars =~ /(\d)(\s)?(\|)(\s)?/) && ($nextChars =~ /\s\d{2}\:\d{2}\:\d{2}(\s)?(\|)/)) {
addType ($key, "Header Date");
$longyear = $yr;
}
else {
addType ($key, "Year/Month/Day");
}
}
}
} #end while
# Checks for year/month/day
while ($text =~ /\b(\d\d|\d{4})\.(\d\d?)\.(\d\d?)\b/g){
my $startI = (length($`));
my $endI = $startI + length($&);
my $key = $startI."-".$endI;
my $yr = $1;
$nn_year = $yr;
my $mo = $2;
my $da = $3;
my $beginr = substr $text, ($startI - 2), 2;
my $endr = substr $text, $endI, 2;
if (($beginr !~ /\d[\/\.\-]/) && ($endr !~ /\A[\%\/]/) && ($endr !~ /\S\d/)) {
#if (isValidDate ($mo, $da, $yr) && (($yr>50) || ($yr<6))) {
if (isValidDate ($mo, $da, $yr)) {
$prevChars = (substr $text, ($startI-4), 4);
$nextChars = (substr $text, $endI, 11);
if (($prevChars =~ /(\d)(\s)?(\|)(\s)?/) && ($nextChars =~ /\s\d{2}\:\d{2}\:\d{2}(\s)?(\|)/)) {
addType ($key, "Header Date");
$longyear = $yr;
}
else {
addType ($key, "Year/Month/Day");
}
}
}
}
# Checks for year/day/month
while ($text =~ /\b(\d\d|\d{4})[\-\/](\d\d?)[\-\/](\d\d?)\b/g){
my $startI = (length($`));
my $endI = $startI + length($&);
my $key = $startI."-".$endI;
my $yr = $1;
$nn_year = $yr;
my $mo = $3;
my $da = $2;
my $beginr = substr $text, ($startI - 2), 2;
my $endr = substr $text, $endI, 2;
if (($beginr !~ /\d[\/\.\-]/) && ($endr !~ /\A[\%\/]/) && ($endr !~ /\S\d/)) {
#if (isValidDate ($mo, $da, $yr) && (($yr>50) || ($yr<6))) {
if (isValidDate ($mo, $da, $yr)) {
$prevChars = (substr $text, ($startI-4), 4);
$nextChars = (substr $text, $endI, 11);
if (($prevChars =~ /(\d)(\s)?(\|)(\s)?/) && ($nextChars =~ /\s\d{2}\:\d{2}\:\d{2}(\s)?(\|)/)) {
addType ($key, "Header Date");
$longyear = $yr;
}
else {
}
}
}
} #end while
# Checks for month/4-digit year
while ($text =~ /\b((\d\d?)[\-\/](\d{4}))/g) {
my $startI = (length($`));
my $endI = $startI + length($&);
my $beginr = substr $text, ($startI - 2), 2;
my $endr = substr $text, $endI, 2;
my $first_num = $2;
my $second_num = $3;
my $st = length($`);
my $endb = $st + length ($2) + length($3) + 1;
my $key = "$st-$endb";
if (($beginr !~ /\|\|/) && ($endr !~ /\|\|/)) {
if (($beginr !~ /\d[\/\.\-]/) && ($endr !~ /[\/\.\%]/)) {
#if (($first_num <= 12) && ($first_num > 0) && ($second_num>=1900)) {
if (($first_num <= 12) && ($first_num > 0) &&
( $second_num >= $VALID_YEAR_LOW && $second_num <= $VALID_YEAR_HIGH ) ) {
addType ($key, "Month/Year 1"); }}}
} #end while
# Checks for 4-digit year/month
while ($text =~ /\b((\d{4})[\-\/](\d\d?))\b/g) {
my $first_num = $2;
my $second_num = $3;
my $st = length($`);
my $endb = $st + length ($2) + length($3) + 1;
my $key = "$st-$endb";
if (($begin !~ /\d[\/\.\-]/) && ($end !~ /[\/\.\%]/)) {
#if (($second_num <= 12) && ($second_num > 0) && ($first_num>=1900) && ($first_num<2010)) {
if (($second_num <= 12) && ($second_num > 0) && ($first_num>=$VALID_YEAR_LOW) && ($first_num <= $VALID_YEAR_HIGH)) {
addType ($key, "Year/Month"); }}
} #end while
# Checks for spelled-out months
# Accounts for ambiguity around the dates, e.g. acronyms for measurements, spelled out months and such
foreach $m (@months) {
while ($text =~ /\b((\d{1,2})[ \-]?$m[ \-\,]? ?\'?\d{2,4})\b/ig) { # 2-May-04
my $day = $2;
my $completeDate = $1;
my $st = length($`);
my $key = "$st-".($st + length($1));
if (($day < 32) && ($day > 0)) {
addType ($key, "Day Month Year");
}
}
while ($text =~ /\b((\d{1,2}) ?(\-|to|through)+ ?(\d{1,2})[ \-]?$m[ \-\,]? ?\'?\d{2,4})\b/ig) { # 2-May-04
my $day1 = $2;
my $day2 = $4;
my $completeDate = $1;
my $st = length($`);
my $key = "$st-".($st + length($1));
if (($day1 < 32) && ($day1 > 0) && ($day2 < 32) && ($day2 >0)) {
addType ($key, "Date range (4)");
}
}
while ($text =~ /\b((\d{1,2}) ?\-\> ?(\d{1,2})[ \-]?$m[ \-\,]? ?\'?\d{2,4})\b/ig) { # 2-May-04
my $day1 = $2;
my $day2 = $3;
my $completeDate = $1;
my $st = length($`);
my $key = "$st-".($st + length($1));
if (($day1 < 32) && ($day1 > 0) && ($day2 < 32) && ($day2 > 0)) {
addType ($key, "Date range (5)");
}
}
while ($text =~ /\b($m\b\.? (\d{1,2})[\,\s]+ *\'?\d{2,4})\b/ig) { # Apr. 2 05
my $day = $2;
my $completeDate = $1;
my $st = length($`);
my $key = "$st-".($st + length($1));
if (($day < 32) && ($day > 0)) {
addType ($key, "Month Day Year");
}
}
while ($text =~ /\b($m\b\.? (\d{1,2}) ?(\-|to|through)+ ?(\d{1,2})[\,\s]+ *\'?\d{2,4})\b/ig) { # Apr. 2 05
my $day1 = $2;
my $day2 = $4;
my $completeDate = $1;
my $st = length($`);
my $key = "$st-".($st + length($1));
if (($day1 < 32) && ($day1 > 0) && ($day2 < 32) & ($day2 > 0)) {
addType ($key, "Date range (6)");
}
}
while ($text =~ /\b($m\b\.? (\d{1,2}) ?\-\> ?(\d{1,2})[\,\s]+ *\'?\d{2,4})\b/ig) { # Apr. 2 05
my $day1 = $2;
my $day2 = $3;
my $completeDate = $1;
my $st = length($`);
my $key = "$st-".($st + length($1));
if (($day1 < 32) && ($day1 > 0) && ($day2 < 32) & ($day2 > 0)) {
addType ($key, "Date range (7)");
}
}
#while ($text =~ /\b($m\b\.?,? ?(\d{1,2})(|st|nd|rd|th|)? ?[\,\s]+ *\'?\d{2,4})\b/ig) { # Apr. 12 2000
while ($text =~ /\b($m\b\.?,? ?(\d{1,2})(|st|nd|rd|th|) ?[\,\s]+ *\'?\d{2,4})\b/ig) { # Apr. 12th 2000
my $day = $2;
my $completeDate = $1;
my $st = length($`);
my $key = "$st-".($st + length($1));
if (($day < 32) && ($day > 0)) {
addType ($key, "Month Day Year (2)");
#addType ($key, "Month Day Year");
}
}
# while ($text =~ /\b($m\b\.?,? ?(\d{1,2})(|st|nd|rd|th|)?)\b/ig) { # Apr. 12
while ($text =~ /\b($m\b\.?,?\s*(\d{1,2})(|st|nd|rd|th|)?)\b/ig) { # Apr. 12
my $day = $2;
my $completeDate = $1;
my $st = length($`);
my $key = "$st-".($st + length($1));
if (($day < 32) && ($day > 0)) {
addType ($key, "Month Day");
}
}
while ($text =~ /\b($m\b\.?,? ?(\d{1,2})(|st|nd|rd|th|)? ?(\-|to|through)+ ?(\d{1,2})(|st|nd|rd|th|)?)\b/ig) { # Apr. 12
my $day1 = $2;
my $day2 = $4;
my $completeDate = $1;
my $st = length($`);
my $key = "$st-".($st + length($1));
if (($day1 < 32) && ($day1 > 0) && ($day2 < 32) && ($day2 > 0)) {
addType ($key, "Date range (8)");
}
}
while ($text =~ /\b($m\b\.?,? ?(\d{1,2})(|st|nd|rd|th|)? ?\-\> ?(\d{1,2})(|st|nd|rd|th|)?)\b/ig) { # Apr. 12th
my $day1 = $2;
my $day2 = $4;
my $completeDate = $1;
my $st = length($`);
my $key = "$st-".($st + length($1));
if (($day1 < 32) && ($day1 > 0) && ($day2 < 32) && ($day2 > 0)) {
addType ($key, "Date range (9)");
}
}
while ($text =~ /\b((\d{1,2})(|st|nd|rd|th|)?( of)?[ \-]\b$m)\b/ig) { # 12-Apr, or Second of April
my $day = $2;
my $completeDate = $1;
my $st = length($`);
my $key = "$st-".($st + length($1));
if (($day < 32) && ($day > 0)) {
addType ($key, "Day Month");
}
}
###
# while ($text =~ /\b((\d{1,2})(|st|nd|rd|th|)?\s+(of)?\s+[\-]\b$m\.?,?)\s*(\d{2,4})\b/ig) { # 12-Apr, or Second of April
while ($text =~ /\b(((\d{1,2})(|st|nd|rd|th|)?\s+(of\s)?[\-]?\b($m)\.?,?)\s+(\d{2,4}))\b/ig) { # 12-Apr, or Second of April
my $day = $3;
my $month = $6;
my $year = $7;
my $completeDate = $1;
my $st = length($`);
my $key = "$st-".($st + length($1));
if (($day < 32) && ($day > 0)) {
addType ($key, "Day Month Year 2");
}
}
###
while ($text =~ /\b((\d{1,2})(|st|nd|rd|th|)? ?(\-|to|through)+ ?(\d{1,2})(|st|nd|rd|th|)?( of)?[ \-]\b$m)\b/ig) { # 12-Apr
my $day1 = $2;
my $day2 = $5;
my $completeDate = $1;
my $st = length($`);
my $key = "$st-".($st + length($1));
if (($day1 < 32) && ($day1 > 0) && ($day2 < 32) && ($day2 > 0)) {
addType ($key, "Date range (10)");
}
}
while ($text =~ /\b((\d{1,2})(|st|nd|rd|th|)? ?\-\> ?(\d{1,2})(|st|nd|rd|th|)?( of)?[ \-]\b$m)\b/ig) { # 12-Apr
my $day1 = $2;
my $day2 = $5;
my $completeDate = $1;
my $st = length($`);
my $key = "$st-".($st + length($1));
if (($day1 < 32) && ($day1 > 0) && ($day2 < 32) && ($day2 > 0)) {
addType ($key, "Date range (11)");
}
}
while ($text =~ /\b($m\.?,? ?(of )?\d{2}\d{2}?)\b/ig) { # Apr. 2002
my $year = $2;
my $completeDate = $1;
my $st = length($`);
my $key = "$st-".($st + length($1));
addType ($key, "Month Year");
}
}
}
}
# End of function date()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: age()
# Checks for ages that are >=90 (assuming that no one is over 125 years old, just as a sanity check)
# When ages are spelled-out, assumes that the number will not be over hundred, i.e. highest spelled-out age="hundred"
sub age {
$text = $_[0];
if ($agefilter =~ /y/) {
foreach $i (@age_indicators_suff) {
if (($text =~ /\b(ninety)[\s\-]+ *$i\b/ig) || ($text =~ /\b(hundred)[\s\-]+ *$i\b/ig)) {
my $age = $1;
my $st = length($`);
my $key = "$st-".((length $age) + $st);
addType ($key, "Age over 90");
}
while ($text =~ /\b(([A-Za-z]+)([\s \-])([A-Za-z]+)) ? *$i\b/ig) {
foreach $j (@digits) {
$first = $2;
$second = $4;
my $age1 = $1;
my $st1 = length($`);
my $end1 = (length $age1) + $st1;
my $key1 = "$st1-$end1";
$st2 = $st1+length($2)+length($3);
$end2 = $st2+(length($second));
my $key2 = "$st2-$end2";
if ((($first=~/\bninety\b/ig) || ($first=~/\bhundred\b/ig)) && (($second=~/\b$digits\b/ig))) {
addType ($key1, "Age over 90");
}
else {
if (!(($first=~/\bninety\b/ig) || ($first=~/\bhundred\b/ig))) {
if (($second=~/\bninety\b/ig) || ($second=~/\bhundred\b/ig)) {
addType ($key2, "Age over 90");
}
}
}
}
}
while ($text =~ /\b(\d+) *$i/ig) {
my $age = $1;
my $st = length($`);
my $key = "$st-".((length $age) + $st);
if (($age >= 90) && ($age <= 125)) {
addType ($key, "Age over 90");
}
}
}
foreach $i (@age_indicators_pre) {
while ($text =~ /\b($i + *)(([A-Za-z]+)([\s \-])([A-Za-z]+))\b/ig) {
foreach $j (@digits) {
$first = $3;
$second = $5;
my $age1 = $2;
my $st1 = length($`)+length($1);
my $end1 = (length $age1) + $st1;
my $key1 = "$st1-$end1";
$st2 = $st1;
$end2 = $st2+length($first);
my $key2 = "$st2-$end2";
if ((($first=~/\bninety\b/ig) || ($first=~/\bhundred\b/ig)) && (($second=~/\b$digits\b/ig) || (length($second)))) {
addType ($key1, "Age over 90");
}
else {
if (!(($first=~/\bninety\b/ig) || ($first=~/\bhundred\b/ig))) {
if (($second=~/\bninety\b/ig) || ($second=~/\bhundred\b/ig)) {
addType ($key2, "Age over 90");
}
}
}
}
}
while ($text =~ /\b($i + *)(\d+)\b/ig) {
my $age = $2;
my $st = length($`)+length($1);
my $key = "$st-".((length $age) + $st);
if (($age >= 90) && ($age <= 125)) {
addType ($key, "Age over 90");
}
}
}
}
}
# End of function age()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: pager()
# Checks for pager numbers
sub pager {
$text = $_[0];
if ($telfilter =~ /y/) {
foreach $i ("Pager", "Pg", "Pgr", "Page", "Beeper", "Beeper number", "Pager number") { #removed "P"
while ($text =~ /\b$i[\s\#\:\-\=]*([a-zA-Z]\s+)*[a-zA-Z]*\s*(\d\d\d+)\b/gi) {
my $num = $2;
my $end = length($`)+length($&);
my $key = ($end - (length $num))."-$end";
addType ($key, "Pager number");
}
while ($text =~ /\b$i[\s\#\:\-\=]*/gi){
my $startp = length($`);
my $endp = length($`)+length($&);
#get the next 30 characters
my $the_chunck = (substr $text, $endp, 30);
#now look for a 5-digit number
while ($the_chunck =~ /(\D)(\d{5})(\D)/gi){
my $pager_startp = $endp + length($`) + length($1);
my $pager_endp = $pager_startp + length($2);
my $key = "$pager_startp-$pager_endp";
addType ($key, "Pager number");
} #end while
} #end while
}
}
}
# End of function pager()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: email()
# Looks for e-mail addresses
sub email {
$text = $_[0];
if ($emailfilter =~ /y/) {
while ($text =~ /\b([\w\.]+\w ?@ ?\w+[\.\w+]\.\w{2,3})\b/g) {
my $st = length($`);
my $key = "$st-".($st+length($&));
addType ($key, "E-mail address");
}
}
}
# End of function email()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: url()
# Checks for URLs of different types
sub url {
$text = $_[0];
if ($urlfilter =~ /y/) {
while ($text =~ /\bhttps?\:\/\/[\w\.]+\w{2,4}\/\S+\b/gi) {
my $st = length($`);
my $key = "$st-".($st+length($&));
addType ($key, "URL");
}
while ($text =~ /\bftp\:\/\/[\w\.]+\w{2,4}\/\S+\b/gi) {
my $st = length($`);
my $key = "$st-".($st+length($&));
addType ($key, "URL");
}
while ($text =~ /\bwww\.[\w\.]+\w{2,4}\/\S+\b/gi) {
my $st = length($`);
my $key = "$st-".($st+length($&));
addType ($key, "URL");
}
while ($text =~ /\bwww\.[\w\.]+\w{2,4}\b/gi) {
my $st = length($`);
my $key = "$st-".($st+length($&));
addType ($key, "URL");
}
while ($text =~ /\bweb\.[\w\.]+\w{2,4}\/\S+\b/gi) {
my $st = length($`);
my $key = "$st-".($st+length($&));
addType ($key, "URL");
}
while ($text =~ /\bweb\.[\w\.]+\w{2,4}\b/gi) {
my $st = length($`);
my $key = "$st-".($st+length($&));
addType ($key, "URL");
}
while ($text =~ /\bhttps?\:\/\/[\w\.]+\w{2,4}\b/g) {
my $st = length($`);
my $key = "$st-".($st+length($&));
addType ($key, "URL");
}
while ($text =~ /\bftp\:\/\/[\w\.]+\w{2,4}\b/g) {
my $st = length($`);
my $key = "$st-".($st+length($&));
addType ($key, "URL");
}
}
}
# End of function url()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: ssn()
# Checks for social security numbers (SSNs)
sub ssn {
$text = $_[0];
if ($ssnfilter =~ /y/) {
while ($text =~ /\b\d\d\d([- \/]?)\d\d\1\d\d\d\d\b/g) {
my $st = length($`);
my $key = "$st-".($st+length($&));
addType ($key, "Social Security Number");
}
}
}
# End of function ssn()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: name1()
# Uses name prefixes to make last names
sub name1 {
$text = $_[0];
if ($namefilter =~ /y/) {
my @keylst = sort numerically keys %phi;
my $key;
for($i=0;$i<$#keylst;$i++){
$key = $keylst[$i];
if (isType($key, "Last Prefix", 0)){
($f1,$t1) = split ('-',$key);
($f2,$t2) = split ('-',$keylst[$i+1]);
if ($f2 < $t1+3){
if (isType($keylst[$i+1], "Last Name", 1)){
print "Found Last Prefix match, Adding $keylst[$i+1] type for last name!!";
addType("$f1-$t2","Last Name");
}
}
}
}
#####################################################
# Uses common-sense heuristics to try to find more names
foreach $i (@name_indicators){
#while ($text =~ /\b($i)(s)?( *)(\-|\,|\.|\()?( *)([A-Za-z]+\b)(\s+)(and )?( *)([A-Za-z]+)\b/ig) {
while ($text =~ /\b($i)(s)?( *)(\-|\,|\.|\()?( *)([A-Za-z]+\b)\b/ig) {
$potential_name = $6;
$start = length($`)+length($1) + length ($2) + length($3) + length($4) + length($5);
$end = $start + length($potential_name);
$key = "$start-$end";
my $tmpstr = substr $text, $start, $end-$start;
my $tmp = isType($key, "Name",1);
if (isProbablyName($key, $potential_name)){
addType ($key, "Name (NI)");
} # end if the first word after the name indicator is a name
my $new_start = $end + length($6) + length($7);
my $new_end = $new_start + length($8);
#########now check the next word
my $rest = substr $text, $end+1, 20;
if (($rest =~ /\b(and )?( *)([A-Za-z]+)\b/ig)){
my $new_start = $end + 1 + length($`) + length($1)+length($2);
my $new_end = $new_start + length ($3);
my $keyAfter = "$new_start-$new_end";
my $wordAfter = substr $rest, (length ($`)+ length($1) + length($2)) , length ($3);
if ( !isNameIndicator($wordAfter) && ( ( !isCommon($wordAfter) ||
((isType($keyAfter, "Name", 1) && isType($keyAfter, "(un)")) ||
(isType($keyAfter, "Name", 1) && ($wordAfter =~ /\b(([A-Z])([a-z]+))\b/g)) ||
(!isCommonest($wordAfter) && isType($keyAfter, "Name", 1)) ||
(isType($keyAfter, "popular",1)) ) ) ) ) {
if ($rest =! /\b[\d]\b/ig) { #disregard if the rest contains numeric patterns
addType ($keyAfter, "Name2 (NI)");
}
}
elsif ($1 =~ /and/ig){
if (! (isCommon($wordAfter) || isNameIndicator($wordAfter))) {
addType ($keyAfter, "Name2 (NI)");
}
}
} #end if rest
} # end of while
} #end for each name indicator
#**********************************************************************************************************
# Searches for the name pattern LASTNAME, FIRSTNAME
# First checks if word2 is a firstname
# If it is, then if word1 is not a common or commonest word, identifies word1 as a lastname
while ($text =~ /\b([A-Za-z]+)( ?\, ?)([A-Za-z]+)\b/ig) {
$input1 = $1;
$input2 = $3;
my $st1 = length($`);
my $end1 = $st1 + length($input1);
my $key = $key1;
my $key1 = "$st1-$end1";
my $st2 = $end1+length($2);
my $end2 = $st2 + length($input2);
my $key = $key2;
my $key2 = "$st2-$end2";
if ((isType($key2, "Name", 1)) && (isType($key1, "Name (ambig)", 1)) && (!isNameIndicator($input1)) ) {
addType ($key1, "Last Name (LF)");
addType ($key2, "First Name1 (LF)");
}
if ((isType($key1, "Name", 1)) && (isType($key2, "Name (ambig)", 1)) && (!isNameIndicator($input1)) ) {
addType ($key2, "Last Name (LF)");
addType ($key1, "First Name2 (LF)");
}
if (isType($key2, "First Name", 1)) {
if ( (isType($key1, "Last Name", 1) && (!isCommonest($input1)) && (!isNameIndicator($input1))) ||
((!isCommon($input1)) && (!isCommonest($input1))) ) {
addType ($key1, "Last Name (LF)");
addType ($key2, "First Name3 (LF)");
}
}
}
}
}
# End of function name1()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: seasonYear()
# Checks for both season and year from patterns like "<season> of? <year>"
sub seasonYear {
$text = $_[0];
@seasons = ("winter", "spring", "summer", "autumn", "fall");
foreach $i (@seasons) {
while ($text =~ /\b(($i)(( +)of( +))? ?\,?( ?)\'?(\d{2}|\d{4}))\b/gi) {
$f2=$2;
$f3=$3;
$f6=$6;
$f7=$7;
if (length($f7)==4) {
if (($f7<=$longyear) && ($f7>1900)) {
my $st1 = length($`);
my $end1 = (length $f2) + $st1;
my $key1 = "$st1-$end1";
my $st2 = $end1+(length $f3)+(length $f6);
my $key2 = "$st2-".((length $f7) + $st2);
addType ($key2, "Year (4 digits)");
}
}
else {
my $st1 = length($`);
my $end1 = (length $f2) + $st1;
my $key1 = "$st1-$end1";
my $st2 = $end1+(length $f3)+(length $f6);
my $key2 = "$st2-".((length $f7) + $st2);
addType ($key2, "Year (4 digits)");
}
}
}
}
# End of function seasonYear()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: name2()
# Checks for more than 1 name following plural drs, drs., doctors, professors,
# Checks up to 3 names
sub name2 {
$text = $_[0];
if ($namefilter =~ /y/) {
@plural_titles = ("doctors", "drs", "drs\.", "professors");
foreach $p (@plural_titles) {
while ($text =~ /\b((($p +)([A-Za-z]+) *(and +)?\,? *)([A-Za-z]+) *(and +)?\,? *)([A-Za-z]+)?\b/gi) {
my %names = ();
$st3 = length($`);
$st4 = $st3+length($3);
$end4 = $st4+length($4);
$key4 = "$st4-$end4";
$st6 = $st3+length($2);
$end6 = $st6+length($6);
$key6 = "$st6-$end6";
$st8 = $st3+length($1);
$end8 = $st8+length($8);
$key8= "$st8-$end8";
$names{$4} = $key4;
$names{$6} = $key6;
$names{$8} = $key8;
foreach $i (keys %names) {
$val = $names{$i};
if (length($i)>0) {
if (!(isCommonest($i)) || (isType($val, "Name", 1))) {
#print "addtype, val is $val\n";
addType ($val, "Name5 (PTitle)");
}
}
}
}
}
#****************************************************************************************
# Checks for names followed by "MD" or "M.D"
# Checks up to 3 previous words
while ($text =~ /\b((([A-Za-z\']+) +)?(([A-Za-z])\. +)?([A-Za-z\-\']+)((\, *)|(\s+))(rrt|md|m\.d\.|crt|np|rn|nnp|msw|r\.n\.)(\.|\,)*\b)/ig) {
$name = $1;
$start = length($`);
$end = $start + length($name);
$key = "$start-$end";
$name1 = $3; #if present, would be first name
$name2 = $4; #if present, would be initial
$name3 = $6; #if present would be last name
$st1 = length($`);
$end1 = $st1 + (length $name1);
$key1 = "$st1-$end1";
$st2 = $st1 + length($2);
$end2 = $st2 + (length $name2);
$key2 = "$st2-$end2";
$st3 = length($`) + (length $2) + (length $4);
$end3 = $st3 + (length $name3);
$key3 = "$st3-$end3";
if ((!($text =~ /(m\.?d\.?\')/)) && (!($text =~ /(m\.?d\.?s)/))) {
if (length($name1)>0) {
if ((length($name1)==1) || ((length($name1)==2) && ($name1 =~ /\b([A-Za-z])\.+\b/ig))) {
addType($key1, "Name Initial (MD)");
}
else {
if (isProbablyName($key1, $name1)) {
addType($key1,"Name6 (MD)" );
}
}
}
if (length($name2)>0 && length($name3)>0) {
if ((length($name2)==1) || ((length($name2)==2) && ($name2 =~ /\b([A-Za-z])\.+\b/ig))) {
#addType($key2, "Name Initial (MD)");
}
else {
#if (!(isCommon($name2) && !(isType($key2, "Name", 1)))) {
if (isProbablyName($key2, $name2)) {
addType($key2,"Name7 (MD)" );
}
}
}
if (length($name3)>0) {
if ((length($name3)==1) || ((length($name3)==2) && ($name3 =~ /\b([A-Za-z])\.\b/ig))) {
#addType($key3, "Name Initial (MD)");
}
else {
if (isProbablyName($key3, $name3)) {
addType($key3,"Name8 (MD)" );
}
} # end else
} #endif
} #end if text does not have M.D.' or M.D.s
}
#****************************************************************************************
# Removes PCP name field, leaving "PCP name:" intact, from discharge summaries
# Does not check for name patterns, since these should be caught by the other methods
# Required mainly for unknown names, checks up to 3 words following "PCP Name"
# Follows the pattern seen in discharge summaries, may not work well in nursing notes
#@name_pre = ("PCP", "physician", "provider", "created by", "name");
@name_pre = ("PCP", "physician", "provider", "created by");
foreach $l (@name_pre) {
while ($text =~/\b(($l( +name)?( +is)?\s\s*)([A-Za-z\-]+)((\s*\,*\s*)? *)([A-Za-z\-]+)(((\s*\,*\s*)? *)([A-Za-z\-]+))?)\b/ig) {
my $key1 = $5;
my $st1 = length($`)+(length $2);
my $end1 = $st1+(length $5);
my $keyloc1 = "$st1-$end1";
my $key2 = $8;
my $st2 = $end1+(length $6);
my $end2 = $st2+(length $8);
my $keyloc2 = "$st2-$end2";
my $key3 = $12;
my $st3 = $end2+(length $10);
my $end3 = $st3+(length $12);
my $keyloc3 = "$st3-$end3";
my %pcp = ();
$pcp{$keyloc1} = $key1;
$pcp{$keyloc2} = $key2;
$pcp{$keyloc3} = $key3;
foreach my $keyloc (keys %pcp ) {
my $val = $pcp{$keyloc};
if (length($val)>0) {
if ((length($val)==1) || ($val =~ /\b([A-Za-z])\.\b/ig)) {
addType($keyloc, "Name Initial (PRE)");
}
else {
#if (!(isCommonest($val) && !(isType($keyloc, "Name", 1)))) {
if (isProbablyName($keyloc, $val)){
addType($keyloc,"Name9 (PRE)" );
}
}
}
}
}
#followed by pattern "name is"
while ($text =~ /\b(($l( +name)?( +is)? ?([\#\:\-\=\.\,])+ *)([A-Za-z\-]+)((\s*\,*\s*)? *)([A-Za-z\-]+)((\s*\,*\s*)? *)([A-Za-z\-]+)?)\b/ig) {
my $key1 = $6;
my $st1 = length($`)+(length $2);
my $end1 = $st1+(length $6);
my $keyloc1 = "$st1-$end1";
my $key2 = $9;
my $st2 = $end1+(length $7);
my $end2 = $st2+(length $9);
my $keyloc2 = "$st2-$end2";
my $key3 = $12;
my $st3 = $end2+(length $10);
my $end3 = $st3+(length $12);
my $keyloc3 = "$st3-$end3";
my %pcp = ();
my $firstfound = 0;
my $secondfound = 0;
$pcp{$keyloc1} = $key1;
$pcp{$keyloc2} = $key2;
$pcp{$keyloc3} = $key3;
$blah = isCommonest($key3);
$blah2 = isType($keyloc3, "Name", 1);
if (length($key1)>0) {
if ((length($key1)==1) || ($key1 =~ /\b([A-Za-z])\.\b/ig)) {
addType($keyloc1, "Name Initial (NameIs)");
$firstfound = 1;
}
else {
if (isProbablyName($keyloc1, key1)){
addType($keyloc1,"Name10 (NameIs)" );
$firstfound = 1;
}
}
}
if ($firstfound == 1) {
if (length($key2)>0) {
if ((length($key2)==1) || ($key2 =~ /\b([A-Za-z])\.\b/ig)) {
addType($keyloc2, "Name Initial (NameIs)");
$secondfound = 1;
}
else {
if (isProbablyName($keyloc2, $key2)){
addType($keyloc2,"Name11 (NameIs)" );
$secondfound = 1;
}
}
}
}
if ($secondfound == 1) {
if (length($key3)>0) {
if ((length($key3)==1) || ($key3 =~ /\b([A-Za-z])\.\b/ig)) {
addType($keyloc3, "Name Initial (NameIs)");
}
else {
if (isProbablyName ($keyloc3, $key3)){
addType($keyloc3,"Name12 (NameIs)" );
}
}
}
}
}
}
}
}
# End of function name2()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: providerNumber()
# Removes "provider number", whole field, from discharge summaries
# Does not remove the field if there is no number following it
sub providerNumber {
$text = $_[0];
if ($unitfilter =~ /y/) {
while ($text =~ /\b(provider(( +)number)?( ?)[\#\:\-\=\s\.]?( ?)(\d+)([\/\-\:](\d+))?)\b/gi) {
my $unit = $1;
my $st = length($`);
my $key = "$st-".((length $unit) + $st);
addType ($key, "Provider Number");
}
}
}
# End of function providerNumber()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: signatureField()
# Removes signature fields from discharge summaries
# signature field taken as 3 or more underscores
# does not remove doctor names, since these are handled by other name handlers
sub signatureField {
$text = $_[0];
while ($text =~ /\b(\_\_+)\b/gi) {
my $sigfield = $1;
my $st = length($`);
my $key = "$st-".((length $sigfield) + $st);
addType ($key, "Signature");
}
}
# End of function signatureField()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: location1()
# Removes complete street addresses only when including one of the terms in @street_add_suff
sub location1 {
$text = $_[0];
if ($locfilter =~ /y/) {
#check if ambiguous locations are preceded by any of the location indicators,
#if so, add in PHI list
foreach $i (@location_indicators){
while ($text =~ /\b($i)(\s+)([A-Za-z]+)\b/ig) {
#print "Location Match 1 is $1, 2 is $2, 3 is $3\n";
my $st = length ($`) + length ($1) + length ($2);
my $end = $st + length ($3);
my $key = "$st-$end";
my $word = substr $text, $st, ($end-$st);
#print "word is $word\n";
if (isType($key, "Location",1) || (length ($word) > 1 && !(isCommon($word))) ) {
addType ($key, "Location");
}
}
} #end for each i in location indicators
#if the company dictionary is loaded, check if any of the ambiguous company names
#are preceded by the employment indicators
if ($company_list =~/y/){
#print "company list is on\n";
foreach $i (@employment_indicators_pre){
while ($text =~ /\b($i)(\s+)([A-Za-z]+)\b/ig) {
$st = length ($`) + length ($1) + length ($2);
$end = $st + length ($3);
$key = "$st-$end";
my $word = substr $text, $st, ($end-$st);
my $tmp = isCommon($word);
if (isType($key, "Company",1)|| (length ($word) > 1 && !(isCommon($word))) ) {
#print "adding $3 key $key as company unambig";
addType ($key, "Company");
}
}
} #end for each i in location indicators
}
#strict address suffix, case-sensitive match, PHI regardless of ambiguity
foreach $i (@strict_street_add_suff) {
#make it a case-sensitive match for street address suffix
while ($text =~ /\b(([0-9]+ +)?(([A-Za-z\.\']+) +)?([A-Za-z\.\']+) +\b$i\.?\b)\b/g) {
$st = length($`);
$end = $st + length($1);
#check next segment for apartment, suite, floor #s
my $nextSeg = substr $text, $end, 30;
#print "check nextSeg for apt and sutie #, seg is $nextSeg\n";
foreach $k (@apt_indicators){
if ($nextSeg =~ /\b($k\.?\#? +[\w]+)\b/gi) {
$end += length ($`) + length($1);
}
}
$key = "$st-$end";
#addType ($key, "Street Address");
if (length($3) == 0) {
if (!isUnambigCommon($5)) {
addType ($key, "Street Address");
}
}
elsif (!((isUnambigCommon($4)) && (isUnambigCommon($5)))) {
addType($key, "Street Address");
}
} # end while
} #end foreach
}#end if
#Non-strict address suffix, case-insensitive match, PHI if no ambiguity
if ($locfilter =~ /y/) {
foreach $i (@street_add_suff) {
while ($text =~ /\b(([0-9]+) +(([A-Za-z]+) +)?([A-Za-z]+) +$i)\b/gi) {
$st = length($`);
$end = $st + length($1);
$key = "$st-$end";
if (length($3) == 0) {
if (!isUnambigCommon($word)){
addType ($key, "Street Address");
}
}
elsif ( ! (isUnambigCommon($4) || isUnambigCommon($5))){
addType($key, "Street Address");
}
}
}
}
#****************************************************************************************
# Removes 2-word location PHI ending with @loc_indicators_suff or preceded by @loc_indicators_pre
# Words potentially PHI
if ($locfilter =~ /y/) {
foreach $i (@loc_indicators_suff) {
while ($text =~ /\b(([A-Za-z\-]+)? +)?(([A-Za-z\-]+) + *$i +)\b/ig) {
if (!isCommon($4)) {
$st2 = length($`)+length($1);
$end2 = $st2 + length($3);
$key2 = "$st2-$end2";
addType ($key2, "Location");
if (length $2>0) {
if (!isCommon($2)) {
$st1 = length($`);
$end1 = $st1 + length($2);
$key1 = "$st1-$end1";
addType ($key1, "Location");}
}
}
}
}
}
if ($locfilter =~ /y/) {
# Words most likely PHI
foreach $i (@loc_ind_suff_c) {
while ($text =~ /\b(([A-Za-z]+ +)?)(([A-Za-z]+)$i+)\b/ig) {
if (!isCommon($3)) {
$st2 = length($`)+length($1);
$end2 = $st2 + length($3);
$key2 = "$st2-$end2";
addType ($key2, "Location");
}
}
}
}
if ($locfilter =~ /y/) {
# Words potentially PHI
foreach $i (@loc_indicators_pre) {
while ($text =~ /\b((($i + *([A-Za-z\-]+)) *)([A-Za-z\-]+)?)\b/ig) {
if (!isCommon($4)) {
$st2 = length($`);
$end2 = $st2 + length($3);
$key2 = "$st2-$end2";
addType ($key2, "Location");
if (length $5>0) {
if (!isCommon($5)) {
$st1 = length($`)+length($2);
$end1 = $st1 + length($5);
$key1 = "$st1-$end1";
addType ($key1, "Location");
}
}
}
}
}
} # end if locfilter =~ /y/
@universities_pre = ("University", "U", "Univ", "Univ.");
#catches "University of", "U of", "Univ of", "Univ. of"
if ($locfilter =~ /y/) {
# Words potentially PHI
foreach $i (@universities_pre) {
while ($text =~ /\b((($i +of *([A-Za-z\-]+)) *)([A-Za-z\-]+)?)\b/ig) {
my $tmp = isUSStateAbbre($4);
if (isUSStateAbbre($4) || isUSState($4) || !isCommon($4) ) {
$st2 = length($`);
$end2 = $st2 + length($3);
$key2 = "$st2-$end2";
addType ($key2, "Location");
if (length $5>0) {
if (!isCommon($5)) {
$st1 = length($`)+length($2);
$end1 = $st1 + length($5);
$key1 = "$st1-$end1";
addType ($key1, "Location (Universities)");
}
}
}
}
}
} # end if locfilter =~ /y/
}
# End of function location1()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: location2()
# Searches for multiple hospital and location terms
sub location2 {
$text = $_[0];
if ($locfilter =~ /y/) {
foreach $hos (@hospital) {
my @hospital_terms = split " ", $hos;
$len = 0;
foreach $h (@hospital_terms) {
if (length($h) != 0) {
$len = $len+1;
$hos[$len] = $h;
}
}
if ($len == 1) {
while ($text =~ /\b($hos[1])\b/ig) {
$hospital = $1;
$st = length($`);
$end = $st + length($hospital);
$key = "$st-$end";
addType($key, "Hospital1");
}
}
if ($len == 2) {
while ($text =~ /\b($hos[1])( )($hos[2])\b/ig) {
$hos1 = $1;
$hos2 = $3;
$space = $2;
$st1 = length($`);
$end1 = $st1 + length($hos1);
$key1 = "$st1-$end1";
addType($key1, "Hospital2");
$st2 = $end1 + length($space);
$end2 = $st2 + length($hos2);
$key2 = "$st2-$end2";
addType($key2, "Hospital3");
}
}
if ($len == 3) {
while ($text =~ /\b($hos[1])( )($hos[2])( )($hos[3])\b/ig) {
$hos1 = $1;
$hos2 = $3;
$hos3 = $5;
$st1 = length($`);
$end1 = $st1 + length($hos1);
$key1 = "$st1-$end1";
addType($key1, "Hospital4");
$st2 = $end1 + length($2);
$end2 = $st2 + length($hos2);
$key2 = "$st2-$end2";
addType($key2, "Hospital5");
$st3 = $end2 + length($4);
$end3 = $st3 + length($hos3);
$key3 = "$st3-$end3";
addType($key3, "Hospital6");
}
}
if ($len == 4) {
while ($text =~ /\b($hos[1])( )($hos[2])( )($hos[3])( )($hos[4])\b/ig) {
$hos1 = $1;
$hos2 = $3;
$hos3 = $5;
$st1 = length($`);
$end1 = $st1 + length($hos1);
$key1 = "$st1-$end1";
addType($key1, "Hospital");
$st2 = $end1 + length($2);
$end2 = $st2 + length($hos2);
$key2 = "$st2-$end2";
addType($key2, "Hospital");
$st3 = $end2 + length($4);
$end3 = $st3 + length($hos3);
$key3 = "$st3-$end3";
addType($key3, "Hospital");
$st4 = $end3 + length($6);
$end4 = $st4 + length($hos4);
$key4 = "$st4-$end4";
addType($key4, "Hospital");
}
}
}
foreach $loc (@loc_unambig) {
my @loc_terms = split " ", $loc;
$len = 0;
foreach $h (@loc_terms) {
if (length($h) != 0) {
$len = $len+1;
$loc[$len] = $h;
}
}
if ($len == 1) {
while ($text =~ /\b($loc[1])\b/ig) {
$location = $1;
$st = length($`);
$end = $st + length($location);
$key = "$st-$end";
addType($key, "Location");
}
}
if ($len == 2) {
while ($text =~ /\b($loc[1])( )($loc[2])\b/ig) {
$loc1 = $1;
$loc2 = $3;
$st1 = length($`);
$end1 = $st1 + length($loc1);
$key1 = "$st1-$end1";
addType($key1, "Location");
$st2 = $end1 + length($2);
$end2 = $st2 + length($loc2);
$key2 = "$st2-$end2";
addType($key2, "Location");
}
}
if ($len == 3) {
while ($text =~ /\b($loc[1])( )($loc[2])( )($loc[3])\b/ig) {
$loc1 = $1;
$loc2 = $3;
$loc3 = $5;
$st1 = length($`);
$end1 = $st1 + length($loc1);
$key1 = "$st1-$end1";
addType($key1, "Location");
$st2 = $end1 + length($2);
$end2 = $st2 + length($loc2);
$key2 = "$st2-$end2";
addType($key2, "Location");
$st3 = $end2 + length($4);
$end3 = $st3 + length($loc3);
$key3 = "$st3-$end3";
addType($key3, "Location");
}
}
if ($len == 4) {
while ($text =~ /\b($loc[1])( )($loc[2])( )($loc[3])( )($loc[4])\b/ig) {
$loc1 = $1;
$loc2 = $3;
$loc3 = $5;
$st1 = length($`);
$end1 = $st1 + length($loc1);
$key1 = "$st1-$end1";
addType($key1, "Location");
$st2 = $end1 + length($2);
$end2 = $st2 + length($loc2);
$key2 = "$st2-$end2";
addType($key2, "Location");
$st3 = $end2 + length($4);
$end3 = $st3 + length($loc3);
$key3 = "$st3-$end3";
addType($key3, "Location");
$st4 = $end3 + length($6);
$end4 = $st4 + length($loc4);
$key4 = "$st4-$end4";
addType($key4, "Location");
}
}
}
#######
#PO Box number
while ($text =~ /\b(P[\.]?O[\.]? *Box *[\#]? *[0-9]+)\b/gi) {
$location = $1;
$st = length($`);
$end = $st + length($location);
$key = "$st-$end";
addType($key, "PO Box");
}
######
#Zipcodes
foreach $loc (@us_states_abbre) {
while ($text =~ /\b($loc *[\.\,]*\s*\d{5}[\-]?[0-9]*)\b/gi) {
$location = $1;
$st = length($`);
$end = $st + length($location);
$key = "$st-$end";
addType($key, "State/Zipcode");
}
}
#Zipcodes with more US states abbreviations
foreach $loc (@more_us_states_abbre) {
while ($text =~ /\b($loc *[\.\,]*\s*\d{5}[\-]?[0-9]*)\b/gi) {
$location = $1;
$st = length($`);
$end = $st + length($location);
$key = "$st-$end";
addType($key, "State/Zipcode");
}
}
#Zipcodes with full US state names
foreach $loc (@us_states) {
while ($text =~ /\b($loc *[\.\,]*\s*\d{5}[\-]?[0-9]*)\b/gi) {
$location = $1;
$st = length($`);
$end = $st + length($location);
$key = "$st-$end";
addType($key, "State/Zipcode");
}
}
##########
#remove US states if filter flag for State is on
if ($us_state_filter =~ /y/) {
foreach $loc (@us_states) {
my @loc_terms = split " ", $loc;
$len = 0;
foreach $h (@loc_terms) {
if (length($h) != 0) {
$len = $len+1;
$loc[$len] = $h;
}
}
if ($len == 1) {
while ($text =~ /\b($loc[1])\b/ig) {
$location = $1;
$st = length($`);
$end = $st + length($location);
$key = "$st-$end";
addType($key, "State");
}
}
if ($len == 2) {
while ($text =~ /\b(($loc[1])( )($loc[2]))\b/ig) {
$location = $1;
$st = length($`);
$end = $st + length($location);
$key = "$st-$end";
addType($key, "State");
}
}
if ($len == 3) {
while ($text =~ /\b(($loc[1])( )($loc[2])( )($loc[3]))\b/ig) {
$location = $1;
$st = length($`);
$end = $st + length($location);
$key = "$st-$end";
addType($key, "State");
}
}
if ($len == 4) {
while ($text =~ /\b(($loc[1])( )($loc[2])( )($loc[3])( )($loc[4]))\b/ig) {
$location = $1;
$st = length($`);
$end = $st + length($location);
$key = "$st-$end";
addType($key, "State");
}
}
}
} #end if us_state_filter is on
#######
# Sub-function: hospitalIndicators()
# Searches for hospital indicators and checks if previous and following words are hospitals
foreach $h (@hospital_indicators) {
while ($text =~ /((([A-Za-z\-\']+)( + *))?(([A-Za-z\-\']+)( + *))?($h\b)(( + *)([A-Za-z\-\']+))?(( + *)([A-Za-z\-\']+))?\b)/ig) {
my $typeadded = 0;
$st1 = length($`);
$end1 = $st1 + length($3);
$key1 = "$st1-$end1";
$st2 = $st1 + length($2);
$end2 = $st2 + length($6);
$key2 = "$st2-$end2";
$st3 = $st1 + length($2) + length ($5) + length($8) + length($10);
$end3 = $st3 + length($11);
$key3 = "$st3-$end3";
$st4 = $end3 + length($13);
$end4 = $st4 + length($14);
$key4 = "$st4-$end4";
$st5 = $end2 + length($7);
$end5 = $st5 + length($8);
$key5 = "$st5-$end5";
if (length($5)==0) {
if ((length($3) > 1) && (!isUnambigCommon($3)) && (!(isCommon ($3)) || (isType ($key1, "Hospital", 1)))) {
addType ($key1, "Hospital");
#addType ($key5, "Hospital-Ind");
$typeadded = 1;
}
}
elsif ((length($6) > 1) && (!isUnambigCommon($6)) && (!(isCommon ($6)) || isUSState($6) || isUSStateAbbre($6) || (isType ($key2, "Hospital", 1)))) {
addType ($key2, "Hospital");
#addType ($key5, "Hospital-Ind");
$typeadded = 1;
if ((length($3) > 1) && (!isUnambigCommon($3)) && (!(isCommon ($3)) || isUSState($3) || isUSStateAbbre($3) || (isType ($key1, "Hospital", 1)))) {
addType ($key1, "Hospital");
#addType ($key5, "Hospital-Ind");
$typeadded = 1;
}
}
# #Generating too many false positives.
# #Need a better common word dictionary to enable this.
#if ($typeadded == 0) {
# if ((length($11) > 1) && (!(isCommonest ($11)) || (isType ($key3, "Hospital", 1)))) {
# #addType ($key3, "Hospital");
# #addType ($key5, "Hospital-Ind");
# #if ((length($14) > 1) && (!(isCommonest ($14)) || (isType ($key4, "Hospital", 1)))) {
# # # addType ($key4, "Hospital");
# # #addType ($key5, "Hospital-Ind");
# # }
# }
#} #end if (typeadded == 0)
}
}
}
}
# End of function location2()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: problem()
# Checks for names preceded by "problem", pattern found in discharge summaries
sub problem {
$text = $_[0];
$k = "problem";
$l = ":";
while ($text =~ /\b(([A-Za-z\-]+) + *($k))\b/ig) {
if ((!isCommon($2)) || (isNameAmbig($2))) {
$st = length($`);
$end = $st + length($2);
$key = "$st-$end";
addType ($key, "Last Name");
}
}
}
# End of function problem()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: mrn()
# Checks for medical record numbers, i.e. numbers preceded by "mrn" or "medical record number"
sub mrn {
$text = $_[0];
if ($unitfilter =~ /y/) {
while ($text =~ /\b(mrn( *)[\#\:\-\=\s\.]?( *)(\t*)( *)(\d+)([\/\-\:](\d+))?)\b/gi) {
my $unit = $1;
my $st = length($`);
my $key = "$st-".((length $unit) + $st);
addType ($key, "Medical Record Number");
}
@numbers = ("number", "no", "num", "");
foreach $i (@numbers) {
while ($text =~ /\b(medical record( *)$i?( *)[\#\:\-\=\s\.]?( *)(\t*)( *)(\d+)([\/\-\:](\d+))?)\b/gi) {
my $unit = $1;
my $st = length($`);
my $key = "$st-".((length $unit) + $st);
addType ($key, "Medical Record Number");
}
}
}
}
# End of function mrn()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: unit()
# Checks for unit numbers in discharge summaries
# Removes the entire field of "unit <number>" or unit <number>/<number>
# If "unit" is not followed by a number, does not remove it
sub unit {
$text = $_[0];
if ($unitfilter =~ /y/) {
@numbers = ("number", "no", "num", "");
foreach $i (@numbers) {
while ($text =~ /\b(unit( ?)$i?( *)[\#\:\-\=\s\.]?( *)(\t*)( *)(\d+)([\/\-\:](\d+))?)\b/gi) {
my $unit = $1;
my $st = length($`);
my $key = "$st-".((length $unit) + $st);
addType ($key, "Unit Number");
}
}
}
}
# End of function unit()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: name3()
# Checks every lastnameprefix
# If the following word is either a name or not commonest, identifies it as lastname
sub name3 {
$text = $_[0];
if ($namefilter =~ /y/) {
foreach $line (@prefixes_unambig) {
while ($text =~ /\b(($line)([\s\'\-])+ *)([A-Za-z]+)\b/ig) {
my $pre = $2;
my $prestart = length($`);
my $preend = $prestart+(length $pre);
my $prekey = "$prestart-$preend";
my $lname = $4;
my $lstart = $prestart+length($1);
my $lend = $lstart+length($4);
my $lnamekey = "$lstart-$lend";
if ((!(isCommonest ($lname))) || (isType ($lnamekey, "Name", 1))) {
addType ($prekey, "Name Prefix (Prefixes)");
addType ($lnamekey, "Last Name (Prefixes)");
}
}
}
#****************************************************************************************
@specific_titles = ("MR", "MISTER", "MS");
foreach $i (@specific_titles) {
while ($text =~ /\b($i\.( *))([A-Za-z\'\-]+)\b/ig) {
$potential_name = $3;
$start = length($`)+length($1);
$end = $start + length($potential_name);
$key = "$start-$end";
if (isType($key, "Name", 1)) {
addType ($key, "Name13 (STitle)");
}
elsif (!(isCommon($potential_name))) {
addType ($key, "Name14 (STitle)");
}
}
}
#****************************************************************************************
# Goes through word by word looking for unspotted names
# All words have already been marked as potential names (where appropriate) by the previous routines
# Looks for last names following titles (Dr. Smith)
# Also should pick up "Dr. S"
# Looks for the last name prefixes
foreach $i (@strict_titles) {
L:
while ($text =~ /\b($i\b\.? *)([A-Za-z\'\-]+)\b/ig) { # added ' -
my $tt = $1;
my $word = $2;
my $st = length($`) + length($1);
my $fi = $st + length($2);
my $key = "$st-$fi";
if (exists $prefixes{uc($word)}) {
addType ($key, "Last Name (STitle)");
my $start = $fi;
my $nextWord = substr $text, $start;
if ($nextWord =~ /\A( ?)(\')?( ?)([A-Za-z]+)\b/g) {
my $token = $4;
my $lstart = $start+length($1)+length($2)+length($3);
my $lend = $lstart+length($4);
my $fi += length($1)+length($4);
if (exists $prefixes{uc($token)}){
addType ("$start-$fi", "Last Name (STitle)");
my $start = $fi;
my $nextWord = $nextWord;
my $token = $token;
if ($nextWord =~ /\A( ?$token( ?))([A-Za-z]+)\b/g) {
$word = $3;
$key = "$fi-".($fi + length($2) + length($3));
} else {
next L;
}
}
else {
# Has already identified one prefix, should now check to see if next word is name or is not commonest
$word = $token;
$key = "$lstart-$lend";
if (isProbablyName($key, $word)){
addType ($key, "Last Name (STitle)");
}
}
} else {
next L;
}
} else { #else $word is not a prefix
if ($word =~ /\'([A-Za-z]+)/) {
$word = $1;
$st--;
$key = $st."-".$fi;
}
if ($word =~ /([A-Za-z]+)\'/) {
$word = $1;
$key = $st."-".($fi-1);
}
}
###########################################################
if (exists $phi{$key}) {
addType($key, "Last Name (STitle)");
if ((isType($key, "First Name", 1))) {
addType($key, "First Name (STitle)");
}
} else {
if (isProbablyName($key, $word)){
addType ($key, "Last Name (STitle)");
}
else {
addType ($key, "Last Name (STitle)");
}
} #end else (!exists $phi{$key})
################################
#added to catch Dr. <firstname> <lastname>
#check the word after $word
my ($tmpStart,$tmpEnd) = split '-', $key;
my $following = substr $text, $tmpEnd;
if($following =~/\A(\s+)([A-Za-z\-\']{2,})\b/g){
my $fword = $2;
my $newst = $tmpEnd + (length ($1));
my $nextKey = "$newst-".($newst + length($2));
if (isProbablyName($nextKey, $fword)){
addType($nextKey, "Name (STitle)");
}
}
##########################################
} #end while text matches the pattern
} #end for each $i strict_titles
#****************************************************************************************
# Goes through word by word looking for unspotted names
# All words have already been marked as potential names (where appropriate) by the previous routines
# Looks for last names following titles (Dr. Smith)
# Also should pick up "Dr. S"
# Looks for the last name prefixes
#mark as ambiguous if common words
foreach $i (@titles) {
L:
while ($text =~ /\b($i\b\.? ?)([A-Za-z]+) *([A-Za-z]+)?\b/ig) {
my $tt = $1;
my $word = $2;
my $st = length($`) + length($1);
my $fi = $st + length($2);
my $key = "$st-$fi";
my $wordAfter = $3; ##added to catch last names
my $stAfter = $fi + 1;
my $fiAfter = $stAfter + length ($3);
my $keyAfter = "$stAfter-$fiAfter";
if (exists $prefixes{uc($word)}) {
addType ($key, "Last Name (Titles)");
my $start = $fi;
my $nextWord = substr $text, $start;
if ($nextWord =~ /\A( ?)(\')?( ?)([A-Za-z]+)\b/g) {
my $token = $4;
my $lstart = $start+length($1)+length($2)+length($3);
my $lend = $lstart+length($4);
my $fi += length($1)+length($4);
if (exists $prefixes{uc($token)}){
addType ("$start-$fi", "Last Name (Titles)");
my $start = $fi;
my $nextWord = $nextWord;
my $token = $token;
if ($nextWord =~ /\A( ?$token( ?))([A-Za-z]+)\b/g) {
$word = $3;
$key = "$fi-".($fi + length($2) + length($3));
} else {
next L;
}
}
else {
# Has already identified one prefix, should now check to see if next word is name or is not commonest
$word = $token;
$key = "$lstart-$lend";
if (isProbablyName($key, $word) && length($word) > 1 ){
addType ($key, "Last Name (Titles)");
}
}
} else {
next L;
}
} else {
if ($word =~ /\'([A-Za-z]+)/) {
$word = $1;
$st--;
$key = $st."-".$fi;
}
if ($word =~ /([A-Za-z]+)\'/) {
$word = $1;
$key = $st."-".($fi-1);
}
}
if (length ($wordAfter) > 1) {
my $tmp = isCommon($wordAfter);
if (!isCommonest($wordAfter) || (isType($keyAfter, "Name", 1) && isType($keyAfter, "(un)")) ||
(isType($keyAfter, "Name", 1) && ($wordAfter =~ /\b(([A-Z])([a-z]+))\b/g)) ) {
addType($keyAfter, "Last Name (Titles)");
addType($key, "First Name (Titles)");
}
}
elsif (exists $phi{$key}) {
if ((isType($key, "Name", 1))) {
addType($key, "Last Name (Titles)");
}
} else {
if ( length($word) > 1 && !(isCommon($word)) ) {
addType ($key, "Last Name (Titles)");
}
else {
if (($word =~ /\b[A-Z][a-z]+\b/) || ($tt =~ /$i\. /)) {
addType ($key, "Last Name (Titles ambig)");
} else {
addType ($key, "Last Name (Titles ambig)");
}
}
}
}
}
#****************************************************************************************
# Implements simple rules for finding names that aren't in the list or are ambiguous...
# first name + last name -> first name + last name (ambig), first name +
#not-on-any-safe-word-list, else save the second word and see whether it appears
#in the patient text not associated with the first name or any other name indicator
# Also first + initial + last name
# Finds each prefix, labels the next not uncommonest word
# Finds all first names (unambig), look at following word -> make last name unambigs
foreach $k (keys %phi) {
if (((isType($k, "Male First Name", 1)) || (isType($k, "Female First Name", 1))) && ((isType($k, "(un)", 1)) || (isType($k, "pop", 1)))) {
my ($start, $end) = split '-', $k;
my $following = substr $text, $end;
# No middle initial
if ($following =~ /\A( +)([A-Za-z\']{2,})\b/g) { #added to catch firstname s.a. O'Connell
my $fword = $2;
my $st = $end + (length $1);
my $nextKey = "$st-".($st + length($2));
if (exists $phi{$nextKey}) {
if ((isType($nextKey, "Name", 1) == 1) && isProbablyName($nextKey, $fword)) {
addType($nextKey, "Last Name (NamePattern1)");
addType($k,"First Name4 (NamePattern1)"); # make it unambig
}
}
else {
if (isProbablyName($nextKey, $fword)){
addType ($nextKey, "Last Name (NamePattern1)");
addType($k,"First Name5 (NamePattern1)"); }}}# make it unambig
# Looks for that middle initial
if ($following =~ /\A( +)([A-Za-z])(\.? )([A-Za-z\-][A-Za-z\-]+)\b/g) {
my $initial = $2;
my $lastN = $4;
my $st = $end + (length $1);
my $iniKey = "$st-".($st+1);
my $stn = $st + (length $2) + (length $3);
my $nextKey = "$stn-".($stn + (length $4));
if (exists $phi{$nextKey}) {
if ((isType($nextKey, "Last Name", 0) == 0)) {
addType($nextKey, "Last Name (NamePattern1)");
addType($iniKey, "Initial (NamePattern1)");
addType($k,"First Name11 (Name Pattern1)");
}
}
else {
if ($following =~ /\A( +)([A-Za-z])(\.? )([A-Za-z][A-Za-z]+)\b\s*\Z/g){
addType ($nextKey, "Last Name (NamePattern1)");
addType($iniKey, "Initial (NamePattern1)");
addType($k,"First Name6 (NamePattern1)");
}
elsif (!(isCommonest($lastN))) {
addType ($nextKey, "Last Name (NamePattern1)");
addType($iniKey, "Initial (NamePattern1)");
addType($k,"First Name7 (NamePattern1)");
}
}
}
}
}
# Finds all last names (unambig), looks at proceeding word -> make first names unambigs
foreach $k (keys %phi) {
if (isType($k, "Last Name", 1) && (isType($k, "(un)", 1))) {
my ($start, $end) = split '-', $k;
my $preceding = substr $text, 0, $start;
if ($preceding =~ /\b([A-Za-z]+)( *)\Z/g) {
my $pword = $1;
my $st = length($`);
my $prevKey = "$st-".($st + (length $1));
if (exists $phi{$prevKey}) {
#my $result = isNameIndicator($pword);
#print "pword is $pword, isNameIndicator returns $result";
#if ((isType($prevKey, "First Name", 1)) && (!isType($prevKey, "Name Indicator", 0))) {
if ((isType($prevKey, "First Name", 1)) && (!isNameIndicator($pword)) ) {
addType($prevKey, "First Name8 (NamePattern2)");
} # Else it's been positively identified as something that is not a name so leave it
}
else {
# Sees whether it appears in the common words...
if (!(isCommon($pword))) {
addType ($prevKey, "First Name9 (NamePattern2)");
}
}
}
}
}
#****************************************************************************************
# Looks for compound last names -> last name + last name (ambig), last name + not-on-any-safe-word-list, last name "-" another word
# Last name with an ambiguous name preceding it has already labeled the preceding thing a first name; no huge loss if it's just a weird first part of a compound last name
foreach $k (keys %phi) {
if (isType($k, "Last Name", 0)) {
my ($start, $end) = split '-', $k;
my $following = substr $text, $end;
if ($following =~ /\A-([A-Za-z]+)\b/g) { #hypen-ated last name
my $newend = $end+length($1)+1;
my $nextKey = "$end-$newend";
addType ($nextKey, "Last Name (NamePattern3)");
}
if ($following =~ /\A( *)([A-Za-z]+)\b/g) {
my $fword = $2;
my $st = $end + (length $1);
my $nextKey = "$st-".($st + length($2));
if (exists $phi{$nextKey}) {
if (!(isType($nextKey, "ambig", 1))) {
if (isType($nextKey, "Last Name", 0) == 0) {
addType($nextKey, "Last Name (NamePattern3)");
}
} # Else it's been positively identified as something that is not a name so leaves it
}
else {
# Sees whether it appears in the common words
if (!(isCommon($fword))) {
addType ($nextKey, "Last Name (NamePattern3)");
}
}
}
}
}
#****************************************************************************************
# Looks for initials
# Many last names get classified as first names and other PHI -> looks for initial before all unambig names and locations
INI:
foreach $k (keys %phi) {
if ( ((!(isType($k, "ambig", 1))) || isType($k, "(un)",1)) && (isType($k, "Name", 1))) {
#if (isType($k, "Name", 1)) {
my ($start, $end) = split '-', $k;
my $preceding = substr $text, 0, $start;
# Checks for two initials
if ($preceding =~ /\b([A-Za-z][\. ] ?[A-Za-z]\.?) ?\Z/g) {
my $key = (length ($`))."-".(length($`) + (length $1));
addType ($key, "Initials (NamePattern4)");
if (!(isType($k, "Last Name", 0))) {
}
}
# Checks if preceding word is an initial
elsif ($preceding =~ /\b([A-Za-z]\.?) ?\Z/g) { #1 initial
my $tmp = substr $text, $start, $end - $start +1;
my $init = $1;
my $key = (length ($`))."-".(length($`) + (length $1));
if (lc($init) eq "s") {
if ((substr $preceding, (length($`) - 1), 1) eq "'") { #for 's
# next INI;
}
}
if ((lc($init) eq "a") || (lc($init) eq "i")) {
if (isCommon(substr $text, $start, ($end - $start))) {
# next INI;
}
}
if (length($init)==2 || length($init)==1) {
addType ($key, "Initials (NamePattern4)");
}
if (!(isType($k, "Last Name", 0))) {
addType ($k, "Last Name (NamePattern4)");
}
}
}
}
#****************************************************************************************
# Looks for initials; similar to previous code block
foreach $k (keys %phi) {
if (isType($k, "Last Name", 1) && (!isType ($k, "ambig", 1))) {
my ($start, $end) = split '-', $k;
my $preceding = substr $text, 0, $start;
#two initials (why would they write that? Why not?) {
if ($preceding =~ /\b([A-Za-z][\. ] ?[A-Za-z]\.?) ?\Z/g) {
my $key = (length ($`))."-".(length($`) + (length $1));
addType ($key, "Initials (NamePattern5)");
if (!(isType($k, "Last Name", 0))) {
addType ($k, "Last Name (NamePattern5)");
}
}
elsif ($preceding =~ /\b([A-Za-z]\.?) ?\Z/g) { #1 initial
my $init = $1;
my $key = (length ($`))."-".(length($`) + (length $1));
if (lc($init) eq "s") {
if ((substr $preceding, (length($`) - 1), 1) eq "'") { #for 's
#next INI;
}
}
if ((lc($init) eq "a") || (lc($init) eq "i")) {
if (isCommon(substr $text, $start, ($end - $start))) {
# next INI;
}
}
}
}
}
#****************************************************************************************
# Searches for patterns "name and/or," comma list names
foreach $k (keys %phi) {
if ((isType($k, "Last Name", 0)) || (isType($k, "Male First Name", 0)) || (isType($k, "Female First Name", 0))) {
my ($start, $end) = split '-', $k;
my $following = substr $text, $end;
if ((length $following) == 0) { next; }
# First just looks for "and"/"or"
if ($following =~ /\A and ([A-Za-z]+)\p{IsPunct}/ig) {
my $word = $text1;
my $key = ($end + 5)."-".($end + 5 + length($1));
if ((isType($key, "Name", 1)) || (!(isCommon($word)))) {
addType ($key, "Last Name (NamePattern6)");
}
}
elsif ($following =~ /\A and ([A-Za-z]+)\b/ig) {
my $word = $1;
my $key = ($end + 5)."-".($end + 5 + length($1));
if (!(isCommon($word))) {
addType ($key, "Last Name (NamePattern6)");
}
}
elsif ($following =~ /\A or ([A-Za-z]+)\b/ig) {
my $word = $1;
my $key = ($end + 4)."-".($end + 4 + length($1));
if (!(isCommon($word))) {
addType ($key, "Last Name (NamePattern6)");
}
}
elsif ($following =~ /\A( ?[\&\+] ?)([A-Za-z]+)\b/ig) {
my $word = $2;
my $st = $end + (length $1);
my $key = "$st-".($st + length($2));
if (!(isCommon($word))) {
addType ($key, "Last Name (NamePattern6)");
}
}
elsif ($following =~ /\A, ([A-Za-z]+)(,? and )([A-Za-z]+)\b/ig) {
# Searches up to 3 names in a list
my $name1 = $1;
my $name2 = $3;
my $st2 = $end + 2 + (length $name1) + length($2);
my $key1 = ($end + 2)."-".($end + 2 + (length $name1));
my $key2 = "$st2-".($st2 + length($name2));
if (!(isCommon($name1))) {
addType ($key1, "Last Name (NamePattern6)");
}
if (!(isCommon($name2))) {
addType ($key2, "Last Name (NamePattern6)");
}
}
}
}
}
}
# End of function name3()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: commonHoliday()
# Searches for some common holiday names that can identify the date
# Extension: Add new holiday names to this regex
sub commonHoliday() {
$text = $_[0];
if ($datefilter =~ /y/) {
while ($text =~ /\b(christmas|thanksgiving|easter|hannukah|rosh hashanah|ramadan)\b/ig) {
$holidayname = $1;
$start = length($`);
$end = $start + length($holidayname);
$key = $start."-".$end;
addType ($key, "Holiday");
}
}
}
# End of function commonHoliday()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: knownPatientName()
# Searches for PID-specific patient names known a priori, i.e. the patient first and last names for this particular PID
# Indiscriminately removes these PHI from anywhere in the text
# Extension: To include new PID-patient name mappings, extend the file $patient_file
sub knownPatientName {
$text = $_[0];
if ($namefilter =~ /y/) {
foreach $i (@known_first_name) {
while ($text =~ /\b($i)\b/ig) {
my $start = length($`);
my $end = $start + length($1);
my $key = "$start-$end";
addType ($key, "Known patient firstname");
}
}
foreach $j (@known_last_name) {
while ($text =~ /\b($j)\b/ig) {
my $start = length($`);
my $end = $start + length($1);
my $key = "$start-$end";
addType ($key, "Known patient lastname");
}
}
}
}
# End of function knownPatientName()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
#Returns true if the number passed in matches a defined us area code
sub isCommonAreaCode {
$areacode = $_[0];
return ($us_area_code{$areacode});
}
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: telephone()
# Searches for telephone numbers, with or without area codes, with or without extensions
# Extension: To add new formats, add a new rule
sub telephone() {
$text = $_[0];
if ($telfilter =~ /y/) {
while ($text =~ /\b\(?\d{3}\s*[ \-\.\/\=\,]*\s*\d{4}\)?\b/g) { #added back \b to avoid high fp
#while ($text =~ /\b\d{3}\s*[ \-\.\/\=\,]*\s*\d{4}\b/g) { #added back \b to avoid high fp
my $start = length($`);
my $end = $start + length($&);
my $nextSeg = substr $text, $end, 20;
#catch extensions
if ($nextSeg =~ /\A(\s*x\.?\s*[\(]?[\d]+[\)]?)\b/) {
$end += length($1);
} elsif ($nextSeg =~ /\A(\s*ext[\.]?\s*[\(]?[\d]+[\)]?)\b/) {
$end += length($1);
} elsif ($nextSeg =~ /\A(\s*extension\s*\(?[\d]+\)?)\b/) {
$end += length($1);
}
my $key = "$start-$end";
#now checks the context
$context_len = 20;
my $start_pos = $start - $context_len;
if ($start_pos < 0) {
$start_pos = 0;
}
my $len = $context_len;
if (length ($text) < ($end + $context_len)){
$len = length($text) - $end;
}
my $textBefore = substr $text, $start_pos, ($start - $start_pos);
my $textAfter = substr $text, $end, $len;
if (isProbablyPhone($textBefore)){
addType ($key, "Telephone/Fax (1)");
}
}
#pattern such as ###-###-####
#let's not worry about patterns such as ###-HART and ###-LUNG for now
#while ($text =~ /\(?\d{3}?\s?[\)\.\/\-\=\, ]*\s?\d{3}\s?[ \-\.\/\=]*\s?\d{4}\b/g) {
while ($text =~ /\d{3}\s*[\)\.\/\-\, ]*\s*\d{3}\s*[ \-\.\/]*\s*\d{4}/g) {
#if (isCommonAreaCode($1)){
my $st = length($`);
my $end = $st + length($&);
my $nextSeg = substr $text, $end, 20;
if ($nextSeg =~ /\A(\s*x\.?\s*[\(]?[\d]+[\)]?)\b/) {
$end += length($1);
} elsif ($nextSeg =~ /\A(\s*ex\.?\s*[\(]?[\d]+[\)]?)\b/) {
$end += length($1);
} elsif ($nextSeg =~ /\A([\,]?\s?ext[\.]?\s*[\(]?[\d]+[\)]?)\b/) {
$end += length($1);
} elsif ($nextSeg =~ /\b(\s?extension\s*\(?[\d]+\)?)\b/) {
$end += length($1);
}
my $key = "$st-$end";
addType ($key, "Telephone/Fax (2)");
}
#allow arbitrary line break (almost) anywhere in the phone numbers (except first 3 digit to reduce fp)
#only scrubbs the pattern, if it's a known area code
while ($text =~ /(\d\d\d)\s*[\)\.\/\-\, ]*\s*\d\s*\d\s*\d\s*[ \-\.\/]*\s*\d\s*\d\s*\d\s*\d/g) {
if (isCommonAreaCode($1)){
my $st = length($`);
my $end = $st + length($&);
my $nextSeg = substr $text, $end, 20;
if ($nextSeg =~ /\A(\s*x\.?\s*[\(]?[\d]+[\)]?)\b/) {
$end += length($1);
} elsif ($nextSeg =~ /\A(\s*ex\.?\s*[\(]?[\d]+[\)]?)\b/) {
$end += length($1);
} elsif ($nextSeg =~ /\A([\,]?\s?ext[\.]?\s*[\(]?[\d]+[\)]?)\b/) {
$end += length($1);
} elsif ($nextSeg =~ /\b(\s?extension\s*\(?[\d]+\)?)\b/) {
$end += length($1);
}
my $key = "$st-$end";
addType ($key, "Telephone/Fax (2)");
}
}
#check phone pattern that has 1 extra or 1 less digit at end
#in case pattern such as xxx-xxx-xxx?, check if the first 3 digits match with
#common area code
while (($text =~ /\(?(\d{3})\s*[\)\.\/\-\=\, ]*\s*\d{3}\s*[ \-\.\/\=]*\s*\d{3}\b/g)){
#match it with common local area code
if (isCommonAreaCode($1)){
my $st = length($`);
my $end = $st + length($&);
my $nextSeg = substr $text, $end, 20;
if ($nextSeg =~ /\A(\s*x\.?\s*[\(]?[\d]+[\)]?)\b/) {
$end += length($1);
} elsif ($nextSeg =~ /\A(\s*ex\.?\s*[\(]?[\d]+[\)]?)\b/) {
$end += length($1);
} elsif ($nextSeg =~ /\A(\s?ext[\.]?\s*[\(]?[\d]+[\)]?)\b/) {
$end += length($1);
} elsif ($nextSeg =~ /\A(\s?extension\s*\(?[\d]+\)?)\b/) {
$end += length($1);
}
my $key = "$st-$end";
addType ($key, "Telephone/Fax (3)");
} #end if the first 3 digits are area codes
} #end while
#check phone pattern that has 1 extra digit at end
#in case pattern such as xxx-xxx-xxxxx, check if the first 3 digits match with
#common area code
while (
($text =~ /\(?(\d{3})\s*[\)\.\/\-\=\, ]*\s*\d{3}\s*[ \-\.\/\=]*\s*\d{5}\b/g)) {
#match it with common local area code
if (isCommonAreaCode($1)){
my $st = length($`);
my $end = $st + length($&);
my $nextSeg = substr $text, $end, 20;
if ($nextSeg =~ /\A(\s*x\.?\s*[\(]?[\d]+[\)]?)\b/) {
$end += length($1);
} elsif ($nextSeg =~ /\A(\s*ex\.?\s*[\(]?[\d]+[\)]?)\b/) {
$end += length($1);
} elsif ($nextSeg =~ /\A(\s?ext[\.]?\s*[\(]?[\d]+[\)]?)\b/) {
$end += length($1);
} elsif ($nextSeg =~ /\A(\s?extension\s*\(?[\d]+\)?)\b/) {
$end += length($1);
}
my $key = "$st-$end";
addType ($key, "Telephone/Fax (4)");
} #end if the first 3 digits are area codes
} #end while
#in case typed in pattern such as ###-####-###
while ($text =~ /\(?\d{3}?\s?[\)\.\/\-\=\, ]*\s?\d{4}\s?[ \-\.\/\=]*\s?\d{3}\b/g) {
my $st = length($`);
my $end = $st + length($&);
my $nextSeg = substr $text, $end, 20;
if ($nextSeg =~ /\A(\s*x\.?\s*[\(]?[\d]+[\)]?)\b/) {
$end += length($1);
} elsif ($nextSeg =~ /\A(\s*ex\.?\s*[\(]?[\d]+[\)]?)\b/) {
$end += length($1);
}
elsif ($nextSeg =~ /\A(\s*ext[\.]?\s*[\(]?[\d]+[\)]?)\b/) {
$end += length($1);
} elsif ($nextSeg =~ /\A(\s*extension\s*\(?[\d]+\)?)\b/) {
$end += length($1);
}
my $key = "$st-$end";
addType ($key, "Telephone/Fax (5)");
}
}
}
# End of function telephone()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Add new function here >>>>>>>>>>
# Follow format shown here if necessary
# sub functionName {
# $text = $_[0];
# while ($text =~ /(<search pattern>)/) {
# $startIndex = length($');
# $endIndex = $startIndex + length($1);
# $phiKey = $startIndex."-".$endIndex;
# addType ($phiKey, "Name of PHI Category");
# }
# }
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: pruneKeys()
# Arguments: hash %keys, string $text
# Returns: array @keylst
# Called by: findPHI()
# Description: Extracts PHI locations from hash %keys, compares each loc with previous loc to prevent overlaps
# Returns an array of pruned PHI keys
sub pruneKeys {
my ($keyh,$text) = @_;
my $lk = "";
my ($ls,$le)=(0,0);
my ($cs,$ce)=(0,0);
my @keylst = ();
foreach $k (sort numerically keys %{$keyh}) {
#print "prunkey, key = $k values = \n";
$ls = $cs;
$le = $ce;
($cs,$ce)= split ('-',$k);
if ($cs > $le){push (@keylst,$lk);} # proper relation
elsif($cs > $ls){
if($ce > $le) {
my $stgl = substr($text,$ls,$le-$ls);
my $stgc = substr($text,$cs,$ce-$cs);
$cs = $ls; $k = "$ls-$ce"; $$keyh{$k} = $$keyh{$lk}} # include both transfer types
else{$cs = $ls; $ce = $le; $k = $lk;}} # use previous (current in previous)
elsif($le > $ce){$cs = $ls; $ce = $le; $k = $lk;} # use previous (current in previous)
$lk = $k;}
#print "pushing $lk to keylst\n";
push (@keylst,$lk); # last one
return (@keylst)
}
# End of pruneKeys()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: addType()
# Arguments: string $key ("start-end" of PHI loc), string $type (PHI type)
# Returns: None
# Called by: findPHI()
# Description: Pushes PHI key and type into the hash %phi
# Keeps track of all possible PHI types for each PHI key
sub addType {
my ($key,$type) = @_;
($st,$end) = split '-',$key;
if ($end > $end{$st}) {
$end{$st} = $end;
}
#print "in addType, key is $key\n";
push @{$phi{$key}}, $type;
$t = (@{$phiT{$key}});
$start = $st - 1 - 64;
$ending = $end - 1 - 64;
return;
}
# End of addType()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: isType()
# Arguments: string $key ("start-end" of PHI loc), string $type (PHI type), int $pattern (1 if PHI type can be matched with '=~'; 0 otherwise)
# Returns: 1 if PHI $key is of PHI type $type; 0 otherwise
# Called by: findPHI()
# Description: Given a PHI loc, checks its PHI type in the existing PHI hash. If the type in the hash is equal to the given type, then returns 1.
sub isType {
my ($key, $type, $pattern) = @_;
foreach $tt (@{$phi{$key}}){
# print "isType, tt is $tt key is $key\n";
if ($pattern) {
if ($tt =~ /$type/) {
return 1;
}
}
elsif ($tt eq $type) {
return 1;
}
}
return 0;
}
# End of isType()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: isPHIType()
# Arguments: string $mytype (PHI type), array of string @phiTypes
# Returns: 1 if PHI $mytype appears in @phiTypes, 0 otherwise.
# Called by: deid()
# Description: Given a PHI type, checks if it appears in @phiTypes, if so, returns 1. Returns 0 otherwise.
sub isPHIType {
my ( $mytype, @phiTypes) = @_;
#foreach $tt (@{$phi{$key}}){
foreach $tt (@phiTypes){
if ($tt =~ /$mytype/) {
return 1;
} #end if
} #end foreach
return 0;
}
# End of isPHIType()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: isCommon()
# Arguments: string $word
# Returns: 1 if given word is a common word; 0 otherwise
# Called by: findPHI()
# Description: Compares the given word to the common_words association, compiled from dictionary files for common English words and from SNOMED.
# Returns 1 if given word is in one of those lists, i.e. is a common word.
sub isCommon {
my $word = $_[0];
chomp $word;
$word = uc($word);
return ($common_words{$word} || $unambig_common_words{$word});
}
# End of isCommon()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: isUnambigCommon()
# Arguments: string $word
# Returns: 1 if given word is a really common word or unambig med terms; 0 otherwise
sub isUnambigCommon {
my $word = $_[0];
$word = uc($word);
return $unambig_common_words{$word};
}
# End of isUnambigCommon()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: isNameAmbig()
# Arguments: string $word
# Returns: 1 if given word is an ambiguous name
# Called by: findPHI()
# Description: Searches for given word in lists of ambiguous male, female and last names
# Returns 1 if word is in any of those lists
sub isNameAmbig {
my $word = $_[0];
$word = uc($word);
return (($male_ambig{$word}) || ($female_ambig{$word}) || ($last_ambig{$word}));
}
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
#Function: isProbablyName()
#Arguments: string $key, $potential_name
#Returns true if
#name is Not a common word OR
#name is Unambiguous name OR
#name maybe ambiguous BUT starts with Capital_letter followed by small_case letter OR
#name is popular
sub isProbablyName{
my ($key, $potential_name) = @_;
if ( (!isCommon($potential_name)) ||
((isType($key, "Name", 1) && isType($key, "(un)")) ||
(isType($key, "Name", 1) && ($potential_name =~ /\b(([A-Z])([a-z]+))\b/g)) ||
(isType($key, "popular",1)) )) {
return 1;
} else {
return 0;
}
}
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
#Function: isUSStateAbbre
#Data structure used for us states
#Returns true if the word is a US state abbreviation
sub isUSStateAbbre {
my $word = $_[0];
$word = uc($word);
foreach $loc (@us_states_abbre){
if ($word =~/\b$loc\b/gi){
return 1;
}
}
foreach $loc (@more_us_states_abbre){
if ($word =~/\b$loc\b/gi){
return 1;
}
}
return 0;
}
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
#Function: isNameIndicator
#Returns true if the word is a name indicator
sub isNameIndicator {
my $word = $_[0];
$word = uc($word);
foreach $nam (@name_indicators){
#print "nam in name indicators is $nam";
if ($word =~/\b$nam\b/gi){
return 1;
}
}
return 0;
}
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
#Function: isUSState
#Returns true if the word is a US State
sub isUSState {
my $word = $_[0];
$word = uc($word);
#return (($us_states{$word}));
foreach $loc (@us_states){
if ($word =~/\b$loc\b/gi){
return 1;
}
}
return 0;
}
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: isFirstName()
# Arguments: string $word
# Returns: 1 if given word is an ambiguous or unambiguous firstname
# Called by: findPHI()
sub isFirstName {
my $word = $_[0];
#$word = ($word);
$word = uc($word);
return (($male_ambig{$word}) || ($female_ambig{$word}) || ($male_unambig{$word}) || ($female_unambig{$word}) || ($male_popular{$word}) || ($female_popular{$word}));
}
# End of isFirstName()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: isCommonest()
# Arguments: string $word
# Returns: 1 if given word is a commonest word; 0 otherwise
# Called by: findPHI()
# Description: Compares the given word to the commonest_words association, compiled from dictionary file for commonest English words.
# Returns 1 if given word is in that list, i.e. is a commonest word.
sub isCommonest {
my $word = $_[0];
$word = uc($word);
return ($very_common_words{$word} || isUnambigCommon($word));
}
# End of isCommonest()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: getNote()
# Arguments: int $patient (patient number), int $note (note number)
# Returns: string $noteText
# Called by: deidStats() (obsolete)
# Description: Given patient and note numbers, looks up header in $header_file
# If it finds the header, extracts the body of the note, and returns text until the end pattern
sub getNote{
my ($patient, $note) = @_;
open DF, $data_file or die "Cannot open $data_file";
my $noteFound = 0;
my $noteText = "";
D:
# Parses the data file line-by-line to match the header found in the header file
while ($line = <DF>) {
chomp $line;
# If header is found in the text, then matches the end pattern, and sets the body of the note (excluding the header) as the note text
if ($line =~ /\b$patient\|\|\|\|$note\|\|\|\|/) {
$noteFound = 1;
$noteText = "";
}
else {
if ($noteFound) {
if ($line eq "||||END_OF_RECORD"){
#$noteText = $noteText."\n".$1;
#$noteText = $noteText.$1."\n";
$end = $2;
last D;
}
else {
$noteText = $noteText.$line."\n";
}
}
}
}
close DF;
# If the note text has zero length, prints an error message
if ((length $noteText) == 0) {
print("Warning. No text found for Patient $patient, Note $note ");
}
# Returns the body of the note (everything excluding the header) as the note text
return $noteText;
}
# End of getNote()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: isValidDate()
# Arguments: int $month, int $day, int $year (If the date being validated doesn't specify year, the "year" argument should be "-1")
# Returns: 1 if given date is valid based on the calendar
# Called by: findPHI(), isValidDay()
# Description: Verifies if the given date is valid or not.
sub isValidDate{
my ($month, $day, $year) = @_;
if (($year!=-1) && (length $year) == 2) {
#if ($year < 30) {
if ($year <= $TWO_DIGIT_YEAR_THRESHOLD) {
$year = "20".$year;
}
else {
$year = "19".$year;
}
}
#if (($year != -1) && ($year < 1900 || $year > 2030)){
#if (($year != -1) && ($year <= $VALID_YEAR_LOW || $year >= $VALID_YEAR_HIGH)){
if (($year != -1) && ($year < $VALID_YEAR_LOW || $year > $VALID_YEAR_HIGH)){
return 0;
}
# Invalid months and days
if (($month< 1) || ($month > 12) || ($day < 1) || ($day > 31)) {
return 0;
}
# Checks validity of February days
if ($month == 2) {
if (($year != -1) && (($year % 4) == 0) && ($year != 2000)) {
return ($day <= 29);
}
return ($day <= 28);
# Checks validity of months consisting of 30 days
}
elsif (($month == 4) || ($month == 6) || ($month== 9) || ($month == 11)) {
return ($day <= 30);
}
# Checks validity of months consisting of 31 days
return ($day <= 31);
}
# End of isValidDate()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: isValidDay()
# Arguments: int $day, string $month, int $year
# Returns: 1 if given date is valid; 0 otherwise
# Called by: findPHI()
# Description: Verifies validity of date when month is printed, by calling isValidDate()
sub isValidDay {
my ($day, $month, $year) = @_;
my $mnum = 0;
# Converts printed out months to numerical months
if ($month =~ /Jan|January|Januar/i) { $mnum = 1; }
elsif ($month =~ /Feb|February|Februar/i) { $mnum = 2; }
elsif ($month =~ /Mar|March|Maerz/i) { $mnum = 3; }
elsif ($month =~ /Apr|April/i) { $mnum = 4; }
elsif ($month =~ /May|Mai/i) { $mnum = 5; }
elsif ($month =~ /June|Jun|Juni/i) { $mnum = 6; }
elsif ($month =~ /July|Jul|Juli/i) { $mnum = 7; }
elsif ($month =~ /August|Aug/i) { $mnum = 8; }
elsif ($month =~ /September|Sept|Sep/i) { $mnum = 9; }
elsif ($month =~ /October|Oct/i) { $mnum = 10; }
elsif ($month =~ /November|Nov/i) { $mnum = 11; }
elsif ($month =~ /December|Dec/i) { $mnum = 12; }
if ($mnum == 0) { return 0; }
return (isValidDate($mnum, $day, $year));
}
# End of isValidDay()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: outputText()
# Arguments: hash %deids (key=PHI start index, value=PHI end index), hash %phiT (key=PHI start-end indices, value=PHI type)
# Returns: None
# Called by: deid()
# Description: Creates the de-identified version of the text
# Replaces dates with shifted dates, and other PHI with their PHI types
sub outputText {
my %deids = %{$_[0]};
my %phiT = %{$_[1]};
# These are the date and PID of the medical record. The year needs to be initialized.
# my $checkYear = "2005";
my $checkYear;
my $checkDate;
my $checkID;
# Forms associations between printed months and numerical ones
# This is because the date-shifting function only accepts numerical months, and months in the text can be non-numerical as well
my %months;
$months{"jan"} = 1;
$months{"feb"} = 2;
$months{"mar"} = 3;
$months{"apr"} = 4;
$months{"may"} = 5;
$months{"jun"} = 6;
$months{"jul"} = 7;
$months{"aug"} = 8;
$months{"sep"} = 9;
$months{"oct"} = 10;
$months{"nov"} = 11;
$months{"dec"} = 12;
#TF is the .res file (de-identified corpus), and OF is the (.phi file) list of PHIs
# open TF, ">$deid_text_file" or die "Cannot open $deid_text_file";
open TF, ">>$deid_text_file" or die "Cannot open $deid_text_file"; #now open in append mode
my $lastEnd = 0;
#open OF, ">>$output_file_old" or die "Cannot open $output_file_old";
my $phiType = "";
# Prints the PHI locations to the output file (.phi)
foreach $k (sort numerically keys %deids) {
my @deidsval = @{$deids{$k}};
local $added = 0;
my $phiID;
# Loops over each PHI recorded in %deids
# %deids maps each PHI start index to an array of 3 items
# These items are in order: the PHI end index, the PID of the PHI, the record date of the PHI
#if (exists ${@{$deids{$k}}}[0]) {
if (exists $deidsval[0]){
# Sets some key variables for the PHI
#the following no longer works with perl v5.10
#$deidsend = ${@{$deids{$k}}}[0]; # End index
#$checkID = ${@{$deids{$k}}}[1]; # PID
#$checkDate = ${@{$deids{$k}}}[2]; # Record date
$deidsend = $deidsval[0]; # End index
$checkID = $deidsval[1]; # PID
$checkDate = $deidsval[2]; # Record date
$checkYear = (substr $checkDate, 6, 4); # Record year
if (length($checkYear) ==0) {
$checkYear = extractYear($DEFAULT_DATE);
print "Warning, in outputText(), cannot extract year from noteDate, setting year to default year $checkYear.";
}
# Immediately prints the start and end indices of the PHI to the .phi file
#print OF "$k\t$deidsend\n";
# Sets the $key to the current PHI
my $key = $k."-".$deidsend;
my $lastlast = $lastEnd;
my $phiText;
# If this PHI is a date element, shifts the date and replaces it in the text
# Output format is YYYY/MM/DD always
# For month/date formats, assumes that year = record year; for month/year formats, assumes that day = 1
# Needs to go over %phiT for every PHI in %deids
# %phiT maps each PHI key to its type, e.g. "Mary" -> "First Name"
# This part is necessary because re-identification depends on the PHI's type
foreach $ky (sort numerically keys %phiT) {
my $ky = $ky;
($startp, $endp) = split "-", $ky;
$notAmbig = 0;
# Checks to see if PHI type matches any of the date patterns
# Each PHI may have more than one listed type, e.g. First Name AND Last Name
# For each PHI type listed for the specific PHI
foreach $t (@{$phiT{$ky}}) {
$datephi1 = "Year/Month/Day"; # e.g. 1999/2/23
$datephi2 = "Year/Day/Month"; # e.g. 1999/23/2, note: pattern currently not filtered in sub date()!
$datephi3 = "Month/Day/Year"; # e.g. 2/23/1999
$datephi5 = "Day/Month/Year"; # 23/2/1999, note: pattern currently not filtered in sub date()!
$datephi4 = "Month/Day"; # e.g. 2/23, using record year as year
$datephi6 = "Day/Month"; # e.g. 23/2, using record current year as year, note: pattern currently not filtered in sub date()!
$datephi7 = "Month/Year"; # e.g. 2/1999, using 1 as day
$datephi8 = "Year/Month"; # e.g. 1999/2, using 1 as day
$datephi9 = "Day Month Year"; # e.g. 23 february 1999
$datephi10 = "Month Day Year"; # e.g. feb 23 1999 or feb. 23rd 1999
$datephi11 = "Month Day"; # e.g. feb 23, using record year as year
$datephi12 = "Day Month"; # e.g. 23 february, using record year as year
$datephi13 = "Month Year"; # e.g. feb 1999, or february of 1999 or feb. 1999, using 1 as day
$datephi14 = "Header Date"; # not important
$datephi15 = "4 digits"; # 4-digit year, e.g. 1999
$datephi16 = "2 digits"; # 2-digit year, e.g. '99
$datephi17 = "Day Month Year 2"; # e.g. 23rd february 1999
#if ($ky =~/$key/) {$phiType = $t;}
if ($ky eq $key) {$phiType = $t;}
# Calls the date-shifting function alterdate() with a date argument appropriate for the date pattern
# This is because alterdate() accepts an argument of a fixed date pattern
# Prints the resulting shifted date in deid_text_file (.res)
# If the current PHI has not been output to the .res file yet, checks if PHI type is date
# Shifts the date and writes the shifted date to TF (.res file)
if ($added == 0) {
#if (($t =~ /$datephi1/) && ($ky=~/$key/)){
if (($t =~ /$datephi1/) && ($ky eq $key)){
$date = (substr $allText, $k, ($deidsend-$k));
$date =~ s/\-/\//g;
$date =~ s/\./\//g;
$altereddate = &alterdate($date, $checkID);
$date =~ /(\d+)(.)(\d+)(.)(\d+)/;
$longyear = $1;
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."[**$altereddate**]";
$added = 1;
$lastEnd = $deidsend;
}
elsif (($t =~ /$datephi17/) && ($ky eq $key)){
$date = (substr $allText, $k, ($deidsend-$k));
$date =~ /\b(((\d{1,2})(|st|nd|rd|th|)?\s+(of\s)?[\-]?\b([A-Za-z]+)\.?,?)\s+(\d{2,4}))\b/ig; # 12-Apr, or Second of April
$mon = $6;
$day = $3;
$year = $7;
foreach $m (sort keys %months) {
if ($mon =~ /$m/ig) {
$month = $months{$m};
}
}
$date = "$year/$month/$day";
$altereddate = &alterdate($date, $checkID );
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."[**$altereddate**]";
$added = 1;
$lastEnd = $deidsend;
}
#elsif (($t =~ /$datephi9/) && ($ky=~/$key/)){
elsif (($t =~ /$datephi9/) && ($ky eq $key)){
$date = (substr $allText, $k, ($deidsend-$k));
$date =~ /(\d+) ([A-Za-z]+)\,? (\d+)/;
$mon = $2;
$day = $1;
$year = $3;
foreach $m (sort keys %months) {
if ($mon =~ /$m/ig) {
$month = $months{$m};
}
}
$date = "$year/$month/$day";
$longyear = $5;
$altereddate = &alterdate($date, $checkID );
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."[**$altereddate**]";
#local $added = 1;
$added = 1;
$lastEnd = $deidsend;
}
#elsif (($t =~ /$datephi10/) && ($ky=~/$key/)){
elsif (($t =~ /$datephi10/) && ($ky eq $key)){
$date = (substr $allText, $k, ($deidsend-$k));
$date =~ /\b(([A-Za-z]+)\b\.?,? ?(\d{1,2})(|st|nd|rd|th|)? ?[\,\s]+ *\'?(\d{2,4}))\b/ig;
$mon = $2;
$day = $3;
$year = $5;
#$date =~ /([A-Za-z]+) (\d+)\,? (\d+)/;
#$mon = $1;
#$day = $2;
#$year = $3;
#print "DatePHI10: Before date shift: month= $mon, day = $day , year = $year \n";
foreach $m (sort keys %months) {
if ($mon =~ /$m/ig) {
$month = $months{$m};
}
}
$date = "$year/$month/$day";
$altereddate = &alterdate($date, $checkID);
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."[**$altereddate**]";
#local $added = 1;
$added = 1;
$lastEnd = $deidsend;
}
#elsif (($t =~ /$datephi2/) && ($ky=~/$key/)){
elsif (($t =~ /$datephi2/) && ($ky eq $key)){
$date = (substr $allText, $k, ($deidsend-$k));
$date =~ /(\d+)(.)(\d+)(.)(\d+)/;
$date = "$1/$5/$3";
$longyear = $1;
$altereddate = &alterdate($date, $checkID);
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."[**$altereddate**]";
#local $added = 1;
$added = 1;
$lastEnd = $deidsend;
}
#elsif (($t =~ /$datephi3/) && ($ky=~/$key/)){
elsif (($t =~ /$datephi3/) && ($ky eq $key)){
$date = (substr $allText, $k, ($deidsend-$k));
$date =~ /(\d+)(.)(\d+)(.)(\d+)/;
$date = "$5/$1/$3";
$altereddate = &alterdate($date, $checkID);
$longyear = $5;
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."[**$altereddate**]";
$added = 1;
$lastEnd = $deidsend;
}
#elsif (($t =~ /$datephi5/) && ($ky=~/$key/)){
elsif (($t =~ /$datephi5/) && ($ky eq $key)){
$date = (substr $allText, $k, ($deidsend-$k));
$date =~ /(\d+)(.)(\d+)(.)(\d+)/;
$date = "$5/$3/$1";
$altereddate = &alterdate($date, $checkID );
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."[**$altereddate**]";
$longyear = $5;
$added = 1;
$lastEnd = $deidsend;
}
#elsif (($t =~ /$datephi4/) && ($ky=~/$key/)){
elsif (($t =~ /$datephi4/) && ($ky eq $key)){
$date = (substr $allText, $k, ($deidsend-$k));
$date =~ s/\-/\//g;
$date = "$checkYear/$date";
$altereddate = &alterdate($date, $checkID);
$altereddate = (substr $altereddate, 5, (length($altereddate)-5));
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."[**$altereddate**]";
$added = 1;
$lastEnd = $deidsend;
}
#elsif (($t =~ /$datephi11/) && ($ky=~/$key/)){
elsif (($t =~ /$datephi11/) && ($ky eq $key)){
$date = (substr $allText, $k, ($deidsend-$k));
#$date =~ /([A-Za-z]+) (\d+)/;
#$mon = $1;
#$day = $2;
$date =~ /\b(([A-Za-z]+)\b\.?,?\s*(\d{1,2})(|st|nd|rd|th|)?)\b/ig; # Apr. 12
$mon = $2;
$day = $3;
foreach $m (sort keys %months) {
if ($mon =~ /$m/ig) {
$month = $months{$m};
}
}
$date = "$checkYear/$month/$day";
$altereddate = &alterdate($date, $checkID);
$altereddate = substr($altereddate, 5, (length($altereddate)-5));
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."[**$altereddate**]";
$added = 1;
$lastEnd = $deidsend;
}
#elsif (($t =~ /$datephi6/) && ($ky=~/$key/)){
elsif (($t =~ /$datephi6/) && ($ky eq $key)){
$date = (substr $allText, $k, ($deidsend-$k));
$date =~ /(\d+)(.)(\d+)/;
#print "DatePHI6: date is $date, 3 is $3, 1 is $1\n";
$date = "$3/$1";
$date = "$checkYear/$date";
$altereddate = &alterdate($date, $checkID);
$altereddate = substr($altereddate, 5, (length($altereddate)-5));
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."[**$altereddate**]";
$added = 1;
$lastEnd = $deidsend;
}
#elsif (($t =~ /$datephi12/) && ($ky=~/$key/)){
elsif (($t =~ /$datephi12/) && ($ky eq $key)){
$date = (substr $allText, $k, ($deidsend-$k));
#$date =~ /(\d+) ([A-Za-z]+)/;
#$mon = $2;
#$day = $1;
$date =~ /\b((\d{1,2})(|st|nd|rd|th|)?( of)?[ \-]\b([A-Za-z]+))\b/ig;
$mon = $5;
$day = $2;
#print "month is $month, day is $day\n";
foreach $m (sort keys %months) {
if ($mon =~ /$m/ig) {
$month = $months{$m};
}
}
$date = "$checkYear/$month/$day";
$altereddate = &alterdate($date, $checkID);
$altereddate = substr($altereddate, 5, (length($altereddate)-5));
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."[**$altereddate**]";
$added = 1;
$lastEnd = $deidsend;
}
#elsif (($t =~ /$datephi13/) && ($ky=~/$key/)){
elsif (($t =~ /$datephi13/) && ($ky eq $key)){
$date = (substr $allText, $k, ($deidsend-$k));
$date =~ /([A-Za-z]+)(\.)?(\s+)(of\s+)?(\d+)/ig;
$mon = $1;
$year = $5;
foreach $m (sort keys %months) {
if ($mon =~ /$m/ig) {
$month = $months{$m};
}
}
$date = "$year/$month/1";
$longyear = $3;
$altereddate = &alterdate($date, $checkID );
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."[**$altereddate**]";
$added = 1;
$lastEnd = $deidsend;
}
#elsif (($t =~ /$datephi7/) && ($ky=~/$key/)){
elsif (($t =~ /$datephi7/) && ($ky eq $key)){
$date = (substr $allText, $k, ($deidsend-$k));
$date =~ /(\d+)(.)(\d+)/;
$date = $3.'/'.$1.'/1';
$altereddate = &alterdate($date, $checkID);
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."[**$altereddate**]";
$longyear = $3;
$added = 1;
$lastEnd = $deidsend;
}
#elsif (($t =~ /$datephi8/) && ($ky=~/$key/)){
elsif (($t =~ /$datephi8/) && ($ky eq $key)){
$date = (substr $allText, $k, ($deidsend-$k));
$date =~ /(\d+)(.)(\d+)/;
$date = $1.'/'.$3.'/1';
$altereddate = &alterdate($date, $checkID);
$longyear = $1;
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."[**$altereddate**]";
$added = 1;
$lastEnd = $deidsend;
}
#elsif (($t =~ /$datephi14/) && ($ky=~/$key/)) {
elsif (($t =~ /$datephi14/) && ($ky eq $key)) {
$date = (substr $allText, $k, ($deidsend-$k));
$date =~ /(\d+)(\-)(\d+)(\-)(\d+)/;
$date = $1.'/'.$3.'/'.$5;
$altereddate = &alterdate($date, $checkID);
$longyear = $1;
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."$date";
$added = 1;
$lastEnd = $deidsend;
}
#elsif (($t =~ /$datephi15/) && ($ky=~/$key/)) {
elsif (($t =~ /$datephi15/) && ($ky eq $key)) {
$year = (substr $allText, $k, ($deidsend-$k));
$date = $year.'/1/1';
$altereddate = &alterdate($date, $checkID);
$alteredyear = (substr $altereddate, 0, 4);
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."[**$alteredyear**]";
$added = 1;
$lastEnd = $deidsend;
}
#elsif (($t =~ /$datephi16/) && ($ky=~/$key/)) {
elsif (($t =~ /$datephi16/) && ($ky eq $key)) {
$year = (substr $allText, $k, ($deidsend-$k));
#if ($year > 20) {
# $year = '19'.$year;
#} else {
# #$year = '20.'.$year;
# $year = '20'.$year;
# }
$date = $year.'/1/1';
$altereddate = &alterdate($date, $checkID);
$alteredyear = (substr $altereddate, 2, 2);
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."[**$alteredyear**]";
$added = 1;
$lastEnd = $deidsend;
}
# If the current PHI is not a date, then indicates that it has not been output yet
else { my $added = 0;}
}
}
}
# If the PHI is not a date, replaces it in deid_text_file (.res) by its PHI type tag
if ($added==0) {
if ($k > $lastEnd || ($k==0)) {
$phiText = (substr $allText, $k, ($deidsend-$k));
# Parentheses are eliminated so that they do not trip up the run
$phiText =~ s/\(//g;
$phiText =~ s/\)//g;
$phiText =~ s/\+//g;
$found = 0;
# Assigns a unique ID to each PHI, e.g. all instances of "Mary" may be assigned "1", but "John" may be assigned "2"
# %ID maps each PHI (e.g. "Mary") to its ID (e.g. "1")
foreach $phik (keys %ID) {
if ($phik =~/$phiText/ig) {
$found = 1;
}
}
# If the current PHI to be added to .res file is already recorded in %ID, then retrieves its unique ID
if ($found==1) {
$phiID = $ID{$phiText};
}
# If the current PHI is not recorded in %ID, records it in %ID and assigns the PHI a unique ID
else {
$ID{$phiText} = keys(%ID) + 1;
$phiID = $ID{$phiText};
}
# Prints the PHI type and PHI ID in place of the original PHI in the .res file
print TF (substr $allText, $lastEnd, ($k - $lastEnd))."[**$phiType $phiID**]";
$lastEnd = $deidsend;
}
else {
if ($lastEnd < $deidsend) {
$lastEnd = $deidsend;
}
}
if ($lastEnd == 0) {
$lastEnd = $lastlast;
}
}
}
}
#close OF;
#print "Finished outputing to the .phi file.";
# Prints the remaining non-PHI text to the .res file
print TF (substr $allText, $lastEnd);
#print "finished outputing to the .res file";
close TF;
}
# End of outputText()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: alterdate()
# Arguments: string $date (yyyy/mm/dd), int $pid (patient ID)
# Returns: string $year-$month-$day
# Called by: outputText()
# Description: Converts given date to shifted date, depending on date-shift-mode, by calling doalterdate().
# Returns shifted date
sub alterdate {
# Separates date fields by splitting along "/" or "-"
# Then calls doalterdate on the resulting array of date elements
$d = $_[0];
if (substr($d,0,6) =~ /(\/)/) {
@d = split '/', $d;
}
elsif (substr($d,0,6) =~ /(\-)/) {
@d = split '-', $d;
}
($entryyear, $entrymonth)=@d[0..1];
return join "-", &doalterdate(@d, $_[1]);
}
# End of alterdate()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: doalterdate()
# Arguments: int $year, int $month, int $day, int $pid (patient ID)
# Returns: array @($year, $month, $day)
# Called by: alterdate()
# Description: Converts given date, depending on date-shift-mode, to shifted date.
# Returns shifted date in an array format to calling function alterdate(). alterdate() converts the shifted date to a string.
sub doalterdate {
my $year=$_[0];
if (length $year == 2) {
# Limits 2-digit years between 1900 and 2020
# Converts them to 4-digit years
#if ($year<=10) {$year = 2000+$year;}
#if ($year<=20) {$year = 2000+$year;}
if ($year<=$TWO_DIGIT_YEAR_THRESHOLD) {$year = 2000+$year;}
else {$year = 1900+$year;}
}
my $month=$_[1];
my $day=$_[2];
my $pid=$_[3];
if ($pid_dateshift_list =~ /y/) {
open SF, $date_shift_file or die "Cannot open $date_shift_file";
while ($line = <SF>) {
chomp $line;
if ($line =~ /\A($pid)\|\|\|\|([0-9\-]+)/) {
$offset = $2;
}
}
close SF;
}
my $ml=&monthlength($month, $year);
# $offset = days of offset (positive or negative shift)
# Sets the shifted year
$offset_local = $offset;
if ($offset_local>0) {
$year += 4*int($offset_local/1461);
$offset_local -=1461*int($offset_local/1461);
}
if ($offset_local<0){
$year -= 4*int(-$offset_local/1461);
$offset_local +=1461*int(-$offset_local/1461);
}
# Shifts number of days
$day +=$offset_local;
$ml=&monthlength($month, $year);
# Changes $day, $month, $year based on the remaining offset after shifting $year
while ($day>$ml) {
$ml=&monthlength($month, $year);
$day=$day-$ml;
$month++;
if ($month>12) {
$month -=12;
$year++;
}
$ml = &monthlength($month, $year);
}
while ($day<1) {
$ml=&monthlength($month-1, $year);
$day=$day + $ml;
$month--;
if ($month<1) {
$month +=12;
$year--;
}
}
# Formats the output of single-digit month and day: "2" becomes "02"
if (length($month)<2) {
$month="0".$month;
}
if (length($day)<2) {
$day="0".$day;
}
# Returns the shifted date as an array
return ($year, $month, $day);
}
# End of doalterdate()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: altermonthdate()
# Arguments: int $month, int $day, int $pid (patient ID)
# Returns: call doalterdate(), returns array ($year, $month, $day)
# Called by: None
# Description: Calls doalterdate() which performs dateshift
# This function is not used
sub altermonthdate {
my ($month, $day, $pid)=@_;
my $year;
if (($month-$entrymonth)%12<6) {
if ($month<$entrymonth) {
$year=$entryyear+1;
}
else {
$year=$entryyear;
}
}
else {
if ($month>$entrymonth) {
$year=$entryyear-1;
}
else {
$year=$entryear;
}
}
return (&doalterdate($year, $month, $day, $pid))[1,2];
}
# End of altermonthdate()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: getcentury()
# Arguments: int 2-digit $year
# Returns: int
# Called by: None
# Description: Converts a 2-digit year into a 4-digit year based on entryyear
# This function is not used
sub getcentury {
my $year=$_[0];
if (($year-$entryyear)%100<10) {
$year=$entryyear+(($year-$entryyear)%100);
}
else {
$year=$entryyear-(($entryyear-$year)%100);
}
}
# End of getcentury()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: monthlength()
# Arguments: int $m, int $y
# Returns: int
# Called by: doalterdate()
# Description: Returns the number of days in given month-year
sub monthlength {
my($m, $y)=@_;
while ($m<=0) {
$m += 12;
$y --;
}
while ($m>=13) {
$m -= 12;
$y ++;
}
# Checks for February
if ($m==2) {
if ($y % 4 ==0) {
if($y % 100 ==0) {
if ($y % 400 ==0){
return 29;
}
else {
return 28;
}
}
else {
return 29;
}
}
else {
return 28;
}
}
# Checks for months consisting of 30 days
elsif (($m==4) || ($m==6) || ($m==9) || ($m==11)) {
return 30;
}
# Checks for months consisting of 31 days
else {
return 31;
}
}
# End of monthlength()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Application-specific code follows. Code may contain patterns specific to our medical notes.
# Customize by replacing with your application-specific filters.
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
#Function: isProbablyPhone
#Argument: context string
#Returns: Always returns 1 (true) unless the context is one of the words defined in
#phone_pre_disqualifier. For future extensions, can add qualifier words
#such as "phone", "pager", etc.
sub isProbablyPhone {
@phone_pre_disqualifier = ("HR","Heart", "BP", "SVR", "STV", "VT", "Tidal Volumes", "Tidal Volume", "TV", "CKS");
$context = $_[0];
foreach $i (@phone_pre_disqualifier) {
if ($context =~ /\b$i\b/i){
return 0;
}
}
return 1;
}
#end of isProbablyPhone()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# Function: wardname()
# Argument: string
# Searches for ward names specific to our hospital
sub wardname() {
$text = $_[0];
#Added to catch gs specific wardnames
if ($gs_specific_filter =~ /y/){
@ward_indicators = ("Quartermain");
foreach $ward_ind (@ward_indicators){
while ($text =~ /\b(($ward_ind) ?(\d))\b/ig){
$wardname = $1;
$start = length($`);
$end = $start + length($wardname);
$key = $start."-".$end;
addType ($key, "Wardname");
}
}
}
}
# End of function wardname()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
#Function: isProbablyMeasurement
#Argument: context string
#Returns: Returns true if the text passed in contains (more specifically, ends with) any of the measurement indicators.
sub isProbablyMeasurement {
@measurement_indicators_pre = ("increased to","decreased from","rose to","fell from", "down to",
"increased from", "dropped to", "dec to", "changed to","remains on", "change to");
$context = $_[0];
foreach $i (@measurement_indicators_pre) {
if ($context =~ /\b$i\b/i){ #only match if it ends with the phrase
return 1;
}
}
return 0;
}
#end isProbablyMeasurement()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
#Function: isProbablyDate
#Argument: textBefore string and textAfter string
#Returns: returns 1 if the context check determines that textBefore or textAfter
#are most likely strings preceding or following a date PHI; returns 0 otherwise.
#Description: Subroutine performs a context check on the textBefore and textAfter. If it contains one of the
#keywords (see below) that indicates it's probably not a date, then return false; otherwise return true.
#Called by dateWithContextCheck on partial dates MM-DD
sub isProbablyDate{
my ($textBefore, $textAfter) = @_;
if ((!isProbablyMeasurement($textBefore)) && ($textBefore !~ /\b(drop|up|cc|dose|doses|range|ranged|pad|rate|bipap|pap|unload|ventilation|scale|cultures|blood|at|up|with|in|of|RR|ICP|CVP|strength|PSV|SVP|PCWP|PCW|BILAT|SRR|VENT|PEEP\/PS|flowby|drinks|stage) ?\Z/i) && ($textAfter !~ /\A ?(packs|litres|puffs|mls|liters|L|pts|patients|range|psv|scale|beers|per|esophagus|tabs|tablets|systolic|sem|strength|hours|pts|times|drop|up|cc|mg|\/hr|\/hour|mcg|ug|mm|PEEP|hr|hrs|hour|hours|bottles|bpm|ICP|CPAP|years|days|weeks|min|mins|minutes|seconds|months|mons|cm|mm|m|sessions|visits|episodes|drops|breaths|wbcs|beat|beats|ns|units|amp|qd|chest pain|intensity)\b/i)) {
return 1;
}
return 0;
}
#end isProbablyDate()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
#Function: isProbablyDate2
#Argument: textBefore string and textAfter string
#Returns: returns 1 if the context check determines that textBefore or textAfter
#are most likely strings preceding or following a date PHI; returns 0 otherwise.
#Subroutine performs a context check on the textBefore and textAfter. If it contains one of the
#keywords (see below) that indicates it's probably not a date, then return false; otherwise return true.
#Called by dateWithContextCheck on partial dates MM/DD.
sub isProbablyDate2{
if ( (!isProbablyMeasurement($textBefore)) && ($textBefore !~ /\b(drop|up|cc|range|ranged|pad|rate|rating|bipap|pap|unload|ventilation|scale|blood|at|up|with|RR|ICP|CVP|strength|PSV|SVP|PCWP|BILAT|SRR|VENT|PEEP\/PS|flowby) ?\Z/i) && ($textAfter !~ /\A ?(packs|litres|puffs|mls|liters|L|pts|patients|range|psv|scale|drinks|beers|per|esophagus|tabs|tab|tablet|tablets|systolic|sem|strength|hours|pts|times|drop|up|cc|mg|\/hr|\/hour|mcg|ug|mm|hr|hrs|hour|hours|bottles|bpm|ICP|CPAP|years|days|weeks|min|mins|minutes|seconds|months|mons|cm|mm|m|sessions|visits|drops|breaths|wbcs|beat|beats|ns|units|amp)\b/i)) {
return 1;
}
return 0;
}
#end isProbablyDate2()
#***********************************************************************************************************
#***********************************************************************************************************
#Function: extractYear
#Argument: a date string in the format MM/DD/YYYY
#Returns: the 4-digit year if the date is in the correct format
#returns 0000 otherwise.
sub extractYear{
$date = $_[0];
if ($date =~ /\b(\d\d)\/(\d\d)\/(\d\d\d\d)\b/){
$year = $3;
} else{
$year = 0000;
}
return $year;
}
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
#Function: dateWithContextCheck
#Argument: text string
#Returns: none
#Description: Find date patterns. Performs context check on text before and after the date patterns
#to determine if its an actual date.
sub dateWithContextCheck{
#$text = $_[0];
my ($text, $date) = @_;
my $year = extractYear($date);
#my $year = substr $date, 0, 4;
#**********************************************************************************************
# Searches for numerical date formats
# Checks if dates should be filtered
if ($datefilter =~ /y/) {
# Searches for mm/dd or mm/yy
while ($text =~ /\b([A-Za-z0-9%\/]+ +)?(\d\d?)([\/\-])(\d\d?)\/?\/?( +[A-Za-z]+)?\b/g) {
$pre = $1;
$post = $5;
my $first_num = $2;
my $divider = $3;
my $second_num = $4;
my $postdate = $5;
my $startI = length($`) + length($pre);
my $endI = $startI + length($first_num)+length($divider)+length($second_num);
my $key = $startI."-".$endI;
my $beginr = substr $text, ($startI - 2), 2;
my $endr = substr $text, $endI, 2;
#Excludes nn/nn formats when preceded by any in array @prev
#@prev = ("cvp", "noc", "peep/ps","%");
@prev = ("cvp", "noc", "%", "RR", "PCW");
my $dateorno = 1;
foreach $j (@prev) {
if ((!($pre =~ /\b$j/ig)) && (!($post =~ /\bpersantine\b/ig))) {
}
else {
$dateorno = 0;
}
}
my $context_len = 12; #number of characters we extract before the date
if ($dateorno == 1) {
if (($beginr !~ /\d[\/\.\-]/) && ($endr !~ /\A[\%]/) && ($endr !~ /\S\d/)) {
# Checks if date identified is valid as mm/dd; then adds the date as PHI
if (isValidDate ($first_num, $second_num, -1)) {
if ($second_num == 5) {
my $start_pos = $startI - $context_len;
if ($start_pos < 0) {
$start_pos = 0;
}
my $len = $context_len;
if (length($text) < ($endI + $context_len)){
$len = length($text) - $endI;
}
my $textBefore = substr $text, $start_pos, ($startI - $start_pos);
my $textAfter = substr $text, $endI, $len;
if ( (!isProbablyMeasurement($textBefore)) && ($textBefore !~ /\bPSV? \Z/i) && ($textBefore !~ /\b(CPAP|PS|range|bipap|pap|pad|rate|unload|ventilation|scale|strength|drop|up|cc|rr|cvp|at|up|in|with|ICP|PSV|of) \Z/i) && ($textAfter !~ /\A ?(packs|psv|puffs|pts|patients|range|scale|mls|liters|litres|drinks|beers|per|esophagus|tabs|pts|tablets|systolic|sem|strength|times|bottles|drop|drops|up|cc|mg|\/hr|\/hour|mcg|ug|mm|PEEP|L|hr|hrs|hour|hours|dose|doses|cultures|blood|bpm|ICP|CPAP|years|days|weeks|min|mins|minutes|seconds|months|mons|cm|mm|m|sessions|visits|episodes|drops|breaths|wbcs|beat|beats|ns)\b/i)) {
addType ($key, "Month/Day (1)");
}
} elsif ($second_num == 2) {
my $start_pos = $startI - $context_len;
if ($start_pos < 0) {
$start_pos = 0;
}
my $len = $context_len;
if (length ($text) < ($endI + $context_len)){
$len = length($text) - $endI;
}
my $textBefore = substr $text, $start_pos, ($startI - $start_pos);
my $textAfter = substr $text, $endI, $len;
if ( (!isProbablyMeasurement($textBefore)) && ($textAfter !~ /\A ?hour\b/i) && ($textBefore !~ /\b(with|drop|bipap|pap|range|pad|rate|unload|ventilation|scale|strength|up|cc|rr|cvp|at|up|with|in|ICP|PSV|of) \Z/i) && ($textAfter !~ /\A ?hr\b/i) && ($textAfter !~ /\A ?(packs|L|psv|puffs|pts|patients|range|scale|dose|doses|cultures|blood|mls|liters|litres|pts|drinks|beers|per|esophagus|tabs|tablets|systolic|sem|strength|bottles|times|drop|cc|up|mg|\/hr|\/hour|mcg|ug|mm|PEEP|hr|hrs|hour|hours|bpm|ICP|CPAP|years|days|weeks|min|mins|minutes|seconds|months|mons|cm|mm|m|sessions|visits|episodes|drops|breaths|wbcs|beat|beats|ns)\b/i)) {
addType ($key, "Month/Day (2)");
}
#} elsif (($divider eq "-") && ($startI > 4)) {
} elsif (($divider eq "-")) {
my $start_pos = $startI - $context_len;
if ($start_pos < 0) {
$start_pos = 0;
}
my $len = $context_len;
if (length ($text) < ($endI + $context_len)){
$len = length($text) - $endI;
}
my $textBefore = substr $text, $start_pos, ($startI - $start_pos);
my $textAfter = substr $text, $endI, $len;
if (isProbablyDate($textBefore, $textAfter)){
addType ($key, "Month/Day (3)");
}
}
else {
my $start_pos = $startI - $context_len;
if ($start_pos < 0) {
$start_pos = 0;
}
my $len = $context_len;
if (length ($text) < ($endI + $context_len)){
$len = length($text) - $endI;
}
my $textAfter = substr $text, $endI, $len;
my $textBefore = substr $text, $start_pos, ($startI - $start_pos);
if (isProbablyDate($textBefore, $textAfter)){
addType ($key, "Month/Day (4)");
}
}
}
# Checks if date identified is valid as mm/yy; then adds the date as PHI
# Checks for years of length 2, restricted to 1950-2030
if (($first_num <= 12) && ($first_num > 0) && ((length $second_num) == 2)
&& (($second_num>=50) || ($second_num<=30))) {
#my $textAfter = substr $text, $endI, 9;
my $start_pos = $startI - $context_len;
if ($start_pos < 0) {
$start_pos = 0;
}
my $len = $context_len;
if (length ($text) < ($endI + $context_len)){
$len = length($text) - $endI;
}
my $textAfter = substr $text, $endI, $len;
my $textBefore = substr $text, $start_pos, ($startI - $start_pos);
# print "checking mm/yy text before is $textBefore, text after is $textAfter\n";
if (isProbablyDate($textBefore, $textAfter)){
addType ($key, "Month/Year (2)");
}
} #end if the first num and second num are month/year
}
} #end if dateno ==1
} #end while the pattern match
} # end if datefilter is on
}
#end dateWithContextCheck()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
#Function: yearWithContextCheck
#Argument: text string
#Returns: none
#Description: Find date patterns. Performs context check on text before and after the year patterns
#to determine if it is a year.
sub yearWithContextCheck {
#$text = $_[0];
my ($text, $date) = @_;
#my $year = substr $date, 0, 4;
my $year = extractYear($date);
# Checks for 2-digit year written as '01, &c, only when preceded by the following medical terms
while ($text =~ /\b((embolus|mi|mvr|REDO|pacer|ablation|cabg|avr|x2|x3|CHOLECYSTECTOMY|cva|ca|PTC|PTCA|stent|since|surgery|year) + *(\')?)(\d\d)\b/ig) {
my $num = $1;
#print "2-digit date, 1 is $1, 2 is $2, 3 is $3, 4 is $4, 5 is $5\n";
#my $key = (1 + (length($`))+length($1))."-".(pos $text);
my $startd = (length($`))+length($1);
my $endd = $startd + length($4);
my $key = $startd."-".$endd;
#check if the match is part of number followed by decimal point and a number
my $textAfter = substr $text, $endd, 2;
if ($textAfter !~ /\.\d/){
addType($key, "Year (2 digits)");
}
}
while ($text =~ /\b((embolus|mi|mvr|REDO|pacer|ablation|cabg|avr|x2|x3|CHOLECYSTECTOMY|cva|ca|PTCA|since|surgery|year)(\'+))(\d\d)\b/ig) {
my $num = $1;
my $startd = (length($`))+length($1);
my $endd = $startd + length($4);
my $key = $startd."-".$endd;
#check if the match is part of number followed by decimal point and a number
#or if it is a time (HH:MM)
my $textAfter = substr $text, $endd, 2;
if ($textAfter !~ /(\.|\:)\d/){
addType($key, "Year (2 digits)");
}
}
# Checks for 4-digit year written as 2001, &c, only when preceded by the following medical terms
while ($text =~ /\b((embolus|mi|mvr|REDO|pacer|ablation|cabg|x2|x3|CHOLECYSTECTOMY|cva|ca|in|PTCA|since|from|year) + *)(\d{4})((\,? )\d{4})?\b/ig) {
my $num1 = $1;
$s1 = length($`) + length($1);
$e1 = $s1+length($3);
$s2 = $e1+length($5);
$e2 = $e1+length($4);
$k1 = "$s1-$e1";
$k2 = "$s2-$e2";
#for 4-digit year, check if the matched number is in the range of [$VALID_YEAR_LOW,$VALID_YEAR_HIGH]
#if ($3 <= 2030 && $3 >= 1950){
if ($3 <= $VALID_YEAR_HIGH && $3 >= $VALID_YEAR_LOW){
addType($k1, "Year (4 digits)");
addType($k2, "Year (4 digits)");
}
}
# Looks for year only (esp Patient Medical History): looks for year numbers within the 30 years before
# and 2 years after the date passed in as an argument.
# for $n (($year - 30) .. $year) {
for $n (($year - 30) .. ($year+2)) {
my $short = substr $n, 2, 2;
if ($n =~ /\d\d\d\d/) {
while ($text =~ /\b((embolus|mi|mvr|REDO|pacer|ablation|cabg|x2|x3|CHOLECYSTECTOMY|cva|ca|in|PTCA|since|from|year) + *)$n\b/ig) {
my $key = (length($`)+length($1))."-".(pos $text);
addType ($key, "Year (4 digits)");
}}
if ($short =~ /\d\d/) {
#while ($text =~ /\b((embolus|mi|mvr|REDO|pacer|ablation|cabg|x2|x3|CHOLECYSTECTOMY|cva|ca|PTCA|since|from|year) + *(\'?))$short\b/ig) {
while ($text =~ /\b((embolus|mi|mvr|REDO|pacer|ablation|cabg|x2|x3|CHOLECYSTECTOMY|cva|ca|PTCA|since|year) + *(\'?))$short\b/ig) {
my $key = (length($`)+length($1))."-".(pos $text);
addType ($key, "Year (2 digits)");
}}
if ($short =~ /\d\d/) {
# while ($text =~ /\b((embolus|mi|mvr|REDO|pacer|ablation|cabg|x2|x3|CHOLECYSTECTOMY|cva|ca|PTCA|since|from|year)(\'+))$short\b/ig) {
while ($text =~ /\b((embolus|mi|mvr|REDO|pacer|ablation|cabg|x2|x3|CHOLECYSTECTOMY|cva|ca|PTCA|since|year)(\'+))$short\b/ig) {
my $key = (length($`)+length($1))."-".(pos $text);
addType ($key, "Year (2 digits)");
}}
}
}
#end yearWithContextCheck()
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************
# End of De-Identification Algorithm
#***********************************************************************************************************
#***********************************************************************************************************
#***********************************************************************************************************