frmxiangmu.frm

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

    '是否输入了拼音缩写
    txtXXPYSX.Text = Trim(txtXXPYSX.Text)
    If txtXXPYSX.Text = "" Then
        MsgBox "请输入项目的拼音缩写！", vbInformation, "提示"
        txtXXPYSX.SetFocus
        GoTo ExitLab
    End If
    
    strXXID = txtXXID.Text
    
    '拼音缩写不能是特殊字符
    If strXXID = "GUID" Or strXXID = "TJRQ" Then
        MsgBox "项目拼音缩写不能不能为 GUID、TJRQ 等特殊字符串，请重新设置！", vbExclamation, "提示"
        txtXXPYSX.SetFocus
        GoTo ExitLab
    End If

    '拼音缩写是否已经存在
    If txtXXPYSX.Text <> txtXXPYSX.Tag Or m_blnIsSystem Then
        strSQL = "select Count(*) from SET_XX" _
                & " where XXPYSX='" & txtXXPYSX.Text & "' and KSID='" & strKSID & "'"
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rsTemp(0) > 0 Then
            MsgBox "您输入的项目拼音缩写已经存在，请核对后重新输入！", vbInformation, "提示"
            If txtXXPYSX.Enabled Then txtXXPYSX.SetFocus
            GoTo ExitLab
        End If
        rsTemp.Close
    End If
    
    '如果是计算型，检查是否输入了表达式
    If optXXJSuan.Value = True Then
        If txtExpression.Text = "" Then
            MsgBox "请设置计算型的表达式！", vbInformation, "提示"
            txtExpression.SetFocus
            GoTo ExitLab
        End If
    End If
    
    '开始事务
    GCon.BeginTrans
    On Error GoTo RollBack
    
    '校验完毕，写入数据库
    If menuOperation = Add Then
        '添加时，首先插入一条空记录
        strSQL = "insert into SET_XX(XXID,KSID) values(" _
                & "'" & strXXID & "'" _
                & ",'" & strKSID & "'" _
                & ")"
        GCon.Execute strSQL
    End If
    
    '更新其余字段
    strSQL = "update SET_XX set" _
            & " XXMC='" & txtXXMC.Text & "'"
    '项目类型
    If optXXSMing.Value = True Then
        intTemp = SHUOMING
    ElseIf optXXSZhi.Value = True Then
        intTemp = SHUZHI
    Else
        intTemp = JISUAN
    End If
    strSQL = strSQL & ",XXType=" & intTemp _
            & ",HavePhoto=" & IIf(chkHavePhoto.Value = vbChecked, 1, 0) _
            & ",XXPYSX='" & txtXXPYSX.Text & "'" _
            & ",XXPrice=" & CCur(Val(txtXXPrice.Text)) _
            & ",SXH=" & CInt(Val(cmbXXSXH.Text))
    If intTemp = JISUAN Then '计算型
        strSQL = strSQL & ",XXExpression='" & txtExpression.Text & "," & txtExpression.Tag & "'"
    End If
    '性别
    If optXXNNTY.Value = True Then
        intTemp = 0
    ElseIf optXXMale.Value = True Then
        intTemp = 1
    Else
        intTemp = 2
    End If
    strSQL = strSQL & ",XXNNTY=" & intTemp
    '是否进入小结
    If optXJieNo.Value = True Then
        intTemp = 0
    Else
        intTemp = 1
    End If
    strSQL = strSQL & ",XXSFJRXJ=" & intTemp
    '是否有建议项
    If optJYiNo.Value = True Then
        intTemp = 0
    Else
        intTemp = 1
    End If
    If menuOperation = Add Then
        '是否系统项目
        If m_blnIsSystem Then
            strSQL = strSQL & ",SYSXXID='" & Mid(tvwSysXMu.SelectedItem.Key, 2) & "'"
        End If
    End If
    strSQL = strSQL & ",XXSFYJY=" & intTemp _
            & ",XXSM='" & txtXXSM.Text & "'" _
            & " where XXID='" & strXXID & "'"
    GCon.Execute strSQL '写入数据库
    
    '************************20040902加入 闻**************************
    If menuOperation = Modify Then
        strOldXXPYSX = txtXXPYSX.Tag
        If strOldXXPYSX <> txtXXPYSX.Text Then        '如果小项的拼音缩写改变了
            Set rsTemp = New ADODB.Recordset
            '检索当前小项所属的组合
            strSQL = "select * from SET_ZH_DATA where XXID='" & strXXID & "'"
            rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If rsTemp.RecordCount > 0 Then      '说明该小项已进入了某个组合，则需修改该组合的表的设计
                rsTemp.MoveFirst
                Do While Not rsTemp.EOF
                    Set rsDX = New ADODB.Recordset
                    rsDX.Open "select * from SET_DX where DXID='" & rsTemp("DXID") & "'", GCon, adOpenStatic, adLockReadOnly
                    If rsDX.RecordCount > 0 Then
                        '表名
                        strTableName = "[DATA_" & rsDX("DXPYSX") & "]"
                        
                        '添加新列
                        strSQL = "alter TABLE " & strTableName & " add [" & txtXXPYSX.Text & "] VARCHAR"
                        If optXXSMing.Value = True Then  '说明型项目
                            strSQL = strSQL & "(300) NULL"
                        Else
                            strSQL = strSQL & "(10) NULL"
                        End If
                        GCon.Execute strSQL
                        
                        '复制旧列中的数据到新列
                        strSQL = "update " & strTableName _
                                & " set [" & txtXXPYSX.Text & "]="
                        If (lblXMLX.Tag <> "") And (Not optXXSMing.Value) Then
                            '之前是说明型，现在不再是说明型
                            '这时需要转换原来的内容
                            'strSQL = strSQL & "val([" & strOldXXPYSX & "]"
                            strSQL = "select GUID,[" & strOldXXPYSX & "],[" & txtXXPYSX.Text & "]" _
                                    & " from " & strTableName
                            Set rsConvert = New ADODB.Recordset
                            rsConvert.Open strSQL, GCon, adOpenKeyset, adLockBatchOptimistic
                            If rsConvert.RecordCount > 0 Then
                                rsConvert.MoveFirst
                                Do While Not rsConvert.EOF
                                    '旧列写入新列
                                    rsConvert(txtXXPYSX.Text) = CStr(Val(rsConvert(strOldXXPYSX)))
                                    
                                    rsConvert.MoveNext
                                Loop
                                rsConvert.UpdateBatch '更新数据库
                                
                                rsConvert.Close
                            End If
                        Else
                            '无需转换
                            strSQL = strSQL & "[" & strOldXXPYSX & "]"
                            GCon.Execute strSQL
                        End If
                        
                        '删除表中旧列
                        strSQL = "alter TABLE " & strTableName & " drop COLUMN [" & strOldXXPYSX & "]"
                        GCon.Execute strSQL
                        
                        rsDX.Close
                    End If
                    rsTemp.MoveNext
                Loop
                rsTemp.Close
            End If
        Else
            '拼音缩写尚未改变
            '检查项目类型是否改变
            Set rsTemp = New ADODB.Recordset
            '检索当前小项所属的组合
            strSQL = "select * from SET_ZH_DATA where XXID='" & strXXID & "'"
            rsTemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
            If rsTemp.RecordCount > 0 Then      '说明该小项已进入了某个组合，则需修改该组合的表的设计
                rsTemp.MoveFirst
                Do While Not rsTemp.EOF
                    strSQL = "select DXPYSX from SET_DX where DXID='" & rsTemp("DXID") & "'"
                    Set rsDX = New ADODB.Recordset
                    rsDX.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
                    If rsDX.RecordCount > 0 Then
                        '表名
                        strTableName = "[DATA_" & rsDX("DXPYSX") & "]"
                        '更新字段长度
                        strSQL = "ALTER TABLE " & strTableName _
                                & " ALTER COLUMN" _
                                & " [" & txtXXPYSX.Text & "]"
                        If optXXSMing.Value Then
                            strSQL = strSQL & " VARCHAR(300)"
                        Else
                            strSQL = strSQL & " VARCHAR(10)"
                        End If
                        GCon.Execute strSQL
                    End If
                    
                    rsTemp.MoveNext
                Loop
            End If
        End If
        
        '是否在图像数据之间做了更改
        If CBool(chkHavePhoto.Tag) Xor (chkHavePhoto.Value = vbChecked) Then
            '图像标志被修改，需要进行处理
            '检索当前小项所属的组合
            strSQL = "select DXPYSX from SET_DX" _
                    & " where DXID in(" _
                        & "select DXID from SET_ZH_DATA" _
                        & " where XXID='" & strXXID & "'" _
                    & ")"
            Set rsDX = New ADODB.Recordset
            rsDX.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
            If Not rsDX.EOF Then       '说明该小项已进入了某个组合，则需修改该组合的表的设计
                rsDX.MoveFirst
                Do While Not rsDX.EOF
                    '表名
                    strTableName = "[DATA_" & rsDX("DXPYSX") & "]"
                    
                    strSQL = "ALTER TABLE " & strTableName
                    '判断是添加还是删除字段
                    If chkHavePhoto.Value = vbChecked Then
                        '添加字段
                        strSQL = strSQL & " ADD [" & txtXXPYSX.Text & PHOTO_FIELD & "] image"
                    Else
                        '删除字段
                        strSQL = strSQL & " DROP COLUMN [" & txtXXPYSX.Text & PHOTO_FIELD & "]"
                    End If
                    
                    GCon.Execute strSQL
                        
                    rsDX.MoveNext
                Loop
            End If
        End If
    End If
    '************************20040902加入完 闻************************
    
    '提交事务
    GCon.CommitTrans
    On Error GoTo ErrMsg
    
    '更新树形控件
    If menuOperation = Add Then '添加项目
        If Len(strKey) = 2 Then
            Set nodTemp = tvwXMu.Nodes.Add("W" & strKey, tvwChild, "W" & strXXID, txtXXMC.Text)
        Else
            Set nodTemp = tvwXMu.Nodes.Add("W" & strKey, tvwNext, "W" & strXXID, txtXXMC.Text)
        End If
        Set tvwXMu.SelectedItem = nodTemp
        
        If m_blnIsSystem Then nodTemp.Tag = Mid(tvwSysXMu.SelectedItem.Key, 2)
    Else '修改项目
        If txtXXMC.Text <> txtXXMC.Tag Then
            tvwXMu.SelectedItem.Text = txtXXMC.Text
        End If
    End If
    
    '调用单击事件
    tvwXMu_NodeClick tvwXMu.SelectedItem
    
    m_blnIsSystem = False
    
    GoTo ExitLab
RollBack:
    GCon.RollbackTrans
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 rsKS As ADODB.Recordset
    Dim rsXX As ADODB.Recordset
    Dim nodTemp As Node
    
    Screen.MousePointer = vbArrowHourglass
    
    '添加根节点
    '关键字长度：1＝1
    Set nodTemp = tvwXMu.Nodes.Add(, , "W", "所有科室")
    nodTemp.Expanded = True
    
    '外层循环，添加所有科室
    strSQL = "select KSID,KSMC from SET_KSSZ order by SXH"
    Set rsKS = New ADODB.Recordset
    rsKS.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsKS.RecordCount > 0 Then
        rsKS.MoveFirst
        With tvwXMu.Nodes
            Do
                '关键字长度：1＋2＝3
                Set nodTemp = .Add("W", tvwChild, "W" & rsKS("KSID"), rsKS("KSMC"))
                
                '对每个科室，循环添加下属的所有项目
                strSQL = "select XXID,SYSXXID,XXMC from SET_XX" _
                        & " where left(XXID,2)='" & rsKS("KSID") & "'" _
                        & " order by SXH"
                Set rsXX = New ADODB.Recordset
                rsXX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                If rsXX.RecordCount > 0 Then
                    rsXX.MoveFirst
                    '内层循环
                    Do
                        '关键字长度：1＋7＝8
                        Set nodTemp = .Add("W" & rsKS("KSID"), tvwChild, "W" & rsXX("XXID"), rsXX("XXMC"))
                        nodTemp.Tag = rsXX("SYSXXID") & ""
                        
                        rsXX.MoveNext
                    Loop Until rsXX.EOF
                    rsXX.Close
                End If
                
                rsKS.MoveNext
            Loop Until rsKS.EOF
        End With
        rsKS.Close
    End If
    
    If tvwXMu.Nodes.Count > 1 Then
        '说明至少存在一个科室
        '默认选中第一个科室，即第二个节点
        Set tvwXMu.SelectedItem = tvwXMu.Nodes(2)
    Else
        '没有科室
        '选中第一个根节点
        Set tvwXMu.SelectedItem = tvwXMu.Nodes(1)
        
        MsgBox "尚未建立任何科室，无法添加项目！" & vbCrLf & "请首先添加科室！", vbInformation, "提示"
    End If
    tvwXMu_NodeClick tvwXMu.SelectedItem
    
    '加载系统项目
    strSQL = "select KSID,KSMC from SET_KSSZ_SYSTEM" _
            & " order by SXH"
    Set rsKS = New ADODB.Recordset
    rsKS.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rsKS.EOF Then
        With tvwSysXMu
            Set nodTemp = .Nodes.Add(, , "S", "参考项目")
            nodTemp.Expanded = True
            Do
                '添加科室
                Set nodTemp = .Nodes.Add("S", tvwChild, "S" & rsKS("KSID"), rsKS("KSMC"))
                
                '提取该科室下属的项目
                strSQL = "select XXID,XXMC from SET_XX_SYSTEM" _
                        & " where KSID='" & rsKS("KSID") & "'" _
                        & " order by SXH"
                Set rsXX = New ADODB.Recordset
                rsXX.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
                If Not rsXX.EOF Then
                    Do
                        .Nodes.Add "S" & rsKS("KSID"), tvwChild, "S" & rsXX("XXID"), rsXX("XXMC")
                        
                        rsXX.MoveNext
                    Loop Until rsXX.EOF
                    rsXX.Close
                End If
                
                rsKS.MoveNext
            Loop Until rsKS.EOF
            
            rsKS.Close
        End With
    End If
        
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

Private Sub optJYiNo_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub optJYiYes_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub optXJieNo_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub optXJieYes_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub optXXFemale_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub optXXJSuan_Click()
    If optXXJSuan.Enabled = True Then
        EnableExpression True
    Else
        EnableExpression False
    End If
End Sub

Private Sub optXXMale_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub optXXNNTY_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii