frmfyhz.frm

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

    Dim strSelect As String 'SQL语句的Select部分
    Dim strSJ As String '散检部分
    Dim strTJ As String '团检部分
    Dim strTJ_A As String '团检部分
    Dim strCondition As String '用户输入的查询条件
    Dim rsHZ As ADODB.Recordset
    Dim rstemp As ADODB.Recordset
    Dim itmHZ As ListItem
    Dim curTotal_XMJG As Currency
    Dim curTotal_CJJG As Currency
    Dim curTotal_ZFJG As Currency
    
    Me.MousePointer = vbHourglass
    
    '是否选择了单位
'    If cmbDWei.Text = "" Then
'        MsgBox "请选择要汇总的单位！", vbInformation, "提示"
'        GoTo ExitLab
'    End If
    
    
    '日期是否符合规范
    If dtpBegin.Value > dtpStop.Value Then
        MsgBox "起始日期不应大于终止日期！请核对后重新输入！", vbInformation, "提示"
        dtpBegin.SetFocus
        GoTo ExitLab
    End If
    
    '******************************************************
    '检验完毕
    '******************************************************
    '***********************************
    '以下构建查询语句的Select部分
    '***********************************
    strSelect = "select SET_GRXX.GUID as 流水号,HealthID as " & g_strSystemIDTitle _
            & ",SelfBH as " & g_strSelfIDTitle & ",TJSerialNum as 体检序号" _
            & ",YYRXM as 姓名,SET_GRXX.SEX as 性别,SET_GRXX.AGE as 年龄" _
            & ",SET_GRXX.TJRQ as 体检日期" _
            & ",SET_GRXX.XMJG as 项目价格,SET_GRXX.CJJG as 成交价格" _
            & ",SET_GRXX.YYID"
    
    '***********************************
    '以下根据用户选择决定显示全部还是只显示团检客户
    '***********************************
    '如果选择了一个团体
    If cmbDWei.Text <> "" Then
        strTJ = " from SET_GRXX,FZ_FZSJ" _
                    & " where SET_GRXX.YYID='" & arrYYID(cmbDWei.ItemData(cmbDWei.ListIndex)) & "'" _
                    & " and SET_GRXX.GUID=FZ_FZSJ.GUID" _
                    & " and FZ_FZSJ.SFTJ in (1,2)"
        If txtName.Text <> "" Then
            strTJ = strTJ & " and YYRXM like '%" & Trim(txtName.Text) & "%'"
        End If
        If cmbSex.Text <> "" Then
            strTJ = strTJ & " and SET_GRXX.SEX='" & cmbSex.Text & "'"
        End If
    End If
    If cmbDWei.Text = "" Then
        '这个时候要考虑到散检客户
        strSJ = " from SET_GRXX,YY_SJDJ" _
                & " where SET_GRXX.GUID=YY_SJDJ.GUID" _
                & " and YY_SJDJ.SFTJ in (1,2)"
    
        '团体全部
       strTJ_A = " from SET_GRXX,FZ_FZSJ" _
                & " where SET_GRXX.YYID=FZ_FZSJ.YYID" _
                & " and SET_GRXX.GUID=FZ_FZSJ.GUID" _
                & " and FZ_FZSJ.SFTJ in (1,2)"
        If txtName.Text <> "" Then
            strSJ = strSJ & " and YYRXM like '%" & Trim(txtName.Text) & "%'"
            strTJ_A = strTJ_A & " and YYRXM like '%" & Trim(txtName.Text) & "%'"
        End If
        If cmbSex.Text <> "" Then
            strSJ = strSJ & " and SET_GRXX.SEX='" & cmbSex.Text & "'"
            strTJ_A = strTJ_A & " and SET_GRXX.SEX='" & cmbSex.Text & "'"
        End If
    End If
    
    '***********************************
    '构建最后的查询语句
    '***********************************
    If strSJ = "" Then
        strSQL = strSelect & strTJ _
                & " and SET_GRXX.TJRQ>='" & dtpBegin.Value & "'" _
                & " and SET_GRXX.TJRQ<='" & dtpStop.Value & " 23:59:59'"
    Else
        strSQL = strSelect & strTJ_A _
                & " and SET_GRXX.TJRQ>='" & dtpBegin.Value & "'" _
                & " and SET_GRXX.TJRQ<='" & dtpStop.Value & " 23:59:59'" _
                & " union " _
                & strSelect & strSJ _
                & " and SET_GRXX.TJRQ>='" & dtpBegin.Value & "'" _
                & " and SET_GRXX.TJRQ<='" & dtpStop.Value & " 23:59:59'"
    End If
    
    '***********************************
    '执行查询
    '***********************************
    Set rsHZ = New ADODB.Recordset
    rsHZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    DoEvents
    If rsHZ.RecordCount >= 1 Then
        '显示到ListView控件
        lvwSJRY.ListItems.Clear
        rsHZ.MoveFirst
        Do
            Set itmHZ = lvwSJRY.ListItems.Add(, "W" & rsHZ("流水号"), rsHZ(g_strSystemIDTitle))
            itmHZ.SubItems(1) = rsHZ(g_strSelfIDTitle) & ""
            itmHZ.SubItems(2) = rsHZ("姓名")
            itmHZ.SubItems(3) = rsHZ("性别")
            itmHZ.SubItems(4) = rsHZ("年龄") & ""
            itmHZ.SubItems(5) = rsHZ("体检日期")
            
            '获取累计价格
'            If Not IsNull(rsHZ("项目价格")) Then
'                '有数据时以当时计算为准
'                itmHZ.SubItems(6) = rsHZ("项目价格")
'                curTotal_XMJG = curTotal_XMJG + rsHZ("项目价格")
'            Else
'                '无数据时重新计算
                strSQL = "select Sum(DXJG) from SET_DX" _
                        & " where DXID in(" _
                            & "select DXID from YY_SJDJDX" _
                            & " where GUID=" & rsHZ("流水号") _
                        & ")"
                Set rstemp = New ADODB.Recordset
                rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
                If Not rstemp.EOF Then
                    If Not IsNull(rstemp(0)) Then
                        itmHZ.SubItems(6) = rstemp(0)
                          
                        curTotal_XMJG = curTotal_XMJG + rstemp(0)
                    End If
                    rstemp.Close
                End If
'            End If
            
            itmHZ.SubItems(7) = rsHZ("成交价格") & ""
            
            '是否有单位
            If Not IsNull(rsHZ("YYID")) Then
                strSQL = "select DWMC from SET_DW,YY_TJDJ" _
                        & " where YY_TJDJ.YYID='" & rsHZ("YYID") & "'" _
                        & " and YY_TJDJ.DWID=SET_DW.DWID"
                Set rstemp = New ADODB.Recordset
                rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
                If Not rstemp.EOF Then
                    itmHZ.SubItems(9) = rstemp("DWMC")
                    rstemp.Close
                End If
            End If
            
            '成交价格
            If Not IsNull(rsHZ("成交价格")) Then
                curTotal_CJJG = curTotal_CJJG + rsHZ("成交价格")
            End If
            
            '已支付费用
            
            If itmHZ.Index Mod 150 = 0 Then DoEvents
            
            rsHZ.MoveNext
        Loop Until rsHZ.EOF
        
        rsHZ.Close
        Set rsHZ = Nothing
        
        '最后添加一栏总费用
        Set itmHZ = lvwSJRY.ListItems.Add(, "W", "总计")
        If Not g_blnSystemID Then
            itmHZ.SubItems(1) = "总计"
        End If
        itmHZ.SubItems(6) = curTotal_XMJG
        itmHZ.SubItems(7) = curTotal_CJJG
        
        Set lvwSJRY.SelectedItem = lvwSJRY.ListItems(1)
        lvwSJRYClick
    Else
        MsgBox "没有找到匹配记录！请重新输入查询条件", vbInformation, "提示"
    End If
    
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim nodTemp As Node
    Dim rsYY As ADODB.Recordset
    Dim i As Integer
    
    Screen.MousePointer = vbHourglass
    
    dtpBegin.Value = Date
    dtpStop.Value = Date
    
    Me.Height = 8355
    Me.Width = 9795
    
    
    '显示所有预约的团体
    '刷新团体信息
    strSQL = "select YYID,DWMC" _
            & " from YY_TJDJ,SET_DW" _
            & " where YY_TJDJ.DWID=SET_DW.DWID" _
            & " order by JLRQ desc"
    Set rsYY = New ADODB.Recordset
    rsYY.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    cmbDWei.Clear
    If rsYY.RecordCount > 0 Then
        ReDim arrYYID(rsYY.RecordCount)
        
        '首先添加一个空行，以便用户不选择单位
        cmbDWei.AddItem ""
        
        '添加已经预约过的团体
        rsYY.MoveFirst
        For i = 1 To rsYY.RecordCount
            cmbDWei.AddItem rsYY("DWMC")
            cmbDWei.ItemData(cmbDWei.NewIndex) = i
            arrYYID(i) = rsYY("YYID") 'YYID字段太长，ItemData属性无法存放，只能存入数组
            
            rsYY.MoveNext
        Next
        rsYY.Close
        Set rsYY = Nothing
        
        cmbDWei.ListIndex = 0
    End If
    
    '设置ListView的列名及列宽
    Call SetObjectTitleAndWidth(Me.lvwSJRY, 1, 2)
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

Private Sub lvwSJRYClick()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsHZ As ADODB.Recordset
    Dim itmHZ As ListItem
    Dim lngGUID As Long
    Dim curTotal_XMJG As Currency
    Dim curTotal_CJJG As Currency
    Dim curTotal_ZFJG As Currency
    
    Me.MousePointer = vbHourglass
    
    lvwFYQD.ListItems.Clear
    
    '判断是否有选择
    If lvwSJRY.ListItems.Count < 1 Then
        lblTitle.Caption = "费用清单"
        GoTo ExitLab
    End If
    If lvwSJRY.SelectedItem Is Nothing Then
        lblTitle.Caption = "费用清单"
        GoTo ExitLab
    End If
    
    '是否单击了“合计”一栏
    If Len(lvwSJRY.SelectedItem.Key) = 1 Then
        lblTitle.Caption = "费用清单"
        GoTo ExitLab
    End If
    
    cmdPrint.Enabled = True
    lblTitle.Caption = lvwSJRY.SelectedItem.SubItems(2) & " 的 费用清单"
    
    '获取ID号和类型
    lngGUID = Val(Mid(lvwSJRY.SelectedItem.Key, 2))
    '提取选择的项目
    strSQL = "select DXMC,DXJG,KSMC from SET_DX,YY_SJDJDX,SET_KSSZ" _
            & " where YY_SJDJDX.GUID=" & lngGUID _
            & " and YY_SJDJDX.DXID=SET_DX.DXID" _
            & " and left(SET_DX.DXID,2)=SET_KSSZ.KSID" _
            & " order by SET_KSSZ.SXH,SET_DX.SXH"
    Set rsHZ = New ADODB.Recordset
    rsHZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If Not (rsHZ.EOF) Then
        rsHZ.MoveFirst
        Do
            Set itmHZ = lvwFYQD.ListItems.Add(, , rsHZ("KSMC"))
            itmHZ.SubItems(1) = rsHZ("DXMC")
            itmHZ.SubItems(2) = rsHZ("DXJG") & ""
            '累加项目价格
            If Not IsNull("DXJG") Then
                curTotal_XMJG = curTotal_XMJG + rsHZ("DXJG")
            End If
            
            rsHZ.MoveNext
        Loop Until rsHZ.EOF
        rsHZ.Close
        
        '加上一行项目合计
        Set itmHZ = lvwFYQD.ListItems.Add(, , "项目合计")
        itmHZ.SubItems(2) = CStr(curTotal_XMJG)
        
        '加上一行成交价格
        Set itmHZ = lvwFYQD.ListItems.Add(, , "成交价格")
        itmHZ.SubItems(2) = lvwSJRY.SelectedItem.SubItems(7)
    End If
    Set rsHZ = Nothing
    
    mstrFYQD = strSQL
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set FrmFYHZ = Nothing
End Sub

Private Sub lvwSJRY_KeyUp(KeyCode As Integer, Shift As Integer)
    If (KeyCode = vbKeyUp) Or (KeyCode = vbKeyDown) Then
        lvwSJRYClick
    End If
End Sub
    
Private Sub lvwSJRY_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    lvwSJRYClick
    
    If lvwSJRY.ListItems.Count > 0 Then
    
        If Button = vbRightButton Then
            If Len(lvwSJRY.SelectedItem.Key) > 1 Then
                PopupMenu fMainForm.mnuPrint_
            End If
        Else
            If Len(lvwSJRY.SelectedItem.Key) > 1 Then
                cmdPrint.Enabled = True
            Else
                cmdPrint.Enabled = False
            End If
        End If
    End If
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
    
    '★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
    '                                  是否已经注册
    '★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
    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