frmgreport.frm

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

    Dim rsKS, rsDX, rsXX, rsBZ, rstemp, rs As ADODB.Recordset
    
    Dim strSQL As String
    
    Dim intSex As Integer
    
    Dim strSex As String
    Dim strAge As String
    Dim strTJRQ As String

    
    Dim intBZID As Integer
    Dim intFZID As Integer
    Dim lngErr As Long
    Dim strCKXX, strCKSX As String
    Dim strXXValue As String
    
    Dim strDW, strFW, strNote As String '单位，参考范围，提示
    Cell1.Rows = 0
    'Cell1.DoRedrawAll
    '判断来自团体还是个人
    strSQL = "select * from SET_GRXX" _
            & " where GUID=" & lngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenKeyset, adLockReadOnly
    If Not g_blnSelfID Then
        strHealthID = rstemp("HealthID")
    Else
        strHealthID = rstemp("SelfBH") & ""
    End If
    strName = rstemp("YYRXM")
    strSex = rstemp("Sex")
    intSex = IIf(rstemp("Sex") = "女", 1, 2)
    strAge = rstemp("AGE") & ""
    strDW = rstemp("YYID")
    If strAge = "0" Then strAge = ""
    strTJRQ = str(rstemp("TJRQ"))
'    AddOther gstrHospital, 1, 1, 25, 1, "宋体", &HFF&, &H80000005, 1200
    AddOther "个人报告", 1, 1, 25, 1, "宋体", 1, &H80000005, 700
    Cell1.DoClearLine 0, Cell1.Rows - 1, 4, Cell1.Rows - 1, 0
    strSQL = "select YYID,TaskNumber,DWMC" _
            & " from YY_TJDJ,SET_DW" _
            & " where YY_TJDJ.DWID=SET_DW.DWID and YYid='" & strDW & "'"
    Set rs = New ADODB.Recordset
    rs.Open strSQL, GCon, adOpenKeyset, adLockReadOnly
    If rs.RecordCount >= 1 Then
        strDW = rs("DWMC")
    Else
        strDW = ""
    End If
    rs.Close
    Cell1.DoAppendRow 1
    Cell1.DoSetCellString 2, Cell1.Rows - 1, "档案号：" & strHealthID
    Cell1.DoJoinCells 2, Cell1.Rows - 1, 4, Cell1.Rows - 1
    
    Cell1.DoAppendRow 1
    Cell1.DoSetCellString 2, Cell1.Rows - 1, "姓  名：" & strName
    
    Cell1.DoAppendRow 1
    Cell1.DoSetCellString 2, Cell1.Rows - 1, "性  别：" & strSex
    
    Cell1.DoAppendRow 1
    Cell1.DoSetCellString 2, Cell1.Rows - 1, "年  龄：" & strAge
    
    Cell1.DoAppendRow 1
    Cell1.DoSetCellString 2, Cell1.Rows - 1, "单  位：" & strDW
    Cell1.DoJoinCells 2, Cell1.Rows - 1, 4, Cell1.Rows - 1
    
    AddOther "", 1, 1, 25, 1, "宋体", 1, &H80000005, 375
    Cell1.DoClearLine 0, Cell1.Rows - 1, 4, Cell1.Rows - 1, 0
    
    AddOther "档案号：" & strHealthID & "     姓名：" & strName & "    性别：" & strSex & "     年龄：" & strAge, 1, 1, 8, 1, "宋体", 1, &H80000005, 50
    strDW = ""
    


    '以下显示当前用户有选择的科室
    strSQL = "select KSID,KSMC from SET_KSSZ"
    If IsNull(rstemp("YYID")) Or rstemp("YYID") = "" Then
        strYYID = ""

        strSQL = strSQL & " where KSID in (" _
                & "select distinct left(DXID,2) from YY_SJDJDX" _
                & " where GUID=" & lngGUID & ")"

        '获取该用户的体检标准id
        strTJBZ = "select BZID from YY_SJDJ" _
                & " where GUID=" & lngGUID
    Else
        '来自团体
        strYYID = rstemp("YYID")
        rstemp.Close

        '首先获取分组id号
        strTemp = "select FZID from FZ_FZSJ" _
                & " where GUID=" & lngGUID
        Set rstemp = New ADODB.Recordset
        rstemp.Open strTemp, GCon, adOpenForwardOnly, adLockReadOnly
        If rstemp.RecordCount < 1 Then
            MsgBox "当前用户“" & strName & "”尚未参与分组，无法实现报表输出！", vbInformation, "提示"
'            GoTo ExitLab
        End If
        intFZID = rstemp("FZID")
        rstemp.Close

        strSQL = strSQL & " where KSID in (" _
                & "select distinct left(DXID,2) from YY_SJDJDX" _
                & " where GUID=" & lngGUID & ")"

'                & "select distinct left(DXID,2) from YY_TJDJDX" _
'                & " where YYID='" & strYYID & "'" _
'                & " and FZID=" & intFZID & ")"

        '获取该用户的体检标准id，每个分组公用一个体检标准
        strTJBZ = "select BZID from FZ_FZSY" _
                & " where YYID='" & strYYID & "'" _
                & " and FZID=" & intFZID
    End If
    '获取体检标准
    Set rstemp = New ADODB.Recordset
    rstemp.Open strTJBZ, GCon, adOpenStatic, adLockOptimistic
    If Not IsNull(rstemp(0)) Then
        intBZID = rstemp(0)
        intBZID = g_intEnableBZID '重新设置为默认体检标准
        rstemp.Close
    Else
        MsgBox "当前用户“" & strName & "”尚未选择体检标准，无法实现报表输出，请到“登记”处选择体检标准！", vbInformation, "提示"
'        GoTo ExitLab
    End If
    
    strSQL = strSQL & " order by SET_KSSZ.SXH"
    Set rsKS = New ADODB.Recordset
    rsKS.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    If rsKS.RecordCount < 1 Then
        '当前用户没有选择科室
        MsgBox "当前用户“" & strName & "”没有选择具体项目，无法实现报表输出！", vbInformation, "提示"
'        GoTo ExitLab
    Else
        While Not rsKS.EOF
            '添加科室
            AddKeShi rsKS("KSMC"), 1, 1, 9, 1, "宋体", 1, &HC0C0C0, 30
            
            '加载大项
            '根据性别显示大项
            
            strSQL = "select DXID,DXMC,DXPYSX,DXSFYZX from SET_DX" _
                    & " where KSID='" & rsKS("KSID") & "'" _
                    & " and DXNNTY<>" & intSex
'            If strYYID = "" Then
                '个人
                strSQL = strSQL & " and DXID in (select DXID from YY_SJDJDX" _
                        & " where GUID=" & lngGUID & ")"
'            Else
'                '团体客户
'                strSQL = strSQL & " and DXID in (select DXID from YY_TJDJDX" _
'                        & " where YYID='" & strYYID & "'" _
'                        & " and FZID=" & intFZID _
'                        & ")"
'            End If

            '按顺序号排序
            strSQL = strSQL & " order by SXH"

            Set rsDX = New ADODB.Recordset
            rsDX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                 While Not rsDX.EOF    '循环添加大项
                   '取得大项检查时间和检查医生
                    Set rstemp = New ADODB.Recordset
                    strSQL = "SELECT [DATA_" & rsDX("DXPYSX") & "].TJRQ, [Name]" & _
                    " FROM dbo.YY_SJDJDX INNER JOIN" & _
                    " dbo.RY_Employee ON" & _
                    " dbo.YY_SJDJDX.EmployeeID = dbo.RY_Employee.EmployeeID INNER JOIN" & _
                    " [DATA_" & rsDX("DXPYSX") & "] ON dbo.YY_SJDJDX.GUID = [DATA_" & rsDX("DXPYSX") & "].GUID" & _
                    " where Dxid='" & rsDX("DXID") & "' and dbo.YY_SJDJDX.guid=" & lngGUID
                    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic

                     AddDX rsDX("DXMC"), IIf(rstemp.RecordCount >= 1, rstemp("TJRQ"), ""), IIf(rstemp.RecordCount >= 1, rstemp("Name"), ""), 1, 1, 9, 1, "宋体", 1, &HE0E0E0
                     
                        '获取该大项下面的小项名称和拼音缩写
                        strSQL = "select XXID,XXMC,XXPYSX,xxType,HavePhoto" _
                                & " from SET_XX" _
                                & " where XXID in (" _
                                    & "select XXID from SET_ZH_Data" _
                                    & " where DXID='" & rsDX("DXID") & "'" _
                                & ")" _
                                & " and XXNNTY<>" & intSex
'
                        '按顺序号排序
                        strSQL = strSQL & " order by SXH"
                        Set rsXX = New ADODB.Recordset
                        rsXX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                        AddXX "项目名称", "检查结果：", "单位", "参考范围：", "提示", 1, 1, 8, 1, "宋体", 0, 0                  ' &HFF&
                        
                        While Not rsXX.EOF '循环增加小巷
                            strSQL = "select "
                            strSQL = strSQL & "[" & rsXX("XXPYSX") & "] as [" & rsXX("XXMC") & "]"

                            strSQL = strSQL & " from [DATA_" & rsDX("DXPYSX") & "]" & " where GUID=" & lngGUID
                            Set rstemp = New ADODB.Recordset
                            rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                            '查询该项目的相关标准
                            Set rsBZ = New ADODB.Recordset
''                            rsBZ.Open "select XMID,NormalVal,DW,CKXX,CKSX,HighInfo,LowInfo from SET_TJBZDT where XMID='" & rsXX("XXID") & "' and (sex=0 or  sex=" & intSex & ")", GCon, adOpenStatic, adLockOptimistic
                            
                            '====================================================
                            If (rsXX("XXtype") = 1) Or (rsXX("XXtype") = 3) Then
                                strSQL = "select distinct DW,(select xx_min from set_xx_bz  where xx_id='" & rsXX("XXID") & "' and zcz='正常值' and set_xx_bz.SEX<>" & intSex & ") as CKXX,(select xx_max from set_xx_bz  where xx_id='" & rsXX("XXID") & "' and zcz='正常值' and set_xx_bz.SEX<>" & intSex & ") as CKSX,NormalVal" _
                                        & " from SET_TJBZDT,set_xx_bz" _
                                        & " where   set_xx_bz.xx_id=SET_TJBZDT.xmid  and  XMID='" & rsXX("XXID") & "'" _
                                        & " and BZID=" & g_intEnableBZID
                            Else
                                strSQL = "select distinct ckxx,cksx, DW,NormalVal" _
                                        & " from SET_TJBZDT" _
                                        & " where    XMID='" & rsXX("XXID") & "'" _
                                        & " and BZID=" & g_intEnableBZID
                            End If

                            '==========================================================
                            rsBZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                            
                            If rstemp.RecordCount < 1 Then

                            Else
                                strXXValue = rstemp.Fields(0)
                                strDW = IIf(rsBZ.RecordCount >= 1, rsBZ("DW"), "-")
                                strCKXX = IIf(rsBZ.RecordCount >= 1, rsBZ("CKXX"), " ")
                                strCKSX = IIf(rsBZ.RecordCount >= 1, rsBZ("CKSX"), " ")
                                 '数值型/计算型项目，超出范围显示红色
                                If rsXX("XXtype") = 1 Or rsXX("XXtype") = 3 Then
                                    strFW = IIf(Left(strCKXX, 1) = ".", "0" & strCKXX, strCKXX) & "-" & IIf(Left(strCKSX, 1) = ".", "0" & strCKSX, strCKSX)
                                    If rstemp.Fields(0) < Val(strCKXX) Or rstemp.Fields(0) > Val(strCKSX) Then
                                        lngErr = 1
                                    Else
                                        lngErr = 0
                                    End If
                                    If rsBZ.RecordCount >= 1 Then
'                                        If rstemp.Fields(0) < Val(strCKXX) Then strNote = IIf(IsNull(rsBZ("LowInfo")), "", rsBZ("LowInfo"))
'                                        If rstemp.Fields(0) > Val(strCKSX) Then strNote = IIf(IsNull(rsBZ("HighInfo")), "", rsBZ("HighInfo"))
                                    End If
                                    
                                    Set rsKsType = GCon.Execute("select xxid,kstype from  set_xx,set_kssz where set_xx.ksid=set_kssz.ksid and set_xx.xxid='" & rsXX("XXID") & "'")
                                    If rsKsType.RecordCount >= 1 Then
                                        If Not IsNull(rsKsType!kstype) Then
                                            If Trim(rsKsType!kstype) = "检验" Then
                                                If rstemp.Fields(0) > Val(strCKSX) Then
                                                    strXXValue = strXXValue & "↑"
                                                End If

                                                If rstemp.Fields(0) < Val(strCKXX) Then
                                                    strXXValue = strXXValue & "↓"
                                                End If
                                            End If
                                        End If
                                    End If
                                    
                                    
                                Else
                                    '说明型项目，与正常值不一致显示红色
                                    If rsBZ.RecordCount >= 1 Then
                                        If rstemp.Fields(0) = rsBZ("NormalVal") Then
                                            lngErr = 0
                                        Else
                                            lngErr = 1
                                        End If
                                        strFW = rsBZ("NormalVal")
                                    End If
                                    strNote = IIf(IsNull(rstemp.Fields(0)), "", rstemp.Fields(0))
                                End If
                                AddXX rsXX("XXMC"), strXXValue, strDW, strFW, strNote, 1, 1, 7, 0, "宋体", &HFF&, lngErr
                                strXXValue = ""
                                If rsXX("HavePhoto") Then
                                   '根据版本限制
                                    '获取图像
                                    strSQL = "select [" & rsXX("XXPYSX") & PHOTO_FIELD & "]" _
                                            & " from [DATA_" & rsDX("DXPYSX") & "]" _
                                            & " where GUID=" & lngGUID
                                    Set rs = New ADODB.Recordset
                                    rs.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
                                    If Not rstemp.EOF Then
                                        If Not IsNull(rs(0)) Then
                                            If ColumnToFile(rs.Fields(0), GetTempPathW & "T" & rsXX("xxid") & ".bmp", rs) Then
'                                                pictemp.PICTURE = LoadPicture(GetTempPathW & "temp.jpg")
                                            End If
                                        End If
                                    End If

'                                    SavePicture(pictemp.PICTURE, m_strScanFile)
                                    AddPic rsXX("XXMC") & "图像", GetTempPathW & "T" & rsXX("xxid") & ".bmp", 1, 1, 8, 0, "宋体", &HFF&, lngErr
                                    
                 
                                End If
                                
                                lngErr = 0
                                strNote = ""
                            End If
                            rstemp.Close
                            rsXX.MoveNext
                         Wend
                         rsXX.Close
                 rsDX.MoveNext
                 Wend
                 rsDX.Close
             '添加科室小结
            strSQL = "select XJValue from DATA_KSXJ" _
                    & " where GUID=" & lngGUID _
                    & " and KSID='" & rsKS("KSID") & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            If rstemp.RecordCount > 0 Then
                If Not IsNull(rstemp(0)) Then
                    AddKSXJ "科室小结", rstemp(0), 1, 1, 7, 0, "宋体", 0, &H80000005
                Else
                    AddKSXJ "科室小结", "无", 1, 1, 7, 0, "宋体", 0, &H80000005
                End If
                rstemp.Close
            End If

            rsKS.MoveNext
        Wend
    End If
    '总捡结论
    
    AddOther "终检报告", 1, 1, 8, 1, "宋体", 1, &H80000005, 40

    strSQL = "select JLValue from DATA_ZJJL" _
            & " where GUID=" & lngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount > 0 Then
        If Not IsNull(rstemp(0)) Then
            AddKSXJ "终检结论", rstemp(0), 1, 1, 7, 0, "宋体", 0, &H80000005
        Else
             AddKSXJ "终检结论", "无", 1, 1, 7, 0, "宋体", 0, &H80000005
        End If
        rstemp.Close
    Else
        AddKSXJ "终检结论", "无", 1, 1, 7, 0, "宋体", 0, &H80000005
    End If
    
    '总捡建议
    strSQL = "select JYValue from DATA_ZJJY" _
            & " where GUID=" & lngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount > 0 Then
        If Not IsNull(rstemp(0)) Then
             AddKSXJ "终检建议", rstemp(0), 1, 1, 7, 0, "宋体", 0, &H80000005
        Else
             AddKSXJ "终检建议", "无", 1, 1, 7, 0, "宋体", 0, &H80000005
        End If

        rstemp.Close
    Else
        AddKSXJ "总捡建议", "无", 1, 1, 7, 0, "宋体", 0, &H80000005
    End If

    Cell1.DoRedrawAll '刷新报表
    DoEvents
    Exit Sub
er:
    MsgBox Err.Description
End Sub


'添加科室
Private Sub AddKeShi(ByVal strKSTitle As String, _
                    ByVal lngLine As Long, _
                    ByVal lngColor As Long, _