vb808.tmp

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

               Underline       =   0   'False
               Italic          =   0   'False
               Strikethrough   =   0   'False
            EndProperty
            ForeColor       =   &H00FFFFFF&
            Height          =   255
            Left            =   360
            TabIndex        =   11
            Top             =   420
            Width           =   975
         End
      End
   End
End
Attribute VB_Name = "frmMaintain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit


Dim myConn As New ADODB.Connection


Private Sub btnAddMainPart_Click(Shifit As Integer)
    On Error GoTo ErrHandler
    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
    
    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) + "'  )"
    
    '===事务处理开始====================================================
    Dim myConn As New ADODB.Connection
    myConn.CursorLocation = adUseClient
    myConn.Open modGlobalDbConnect.GetConnectionString
    
    myConn.BeginTrans '开始
    '执行语句
    myConn.Execute strSql1
    myConn.Execute strSql2
    If Err.Number = 0 Then
        myConn.CommitTrans '---提交事務
        MsgBox "<主部位>添加成功.", vbExclamation, "提示"
    Else
        myConn.RollbackTransaction
        MsgBox "<主部位>添加成功.", vbExclamation, "提示"
    End If
    '===事务处理结束====================================================
    
    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
    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 btnAddMethod_Click(Shifit As Integer)
    On Error GoTo ErrHandler
    If Trim(cmbMainPart.Text) = "" Or Trim(cmbSubPart.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
    
    strSql = "INSERT INTO CheckMethod (ID,Name, CheckSubPartId ) VALUES(CheckMethod_SEQUENCE.NEXTVAL, '" + Trim(txtMethod.Text) _
        + "','" + cmbSubPartId.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 InitMethodMethods(cmbSubPartId.Text)
    txtMethod.Text = ""
    Exit Sub
ErrHandler:
    MsgBox "检查方式添加失败, 原因:" + Err.Description, vbExclamation, "提示"
    
End Sub


'患者状态----添加状态
Private Sub btnAddPatientStates_Click(Shifit As Integer)
    On Error GoTo ErrHandler
    
    If InStr(Trim(txtPatientState.Text), " ") > 0 Then
        MsgBox "请输入要添加的<状态名称>, 名称中空格为无效字符!", vbExclamation, "提示"
        Exit Sub
    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 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 InStr(Trim(txtSubPart.Text), " ") > 0 Then
        MsgBox "请填写要添加的<子部位>, 名称中空格为无效字符!", vbExclamation, "提示"
        Exit Sub
    End If
    If Trim(txtSubPart.Text) = "" 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
    
    '==获取主部位的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 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
    If Trim(cmbMainPartId.Text) <> "" Then
        Call InitMethodSubParts(cmbMainPartId.Text)
    End If
    
    lstSubPart.Text = ""
    txtMainPart.Text = ""
    txtSubPart.Text = ""
    Exit Sub
ErrHandler:
    MsgBox "部位删除失败, 原因:" + Err.Description, vbExclamation, "提示"
End Sub

Private Sub btnDeleteMethod_Click(Shifit As Integer)
On Error GoTo ErrHandler
    If lstCheckMethod.ListCount <= 0 Or Trim(lstCheckMethod.Text) = "" Then
        MsgBox "请选择要删除的<检查方式>!", vbExclamation, "提示"
        Exit Sub
    End If