frmtjpq.frm

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

    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim rsFZ As ADODB.Recordset
    Dim dtmDate As Date
    Dim itemX As ListItem
    Dim nodeTemp As Node
    Dim blnFirst As Boolean '是否第一个单位
    
    Me.MousePointer = vbHourglass
    
    '首先清除上次的查询结果
    tvwDWei.Nodes.Clear
    lvwPerson.ListItems.Clear
    txtHJRS.Text = ""
    
    '禁用打印按钮
    cmdPrint.Enabled = False
    '清除模块打印变量
    mstrSQL = ""
    
    '当前要查询的日期
    dtmDate = DTP1.Value
    
    '个人还是团体
    If optGRen Then
        '*************************************************************************
        '查询散检中符合条件的客户
        '*************************************************************************
        strSQL = "select SET_GRXX.GUID,HealthID,SelfBH,YYRXM,Sex,Age,Status='未检'" _
                & " from SET_GRXX,YY_SJDJ" _
                & " where ((YYID is null) or (YYID=''))" _
                & " and SET_GRXX.TJRQ='" & dtmDate & "'" _
                & " and SET_GRXX.GUID=YY_SJDJ.GUID" _
                & " and (SFTJ=0 or SFTJ=1)"
        strSQL = strSQL & " union "
        strSQL = strSQL & "select SET_GRXX.GUID,HealthID,SelfBH,YYRXM,Sex,Age,Status='已检'" _
                & " from SET_GRXX,YY_SJDJ" _
                & " where ((YYID is null) or (YYID=''))" _
                & " and SET_GRXX.TJRQ='" & dtmDate & "'" _
                & " and SET_GRXX.GUID=YY_SJDJ.GUID" _
                & " and (SFTJ=2)"
        
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rstemp.RecordCount > 0 Then
            '显示查询到的总人数
            txtHJRS.Text = rstemp.RecordCount
            
            '向lvwPerson中加入个人预约的信息列表
            rstemp.MoveFirst
            Do While Not rstemp.EOF
                Set itemX = lvwPerson.ListItems.Add(, "W" & rstemp("GUID"), rstemp("HealthID"))
                itemX.SubItems(1) = rstemp("SelfBH") & ""
                itemX.SubItems(2) = rstemp("YYRXM")
                itemX.SubItems(3) = rstemp("Sex")
                itemX.SubItems(4) = rstemp("Age") & ""
                itemX.SubItems(5) = rstemp("Status")
                rstemp.MoveNext
            Loop
            
            rstemp.Close
            mstrSQL = strSQL
        End If
        
    Else
        '*************************************************************************
        '查询团检中符合条件的客户
        '*************************************************************************
        '添加一个根节点
        '关键字长度：1＝1
        tvwDWei.Nodes.Clear
        Set nodeTemp = tvwDWei.Nodes.Add(, , "W", "团检单位")
        nodeTemp.Expanded = True
        Set nodeTemp = Nothing
        
        strSQL = "select YY_TJDJ.*,SET_DW.*" _
                & " from YY_TJDJ,SET_DW" _
                & " where TJRQ='" & dtmDate & "'" _
                & " and YY_TJDJ.DWID=SET_DW.DWID"
'                & " and (SFTJ=0 or SFTJ=1)"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        '有预约的团体
        If rstemp.RecordCount > 0 Then
            rstemp.MoveFirst
            blnFirst = True
            Do While Not rstemp.EOF
                Set nodeTemp = tvwDWei.Nodes.Add("W", tvwChild, "W" & rstemp("YYID"), rstemp("DWMC"))
                If blnFirst = True Then
                    Set tvwDWei.SelectedItem = nodeTemp
                    tvwDWeiClick
                    
                    blnFirst = False
                End If
                
                '获取当前YYID中的分组信息
                Set rsFZ = New ADODB.Recordset
                strSQL = "select * from FZ_FZSY WHERE YYID='" & rstemp("YYID") & "'"
                rsFZ.Open strSQL, GCon, adOpenDynamic, adLockOptimistic
                If rsFZ.RecordCount > 0 Then
                    rsFZ.MoveFirst
                    Do While Not rsFZ.EOF
                        Set nodeTemp = tvwDWei.Nodes.Add("W" & rstemp("YYID"), tvwChild, "W" & rstemp("YYID") & rsFZ("FZID"), rsFZ("FZMC"))
                    
                        rsFZ.MoveNext
                    Loop
                    
                    rsFZ.Close
                End If
                
                rstemp.MoveNext
            Loop
            rstemp.Close
        
            '构建用于打印的语句。
            '对于散检，这一步不需要，因为一开始构造的就是这个语句
            strSQL = "select SET_GRXX.GUID,HealthID,SelfBH,YYRXM,Sex,Age,Status='未检'" _
                    & " from SET_GRXX,FZ_FZSJ" _
                    & " where not (SET_GRXX.YYID is null)" _
                    & " and SET_GRXX.TJRQ='" & dtmDate & "'" _
                    & " and SET_GRXX.GUID=FZ_FZSJ.GUID" _
                    & " and (SFTJ=0 or SFTJ=1)"
            strSQL = strSQL & " union "
            strSQL = strSQL & "select SET_GRXX.GUID,HealthID,SelfBH,YYRXM,Sex,Age,Status='已检'" _
                    & " from SET_GRXX,FZ_FZSJ" _
                    & " where not (SET_GRXX.YYID is null)" _
                    & " and SET_GRXX.TJRQ='" & dtmDate & "'" _
                    & " and SET_GRXX.GUID=FZ_FZSJ.GUID" _
                    & " and (SFTJ=2)"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            If rstemp.RecordCount > 0 Then
                txtHJRS.Text = rstemp.RecordCount
                
                mstrSQL = strSQL
            End If
        End If
    End If
    
    '根据打印变量是否有值来决定打印按钮的启用与否
    If mstrSQL <> "" Then
        cmdPrint.Enabled = True
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub optGRen_Click()
    cmdQueryClick
End Sub

Private Sub optTTi_Click()
    cmdQueryClick
End Sub

Private Sub tvwDWeiClick()
On Error GoTo ErrMsg
    Dim Status
    Dim tmpYYID As String
    Dim tmpFZID As Integer
    Dim rstemp As ADODB.Recordset
    Dim strSQL As String
    Dim itemX As ListItem
    
    Me.MousePointer = vbHourglass
    
    lvwPerson.ListItems.Clear
    
    If tvwDWei.SelectedItem Is Nothing Then GoTo ExitLab
    
    Select Case Len(tvwDWei.SelectedItem.Key)
        Case 12 '单位节点
            '显示当前单位的人员
            tmpYYID = Left(Mid(tvwDWei.SelectedItem.Key, 2), 11)
            
            strSQL = "select SET_GRXX.GUID,HealthID,SelfBH,YYRXM,Sex,Age,Status='未检'" _
                    & " from SET_GRXX,FZ_FZSJ" _
                    & " where SET_GRXX.YYID='" & tmpYYID & "'" _
                    & " and SET_GRXX.GUID=FZ_FZSJ.GUID" _
                    & " and (SFTJ=0 or SFTJ=1)"
            strSQL = strSQL & " union "
            strSQL = strSQL & "select SET_GRXX.GUID,HealthID,SelfBH,YYRXM,Sex,Age,Status='已检'" _
                    & " from SET_GRXX,FZ_FZSJ" _
                    & " where SET_GRXX.YYID='" & tmpYYID & "'" _
                    & " and SET_GRXX.GUID=FZ_FZSJ.GUID" _
                    & " and (SFTJ=2)"
        Case 13, 14    '是分组节点
            '显示当前分组的人员
            tmpYYID = Left(Mid(tvwDWei.SelectedItem.Key, 2), 11)
            tmpFZID = Mid(tvwDWei.SelectedItem.Key, 13)
            
            strSQL = "select SET_GRXX.GUID,HealthID,SelfBH,YYRXM,Sex,Age,Status='未检'" _
                    & " from SET_GRXX" _
                    & " where YYID='" & tmpYYID & "'" _
                    & " and GUID in (" _
                    & "select GUID from FZ_FZSJ where YYID='" & tmpYYID & "'" _
                    & " and FZID=" & tmpFZID _
                    & " and (SFTJ=0 or SFTJ=1))"
            strSQL = strSQL & " union "
            strSQL = strSQL & "select SET_GRXX.GUID,HealthID,SelfBH,YYRXM,Sex,Age,Status='已检'" _
                    & " from SET_GRXX" _
                    & " where YYID='" & tmpYYID & "'" _
                    & " and GUID in (" _
                    & "select GUID from FZ_FZSJ where YYID='" & tmpYYID & "'" _
                    & " and FZID=" & tmpFZID _
                    & " and (SFTJ=2))"
        Case Else   '其它节点
            '清除列表显示
'            lvwPerson.ListItems.Clear'前面已经清空
    End Select
    
    If strSQL <> "" Then
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenDynamic, adLockOptimistic
            
        If rstemp.RecordCount > 0 Then
            '向lvwPerson中加入个人预约的信息列表
            rstemp.MoveFirst
            Do While Not rstemp.EOF
                Set itemX = lvwPerson.ListItems.Add(, "W" & rstemp("GUID"), rstemp("HealthID"))
                itemX.SubItems(1) = rstemp("SelfBH") & ""
                itemX.SubItems(2) = rstemp("YYRXM")
                itemX.SubItems(3) = rstemp("Sex")
                itemX.SubItems(4) = rstemp("Age") & ""
                itemX.SubItems(5) = rstemp("Status")
                
                rstemp.MoveNext
            Loop
            LblRS.Caption = "合计人数：" & rstemp.RecordCount & " 人"
            rstemp.Close
        End If
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub tvwDWei_NodeClick(ByVal Node As MSComctlLib.Node)
    tvwDWeiClick
End Sub

Public Sub PrintReport()
On Error GoTo Print_Cancel
    Dim Status
    Dim Msg As String
    Dim PrintNummber As Integer
    Dim i As Integer, j As Integer
    Dim lngGUID As Long
    Dim strHealthID As String
    Dim strBBID As String
    
    '★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
    '                                  是否已经注册
    '★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
    If gblnRegister = False Then
        MsgBox "您使用的是未注册版本，不能使用该功能，请通过“系统设置”->“系统注册”进行注册！", vbInformation, "提示"
        Exit Sub
    End If
    '★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
    
    CommonDialog1.CancelError = True
    CommonDialog1.Flags = cdlPDCollate Or cdlPDNoSelection     ' cdlPDUseDevModeCopies
     'CommonDialog1.Flags = cdlPDPageNums
    CommonDialog1.Min = 1
    CommonDialog1.Max = 1
    CommonDialog1.FromPage = 1
    CommonDialog1.ToPage = 1

    CommonDialog1.ShowPrinter
On Error Resume Next
    Printer.Copies = CommonDialog1.Copies
    If Printer.Copies < 1 Then Printer.Copies = 1
    '纵向走纸
    Printer.Orientation = cdlPortrait
On Error GoTo Print_Cancel
    '设成A4纸
    Printer.ScaleMode = vbMillimeters
    Printer.ScaleWidth = 210
    Printer.ScaleHeight = 297
    
    '调用打印程序
    PrintPerson DTP1.Value
    
    Exit Sub
Print_Cancel:
    MousePointer = vbDefault
    If Err.Number <> cdlCancel Then
        Status = SetError(Err.Number, "无法完成打印，请确认打印机电源已经开启并与计算机正确连接！:" _
                & vbCrLf & Err.Description, Err.Source)
        ErrMsg Status
    End If
End Sub

'打印当前选择日期的体检人员。包括团检和散检
'传入参数：要打印人员的日期
Public Sub PrintPerson(ByVal dtmDate As Date)