frmmaintain.frm

1、以DLL形式提供医生工作站 2、 根据【检查项目】

        Exit Sub
    End If
    
    If InStr(txtMainPart.Text, "'") > 0 Then
        MsgBox "主部位名称中含有非法字符( < ' >  ,< - >), 请重新输入!", vbExclamation, "提示"
        Exit Sub
    End If
    If InStr(txtMainPart.Text, "-") > 0 Then
        MsgBox "主部位名称中含有非法字符( < ' >  ,< - >), 请重新输入!", vbExclamation, "提示"
        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, "提示"
        Exit Sub
    End If
    
    strSql = "INSERT INTO CheckMainPart (ID,Name) VALUES(CheckMainPart_SEQUENCE.NEXTVAL, '" + Trim(txtMainPart.Text) + "'  )"
    
    ErrNumber = 0
    If ExecuteInsert(strSql) Then
        MsgBox "部位添加成功!", vbExclamation, "提示"
    End If
    
    If ErrNumber = -2147217900 Then
        If ExecuteInsert(strSql) Then
            MsgBox "部位添加成功。", vbExclamation, "提示"
        End If
    End If
    
    Call InitMainParts
    
    '检查方式--主部位
    Call InitMethodMainPart
    
    Call InitMethodSubParts(cmbMainPartId.Text)
    
    txtMainPart.Text = ""
    txtSubPart.Text = ""
    Exit Sub
ErrHandler:
    MsgBox "部位添加失败, 原因:" + Err.Description, vbExclamation, "提示"
    
End Sub


'检查方式----添加检查方式
Private Sub btnAddMethod_Click(Shifit As Integer)
    On Error GoTo ErrHandler
    
    If Trim(txtMethod.Text) = "" Then
        MsgBox "请输入要添加的检查方式, 名称中空格为无效字符!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If InStr(txtMethod.Text, "'") > 0 Or InStr(txtMethod.Text, "-") > 0 Then
        MsgBox "检查方式中含有非法字符( < ' >  ,< - >), 请重新输入!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If Len(CStr(Trim(cmbCharge.Text))) > 5 Then
        MsgBox "检查费用数过大！", vbExclamation, "提示"
        Exit Sub
    End If
    
    Dim strCharge As String
    Dim strAgensName As String
    Dim strgosage As String
    Dim strGosageFee As String
    If CStr(Trim(cmbCharge.Text)) = "" Then
        strCharge = "0"
    Else
        strCharge = CStr(Trim(cmbCharge.Text))
    End If
    
    If Trim(cmbAgensName.Text) = "" Then
        strAgensName = " "
    Else
        strAgensName = Trim(cmbAgensName.Text)
    End If
    
    If Trim(cmbGosage.Text) = "" Then
        strgosage = " "
    Else
        strgosage = Trim(cmbGosage.Text)
    End If
    
    If Trim(txtGosageFee.Text) = "" Then
        strGosageFee = "0"
    Else
        strGosageFee = Trim(txtGosageFee.Text)
    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
    
    strSql = "INSERT INTO CheckMethod (ID,Name, CheckSubPartId ,Charge," _
        + " AGENSNAME,GOSAGE,GOSAGE_FEE ) VALUES(CheckMethod_SEQUENCE.NEXTVAL," _
        + "'" + Trim(txtMethod.Text) _
        + "','" + cmbSubPartId.Text + "','" + strCharge _
        + "','" + strAgensName + "','" + strgosage _
        + "','" + strGosageFee + "')"
    
    ErrNumber = 0
    If ExecuteInsert(strSql) Then
        MsgBox "检查方式添加成功!", vbExclamation, "提示"
    End If
    
    If ErrNumber = -2147217900 Then
        If ExecuteInsert(strSql) Then
            MsgBox "检查方式添加成功!", vbExclamation, "提示"
        Else
            MsgBox "检查方式添加失败, 请重试, 如果问题仍然存在, 请与系统管理员联系!", vbExclamation, "提示"
        End If
    End If
    
    Call InitMethodMethods(cmbSubPartId.Text)
    txtMethod.Text = ""
    cmbCharge.Text = ""
    Exit Sub
ErrHandler:
    MsgBox "检查方式添加失败, 原因:" + Err.Description, vbExclamation, "提示"
    
End Sub


'患者状态----添加状态
Private Sub btnAddPatientStates_Click(Shifit As Integer)
    On Error GoTo ErrHandler
    
    If Trim(txtPatientState.Text) = "" Then
        MsgBox "请输入状态名称, 名称中空格为无效字符!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If InStr(txtPatientState.Text, "'") > 0 Or InStr(txtPatientState.Text, "-") > 0 Then
        MsgBox "状态名称中含有非法字符( < ' >  ,< - >), 请重新输入!", vbExclamation, "提示"
        Exit Sub
    End If
    Dim strSql As String
    strSql = "SELECT ID FROM State WHERE State = '" + Trim(txtPatientState.Text) + "'"
    If GetRecordNumber(strSql) > 0 Then
        MsgBox "该状态已存在, 请重新添加!", vbExclamation, "提示"
        Exit Sub
    End If
    
    strSql = "INSERT INTO State (ID,State) VALUES(State_SEQUENCE.NEXTVAL, '" + Trim(txtPatientState.Text) + "'  )"
    
    ErrNumber = 0
    If ExecuteInsert(strSql) Then
        MsgBox "状态添加成功!", vbExclamation, "提示"
    End If
    
    If ErrNumber = -2147217900 Then
        If ExecuteInsert(strSql) Then
            MsgBox "状态添加成功!", vbExclamation, "提示"
        Else
            MsgBox "状态添加失败, 请重试, 如果问题仍然存在, 请与系统管理员联系!", vbExclamation, "提示"
        End If
    End If
    
    Call InitPatientStates
    txtPatientState.Text = ""
    Exit Sub
ErrHandler:
    MsgBox "状态添加失败, 原因:" + Err.Description, vbExclamation, "提示"
    
End Sub


'检查部位----添加子部位
Private Sub btnAddSubPart_Click(Shifit As Integer)
    On Error GoTo ErrHandler
    
    If lstPartMainPart.ListCount <= 0 Or Trim(lstPartMainPart.Text) = "" Then
        MsgBox "请您先选择主部位, 再添加对应的子部位!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If Trim(txtSubPart.Text) = "" Then
        MsgBox "请填写要添加的子部位名称, 名称中空格为无效字符!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If InStr(txtSubPart.Text, "'") > 0 Then
        MsgBox "子部位名称中含有非法字符( < ' >  ,< - >), 请您重新输入!", vbExclamation, "提示"
        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
    
    '==获取主部位的ID===============================================
    strSql = "SELECT ID FROM CHECKMAINPART WHERE rownum<=1 AND  NAME='" _
        + lstPartMainPart.Text + "'"
    Dim rsMainPart As New ADODB.Recordset
    If rsMainPart.State = adStateOpen Then
        rsMainPart.Close
    End If
    
    
    Dim myConn As New ADODB.Connection
    myConn.CursorLocation = adUseClient
    If myConn.State <> adStateOpen Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    
    rsMainPart.Open strSql, myConn
    
    If rsMainPart.RecordCount <> 1 Or IsNull(rsMainPart.Fields("ID")) Then
        Exit Sub
    End If
    
    Dim strMainPartId As String
    strMainPartId = CStr(rsMainPart.Fields("ID"))
    If strMainPartId = "" Then
        MsgBox "子部位添加失败,原因:该子部位对应的主部位登记有误, 请与系统管理员联系!", vbExclamation, "提示"
        Exit Sub
    End If
    '==========================================================
    
    strSql = "INSERT INTO CheckSubPart (ID,Name, CheckMainPartId) VALUES( CheckSubPart_SEQUENCE.NEXTVAL,'" _
        + Trim(txtSubPart.Text) + "' , '" + strMainPartId + "' )"

        
    
    ErrNumber = 0
    If ExecuteInsert(strSql) Then
        MsgBox "子部位添加成功!", vbExclamation, "提示"
    End If
    
    If ErrNumber = -2147217900 Then
        If ExecuteInsert(strSql) Then
            MsgBox "子部位添加成功!", vbExclamation, "提示"
        Else
            MsgBox "子部位添加失败!", vbExclamation, "提示"
        End If
    End If
    

    Call InitSubParts(lstPartMainPart.Text)
    
    Call InitMethodMainPart
    
    Call InitMethodSubParts(cmbMainPartId.Text)
    
    
    Exit Sub
ErrHandler:
    MsgBox "部位添加失败, 原因:" + Err.Description, vbExclamation, "提示"
End Sub

Private Sub btnBack_Click(Shifit As Integer)
On Error GoTo ErrHandler
    Unload Me
    frmCheckList.SetFocus
    Exit Sub
ErrHandler:
     MsgBox Err.Description, vbExclamation, "提示"

End Sub

Private Sub btnDeleteMainPart_Click(Shifit As Integer)
On Error GoTo ErrHandler
    If lstPartMainPart.ListCount <= 0 Or Trim(lstPartMainPart.Text) = "" Then
        MsgBox "请选择要删除的主部位!", vbExclamation, "提示"
        Exit Sub
    End If
        
    
    If MsgBox("您确定要删除吗?", vbYesNo Or vbQuestion, "") <> vbYes Then
        Exit Sub
    End If
    Dim strSql As String
       
    '==获取主部位的ID===============================================
    strSql = "SELECT ID FROM CHECKMAINPART WHERE rownum<=1 AND  NAME='" _
        + lstPartMainPart.Text + "'"
    Dim rsMainPart As New ADODB.Recordset
    If rsMainPart.State = adStateOpen Then
        rsMainPart.Close
    End If
    
    
    Dim myConn As New ADODB.Connection
    myConn.CursorLocation = adUseClient
    If myConn.State <> adStateOpen Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    
    rsMainPart.Open strSql, myConn
    
    If rsMainPart.RecordCount <> 1 Or IsNull(rsMainPart.Fields("ID")) Then
        Exit Sub
    End If
    
    Dim strMainPartId As String
    strMainPartId = CStr(rsMainPart.Fields("ID"))
    If strMainPartId = "" Then
        MsgBox "删除失败, 请与系统管理员联系!", vbExclamation, "提示"
        Exit Sub
    End If
    '==========================================================
    
    
    strSql = "DELETE FROM CheckSubPart WHERE CheckMainPartId = '" _
        + strMainPartId + "'"
            
    If Not ExecuteNonQuery(strSql) Then
        MsgBox "主部位相应子部位删除失败, 请与系统管理员联系!", vbExclamation, "提示"
        Exit Sub
    End If
    
    strSql = "DELETE FROM CheckMainPart WHERE Name = '" + lstPartMainPart.Text + "'"
    
    
    If Not ExecuteNonQuery(strSql) Then
        MsgBox "删除失败, 请与系统管理员联系!", vbExclamation, "提示"
        Exit Sub
    Else
        MsgBox "删除成功!", vbExclamation, "提示"
    End If
        
    Call InitMainParts
    Call InitSubParts("")
    
    
    
    '检查方式--主部位
    Call InitMethodMainPart
    
    Call InitMethodSubParts(cmbMainPartId.Text)
    
    lstSubPart.Text = ""
    txtMainPart.Text = ""