frmcwhz.frm

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

    Dim dstop As Date
    Dim strrq As String
    Dim l_djrs As Integer
    Dim c_ysje As Currency
    Dim c_cjje As Currency
    Dim l_cjxx As Integer
    Dim c_ssfy As Currency
    Dim bool As Boolean
    bool = False
     
    If cmbRepType.Text = "日报表" Then lvwSJRY.ListItems.Clear
    
    If cmbRepType.Text = "周报表" Then
        strrq = Format(CStr(MonthView1.Value), "yyyy-mm-dd")
        Set li_find = lvwSJRY.FindItem(strrq, 0)
        If li_find Is Nothing Then
            bool = True
            lvwSJRY.ListItems.Clear
            For n = 1 To 7
                Set litem = lvwSJRY.ListItems.Add()
                strrq = Format(CStr(MonthView1.Value + n - MonthView1.DayOfWeek), "yyyy-mm-dd")
                  
                  
                litem.Text = strrq
                litem.SubItems(1) = get_djxx(strrq)
                litem.SubItems(2) = get_ysje(strrq)
                litem.SubItems(3) = get_cjje(strrq)
                litem.SubItems(4) = get_cjxx(strrq)
                
                litem.SubItems(5) = get_ssfy(strrq)
              
               
              '  DoEvents
            Next n
       End If
    End If
    
    If cmbRepType.Text = "月报表" Then
        strrq = Format(CStr(MonthView1.Value), "yyyy-mm-dd")
        Set li_find = lvwSJRY.FindItem(strrq, 0)
        If li_find Is Nothing Then
            bool = True
            lvwSJRY.ListItems.Clear
            DT = MonthView1.Year & "-" & MonthView1.Month & "-1"
     
            dstop = DateAdd("m", 1, DT)
            lcount = DateDiff("d", DT, dstop)
     
            For n = 0 To lcount - 1
                Set litem = lvwSJRY.ListItems.Add()
                strrq = Format(CStr(DT + n), "yyyy-mm-dd")
                litem.Text = strrq
                litem.SubItems(1) = get_djxx(strrq)
                litem.SubItems(2) = get_ysje(strrq)
                litem.SubItems(3) = get_cjje(strrq)
                litem.SubItems(4) = get_cjxx(strrq)
                litem.SubItems(5) = get_ssfy(strrq)
                If n Mod 5 = 0 Then DoEvents
            Next n
        End If
    End If
    
    If bool = True Then
        Set litem = lvwSJRY.ListItems.Add(1)
        litem.Text = "合计:"
        For n = 2 To lvwSJRY.ListItems.Count
            l_djrs = l_djrs + CCur(lvwSJRY.ListItems.item(n).SubItems(1))
            litem.SubItems(1) = l_djrs
            c_ysje = c_ysje + CCur(lvwSJRY.ListItems.item(n).SubItems(2))
            litem.SubItems(2) = c_ysje
            c_cjje = c_cjje + CCur(lvwSJRY.ListItems.item(n).SubItems(3))
            litem.SubItems(3) = c_cjje
            l_cjxx = l_cjxx + CCur(lvwSJRY.ListItems.item(n).SubItems(4))
            litem.SubItems(4) = l_cjxx
            c_ssfy = c_ssfy + CCur(lvwSJRY.ListItems.item(n).SubItems(5))
            litem.SubItems(5) = c_ssfy
                
        Next n
    End If
End Sub




Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdPrint_Click()
    If Me.lvwSJRY.ListItems.Count > 0 Then
        PrintReport
    Else
        MsgBox "请选择需打印清单的日期", vbInformation, "提示"
    End If
End Sub

Private Sub cmdQuery_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    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
    Dim date_value As Long
    Dim n As Integer
    
    Me.MousePointer = vbHourglass
    
 
    
   '是否选择了单位
    If cmbRepType.Text = "" Then
        MsgBox "请选择报表类型！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    
    
    
    '日期是否符合规范
    If dtpBegin.Value > dtpStop.Value Then
        MsgBox "起始日期不应大于终止日期！请核对后重新输入！", vbInformation, "提示"
        dtpBegin.SetFocus
        GoTo ExitLab
    End If
    lvwSJRY.ColumnHeaders.Clear
    
    If cmbRepType.Text = "日报表" Then
           date_value = DateDiff("d", dtpBegin.Value, dtpStop.Value)
           
     End If
     If cmbRepType.Text = "周报表" Then
           date_value = DateDiff("w", dtpBegin.Value, dtpStop.Value)
            
    End If
     If cmbRepType.Text = "月报表" Then
           date_value = DateDiff("m", dtpBegin.Value, dtpStop.Value)
           
    End If
    If date_value <= 0 Then
       GoTo ExitLab
    End If
    If cmbRepType.Text = "日报表" Then
        
    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
'    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
'
'            '已支付费用
'
'
'            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 = Now ' - 7
    dtpStop.Value = Date
    
    Me.Height = 8355
    Me.Width = 9795
    cmbRepType.ListIndex = 0
    
    
'    '显示所有预约的团体
'    '刷新团体信息
'    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
'
        
'    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.Text & " 的 费用清单"
    
    '获取ID号和类型
    lngGUID = Val(Mid(lvwSJRY.SelectedItem.Key, 2))
    '提取选择的项目