The following code is still in the test phase but it works other than the
file growth issue.
An associate mentioned that there was a way to modify update queries to not
do a delete prior to updates but I could not find any information about this.
Thanks for looking into this issue,
alr
Option Compare Database
Option Explicit
Public Function ProdBrCd()
On Error GoTo errHdl1
Debug.Print "Start " & Now()
Dim I As Long
Dim J As Long
Dim intClmSum As Long
Dim intClmNbr As Long
Dim intCheckDigit As Long
Dim MaxOfClaim7 As Long
Dim ModSum As Long
Dim TmpDig As Long
Dim CurChar As String
Dim ClmPlCkDig As String
Dim CaseCode As String
Dim ApndSql As String
Dim MstrTbl As String
Dim strMastPth As String
Dim strOpMast As String
Dim strErrTrck As String
strErrTrck = "Opening"
CaseCode = Forms!AddClm7BCode!txtCaseCode
CaseCode = UCase(CaseCode)
MstrTbl = CaseCode & "Master"
strMastPth = "c:\BrCD\" & CaseCode & "master" & ".mdb"
DoCmd.TransferDatabase acLink, "Microsoft Access", strMastPth, acTable,
CaseCode & "Master", CaseCode & "Master"
Dim rsWkDt As Recordset
Set rsWkDt = New Recordset
rsWkDt.Open "select * from WkDt", CurrentProject.Connection, adOpenDynamic,
adLockOptimistic
Dim rsMaster As Recordset
Set rsMaster = New Recordset
strOpMast = "Select * from " & MstrTbl & ""
'MsgBox strOpMast
rsMaster.Open strOpMast, CurrentProject.Connection, adOpenDynamic,
adLockOptimistic
MaxOfClaim7 = DMax("[claim7]", MstrTbl)
'MaxOfClaim7 = "SELECT Max(ABC1MASTER![CLAIM7]) AS MaxOfCLAIM7 FROM
ABC1MASTER;"
strErrTrck = "start1stloop"
rsWkDt.MoveFirst
J = 1
Do Until rsWkDt.EOF
strErrTrck = "in1stloop"
'If AutoAdd not = record count error out, automate added field??
'populate claim number
rsWkDt![claim7] = MaxOfClaim7 + J
If rsWkDt![claim7] = 1071489 Then
MsgBox ("under coming up")
End If
intClmSum = 0
I = 0
Do Until I = Len(rsWkDt![claim7])
strErrTrck = "in2ndloop"
'Calc Check Digit Sum
intClmSum = intClmSum + Mid(rsWkDt![claim7], Len(rsWkDt![claim7]) -
I, 1) * (I + 2)
I = I + 1
Loop
'Create Check Digit
intCheckDigit = intClmSum Mod 11
intCheckDigit = 11 - intCheckDigit
If intCheckDigit = 10 Or intCheckDigit = 11 Then
intCheckDigit = 0
End If
'Assign CkDig
rsWkDt![CkDig] = intCheckDigit
'Calculate Mod to Claim7 PLUS CkDig
ClmPlCkDig = rsWkDt![claim7] & intCheckDigit
I = 0
ModSum = 0
Do Until I = Len(ClmPlCkDig)
strErrTrck = "in3rdloop"
'Calc Mod Sum
CurChar = Mid(ClmPlCkDig, Len(ClmPlCkDig) - I, 1)
CurChar = UCase(CurChar)
'Convert Curr MOD Char to Ascii in case there are alpha chars
If Asc(CurChar) > 47 And Asc(CurChar) < 58 Then
ModSum = ModSum + Asc(CurChar) - 48
End If
If Asc(CurChar) > 64 And Asc(CurChar) < 91 Then
ModSum = ModSum + Asc(CurChar) - 55
End If
If Asc(CurChar) = 45 Then
ModSum = ModSum + Asc(CurChar) + 36
End If
If Asc(CurChar) = 46 Then
ModSum = ModSum + Asc(CurChar) + 37
End If
If Asc(CurChar) = 32 Then
ModSum = ModSum + Asc(CurChar) + 38
End If
If Asc(CurChar) = 36 Then
ModSum = ModSum + Asc(CurChar) + 39
End If
If Asc(CurChar) = 47 Then
ModSum = ModSum + Asc(CurChar) + 40
End If
If Asc(CurChar) = 43 Then
ModSum = ModSum + Asc(CurChar) + 41
End If
If Asc(CurChar) = 37 Then
ModSum = ModSum + Asc(CurChar) + 42
End If
'ModSum = ModSum + Mid(rsWkDt![claim7], Len(rsWkDt![claim7]) - I, 1)
I = I + 1
Loop
strErrTrck = "fin3rdloop"
'Create Check Digit converting ascii back to chr()
TmpDig = ModSum Mod 43
If (TmpDig >= 0) And (TmpDig <= 9) Then
TmpDig = TmpDig + 48
End If
If (TmpDig >= 10) And (TmpDig <= 35) Then
TmpDig = TmpDig + 55
End If
If TmpDig = 36 Then
TmpDig = 45
End If
If TmpDig = 37 Then
TmpDig = 46
End If
If TmpDig = 38 Then
TmpDig = 175 'OverScore instead of space or underscore, no scan
End If
If TmpDig = 39 Then
TmpDig = 36
End If
If TmpDig = 40 Then
TmpDig = 47
End If
If TmpDig = 41 Then
TmpDig = 43
End If
If TmpDig = 42 Then
TmpDig = 37
End If
strErrTrck = "fin3rdloopAftIfs"
rsWkDt![Mod] = Chr(TmpDig)
rsWkDt![BarCode] = "*" & CaseCode & rsWkDt![claim7] & rsWkDt![CkDig] &
rsWkDt![Mod] & "*"
rsWkDt.Update
rsWkDt.MoveNext
J = J + 1
Loop
strErrTrck = "afterloops"
'ApndSql = "INSERT INTO " & CaseCode & "MASTER SELECT WkDt.* FROM WkDt;"
'DoCmd.RunSQL ApndSql
Debug.Print "End " & Now()
Set rsWkDt = Nothing
Set rsMaster = Nothing
ExitErrHdl1:
Exit Function
errHdl1:
MsgBox Err.Description & " " & strErrTrck
Resume ExitErrHdl1
End Function