frmcase.frm

VB6.0编写的医院影像系统

    '加入列表框
    lstOrgan.AddItem strOrgan
    lstOrgan.ListIndex = lstOrgan.ListCount - 1

End Sub

Private Sub cmdAddtoReport_Click()
'----------------------------
'将当前的内容加入报告
'----------------------------
Dim CurrentIndex, i As Integer
Dim ItemChosen As Boolean

    
    CurrentIndex = lstOrgan.ListIndex
    ItemChosen = False
    If frmReport.Loaded Then
        If modOrganDescribe.OrganChosen(CurrentIndex) = CurrentIndex + 1 Then
            ItemChosen = True
        End If
        If Not ItemChosen Then
            frmReport.cboOrganName.Text = frmReport.cboOrganName.Text & lstOrgan.Text
            modOrganDescribe.OrganChosen(lstOrgan.ListIndex) = lstOrgan.ListIndex + 1
        End If
        frmReport.txtDescribe.Text = frmReport.txtDescribe.Text & txtDescribe.Text
    Else
        Exit Sub
    End If
    
    If frmReport.txtDescribe.Locked Then Exit Sub     '如果在禁止状态下，则不弹出器官模版
    
'    With frmReport
'        If .Loaded Then
'            .txtDescribe.Text = .txtDescribe.Text & txtDescribe.Text
'        End If
'    End With
    
End Sub

Private Sub cmdClose_Click()
    
    '-------------------------
    '关闭窗口
    '-------------------------

    Unload Me
    
End Sub


Private Sub cmdDeleteIll_Click()
'-------------
'删除一个疾病
'-------------
On Error GoTo ErrHandle
Dim strSQL As String
Dim Ill_Index As Integer
        
    If lstIll.ListIndex = -1 Then
        MsgBox "请先选择一个疾病,再进行删除操作!", vbOKOnly + vbInformation, "提示"
        Exit Sub
    End If
    
    If MsgBox("这将删除当前的疾病，确定吗？", vbQuestion + vbYesNo, "删除疾病") = vbNo Then
        Exit Sub
    End If
    
    Ill_Index = lstIll.ListIndex
    'strSQL = "DELETE * FROM US_CASE WHERE ORGAN_NAME = '" & lstOrgan.Text & "' AND ILL_NAME = '" & lstIll.Text & "'"
    strSQL = "DELETE FROM US_CASE WHERE ORGAN_NAME = " & SingleQuote(lstOrgan.Text) & " AND ILL_NAME = " & SingleQuote(lstIll.Text)
    GDB.Execute strSQL
    
    FillOrganIll lstOrgan.Text
    lstIll.SetFocus
    If lstIll.ListCount <> 0 Then lstIll.ListIndex = Ill_Index - 1
    Exit Sub

ErrHandle:
    If Err.Number = 3021 Then
        MsgBox "当前已经没有记录可以删除！", vbInformation, "提示"
        Exit Sub
    End If

End Sub

Private Sub cmdDeleteOrgan_Click()
On Error GoTo ErrHandle
'-----------------------------
'删除一个器官
'-----------------------------
Dim strSQL As String

    
    '删除字段
    If lstOrgan.ListIndex = -1 Then
        MsgBox "请先选择一个部位,再进行删除操作!", vbOKOnly + vbInformation, "提示"
        Exit Sub
    End If
    
    If MsgBox("这将删除当前的部位，确定吗？", vbQuestion + vbYesNo, "删除部位") = vbNo Then
        Exit Sub
    End If
    
    strSQL = "DELETE FROM US_CASE WHERE ORGAN_NAME = " & SingleQuote(lstOrgan.Text)
    GDB.Execute strSQL
    strSQL = "DELETE FROM US_CASE_PART WHERE ORGAN_NAME = '" & lstOrgan.Text & "'"
    GDB.Execute strSQL
    
    FillOrgan   '重新填写列表
    Exit Sub

ErrHandle:
    If Err.Number = 3021 Then
        MsgBox "当前已经没有记录可以删除！", vbInformation, "提示"
        Exit Sub
    End If

End Sub

Private Sub cmdEditIll_Click()
'-----------------
'编辑一个疾病名称
'-----------------
Dim strIll As String
Dim strSQL As String
Dim rsTemp As String
Dim Ill_Index As Integer
    
    If lstIll.ListIndex = -1 Then
        MsgBox "请先选择一个语句,再对其进行编辑!", vbOKOnly + vbInformation, "提示"
        Exit Sub
    End If
    
    strIll = Trim(InputBox("请输入新疾病内容:", "新疾病", lstIll.Text))
    If strIll = vbNullString Then Exit Sub
    If ExistRecord("US_CASE", "ILL_NAME", strIll, "AND ORGAN_NAME = '" & lstOrgan.Text & "'") Then
        MsgBox "已经存在该记录,请重新输入!", vbExclamation + vbOKOnly, "输入错误"
        Exit Sub
    ElseIf MsgBox("这将修改当前的疾病，确定吗？", vbQuestion + vbYesNo, "编辑疾病") = vbNo Then
        Exit Sub
    End If
    
    Ill_Index = lstIll.ListIndex
    
    '更新记录
    strSQL = "UPDATE US_CASE SET ILL_NAME = '" & strIll & "' WHERE ILL_NAME = '" & lstIll.Text & "' AND ORGAN_NAME = '" & lstOrgan.Text & "'"
    GDB.Execute strSQL
    
    lstOrgan_Click
    lstIll.SetFocus
    lstIll.ListIndex = Ill_Index

End Sub

Private Sub cmdEditOrgan_Click()
'------------------
'编辑一个列表值
'------------------

Dim strOrgan As String
Dim strSQL As String
Dim rsTemp As String
Dim Organ_Index As Integer

    Organ_Index = lstOrgan.ListIndex
    If lstOrgan.ListIndex = -1 Then
        MsgBox "请先选择一个器官, 再对其进行编辑!", vbOKOnly + vbInformation, "提示"
        Exit Sub
    End If
    
    strOrgan = Trim(InputBox("请输入新器官内容:", "新器官", lstOrgan.Text))
    If strOrgan = vbNullString Then Exit Sub
    If ExistRecord("US_CASE_PART", "ORGAN_NAME", strOrgan, "") Then
        MsgBox "已经存在该记录, 请重新输入!", vbExclamation + vbOKOnly, "输入错误"
        Exit Sub
    ElseIf MsgBox("这将修改当前的部位内容, 确定吗?", vbQuestion + vbYesNo, "编辑部位") = vbNo Then
        Exit Sub
    End If
    
    '编辑记录,注意同时要更新两张表(这样在移植时问题少一些)
    strSQL = "UPDATE US_CASE_PART SET ORGAN_NAME = '" & strOrgan & "' WHERE ORGAN_NAME = '" & lstOrgan.Text & "'"
    GDB.Execute strSQL
    strSQL = "UPDATE US_CASE SET ORGAN_NAME = '" & strOrgan & "' WHERE ORGAN_NAME = '" & lstOrgan.Text & "'"
    GDB.Execute strSQL
    
    FillOrgan
    lstOrgan.SetFocus
    lstOrgan.ListIndex = Organ_Index

End Sub

Private Sub cmdSaveCase_Click()
'----------------
'更新当前病例的内容
'----------------
Dim strSQL As String
Dim rsTemp As ADODB.Recordset

    '这里不能使用UPDATE句,因为描述中可能含有回车,将引起错误
    strSQL = "SELECT * FROM US_CASE WHERE ILL_NAME = '" & lstIll.Text & "' AND ORGAN_NAME = '" & lstOrgan.Text & "'"
    Set rsTemp = OpenRSClient(strSQL)
    If rsTemp.EOF = False Then
        rsTemp!DESCRIBE = txtDescribe.Text
        rsTemp.Update
    End If
    
    Set rsTemp = Nothing
    
End Sub



Private Sub Form_Load()
    
    '-------------------------------
    '窗体加载过程
    '-------------------------------
    
'    If USV.AllowSickCase = False Then Unload Me
    
    '设置加载标志
    Me.Loaded = True
    Me.cmdAddToReport.Enabled = frmReport.Loaded        '如果frmReport没有加载，则不允许插入到报告中
    
    '设置窗体位置
    'IniUS.LoadFormPlace Me
    
    FillOrgan
    
    '检查用户权限
    CheckAdminUser
    '
End Sub

Private Sub Form_Resize()
    
    If Me.width < 5400 Then Me.width = 5400
    If Me.height < 3600 Then Me.height = 3600
    txtDescribe.width = Me.width - txtDescribe.Left - 320
    cmdSaveCase.Left = Me.width - 14385 + cmdSaveCase.Left
    cmdAddToReport.Left = Me.width - 14385 + cmdAddToReport.Left
    cmdClose.Left = Me.width - 14385 + cmdClose.Left
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
Dim i As Integer
    '清除加载标志
    Me.Loaded = False
    
    '保存窗体位置
    IniUS.SaveFormPlace Me
    '清空数组
    'For i = 0 To 199
    '    OrganChosen(i) = 0
    'Next i
End Sub

Private Sub FillOrgan()

'------------------
'填充"器官"列表
'------------------

Dim strSQL As String
Dim rsTemp As New ADODB.Recordset
    
    strSQL = "SELECT * FROM US_CASE_PART ORDER BY SERIAL_ID"
    lstOrgan.Clear
    With rsTemp
        .Open strSQL, GDB
        If .EOF = False Then
            Do While Not .EOF
                lstOrgan.AddItem !Organ_Name
                .MoveNext
            Loop
            lstOrgan.ListIndex = 0
        End If
    End With
    
    Set rsTemp = Nothing

End Sub

Private Sub FillOrganIll(OrganName As String)
    
    Dim strSQL As String
    Dim rsTemp As New ADODB.Recordset
    
    '填充器官项目列表
    strSQL = "SELECT * FROM US_CASE WHERE ORGAN_NAME = '" & OrganName & "'"
    lstIll.Clear
    With rsTemp
        .Open strSQL, GDB
        If .EOF = False Then
            Do While Not .EOF
                lstIll.AddItem !Ill_Name
                .MoveNext
            Loop
            lstIll.ListIndex = 0
        Else
            Me.txtDescribe.Text = vbNullString  '没有项目时要清空Describe的内容
        End If
    End With
    
    Set rsTemp = Nothing
    
End Sub

Private Sub lstIll_Click()
    
    '显示对应的病例
    ShowCase
    
    
End Sub

Private Sub lstOrgan_Click()
    
    '--------------
    '填充疾病列表
    '--------------
    FillOrganIll lstOrgan.Text
    
    
End Sub

Private Sub ShowCase()
    
    '---------------------------
    '显示指定的病例
    '---------------------------
    
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    
    strSQL = "SELECT * FROM US_CASE WHERE ORGAN_NAME = " & SingleQuote(lstOrgan.Text) & " AND ILL_NAME = " & SingleQuote(lstIll.Text)
    Set rsTemp = OpenRSClient(strSQL)
    
    If rsTemp.EOF = False Then
        txtDescribe.Text = rsTemp!DESCRIBE & vbNullString
    End If
    
End Sub


Private Sub CheckAdminUser()
    
    '-----------------------
    '根据是否是系统管理员做出判断
    '-----------------------
        
    cmdDeleteIll.Enabled = cmdDeleteIll.Enabled And AdminUser
    cmdDeleteOrgan.Enabled = cmdDeleteOrgan.Enabled And AdminUser
    
End Sub