Access - Run Time Error 3049

[pfarley1212]

Hi,

I have a macro that I am running in Microsoft Access and I am receiving an error "Run Time Error 3049. Cannot Open Database. It may not be a database that your application recognizes, or the file may be corrupt". I'm positive that the file isn't corrupt and not sure why it's saying it can't recognize the database. Can you please help? The code of my query is below and I have highlighted where it errors out and where I have to debug. THANKS!!

Function EAPGIn()

Open Application.CurrentProject.Path & "\" & "EAPGFromGrouperData.csv" For Input As #1
Open Application.CurrentProject.Path & "\" & "EAPGGrouperJobLog.txt" For Append As #2
Print #2, Date & " " & Time & " >------- Start EAPGIn"
'
Dim SQLQuery As String
Dim IREC As Double
Dim StrLine As String
Dim SplitLine() As String
Dim SplitHeaders() As String
Dim ItemCounter As Double
Dim I As Integer
Dim Z As Integer
Dim EpisodeNo As String
Dim HCPCSString() As String
Dim RevString() As String
Dim DOSString() As String
Dim ItemChargesString() As String
Dim EAPGString() As String
Dim EAPGTypeString() As String
Dim EAPGCategoryString() As String
Dim GrouperVersion As String
Dim MultiProcString() As String
Dim RepeatAncString() As String
Dim BilateralString() As String
Dim UnassignedFlagString() As String
Dim ActionFlagString() As String
Dim PackageFlagString() As String
Dim SameProcString() As String
Dim ClinicalProcString() As String
Dim ProcEditString() As String
Dim ClaimProcessFlag As String
Dim ClaimProcessWarning As String
Dim ItemVisitTypeString() As String
Dim ItemVisitWarningString() As String
Dim ClaimEdits As String
Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim rs3 As DAO.Recordset
Dim NumStatus As Integer
Dim DteEffective As Double
Dim DteEnd As Double
Dim StdConv As Double
Dim DiscPercent As Double
Dim AmtThreshold As Double
Dim NumWeight As Double
Dim WorkingDate As Double
Dim EAPGCalcPrice As Double
Dim EAPGSumCalcPrice As Double
Dim EAPGSumAmtBilled As Double
Dim ProvCCR As Double
Dim EpisodeAmtOutlier As Double


Dim WeightRecords() As String
Dim WeightRecord() As String
'
'
' First, get the Num Stats values from the database where the CUR_RUN flag = "*"
' If we can't find that, abort.
Print #2, Date & " " & Time & " Get Stats"
NumStatus = 0
StdConv = 0
DiscPercent = 0
AmtThreshold = 0
NumWeight = 0
SQLQuery = "SELECT * FROM T_CLM_EAPG_NUM_STATS WHERE T_CLM_EAPG_NUM_STATS.CUR_RUN = ""*"";"
Set rs3 = CurrentDb.OpenRecordset(SQLQuery)
If rs3.RecordCount = 0 Then
Print #2, Date & " " & Time & " Cannot find NUM STATS row, aborting"
rs3.Close
GoTo End_Abort
Else
NumStatus = rs3.Fields("NUM_STATUS")
DteEffective = rs3.Fields("DTE_EFFECTIVE")
DteEnd = rs3.Fields("DTE_END")
AmtThreshold = rs3.Fields("AMT_THRESHOLD")
StdConv = rs3.Fields("STD_CONV")
DiscPercent = rs3.Fields("DISC_PERCENT")
Print #2, Date & " " & Time & " Num Status " & NumStatus & " Date Eff " & _
DteEffective & " Date End " & DteEnd & " Threshold " & AmtThreshold & _
" Std Conv " & StdConv & " Disc Percent " & DiscPercent
rs3.Close
End If
'
' Using the NumStatus value, get the relative weights and build an internal table
' that will be used for weight lookup during pricing. This speeds things up instead
' of queries to the database on each service.
Print #2, Date & " " & Time & " Build Relative Weights array"
SQLQuery = "SELECT CDE_EAPG, NUM_WEIGHT from T_CLM_EAPG_REL_WGHT WHERE " & _
"NUM_STATUS = " & NumStatus & ";"
Set rs3 = CurrentDb.OpenRecordset(SQLQuery)
If rs3.RecordCount = 0 Then
Print #2, Date & " " & Time & " No relative weights selected, aborting"
rs3.Close
GoTo End_Abort
End If
' There are usually at least 400 weights
ReDim Preserve WeightRecords(400)
I = -1
Do Until rs3.EOF
I = I + 1
If UBound(WeightRecords) < I Then
ReDim Preserve WeightRecords(I)
End If
WeightRecords(I) = rs3.Fields("CDE_EAPG") & "," & rs3.Fields("NUM_WEIGHT")
rs3.MoveNext
Loop
rs3.Close
'
' Drop Grouper Header Table
Print #2, Date & " " & Time & " Drop T_CLM_EAPG_GROUPER_HDR"
On Error Resume Next
SQLQuery = "DROP TABLE T_CLM_EAPG_GROUPER_HDR;"
CurrentDb.Execute SQLQuery
On Error GoTo 0
'
' Build Grouper Header Table
Print #2, Date & " " & Time & " Create T_CLM_EAPG_GROUPER_HDR"
SQLQuery = "CREATE TABLE T_CLM_EAPG_GROUPER_HDR (EPISODE NUMERIC PRIMARY KEY, " & _
"GROUPER_VERSION_USED VARCHAR, CLAIM_PROCESSED_FLAG VARCHAR, " & _
"EAPG_SUM_CALC_PRICE NUMERIC, EPISODE_BILLED NUMERIC, AMT_COST_CHRG NUMERIC, " & _
"AMT_OUTLIER NUMERIC, EPISODE_PRICE NUMERIC, CLAIM_PROCESSED_WARNING VARCHAR, " & _
"CLAIM_EDITS VARCHAR);"
CurrentDb.Execute SQLQuery
'
' Drop Grouper Detail Table
Print #2, Date & " " & Time & " Drop T_CLM_EAPG_GROUPER_DTL"
On Error Resume Next
SQLQuery = "DROP TABLE T_CLM_EAPG_GROUPER_DTL;"
CurrentDb.Execute SQLQuery
On Error GoTo 0
'
' Build Grouper Detail Table
Print #2, Date & " " & Time & " Create T_CLM_EAPG_GROUPER_DTL"
'
SQLQuery = "CREATE TABLE T_CLM_EAPG_GROUPER_DTL (EPISODE NUMERIC, EPISODE_SEQ NUMERIC, " & _
"CDE_PROCEDURE VARCHAR, CDE_REVENUE VARCHAR, ITEM_FINAL_EAPG NUMERIC, EAPG_NUM_WEIGHT NUMERIC, " & _
"EAPG_CALC_PRICE NUMERIC, ITEM_FINAL_EAPG_TYPE VARCHAR, ITEM_FINAL_EAPG_CATEGORY VARCHAR, " & _
"ITEM_MULTI_PROC_DISC_FLAG VARCHAR, ITEM_REPEAT_ANC_DISC_FLAG VARCHAR, " & _
"ITEM_BILAT_DISC_FLAG VARCHAR, ITEM_UNASSIGNED_FLAG VARCHAR, ITEM_ACTION_FLAG VARCHAR, " & _
"ITEM_PACKAGING_FLAG VARCHAR, ITEM_SAME_PROC_CONS_FLAG VARCHAR, ITEM_CLINICALPROC_CONS_FLAG VARCHAR, " & _
"ITEM_PROCEDURE_EDITS VARCHAR, ITEM_OVERALL_VISIT_TYPE VARCHAR, ITEM_VISIT_PROCESSED_WARNING VARCHAR, " & _
"CONSTRAINT PrimaryKey PRIMARY KEY (EPISODE, EPISODE_SEQ));"
CurrentDb.Execute SQLQuery
'
Set rs1 = CurrentDb.OpenRecordset("T_CLM_EAPG_GROUPER_HDR")
Set rs2 = CurrentDb.OpenRecordset("T_CLM_EAPG_GROUPER_DTL")
'
Print #2, Date & " " & Time & " Read input file and build output tables"
IREC = 0
Do Until EOF(1)
Line Input #1, StrLine
If Left(StrLine, 1) = "A" Then '<-- first record is headers
SplitHeaders = Split(StrLine, ",")
' Print #2, Date & " " & Time & " File Headers " & StrLine
GoTo Skip_Loop
End If
IREC = IREC + 1
' Split the input record to individual fields and arrays for those fields with multiple values
SplitLine = Split(StrLine, ",")
EpisodeNo = SplitLine(0)
HCPCSString = Split(SplitLine(1), ";")
RevString = Split(SplitLine(2), ";")
DOSString = Split(SplitLine(3), ";")
ItemChargesString = Split(SplitLine(4), ";")
EAPGString = Split(SplitLine(5), ";")
EAPGTypeString = Split(SplitLine(6), ";")
EAPGCategoryString = Split(SplitLine(7), ";")
GrouperVersion = SplitLine(8)
MultiProcString = Split(SplitLine(9), ";")
RepeatAncString = Split(SplitLine(10), ";")
BilateralString = Split(SplitLine(11), ";")
UnassignedFlagString = Split(SplitLine(12), ";")
ActionFlagString = Split(SplitLine(13), ";")
PackageFlagString = Split(SplitLine(14), ";")
SameProcString = Split(SplitLine(15), ";")
ClinicalProcString = Split(SplitLine(16), ";")
ProcEditString = Split(SplitLine(17), ";")
ClaimProcessFlag = SplitLine(18)
ClaimProcessWarning = SplitLine(19)
ItemVisitTypeString = Split(SplitLine(20), ";")
ItemVisitWarningString = Split(SplitLine(21), ";")
ClaimEdits = SplitLine(22)
'
' Item level fields
'
' The number of occurances in the revenue code string dicates looping.
' Note it starts at zero.
EAPGSumAmtBilled = 0
EAPGSumCalcPrice = 0
For I = 0 To UBound(RevString)
With rs2
.AddNew
.Fields("EPISODE") = EpisodeNo
.Fields("EPISODE_SEQ") = (I + 1)
.Fields("CDE_REVENUE") = RevString(I)
If I <= UBound(HCPCSString) Then
.Fields("CDE_PROCEDURE") = HCPCSString(I)
End If
' WorkingDate = CDbl(Right(DOSString(I), 4) & Left(DOSString(I), 4))
EAPGSumAmtBilled = EAPGSumAmtBilled + CDbl(ItemChargesString(I))
'
' 04/23/12
'
If UnassignedFlagString(I) = "11" Or UnassignedFlagString(I) = "12" Then
EAPGString(I) = "501"
' MsgBox "unassignedflag" & UnassignedFlagString(I) & " eapgstring(i)" & EAPGString(I)
End If
'
.Fields("ITEM_FINAL_EAPG") = CDbl(EAPGString(I))
.Fields("ITEM_FINAL_EAPG_TYPE") = EAPGTypeString(I)
.Fields("ITEM_FINAL_EAPG_CATEGORY") = EAPGCategoryString(I)
.Fields("ITEM_MULTI_PROC_DISC_FLAG") = MultiProcString(I)
.Fields("ITEM_REPEAT_ANC_DISC_FLAG") = RepeatAncString(I)
.Fields("ITEM_BILAT_DISC_FLAG") = BilateralString(I)
.Fields("ITEM_UNASSIGNED_FLAG") = UnassignedFlagString(I)
If I <= UBound(ActionFlagString) Then
If ActionFlagString(I) > "" Then
.Fields("ITEM_ACTION_FLAG") = ActionFlagString(I)
Else
.Fields("ITEM_ACTION_FLAG") = " "
End If
End If
.Fields("ITEM_PACKAGING_FLAG") = PackageFlagString(I)
.Fields("ITEM_SAME_PROC_CONS_FLAG") = SameProcString(I)
.Fields("ITEM_CLINICALPROC_CONS_FLAG") = ClinicalProcString(I)
If I <= UBound(ProcEditString) Then
If ProcEditString(I) > "" Then
.Fields("ITEM_PROCEDURE_EDITS") = ProcEditString(I)
Else
.Fields("ITEM_PROCEDURE_EDITS") = " "
End If
End If
If I <= UBound(ItemVisitTypeString) Then
If ItemVisitTypeString(I) > "" Then
.Fields("ITEM_OVERALL_VISIT_TYPE") = ItemVisitTypeString(I)
Else
.Fields("ITEM_OVERALL_VISIT_TYPE") = " "
End If
End If
If I <= UBound(ItemVisitWarningString) Then
If ItemVisitWarningString(I) > "" Then
.Fields("ITEM_VISIT_PROCESSED_WARNING") = ItemVisitWarningString(I)
Else
.Fields("ITEM_VISIT_PROCESSED_WARNING") = " "
End If
End If
'
' Price the service
'
NumWeight = 0
If CDbl(EAPGString(I)) = 0 Or CDbl(EAPGString(I)) = 999 Then
EAPGCalcPrice = 0
GoTo Skip_Dtl_Pricing
End If
For Z = 0 To UBound(WeightRecords)
WeightRecord = Split(WeightRecords(Z), ",")
If EAPGString(I) = WeightRecord(0) Then
NumWeight = CDbl(WeightRecord(1))
GoTo Skip_Weight_Array
End If
Next Z
Skip_Weight_Array:
'MsgBox (Z & " " & NumWeight & " " & EAPGString(I))
If NumWeight = 0 Then
Print #2, Date & " " & Time & " Cannot price Episode/Seq/EAPG " & EpisodeNo & _
"/" & (I + 1) & "/" & EAPGString(I)
GoTo Skip_Dtl_Pricing
' Else
' .Fields("WEIGHT_ERROR_FLAG") = " "
End If
EAPGCalcPrice = NumWeight * StdConv
If MultiProcString(I) = "1" Then
EAPGCalcPrice = EAPGCalcPrice * DiscPercent
ElseIf RepeatAncString(I) = "1" Then
EAPGCalcPrice = EAPGCalcPrice * DiscPercent
ElseIf BilateralString(I) = "1" Then
EAPGCalcPrice = EAPGCalcPrice * DiscPercent
ElseIf PackageFlagString(I) = "1" Then
EAPGCalcPrice = 0
ElseIf SameProcString(I) = "1" Then
EAPGCalcPrice = 0
ElseIf ClinicalProcString(I) = "1" Then
EAPGCalcPrice = 0
End If
Skip_Dtl_Pricing:
.Fields("EAPG_NUM_WEIGHT") = NumWeight
.Fields("EAPG_CALC_PRICE") = EAPGCalcPrice
EAPGSumCalcPrice = EAPGSumCalcPrice + EAPGCalcPrice
.Update
End With
Next I
'
' Write the header
With rs1
.AddNew
.Fields("EPISODE") = EpisodeNo
If GrouperVersion > "" Then
.Fields("GROUPER_VERSION_USED") = GrouperVersion
Else
.Fields("GROUPER_VERSION_USED") = " "
End If
.Fields("CLAIM_PROCESSED_FLAG") = ClaimProcessFlag
.Fields("EAPG_SUM_CALC_PRICE") = EAPGSumCalcPrice
.Fields("EPISODE_BILLED") = EAPGSumAmtBilled
.Fields("CLAIM_PROCESSED_WARNING") = ClaimProcessWarning
If ClaimEdits > "" Then
.Fields("CLAIM_EDITS") = ClaimEdits
Else
.Fields("CLAIM_EDITS") = " "
End If
'
' Episode pricing
SQLQuery = "SELECT DISTINCT T_CLM_EAPG_PRV_CCR.AMT_COST_CHRG " & _
"FROM (T_CLM_EAPG_EPISODE_XRF INNER JOIN T_CLM_EAPG_HDR_EXTRACT ON " & _
"T_CLM_EAPG_EPISODE_XRF.SAK_CLAIM = T_CLM_EAPG_HDR_EXTRACT.SAK_CLAIM) " & _
"INNER JOIN T_CLM_EAPG_PRV_CCR ON T_CLM_EAPG_HDR_EXTRACT.NUM_TAX_ID " & _
"= T_CLM_EAPG_PRV_CCR.NUM_TAX_ID " & _
"WHERE (((T_CLM_EAPG_EPISODE_XRF.EPISODE)= " & EpisodeNo & _
") AND ((T_CLM_EAPG_PRV_CCR.NUM_STATUS)= " & NumStatus & _
"));"
Set rs3 = CurrentDb.OpenRecordset(SQLQuery)
If rs3.RecordCount = 0 Or rs3.RecordCount > 1 Then
Print #2, Date & " " & Time & " Cannot retrieve Provider CCR for Episode " & _
NumStatus & " / " & EpisodeNo
MsgBox "Cannot retrieve Provider CCR for Episode " & NumStatus & " / " & EpisodeNo
GoTo End_Abort
End If
ProvCCR = rs3.Fields(0)
.Fields("AMT_COST_CHRG") = rs3.Fields(0)
rs3.Close
' calculate outlier and final episode price
If ((EAPGSumAmtBilled * ProvCCR) - EAPGSumCalcPrice) > AmtThreshold Then
EpisodeAmtOutlier = ((EAPGSumAmtBilled * ProvCCR) - EAPGSumCalcPrice)
Else
EpisodeAmtOutlier = 0
End If
.Fields("AMT_OUTLIER") = EpisodeAmtOutlier
.Fields("EPISODE_PRICE") = EAPGSumCalcPrice + EpisodeAmtOutlier
.Update
End With
'
Skip_Loop:
Loop
'
End_Abort:
Close #1
Print #2, Date & " " & Time & " Episodes input - " & IREC
Print #2, Date & " " & Time & " >------- End EAPGIn"
Close #2
rs1.Close
rs2.Close
'
End Function

[June7]

The hightlighted line is .Update toward end of the procedure. This is the line causing error?

You are trying to add records to rs1 and the Update is failing?

I can't see anything wrong with the code.

If you want to provide files for analysis, follow instructions at bottom of my post.

[tanvi]

Have you run Compact & Repair?
If not, first run it..