frmstandardset.frm

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

    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, INSERT_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    Call EnableCommand(False, True)
    m_enuOperation = Add
    Call EnableInput(True, CBool(txtNormalVal.Tag))
    
    txtNormalVal.SetFocus
    
ExitLab:

End Sub

Private Sub cmdChange_Click()
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, UPDATE_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    mintIndex = cmbBZMC.ListIndex
    mintBZID = cmbBZMC.ItemData(mintIndex)
    cmdAdd.Enabled = False
    cmdChange.Enabled = False
    cmdSave.Enabled = True
    
ExitLab:

End Sub

Private Sub cmdDel_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim intBZID As Integer
    Dim intIndex As Integer
    
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, DELETE_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    If cmbBZMC.ListIndex < 0 Then
        cmbBZMC.Text = ""
        txtBZSM.Text = ""
        
        GoTo ExitLab
    End If
    
    '让用户确认
    If MsgBox("该操作不可恢复！" & vbCrLf _
            & "确实要删除标准“" & cmbBZMC.Text & "”及该标准下的所有数据吗？", _
            vbExclamation + vbYesNo + vbDefaultButton2, "小心") = vbNo Then Exit Sub
    '准备删除
    intBZID = Val(cmbBZMC.ItemData(cmbBZMC.ListIndex))
    strSQL = "update SET_TJBZIndex set" _
            & " SFQY=0" _
            & " where BZID=" & intBZID
    GCon.Execute strSQL
    
    intIndex = cmbBZMC.ListIndex
    cmbBZMC.RemoveItem intIndex
    If cmbBZMC.ListCount = 0 Then
        cmbBZMC.Text = ""
        txtBZSM.Text = ""
        
        cmdChange.Enabled = False
    Else
        If intIndex = 0 Then
            cmbBZMC.ListIndex = intIndex
        Else
            cmbBZMC.ListIndex = intIndex - 1
        End If
    End If
    
    Call tvwXMu_NodeClick(tvwXMu.SelectedItem)
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdDeleteInfo_Click()
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim strSHID As String
    
    Me.MousePointer = vbHourglass
    
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, DELETE_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    If MsgBox("该操作不可恢复，您确认要删除体检项目 " & tvwXMu.SelectedItem _
            & " 在年龄范围 " & cmbAgeRange.Text & " 内的体检标准数据吗？", _
            vbQuestion + vbYesNo + vbDefaultButton2, "提示") = vbNo Then GoTo ExitLab
    
    '准备删除
    strSHID = LongToString(cmbAgeRange.ItemData(cmbAgeRange.ListIndex), 10)
    strSQL = "delete from SET_TJBZDT" _
            & " where SHID='" & strSHID & "'"
    GCon.Execute strSQL
    With cmbAgeRange
        Call DeleteItemFromCombox(cmbAgeRange, .ListIndex)
        If .ListCount = 0 Then Call ClearInfo
    End With
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdExport_Click()
On Error GoTo ErrMsg
    Dim fsoOut As New Scripting.FileSystemObject
    Dim TxtStream As Scripting.TextStream
    Dim strOutFileName As String
    Dim Status
    Dim i, j, K As Integer
    Dim strSQL As String
    Dim strTempResult As String
    Dim strXMMC As String
    Dim strXMSex As String
    Dim strPath As String
    
    Dim rsBZ As ADODB.Recordset
    Dim rsTemp As ADODB.Recordset
    Dim rsXM As ADODB.Recordset
    
    Me.MousePointer = vbHourglass
    '是否有体检标准
    If cmbBZMC.ListCount < 1 Then
        MsgBox "当前没有体检标准，无法导出！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '获取文件名
    strOutFileName = GetFileName(Me.CommonDialog1, "文本文件(*.txt)|*.txt", _
            "体检标准导出", "BTTJ_体检标准导出文件.txt", WRITEFILE)
    If strOutFileName = "" Then GoTo ExitLab
    
    If MsgBox("确实要导出体检标准到文件“" & strOutFileName & "”吗？", _
            vbQuestion + vbYesNo + vbDefaultButton2, "询问") = vbNo Then
        GoTo ExitLab
    End If
    
    Set TxtStream = fsoOut.CreateTextFile(strOutFileName, True, True)
    '执行导出操作
    TxtStream.WriteLine Space(30) & "体检标准导出结果"
    TxtStream.WriteLine
    
    Set rsBZ = New ADODB.Recordset
    rsBZ.Open "select * from SET_TJBZIndex where SFQY=1 order by BZID", GCon, adOpenStatic, adLockReadOnly
    If rsBZ.RecordCount > 0 Then
        TxtStream.WriteLine "共有 " & rsBZ.RecordCount & " 条体检标准"
        rsBZ.MoveFirst
        '对每一条标准执行导出操作
        Do While Not rsBZ.EOF
            TxtStream.WriteLine "**********体检标准：" & rsBZ("BZMC") & " 导出结果**********"
            strSQL = "select * from SET_TJBZDT where BZID=" & rsBZ("BZID") & " order by XMID"
            Set rsTemp = New ADODB.Recordset
            rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If Not rsTemp.EOF Then
                rsTemp.MoveFirst
                Do While Not rsTemp.EOF
                    '得出该XMID所对应的项目名称
                    Set rsXM = New ADODB.Recordset
                    strSQL = "select XXMC,XXType from SET_XX where XXID='" & rsTemp("XMID") & "'"
                    rsXM.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                    If rsXM.RecordCount > 0 Then
                        strXMMC = rsXM("XXMC")
                        strXMSex = strXMMC
                        If rsTemp("SEX") = 1 Then
                            strXMSex = strXMSex & "（适用性别：男）"
                        ElseIf rsTemp("SEX") = 2 Then
                            strXMSex = strXMSex & "（适用性别：女）"
                        Else
                            '
                        End If
                        TxtStream.WriteLine strXMSex & "："
                        Select Case rsXM("XXType")
                            Case 0, 2   '是说明型或阴阳型
                                TxtStream.WriteLine "标准值：" & rsTemp("NormalVal") & ""
                            Case 1, 3     '是数值型，计算型
                                TxtStream.WriteLine "参考下限：" & rsTemp("CKXX") & "" _
                                                    & " , 参考上限：" & rsTemp("CKSX") & "" _
                                                    & "；最小值：" & rsTemp("minVal") & "" _
                                                    & " , 最大值：" & rsTemp("maxVal") & "" _
                                                    & "；单位：" & rsTemp("DW") & ""
                                TxtStream.WriteLine "偏低提示：" & rsTemp("LowInfo") & "" _
                                                    & " , 偏高提示：" & rsTemp("HighInfo") & ""
                        End Select
                        TxtStream.WriteLine "适用年龄范围：" & rsTemp("LowerAge") & " - " & rsTemp("UpperAge")
                        TxtStream.WriteLine
                    End If
                    
                    rsTemp.MoveNext
                Loop
            End If
            rsBZ.MoveNext
        Loop
    End If
    
    TxtStream.Close
    Set TxtStream = Nothing
    Set fsoOut = Nothing
    Call Shell(gstrCurrPath & "wordpad.exe " & Chr(34) & strOutFileName, vbNormalFocus)
         
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Me.Caption & ".cmdBackup_Click")
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdModifyInfo_Click()
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, UPDATE_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    Call EnableCommand(False, True)
    m_enuOperation = Modify
    Call EnableInput(True, CBool(txtNormalVal.Tag))
    
    txtNormalVal.SetFocus
ExitLab:

End Sub

Private Sub cmdSave_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim intBZID As Integer
    Dim rsBZ As ADODB.Recordset
    Dim dtmNow As Date

    Me.MousePointer = vbHourglass
    
    If mintBZID = -1 Then
        '添加标准
        '标准名称是否为空
        If cmbBZMC.Text = "" Then
            MsgBox "标准名称不能为空，请重新输入！", vbInformation, "提示"
            cmbBZMC.SetFocus
            GoTo ExitLab
        End If
        
        '检查是否重复
        strSQL = "select count(*) from SET_TJBZIndex" _
                & " where BZMC='" & cmbBZMC.Text & "'"
        Set rsBZ = New ADODB.Recordset
        rsBZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rsBZ(0) > 0 Then
            '重复了
            MsgBox "您输入的标准名称已经存在，请核对后重新输入！", vbInformation, "提示"
            cmbBZMC.SetFocus
            GoTo ExitLab
        End If
        rsBZ.Close
        
        '获取当前最大的标准id号
        strSQL = "select max(BZID) from SET_TJBZIndex"
        Set rsBZ = New ADODB.Recordset
        rsBZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rsBZ.RecordCount > 0 Then
            If IsNull(rsBZ(0)) Then
                intBZID = 1
            Else
                intBZID = rsBZ(0) + 1
            End If
            
            rsBZ.Close
        Else
            intBZID = 1
        End If
        
        '添加一条空记录
        strSQL = "insert into SET_TJBZIndex(BZID)" _
                & " values(" & intBZID & ")"
        GCon.Execute strSQL
    Else
        '修改标准
        '检查是否重复
        strSQL = "select count(*) from SET_TJBZIndex" _
                & " where BZMC='" & cmbBZMC.Text & "'" _
                & " and BZID<>" & mintBZID
        Set rsBZ = New ADODB.Recordset
        rsBZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rsBZ(0) > 0 Then
            '重复了
            MsgBox "您输入的标准名称已经存在，请核对后重新输入！", vbInformation, "提示"
            GoTo ExitLab
        End If
        
        intBZID = mintBZID
    End If
    
    dtmNow = Now
    '更新标准信息
    strSQL = "update SET_TJBZIndex set" _
            & " BZMC='" & cmbBZMC.Text & "'" _
            & ",BZSM='" & txtBZSM.Text & "'" _
            & ",XGSJ='" & dtmNow & "'" _
            & ",ModifyManager=" & gintManagerID
    If mintBZID = -1 Then
        strSQL = strSQL & ",JLSJ='" & dtmNow & "'" _
                & ",BuildManager=" & gintManagerID
    End If
    strSQL = strSQL & " where BZID=" & intBZID
    GCon.Execute strSQL
    
    If mintBZID = -1 Then
        cmbBZMC.AddItem cmbBZMC.Text
        cmbBZMC.ItemData(cmbBZMC.NewIndex) = intBZID
        cmbBZMC.ListIndex = cmbBZMC.NewIndex
    Else
        cmbBZMC.List(mintIndex) = cmbBZMC.Text
        cmbBZMC.ListIndex = mintIndex
    End If
    
    cmdAdd.Enabled = False '已经保存过，说明至少存在一条，所以禁用添加按钮
    cmdChange.Enabled = True
    cmdSave.Enabled = False
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdSaveInfo_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsBZ As ADODB.Recordset
    Dim strSHID As String
    Dim intBZID As Integer
    Dim strXMID As String
    Dim intSex As Integer
    Dim intUpperAge As Integer
    Dim intLowerAge As Integer
    
    Me.MousePointer = vbHourglass
    
    '是否选择了项目
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    '当前是否有体检标准
    If cmbBZMC.ListIndex < 0 Then
        MsgBox "请首先设置体检标准", vbInformation, "提示"
        GoTo ExitLab
    End If