Makros für Radiologen: Makro zum Report der lumbalen Knochendichtemessung mit QCT: Makro Osteodensitometrie

Links hinzufügen
Aus Wikibooks

Diese Makros gehören zu Makro zum Report der lumbalen Knochendichtemessung mit QCT.

Im Quellcode werden folgende Makros aufgerufen: 

***********************************
Option Explicit

Public ODMESSP As String : Dim KND As Byte : Dim JGKND As Variant : 
Dim ODSTREU As String : Dim MINKND As Variant : Dim TSCORE As Single : 
Dim ZSCORE As Single : Dim TTSCORE As Single : Dim ZZSCORE As Single : 
Dim ODVORAUFN As Byte : Dim AZSCORE As Single : Dim ODASTREU As Byte : 
Public ODINDIK As String : Public ODREPORT As Variant : Dim ALTERSGR As String : 
Dim WHO As String : Dim ODVERGLEICH As String : Dim ODVORDATUM As Date : 
Dim ODDATUM As Date :  Dim ODGESCHL As Byte : Dim DIFFZSCORE As Single : 
Dim ODKORR As Byte : Dim ODSTREUTEXT As String : Dim DATENB As String

------------------

Sub makroOD()

'*****Initialisieren*******

KND = 0 : JGKND = 0 : ODSTREU = "" : TSCORE = 0 : ZSCORE = 0 : ODVORAUFN = 0 : 
AZSCORE = 0 : ODASTREU = 0 : ODINDIK = "" : ODREPORT = "" : ALTERSGR = "" : 
WHO = "" : ODVERGLEICH = "" : ODVORUNT = "" :  ODVORDATUM = "1.1.1900" : 
ODDATUM = "1.1.1900" : ODGESCHL = 0 : DIFFZSCORE = 0 : ODKORR = 0 : 
ODSTREUTEXT = "" : DATENB = ""

'***********Erfassen

ODDATUM = MsgBox("Messung von heute?", vbYesNo + vbQuestion)

If ODDATUM = 7 Then
    ODDATUM = InputBox("Datum der Untersuchung?")
    'Eingabe prüfen
Else
    ODDATUM = Date
End If

ODGESCHL = MsgBox("Weiblich?", vbYesNo + vbQuestion)

'******Auswahl der Messpunkte*************

' siehe [[Makros für Radiologen: Makro zum Report der lumbalen Knochendichtemessung mit QCT: 
'         Makro Osteodensitometrie: ODfrmMessP]]
ODfrmMessP.Show

'*******Abfrage der Knochendiche und Streuung********

KND = InputBox("Knochendichte ohne Kommastellen?")

ODSTREU = MsgBox("Streuung klein (Ringe überlagern sich alle und liegen dicht beieinander)? Wenn Streuung sehr gross (Ringe überlagern sich nicht alle, dann Abbrechen", vbYesNoCancel + vbQuestion)

If ODSTREU = 2 Then
    MINKND = InputBox("Kleinste gemessene Knochendichte ohne Kommastellen?")
    MINKND = "Die kleinste gemessene Dichte beträgt " & MINKND & " mg/ml. "
End If

'***********Knochendichte des Jahrgangs abfragen *****************

JGKND = InputBox("mittlere Knochendichte des Jahrganges ohne Kommastellen? 0 wenn keine mehr angegeben wird")

If JGKND = 0 Then
JGKND = InputBox("mittlere geschätzte Knochendichte des Jahrganges ohne Kommastellen?")
JGKND = "extrapoliert, da für das Alter des Patienten keine Daten in der Siemens Somatom Datenbank sind:" & JGKND
End If

    'Eingabe prüfen

ZSCORE = InputBox("Z-Score / geschätzt / bei sehr großer Streuung vom Minimum")

TSCORE = InputBox("T-Score / geschätzt / bei sehr großer Streuung vom Minimum")

'*********fragen nach Voruntersuchungen**************
ODVORAUFN = MsgBox("Voruntersuchung?", vbYesNo + vbQuestion)

If ODVORAUFN = 6 Then
    AZSCORE = InputBox("Alter Z-Score / geschätzt?")
    ODASTREU = MsgBox("Streuung klein (Ringe überlagern sich alle und liegen dicht beieinander? Wenn sehr gross (Ringe überlagern sich nicht alle , dann Abbrechen", vbYesNoCancel + vbQuestion)
    DIFFZSCORE = ZSCORE - AZSCORE
    ODVORDATUM = InputBox("Datum der Untersuchung?")
    'Datumseingabe prüfen
    ODVORUNT = "Am " & ODVORDATUM & " betrug der Z- Score " & AZSCORE & " . "
End If

ODINDIK = ""

' siehe [[Makros für Radiologen: Makro zum Report der lumbalen Knochendichtemessung mit QCT: 
'         Makro Osteodensitometrie: ODfrmIndik]]
ODfrmIndik.Show

'********* Bewertung
'WHO: Zuornung von Text den Bereichen des T- Scores*************
'
Select Case TSCORE
Case Is > -1
    If ODGESCHL = 6 Then
        WHO = "Eine Osteoporose oder Osteopenie liegt nach WHO  Kriterien nicht vor."
    Else
        WHO = "Eine Osteoporose oder Osteopenie liegt bei analoger Anwendung der für Frauen definierten WHO Kriterien nicht vor."
    End If
Case -2.49 To -1
    If ODGESCHL = 6 Then
        WHO = "Nach WHO Kriterien besteht eine Osteopenie."
    Else
        WHO = "Bei analoger Anwendung der für Frauen definierten WHO Kriterien besteht eine Osteopenie."
    End If
Case Is <= -2.5
    If ODGESCHL = 6 Then
        WHO = "Nach WHO Kriterien besteht eine Osteoporose."
    Else
        WHO = "Bei analoger Anwendung der für Frauen definierten WHO Kriterien besteht eine Osteoporose."
    End If
End Select
'
'ALTERSGR : Zuordnung von Text den Bereichen des Z-Scores*******
'
Select Case ZSCORE
Case Is > 1.5
    ALTERSGR = "Im Vergleich zur Altersgruppe sehr hohe und damit möglicherweise pathologische Kochendichte. "
Case -0.49 To 1.49
    ALTERSGR = "Im Vergleich zur Altersgruppe normale Kochendichte. "
Case -0.99 To -0.5
    ALTERSGR = "Im Vergleich zur Altersgruppe niedrige Kochendichte. "
Case -2 To -1
    ALTERSGR = "Im Vergleich zur Altersgruppe sehr niedrige Kochendichte. "
Case Is < -2
    ALTERSGR = "Im Vergleich zur Altersgruppe extrem niedrige Kochendichte. "
End Select
'
'ODVERGLE: Vergleich des Zscores abhängig von der Grösse der Streuung*****
'
If ODVORAUFN = 6 Then 'wenn es Voraufnahmen gibt******
    If ODSTREU = 6 And ODASTREU = 6 Then 'wenn Streuung groß***
    ' gleich geblieben
        Select Case DIFFZSCORE
        Case -0.2 To 0.2
        ODVERGLEICH = "Relativ zur Altersgruppe keine Änderung seit der Voruntersuchung vom " & ODVORDATUM & "."
    'besser
        Case Is > 0.2
        ODVERGLEICH = "Relativ zur Altersgruppe Befundbesserung seit der Voruntersuchung vom " & ODVORDATUM & "."
    'schlechter
        Case Is < -0.2
        ODVERGLEICH = "Relativ zur Altersgruppe Befundverschlechterung seit der Voruntersuchung vom " & ODVORDATUM & "."
        End Select
    End If
    If ODSTREU <> 6 Or ODASTREU <> 6 Then 'wenn Streuuung klein****
' gleich geblieben
        Select Case DIFFZSCORE
        Case -0.5 To 0.5
            ODVERGLEICH = "Relativ zur Altersgruppe bei der großen Streuung der Meßwerte keine Änderung seit der Voruntersuchung vom " & ODVORDATUM & "."
    'besser
        Case Is >= 0.5
            ODVERGLEICH = "Relativ zur Altersgruppe Befundbesserung seit der Voruntersuchung vom " & ODVORDATUM & "."
    'schlechter
        Case Is <= -0.5
            ODVERGLEICH = "Relativ zur Altersgruppe Befundverschlechterung seit der Voruntersuchung vom " & ODVORDATUM & "."
        End Select
    End If
End If

'**********Zahlen in Text umwandeln********

If ODSTREU = 2 Then ODSTREUTEXT = "sehr großer Streuung "

If ODSTREU = 6 Then ODSTREUTEXT = "geringerer Streuung "

If ODSTREU = 7 Then ODSTREUTEXT = "größerer Streuung "

'********** Report****************
ODREPORT = (ODINDIK & vbCrLf & "Osteodensitometrie an der LWS vom "  & ODDATUM & ":" & vbCrLf & "Beurteilung: " & WHO & vbCrLf & ALTERSGR & vbCrLf & ODVERGLEICH & vbCrLf & vbCrLf & "Nach Anlegen mittvertebraler Schichten an " & ODMESSP & "wird die Dichte der knochenstoffwechselaktiven Wirbelspongiosa mit " & ODSTREUTEXT &  "im Mittel bei " & KND & " mg CaHA/ml gemessen. " & MINKND & vbCrLf &  "Von der mittleren Knochendichte 20- jähriger weicht der Wert um " & TSCORE & " SD ab (T- Score). " & vbCrLf & DATENB & "Die Knochendichte weicht vom Mittelwert der Altersgruppe (" & JGKND & " mg/ml) um " & ZSCORE & " SD ab (Z- Score). " & vbCrLf & ODVORUNT)

ODKORR = MsgBox(ODREPORT, vbYesNo + vbQuestion)

' siehe [[Makros für Radiologen: Makro zum Report der lumbalen Knochendichtemessung mit QCT: 
'         Makro Osteodensitometrie: ODfrmkorr]]
If ODKORR = 7 Then ODfrmkorr.Show 

'*********Text einfügen***********************

'zwablage einfügen

'**********Formatieren***********

End Sub
Abgerufen von „https://de.wikibooks.org/w/index.php?title=Makros_für_Radiologen:_Makro_zum_Report_der_lumbalen_Knochendichtemessung_mit_QCT:_Makro_Osteodensitometrie&oldid=957301“