frmformula.frm

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

    Dim i As Integer
    Dim intID As Integer
    Dim curPrice As Currency
    
    
    '一般校验
    '校验名称
    txtName.Text = Trim(txtName.Text)
    If txtName.Text = "" Then
        MsgBox "请输入套餐名称！", vbInformation, "提示"
        txtName.SetFocus
        Exit Sub
    End If
    
    '检查名称是否重复
    If (menuOperation = Add) Or ((menuOperation = Modify) And (lstFormula.Text <> txtName.Text)) Then '添加
        strSQL = "select count(*) from SET_TC" _
                & " WHERE TCMC='" & txtName.Text & "'"
        Status = GetRows(strSQL)
        If rs(0) >= 1 Then
            MsgBox "你输入的套餐名称已经存在，请核对后重新输入！", vbInformation, "提示"
            txtName.SetFocus
            Exit Sub
        End If
    End If
    '校验描述
    txtDescription.Text = Trim(txtDescription.Text)
    If txtDescription.Text = "" Then
        MsgBox "请输入套餐描述，也就是套餐“" & txtName.Text & "”的适用范围！", _
                vbInformation, "提示"
        txtDescription.SetFocus
        Exit Sub
    End If
    
    '是否输入了价格
    If Trim(txtPrice.Text) = "" Then
        MsgBox "请输入套餐价格！", vbInformation, "提示"
        txtPrice.SetFocus
        Exit Sub
    End If
    '套餐价格是否合理
    curPrice = CCur(Val(txtPrice.Text))
    If curPrice <= 0 Then
        MsgBox "套餐价格应该大于零！", vbInformation, "提示"
        txtPrice.SetFocus
        Exit Sub
    End If
    
    '是否选择了组合
    If lvwChecked.ListItems.Count < 1 Then
        MsgBox "套餐必须包含体检项目组合。请添加当前套餐要包含的项目组合！", vbInformation, "提示"
        Exit Sub
    End If
    
    '判断是添加还是修改
    If menuOperation = Add Then '添加
        '添加到数据库
        strSQL = "insert into SET_TC(TCMC,TCMS,TCJG)" _
                & " values('" & txtName.Text & "'" _
                & ",'" & txtDescription.Text & "'" _
                & "," & IIf(IsNull(txtPrice.Text) Or txtPrice.Text = "", 0, curPrice) & ")"
        Status = Execute(strSQL)
        If ErrTrue(Status) Then
            ErrMsg Status
        Else
            '获取新添加套餐的ID号
            strSQL = "select TCID FROM SET_TC" _
                    & " WHERE TCMC='" & txtName.Text & "'"
            Status = GetRows(strSQL)
            intID = rs(0)
            
            '添加对应关系
            With lvwChecked
                For i = lvwChecked.ListItems.Count To 1 Step -1
                    Call AddDXToTC(intID, txtName.Text, Mid(.ListItems(i).Key, 2), .ListItems(i).Text)
                Next i
            End With
            
            With lstFormula
                .AddItem txtName.Text
                .ItemData(.NewIndex) = intID
                '设置新的焦点
                .ListIndex = .NewIndex
            End With
        End If
    Else '修改
        intID = Val(lstFormula.ItemData(lstFormula.ListIndex))
        '更新SET_TC表
        strSQL = "UPDATE SET_TC" _
                & " SET TCMC='" & txtName.Text & "'" _
                & ",TCMS='" & txtDescription.Text & "'" _
                & ",TCJG=" & curPrice _
                & " WHERE TCID=" & intID
        Status = Execute(strSQL)
        If ErrTrue(Status) Then
            ErrMsg Status
            Exit Sub
        End If
        
        '更新SET_TCDX表
        strSQL = "delete from SET_TCDX" _
                & " WHERE TCID=" & intID
        Status = Execute(strSQL)
        '添加对应关系
        With lvwChecked
            For i = lvwChecked.ListItems.Count To 1 Step -1
                Call AddDXToTC(intID, txtName.Text, Mid(.ListItems(i).Key, 2), .ListItems(i).Text)
            Next i
        End With
        
        If lstFormula.Text <> txtName.Text Then
            lstFormula.List(lstFormula.ListIndex) = txtName.Text
        End If
        lstFormula_Click
    End If
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, "保存套餐数据时出现错误：" & vbCrLf & Err.Description, Err.Source)
    ErrMsg Status
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 i As Integer, j As Integer
    
    Screen.MousePointer = vbArrowHourglass

    lstFormula.Clear
    '加载套餐
    strSQL = "select TCID,TCMC from SET_TC"
    Status = GetRows(strSQL)
    If ErrTrue(Status) Then
        If Status(0) <> NoRecord Then
            ErrMsg Status
        End If
        lstFormula_Click
    Else
        rs.MoveFirst
        Do Until rs.EOF
            lstFormula.AddItem rs("TCMC")
            lstFormula.ItemData(lstFormula.NewIndex) = rs("TCID")
            rs.MoveNext
        Loop
        lstFormula.ListIndex = 0
    End If
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, "加载套餐时出现错误：" & vbCrLf & Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

Private Sub lstFormula_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim i As Integer, j As Integer
    Dim blnHave As Boolean
    Dim intTCID As Integer
    Dim itmTemp As ListItem
    
    '禁用相应按钮
    txtName.Enabled = False
    txtDescription.Enabled = False
    txtPrice.Enabled = False
    cmdSave.Enabled = False
    
    '清空列表显示
    lvwChecked.ListItems.Clear
    lvwUnchecked.ListItems.Clear
    
    '禁止拖动
    EnableMove False
    
    '是否有选中
    If lstFormula.Text = "" Then
        '清空以前的显示
        txtName.Text = ""
        txtDescription.Text = ""
        
        cmdDelete.Enabled = False
        cmdModify.Enabled = False
        GoTo ExitLab
    End If
    
    '记录套餐ID
    intTCID = Val(lstFormula.ItemData(lstFormula.ListIndex))
    
    '加载套餐
    strSQL = "select TCMC,TCMS,TCJG" _
            & " from SET_TC" _
            & " where TCMC='" & lstFormula.Text & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    
    If rstemp.RecordCount >= 1 Then
        txtName.Text = rstemp("TCMC")
        txtDescription = rstemp("TCMS")
        If Not IsNull(rstemp("TCJG")) Then
            txtPrice.Text = rstemp("TCJG")
        Else
            txtPrice.Text = "0"
        End If
        rstemp.Close
        
        '显示当前套餐包含的大项
        strSQL = "select DXID,DXMC,DXJG from SET_DX" _
                & " where DXID in (" _
                    & "select DXID from SET_TCDX" _
                    & " where TCID=" & intTCID _
                & ")"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rstemp.RecordCount > 0 Then
            rstemp.MoveFirst
            Do
                Set itmTemp = lvwChecked.ListItems.Add(, "W" & rstemp("DXID"), rstemp("DXMC"))
                itmTemp.SubItems(1) = rstemp("DXJG") & ""
                
                rstemp.MoveNext
            Loop Until rstemp.EOF
            rstemp.Close
        End If
        
        '显示当前套餐未包含的大项
        strSQL = "select DXID,DXMC,DXJG from SET_DX" _
                & " where DXID not in (" _
                    & "select DXID from SET_TCDX" _
                    & " where TCID=" & intTCID _
                & ")"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rstemp.RecordCount > 0 Then
            rstemp.MoveFirst
            Do
                Set itmTemp = lvwUnchecked.ListItems.Add(, "W" & rstemp("DXID"), rstemp("DXMC"))
                itmTemp.SubItems(1) = rstemp("DXJG") & ""
                
                rstemp.MoveNext
            Loop Until rstemp.EOF
            rstemp.Close
        End If
        
        '启用相应命令按钮
        cmdDelete.Enabled = True
        cmdModify.Enabled = True
        cmdAdd.Enabled = True
    End If
    
    mblnChecked = False
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, "加载套餐时出现错误：" & vbCrLf & Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

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

Private Sub txtName_GotFocus()
    txtName.SelStart = 0
    txtName.SelLength = Len(txtName.Text)
End Sub

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

Private Sub txtPrice_LostFocus()
    txtPrice.Text = CCur(Val(txtPrice.Text))
End Sub

'添加指定组合到指定套餐
'参数1：套餐ID
'参数2：套餐名称
'参数3：组合ID
'参数4：组合名称
'返回值：是否成功
Private Function AddDXToTC(ByVal intTCID As Integer, ByVal strTCMC As String, _
        ByVal strDXID As String, ByVal strDXMC As String) As Boolean
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    AddDXToTC = False
    
    '首先检查目标套餐里面是否包含指定组合
    strSQL = "select Count(*) from SET_TCDX" _
            & " where TCID=" & intTCID _
            & " and DXID='" & strDXID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp(0) > 0 Then
        MsgBox "项目组合“" & strDXMC & "”已经在套餐“" & strTCMC & "”里面存在！", _
                vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '添加指定组合到指定套餐中
    strSQL = "insert into SET_TCDX values(" _
            & intTCID _
            & ",'" & strDXID & "'" _
            & ")"
    GCon.Execute strSQL
    
    AddDXToTC = True
    
ExitLab:
    
End Function

'把指定组合从指定套餐中删除
'参数1：套餐ID
'参数2：组合ID
'返回值：是否成功
Private Function DeleteDXFromTC(ByVal intTCID As Integer, ByVal strDXID As String) As Boolean
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    DeleteDXFromTC = False
    
    '从指定套餐中删除指定组合
    strSQL = "delete from SET_TCDX" _
            & " where TCID=" & intTCID _
            & " and DXID='" & strDXID & "'"
    GCon.Execute strSQL
    
    DeleteDXFromTC = True
    
ExitLab:
    
End Function

'启用/禁用增删按钮
Private Sub EnableMove(ByVal blnFlag As Boolean)
    cmdAddDX.Enabled = blnFlag
    cmdAddAll.Enabled = blnFlag
    cmdDeleteDX.Enabled = blnFlag
    cmdDeleteAll.Enabled = blnFlag
End Sub

'根据项目是否可移动决定是否启用/禁用增删按钮
Private Sub EnableCommand()
    If lvwChecked.ListItems.Count < 1 Then
        cmdDeleteDX.Enabled = False
        cmdDeleteAll.Enabled = False
    Else
        cmdDeleteDX.Enabled = True
        cmdDeleteAll.Enabled = True
    End If
    
    If lvwUnchecked.ListItems.Count < 1 Then
        cmdAddDX.Enabled = False
        cmdAddAll.Enabled = False
    Else
        cmdAddDX.Enabled = True
        cmdAddAll.Enabled = True
    End If
End Sub