mdldatabase2.bas

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

                                            tmpTCID = rstemp("TCID")
                                            strSQL = "select * from SET_TC where TCID=" & tmpTCID
                                            Set rstemp = New ADODB.Recordset
                                            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                                            strPrint = rstemp("TCMC")
                                        End If
                                        
                                    End If
                                End If
                        End Select
                    End If
                    
                    If strPrint <> "" Then
                        GoSub PrintText
                    End If
                    
                End If
                rsReport.MoveNext
            Loop Until rsReport.EOF
        End With
        rsReport.Close
'        '提交打印
'        objPrint.EndDoc
    End If
    rsPerson.Close
    
    Set rstemp = Nothing
    Set rsReport = Nothing
    Set rsPerson = Nothing
    
    GoTo ExitLab
    
PrintText:
    If strPrint <> "" Then
        With objPrint
            If Len(strPrint) <= 5 Then
                '字符串很短的时候，防止出现乱码，需直接打印
                .CurrentX = sngLeft
                .CurrentY = sngTop
                objPrint.Print strPrint
            Else
                '把打印内容放到一个文本框中，再逐行打印
                txtTemp.Text = strPrint
                intCount = GetLineCount(txtTemp)
                For i = 0 To intCount - 1 '遍历每一行
                    '获取字符串
                    strLine = GetPosChar(i, txtTemp)
                    If strLine <> "" Then '空行无需打印
                        .CurrentX = sngLeft
                        '行距设为0.2倍字高
                        .CurrentY = sngTop + i * .TextHeight(strLine) * 1.2
                        objPrint.Print strLine
                    End If
                Next
            End If
        End With
    End If
    
    Return
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub
'*************************************************************************
'*************************************************************************

'*************************************************************************
'*************************************************************************
'*********************                              **********************
'*********************      导出体检结论到记事本     **********************
'*********************                              **********************
'*************************************************************************
'*************************************************************************
Public Function ExportToText(ByVal lngGUID As Long, ByVal strFileName As String, _
        ByVal blnAll As Boolean) As Boolean
'参数1：要导出客户的全局标识符
'参数2：导出的文件名
'参数3：是否导出全部体检数据
'返回值：成功为True，否则为False
On Error GoTo ErrMsg
    Dim Status
    Dim strHealthID As String '当前选中客户
    Dim strYYID As String
    Dim arrRet() As String '模块内容
    Dim strResult As String '输出内容
    Dim strSQL As String
    Dim strTemp As String
    Dim strTJBZ As String
    Dim intBZID As Integer
    Dim rstemp As ADODB.Recordset
    Dim rsKS As ADODB.Recordset
    Dim rsDX As ADODB.Recordset
    Dim rsBZ As ADODB.Recordset
    Dim i As Integer, j As Integer
    Dim strTempletFile As String '模板文件名
    Dim f As Integer '文件号
    Dim intSFYZX As Integer
    Dim intFZID As Integer
    Dim blnHave As Boolean '是否有参考上限。如果存在，说明是数值型
    Dim arrXMID() As String
    Dim blnLine As Boolean
    
    Dim strPrint As String
    Dim strLine As String '文本框里的每一行文本
    
    Dim intSex As Integer
    Dim strName As String
    Dim strSex As String
    Dim strTJRQ As String
    
    Screen.MousePointer = vbArrowHourglass
    
    '判断来自团体还是个人
    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)
    strTJRQ = str(rstemp("TJRQ"))
    
    '以下显示当前用户有选择的科室
    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_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
    
    '首先提取体检标准记录集
    '只取数值型
    strTJBZ = "select XMID,NormalVal,DW,CKXX,CKSX from SET_TJBZDT,SET_XX" _
            & " where BZID=" & intBZID _
            & " and SET_TJBZDT.XMID=SET_XX.XXID" _
            & " and XXType=1" _
            & " union " _
            & "select XMID,NormalVal,DW,CKXX,CKSX from SET_TJBZDT,SET_DX" _
            & " where BZID=" & intBZID _
            & " and SET_TJBZDT.XMID=SET_DX.DXID" _
            & " and DXType=1"
    Set rsBZ = New ADODB.Recordset
    rsBZ.Open strTJBZ, GCon, adOpenStatic, adLockOptimistic
    
    '加载有选择的科室
    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
        '打印第一页的标题
        GoSub PrintTitle
        
        rsKS.MoveFirst
        Do
            '★★★★★★★★★★★★★★★★★★★★★★★★★★★
            '                   打印科室名称
            '★★★★★★★★★★★★★★★★★★★★★★★★★★★
            strResult = strResult & rsKS("KSMC") & vbCrLf
            
            '检查是否全部打印
            If blnAll = True Then
                '加载大项
                '根据性别显示大项
                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
                If rsDX.RecordCount >= 1 Then
                    rsDX.MoveFirst
                    Do
                        '★★★★★★★★★★★★★★★★★★★★★★★★★★★
                        '                   打印大项名称
                        '★★★★★★★★★★★★★★★★★★★★★★★★★★★
                        '退两格显示大项
                        strResult = strResult & "    " & rsDX("DXMC") & vbCrLf
                        
                        '对于每一个大项，打印下属的所有小项
                        intSFYZX = rsDX("DXSFYZX")
                        If intSFYZX = 1 Then
                            '*****************************************************
                            '                       有子项
                            '*****************************************************
                            '获取该大项下面的小项名称和拼音缩写
                            strSQL = "select XXID,XXMC,XXPYSX" _
                                    & " 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 rstemp = New ADODB.Recordset
                            rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                            '检查是否有符合条件的小项