Overstay Predictor Project Algorithm
The following is the algorithm as implemented to generate the Overstay colour as of 09:55, 2017 July 19 (CDT); this will change soon as we step away from using the DPST form, at which point only the parts for the red/yellow will remain.
Option Compare Database
Option Explicit
' colours used on viewer to direct collector action
Public Const overstay_green = 2537789
Public Const overstay_yellow = 648439
Public Const overstay_red = 206
Public Const overstay_gray = -2147483633
' logistic regression coefficients etc
'2013-03-20 was Const Log_Reg_threshold = 0.23 'threshold determines how many come through, .23 provided by Leigh Anne
'2013-05-30 changed Const Log_Reg_threshold back from 0.4 to 0.23 as requested by Linda
Const Log_Reg_threshold = 0.23
Const L_c_age = 0.0584403
Const L_c_OutsideWpg = -1.702245
Const L_c_mb = 1.921782
Const L_c_mi = -0.2284896
Const L_c_Pulmonary = -0.1948701
Const L_c_Connective = 0.1682782
Const L_c_Renal = -0.1862202
Const L_c_bath = 0.1889576
Const L_c_dress = 0.1591606
Const L_c_toilet = 0.2145833
Const L_c_transfer = 0.1756111
Const L_c_continence = 0.1526968
Const L_c_Dementia_AdCo = 0.8951998
Const L_c_eye = 0.5605131
Const L_c_verb = -0.3018936
Const L_c_adlmean_nh = -0.0875967
Const L_c_adlmean_age = -0.0012927
Const L_c_charlson_nh = -0.106952
Const L_c_cons = -11.23138
Public Function Transition_Coordinator_colour(Pat_ID As Long) As Long
On Error GoTo Err_goto
Dim colour As String
Dim DOB As Date
Dim admit As Date
Dim age As Double
Dim bath As Integer
Dim dress As Integer
Dim toilet As Integer
Dim transfer As Integer
Dim continence As Integer
Dim mi As Integer
Dim Pulmonary As Integer
Dim Connective As Integer
Dim Renal As Integer
Dim Dementia_AdCo As Integer
Dim feeding As Integer 'needed as part of SCORE
Dim adlscore As Integer
Dim ADL_center As Integer
Dim ADL_center_sqr As Integer
Dim OutsideWpg As Integer
Dim mb As Integer
Dim eye As Integer
Dim verb As Integer
Dim adlmean_nh As Integer
Dim Adlmean_age As Integer
Dim Charlson_nh As Integer
Dim from_PCH As Boolean
Dim NFE As String
Dim pt_from_PCH As String
' if patient is transferred, msg so and be done with
If Not IsNull(DLookup("Pat_ID", "L_TmpV2", "Pat_ID = " & Form_View.Pat_ID & " and Project = ""Overstay"" and Item = ""Transferred form""")) Then
Transition_Coordinator_colour = overstay_gray
MsgBox "Patient transferred in from other unit, you should not update the sticker colour."
GoTo Exit_sub
End If
' if Nursing Discharge Screen Tool indicated no discharge trouble make green be done with
NFE = NurseFormEval(Form_View.Pat_ID)
If NFE = "green" Then 'i.e. if "red" or "undefined", keep checking.
Transition_Coordinator_colour = overstay_green
GoTo Got_Colour
Else
If NFE = "undefined" Then
Transition_Coordinator_colour = overstay_gray
GoTo Got_Colour
End If
End If ' if "red" keep checking, pt can become red or yellow
' populate variables
DOB = CDate(Nz(Form_View.Birth, #1/1/1800#))
admit = Nz(Form_View.Accept_DtTm, Nz(Form_View.Arrive_DtTm, #1/1/1800#))
If DOB = #1/1/1800# Or admit = #1/1/1800# Then
MsgBox "can't evaluate overstay algorithm without DOB and Admit Date."
Transition_Coordinator_colour = overstay_gray
GoTo Exit_sub
End If
age = (admit - DOB) / 365.25
'MsgBox "confirming that age is integer, part of comments sent to Leigh Anne"
If age < 10 Or age > 107 Then
MsgBox "Age is <10 or >107, not allowed, check admit date and DOB."
Transition_Coordinator_colour = overstay_gray
GoTo Got_Colour
End If
bath = adl_sc(Nz(Form_View.ADL_Bathing))
dress = adl_sc(Nz(Form_View.ADL_Dressing))
toilet = adl_sc(Nz(Form_View.ADL_Toileting))
transfer = adl_sc(Nz(Form_View.ADL_Transfering))
continence = adl_sc(Nz(Form_View.ADL_Continence))
feeding = adl_sc(Nz(Form_View.ADL_Feeding))
If bath < 0 Or dress < 0 Or toilet < 0 Or transfer < 0 Or continence < 0 Or feeding < 0 Then
MsgBox "Can't evaluate overstay algorithm without ADLs."
Transition_Coordinator_colour = overstay_gray
GoTo Exit_sub
End If
adlscore = feeding + bath + dress + toilet + transfer + continence
pt_from_PCH = pt_is_from_PCH(Form_View.Pat_ID)
If InStr(pt_from_PCH, "undefined") > 0 Then
Transition_Coordinator_colour = overstay_gray
GoTo Exit_sub
End If
from_PCH = (pt_from_PCH = "yes")
'OutsideWpg
'OutsideWpg = transferred in from a facility outside of Winnipeg
' Julie wrote: OutsideWpg=(fromhosp in ('X','Y'));
'OutsideWpg = -1 * (Mid(Form_View.R_AdmitFrom, 1, 1) = "x" Or Mid(Form_View.R_AdmitFrom, 1, 1) = "y")
OutsideWpg = -1 * (Not IsNull(DLookup("Pat_ID", "check_from_out_of_town", "Pat_ID = " & Form_View.Pat_ID)))
If IsNull(Form_View.R_Province) Then
MsgBox "No ""Province"" entry found. Please enter and re-evaluate if this is not a Manitoba patient. (see http://ccmdb.kuality.ca/index.php/Overstay_Predictor_Project_Collection_Instructions)"
Transition_Coordinator_colour = overstay_gray
GoTo Exit_sub
End If
mb = ((Form_View.R_Province = "MB") * -1)
If IsNull(Form_View.Ap_Eye) Or IsNull(Form_View.Ap_Verbal) Then
MsgBox "Can't evaluate overstay algorithm without Glasgow Coma Scale."
Transition_Coordinator_colour = overstay_gray
GoTo Exit_sub
Else
eye = GCS_Eye_pts(Form_View.Ap_Eye)
verb = GCS_Verbal_pts(Form_View.Ap_Verbal)
End If
adlmean_nh = adlmean_nh_function(adlscore, from_PCH)
Adlmean_age = adlmean_age_function(adlscore, age)
Charlson_nh = Charlson_nh_function(Form_View.Pat_ID, Charlson_score_function(Form_View.Pat_ID), from_PCH)
mi = IIf(DCount("Charlson_category", "s_tmp_overstay_c_mi", "Pat_ID = " & Pat_ID) > 0, 1, 0)
Pulmonary = IIf(DCount("Charlson_category", "s_tmp_overstay_c_mi", "Pat_ID = " & Pat_ID) > 0, 1, 0)
Connective = IIf(DCount("Charlson_category", "s_tmp_overstay_c_mi", "Pat_ID = " & Pat_ID) > 0, 1, 0)
Renal = IIf(DCount("Charlson_category", "s_tmp_overstay_c_mi", "Pat_ID = " & Pat_ID) > 0, 1, 0)
' Dementia_AdCo = has either admit or comorbid dementia dx
Dementia_AdCo = -1 * (Nz(DLookup("Pat_ID", "s_tmp_overstay_Dementia_adm_como", "Pat_ID = " & Form_View.Pat_ID), 0) > 0)
' if none of above have kicked out of function, then make sure we have data to eval the rest
If bath = -1 Then
MsgBox "can't evaluate overstay algorithm without ADL bath."
Transition_Coordinator_colour = overstay_gray
GoTo Exit_sub
End If
If dress = -1 Then
MsgBox "can't evaluate overstay algorithm without ADL dressing."
Transition_Coordinator_colour = overstay_gray
GoTo Exit_sub
End If
If toilet = -1 Then
MsgBox "can't evaluate overstay algorithm without ADL toilet."
Transition_Coordinator_colour = overstay_gray
GoTo Exit_sub
End If
If transfer = -1 Then
MsgBox "can't evaluate overstay algorithm without ADL transfer."
Transition_Coordinator_colour = overstay_gray
GoTo Exit_sub
End If
If continence = -1 Then
MsgBox "can't evaluate overstay algorithm without ADL continence."
Transition_Coordinator_colour = overstay_gray
GoTo Exit_sub
End If
If feeding = -1 Then
MsgBox "can't evaluate overstay algorithm without ADL feeding."
Transition_Coordinator_colour = overstay_gray
GoTo Exit_sub
End If
Dim LRS As Double
LRS = Log_reg_shafer(age, OutsideWpg, mb, mi, Pulmonary, Connective, Renal, _
bath, dress, toilet, transfer, continence, _
Dementia_AdCo, eye, verb, adlmean_nh, Adlmean_age, Charlson_nh)
'evaluate whether patient will be yellow or red
If LRS > Log_Reg_threshold Then
Transition_Coordinator_colour = overstay_red
Else
Transition_Coordinator_colour = overstay_yellow
End If
Got_Colour:
colour = ""
If Transition_Coordinator_colour = overstay_red Then colour = "red"
If Transition_Coordinator_colour = overstay_yellow Then colour = "yellow"
If Transition_Coordinator_colour = overstay_green Then colour = "green"
If colour > "" Then
If MsgBox("Is this the final colour you want to actually send?", vbYesNo) = vbYes Then
GenerUpdate_tmp_entry Form_View.Pat_ID, "Overstay_autoentry", "Overstay_Colour", True, , , , , , , , colour
' add colour to beginning of notes field
Form_View.Dirty = False
Form_View.Notes = colour & "-" & Form_View.Notes
End If
End If
Exit_sub:
Exit Function
Err_goto:
MsgBox Err.Description
Resume Exit_sub
End Function
Public Function Log_reg_shafer(ByVal age As Double, OutsideWpg As Integer, ByVal mb As Integer, ByVal mi As Integer, ByVal Pulmonary As Integer, ByVal Connective As Integer, ByVal Renal As Integer, ByVal _
bath As Integer, ByVal dress As Integer, ByVal toilet As Integer, ByVal transfer As Integer, ByVal continence As Integer, ByVal _
Dementia_AdCo As Integer, ByVal eye As Integer, ByVal verb As Integer, ByVal adlmean_nh As Integer, ByVal Adlmean_age As Integer, ByVal Charlson_nh As Integer) As Double
On Error GoTo Err_goto
Dim sum, probability As Double
sum = _
L_c_cons + _
L_c_age * age + _
L_c_OutsideWpg * OutsideWpg + _
L_c_mb * mb + _
L_c_mi * mi + _
L_c_Pulmonary * Pulmonary + _
L_c_Connective * Connective + _
L_c_Renal * Renal + _
L_c_bath * bath + _
L_c_dress * dress + _
L_c_toilet * toilet + _
L_c_transfer * transfer + _
L_c_continence * continence + _
L_c_Dementia_AdCo * Dementia_AdCo + _
L_c_eye * eye + _
L_c_verb * verb + _
L_c_adlmean_nh * adlmean_nh + _
L_c_adlmean_age * Adlmean_age + _
L_c_charlson_nh * Charlson_nh
probability = Exp(sum) / (1 + Exp(sum))
Log_reg_shafer = probability
Exit_sub:
Exit Function
Err_goto:
MsgBox Err.Description
Resume Exit_sub
End Function
Public Function NurseFormEval(ByVal Pat_ID As Long) As String
On Error GoTo Err_goto
Dim r As Recordset
Dim has_positive As Boolean
Dim q(6) As Integer
Dim i As Integer
has_positive = False
' if exists "form data missing" consider as if there was at least one "no"
If Not IsNull(DLookup("Pat_ID", "L_TmpV2", "Pat_ID = " & Form_View.Pat_ID & " and Project = ""Overstay"" and Item = ""DPST data missing""")) Then
NurseFormEval = "red"
MsgBox """DPST data missing"" variable set, form will be evaluated as requiring assistance. "
GoTo Exit_sub
End If
Set r = CurrentDb.OpenRecordset("Select * from s_tmp_overstay_nurseForm where Pat_ID = " & Pat_ID, , dbReadOnly)
If r.RecordCount <> 6 Then
NurseFormEval = "undefined"
MsgBox "For each of the 6 questions you must either enter a specific answer, or a ""Form Data Missing"" entry. You don't have the correct number of entries. "
GoTo Exit_sub
End If
r.MoveFirst
For i = 1 To 6
q(i) = 1 ' non-boolean to express not-set, i.e. default
Next
'get data into variable "q"
While Not r.EOF
If IsNumeric(Mid(r(1), 1, 1)) Then
q(Mid(r(1), 1, 1)) = r(2)
End If
r.MoveNext
Wend
' iterate through q and validate colour
' check that there are entries for each and that none are positive
For i = 1 To 6
Select Case q(i)
Case 1 ' no answer
MsgBox "Overstay question " & i & " was not filled in and ""Form Data Missing"" wasn't either; fill in one or the other to be able to evaluate colour."
NurseFormEval = "undefined"
GoTo Exit_sub
Case 0 ' answer is unchecked-"patient not OK", calling function will use Rodrigo's algorithm to get colour
NurseFormEval = "red"
GoTo Exit_sub
Case -1 ' answer is checked-"patient OK"
NurseFormEval = "green"
' keep cycling through q, see if next has non-green
Case Else ' should never happen
MsgBox "Error in Function NurseFormEval, talk to Tina."
NurseFormEval = "undefined"
GoTo Exit_sub
End Select
Next
Set r = Nothing
Exit_sub:
Exit Function
Err_goto:
MsgBox Err.Description
Resume Exit_sub
End Function
Public Function pt_is_from_PCH(Pat_ID) As String 'returns "yes", "no" or "undefined - <explanation>"
On Error GoTo Err_goto
' ensure necessary data entered to evaluate "from Nursing home"
Dim nr_of_froms As Integer
Dim Pre_Acute_Living_Situation As Variant 'to allow null
Pre_Acute_Living_Situation = DLookup("pre_acute_living_situation", "check_pt_from_pch", "Pat_ID = " & Pat_ID)
If IsNull(Pre_Acute_Living_Situation) Then
MsgBox "Overstay Pre-acute Living Situation: The field is empty, needs to be entered before Overstay Colour can be generated. (see http://ccmdb.kuality.ca/index.php/Overstay_Predictor_Project_Collection_Instructions#admitted_from)"
pt_is_from_PCH = "undefined - pre_acute_living_situation not entered"
GoTo Exit_sub
End If
If Pre_Acute_Living_Situation = "location missing/unknown" Then
MsgBox "Overstay Pre-acute Living Situation: The field is ""location missing/unknown""if info is available please enter and re-evaluate colour. (see http://ccmdb.kuality.ca/index.php/Overstay_Predictor_Project_Collection_Instructions#admitted_from)"
pt_is_from_PCH = "No"
GoTo Exit_sub
End If
If (Pre_Acute_Living_Situation = "Personal Care Home") Or (Pre_Acute_Living_Situation = "Chronic Health Facility") Then
pt_is_from_PCH = "Yes"
Else
pt_is_from_PCH = "No"
End If
Exit_sub:
Exit Function
Err_goto:
MsgBox Err.Description
Resume Exit_sub
End Function
Public Function adlmean_nh_function(adlscore As Integer, from_PCH As Boolean) As Integer
On Error GoTo Err_goto
' Adlmean_nh
' Adlmean_nh = the additional impact of ADL Score only among those who came from a NH
' Adlmean_nh = (ADLScore - 12)*(from a nursing home)
adlmean_nh_function = (adlscore - 12) * (-from_PCH)
Exit_sub:
Exit Function
Err_goto:
MsgBox Err.Description
Resume Exit_sub
End Function
Public Function adlmean_age_function(adlscore As Integer, age As Double) As Integer
On Error GoTo Err_goto
' Adlmean_age
' Adlmean_age = An interaction between age and ADL Score
' Adlmean_age = (ADLScore - 12)*(age)
adlmean_age_function = (adlscore - 12) * age
Exit_sub:
Exit Function
Err_goto:
MsgBox Err.Description
Resume Exit_sub
End Function
Public Function Charlson_nh_function(Pat_ID As Long, charlsonscore As Integer, from_PCH As Boolean) As Integer
On Error GoTo Err_goto
'Charlson_nh
'Charlson_nh = the additional impact of Charlson Score only among those who came from a NH
'Charlson_nh = (Charlson score)*(from a nursing home)
Charlson_nh_function = Charlson_score_function(Pat_ID) * (-from_PCH)
Exit_sub:
Exit Function
Err_goto:
MsgBox Err.Description
Resume Exit_sub
End Function