紙カルテからJOSLER作成 検査値

 一度に自動でJOSLER作成は難しそうです　

部分的に入力の手間を省くという意味でせめて最も入力回数が多い　検査項目　だけでも無理やり自動化させました。

text file カルテ原文　→　エクセル VBA → 検査項目の文字列　

とカルテ原文から欲しい検査項目を抽出してJOSLERにそのままコピペできるような形に出力します

excelファイルを作るまでは面倒ですが, 一度作ってしまえば次からは検査項目を手入力するのは不要になります。

3種類のコードを作成しました　それぞれのコードの意味は

① カルテ原文から検査値のみを抜き出す ② 各科 (今回は循環器, 腎臓, 血液のtemplateを作成しました) で必要な検査項目に振り分ける ③ 文字列の形として再構成

① カルテ原文から検査値のみを抜き出す 

まずはエクセルのテンプレートをつくります　sheet1 のDEF循環器 GHI血液 JKL循環器で必要な検査項目が表示 されるようにしています。sheet 2にはそれらの文字列が出力されるように用意しています。

ここからダウンロード→exceltemplate

excelfileのsheet A1 をダブルクリックして, カルテの原文textを貼り付けます。

① ReplaceAndSplit_A1()

A1内の文字列から検査項目を抽出し A列に検査項目種類 B列に数字を表示するマクロです。

Sub ReplaceAndSplit_A1()
    Dim cell As Range
    Dim data As Variant
    Dim splitData() As String
    Dim i As Long
    Dim ws As Worksheet
    Dim lastRow As Long

    ' アクティブシートを選択します
    Set ws = ActiveSheet

    ' A1セルを操作対象として設定します
    Set cell = ws.Range("A1")

    ' 対象のセルに対して、改行と全角カンマの置換、および検査項目と検査値の分割を実行します
    cell.Value = Replace(cell.Value, Chr(10), "")
    cell.Value = Replace(cell.Value, "，", ", ")
    data = Split(cell.Value, ",")
    For i = LBound(data) To UBound(data)
        splitData = Split(Trim(data(i)))
        If UBound(splitData) >= 1 Then
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
            ws.Cells(lastRow, "A").Value = splitData(0)
            ws.Cells(lastRow, "B").Value = splitData(1)
        End If
    Next i
End Sub

AB列に検査項目が出力されました。

②-1 InputTestValuesWithAlternativeNames 

ABの列から循環器の項目があればE列に出力するマクロです

Sub InputTestValuesWithAlternativeNames()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim lastRowD As Long
    Dim i As Long
    Dim j As Long
    Dim targetItem As String
    Dim targetValue As Variant

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastRowD = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    For i = 1 To lastRowD
        targetItem = ws.Cells(i, "D").Value
        
        For j = 1 To lastRow
            If ws.Cells(j, "A").Value = targetItem Or _
               (targetItem = "白血球" And ws.Cells(j, "A").Value = "WBC") Or _
               (targetItem = "尿酸" And ws.Cells(j, "A").Value = "UA") Or _
               (targetItem = "赤血球" And ws.Cells(j, "A").Value = "RBC") Or _
               (targetItem = "血小板" And ws.Cells(j, "A").Value = "PLT") Or _
               (targetItem = "総ビリルビン" And (ws.Cells(j, "A").Value = "T-Bil" Or ws.Cells(j, "A").Value = "T.Bil")) Or _
               (targetItem = "トリグリセリド" And ws.Cells(j, "A").Value = "TG") Or _
               (targetItem = "Ht" And ws.Cells(j, "A").Value = "HCT") Or _
               (targetItem = "Hb" And ws.Cells(j, "A").Value = "HGB") Or _
               (targetItem = "LD" And (ws.Cells(j, "A").Value = "LD_IFCC" Or ws.Cells(j, "A").Value = "LDH")) Or _
               (targetItem = "γ-GTP" And ws.Cells(j, "A").Value = "7-GTP") Or _
               (targetItem = "Cr" And ws.Cells(j, "A").Value = "Cre") Or _
               (targetItem = "HbA1c" And ws.Cells(j, "A").Value = "HbA1c(NGSP)") Or _
               (targetItem = "Cl" And (ws.Cells(j, "A").Value = "CI" Or ws.Cells(j, "A").Value = "C1")) Or _
               (targetItem = "Hb" And ws.Cells(j, "A").Value = "HGB") Then
                targetValue = ws.Cells(j, "B").Value
                ws.Cells(i, "E").Value = targetValue
                Exit For
End If
        Next j
    Next i
End Sub

Eに検査値が出力されました 同様に 血液, 腎臓でも同じことを繰り返します。

②-2 InputTestValuesWithAlternativeNames_GtoH

ABの列から血液の項目があればH列に出力するマクロです

  Sub InputTestValuesWithAlternativeNames_GtoH()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim lastRowG As Long
    Dim i As Long
    Dim j As Long
    Dim targetItem As String
    Dim targetValue As Variant

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastRowG = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row

    For i = 1 To lastRowG
        targetItem = ws.Cells(i, "G").Value
        
        For j = 1 To lastRow
            If ws.Cells(j, "A").Value = targetItem Or _
               (targetItem = "白血球" And ws.Cells(j, "A").Value = "WBC") Or _
               (targetItem = "Ly" And (ws.Cells(j, "A").Value = "LYMP" Or ws.Cells(j, "A").Value = "LYM%")) Or _
               (targetItem = "Eo" And (ws.Cells(j, "A").Value = "EOS" Or ws.Cells(j, "A").Value = "EOS%")) Or _
               (targetItem = "Mono" And (ws.Cells(j, "A").Value = "MONO" Or ws.Cells(j, "A").Value = "MONO%")) Or _
               (targetItem = "尿酸" And ws.Cells(j, "A").Value = "UA") Or _
               (targetItem = "赤血球" And ws.Cells(j, "A").Value = "RBC") Or _
               (targetItem = "血小板" And ws.Cells(j, "A").Value = "PLT") Or _
               (targetItem = "総ビリルビン" And (ws.Cells(j, "A").Value = "T-Bil" Or ws.Cells(j, "A").Value = "T.Bil")) Or _
               (targetItem = "トリグリセリド" And ws.Cells(j, "A").Value = "TG") Or _
               (targetItem = "Ht" And ws.Cells(j, "A").Value = "HCT") Or _
               (targetItem = "Hb" And ws.Cells(j, "A").Value = "HGB") Or _
               (targetItem = "LD" And (ws.Cells(j, "A").Value = "LD_IFCC" Or ws.Cells(j, "A").Value = "LDH")) Or _
               (targetItem = "γ-GTP" And ws.Cells(j, "A").Value = "7-GTP") Or _
               (targetItem = "Cr" And ws.Cells(j, "A").Value = "Cre") Or _
               (targetItem = "HbA1c" And ws.Cells(j, "A").Value = "HbA1c(NGSP)") Or _
               (targetItem = "Cl" And (ws.Cells(j, "A").Value = "CI" Or ws.Cells(j, "A").Value = "C1")) Or _
               (targetItem = "Hb" And ws.Cells(j, "A").Value = "HGB") Then
                targetValue = ws.Cells(j, "B").Value
                ws.Cells(i, "H").Value = targetValue
                Exit For
            End If
        Next j
    Next i
End Sub

②-3 InputTestValuesWithAlternativeNames_JtoK

腎臓の項目をKに出力

Sub InputTestValuesWithAlternativeNames_JtoK()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim lastRowJ As Long
    Dim i As Long
    Dim j As Long
    Dim targetItem As String
    Dim targetValue As Variant

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastRowJ = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row

    For i = 1 To lastRowJ
        targetItem = ws.Cells(i, "J").Value
        
        For j = 1 To lastRow
            If ws.Cells(j, "A").Value = targetItem Or _
               (targetItem = "白血球" And ws.Cells(j, "A").Value = "WBC") Or _
               (targetItem = "Ly" And (ws.Cells(j, "A").Value = "LYMP" Or ws.Cells(j, "A").Value = "LYM%")) Or _
               (targetItem = "Eo" And (ws.Cells(j, "A").Value = "EOS" Or ws.Cells(j, "A").Value = "EOS%")) Or _
               (targetItem = "Mono" And (ws.Cells(j, "A").Value = "MONO" Or ws.Cells(j, "A").Value = "MONO%")) Or _
               (targetItem = "尿酸" And ws.Cells(j, "A").Value = "UA") Or _
               (targetItem = "赤血球" And ws.Cells(j, "A").Value = "RBC") Or _
               (targetItem = "血小板" And ws.Cells(j, "A").Value = "PLT") Or _
               (targetItem = "総ビリルビン" And (ws.Cells(j, "A").Value = "T-Bil" Or ws.Cells(j, "A").Value = "T.Bil")) Or _
               (targetItem = "トリグリセリド" And ws.Cells(j, "A").Value = "TG") Or _
               (targetItem = "Ht" And ws.Cells(j, "A").Value = "HCT") Or _
               (targetItem = "Hb" And ws.Cells(j, "A").Value = "HGB") Or _
               (targetItem = "LD" And (ws.Cells(j, "A").Value = "LD_IFCC" Or ws.Cells(j, "A").Value = "LDH")) Or _
               (targetItem = "γ-GTP" And ws.Cells(j, "A").Value = "7-GTP") Or _
               (targetItem = "Cr" And ws.Cells(j, "A").Value = "Cre") Or _
               (targetItem = "HbA1c" And ws.Cells(j, "A").Value = "HbA1c(NGSP)") Or _
               (targetItem = "Cl" And (ws.Cells(j, "A").Value = "CI" Or ws.Cells(j, "A").Value = "C1")) Or _
               (targetItem = "Hb" And ws.Cells(j, "A").Value = "HGB") Then
                targetValue = ws.Cells(j, "B").Value
                ws.Cells(i, "K").Value = targetValue
                Exit For
            End If
        Next j
    Next i
End Sub

すべての項目が出力されました。

③ 文字列の形に再構成

検査項目と数値がセルで分割されてますので文字列として再構成します。

> ③-1 CombineResultsB2

循環器（D：項目E：数値F：単位）のE列(数値)をsheet 2のB2に出力します　

Sub CombineResultsB2()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim result As String
    
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    
    ' 検査項目の範囲を調整してください
    For i = 1 To 26
        result = result & ws1.Cells(i, 4).Value & " " & ws1.Cells(i, 5).Value & " " & ws1.Cells(i, 6).Value
        If i < 26 Then
            result = result & ", "
        End If
    Next i
    
    ' 結果をシート2のセルB2に表示
    ws2.Cells(2, 2).Value = result
End Sub

③-2 CombineResultsB3

③-3 CombineResultsB4

同様に血液, 腎臓もsheet2に出力します。

Sub CombineResultsB3()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim result As String
    
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    
    ' 検査項目の範囲を調整してください
    For i = 1 To 33
        result = result & ws1.Cells(i, 7).Value & " " & ws1.Cells(i, 8).Value & " " & ws1.Cells(i, 9).Value
        If i < 33 Then
            result = result & ", "
        End If
    Next i
    
    ' 結果をシート2のセルB3に表示
    ws2.Cells(3, 2).Value = result
End Sub

Sub CombineResultsB4()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim result As String
    
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    
    ' 検査項目の範囲を調整してください
    For i = 1 To 35
        result = result & ws1.Cells(i, 10).Value & " " & ws1.Cells(i, 11).Value & " " & ws1.Cells(i, 12).Value
        If i < 35 Then
            result = result & ", "
        End If
    Next i
    
    ' 結果をシート2のセルB4に表示
    ws2.Cells(4, 2).Value = result
End Sub

すべての文字列がsheet2に出力されました。

①-③をすべて実行するコードです。

Sub RunAllMacros()

Call ReplaceAndSplit_A1
Call InputTestValuesWithAlternativeNames
Call InputTestValuesWithAlternativeNames_GtoH
Call InputTestValuesWithAlternativeNames_JtoK
Call CombineResultsB2
Call CombineResultsB3
Call CombineResultsB4

End Sub