Option Compare Database
Option Explicit
Private Sub Assigned_GotFocus()
'Dropdown combo box on Focus
Me.Assigned.Dropdown
End Sub
Private Sub cmb_Week_Number_GotFocus()
'On Focus Dropdown the combo box
'Take the single tick off the next line of code to activate the dropdown
'Me.cmb_Week_Number.Dropdown
End Sub
Public Sub SetComboWkNos(startDate As String, endDate As String)
'Declare Variables
Dim Start_Week As Integer, End_Week As Integer, counter As Integer
Dim comboValue As String
'Give Variables Value
Start_Week = DatePart("ww", CDate(#9/29/2010#), [vbSaturday], [vbFirstJan1])
End_Week = DatePart("ww", CDate(Date), [vbSaturday], [vbFirstJan1])
counter = Start_Week
'Create Loop
Do While Not (counter = End_Week + 1) 'The + 1 is added so that the current week number is shown in the list
comboValue = comboValue & counter & "; "
counter = counter + 1
Loop
Me.cmb_Week_Number.RowSourceType = "Value List"
Me.cmb_Week_Number.RowSource = Left(comboValue, Len(comboValue) - 2)
Me.cmb_Week_Number.DefaultValue = DatePart("ww", CDate(Date), [vbSaturday], [vbFirstJan1])
End Sub
Public Sub SetComboYearNos(startDate As String, endDate As String)
'Declare Variables
Dim Start_Year As Integer, End_Year As Integer, counter As Integer
Dim comboValue As String
'Give Variables Value
Start_Year = DatePart("YYYY", CDate(#9/29/2010#), [vbSaturday], [vbFirstJan1])
End_Year = DatePart("YYYY", CDate(Date), [vbSaturday], [vbFirstJan1])
counter = Start_Year
'Create Loop
Do While Not (counter = End_Year + 1) 'The + 1 is added so that the current week number is shown in the list
comboValue = comboValue & counter & "; "
counter = counter + 1
Loop
Me.cmb_Payment_Year.RowSourceType = "Value List"
Me.cmb_Payment_Year.RowSource = Left(comboValue, Len(comboValue) - 2)
Me.cmb_Payment_Year.DefaultValue = DatePart("YYYY", CDate(Date), [vbSaturday], [vbFirstJan1])
End Sub
Private Sub Form_Load()
'To call the routine use for Week of Requests
SetComboWkNos "9/29/2010", Date
'To call the routine use for Year of Requests
SetComboYearNos "9/29/2010", Date
End Sub
Private Sub Form_Open(Cancel As Integer)
'Clear criteria when form is first opened
GCriteria = ""
End Sub
Private Sub Payee_ID_AfterUpdate()
Dim SID As String
SID = Me.Payee_ID.Value
'Check to see if Payee_ID is in the Payee_Rendering_Claims_Data table, if not give message
If DCount("Payee_ID", "Payee_Rendering_Claims_Data", "Payee_ID=" & Chr(34) & SID & Chr(34)) < 1 Then
'Undo duplicate entry
Me.Undo
'Message box indicating Payee_ID is not in table
MsgBox "The Payee ID: " & SID & " is not in this database." _
& vbCr & " " _
& vbCr & "Please verify the ID and try again or contact your database administrator for assistance."
End If
End Sub
Private Sub cmd_Open_Discontinue_IPP_Form_Click()
On Error GoTo Err_cmd_Open_Discontinue_IPP_Form_Click
Dim stDocName As String
Dim stLinkCriteria As String
stDocName = "frm_Discontinue_IPP"
DoCmd.OpenForm stDocName, , , stLinkCriteria
Exit_cmd_Open_Discontinue_IPP_Form_Click:
Exit Sub
Err_cmd_Open_Discontinue_IPP_Form_Click:
MsgBox Err.Description
Resume Exit_cmd_Open_Discontinue_IPP_Form_Click
End Sub
Private Sub Payee_ID_LostFocus()
'Declare page variable
Dim var_NullCheck As Currency
'Find the DSum of all Rendering Provider's Total_Claims_Paid
'If all Total_Claims_Paid values are Null replace with 0
Me.Thirteen_Week_Average = Nz(DSum("Total_Claims_Paid", "Payee_Rendering_Claims_Data", "Payee_ID =" & Chr(34) & [Payee_ID] & Chr(34)), 0)
'Find the Payee's Name form the Form's Payee_ID
Me.Payee_Name = DLookup("Payee_Name", "Payee_Rendering_Claims_Data", "Payee_ID =" & Chr(34) & [Payee_ID] & Chr(34))
End Sub
Private Sub Requested_Amount_LostFocus()
'-----------------------------------------------------------------
'NOTE: This piece of code it to calculate the lowest value between
'Billed_Amount, Requested_Amount, and Thirteen_Week_Average
'then calculat 80% of the loest value for the Calculated Value.
'Declare Form Variables
Dim var_Billed_Amount As Currency
Dim var_Requested_Amount As Currency
Dim var_Thirteen_Week_Average As Currency
Dim var_New_Total As Currency
'Use Nz Function to deal with Null
Me.Billed_Amount = Nz(Billed_Amount, 0)
Me.Requested_Amount = Nz(Requested_Amount, 0)
Me.Thirteen_Week_Average = Nz(Thirteen_Week_Average, 0)
'Give the Declared Form Variables the Value of the Form Controls
var_Billed_Amount = Me.Billed_Amount
var_Requested_Amount = Me.Requested_Amount
var_Thirteen_Week_Average = Me.Thirteen_Week_Average
'Find the lowest value and then take 80% for the calculated amount
If var_Billed_Amount < var_Requested_Amount Then
var_New_Total = var_Billed_Amount
If var_New_Total > var_Thirteen_Week_Average Then
var_New_Total = var_Thirteen_Week_Average
End If
Else
var_New_Total = var_Requested_Amount
If var_New_Total > var_Thirteen_Week_Average Then
var_New_Total = var_Thirteen_Week_Average
End If
End If
'Give the control Calc_Pmt_Amount the lesser of the 3 variables TIMES 80%
Me.Calc_Pmt_Amount = var_New_Total * 0.8
'-----------------------------------------------------------------
End Sub
'For code housekeeping purpose do not place any code below this section
'This code is for the Save, Undo, and Quit buttons
'Many thanks to the original writer of this code, ghudson, and can be found at
'http://www.access-programmers.co.uk/forums/
'ghudson 11/27/2002
'For those of us not using Access XP, we have a challenge to prevent
'our users from advancing to another record if they do not use the controls
'we want them to use or to prevent them from bypassing our validation
'procedures too ensure the current record is okay to be saved.
'The trick in my form is the value in the tbProperSave text box. The user will
'not be able to advance to another record using their scrolling mouse wheel nor
'will they be able to use the Page Up or Page Down keys nor will they be able
'to use the Shift-Enter keys to save the record. The user is forced to save
'or undo the modified record using my custom save or undo buttons before
'they can advance to another record or before they can close the form.
Private Sub bQuit_Click()
On Error GoTo Err_bQuit_Click
Me.tbHidden.SetFocus
'Prompts the user to save the current record if it needs to be saved.
If Me.Dirty Then
Beep
MsgBox "Please Save This Record!" & vbCrLf & vbLf & "You can not close this form until you either 'Save' the changes made to this record or 'Undo' your changes.", vbExclamation, "Save Required"
Else
'DoCmd.OpenForm "fMainMenu"
DoCmd.Close acForm, Me.Name
End If
Exit_bQuit_Click:
Exit Sub
Err_bQuit_Click:
MsgBox Err.Number, Err.Description
Resume Exit_bQuit_Click
End Sub
Private Sub bSave_Click()
On Error GoTo Err_bSave_Click
Me.tbHidden.SetFocus
If IsNull(Payment_Year) Or IsNull(Week_Number) Or IsNull(Payee_ID) Or IsNull(Payee_Name) Or IsNull(Billed_Amount) Or IsNull(Requested_Amount) Or IsNull(Calc_Pmt_Amount) Or IsNull(Assigned) Or IsNull(Email_Receipt_Date) Or IsNull(Form_Tracking_Number) Then
Beep
MsgBox "All required fields must be completed before you can save a record.", vbCritical, "Invalid Save"
Exit Sub
End If
Beep
Select Case MsgBox("Do you want to save your changes to the current record?" & vbCrLf & vbLf & " Yes: Saves Changes" & vbCrLf & " No: Does NOT Save Changes" & vbCrLf & " Cancel: Reset (Undo) Changes" & vbCrLf, vbYesNoCancel + vbQuestion, "Save Current Record?")
Case vbYes: 'Save the changes
Me.tbProperSave.Value = "Yes"
DoCmd.RunCommand acCmdSaveRecord
Case vbNo: 'Do not save or undo
'Do nothing
Case vbCancel: 'Undo the changes
DoCmd.RunCommand acCmdUndo
Me.tbProperSave.Value = "No"
Case Else: 'Default case to trap any errors
'Do nothing
End Select
Exit_bSave_Click:
Exit Sub
Err_bSave_Click:
If Err = 2046 Then 'The command or action Undo is not available now
Exit Sub
Else
MsgBox Err.Number, Err.Description
Resume Exit_bSave_Click
End If
End Sub
Private Sub bUndo_Click()
On Error GoTo Err_bUndo_Click
Me.tbHidden.SetFocus
'Resets the record if it has been modified by the user.
If Me.Dirty Then
Beep
DoCmd.RunCommand acCmdUndo
Me.tbProperSave.Value = "No"
Else
Beep
MsgBox "There were no modifications made to the current record.", vbInformation, "Invalid Undo"
End If
Exit_bUndo_Click:
Exit Sub
Err_bUndo_Click:
MsgBox Err.Number, Err.Description
Resume Exit_bUndo_Click
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
On Error GoTo Err_Form_BeforeUpdate
Me.tbHidden.SetFocus
If Me.tbProperSave.Value = "No" Then
Beep
MsgBox "Please Save This Record!" & vbCrLf & vbLf & "You can not advance to another record until you either 'Save' the changes made to this record or 'Undo' your changes.", vbExclamation, "Save Required"
DoCmd.CancelEvent
Exit Sub
End If
Exit_Form_BeforeUpdate:
Exit Sub
Err_Form_BeforeUpdate:
If Err = 3020 Then 'Update or CancelUpdate without AddNew or Edit
Exit Sub
Else
MsgBox Err.Number, Err.Description
Resume Exit_Form_BeforeUpdate
End If
End Sub
Private Sub Form_Current()
On Error GoTo Err_Form_Current
Me.tbProperSave.Value = "No"
Exit_Form_Current:
Exit Sub
Err_Form_Current:
MsgBox Err.Number, Err.Description
Resume Exit_Form_Current
End Sub
