mdldatabase4.bas

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

                    & ",Status=0" _
                    & " where HealthID='" & strHealthID & "'"
            con.Execute strSQL
            
            '调用函数更新消费金额
            '还是不用更新了，这个字段(TotalJE)保留下来，防止以后会员卡带金额
            
            strMsg = "成功发卡。所发卡号为 “" & strNewCard & "”"
        End If
    End If
    
    '在SET_GRXX中更改此客户的卡号
    strSQL = "update SET_GRXX set" _
            & " SelfBH='" & strNewCard & "'" _
            & " where HealthID='" & strHealthID & "'"
    con.Execute strSQL
    
    '判断是否需要提交事务
    If blnEnableTrans Then
        con.CommitTrans
    End If
    
    SendCardW = True '成功返回
    If blnSuccessInfo And (strMsg <> "") Then
        MsgBox strMsg, vbInformation, "提示"
    End If
    
    GoTo ExitLab
RollBack:
    con.RollbackTrans '这里不用判断是否启动事务。能运行到这里，就说明事务已经被启动了
ExitLab:
    If blnCommitTrans And blnEnableTrans Then
        con.CommitTrans
    End If
    '
End Function

'**********************************************************************
'主要设置ListView以及MSHFlexGrid控件的列名及列宽
'参数1：控件名
'参数2：要设置的系统档案号标题的索引
'参数3：要设置的自定义档案号标题的索引
'返回值：无
'**********************************************************************
Public Sub SetObjectTitleAndWidth(ByRef objObject As Object, _
        ByVal intSystemIndex As Integer, ByVal intSelfIndex As Integer)
    If TypeOf objObject Is ListView Then
        '设置ListView的列名及列宽
        With objObject
            .ColumnHeaders(intSystemIndex).Text = g_strSystemIDTitle
            If Not g_blnSystemID Then
                .ColumnHeaders(intSystemIndex).Width = 0
            End If
            .ColumnHeaders(intSelfIndex).Text = g_strSelfIDTitle
            If Not g_blnSelfID Then
                .ColumnHeaders(intSelfIndex).Width = 0
            End If
        End With
    ElseIf TypeOf objObject Is mshFlexGrid Then
        '设置MSHFlexGrid控件的列宽
        With objObject
            If Not g_blnSystemID Then
                .ColWidth(intSystemIndex) = 0
            End If
            If Not g_blnSelfID Then
                .ColWidth(intSelfIndex) = 0
            End If
        End With
    End If
End Sub

'**********************************************************************
'生成指定客户的科室小结
'参数1：GUID
'参数2：科室ID
'参数3：相反的性别。1女；2男
'参数4：体检标准
'参数5：医生编号
'返回值：生成的科室小结
'**********************************************************************
Public Function GetKSResult(ByVal lngGUID As Long, ByVal strKSID As String, _
        ByVal intSex As Integer, ByVal intBZID As Integer, _
        ByVal intDoctorID As Integer) As String
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strTemp As String
    Dim rstemp As ADODB.Recordset
    Dim rsData As ADODB.Recordset
    Dim rsHZ As ADODB.Recordset
    Dim i As Integer
    Dim strResult As String '科室小结
    Dim strTempJYi As String '临时存放每个项目的建议
    
    Dim strDXPYSX As String
    Dim strXXPYSX As String
    Dim intType As Integer
    Dim strXMID As String
    Dim strXMMC As String
    
    Dim strID As String
    Dim strXJie As String
    Dim strJYi As String '辅助建议
    Dim strValue As String '字符型数字
    Dim strDXID As String
    
    'wxw add 根据乙肝五项生成结论 20050727于空疗
    Dim strYIGanResult(5) As String
    Dim strYIGanNamol(5) As String
    Dim strYIGanName(5) As String
    Dim strItemId(6) As String
    
    Dim YIGANFile As Boolean
    If Dir(gstrCurrPath & "YIGANItem.ini") <> "" Then YIGANFile = True
    '**********************20040520加入 闻********************************
    '在GetTJResult中标识当要取的值是否为空，如为空说明当前项目未录入，则不允许生成小结(千福要求)
    Dim blXMValueisNull As Boolean
    blXMValueisNull = False      '初始化为false
    '**********************20040520加入完 闻******************************

    Screen.MousePointer = vbHourglass
    
    '获取当前科室下有选择的所有大项
    strSQL = "select * from SET_DX" _
            & " where KSID='" & strKSID & "'" _
            & " and DXID in (select DXID from YY_SJDJDX where GUID=" & lngGUID & ")" _
            & " and DXNNTY<>" & intSex
    '按顺序号排序
    strSQL = strSQL & " order by SXH"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount > 0 Then
        rstemp.MoveFirst
        Do
            strDXPYSX = rstemp("DXPYSX")
            strDXID = rstemp("DXID")
            strJYi = ""
            
            strSQL = "select * from SET_XX" _
                    & " where XXID in (" _
                            & "select XXID from SET_ZH_Data" _
                            & " where DXID='" & rstemp("DXID") & "'" _
                        & ")" _
                        & " and XXSFJRXJ=1" _
                        & " and XXNNTY<>" & intSex
            '按顺序号排序
            strSQL = strSQL & " order by SXH"
            Set rsData = New ADODB.Recordset
            rsData.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            If rsData.RecordCount >= 1 Then
                '首先检是否所有的小项均已输入,若有一项没输入,则不能生成小结
                rsData.MoveFirst
                If gTiJiao = True Then          '如果采用提交方式
                    Do While Not rsData.EOF
                        If CheckXMInput(lngGUID, rstemp("DXID"), rsData("XXID")) = False Then
                            MsgBox "项目 " & rsData("XXMC") & _
                                    " 未录入，不能生成小结，请检查该科各项输入", vbInformation, "提示"
                            GoTo ExitLab
                        End If
                        
                        rsData.MoveNext
                    Loop
                End If
                
                '循环处理所有项目
                rsData.MoveFirst
                Do
                    strXMID = rsData("XXID")
                    strXMMC = rsData("XXMC")
                    strXXPYSX = rsData("XXPYSX")
                    intType = rsData("XXType")
                    strTempJYi = "" '清空
                    GoSub GetTJResult
                    
                    If strTempJYi <> "" Then
                        strJYi = strJYi & strTempJYi & "；"
                    End If
                    
                    rsData.MoveNext
                Loop Until rsData.EOF
                rsData.Close
                
                '截掉最后一个逗号
                If strJYi <> "" Then
                    strJYi = Left(strJYi, Len(strJYi) - 1)
                End If
            End If
            
            '把建议写入建议表
            If strJYi <> "" Then
                Call WriteKSJY(lngGUID, strKSID, strDXID, strJYi)
                strJYi = ""
            End If
            
            rstemp.MoveNext
        Loop Until rstemp.EOF
        rstemp.Close
        
        '所有项目都已处理完毕
        If strResult <> "" Then
            strResult = Left(strResult, Len(strResult) - 1)
        End If
    End If
    
    '*******************************************************
    '添加小结
    '*******************************************************
    If strResult = "" Then
        strResult = "未见异常。" '在没有科室小结时，用默认值填充
    End If
    Call WriteKSXJ(lngGUID, strKSID, Date, intDoctorID, strResult)
    
    '返回
    GetKSResult = strResult
    
    GoTo ExitLab
    
'获取某一项目的体检结果
GetTJResult:
    strSQL = "select distinct GUID as 流水号" _
            & ",[Data_" & strDXPYSX & "].[" & strXXPYSX & "]" _
            & " as [抽查结果]" _
            & ",DW,NormalVal,CKXX,CKSX,HighInfo,LowInfo" _
            & " from [Data_" & strDXPYSX & "],SET_TJBZDT" _
            & " where GUID=" & lngGUID _
            & " and BZID=" & intBZID _
            & " and XMID='" & strXMID & "'" _
            & " and SET_TJBZDT.SEX<>" & intSex
    If intType = 1 Or intType = 3 Then
        '数值型
        strSQL = strSQL & " and (cast([Data_" & strDXPYSX & "].[" & strXXPYSX & "] as float)<cast(CKXX as float)" _
                & " or cast([Data_" & strDXPYSX & "].[" & strXXPYSX & "] as float)>cast(CKSX as float))"
    Else
        '非数值型
        strSQL = strSQL & " and [Data_" & strDXPYSX & "].[" & strXXPYSX & "]<>NormalVal"
    End If
    
    '***********************************
    '执行查询
    '***********************************
    Set rsHZ = New ADODB.Recordset
    rsHZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsHZ.RecordCount >= 1 Then
    
       'wxw add 20050727 于空疗
       If YIGANFile Then '配置文件存在则检验
           strItemId(0) = GetINI(gstrCurrPath & "YIGANItem.ini", "ITEM", "item1", "?")
           strItemId(1) = GetINI(gstrCurrPath & "YIGANItem.ini", "ITEM", "item2", "?")
           strItemId(2) = GetINI(gstrCurrPath & "YIGANItem.ini", "ITEM", "item3", "?")
           strItemId(3) = GetINI(gstrCurrPath & "YIGANItem.ini", "ITEM", "item4", "?")
           strItemId(4) = GetINI(gstrCurrPath & "YIGANItem.ini", "ITEM", "item5", "?")
           strItemId(5) = GetINI(gstrCurrPath & "YIGANItem.ini", "ITEM", "ItemCal", "?")
           
           
            Select Case strXMID
            Case strItemId(0)
                strYIGanResult(0) = Trim(rsHZ("抽查结果"))
                strYIGanName(0) = strXMMC
            Case strItemId(1)
                strYIGanResult(1) = Trim(rsHZ("抽查结果"))
                strYIGanName(1) = strXMMC
            Case strItemId(2)
                strYIGanResult(2) = Trim(rsHZ("抽查结果"))
                strYIGanName(2) = strXMMC
            Case strItemId(3)
                strYIGanResult(3) = Trim(rsHZ("抽查结果"))
                strYIGanName(3) = strXMMC
            Case strItemId(4)
                strYIGanResult(4) = Trim(rsHZ("抽查结果"))
                strYIGanName(4) = strXMMC
            End Select
        End If
        
        If Trim(rsHZ("抽查结果")) <> "" Then
            '补充说明：strTemp记录体检结果，strTempJyi记录对应建议
            If YIGANFile Then '配置文件存在则检验
                If strXMID <> strItemId(0) And strXMID <> strItemId(1) And strXMID <> strItemId(2) And strXMID <> strItemId(3) And strXMID <> strItemId(4) Then
                    strTemp = strXMMC
                End If
            Else
                strTemp = strXMMC
            End If

            If intType = 1 Or intType = 3 Then
                '数值型
                strTempJYi = strXMMC
                'wxw add  根据数值型的标准生成科室小结
                Dim rs As ADODB.Recordset
                Set rs = GCon.Execute("select xx_value  from set_xx_bz where " & rsHZ("抽查结果") & ">=XX_min and " & rsHZ("抽查结果") & "< XX_max  and XX_Id='" & strXMID & "' and BZ_ID=" & intBZID & " and sex<>" & intSex)
                If rs.RecordCount >= 1 Then
                    strTemp = strTemp & Trim(rs!xx_value) & "(" & rsHZ("抽查结果") & rsHZ("DW") & ")"
                Else
                    strTemp = ""
                    strTempJYi = ""
                End If

'                strTempJYi = strXMMC
'                If (Val(rsHZ("抽查结果")) < Val(rsHZ("CKXX"))) And (rsHZ("CKXX") <> "") Then
'                    strTemp = strTemp & rsHZ("LowInfo") & "(" & rsHZ("抽查结果") & rsHZ("DW") & ")" '已有其它符号，可避免Null值
'                    strTempJYi = strTempJYi & rsHZ("LowInfo") & "" '避免Null值
'                ElseIf Val(rsHZ("抽查结果")) > Val(rsHZ("CKSX")) And (rsHZ("CKSX") <> "") Then
'                    strTemp = strTemp & rsHZ("HighInfo") & "(" & rsHZ("抽查结果") & rsHZ("DW") & ")"
'                    strTempJYi = strTempJYi & rsHZ("HighInfo") & "" '避免Null值
'                Else
'                    strTemp = ""
'                    strTempJYi = ""
'                End If
            Else