Fixing Medical Claim Files through Text File Read/Write

Question

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

Answer 1

I can't begin to comprehend exactly what this code is doing, but I saw a few things worth pointing out. First, it seems as though your dictCorrectOptions mostly is used to check for strOnOffSwitch. With this in mind, I would recommend changing strOnOffSwitch to a boolean value instead, and use some kind of data validation to set it from a string to a boolean value. This would allow you to do something like:

If dictCorrectionOptions("Claim Removal - Have Wanted Claims").strOnOffSwitch

Next, you may want to consider setting this as the default member of your class since it is the one you use the most. Chip Pearson offers a tutorial: http://www.cpearson.com/excel/DefaultMember.aspx .

Next, extract this:

If dictCorrectionOptions("Claim Removal - Have Wanted Claims").strOnOffSwitch = "On" Then
    boolWriteClaim = True
Else
    boolWriteClaim = False
End If

To a function, or better yet do something like this:

boolWriteClaim = dictCorrectionOptions("").strOnOffSwitch

This will only work of course once you turn your switch to a boolean value.

Also, what is this loop trying to do? From what I can tell, you are looping through a range to search for some kind of string, once found you overwrite your boolean value (with no regard to its previous state) and enter some text on the sheet. You then exit the loop once it is found. What confuses me mostly is that this bit of code seems to simply just find a cell and write found (and change the boolean).

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

I am sure I am missing something here, but it seems obscure. Further, I notice that this bit has been copied and pasted a few times in your code. As Raystafarian noted, your code is in dire need of refactoring. A good rule of thumb (that I use at least) is if I am copying and pasting code then I probably need to write a sub or a function and use variables. Your loop could be refactored to something like this:

Function bWriteClaimCheck (rSearchArea as Range, sSearchItem as String, bSwitch as Boolean) As Boolean
    Dim rCell as Range

    For Each rCell In rSearchArea 
        If InStr(1, sSearchItem , rCell.Value, vbTextCompare) > 0 Then
            If dictCorrectionOptions("Claim Removal - Have Wanted Claims").strOnOffSwitch = "On" Then
            rCell.Offset(0, 1).Value = "Found"
            bWriteClaimCheck  = bSwitch
            Exit Function
        End If
    Next rCell 
    bWriteClaimCheck = False ' I think default is false so this probably isnt needed.
End Function

Now you can use this function all you want, but if you ever need to fix a bug within it, you just edit the function. You dont have to instead find all the places where you copied and pasted code.

I would recommend really evaluating all of your code and extracting anything you can. While it can be a bit of a pain at first, especially with more complex code, it will not only teach you to become a better programmer but it will also make your code much easier to read and debug.

Finally, your code is literally just one giant method as is. I dont know know if this is just me or not, but I much prefer to cut up my code into subroutines that handle certain tasks. For example, you could have a subroutine that prepares your variables, another that makes decisions, and another that outputs the data. It is easy enough to pass variables between subs, and it makes it easier to manage everything. To me, part of the biggest benefit, is that you can declare only the variables you need for that subroutine instead of declaring a bunch of temp variables that are used to just hold information. When you have that many variables in one method you are bound to run out of descriptive and useful names for them and you will default to things like "Long1".

An additional benefit to slicing up your code (however slight) is you will have fewer variables being held in memory that will never be used again. For example, if you have a variable you need that is just used for getting things ready, you likely wont need it later and it will just sit in memory doing nothing.

I am sure there are other optimizations that can be made. Part of me wonders if you could extract the majority of these methods to a class that takes input settings and is 'fed' a document that it then properly formats and holds onto. I dont know exactly what this would look like, but it might be an approach to consider down the road.

Answer 2

I'll kick us off with some general observations -

You probably haven't counted, but you have a procedure that's 696 lines long.

Your macro is too long! You can probably extract some functions or other procedures out and refactor the code to utilize functions instead of repeating code, but also to break up the code. Like you mentioned, you were thinking in "code blocks" and whatnot - there's no need to put yourself through that!

In terms of how long the code is and how difficult it may be to maintain, I see a lot of comments. Comments - "code tell you how, comments tell you why". The code should speak for itself, if it needs a comment, it might need to be made more clear. If not, the comment should describe why you're doing something rather than how you're doing it. Here are a few reasons to avoid comments all together.

For every Integer you dimensioned, change it to a Long - Integers - integers are obsolete. According to msdn VBA silently converts all integers to long.

---

Variables

Let me take a moment to tell you great job declaring all of your variables. I mean it.

And great job sticking to Standard VBA naming conventions.

But, this Hungarian notation isn't adding anything to the code. With variable names - give your variables meaningful names.

Dim strText

I know that Text is a string - you don't need to tell me that. What you do need to tell me is what the heck text it is. Is it a search string? A temporary string for swapping? I don't know, the first time I encounter it is here

strText = Space$(LOF(Int1))

Which, as you can see, the other names would require me to track back all the way up to their definitions before I could take a guess at what text we're talking about.

'--- 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 
Dim Sheet1 As Worksheet
Dim Range1 As Range
Dim Cell1 As Range
Dim String1 As String
Dim Bool1 As Boolean

I see, you tried naming them as generically as you could so you could reuse them, but that only hurts you down the line. Right,

For Loop1 = LBound(Variant1) To UBound(Variant1)

Without that name, I know you're doing a loop by the For and I also know it's going to be Long You could use something descriptive here. I'd give an example, but I'd have to go figure out what Variant1 is. I guess for example, it could be variant1Index, but only after you tell me what Variant1 is; see the vicious cycle you'll run into? You want to make it easy to jump back in and tweak it. Right now, say 7 months from now, you'll come back to this and say "wait, what's in that variant" whereas if you called it something like patientIDs or even patientArray you'd know what it is.

Similar to

Bool1 = False

I mean, I know it's boolean and it will be 1 or 0, but what are we possibly checking here? No idea.

And I'm not being mean here, I promise, but this line of code -

strDiagProcBeingFixed = Mid(strLines2(Loop2), Long1 + 1, Long2 - Long1 - 1)

it's my favorite line of code ever. I couldn't even begin to guess what's happening in that Mid - it's incredible.

---

Arrows

Arrow code is something I see you're struggling with here - we all have!

GOTO

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

Watch out!

Handle those errors. In this case your Cancel label is is 579 lines away from your GoTo. You catch my drift.

Speaking of that piece of code,

MsgBox "Both " & """" & "Claim Removal" & """" & " correction options on the " & """" & "Correction Type Options" & """" & " are On. Please turn at least one Off."

What's going on here? To me, that looks like a case for a constant:

Const OPTION_TURN_OFF_MESSAGE As String = "Both " & """" & "Claim Removal" & """" & " correction options on the " & """" & "Correction Type Options" & """" & " are On. Please turn at least one Off."

Now all you need to go is Msgbox OPTION_TURN_OFF_MESSAGE and since it's a constant, you can change it at the constant declaration instead of in the code. And if you reuse it - bonus!

You can see it would be more useful in cases like this-

strLines2(Loop2) = "NM1*PR*2*MMEDSCMS*****PI*H0022"

---

Dim Sheet1 As Worksheet

Oh, so worksheets have a CodeName property - View Properties window (F4) and the (Name) field (the one at the top) can be used as the worksheet name. This way you can avoid Sheets("mySheet") and instead just use mySheet. In this case, Sheet1 is a default codename, so when I see that, I'm certainly not expecting it to be the object of a For loop!