forked from HeatherARobinson/EHR-data-processing
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathSIR create medication data table
221 lines (185 loc) · 11.6 KB
/
SIR create medication data table
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
load("sir.data.Rdata") #Full EHR extract
load("crea.rep.rda") #Primary table with 1 row per patient per date summarising the maximum creatinine value per day
inst<-read.csv("inst051217.csv") #Lookup regex file of unique textual precription instructions paired with implications for dose, number etc
codes1<-read.csv("SIRdrugs.csv") #Lookup of medication type, family, active ingredient etc
library(stringr)
library(lubridate)
library(plyr)
library(dplyr)
library(tidyr)
#Subset extract if required to enable faster processing
sir.data<-sir.data[sir.data$EntryDate>=20070101&sir.data$EntryDate<=20170901,]
sir.data<-sir.data[(sir.data$ReadCode %in% codes1$CODE & sir.data$PatientID %in% crea.rep$PatientID),]
#Coerce date fields to date format if needed
sir.data$EntryDate<-as.Date(as.character(sir.data$EntryDate),format="%Y%m%d")
inst$DESCRIPTION<-gsub('[[:punct:]]','',inst$DESCRIPTION) #REMOVE PUNCTUATION
sir.data$CodeUnits<-gsub('[[:punct:]]','',sir.data$CodeUnits) #REMOVE PUNCTUATION
inst$DESCRIPTION<-tolower(inst$DESCRIPTION) #LOWER CASE
sir.data$CodeUnits<-tolower(sir.data$CodeUnits)
#REMOVE ANY DUPLICATE PRECRIPTION ENTRIES
sub<-sir.data[,c("PatientID","ReadCode","CodeValue","CodeUnits","EntryDate"),]
sub <- unique(sub)
colnames(sub)[colnames(sub) == 'CodeUnits'] <- 'DESCRIPTION' #ENSURE FIELD NAMES MATCH BETWEEN TABLES
crea.rep <- unique(crea.rep)
#REPLACE WRITTEN NUMBERS WITH NUMBERS 1-6 IN PATIENT DATA (here already complete in instruction data lookup)
sub$DESCRIPTION<-gsub("one", "1", sub$DESCRIPTION)
sub$DESCRIPTION<-gsub("two", "2", sub$DESCRIPTION)
sub$DESCRIPTION<-gsub("three", "3", sub$DESCRIPTION)
sub$DESCRIPTION<-gsub("four", "4", sub$DESCRIPTION)
sub$DESCRIPTION<-gsub("five", "5", sub$DESCRIPTION)
sub$DESCRIPTION<-gsub("six", "6", sub$DESCRIPTION)
sub$DESCRIPTION<-tolower(sub$DESCRIPTION)#LOWER CASE
sub$DESCRIPTION<-gsub(" ", "", sub$DESCRIPTION, fixed = TRUE) #REMOVE SPACES FROM INSTRUCTION STRINGS (This step already taken in instruction data lookup)
inst<-inst[!duplicated(inst$DESCRIPTION),] #MAKE SURE NO DUPLICATE LINES IN THE LOOKUP TABLE THAT CAN LEAD TO NAs IN THE FINAL TABLE
#############################################################################################################
#JOIN THE INSTRUCTIONS AND RELATED FIELDS ONTO THE MAIN FILE
sub$DESCRIPTION<-gsub("#", "", sub$DESCRIPTION)
sub$DESCRIPTION<-gsub(",", "", sub$DESCRIPTION)
sub$DESCRIPTION<-gsub(":", "", sub$DESCRIPTION)
sub$DESCRIPTION<-gsub("[.]", "", sub$DESCRIPTION)
library(stringr)
sub$DESCRIPTION<-str_replace(sub$DESCRIPTION, "(ip.*)", "")
sub$DESCRIPTION<-gsub("[(]", "", sub$DESCRIPTION)
sub$DESCRIPTION<-gsub("[)]", "", sub$DESCRIPTION)
inst$DESCRIPTION<-gsub("[)]", "", inst$DESCRIPTION)
inst$DESCRIPTION<-gsub("[(]", "", inst$DESCRIPTION)
ESS<-unique(sub$DESCRIPTION[!sub$DESCRIPTION %in% inst$DESCRIPTION])
write.csv(ESS,file="EXTRADESCS.csv") #OUTPUT ANY NON PARSING DESCRIPTIONS. ADD TO THE REGEX TABLE, ANNOTATE AND RERUN.
##################################################################################
#MARK PRESCRIPTIONS WHICH ARE INTENDED TO BE EXTRA TABLETS TO ADD TO AN EXISTING DOSE OF THE SAME DRUG.
EX<-sub$DESCRIPTION[grep("extra",sub$DESCRIPTION)]
AD<-sub$DESCRIPTION[grep("additionto",sub$DESCRIPTION)]
AD2<-sub$DESCRIPTION[grep("additional",sub$DESCRIPTION)]
sub$EXTRA<-ifelse(sub$DESCRIPTION %in% AD | sub$DESCRIPTION %in% AD2 |sub$DESCRIPTION %in% EX,1,0)
#'EXTRA' MARKS PRESCRIPTIONS THAT ARE ADDITIONS OF MORE TO THE SAME DRUG,
#OFTEN SUPPLEMENTING BOXED MEDICATION (E.G. 'TAKE AN EXTRA TABLET EVERY MORNING WITH THE ONE IN YOUR VENALINK').
#############################################################################
#QUANTIFY MISSING PRESCRIPTION DATA
sub<-merge(sub,inst,all.x=TRUE)
head(sub)
length(sub$DESCRIPTION[sub$DESCRIPTION==""])
colnames(sub)[colnames(sub) == 'ReadCode'] <- 'CODE' #RENAME FIELDS IF NEEDED FOR LATER MERGING
#JOIN ON DOSAGE DATA
subs<-merge(sub[sub$CODE %in% codes1$CODE,],codes1,all.x=TRUE) #Add ReadCode dosage information
###########################################################################
#CALCULATE MISSING DATA WHERE POSSIBLE BASED ON PRESENT FIELDS
subs$DAILY_DOSE<-as.numeric(subs$DAILY_DOSE)
subs$DOSE_PER_TAB<-as.numeric(subs$DOSE_PER_TAB)
subs$TABLETS_PER_DAY<-as.numeric(subs$TABLETS_PER_DAY)
subs$DAILY_DOSE<-ifelse(is.na(subs$DAILY_DOSE)&!is.na(subs$TABLETS_PER_DAY),subs$TABLETS_PER_DAY*subs$DOSE_PER_TAB,subs$DAILY_DOSE)
subs$TABLETS_PER_DAY<-ifelse(is.na(subs$TABLETS_PER_DAY)&!is.na(subs$DAILY_DOSE)&!is.na(subs$DOSE_PER_TAB),subs$DAILY_DOSE/subs$DOSE_PER_TAB,subs$TABLETS_PER_DAY)
summary(subs$EntryDate[is.na(subs$DAILY_DOSE)]) #All dose information is complete after 2013 but not before.
#FIND THE MEDIAN DOSE FOR EACH DRUG AND USE THIS IF MISSING
b<-subs[,c("DAILY_DOSE","TYPE")]
b<-na.omit(b)
b$DAILY_DOSE<-as.numeric(b$DAILY_DOSE)
b2<-b %>% group_by(TYPE) %>% summarise(MEDIAN_DOSE = median(DAILY_DOSE, na.rm = TRUE)) %>% as.data.frame
subs<-merge(subs,b2,all.x=TRUE)
subs$DAILY_DOSE<-ifelse(is.na(subs$DAILY_DOSE),subs$MEDIAN_DOSE,subs$DAILY_DOSE)
############################################################################
#DIVIDE INTO MULTIPLE ROWS IF THE DOSE CHANGES OVER TIME
#THIS CODE OVERWRITES SO BE CAREFUL TO GO BACK TO THE INITIAL CONSTRUCTION OF SUBS IF YOU WANT TO RUN IT AGAIN TO AVOID REPETITIVELY CREATING NEW ROWS.
#THEN should contain the number of dose changes (i.e. the number of extra rows you need, so most rows should equal zero.)
#DEFINE THOSE PRESCRIPTINS WITH PROGRESSIVE DOSING
library(splitstackshape)
subs$THEN<-ifelse(is.na(subs$THEN),0,subs$THEN)
subs$THEN<-as.numeric(subs$THEN)
expandRows(subs, "THEN") #Create a copied row for each changing dosage
subt<-subs[subs$THEN>0,]
head(subt)
subnt<-subs[subs$THEN<1,]
############################################################################
#EDIT THE DOSES FOR THE REPLICATE ROWS (FOLLOWING DOSE CHANGE)
subt$DAILY_DOSE<-ifelse(duplicated(subt$PatientID)&duplicated(subt$EntryDate)&duplicated(subt$TYPE),subt$DOSE2,subt$DAILY_DOSE)
subt$TABLETS_PER_DAY<-ifelse(duplicated(subt$PatientID)&duplicated(subt$EntryDate)&duplicated(subt$TYPE),as.numeric(as.character(subt$NUM2)),subt$TABLETS_PER_DAY)
subt$n<-(subt$TABLETS_PER_DAY*as.numeric(subt$DAYS))
subt$C1<-ifelse((duplicated(subt$PatientID)&duplicated(subt$EntryDate)&duplicated(subt$TYPE)),1,0)
subt$CodeValue<-ifelse(subt$C1==1,as.integer(as.numeric(as.character(subt$CodeValue))-as.numeric(as.character(subt$n))),paste(subt$CodeValue))#For the second entry, recalculate the prescription minus what was used up whilst on the original dosage
subt$EntryDateb<-ifelse(subt$C1==1,subt$EntryDate+subt$DAYS,subt$EntryDate)
subt$EntryDate<-as.Date(subt$EntryDateb,origin=(subt$EntryDate[1]-subt$EntryDateb[1]))
subt<-subt[,c(1:19,21)]
subnt<-subnt[,c(1:19,21)]
meddata<-rbind(subt,subnt)
############################################################################
#ASSIGN DATE OF END OF PRESCRIPTION
m<-(as.numeric(meddata$CodeValue)/as.numeric(meddata$TABLETS_PER_DAY))
meddata$END_DATE<-ifelse(!is.na(meddata$TABLETS_PER_DAY)&!is.na(subs$CodeValue),meddata$EntryDate+as.difftime(m, unit="days"),NA)
meddata$END_DATE<-as.Date(meddata$END_DATE,origin="1970-01-01")
head(meddata)
save(meddata,file="PERMITmeddata28.rda")
############################################################################
#STOP INSTRUCTIONS- THOSE WITH STOP INSTRUCTIONS FOR OTHER DRUGS HAVE ENTRIES IN THE ALT_OTHER_MEDS COLUMN
load("PERMITmeddata28.rda")
meddata<-unique(meddata)
meddata$REP<-ifelse(meddata$REP=="Same",paste(meddata$TYPE),paste(meddata$REP))
meddata$REP<-as.factor(meddata$REP)
head(meddata$REP2[!meddata$REP2 %in% meddata$REP])#ALL THOSE IN REP2 ARE ALSO IN REP
r<-paste(unique(meddata$REP))
meddata$REP<-ifelse(meddata$REP %in% r & !is.na(meddata$REP),paste(meddata$REP),NA)
meddata$REP2<-ifelse(meddata$REP2 %in% r& !is.na(meddata$REP2),paste(meddata$REP2),NA) #STOP CODES MAY BE RESTRICTED TO DRUGS NOT OF INTEREST TO US, CHECK IF PROCESSING NEEDED
table(meddata$REP)
table(meddata$REP2)#SOME STOPS MAY REFERG TO MORE THAN ONE MEDICATION
meddata$ALT_OTHER_MEDS<-ifelse(is.na(meddata$REP),NA,meddata$ALT_OTHER_MEDS)
###################################################################################
#NEAREST DATE MATCH TO THE LAST PRIOR ENTRY OF THE DRUG BEING STOPPED
coda<-meddata[!is.na(meddata$REP),]
stops<-meddata[meddata$TYPE %in% meddata$REP,c("PatientID","EntryDate","END_DATE","TYPE")]
columns=names(stops[c(1,2,4)])
dots<-lapply(columns, as.symbol)
first <-stops %>%
group_by_(.dots=dots) %>%
as.data.frame
library(survival)
first$NEWENDDATE<-NA
for (i in 1:length(unique(first$TYPE))){
codab<-coda[coda$REP==first$TYPE[i],]
indx<-neardate(first$PatientID, codab$PatientID, first$EntryDate,codab$EntryDate,best="after")
first$NEWENDDATE<-(ifelse(first$TYPE==first$TYPE[i],codab[indx,"EntryDate"],first$NEWENDDATE))
}
first$NEWENDDATE<-as.Date(first$NEWENDDATE,origin="1970-01-01")
head(first[!is.na(first$NEWENDDATE),])
first<-first[!is.na(first$NEWENDDATE)&first$NEWENDDATE>first$EntryDate&first$NEWENDDATE<first$END_DATE,c("PatientID","EntryDate","END_DATE","TYPE","NEWENDDATE")]
length(first$PatientID)#50 prescriptions are affected
meddata<-merge(meddata,first,all.x=TRUE)
meddata$END_DATE<-ifelse(!is.na(meddata$NEWENDDATE)&meddata$END_DATE>meddata$NEWENDDATE&meddata$EntryDate<meddata$NEWENDDATE,meddata$NEWENDDATE,meddata$END_DATE)
meddata$END_DATE<-as.Date(meddata$END_DATE,origin="1970-01-01")
save(meddata,file="PERMITmeddata28.rda")
####################################################################################
#DEAL WITH 'EXTRAS'
ex<-meddata[meddata$EXTRA==1,]
subx<-meddata[meddata$EXTRA==0,]
ex<-ex[ex$TYPE %in% subx$TYPE & ex$PatientID %in% subx$PatientID & ex$EntryDate>=subx$EntryDate & ex$END_DATE<subx$END_DATE,]
ex[!is.na(ex$TYPE),] #2 specific entries are impacted
#head(subx)
#smalltab<-ex[,c("PatientID","TYPE","EntryDate","END_DATE","DAILY_DOSE")]
#columns=names(smalltab[c(1:3)])
#dots<-lapply(columns, as.symbol)
#firstU <-smalltab %>%
#group_by_(.dots=dots) %>%
#as.data.frame
#firstU$AddDate<-NA
#firstU$AddDose<-NA
#for (i in 1:unique(as.factor(firstU$TYPE))){
#exb<-ex[ex$TYPE==firstU$TYPE[i],]
#indx<-neardate(firstU$PatientID, subx$PatientID, firstU$EntryDate,subx$EntryDate,best="after")
#firstU$AddDate<-(ifelse(firstU$TYPE==firstU$TYPE[i],subx[indx,"EntryDate"],firstU$AddDate))
#firstU$AddDose<-(ifelse(firstU$TYPE==firstU$TYPE[i],subx[indx,"DAILY_DOSE"],firstU$AddDose))
#}
#firstU$AddDate<-as.Date(firstU$AddDate,origin="1970-01-01")
#head(firstU[!is.na(firstU$AddDate),])
#firstU<-firstU[!is.na(firstU$AddDate)&firstU$AddDate>=firstU$EntryDate&firstU$AddDate<firstU$END_DATE,c("PatientID","EntryDate","END_DATE","TYPE","AddDate","AddDose")]
#length(firstU$PatientID)#1252 prescriptions are affected
#names(firstU)
#####################################################################
#CONVERT VOLUME DOSAGES FOR LIQUID MEDS. OMIT WATER TO AVOID PICKING UP SOLID DOSE MEDS INSTRUCTED TO BE DISSOLVED IN WATER.
meddata$CodeValue<-ifelse(grepl("ml",meddata$DESCRIPTION)&!grepl("water",meddata$DESCRIPTION),as.numeric(meddata$CodeValue)/5,as.numeric(meddata$CodeValue))
meddata<-unique(meddata)
meddata$DAILY_DOSE<-signif(meddata$DAILY_DOSE,digits=2)
meddata$FAMILY<-ifelse(meddata$TYPE=="Doxycycline",paste("Antimicrobial"),paste(meddata$FAMILY))
meddata$FAMILY<-ifelse(meddata$TYPE=="Chloretracycline",paste("Chlortetracycline"),paste(meddata$FAMILY))
meddata$EntryDate<-as.Date(meddata$EntryDate,format="%d/%m/%Y")
meddata$END_DATE<-as.Date(meddata$END_DATE,format="%d/%m/%Y")
#Correct any analagous types
meddata$TYPE<-ifelse(meddata$TYPE=="Hydrochlorothiazide",paste("Hydrochlorthiazide"),paste(meddata$TYPE))
meddata$TYPE<-ifelse(meddata$TYPE=="Trandopril",paste("Trandolapril"),paste(meddata$TYPE))
save(meddata,file="PERMITmeddata28.rda")