📄 vb808.tmp

📁 1、以DLL形式提供医生工作站 2、根据【检查项目】
💻 TMP
📖 第 1 页 / 共 5 页
字号:

    If MsgBox("您确定要删除该<检查方式>吗?", vbYesNo Or vbQuestion, "") <> vbYes Then
        Exit Sub
    End If
    
    Dim strSql As String
    strSql = "DELETE FROM CheckMethod WHERE ID = '" + lstMethodNumber.Text + "'"
    If Not ExecuteNonQuery(strSql) Then
        MsgBox "删除失败, 请与系统管理员联系!", vbExclamation, "提示"
        Exit Sub
    Else
        MsgBox "删除成功!", vbExclamation, "提示"
    End If
        
    Call InitMethodMethods(cmbSubPartId.Text)
    txtMethod.Text = ""
    Exit Sub
ErrHandler:
    MsgBox "检查方式删除失败, 原因:" + Err.Description, vbExclamation, "提示"
End Sub

Private Sub btnDeletePatientStates_Click(Shifit As Integer)
On Error GoTo ErrHandler
    If lstPatientState.ListCount <= 0 Or lstPatientState.ListIndex < 0 Then
        MsgBox "请选择要删除的<状态名称>!", vbExclamation, "提示"
        Exit Sub
    End If
    
    
    'If Trim(txtPatientState.Text) = "" Then
    '    MsgBox "请选择要删除的状态!", vbExclamation, "提示"
    '
    '    Exit Sub
    'End If


    If MsgBox("您确定要删除吗?", vbYesNo Or vbQuestion, "") <> vbYes Then
        Exit Sub
    End If
    Dim strSql As String
    strSql = "DELETE FROM State WHERE ID = '" + lstPatientStateId.Text + "'"
    If Not ExecuteNonQuery(strSql) Then
        MsgBox "状态删除失败, 请与系统管理员联系!", vbExclamation, "提示"
        Exit Sub
    Else
        MsgBox "状态删除成功!", vbExclamation, "提示"
    End If
        
    Call InitPatientStates
    txtPatientState.Text = ""
    Exit Sub
ErrHandler:
    MsgBox "状态删除失败, 原因:" + Err.Description, vbExclamation, "提示"
End Sub

Private Sub btnDeleteSubPart_Click(Shifit As Integer)
On Error GoTo ErrHandler
    If lstSubNumber.ListCount <= 0 Or Trim(lstSubPart.Text) = "" Then
        MsgBox "请您选择要删除的<子部位>!", vbExclamation, "提示"
        Exit Sub
    End If

    If MsgBox("您确定要删除该<子部位>吗?", vbYesNo Or vbQuestion, "") <> vbYes Then
        Exit Sub
    End If
    Dim strSql As String
    strSql = "DELETE FROM CheckSubPart WHERE ID = '" + lstSubNumber.Text + "'"
    If Not ExecuteNonQuery(strSql) Then
        MsgBox "删除失败, 请与系统管理员联系!", vbExclamation, "提示"
        Exit Sub
    Else
        MsgBox "子部位删除成功!", vbExclamation, "提示"
    End If
    
    '检查部位----初始化子部位
    Call InitSubParts(lstPartMainPart.Text)
    
    
    
    Call InitMethodMainPart
    Call InitMethodSubParts(cmbMainPartId.Text)
    
    
    txtSubPart.Text = ""
    Exit Sub
ErrHandler:
    MsgBox "部位删除失败, 原因:" + Err.Description, vbExclamation, "提示"
End Sub

Private Sub btnModifyMainPart_Click(Shifit As Integer)
    On Error GoTo ErrHandler
    If lstPartMainPart.ListCount <= 0 Or Trim(lstPartMainPart.Text) = "" Then
        MsgBox "请选择要修改的<主部位>!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If InStr(txtMainPart.Text, " ") > 0 Then
        MsgBox "请填写要修改的<主部位>, 名称中空格为无效字符!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If Trim(txtMainPart.Text) = "" Then
        MsgBox "请填写要修改的<主部位>!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If stringCheck(Trim(txtMainPart.Text)) = False Then
        Exit Sub
    End If
    
    If MsgBox("您确定要修改吗?", vbYesNo Or vbQuestion, "") <> vbYes Then
        Exit Sub
    End If
    
    Dim strSql As String
    strSql = "SELECT ID FROM CheckMainPart WHERE Name = '" + Trim(txtMainPart.Text) + "'"
    If GetRecordNumber(strSql) > 0 Then
        'MsgBox "该部位已存在, 请重新修改!", vbExclamation, "提示"
        MsgBox "部位修改成功!", vbExclamation, "提示"
        Exit Sub
    End If
    
    strSql = "UPDATE  CheckMainPart SET Name = '" + Trim(txtMainPart.Text) _
        + "' WHERE NAME ='" + lstPartMainPart.Text + "'  "
    If Not ExecuteInsert(strSql) Then
        MsgBox "部位修改失败, 请与系统管理员联系!", vbExclamation, "提示"
        Exit Sub
    Else
        MsgBox "部位修改成功!", vbExclamation, "提示"
    End If
    
    Call InitMainParts
    Call InitSubParts("")
    
    
    '检查方式--主部位
    Call InitMethodMainPart
    If Trim(cmbMainPartId.Text) <> "" Then
        Call InitMethodSubParts(cmbMainPartId.Text)
    End If
    
    txtMainPart.Text = ""
    txtSubPart.Text = ""
    Exit Sub
ErrHandler:
    MsgBox "部位修改失败, 原因:" + Err.Description, vbExclamation, "提示"
End Sub

Private Sub btnModifyMethod_Click(Shifit As Integer)
    On Error GoTo ErrHandler
    If lstCheckMethod.ListCount <= 0 Or Trim(lstCheckMethod.Text) = "" Then
        MsgBox "请选择要修改的<检查方式>!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If InStr(Trim(txtMethod.Text), " ") > 0 Then
        MsgBox "请输入要修改的<检查方式>,其中空格为无效字符", vbExclamation, "提示"
        Exit Sub
    End If
    If Trim(txtMethod.Text) = "" Then
        MsgBox "请输入要修改的<检查方式>!", vbExclamation, "提示"
        Exit Sub
    End If
    
    
    If stringCheck(Trim(txtMethod.Text)) = False Then
        Exit Sub
    End If
    
    Dim strSql As String
    strSql = "SELECT ID FROM CheckMethod WHERE Name = '" + Trim(txtMethod.Text) + "'" _
        + " and CheckSubPartId ='" + cmbSubPartId.Text + "'"
    If GetRecordNumber(strSql) > 0 Then
        MsgBox "该检查方式已存在, 请重新输入!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If MsgBox("您确定要修改吗?", vbYesNo Or vbQuestion, "") <> vbYes Then
        Exit Sub
    End If
    strSql = "UPDATE  CheckMethod SET Name = '" + Trim(txtMethod.Text) _
        + "' WHERE ID ='" + lstMethodNumber.Text + "'  "
    If Not ExecuteNonQuery(strSql) Then
        MsgBox "检查方式修改失败, 请与系统管理员联系!", vbExclamation, "提示"
        Exit Sub
    Else
        MsgBox "检查方式修改成功!", vbExclamation, "提示"
    End If
    
    Call InitMethodMethods(cmbSubPartId.Text)
    txtMethod.Text = ""
    Exit Sub
ErrHandler:
    MsgBox "部位修改失败, 原因:" + Err.Description, vbExclamation, "提示"
End Sub

'状态管理----修改状态
Private Sub btnModifyPatientStates_Click(Shifit As Integer)
    On Error GoTo ErrHandler
    If lstPatientState.ListCount <= 0 Or Trim(lstPatientState.Text) = "" Then
        MsgBox "请选择要修改的<状态名称>!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If InStr(Trim(txtPatientState.Text), " ") > 0 Then
        MsgBox "请输入要修改的<状态名称>,名称中空格为无效字符!", vbExclamation, "提示"
    End If
    If Trim(txtPatientState.Text) = "" Then
        MsgBox "请输入要修改的<状态名称>!", vbExclamation, "提示"
        Exit Sub
    End If
    
    
    If stringCheck(Trim(txtPatientState.Text)) = False Then
        Exit Sub
    End If
    
    Dim strSql As String
    strSql = "SELECT ID FROM State WHERE Name = '" + Trim(txtPatientState.Text) + "'"
    If GetRecordNumber(strSql) > 0 Then
        MsgBox "该状态已存在, 请重新修改!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If MsgBox("您确定要修改吗?", vbYesNo Or vbQuestion, "") <> vbYes Then
        Exit Sub
    End If
    strSql = "UPDATE  State SET State = '" + Trim(txtPatientState.Text) _
        + "' WHERE ID ='" + lstPatientStateId.Text + "'  "
    If Not ExecuteInsert(strSql) Then
        MsgBox "状态修改失败, 请与系统管理员联系!", vbExclamation, "提示"
        Exit Sub
    Else
        MsgBox "状态修改成功!", vbExclamation, "提示"
    End If
    
    Call InitPatientStates
    txtPatientState.Text = ""
    Exit Sub
ErrHandler:
    MsgBox "部位修改失败, 原因:" + Err.Description, vbExclamation, "提示"
End Sub

Private Sub btnModifySubPart_Click(Shifit As Integer)
    On Error GoTo ErrHandler
    If lstSubPart.ListCount <= 0 Or Trim(txtSubPart.Text) = "" Then
        MsgBox "请选择要修改的<子部位>!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If Trim(txtSubPart.Text) = "" Then
        MsgBox "请填写要修改的<子部位>!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If InStr(Trim(txtSubPart.Text), " ") > 0 Then
        MsgBox "请填写要修改的<子部位>,名称中空格为无效字符", vbExclamation, "提示"
        Exit Sub
    End If
    
    If stringCheck(Trim(txtSubPart.Text)) = False Then
        Exit Sub
    End If
    
    Dim strSql As String
    strSql = "SELECT ID FROM CheckSubPart WHERE Name = '" + Trim(txtSubPart.Text) + "'"
    If GetRecordNumber(strSql) > 0 Then
        MsgBox "该子部位已存在, 请重新修改!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If MsgBox("您确定要修改吗?", vbYesNo Or vbQuestion, "") <> vbYes Then
        Exit Sub
    End If
    strSql = "UPDATE  CheckSubPart SET Name = '" + Trim(txtSubPart.Text) _
        + "' WHERE ID ='" + lstSubNumber.Text + "'  "
    If Not ExecuteNonQuery(strSql) Then
        MsgBox "部位修改失败, 请与系统管理员联系!", vbExclamation, "提示"
        Exit Sub
    Else
        MsgBox "部位修改成功!", vbExclamation, "提示"
    End If
    
    Call InitSubParts(lstPartMainPart.Text)
    Call InitMethodMainPart
    Call InitMethodSubParts(cmbMainPartId.Text)
    
    txtSubPart.Text = ""
    Exit Sub
ErrHandler:
    MsgBox "部位修改失败, 原因:" + Err.Description, vbExclamation, "提示"
End Sub



Private Sub cmbMainPart_Click()
    
    Dim i As Integer
    i = cmbMainPartId.ListCount
    cmbMainPartId.ListIndex = cmbMainPart.ListIndex
    Call InitMethodSubParts(cmbMainPartId.Text)
End Sub

Private Sub cmbSubPart_Click()
    cmbSubPartId.ListIndex = cmbSubPart.ListIndex
    lstCheckMethod.Clear
    If Trim(cmbSubPartId.Text) <> "" Then
        Call InitMethodMethods(cmbSubPartId.Text)
    End If
End Sub



Private Sub dgMainPart_Click()
On Error GoTo ErrHandler
    
    '待修改--ljf
    'Call InitSubParts(dgMainPart.TextMatrix(dgMainPart.Row, 1))
    'txtMainPart.Text = dgMainPart.TextMatrix(dgMainPart.Row, 2)
    
    
    Exit Sub
ErrHandler:
    MsgBox "", vbExclamation, "提示"

End Sub

Private Sub dgSubPart_Click()
    'If dgSubPart.Row <= 0 Then
    '    Exit Sub
    'End If
    'txtSubPart.Text = dgSubPart.Columns("子部位名称")
    
    
    'txtSubPart.Text = dgSubPart.TextMatrix(dgSubPart.Row, 2)
End Sub

Private Sub Form_Activate()
On Error GoTo ErrHandler
    
    Me.BackColor = mHLSRGB.COLORSET
    
    If InitMainParts Then
        'Call InitSubParts(dgMainPart.Columns("序号"))
        
        '待修改--LJF
        'Call InitSubParts(dgMainPart.TextMatrix(dgMainPart.Row, 1))
    End If

    '检查方式--主部位
    Call InitMethodMainPart

    '患者状态
    Call InitPatientStates
    'Dim i As Integer
    'i = Me.tabMaintain.TabIndex
    Exit Sub
ErrHandler:
    MsgBox "数据初始化失败, 原因:" + Err.Description, vbExclamation, "提示"

End Sub


Private Sub Form_Load()
On Error GoTo ErrHandler
    
    myConn.CursorLocation = adUseClient
    If myConn.State <> adStateOpen Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If

    tabMaintain.Tab = 0
    Exit Sub
ErrHandler:
    MsgBox "数据库连接建立失败, 原因:" + Err.Description, vbExclamation, "提示"
End Sub
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -