frmtjrstj.frm

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

    
    '检查日期是否错误
    If dtpEnd.Value < dtpStart.Value Then
        MsgBox "起始日期不能大于终止日期，请重新设置！", vbInformation, "提示"
        GoTo ExitLab
    Else
        '记录起止日期
        dtmStart = dtpStart.Value
        dtmEnd = DateValue(dtpEnd.Value & " 23:59")
        mdtmStart = dtmStart
        mdtmEnd = dtmEnd
    End If
    
    '清除之前的查询结果
    lvwRS.ListItems.Clear
    cmdPrint.Enabled = False '禁用打印
    
    '查询方式
    If optTTi.Value Then
        '******************************************************************************
        '                               按团体方式查询
        '******************************************************************************
        '清除树型结构
        tvwDWei.Nodes.Clear
        
        '首先检索满足条件的团体
        strSQL = "select YY_TJDJ.YYID,DWMC,Count(GUID) as Number from YY_TJDJ,SET_DW,FZ_FZSJ" _
                & " where YY_TJDJ.DWID=SET_DW.DWID" _
                & " and YY_TJDJ.TJRQ between '" & dtmStart & "' and '" & dtmEnd & "'" _
                & " and YY_TJDJ.YYID=FZ_FZSJ.YYID" _
                & " group by YY_TJDJ.YYID,DWMC"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rstemp.RecordCount <= 0 Then
            blnHave = False
        Else
            blnHave = True
            '首先添加根节点
            Set nodTemp = tvwDWei.Nodes.Add(, , "T", "团检") '团检根节点
            nodTemp.Expanded = True
            '添加团体
            rstemp.MoveFirst
            Do
                tvwDWei.Nodes.Add "T", tvwChild, "W" & rstemp("YYID"), rstemp("DWMC") & "(" & rstemp("Number") & "人)"
                
                '检索该团体下的分组
                strSQL = "select FZ_FZSY.FZID,FZMC,Count(GUID) as Number from FZ_FZSY,FZ_FZSJ" _
                        & " where FZ_FZSY.YYID='" & rstemp("YYID") & "'" _
                        & " and FZ_FZSY.YYID=FZ_FZSJ.YYID" _
                        & " and FZ_FZSY.FZID=FZ_FZSJ.FZID" _
                        & " group by FZ_FZSY.FZID,FZMC"
                Set rsFZ = New ADODB.Recordset
                rsFZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                If rsFZ.RecordCount > 0 Then
                    rsFZ.MoveFirst
                    Do
                        '添加分组
                        tvwDWei.Nodes.Add "W" & rstemp("YYID"), tvwChild, _
                                "W" & rstemp("YYID") & rsFZ("FZID"), rsFZ("FZMC") & "(" & rsFZ("Number") & "人)"
                        
                        rsFZ.MoveNext
                    Loop Until rsFZ.EOF
                    rsFZ.Close
                End If
                
                rstemp.MoveNext
            Loop Until rstemp.EOF
            rstemp.Close
        End If
        
        '检索满足条件的散检人员
        strSQL = "select Count(*) from SET_GRXX" _
                & " where ((YYID is null) or YYID='')" _
                & " and TJRQ between '" & dtmStart & "' and '" & dtmEnd & "'"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rstemp(0) = 0 Then
            If blnHave = False Then
                If m_blnShowInfo Then
                    MsgBox "没有找到匹配记录，请重新设置查询条件！", vbInformation, "提示"
                End If
                GoTo ExitLab
            End If
        Else
            '添加根节点
            Set nodTemp = tvwDWei.Nodes.Add(, , "S", "散检") '散检根节点
            nodTemp.Text = nodTemp.Text & "(" & rstemp(0) & "人)"
        End If
        
        Set tvwDWei.SelectedItem = tvwDWei.Nodes(1)
        Call tvwDWei_NodeClick(tvwDWei.SelectedItem) '这里会显示合计
        cmdPrint.Enabled = True '启用打印
    Else
        '******************************************************************************
        '                               按项目方式查询
        '******************************************************************************
        '是否选择了节点
        If tvwXMu.SelectedItem Is Nothing Then
            MsgBox "请选择要统计的项目！", vbInformation, "提示"
            GoTo ExitLab
        End If
        
        '记录项目编号
        strXMID = Mid(tvwXMu.SelectedItem.Key, 2)
        If Len(strXMID) < 4 Then
            MsgBox "请选择要统计的具体项目！", vbInformation, "提示"
            GoTo ExitLab
        End If
        
        '记录当前项目的名称
        lvwRS.Tag = tvwXMu.SelectedItem.Text '防止用户在查询完毕后切换到其它节点
        
        '***************************************************
        '获取登记过该项目的团体
        '***************************************************
        strSQL = "select YY_TJDJ.YYID,DWMC,Count(YY_SJDJDX.GUID) as Number" _
                & " from SET_GRXX,YY_TJDJ,SET_DW,YY_SJDJDX" _
                & " where SET_GRXX.YYID=YY_TJDJ.YYID" _
                & " and YY_TJDJ.TJRQ between '" & dtmStart & "' and '" & dtmEnd & "'" _
                & " and YY_TJDJ.DWID=SET_DW.DWID" _
                & " and SET_GRXX.GUID=YY_SJDJDX.GUID" _
                & " and YY_SJDJDX.DXID='" & strXMID & "'" _
                & " group by YY_TJDJ.YYID,DWMC"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rstemp.RecordCount > 0 Then
            rstemp.MoveFirst
            Do
                '循环处理每个团体
                '单位名称
                strDWMC = rstemp("DWMC")
                
                '获得该团体的总人数
                intTTZRS = rstemp("Number")
                
                 '向lvwRS中添加
                If intTTZRS > 0 Then
                    Set itemX = lvwRS.ListItems.Add(, , strDWMC) '"W" & rsTemp("YYID")
                    Call ShowPersonRatio(itemX, rstemp("YYID"), , _
                            "exists(select YY_SJDJDX.GUID from YY_SJDJDX" _
                            & " where YY_SJDJDX.GUID=SET_GRXX.GUID" _
                            & " and YY_SJDJDX.DXID='" & strXMID & "')")
                End If
                
                rstemp.MoveNext
            Loop Until rstemp.EOF
            rstemp.Close
            cmdPrint.Enabled = True
        End If
        
        '***************************************************
        '获取登记过该项目的个人
        '***************************************************
        '获得散检总人数
        Set rstemp = New ADODB.Recordset
        strSQL = "select count(*) as 散检总人数 from SET_GRXX,YY_SJDJDX" _
                & " where ((YYID IS Null) or (YYID=''))" _
                & " and TJRQ between '" & dtmStart & "' and '" & dtmEnd & "'" _
                & " and SET_GRXX.GUID=YY_SJDJDX.GUID" _
                & " and YY_SJDJDX.DXID='" & strXMID & "'"
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        intSJZRS = rstemp("散检总人数")
        rstemp.Close
        
        '检查是否有散检人员选择了该项目
        If intSJZRS > 0 Then
            cmdPrint.Enabled = True
        
        
            Set itemX = lvwRS.ListItems.Add(, , "散检")
            Call ShowPersonRatio(itemX, "", , _
                    "exists(select YY_SJDJDX.GUID from YY_SJDJDX" _
                    & " where YY_SJDJDX.GUID=SET_GRXX.GUID" _
                    & " and YY_SJDJDX.DXID='" & strXMID & "')" _
                    & " and ((YYID IS Null) or (YYID=''))" _
                    & " and TJRQ between '" & dtmStart & "' and '" & dtmEnd & "'")
        End If
        
        Call ShowSumRatio
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub dtpEnd_Change()
    mblQuery = False
End Sub

Private Sub dtpStart_Change()
    mblQuery = False
End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsKS As ADODB.Recordset
    Dim rsZH As ADODB.Recordset
    Dim nodTemp As Node
    Dim blnSel As Boolean
    
    Screen.MousePointer = vbArrowHourglass
    m_blnShowInfo = False '窗体加载时不显示提示
    
    blnSel = False
    '显示所有项目组合
    '首先显示根节点
    Set nodTemp = tvwXMu.Nodes.Add(, , "W", "所有项目组合")
    nodTemp.Expanded = True
    '添加仔节点
    strSQL = "select KSID,KSMC from SET_KSSZ"
    Set rsKS = New ADODB.Recordset
    rsKS.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsKS.RecordCount > 0 Then
        rsKS.MoveFirst
        Do
            '添加科室
            tvwXMu.Nodes.Add "W", tvwChild, "W" & rsKS("KSID"), rsKS("KSMC")
            
            strSQL = "select DXID,DXMC from SET_DX" _
                    & " where KSID='" & rsKS("KSID") & "'" _
                    & " order by SXH"
            Set rsZH = New ADODB.Recordset
            rsZH.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            If rsZH.RecordCount > 0 Then
                rsZH.MoveFirst
                Do
                    Set nodTemp = tvwXMu.Nodes.Add("W" & rsKS("KSID"), tvwChild, _
                            "W" & rsZH("DXID"), rsZH("DXMC"))
                    If Not blnSel Then
                        blnSel = True
                        Set tvwXMu.SelectedItem = nodTemp
                    End If
                    
                    rsZH.MoveNext
                Loop Until rsZH.EOF
            End If
            
            rsKS.MoveNext
        Loop Until rsKS.EOF
        rsKS.Close
    End If

    '初始化变量或控件
    mblQuery = False
    lblSJRY.Caption = ""
    dtpEnd.Value = Date '终止日期设为当前日期
    dtpStart.Value = DateAdd("m", -2, Date) '起始日期设为一周前
'    optTTi_Click
    
    '加载完毕后可以显示提示
    m_blnShowInfo = True
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

Private Sub optTTi_Click()
    tvwDWei.ZOrder 0
'    cmdQuery_Click
End Sub

Private Sub optXMu_Click()
    tvwXMu.ZOrder 0
    cmdQuery_Click
End Sub

Private Sub tvwDWei_NodeClick(ByVal Node As MSComctlLib.Node)
    Dim Status
    Dim strYYID As String
    Dim intFZID As Integer
    Dim strFZMC As String
    
    Me.MousePointer = vbHourglass
    
    '是否有选择
    If tvwDWei.SelectedItem Is Nothing Then GoTo ExitLab
    
    strYYID = Mid(tvwDWei.SelectedItem.Key, 2)
    lvwRS.ListItems.Clear
    Select Case Len(strYYID)
        Case 0 '选择了根节点
            If tvwDWei.SelectedItem.Key = "T" Then
                '************************************************************
                '选择了团检根节点
                '************************************************************
                Call ShowTJStatistic(True, "", -1, "", mdtmStart, mdtmEnd)
            Else
                '************************************************************
                '选择了散检根节点
                '************************************************************
                Call ShowTJStatistic(False, "", -1, "", mdtmStart, mdtmEnd)
            End If
        Case 11 '选择了团体
            Call ShowTJStatistic(True, Left(strYYID, 11), -1, "", mdtmStart, mdtmEnd)
        Case Else '选择了分组