frmxmsz.frm

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

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

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdExpression_Click()
    Dim strRet As String
    Dim intPos As Integer
    
    strRet = dlgBuildExpression.GetExpression(Modify, tvwXMu.SelectedItem.Text, txtExpression.Text)
    Unload dlgBuildExpression
    Set dlgBuildExpression = Nothing
    
    If strRet <> "" Then
        intPos = InStr(1, strRet, ",")
        txtExpression.Text = Left(strRet, intPos - 1)
        txtExpression.Tag = Mid(strRet, intPos + 1)
    End If
End Sub

Private Sub cmdModify_Click()
    Dim strKey As String
    
    Me.MousePointer = vbHourglass
    
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, UPDATE_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    cmdAdd.Enabled = False
    cmdDelete.Enabled = False
    cmdModify.Enabled = False
    cmdSave.Enabled = True
    
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    menuOperation = Modify
    strKey = Mid(tvwXMu.SelectedItem.Key, 2)
    Select Case Len(strKey)
        Case 0, 2
            GoTo ExitLab
        Case 7
            EnableXXInput True
            txtXXMC.SetFocus
    End Select
    
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdSave_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim rsDX As ADODB.Recordset
    Dim rsConvert As ADODB.Recordset '转换说明型为其它类型
    Dim strKey As String
    Dim strKSID As String
    Dim nodTemp As Node
    Dim strXXID As String
    Dim intTemp As ItemType
    
    Dim strOldXXPYSX As String      '在修改项目情下，记录原来的小项拼音缩写
    Dim strTableName As String
    
    Me.MousePointer = vbHourglass
    
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    strKey = Mid(tvwXMu.SelectedItem.Key, 2)
    '取出科室
    strKSID = Left(strKey, 2)
    
    '是否输入了项目名称
    txtXXMC.Text = Trim(txtXXMC.Text)
    If txtXXMC.Text = "" Then
        MsgBox "请输入体检项目名称！", vbInformation, "提示"
        txtXXMC.SetFocus
        GoTo ExitLab
    End If
    
    '项目名称在同一科室下是否重复
    If txtXXMC.Text <> txtXXMC.Tag Then
        strSQL = "select Count(*) from SET_XX" _
                & " where XXMC='" & txtXXMC.Text & "'" _
                & " and KSID='" & strKSID & "'"
                
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rstemp(0) > 0 Then
            MsgBox "您输入的项目名称已经存在，请核对后重新输入！", vbInformation, "提示"
            txtXXMC.SetFocus
            GoTo ExitLab
        End If
        rstemp.Close
    End If
    
    '是否输入了拼音缩写
    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 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, "提示"
            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
'        Debug.Print 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
    ElseIf optXXYYang.Value = True Then
        intTemp = YINYANG
    Else
        intTemp = JISUAN
    End If
    strSQL = strSQL & ",XXType=" & intTemp _
            & ",HavePhoto=" & IIf(chkHavePhoto.Value = vbChecked, 1, 0) _
            & ",XXPYSX='" & txtXXPYSX.Text & "'" _
            & ",XXWBSX='" & txtXXWBSX.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
    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)