With thanks to @Mat'sMug and @Comintern for their encouragement, here is a program I wrote to help my team fix medical claim files.
The goal of this program is to make the process of emergency changes to medical claim files as human-proof and rapid as possible, and deliver all the corrected files the analysts need with very easy steps. For this program, the steps are:
- Start the program
- Change the 10 options for file correction on the settings sheet to "On" or "Off" as appropriate.
- Start the macro
- Select the files to fix
In addition to a fixed text file, the program also produces a sheet for each file with the read code in Column A and the write code in Column B, with differences highlighted for easy filtering and comparison.
Procedure
Option Explicit
Sub M1837Fixes()
'
' M1FixNew277URefFJ Macro
'
' Keyboard Shortcut: Ctrl+Shift+Q
'
'--- Fixed Purpose Variables ---
Dim strText As String 'The entire original 837 as one string
Dim strLines() As String 'The original 837 as an array where each line is an array item
Dim strLines2() As String 'The revised 837 as an array where each line is an array item
Dim strLinesTransposed() As String 'Arrays of more than 65536 rows are truncated with #N/As
Dim strLines2Transposed() As String 'Arrays of more than 65536 rows are truncated with #N/As
Dim strText2 As String 'The entire revised 837 as one string
Dim strNewLineCharacter As String
Dim dictCorrectionOptions As Object
Dim UserSettings As classUserSettings
Dim strFileName As String 'Currently ICD9 --> ICD10 Conversion and <Analyst Name> <State Name> <Vendor Name> 2
'HL Segment Numbering
Dim lngHLCount As Long
Dim lngLastHLBilling As Long
'Claim Removal
Dim boolHLSeenSinceLastClm As Boolean
Dim boolWriteClaim As Boolean
Dim rngClaimRemoval As Range
Dim lngClaimStartLoop As Long
'Ref*F8 Update
Dim dictRefF8LookupClaims As Object
Dim rngRefF8LookupClaims As Range
'Invalid Zip Code
Dim rngZipCodeLookupCities As Range
'ICD9 --> ICD10 Conversion
Dim dictICDDiags As Object
Dim dictICDProcs As Object
Dim strDiagProcIndicator As String
Dim strDiagProcBeingFixed As String
Dim boolCodeWarning As Boolean
'<Analyst Name> <State Name> <Vendor Name>
Dim dictReplacementCrosswalk As Object
'<Analyst Name> <State Name> <Vendor Name> 2
Dim dictClaimFileCrosswalk As Object
Dim strClaimNumber As String
'--- Reusable Variables ---
Dim Long1 As Long
Dim Long2 As Long
Dim Loop1 As Long
Dim Loop2 As Long
Dim Loop3 As Long
Dim Variant1 As Variant
Dim Int1 As Integer 'Input file number (system-assigned number for file management)
Dim Sheet1 As Worksheet
Dim Range1 As Range
Dim Cell1 As Range
Dim String1 As String
Dim Bool1 As Boolean
'--- Preparation ---
'Speed Enhancers
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'Tell program the new line delimiting character in the 837s so it can parse them appropriately
Set Cell1 = ThisWorkbook.Sheets("Correction Type Options").Cells.Find(What:="New Line Delimiter:")
strNewLineCharacter = Cell1.Offset(0, 1).Value
'Program Usage Warning
MsgBox "Reminder: If a file you select does not have new lines delimited with the character designated on the Correction Type Options sheet (currently: " & strNewLineCharacter & "), that file will not be updated correctly."
'--- Process Correction Type Options sheet ---
'Detect the settings area
With ThisWorkbook.Sheets("Correction Type Options")
Set Range1 = .Range(.Cells(2, 1), .Cells(.Range("A2").End(xlDown).Row, 1))
End With
'Dictionary initialization
Set dictCorrectionOptions = CreateObject("Scripting.Dictionary")
dictCorrectionOptions.comparemode = vbTextCompare
'Detect which options are on, perform any necessary corrections, save settings table to memory
For Each Cell1 In Range1
'Correction option is neither On or Off
If Cell1.Offset(0, 1).Value <> "On" And Cell1.Offset(0, 1).Value <> "Off" Then
String1 = MsgBox("Preference for " & Cell1.Value & " corrections is currently undetermined. Should " & Cell1.Value & " corrections be turned On?", vbYesNo, "On/Off Setting Determination")
If String1 = vbYes Then Cell1.Offset(0, 1).Value = "On" Else Cell1.Offset(0, 1).Value = "Off"
End If
Set UserSettings = New classUserSettings
UserSettings.strCorrectionType = Cell1.Value
UserSettings.strOnOffSwitch = Cell1.Offset(0, 1).Value
UserSettings.strSettingsSheet = Cell1.Offset(0, 2).Value
dictCorrectionOptions.Add Key:=Cell1.Value, Item:=UserSettings
Next Cell1
'Both Claim Removal options are On
If dictCorrectionOptions("Claim Removal - Have Wanted Claims").strOnOffSwitch = "On" And dictCorrectionOptions("Claim Removal - Have Unwanted Claims").strOnOffSwitch = "On" Then
MsgBox "Both " & """" & "Claim Removal" & """" & " correction options on the " & """" & "Correction Type Options" & """" & " are On. Please turn at least one Off."
GoTo Cancel
End If
'Delete worksheets from files previously processed
'Protect per-Correction Type Settings Sheets from deletion
For Each Sheet1 In ThisWorkbook.Sheets
Bool1 = False
For Loop1 = LBound(dictCorrectionOptions.Keys) To UBound(dictCorrectionOptions.Keys)
If Sheet1.Name = dictCorrectionOptions.Items()(Loop1).strSettingsSheet Then Bool1 = True
Next Loop1
If Sheet1.Name = "Correction Type Options" Then Bool1 = True
If Bool1 = False Then
Application.DisplayAlerts = False
Sheet1.Delete
Application.DisplayAlerts = True
End If
Next Sheet1
'--- Correction Type Settings Sheets Preparation ---
'Claim Removal - Have Wanted Claims
If dictCorrectionOptions("Claim Removal - Have Wanted Claims").strOnOffSwitch = "On" Then
With ThisWorkbook.Sheets(dictCorrectionOptions("Claim Removal - Have Wanted Claims").strSettingsSheet)
Long1 = Application.CountA(.Columns(1))
If Long1 = 0 Then
MsgBox "Claim Removal - Have Wanted Claims option is ON, but there are no claims listed on the " & dictCorrectionOptions("Claim Removal - Have Wanted Claims").strSettingsSheet & " sheet."
GoTo Cancel
Else
Set rngClaimRemoval = .Range(.Cells(1, 1), .Cells(Long1, 1))
End If
End With
End If
'Claim Removal - Have Unwanted Claims
If dictCorrectionOptions("Claim Removal - Have Unwanted Claims").strOnOffSwitch = "On" Then
With ThisWorkbook.Sheets(dictCorrectionOptions("Claim Removal - Have Unwanted Claims").strSettingsSheet)
Long1 = Application.CountA(.Columns(1))
If Long1 = 0 Then
MsgBox "Claim Removal - Have Unwanted Claims option is ON, but there are no claims listed on the " & dictCorrectionOptions("Claim Removal - Have Unwanted Claims").strSettingsSheet & " sheet."
GoTo Cancel
Else
Set rngClaimRemoval = .Range(.Cells(1, 1), .Cells(Long1, 1))
End If
End With
End If
'Ref*F8 Update
If dictCorrectionOptions("Ref*F8 Update").strOnOffSwitch = "On" Then
With ThisWorkbook.Sheets(dictCorrectionOptions("Ref*F8 Update").strSettingsSheet)
'Dictionary initialization
Set dictRefF8LookupClaims = CreateObject("Scripting.Dictionary")
dictRefF8LookupClaims.comparemode = vbTextCompare
Long1 = Application.CountA(.Columns(1))
'Warning if settings sheet empty
If Long1 < 2 Then 'There are headers on this sheet
MsgBox "Ref*F8 Update option is ON, but there are no Claim/ICN combinations listed on the " & dictCorrectionOptions("Ref*F8 Update").strSettingsSheet & " sheet."
GoTo Cancel
Else
Set rngRefF8LookupClaims = .Range(.Cells(2, 1), .Cells(Long1, 1))
End If
'Get info from crosswalk sheet for dictionary
Set Range1 = .Range(.Cells(2, 1), .Cells(Long1, 1))
'Populate dictionary from info
For Each Cell1 In Range1
dictRefF8LookupClaims.Add Key:=Cell1.Value, Item:=Cell1.Offset(0, 1).Value
Next Cell1
'Clear "Found" column but leave directions alone
dictCorrectionOptions("Ref*F8 Update").strSettingsSheet.Cells(2, 3).Resize(1048575, 0).Clear
End With
End If
'Invalid Zip Code
If dictCorrectionOptions("Invalid Zip Code").strOnOffSwitch = "On" Then
With ThisWorkbook.Sheets(dictCorrectionOptions("Invalid Zip Code").strSettingsSheet)
Long1 = Application.CountA(.Columns(1))
If Long1 = 0 Then
MsgBox "Zip Code Removal option is ON, but there are no City/Zip combinations listed on the " & dictCorrectionOptions("Invalid Zip Code").strSettingsSheet & " sheet."
GoTo Cancel
Else
Set rngZipCodeLookupCities = .Range(.Cells(1, 1), .Cells(Long1, 1))
End If
End With
End If
'ICD9 --> ICD10 Conversion
If dictCorrectionOptions("ICD9 --> ICD10 Conversion").strOnOffSwitch = "On" Then
With ThisWorkbook.Sheets(dictCorrectionOptions("ICD9 --> ICD10 Conversion").strSettingsSheet)
'Dictionary initialization
Set dictICDDiags = CreateObject("Scripting.Dictionary")
dictICDDiags.comparemode = vbTextCompare
Set dictICDProcs = CreateObject("Scripting.Dictionary")
dictICDProcs.comparemode = vbTextCompare
'Password for settings sheet is Centene - this isn't intended to be hidden, sheet is only locked to prevent accidental modifications
'Get info from crosswalk sheet for dictionary
'Diagnosis
Set Range1 = .Range(.Cells(2, 4), .Cells(14806, 4))
'Populate dictionary from info
For Each Cell1 In Range1
dictICDDiags.Add Key:=Cell1.Value, Item:=Cell1.Offset(0, 1).Value
Next Cell1
'Procedure
Set Range1 = .Range(.Cells(2, 7), .Cells(3883, 7))
'Populate dictionary from info
For Each Cell1 In Range1
dictICDProcs.Add Key:=Cell1.Value, Item:=Cell1.Offset(0, 1).Value
Next Cell1
strDiagProcIndicator = .Cells.Find("Diag-Proc Indicator:").Offset(0, 1).Value
End With
End If
'<Analyst Name> <State Name> <Vendor Name>
If dictCorrectionOptions("<Analyst Name> <State Name> <Vendor Name>").strOnOffSwitch = "On" Then
With ThisWorkbook.Sheets(dictCorrectionOptions("<Analyst Name> <State Name> <Vendor Name>").strSettingsSheet)
'Dictionary initialization
Set dictReplacementCrosswalk = CreateObject("Scripting.Dictionary")
dictReplacementCrosswalk.comparemode = vbTextCompare
Long1 = Application.CountA(.Columns(1))
'Warning if settings sheet empty
If Long1 = 0 Then
MsgBox "<Analyst Name> <State Name> <Vendor Name> option is ON, but there are no claims listed on the " & dictCorrectionOptions("<Analyst Name> <State Name> <Vendor Name>").strSettingsSheet & " sheet."
GoTo Cancel
Else
Set rngClaimRemoval = .Range(.Cells(1, 1), .Cells(Long1, 1))
End If
'Get info from crosswalk sheet for dictionary
Set Range1 = .Range(.Cells(2, 1), .Cells(Long1, 1))
'Populate dictionary from info
For Each Cell1 In Range1
dictReplacementCrosswalk.Add Key:=Cell1.Value, Item:=Cell1.Offset(0, 15).Value
Next Cell1
End With
End If
'<Analyst Name> <State Name> <Vendor Name> 2
If dictCorrectionOptions("<Analyst Name> <State Name> <Vendor Name> 2").strOnOffSwitch = "On" Then
With ThisWorkbook.Sheets(dictCorrectionOptions("<Analyst Name> <State Name> <Vendor Name> 2").strSettingsSheet)
'Dictionary initialization
Set dictClaimFileCrosswalk = CreateObject("Scripting.Dictionary")
dictClaimFileCrosswalk.comparemode = vbTextCompare
'Get info from crosswalk sheet for dictionary
Long1 = Application.CountA(.Columns(1))
Set Range1 = .Range(.Cells(2, 1), .Cells(Long1, 1))
'Populate dictionary from info
For Each Cell1 In Range1
dictClaimFileCrosswalk.Add Key:=Cell1.Value, Item:=Cell1.Offset(0, 1).Value
Next Cell1
'Warning if settings sheet empty
If Long1 = 0 Then
MsgBox "<Analyst Name> <State Name> <Vendor Name> 2 option is ON, but there are no claims listed on the " & dictCorrectionOptions("<Analyst Name> <State Name> <Vendor Name> 2").strSettingsSheet & " sheet."
GoTo Cancel
Else
Set rngClaimRemoval = .Range(.Cells(1, 1), .Cells(Long1, 1))
End If
'Clear "Found" column
dictCorrectionOptions("<Analyst Name> <State Name> <Vendor Name> 2").strSettingsSheet.Column(3).Clear
End With
End If
'-- Select Files --
MsgBox "Select all of your 837 files (use Ctrl-A in the folder or Ctrl-left mouse button)."
Variant1 = Application.GetOpenFilename(MultiSelect:=True)
If IsArray(Variant1) = "False" Then
GoTo Cancel
End If
For Loop1 = LBound(Variant1) To UBound(Variant1)
'--- Make Changelog Sheet and Parse File ---
Set Sheet1 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Sheet1.Name = Left(Right(Variant1(Loop1), Len(Variant1(Loop1)) - InStrRev(Variant1(Loop1), Application.PathSeparator)), 31)
'-- Copy Text File Contents to String --
'Get Available File Integer for Opening
Int1 = FreeFile()
'Open Text File
Open Variant1(Loop1) For Binary As #Int1
'Resize string to length of text file
strText = Space$(LOF(Int1))
'Copy entire file to string
Get #Int1, , strText
'Close File
Close #Int1
strLines() = Split(strText, strNewLineCharacter)
strLines2() = Split(strText, strNewLineCharacter)
'--- Prepare indicators for work ---
'HL Segment Numbering
lngHLCount = 1
'Claim Removal
boolHLSeenSinceLastClm = False 'So that all header information gets preserved
boolWriteClaim = True
lngClaimStartLoop = LBound(strLines)
'ICD9 --> ICD10 Conversion
boolCodeWarning = False
'ICD9 --> ICD10 Conversion and <Analyst Name> <State Name> <Vendor Name> 2
strFileName = Right(Variant1(Loop1), Len(Variant1(Loop1)) - InStrRev(Variant1(Loop1), Application.PathSeparator))
'--- Begin 837 Manipulation ---
For Loop2 = LBound(strLines) To UBound(strLines) 'For some reason is 1-based
'Progress Tracker
Application.StatusBar = Loop2 & " / " & UBound(strLines)
If Right(Loop2, 3) = "000" Then DoEvents
'HL Segment Numbering
If dictCorrectionOptions("HL Segment Numbering").strOnOffSwitch = "On" Then
If Left(strLines(Loop2), 3) = "HL*" Then
'Check if it is a billing HL
If Right(strLines(Loop2), 4) = "20*1" Then
lngLastHLBilling = lngHLCount
'Fix the segment
strLines2(Loop2) = "HL*" & lngHLCount & "**20*1"
Else
'Fix the segment
strLines2(Loop2) = "HL*" & lngHLCount & "*" & lngLastHLBilling & "*22*0"
End If
lngHLCount = lngHLCount + 1
End If
End If
'Claim Removal
If dictCorrectionOptions("Claim Removal - Have Wanted Claims").strOnOffSwitch = "On" Or dictCorrectionOptions("Claim Removal - Have Unwanted Claims").strOnOffSwitch = "On" Then
If Left(strLines(Loop2), 4) = "CLM*" Then
'Claim Removal - both types
If boolHLSeenSinceLastClm = False Then 'This is the first line of a new claim. Erase previous claim if needed and reset lngClaimStartLoop.
If boolWriteClaim = False Then 'If claim just ended is to be excluded from new file, set all of its strlines2 to nothing
'Erase previous claim
For Loop3 = lngClaimStartLoop To Loop2 - 1
strLines2(Loop3) = vbNullString
Next Loop3
End If
'New claim start loop
lngClaimStartLoop = Loop2
'Check if claim on this line should be written
'Prepare default assumption
If dictCorrectionOptions("Claim Removal - Have Wanted Claims").strOnOffSwitch = "On" Then
boolWriteClaim = False
Else
boolWriteClaim = True
End If
'Make final determination
For Each Cell1 In rngClaimRemoval
If InStr(1, strLines(Loop2), Cell1.Value, vbTextCompare) > 0 Then
If dictCorrectionOptions("Claim Removal - Have Wanted Claims").strOnOffSwitch = "On" Then
boolWriteClaim = True
Else
boolWriteClaim = False
End If
Cell1.Offset(0, 1).Value = "Found"
Exit For
End If
Next Cell1
'boolHLSeenSinceLastClm does not need to be reset to false because it is already false.
Else 'This is the middle of an ongoing claim that started with an HL* segment. Do not write anything now and do not reset lngClaimStartLoop. Just determine if the ongoing claim whose CLM number we just hit will be written.
'Prepare default assumption
If dictCorrectionOptions("Claim Removal - Have Wanted Claims").strOnOffSwitch = "On" Then
boolWriteClaim = False
Else
boolWriteClaim = True
End If
'Make final determination
For Each Cell1 In rngClaimRemoval
If InStr(1, strLines(Loop2), Cell1.Value, vbTextCompare) > 0 Then
If dictCorrectionOptions("Claim Removal - Have Wanted Claims").strOnOffSwitch = "On" Then
boolWriteClaim = True
Else
boolWriteClaim = False
End If
Cell1.Offset(0, 1).Value = "Found"
Exit For
End If
Next Cell1
boolHLSeenSinceLastClm = False 'This is currently true. We need to reset it to help determine when the next claim starts.
End If
End If
If Left(strLines(Loop2), 3) = "HL*" Then
'If not second HL, this is the first line of a new claim. Erase previous claim if needed and reset lngClaimStartLoop.
If boolHLSeenSinceLastClm = False Then
If boolWriteClaim = False Then 'If claim just ended is to be excluded from new file, set all of its strlines2 to nothing
'Erase previous claim
For Loop3 = lngClaimStartLoop To Loop2 - 1
strLines2(Loop3) = vbNullString
Next Loop3
End If
'new claim start loop
lngClaimStartLoop = Loop2
'prevents triggering on second HL
boolHLSeenSinceLastClm = True
End If
End If
'Protects against last claim in file never getting erased
If Loop2 = UBound(strLines) Then
'Claim Removal - both types
If boolWriteClaim = False Then 'If claim just ended is to be excluded from new file, set all of its strlines2 to nothing
'Erase previous claim
For Loop3 = lngClaimStartLoop To Loop2 - 3
strLines2(Loop3) = vbNullString
Next Loop3
End If
End If
End If
'Ref*F8 Update
If dictCorrectionOptions("Ref*F8 Update").strOnOffSwitch = "On" Then
'Track current claim number
If Left(strLines(Loop2), 4) = "CLM*" Then strClaimNumber = Mid(strLines(Loop2), 5, InStr(5, strLines(Loop2), "*", vbTextCompare) - 5)
'Replace ICN with correct ICN from crosswalk
If Left(strLines(Loop2), 7) = "REF*F8*" Then
If dictRefF8LookupClaims.Exists(strClaimNumber) Then
strLines2(Loop2) = "REF*F8*" & dictRefF8LookupClaims.Item(strClaimNumber)
Set Cell1 = rngRefF8LookupClaims.Find(What:=strClaimNumber)
If Not (Cell1 Is Nothing) Then Cell1.Offset(0, 2).Value = "Found"
End If
End If
End If
'ICD9 --> ICD10 Conversion
If dictCorrectionOptions("ICD9 --> ICD10 Conversion").strOnOffSwitch = "On" Then
If Left(strLines(Loop2), 3) = "HI*" Then
strLines2(Loop2) = Replace(strLines2(Loop2), "*BK" & strDiagProcIndicator, "*ABK" & strDiagProcIndicator)
strLines2(Loop2) = Replace(strLines2(Loop2), "*BF" & strDiagProcIndicator, "*ABF" & strDiagProcIndicator)
strLines2(Loop2) = Replace(strLines2(Loop2), "*BJ" & strDiagProcIndicator, "*ABJ" & strDiagProcIndicator)
strLines2(Loop2) = Replace(strLines2(Loop2), "*PR" & strDiagProcIndicator, "*APR" & strDiagProcIndicator)
strLines2(Loop2) = Replace(strLines2(Loop2), "*BR" & strDiagProcIndicator, "*BBR" & strDiagProcIndicator)
strLines2(Loop2) = Replace(strLines2(Loop2), "*BQ" & strDiagProcIndicator, "*BBQ" & strDiagProcIndicator)
If Left(strLines(Loop2), 7) = "HI*BBR" & strDiagProcIndicator Then
'Procedure
Long1 = 1
'Get the code, check if it's in the replacement dictionary, then replace
Long1 = InStr(Long1, strLines2(Loop2), strDiagProcIndicator, vbTextCompare)
Do Until Long1 = 0 'Do until it can't find any more codes
'--- Where does the code end? ---
Long2 = InStr(Long1, strLines2(Loop2), "*", vbTextCompare)
'The code might not end if it's the end of the string
If Long2 = 0 Then Long2 = Len(strLines2(Loop2)) + 1
'HI*BR codes are of the format HI*BR:(code):D8:yyyymmdd, code ends before end of the string
If InStr(1, strLines(Loop2), "HI*BR", vbTextCompare) > 0 Then Long2 = InStr(Long1 + 1, strLines2(Loop2), strDiagProcIndicator, vbTextCompare)
'Save the code to check the dictionary
strDiagProcBeingFixed = Mid(strLines2(Loop2), Long1 + 1, Long2 - Long1 - 1)
'If it's in the dictionary...
If dictICDProcs.Exists(strDiagProcBeingFixed) Then
'Trigger warning if code is blank, replace the code
If dictICDProcs(strDiagProcBeingFixed) = vbNullString Then
strLines2(Loop2) = Replace(strLines2(Loop2), strDiagProcBeingFixed, "BADCODE")
If boolCodeWarning = False Then
MsgBox "ICD9 code without ICD10 replacement found in " & strFileName & ", on line " & Loop2 + 1 & ". This claim should be provider corrected if at all possible. This file will have " & """" & "(Code Issues)" & """" & " appended to its file name and will have " & """" & "BADCODE" & """" & " written in the affected diagnosis. This warning will not appear again for this file."
boolCodeWarning = True
End If
Else
strLines2(Loop2) = Replace(strLines2(Loop2), strDiagProcBeingFixed, dictICDProcs(strDiagProcBeingFixed))
End If
'Trigger warning if multiple replacement codes exist
If InStr(1, strDiagProcBeingFixed, ",", vbTextCompare) > 0 Then
strLines2(Loop2) = Replace(strLines2(Loop2), strDiagProcBeingFixed, "BADCODE")
If boolCodeWarning = False Then
MsgBox "ICD9 code with multiple ICD10 replacements found in " & strFileName & ", on line " & Loop2 + 1 & ". This claim should be provider corrected if at all possible. This file will have " & """" & "(Code Issues)" & """" & " appended to its file name and will have " & """" & "BADCODE" & """" & " written in the affected diagnosis. This warning will not appear again for this file."
boolCodeWarning = True
End If
End If
Else
strLines2(Loop2) = Replace(strLines2(Loop2), strDiagProcBeingFixed, "BADCODE")
If boolCodeWarning = False Then
MsgBox strDiagProcBeingFixed & " in " & strFileName & ", on line " & Loop2 + 1 & " does not appear to be a valid ICD-9 procedure code. This claim should be provider corrected if at all possible. This file will have " & """" & "(Code Issues)" & """" & " appended to its file name and will have " & """" & "BADCODE" & """" & " written in the affected diagnosis. This warning will not appear again for this file."
boolCodeWarning = True
End If
End If
'Check if there are more codes
If InStr(1, strLines(Loop2), "HI*BR", vbTextCompare) = 0 Then
Long1 = InStr(Long1 + 1, strLines2(Loop2), strDiagProcIndicator, vbTextCompare)
Else
Long1 = 0
End If
Loop
Else
If Left(strLines(Loop2), 6) <> "HI*DR^" And Left(strLines(Loop2), 6) <> "HI*BE^" And Left(strLines(Loop2), 6) <> "HI*BH^" Then
'Diagnosis
Long1 = 1
'Get the code, check if it's in the replacement dictionary, then replace
Long1 = InStr(Long1, strLines2(Loop2), strDiagProcIndicator, vbTextCompare)
Do Until Long1 = 0 'Do until it can't find any more codes
'--- Where does the code end? ---
Long2 = InStr(Long1, strLines2(Loop2), "*", vbTextCompare)
'The code might not end if it's the end of the string
If Long2 = 0 Then Long2 = Len(strLines2(Loop2)) + 1
'HI*BR codes are of the format HI*BR:(code):D8:yyyymmdd, code ends before end of the string
If InStr(1, strLines(Loop2), "HI*BR", vbTextCompare) > 0 Then Long2 = InStr(Long1 + 1, strLines2(Loop2), strDiagProcIndicator, vbTextCompare)
'Save the code to check the dictionary
strDiagProcBeingFixed = Mid(strLines2(Loop2), Long1 + 1, Long2 - Long1 - 1)
'If it's in the dictionary...
If dictICDDiags.Exists(strDiagProcBeingFixed) Then
'Trigger warning if code is blank, replace the code
If dictICDDiags(strDiagProcBeingFixed) = vbNullString Then
strLines2(Loop2) = Replace(strLines2(Loop2), strDiagProcBeingFixed, "BADCODE")
If boolCodeWarning = False Then
MsgBox "ICD9 code without ICD10 replacement found in " & strFileName & ", on line " & Loop2 + 1 & ". This claim should be provider corrected if at all possible. This file will have " & """" & "(Code Issues)" & """" & " appended to its file name and will have " & """" & "BADCODE" & """" & " written in the affected diagnosis. This warning will not appear again for this file."
boolCodeWarning = True
End If
Else
strLines2(Loop2) = Replace(strLines2(Loop2), strDiagProcBeingFixed, dictICDDiags(strDiagProcBeingFixed))
End If
Else
strLines2(Loop2) = Replace(strLines2(Loop2), strDiagProcBeingFixed, "BADCODE")
If boolCodeWarning = False Then
MsgBox strDiagProcBeingFixed & " in " & strFileName & ", on line " & Loop2 + 1 & " does not appear to be a valid ICD-9 diagnosis code. This claim should be provider corrected if at all possible. This file will have " & """" & "(Code Issues)" & """" & " appended to its file name and will have " & """" & "BADCODE" & """" & " written in the affected diagnosis. This warning will not appear again for this file."
boolCodeWarning = True
End If
End If
'Check if there are more codes
If InStr(1, strLines(Loop2), "HI*BR", vbTextCompare) = 0 Then
Long1 = InStr(Long1 + 1, strLines2(Loop2), strDiagProcIndicator, vbTextCompare)
Else
Long1 = 0
End If
Loop
End If
End If
End If
End If
'<Analyst Name> <State Name> <Vendor Name>
If dictCorrectionOptions("<Analyst Name> <State Name> <Vendor Name>").strOnOffSwitch = "On" Then
If Left(strLines(Loop2), 5) = "SBR*P" Then
If Right(strLines(Loop2), 2) = "HM" Then
strLines2(Loop2) = Left(strLines2(Loop2), Len(strLines2(Loop2)) - 2) & "16"
Else
MsgBox "SBR*P segment that doesn't end with HM found"
End If
End If
If InStr(1, strLines(Loop2), "100640400C", vbTextCompare) > 0 Then
If Left(strLines(Loop2), 6) = "NM1*PR" Then
strLines2(Loop2) = "NM1*PR*2*MMEDSCMS*****PI*H0022"
Else
strLines2(Loop2) = Replace(strLines2(Loop2), "100640400C", "H0022", , , vbTextCompare)
End If
End If
'Crosswalk segment replacement
If Left(strLines(Loop2), 7) = "NM1*IL*" Then strLines2(Loop2) = dictReplacementCrosswalk.Item(strLines(Loop2))
End If
'<Analyst Name> <State Name> <Vendor Name> 2
If dictCorrectionOptions("<Analyst Name> <State Name> <Vendor Name> 2").strOnOffSwitch = "On" Then
'If Left(strLines(Loop2), 4) = "CLM*" Or Left(strLines(Loop2), 3) = "HL*" Then MsgBox ""
If Left(strLines(Loop2), 4) = "CLM*" Then
'Claim Removal - both types
If boolHLSeenSinceLastClm = False Then 'This is the first line of a new claim. Erase previous claim if needed and reset lngClaimStartLoop.
If boolWriteClaim = False Then 'If claim just ended is to be excluded from new file, set all of its strlines2 to nothing
'Erase previous claim
For Loop3 = lngClaimStartLoop To Loop2 - 1
strLines2(Loop3) = vbNullString
Next Loop3
End If
'New claim start loop
lngClaimStartLoop = Loop2
'Check if claim on this line should be written
'Prepare default assumption
boolWriteClaim = False
'Make final determination
strClaimNumber = Mid(strLines(Loop2), 5, InStr(5, strLines(Loop2), "*", vbTextCompare) - 5)
If dictClaimFileCrosswalk.Exists(strClaimNumber) And strFileName = dictClaimFileCrosswalk.Item(strClaimNumber) Then
boolWriteClaim = True
Set Cell1 = rngClaimRemoval.Find(What:=strClaimNumber)
If Not (Cell1 Is Nothing) Then Cell1.Offset(0, 2).Value = "Found"
End If
'boolHLSeenSinceLastClm does not need to be reset to false because it is already false.
Else 'This is the middle of an ongoing claim that started with an HL* segment. Do not write anything now and do not reset lngClaimStartLoop. Just determine if the ongoing claim whose CLM number we just hit will be written.
'Prepare default assumption
boolWriteClaim = False
'Make final determination
strClaimNumber = Mid(strLines(Loop2), 5, InStr(5, strLines(Loop2), "*", vbTextCompare) - 5)
If dictClaimFileCrosswalk.Exists(strClaimNumber) And strFileName = dictClaimFileCrosswalk.Item(strClaimNumber) Then
boolWriteClaim = True
Set Cell1 = rngClaimRemoval.Find(What:=strClaimNumber)
If Not (Cell1 Is Nothing) Then Cell1.Offset(0, 2).Value = "Found"
End If
boolHLSeenSinceLastClm = False 'This is currently true. We need to reset it to help determine when the next claim starts.
End If
End If
If Left(strLines(Loop2), 3) = "HL*" Then
'If not second HL, this is the first line of a new claim. Erase previous claim if needed and reset lngClaimStartLoop.
If boolHLSeenSinceLastClm = False Then
If boolWriteClaim = False Then 'If claim just ended is to be excluded from new file, set all of its strlines2 to nothing
'Erase previous claim
For Loop3 = lngClaimStartLoop To Loop2 - 1
strLines2(Loop3) = vbNullString
Next Loop3
End If
'new claim start loop
lngClaimStartLoop = Loop2
'prevents triggering on second HL
boolHLSeenSinceLastClm = True
End If
End If
'Protects against last claim in file never getting erased
If Loop2 = UBound(strLines) Then
'Claim Removal - both types
If boolWriteClaim = False Then 'If claim just ended is to be excluded from new file, set all of its strlines2 to nothing
'Erase previous claim
For Loop3 = lngClaimStartLoop To Loop2 - 3
strLines2(Loop3) = vbNullString
Next Loop3
End If
End If
End If
Next Loop2
'Write original and updated segments to worksheet via arrays, highlight differences
With Sheet1
'Transpose manually due to 65536 row Transpose limit
ReDim strLinesTransposed(LBound(strLines) To UBound(strLines), 0 To 0)
For Loop2 = LBound(strLinesTransposed) To UBound(strLinesTransposed)
strLinesTransposed(Loop2, 0) = strLines(Loop2)
Next Loop2
ReDim strLines2Transposed(LBound(strLines2) To UBound(strLines2), 0 To 0)
For Loop2 = LBound(strLines2Transposed) To UBound(strLines2Transposed)
strLines2Transposed(Loop2, 0) = strLines2(Loop2)
Next Loop2
.Cells(1, 1).Resize(UBound(strLinesTransposed)) = strLinesTransposed
.Cells(1, 2).Resize(UBound(strLines2Transposed)) = strLines2Transposed
For Loop2 = LBound(strLines) To UBound(strLines)
If strLines(Loop2) <> strLines2(Loop2) Then .Cells(Loop2 + 1, 1).EntireRow.Interior.ColorIndex = 6
Next Loop2
End With
'--- Write updated segments to new file ---
strText2 = Join(strLines2, strNewLineCharacter)
'Eliminate blank lines due to claim removal
Do Until InStr(1, strText2, strNewLineCharacter & strNewLineCharacter, vbTextCompare) = 0
strText2 = Replace(strText2, strNewLineCharacter & strNewLineCharacter, strNewLineCharacter)
Loop
'Eliminate blank line(s) at end of file, if any
Do Until Right(strText2, 1) <> strNewLineCharacter
strText2 = Left(strText2, Len(strText2) - 1)
Loop
Int1 = FreeFile()
If boolCodeWarning = False Then
Open Variant1(Loop1) & " Fixed.txt" For Output As #Int1
Else
Open Variant1(Loop1) & " Fixed (Code Issues).txt" For Output As #Int1
End If
Print #Int1, strText2
Close #Int1
Next Loop1
'-- All Done --
MsgBox "All 837 files fixed and saved to the same folders as the source files with " & """" & "Fixed" & """" & "added to their filenames. No original files have been modified."
Cancel:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub
classUserSettings
Private pstrCorrectionType As String
Private pstrOnOffSwitch As String
Private pstrSettingsSheet As String
'pstrCorrectionType Properties
Public Property Get strCorrectionType() As String
strCorrectionType = pstrCorrectionType
End Property
Public Property Let strCorrectionType(Value As String)
pstrCorrectionType = Value
End Property
'pstrSwitch Properties
Public Property Get strOnOffSwitch() As String
strOnOffSwitch = pstrOnOffSwitch
End Property
Public Property Let strOnOffSwitch(Value As String)
pstrOnOffSwitch = Value
End Property
'pstrSettingsSheet Properties
Public Property Get strSettingsSheet() As String
strSettingsSheet = pstrSettingsSheet
End Property
Public Property Let strSettingsSheet(Value As String)
pstrSettingsSheet = Value
End Property