📄 ihms_diagnosis.frm
字号:
Height = 180
Index = 0
Left = 240
TabIndex = 13
ToolTipText = "DD/MM/YYYY"
Top = 840
Width = 540
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "symptoms from the combo boxes, starting from"
Height = 180
Left = 2880
TabIndex = 12
ToolTipText = "DD/MM/YYYY"
Top = 240
Width = 3960
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "至少一个"
Height = 180
Left = 1440
TabIndex = 11
ToolTipText = "DD/MM/YYYY"
Top = 240
Width = 720
End
Begin VB.Label Label4
Caption = "请选择"
Height = 255
Left = 360
TabIndex = 10
ToolTipText = "DD/MM/YYYY"
Top = 240
Width = 1095
End
End
Begin VB.Data datHospHist
Caption = "Hospital History"
Connect = "Access"
DatabaseName = ""
DefaultCursorType= 0 '缺省游标
DefaultType = 2 '使用 ODBC
Exclusive = 0 'False
Height = 345
Left = 0
Options = 0
ReadOnly = 0 'False
RecordsetType = 1 'Dynaset
RecordSource = ""
Top = 0
Visible = 0 'False
Width = 2415
End
Begin VB.Frame fraPatientInfo
Caption = "患者信息(&P)"
Enabled = 0 'False
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1215
Left = 360
TabIndex = 4
Top = 960
Width = 6495
Begin VB.TextBox txtCaseRefNo
BackColor = &H80000016&
DataField = "First_Name"
DataSource = "datPerInfo"
Height = 285
Left = 1800
TabIndex = 18
Top = 720
Width = 2295
End
Begin VB.TextBox txtDoctorInCharge
BackColor = &H80000016&
DataField = "Date_of_Birth"
DataSource = "datPerInfo"
Height = 285
Left = 4320
TabIndex = 6
ToolTipText = "DD/MM/YYYY"
Top = 720
Width = 1935
End
Begin VB.TextBox txtHospNo
BackColor = &H80000016&
Height = 285
Left = 1800
TabIndex = 5
Top = 360
Width = 2295
End
Begin VB.Label Label12
Caption = "病例参考 #:"
Height = 255
Left = 240
TabIndex = 19
Top = 720
Width = 1455
End
Begin VB.Label Label8
Caption = "主治医师:"
Height = 255
Left = 4320
TabIndex = 8
ToolTipText = "DD/MM/YYYY"
Top = 360
Width = 1335
End
Begin VB.Label lblHospNo
Caption = "医院编号(&H):"
Height = 255
Left = 240
TabIndex = 7
Top = 360
Width = 1575
End
End
Begin VB.Label Label6
Alignment = 2 'Center
Caption = "诊断助手"
BeginProperty Font
Name = "Courier New"
Size = 18
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000FF&
Height = 495
Left = 1410
TabIndex = 3
Top = 510
Width = 4095
End
Begin VB.Label lblHeading
Alignment = 2 'Center
Caption = "患者编号#"
BeginProperty Font
Name = "Courier New"
Size = 18
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00C00000&
Height = 495
Left = 1830
TabIndex = 2
Top = 120
Width = 3255
End
End
Attribute VB_Name = "frmDiagnosis"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'****************************************************************************
' ：） 人人为我，我为人人 ：）
'枕善居汉化收藏整理
'发布日期：06/02/21
'描 述：智能医院管理系统 Version 1.0
'网 站：http://www.mndsoft.com/
'e-mail ：mnd@mndsoft.com
'OICQ ：88382850
'****************************************************************************
Option Explicit
Private Sub cmdClose_Click()
If MsgBox("不保存信息就退出诊断助手吗?", vbCritical + vbYesNo, "提示") = vbYes Then
Unload Me
End If
End Sub
Private Sub cmdDiagnose_Click()
Dim symptom(4) As String
Dim diseaseID(4) As Integer
Dim diseaseName(4) As String
Dim diagnosisResults(4) As String
Dim x As Integer 'Loop variable
'Collect user input
For x = 0 To 4
symptom(x) = cboSymptom(x)
Next x
'Ensure the user chooses at least one symptom, otherwise, exit this procedure
If symptom(0) = "N/A" Or symptom(0) = "" Then
MsgBox "You must specify AT LEAST one sign/symptom to diagnose a patient, starting with Symptom 1.", vbInformation
Exit Sub
End If
Call DiagnosePatient(symptom(0), diseaseID(0), diseaseName(0))
txtDisease(0).Text = diseaseName(0)
'Generate results for any other symptoms specified.
For x = 1 To 4
If symptom(x) <> "" Then
Call DiagnosePatient(symptom(x), diseaseID(x), diseaseName(x))
If diseaseName(x) <> diseaseName(0) Then diagnosisResults(x) = diseaseName(x)
End If
Next x
'Sort the 4 resulting disease names in descending order, and eliminate duplicates
'MsgBox diseaseName(0) + vbCrLf + diseaseName(1) + vbCrLf + diseaseName(2) + vbCrLf + diseaseName(3) + vbCrLf + diseaseName(4)
Dim a As Integer, b As Integer
Dim temp As String
For a = 1 To 3
For b = 1 To 4 - a
If diagnosisResults(b) > diagnosisResults(b + 1) Then
temp = diagnosisResults(b)
diagnosisResults(b) = diagnosisResults(b + 1)
diagnosisResults(b + 1) = temp
ElseIf diagnosisResults(b) = diagnosisResults(b + 1) Then
'eliminate duplicates
diagnosisResults(b) = ""
End If
Next b
Next a
'Display the results.
txtDisease(1) = ""
For a = 1 To 4
If diagnosisResults(a) <> "" Then txtDisease(1) = txtDisease(1) + diagnosisResults(a) + vbCrLf
Next a
fraDiagInfo.Enabled = False
cmdDiagnose.Enabled = False
cmdSave.Enabled = True
End Sub
Private Sub cmdSave_Click()
Dim flgFound As Boolean
'SEARCH THE PATIENT_HOSPITAL_HISTORY TABLE (for the patient's MOST RECENT record:
With datHospHist.Recordset
.MoveLast
Do
If .Fields("Hosp_No") = somePatient.HospNo Then
flgFound = True
Else
.MovePrevious
End If
Loop Until (.BOF) Or (flgFound)
End With
With datHospHist.Recordset
.Edit
.Fields("Doctors_Diagnosis") = txtDisease(0)
.Update
End With
MsgBox "诊断结果已保存。", vbInformation, "成功"
Unload Me
Unload frmOldPatient
End Sub
Private Sub Form_Load()
datSymptoms.DatabaseName = App.Path & "\IHMS_97.mdb"
datSymptoms.RecordSource = "Symptoms"
datSymptoms.Refresh
datDiseases.DatabaseName = App.Path & "\IHMS_97.mdb"
datDiseases.RecordSource = "Diseases"
datDiseases.Refresh
datHospHist.DatabaseName = App.Path & "\IHMS_97.mdb"
datHospHist.RecordSource = "Patient_Hospital_History"
datHospHist.Refresh
lblHeading.Caption = lblHeading.Caption + Str(somePatient.HospNo)
txtHospNo = somePatient.HospNo
txtCaseRefNo = somePatient.CaseRefNo
txtDoctorInCharge = somePatient.DocName
'Populate the combo boxes...
Dim y As Integer
Dim x As Integer
With datSymptoms.Recordset
.MoveFirst
y = 1
Do While Not .EOF
For x = 0 To 4
cboSymptom(x).List(y) = .Fields("Symptom_Name")
Next x
y = y + 1
.MoveNext
Loop
End With
End Sub
Public Sub DiagnosePatient(symptomX As String, d_ID As Integer, d_Name As String)
'This procedure does the following:
'1. Search for a symptom in the Symptom table, and "get" its Disease_ID
'2. Match the disease_ID against a Disease_Name in the Diseases table
'3. Return the Disease_Name found in the variable "d_Name"
' to the calling procedure.
'Task 1: Locate the disease_ID in the Symptoms table
Dim flgFoundSymptom As Boolean
With datSymptoms.Recordset
.MoveFirst
flgFoundSymptom = False
Do
If symptomX = .Fields("Symptom_Name") Then
flgFoundSymptom = True
Else
.MoveNext
End If
Loop Until flgFoundSymptom = True 'Or .EOF
d_ID = .Fields("Disease_ID")
End With
'Task 2: Use the disease_ID to locate the Diseases_Name in the Diseases table
With datDiseases.Recordset
.MoveFirst
Do
If .Fields("Disease_ID") = d_ID Then
'Task 3: Return the name of the disease
d_Name = .Fields("Diseases_Name")
Else
.MoveNext
End If
Loop Until d_Name = .Fields("Diseases_Name") 'Or .EOF
End With
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -