Prevent duplicate records using 3 fields - not table definitions

[hijinx]

I have a small medical claims database that needs to check for duplicates on a combination of 3 fields: Date of Service, Amount, Medical Provider (example: 12/15/2004;$25.00,Jones Pharmacy.

The problem is that the user needs the ability to override any warning and enter the "duplicate" record because it may be legit, but needs to be warned that a records already exists with this combination of data.

Thanks for any help the group can provide.

 

[VBslammer]

If your table allows the duplicates, then all you need to do is run a query based on the current record's values to see if any matches are found. If you do this in the Form_BeforeUpdate() event, you can Cancel the update if the user decides to:

Private Sub Form_BeforeUpdate(Cancel As Integer)
On Error GoTo ErrHandler
  Dim rst As Recordset
  Dim strSQL As String
  Dim strMsg As String
  Dim IntCount As Integer
  Dim rply As VbMsgBoxResult
  
  Const MAX As Integer = 10
  
  If ValidateUserEntries = False Then
    Cancel = True
    MsgBox "Please enter all required fields!", vbExclamation, "Update Warning"
    Exit Sub
  End If
  
  strSQL = "SELECT [TransID], [Date of Service], [Amount], [Medical Provider] FROM" & _
           " [TableName] WHERE" & _
           " [Date of Service]=#" & Me!txtDate & "#" & _
           " AND [Amount]=" & Me!txtAmount & _
           " AND [Medical Provider]='" & Me!txtProvider & "'"
           
  Set rst = CurrentDb().OpenRecordset(strSQL, dbOpenSnapshot)
 
  'build a message to display if duplicates found.
  'if large number of records found, truncate the
  'message so it fits on a message box:
  
  While Not (rst.EOF Or (IntCount > MAX))
    strMsg = strMsg & "Transaction " & rst("TransID") & _
      " already entered for " & rst("Date of Service") & vbCrLf
    rst.MoveNext
    IntCount = IntCount + 1
  Wend
  
  If IntCount > MAX Then
    strMsg = strMsg & "Continued..." & vbCrLf
  End If
    
  If Len(strMsg) > 0 Then
    rply = MsgBox(strMsg & vbCrLf & "Proceed anyway?", vbQuestion + vbOKCancel, "Duplicate Entries")
        
    Select Case rply
      Case VbMsgBoxResult.vbOK
        'proceed with update
      Case VbMsgBoxResult.vbCancel
        Cancel = True
    End Select
  End If
  
ExitHere:
  On Error Resume Next
  rst.Close
  Set rst = Nothing
  Exit Sub
ErrHandler:
  Debug.Print Err, Err.Description
  Resume ExitHere
End Sub

This is just "Air" code so it won't run without some tweaking. The ValidateUserEntries() call is what I normally do to make sure all input is valid before performing an update, but I didn't include the code because it varies depending on the business model.

VBSlammer

Unemployed in Houston, Texas

 

[PHV]

You may also take a look at the DLookUp function.

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ222-2244

 

[hijinx]

Thank you for your responses. I will try them out today.