formyxhz.frm

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

'            If UCase(Right(strFileName, 4)) <> UCase(".txt") Then
'                strFileName = strFileName & ".txt"
'            End If
'        End If
'    End With

'
'    '查询当前单位选择的科室
'    blnSel = False
'    l = 0
'    For i = 1 To tvwXMu.Nodes.Count
'        If Len(tvwXMu.Nodes(i).Key) = 3 Then '科室
'            blnHave = False
'            For j = 1 To tvwXMu.Nodes.Count
'                Set nodTemp = tvwXMu.Nodes(j)
'                If Len(nodTemp.Key) = 12 Then '小项
'                    If (nodTemp.Parent.Parent Is tvwXMu.Nodes(i)) And nodTemp.Checked = True Then
'                        blnHave = True
'                        ReDim Preserve arrKSMC(l)
'                        arrKSMC(l) = tvwXMu.Nodes(i).Text
'                    End If
'                End If
'                If blnHave = True Then
'                    l = l + 1
'
'                    blnSel = True
'                    Exit For '跳出第一层循环
'                End If
'            Next j
'        End If
'    Next i
'    If blnSel = False Then
'        MsgBox "请选择要汇总的项目！", vbInformation, "提示"
'        GoTo ExitLab '没有选择科室
'    End If
'
'    '记录当前选择单位的预约编号
'    strYYID = arrYYID(cmbDWei.ItemData(cmbDWei.ListIndex))
'    '获取当前单位的总人数
'    strSQL = "select Count(*) from SET_GRXX" _
'            & " where YYID='" & strYYID & "'"
'    Set rsTemp = New ADODB.Recordset
'    rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
'    intCount = rsTemp(0)
'    rsTemp.Close
'    If intCount < 1 Then
'        MsgBox "当前单位“" & cmbDWei.Text & "”没有人员参加体检，无从导出！，", vbInformation, "提示"
'        GoTo ExitLab
'    End If
'
'    '******************************************************************
'    '写入题头
'    '******************************************************************
'    strSummary = "单位体检阳性指征名单：" & vbCrLf
'    strSuggest = "症状分析及建议：" & vbCrLf
'
'    '******************************************************************
'    '写入详细信息
'    '******************************************************************
'    '循环所有选择的项目
'    intIndex = 0
'    For i = 1 To tvwXMu.Nodes.Count
'        '首先判断选择的是大项还是小项
'        strXMID = Mid(tvwXMu.Nodes(i).Key, 6)
'
'        strSQL = ""
'        If (Len(strXMID) = 7) And (tvwXMu.Nodes(i).Checked = True) Then
'            '******************************************************************
'            '选择了小项
'            '******************************************************************
'            strSQL = "select DXPYSX,XXPYSX,XXType from SET_XX,SET_DX" _
'                    & " where XXID='" & strXMID & "'" _
'                    & " and SET_DX.DXID='" & Mid(tvwXMu.Nodes(i).Parent.Key, 2) & "'"
'            strXMMC = tvwXMu.Nodes(i).Text
'            Set rsHZ = New ADODB.Recordset
'            rsHZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
'            If rsHZ.RecordCount > 0 Then
'                strDXPYSX = rsHZ(0)
'                strXXPYSX = rsHZ(1)
'                intType = rsHZ(2)
'                rsHZ.Close
'
'                '***********************************
'                '以下构建查询语句的Select部分
'                '***********************************
'                strSelect = "select distinct SET_GRXX.GUID as 流水号,SET_GRXX.YYRXM as 姓名"
'                strSelect = strSelect & ",[Data_" & strDXPYSX & "].[" & strXXPYSX & "]"
'                strSelect = strSelect & " as [抽查结果]"
'                strSelect = strSelect & ",DW,CKXX,CKSX"
''                strSelect = strSelect & ",NormalVal as 标准值"
'
'                '***********************************
'                '以下构建用户的查询条件
'                '***********************************
'                If intType = 1 Then
'                    '数值型
'                    '小项
'                    strCondition = " and (cast([Data_" & strDXPYSX & "].[" & strXXPYSX & "] as float)<cast(CKXX as float)" _
'                            & " or cast([Data_" & strDXPYSX & "].[" & strXXPYSX & "] as float)>cast(CKSX as float))"
'                Else
'                    '非数值型
'                    '小项
'                    strCondition = " and [Data_" & strDXPYSX & "].[" & strXXPYSX & "]<>NormalVal"
'                End If
'                '设置性别
'                If optMale.Value = True Then
'                    strCondition = strCondition & " and SET_GRXX.SEX='男'"
'                End If
'                If optFemale.Value = True Then
'                    strCondition = strCondition & " and SET_GRXX.SEX='女'"
'                End If
'                '体检日期
'                strCondition = strCondition & " and [DATA_" & strDXPYSX & "].TJRQ>='" & dtpBegin.Value & "'" _
'                        & " and [DATA_" & strDXPYSX & "].TJRQ<='" & dtpStop.Value & " 23:59:59'"
'
'
'                '***********************************
'                '以下根据用户选择决定显示全部还是只显示团检客户
'                '***********************************
'                '团体总是要包括
'                strTJ = " from SET_GRXX,FZ_FZSJ,FZ_FZSY,SET_TJBZDT,[Data_" & strDXPYSX & "]" _
'                        & " where not (SET_GRXX.YYID is null)" _
'                        & " and SET_GRXX.YYID=FZ_FZSJ.YYID" _
'                        & " and SET_GRXX.GUID=FZ_FZSJ.GUID"
'                If cmbDWei.Text <> "" Then
'                    '只有选择团体时才加下一判断
'                    strTJ = strTJ & " and FZ_FZSJ.YYID='" & strYYID & "'"
'                End If
'                strTJ = strTJ & " and FZ_FZSJ.FZID=FZ_FZSY.FZID" _
'                        & " and FZ_FZSY.BZID=SET_TJBZDT.BZID" _
'                        & " and SET_TJBZDT.XMID='" & strXMID & "'" _
'                        & " and [Data_" & strDXPYSX & "].GUID=SET_GRXX.GUID"
'
'                '***********************************
'                '构建最后的查询语句
'                '***********************************
'                strSQL = strSelect & strTJ & strCondition
'
'                '***********************************
'                '执行查询
'                '***********************************
'                Set rsHZ = New ADODB.Recordset
'                rsHZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
'
'                intIndex = intIndex + 1
'                strSummary = strSummary & intIndex & "、" & strXMMC & vbCrLf & "    "
'                strSuggest = strSuggest & intIndex & "、" & strXMMC & vbCrLf & "    "
'                strTempSuggest = ""
'                If rsHZ.RecordCount < 1 Then
'                    '全部体检通过
'                    strSummary = strSummary & "（无）"
'                    strSuggest = strSuggest & "（全体通过）"
'                Else
'                    '**************************************************
'                    '有客户未通过体检
'                    '**************************************************
'
'                    strSuggest = strSuggest & "本次体检“" & strXMMC & "”不正常者共 " _
'                            & rsHZ.RecordCount & " 人，占单位体检人数的" _
'                            & Format(rsHZ.RecordCount * 100 / intCount, "##.##") & "%。" _
'                            & vbCrLf _
'                            & "建议：" _
'                            & vbCrLf & "    "
'
'
'                    rsHZ.MoveFirst
'                    '循环每个取出的记录集
'                    blnHave = False
'                    Do
'                        If Trim(rsHZ("抽查结果")) <> "" Then
'                            blnHave = True
'                            If intType = 1 Then
'                                '数值型
'                                strSummary = strSummary & rsHZ("姓名")
'
'                                If Val(rsHZ("抽查结果")) < Val(rsHZ("CKXX")) Then
'                                    strJYMC = strXMMC & "偏低"
'                                Else
'                                    strJYMC = strXMMC & "偏高"
'                                End If
'                            Else
'                                '说明型
'                                strSummary = strSummary & rsHZ("姓名")
'
'                                '判断是否阴阳型
'                                If rsHZ("抽查结果") = "阳性" Then
'                                    strJYMC = strXMMC & "阳性"
'                                Else
'                                    strJYMC = rsHZ("抽查结果")
'                                End If
'                            End If
'                            strSQL = "select JYNR from DM_ZJJY" _
'                                    & " where JYMC='" & strJYMC & "'"
'
'                            '姓名后面跟一个逗号
'                            strSummary = strSummary & "，"
'
'                            '检查是否有建议
'                            Set rsTemp = New ADODB.Recordset
'                            rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
'                            If rsTemp.RecordCount > 0 Then
'                                If Not IsNull(rsTemp(0)) Then
'                                    If InStr(1, strTempSuggest, rsTemp(0)) < 1 Then
'                                        strTempSuggest = strTempSuggest & strJYMC & "：" & rsTemp(0) & vbCrLf
'                                    End If
'                                End If
'                            End If
'                        End If
'
'                        rsHZ.MoveNext
'                    Loop Until rsHZ.EOF
'
'                    rsHZ.Close
'                    If blnHave = True Then
'                        '截掉最后一个逗号
'                        strSummary = Left(strSummary, Len(strSummary) - 1)
'                    End If
'
'                    If strTempSuggest <> "" Then
'                        strSuggest = strSuggest & strTempSuggest
'                    End If
'                End If
'
'                '每个项目后面跟一个回车换行
'                strSummary = strSummary & vbCrLf
'                strSuggest = strSuggest & vbCrLf
'
'                '不要让系统呈现死机状态
'                DoEvents
'            End If
'        End If
'    Next i
'
'    '判断是否有记录
'    If strSummary = "" Then
'        MsgBox "没有记录！", vbInformation, "提示"
'        GoTo ExitLab
'    End If
'
'    '最后写入文件
'     If WriteTextFile(strFileName, strSummary & vbCrLf & strSuggest) Then
'        '用记事本打开文件
'        Shell "notepad.exe " & strFileName, vbNormalFocus
'    End If
'
'    GoTo ExitLab
'
'ErrMsg:
'    Status = SetError(Err.Number, Err.Description, Err.Source)
'    ErrMsg Status
'ExitLab:
'    Me.MousePointer = vbDefault
End Sub

Private Sub cmdQuery_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strSelect As String 'SQL语句的Select部分
    Dim strSJ As String '散检部分
    Dim strTJ As String '团检部分
    Dim strCondition As String '用户输入的查询条件
    Dim rsHZ As ADODB.Recordset
    Dim strXMID As String '项目ID
    Dim strDXPYSX As String
    Dim strXXPYSX As String
    Dim intType As Integer '项目类型
    
    Me.MousePointer = vbHourglass
    
    '是否选择了单位
'    If cmbDWei.Text = "" Then
'        MsgBox "请选择要汇总的单位！", vbInformation, "提示"
'        GoTo ExitLab
'    End If
    
    '日期是否符合规范
    If dtpBegin.Value > dtpStop.Value Then
        MsgBox "起始日期不应大于终止日期！请核对后重新输入！", vbInformation, "提示"
        dtpBegin.SetFocus
        GoTo ExitLab
    End If
    
    '用户是否选择
    If tvwXMu.SelectedItem Is Nothing Then
        MsgBox "请在左侧的树形结构中选择要汇总的项目！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '是否选择的是科室或根节点
    If Len(tvwXMu.SelectedItem.Key) <= 5 Then
        MsgBox "请选择左侧树形结构中科室下的具体项目！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '******************************************************
    '检验完毕
    '******************************************************
    '构造查询语句
    strXMID = Mid(tvwXMu.SelectedItem.Key, 6)
    strSQL = "select DXPYSX,XXPYSX,XXType from SET_XX,SET_DX" _
            & " where XXID='" & strXMID & "'" _
            & " and SET_DX.DXID='" & Mid(tvwXMu.SelectedItem.Parent.Key, 2) & "'"
    Set rsHZ = New ADODB.Recordset
    rsHZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsHZ.RecordCount > 0 Then
        strDXPYSX = rsHZ(0)
        strXXPYSX = rsHZ(1)
        intType = rsHZ(2)
        rsHZ.Close
        
        '***********************************
        '以下构建查询语句的Select部分
        '***********************************
        strSelect = "select distinct SET_GRXX.GUID as 流水号,YYRXM as 姓名,SET_GRXX.SEX as 性别" _
                & ",[DATA_" & strDXPYSX & "].TJRQ as 体检日期,"
        strSelect = strSelect & "[Data_" & strDXPYSX & "].[" & strXXPYSX & "]"
        strSelect = strSelect & " as [检查结果(" & tvwXMu.SelectedItem.Text & ")]"
        '数值型或计算型项目，跟据新的标准查询，说明型根据原有标准查询
        If intType = 1 Or intType = 3 Then
            strSelect = strSelect & ",str(set_xx_bz.xx_min,5,1) AS 参考下限,str(set_xx_bz.xx_max,5,1) as 参考上限"
        Else
            strSelect = strSelect & ",NormalVal as 标准值"
        End If
        
        '***********************************
        '以下构建用户的查询条件
        '***********************************
        '数值型或计算型项目，跟据新的标准查询，说明型根据原有标准查询
        If intType = 1 Or intType = 3 Then
            '数值型
            '小项
'            strCondition = " and (cast([Data_" & strDXPYSX & "].[" & strXXPYSX & "] as float)<cast(CKXX as float)" _
'                    & " or cast([Data_" & strDXPYSX & "].[" & strXXPYSX & "] as float)>cast(CKSX as float))"
            'wxw Edit  根据新的体检标准查询
            strCondition = " and ((cast([Data_" & strDXPYSX & "].[" & strXXPYSX & "] as float)<" _
                & "(select xx_min from set_xx_bz  where xx_id='" & strXMID & "' and zcz='正常值' ))" _
                & " or (cast([Data_" & strDXPYSX & "].[" & strXXPYSX & "] as float)>" _
                & "(select xx_max from set_xx_bz  where xx_id='" & strXMID & "' and zcz='正常值')))" _
                
        Else
            '非数值型
            '小项
            strCondition = " and [Data_" & strDXPYSX & "].[" & strXXPYSX & "]<>NormalVal"
        End If
        '设置性别
        If optMale.Value = True Then
            strCondition = strCondition & " and SET_GRXX.SEX='男'"
        End If
        If optFemale.Value = True Then
            strCondition = strCondition & " and SET_GRXX.SEX='女'"
        End If
        '体检日期
        strCondition = strCondition & " and [DATA_" & strDXPYSX & "].TJRQ>='" & dtpBegin.Value & "'" _
                & " and [DATA_" & strDXPYSX & "].TJRQ<='" & dtpStop.Value & " 23:59:59'"
        '＄＄＄加上体检标准的性别判断
        strCondition = strCondition & " and ((SET_GRXX.SEX='男' and SET_TJBZDT.SEX<>2) or (SET_GRXX.SEX='女' and SET_TJBZDT.SEX<>1))"
        
        '***********************************
        '以下根据用户选择决定显示全部还是只显示团检客户
        '***********************************
        '团体总是要包括