カルテから症例報告作成

Chat GPT 4で内科医の仕事効率化をめざします。

GPTは検索はもちろんのと書類仕事　カルテ, 紹介状の作成など威力を発揮します。

論文, 記事, 症例報告(J-OSLER含む?!)など個人PCで行う書類作成はGPTが登場して快適になりつつあります。

IT社会になりつつあるがいまだに手書き文化が残っている医学会(カルテ→退院サマリ→J-OSLERと何回同じことを入力させるのか...)　せっかくAIが登場しましたのでぜひ手伝っていただきましょう

最終的な目的は　症例報告, JOSLERの文章の骨格（考察以外を）ワンクリックでつくることです。

プログラミング, visual basicなどほとんど知識がありませんがGPT にこういうコードを作って欲しいと指示することで作成できました。

クリックのみでパワーポイントで症例報告のスライドができてます。患者のword file(メモ帳)からパワーポイント出力まで 1分 以内で作成できました。　紙カルテ(個人情報をmaskして, scan→OCR)からパワーポイントへの出力も可能です。

① テキストファイルを用意

メモ帳>word (word自体に書式などの情報が多かったり, マクロがすでに埋め込まれていたらうまくいかないこと多いのでmemo帳が安定しています) wordにコピペ　主訴, 現病歴, 検査データふくめ全て

② アウトラインの設定

表示→アウトラインからタイトル(例えば25歳男性)を「アウトライン1」に

それ以外を「本文」に設定します

※パワーポイントではアウトライン1段落毎に新しいスライドを設定するためです※

③ マクロ　アウトライン　レベルの設定, 改行の3つのマクロを実行します

1. アウトライン1 には主訴, 現病歴, 血液検査など ページを切り替え(新しいスライドで改ページし)たい単語に設定します。

2. アウトライン2には既往歴など設定しています。アウトライン2は特に設定しなくてもいい気がします

3. Lの後の改行を消去するマクロ　

word→alt+f11でVB起動→挿入→標準モジュール　

下のコードをコピペします

1-3 すべてコピペし　全て実行(f5)します

各キーワードに対してアウトラインが設定されました

↓　マクロ　コード↓

1. outline 1の設定

Sub SetOutlineLevel2ForMultipleKeywords()
    Dim keywords() As Variant
    Dim keyword As Variant
    Dim targetRange As Range
    
    ' キーワードの配列を作成し、検索したい単語を設定します
    keywords = Array("主訴", "現症", "症例", "検査所見", "血液所見", "入院後経過と考察", "入院後経過", "プロブレムリスト", "総合考察")

    ' 配列内の各キーワードに対して、検索とアウトラインレベル1の設定を行う
    For Each keyword In keywords
        With ActiveDocument.Content.Find
            .ClearFormatting
            .Text = keyword
            .Forward = True
            .Wrap = wdFindStop
            .Execute
            While .Found
                Set targetRange = ActiveDocument.Range(Start:=.Parent.Start, End:=.Parent.End)
                targetRange.ParagraphFormat.OutlineLevel = wdOutlineLevel1
                .Execute
            Wend
        End With
    Next keyword
End Sub

２. outline 2の設定

Sub SetOutlineLevel2ForMultipleKeywords()
    Dim keywords() As Variant
    Dim keyword As Variant
    Dim targetRange As Range
    
    ' キーワードの配列を作成し、検索したい単語を設定します
    keywords = Array("現病歴", "既往歴", "生活歴", "内服歴", "家族歴", "入院後経過")

    ' 配列内の各キーワードに対して、検索とアウトラインレベル2の設定を行う
    For Each keyword In keywords
        With ActiveDocument.Content.Find
            .ClearFormatting
            .Text = keyword
            .Forward = True
            .Wrap = wdFindStop
            .Execute
            While .Found
                Set targetRange = ActiveDocument.Range(Start:=.Parent.Start, End:=.Parent.End)
                targetRange.ParagraphFormat.OutlineLevel = wdOutlineLevel2
                .Execute
            Wend
        End With
    Next keyword
End Sub

3. Lの後の改行を消去

Sub RemoveLineBreakAfterSpecificWord()
    Dim findText As String
    Dim oRange As Range
    
    findText = "L"
    
    With ActiveDocument.Content.Find
        .ClearFormatting
        .Text = findText & "^p"
        .Forward = True
        .Wrap = wdFindStop
        .Execute
        While .Found
            Set oRange = ActiveDocument.Range(Start:=.Parent.Start, End:=.Parent.End)
            oRange.Text = findText & " "
            .Execute
        Wend
    End With
End Sub

④ パワーポイント　

挿入→新しいスライド→アウトラインから

検査値のテキストデータを　アクティブ　マクロで表を作成　(同じスライド内にtitleウィンドウがあれば手動で消してください)

スキャナーから紙の電子カルテを取り込みPDFfileのOCR処理という手順をふめば紙媒体からもパワーポイントが一瞬で作れました

↓パワーポイント側で使うマクロです↓

検査値からn行2列の表をつくるマクロです　(テキストボックスをアクティブにして実行してください)

Sub CreateTableFromText()
    Dim text As String
    Dim data() As String
    Dim numRows As Integer
    Dim i As Integer
    Dim dataTable As Table
    Dim slide As slide

    ' Get the active slide
    Set slide = ActiveWindow.View.slide

    ' Get the text from the selected text box
    text = slide.Shapes(1).TextFrame.TextRange.text

    ' Replace full-width comma with half-width comma
    text = Replace(text, "，", ",")

    ' Split the text by comma
    data = Split(text, ",")

    ' Calculate the number of rows
    numRows = UBound(data) - LBound(data) + 1

    ' Create a table with numRows rows and 2 columns
    Set dataTable = slide.Shapes.AddTable(numRows, 2, 0, 0, 500, 300).Table

    ' Populate the table
    For i = LBound(data) To UBound(data)
        ' Split the data element into label and value
        Dim parts() As String
        parts = Split(Trim(data(i)), " ", 2)

        ' Set the label and value in the table
        dataTable.Cell(i + 1, 1).Shape.TextFrame.TextRange.text = parts(0)
        If UBound(parts) > 0 Then
            dataTable.Cell(i + 1, 2).Shape.TextFrame.TextRange.text = parts(1)
        End If
    Next i
End Sub

macroの役割

lbreak: 検査値"L"の後にある改行（行の終わり）を削除し、単語と単語の間にスペースを挿入する　検査値はdLなどLで終わることが多いので　これを作ったらうまくいきました