frmsjmb.frm

本系统可用于医院和专业体检中心的健康体检管理

         Caption         =   "建议内容"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   9
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00000000&
         Height          =   195
         Left            =   180
         TabIndex        =   19
         Top             =   990
         Width           =   930
      End
   End
   Begin VB.Label Label3 
      BackStyle       =   0  'Transparent
      Caption         =   "输入新的数据字典或模板（请不要超过200个字）："
      ForeColor       =   &H00000000&
      Height          =   315
      Left            =   3660
      TabIndex        =   22
      Top             =   120
      Width           =   4140
   End
End
Attribute VB_Name = "FrmSJMB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim mstrType As String '当前编辑的模板类型
Dim mstrXMID As String '当前选中项目的ID号
Dim mlvwType As String '当前选中的是数据字典或数据模板

Private Sub cmdAdd_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strValue As String
    Dim cmd As ADODB.Command
    Dim i As Integer
    Dim strMaxID As String
    
    Me.MousePointer = vbHourglass
    
    strValue = Trim(txtTemplate.Text)
    '检查用户是否输入了模板
    If strValue = "" Then
        MsgBox "请输入数据！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '检查该模板是否已经存在
    For i = 1 To lvwTemplates.ListItems.Count
        If lvwTemplates.ListItems(i).Text = strValue Then
            MsgBox "您输入的数据字典已经存在，请核对后重新输入！", vbInformation, "提示"
            GoTo ExitLab
        End If
    Next
    
    '校验完毕，首先获取当前最大的ID号
    Select Case mstrType
        Case "ZJ"
            strMaxID = GetMaxID("DM_ZJJY", "JYDMID", "00001")
            strSQL = "insert into DM_ZJJY values('" & strMaxID & "'" _
                    & ",'" & mstrXMID & "','" & strValue & "'" _
                    & ",''"
            strSQL = strSQL & "," & gintManagerID & ",'" & Date & "')"
        Case "KS"
            strMaxID = GetMaxID("DM_KS", "KSDMID", "00001")
            strSQL = "insert into DM_KS values('" & strMaxID & "'" _
                    & ",'" & mstrXMID & "','" & strValue & "'"
            strSQL = strSQL & "," & gintManagerID & ",'" & Date & "')"
        Case "DX"
            strMaxID = GetMaxID("DM_DX", "DXDMID", "00001")
            strSQL = "insert into DM_DX values('" & strMaxID & "'" _
                    & ",'" & mstrXMID & "','" & strValue & "'"
        Case "XX"
            strMaxID = GetMaxID("DM_XX", "XXDMID", "00001")
            strSQL = "insert into DM_XX values('" & strMaxID & "'" _
                    & ",'" & mstrXMID & "','" & strValue & "'"
            strSQL = strSQL & "," & gintManagerID & ",'" & Date & "','')"
        Case Else
            GoTo ExitLab
    End Select
    
    '写入数据库
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon
    cmd.CommandText = strSQL
    cmd.Execute
    
    '添加到ListView中
    lvwTemplates.ListItems.Add , "W" & strMaxID, strValue
    '同时显示在详细信息中
    txtXXNR.Text = strValue
    txtTemplate.Text = ""
    
'    Set rsTemp = New ADODB.Recordset
'    rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
'    If rsTemp(0) >= 1 Then
'        MsgBox "您输入的数据模板已经存在，请核对后重新输入！", vbInformation, "提示"
'        GoTo ExitLab
'    End If
    
    cmdModify.Caption = "修改"
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
    
End Sub


Private Sub cmdAddToModel_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strValue As String
    Dim cmd As ADODB.Command
    Dim i As Integer
    Dim strMaxID As String
    
    Me.MousePointer = vbHourglass
            
    strValue = Trim(txtTemplate.Text)
    '检查用户是否输入了模板
    If strValue = "" Then
        MsgBox "请输入数据！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '检查该模板是否已经存在
    For i = 1 To LvwSJMB.ListItems.Count
        If LvwSJMB.ListItems(i).Text = strValue Then
            MsgBox "您输入的数据模板已经存在，请核对后重新输入！", vbInformation, "提示"
            GoTo ExitLab
        End If
    Next
    
    '校验完毕，首先获取当前最大的ID号
    Select Case mstrType
        Case "ZJ"
'                strMaxID = GetMaxID("DM_ZJJY", "JYDMID", "00001")
'                strSQL = "insert into DM_ZJJY values('" & strMaxID & "'" _
'                        & ",'" & mstrXMID & "','" & strValue & "'" _
'                        & ",''"
        Case "KS", "DX", "XX"
            strMaxID = GetMaxID("DM_XM_Value", "XMDMID", "00001")
            strSQL = "insert into DM_XM_Value values('" & strMaxID & "'" _
                    & ",'" & mstrXMID & "','" & strValue & "'"
    End Select
    strSQL = strSQL & "," & gintManagerID & ",'" & Date & "')"
    '写入数据库
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon
    cmd.CommandText = strSQL
    cmd.Execute
    
    '添加到ListView中
    LvwSJMB.ListItems.Add , "W" & strMaxID, strValue
    '同时显示在详细信息中
    txtXXNR.Text = strValue
    txtTemplate.Text = ""
            
    cmdModify.Caption = "修改"
    GoTo ExitLab
    
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault

End Sub

Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdDelete_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim cmd As ADODB.Command
    
    Me.MousePointer = vbHourglass
    
    If mlvwType = "数据字典" Then
        If lvwTemplates.ListItems.Count < 1 Then GoTo ExitLab
        If lvwTemplates.SelectedItem Is Nothing Then
            MsgBox "请选择您要删除的数据字典！", vbInformation, "提示"
            GoTo ExitLab
        End If
        If MsgBox("您确实要删除数据字典“" & lvwTemplates.SelectedItem.Text & "”吗？", _
                vbQuestion + vbYesNo + vbDefaultButton2, "小心") = vbNo Then GoTo ExitLab

        Select Case mstrType
            Case "ZJ"
                strSQL = "delete from DM_ZJJY" _
                        & " where JYDMID='"
            Case "KS"
                strSQL = "delete from DM_KS" _
                        & " where KSDMID='"
            Case "DX"
                strSQL = "delete from DM_DX" _
                        & " where DXDMID='"
            Case "XX"
                strSQL = "delete from DM_XX" _
                        & " where XXDMID='"
        End Select
        strSQL = strSQL & Mid(lvwTemplates.SelectedItem.Key, 2) & "'"
        Set cmd = New ADODB.Command
        Set cmd.ActiveConnection = GCon
        cmd.CommandText = strSQL
        cmd.Execute
        
        lvwTemplates.ListItems.Remove lvwTemplates.SelectedItem.Index
        lvwTemplates_Click
        
        cmdModify.Caption = "修改"
        
        GoTo ExitLab
    ElseIf mlvwType = "数据模板" Then
        If LvwSJMB.ListItems.Count < 1 Then GoTo ExitLab
        If LvwSJMB.SelectedItem Is Nothing Then
            MsgBox "请选择您要删除的数据模板！", vbInformation, "提示"
            GoTo ExitLab
        End If
        If MsgBox("您确实要删除数据模板“" & LvwSJMB.SelectedItem.Text & "”吗？", _
                vbQuestion + vbYesNo + vbDefaultButton2, "小心") = vbNo Then GoTo ExitLab

        Select Case mstrType
            Case "ZJ"
            Case "KS", "DX", "XX"
                strSQL = "delete from DM_XM_Value" _
                        & " where XMDMID='"
        End Select
        strSQL = strSQL & Mid(LvwSJMB.SelectedItem.Key, 2) & "'"
        Set cmd = New ADODB.Command
        Set cmd.ActiveConnection = GCon
        cmd.CommandText = strSQL
        cmd.Execute
        
        LvwSJMB.ListItems.Remove LvwSJMB.SelectedItem.Index
        LvwSJMB_Click
        
        cmdModify.Caption = "修改"
        
        GoTo ExitLab

    End If
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdModify_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim cmd As ADODB.Command
    
    Me.MousePointer = vbHourglass
    
    If lvwTemplates.ListItems.Count < 1 Then GoTo ExitLab
    
    If cmdModify.Caption = "修改" Then
        If mlvwType = "数据字典" Then
            If lvwTemplates.SelectedItem Is Nothing Then
                MsgBox "请选择您要修改的数据字典！", vbInformation, "提示"
                GoTo ExitLab
            End If
    
            txtTemplate.Text = lvwTemplates.SelectedItem.Text
            cmdModify.Caption = "确认修改"
        ElseIf mlvwType = "数据模板" Then
            If LvwSJMB.SelectedItem Is Nothing Then
                MsgBox "请选择您要修改的数据模板！", vbInformation, "提示"
                GoTo ExitLab
            End If
    
            txtTemplate.Text = LvwSJMB.SelectedItem.Text
            cmdModify.Caption = "确认修改"
        End If
    Else
        If mlvwType = "数据字典" Then       '如果是修改数据字典
            '比较是否相同
            If txtTemplate.Text <> lvwTemplates.SelectedItem.Text Then
                Select Case mstrType
                    Case "ZJ"
                        strSQL = "Update DM_ZJJY set" _
                                & " DMValue='" & txtTemplate.Text & "'" _
                                & ",JYNR=''" _
                                & " where JYDMID='"
                    Case "KS"
                        strSQL = "Update DM_KS set" _
                                & " DMValue='" & txtTemplate.Text & "'" _
                                & " where KSDMID='"
                    Case "DX"
                        strSQL = "Update DM_DX set" _
                                & " DMValue='" & txtTemplate.Text & "'" _
                                & " where DxDMID='"
                    Case "XX"
                        strSQL = "Update DM_XX set" _
                                & " DMValue='" & txtTemplate.Text & "'" _
                                & " where XXDMID='"
                End Select
                strSQL = strSQL & Mid(lvwTemplates.SelectedItem.Key, 2) & "'"
                Set cmd = New ADODB.Command
                Set cmd.ActiveConnection = GCon
                cmd.CommandText = strSQL
                cmd.Execute
                
                lvwTemplates.SelectedItem.Text = txtTemplate.Text
                txtTemplate.Text = ""
            End If
        ElseIf mlvwType = "数据模板" Then       '如果是修改数据模板
             If txtTemplate.Text <> LvwSJMB.SelectedItem.Text Then
                Select Case mstrType
                    Case "ZJ"
                    Case "KS", "DX", "XX"
                        strSQL = "Update DM_XM_Value set" _
                                & " DMValue='" & txtTemplate.Text & "'" _
                                & " where XMDMID='"
                End Select
                strSQL = strSQL & Mid(LvwSJMB.SelectedItem.Key, 2) & "'"
                Set cmd = New ADODB.Command
                Set cmd.ActiveConnection = GCon
                cmd.CommandText = strSQL
                cmd.Execute
                
                LvwSJMB.SelectedItem.Text = txtTemplate.Text
                txtTemplate.Text = ""
            End If
           
        End If
        cmdModify.Caption = "修改"
    End If

    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim nodTemp As Node
    Dim rsKShi As ADODB.Recordset
    Dim rsDX As ADODB.Recordset
    Dim rsXX As ADODB.Recordset
    
    Screen.MousePointer = vbArrowHourglass
    
    
    '如果是科室医生，则禁用总检设置
    '科室医生只能设置本科室内的模板
    If gstrClassifyID = GManager.SystemKSYS Then
        Set nodTemp = tvwXMu.Nodes.Add(, , "W" & gstrKSID, gstrKSMC)
        nodTemp.Expanded = True
'        '显示当前科室的项目
'        strSQL = "select DXID,DXMC,DXSFYZX from SET_DX" _
'                & " where left(DXID,2)='" & gstrKSID & "'"
'        '按顺序号排序
'        strSQL = strSQL & " order by SXH"
'        Set rsDX = New ADODB.Recordset
'        rsDX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
'        If rsDX.RecordCount > 0 Then
'            rsDX.MoveFirst
'            Do
'                '添加大项
'                '关键字长度：1＋4＝5
'                Set nodTemp = tvwXMu.Nodes.Add("W" & gstrKSID, tvwChild, "W" & rsDX("DXID"), rsDX("DXMC"))
'                nodTemp.Expanded = True
'
'                If rsDX("DXSFYZX") = 1 Then '有子项
'                    strSQL = "select XXID,XXMC from SET_XX" _
'                            & " where XXID in (" _
'                                & "select XXID from SET_ZH_Data" _
'                                & " where DXID='" & rsDX("DXID") & "'" _
'                            & ")"
'                    '按顺序号排序
'                    strSQL = strSQL & " order by SXH"
'                    Set rsXX = New ADODB.Recordset
'                    rsXX.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
'                    If rsXX.RecordCount > 0 Then