frmmian.frm

这是本人几年前写的一个导医院His数据的小程序。

            Strikethrough   =   0   'False
         EndProperty
         Height          =   375
         Index           =   0
         Left            =   150
         TabIndex        =   4
         Top             =   330
         Width           =   1515
      End
   End
End
Attribute VB_Name = "frmMian"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim rsMain As New ADODB.Recordset
Dim sqlMain As String
Private Sub cmdOK_Click(Index As Integer)
Dim DateT As String
Dim DateE As String
Dim DateHead As String
Dim flgClass As String
Dim bolResult As Boolean
Call connectionT
If Index = 1 Then Unload Me: Exit Sub
If Not IsDate(dtpDate(0).Value) Then
    MsgBox "日期格式不对！", vbInformation, "提示"
    dtpDate(0).SetFocus
    Exit Sub
End If
If Not IsDate(dtpDate(1).Value) Then
    MsgBox "日期格式不对！", vbInformation, "提示"
    dtpDate(1).SetFocus
    Exit Sub
End If
If DateValue(dtpDate(1).Value) <= DateValue(dtpDate(0).Value) Then
    MsgBox "终止日期应大于开始日期！", vbInformation, "提示"
    dtpDate(1).SetFocus
    Exit Sub
End If
Screen.MousePointer = vbHourglass
DateT = Format(dtpDate(0).Value, "yyyy-mm-dd")
DateE = Format(dtpDate(1).Value, "yyyy-mm-dd")
DateHead = Format(dtpDate(1).Value, "YYYYMM")

If optSel(0).Value = True Then
    flgClass = "zytj"
ElseIf optSel(1).Value = True Then
    flgClass = "mztj"
ElseIf optSel(2).Value = True Then
    flgClass = "zyll"
ElseIf optSel(3).Value = True Then
    flgClass = "zydm"
ElseIf optSel(4).Value = True Then
    flgClass = "mzdm"
ElseIf optSel(5).Value = True Then
    flgClass = "ksdm_zy"
ElseIf optSel(6).Value = True Then
    flgClass = "ypdm"
ElseIf optSel(8).Value = True Then
    flgClass = "mzll"
ElseIf optSel(9).Value = True Then
    flgClass = "ksdm_mz"
ElseIf optSel(10).Value = True Then
    flgClass = "lb_zy"
ElseIf optSel(11).Value = True Then
    flgClass = "lb_mz"
Else
    flgClass = "clkc"
End If

Conn.BeginTrans
    bolResult = TJfunction(flgClass, DateHead, DateT, DateE)
    If bolResult = False Then Screen.MousePointer = vbDefault: Conn.RollbackTrans: Exit Sub
Conn.CommitTrans

Screen.MousePointer = vbDefault
MsgBox "导出成功！", vbInformation, "提示"
cmdOK(0).Enabled = False
cmdOK(1).Enabled = False
End Sub


Private Sub Command1_Click()
Form1.Sdate = Format(dtpDate(0), "yyyy-mm-dd")
Form1.Edate = Format(dtpDate(1), "yyyy-mm-dd")

Form1.Show
End Sub

Private Sub Command2_Click(Index As Integer)
Dim ss As Integer
Select Case Index
    Case 0 '对照住院月报中的收费类别代码
        ss = MsgBox("在更新住院月报中的收费代码前，请务必维护好字典表Kind_zy中的收费类别，继续否？", vbQuestion + vbYesNo, "提示")
        If ss = vbYes Then
            sqlMain = "update st_dept_income_detail_i a,Kind_zy b set a.Charge_kind_code=b.编号 where a.Charge_kind_name=b.income_type"
            ConnAccess.Execute sqlMain
            sqlMain = "update st_dept_income_detail_i set Charge_kind_code=Charge_kind_code"
            ConnAccess.Execute sqlMain
            sqlMain = "update st_dept_income_detail_i a,code_zy b set a.perform_by_name=b.department where a.perform_by_name=b.Category"
            ConnAccess.Execute sqlMain
            sqlMain = "update st_dept_income_detail_i a,code_zy b set a.perform_by=b.code where a.perform_by_name=b.department"
            ConnAccess.Execute sqlMain
            '下面处理本科开单，本科实行,用K标记
            sqlMain = "update st_dept_income_detail_i a,dict_kbb_zy b set a.perform_by_name=b.name where a.perform_by_name='k'"
            ConnAccess.Execute sqlMain
            sqlMain = "update st_dept_income_detail_i a,dict_kbb_zy b set perform_by=ordered_by where perform_by is null"
            ConnAccess.Execute sqlMain
            MsgBox "更新成功！住院月报表中的数据现已经完整了！", vbInformation, "提示"
        End If
    Case 1 '对照门诊月报中的收费类别代码
        ss = MsgBox("在更新门诊月报中的收费代码前，请务必维护好字典表Kind_mz中的收费类别，继续否？", vbQuestion + vbYesNo, "提示")
        If ss = vbYes Then
            'sqlMain = "update st_dept_income_detail_o a,Kind_mz b set a.charge_detail_code=b.编号 where a.charge_detail_name=b.income_type"
            sqlMain = "update st_dept_income_detail_o a,Kind_mz b set a.Charge_kind_code=b.编号 where a.Charge_kind_name=b.income_type"
            ConnAccess.Execute sqlMain
            sqlMain = "update st_dept_income_detail_o set Charge_kind_code=Charge_kind_code"
            ConnAccess.Execute sqlMain
            sqlMain = "update st_dept_income_detail_o a,code_mz b set a.perform_by_name=b.department where a.perform_by_name=b.Category"
            ConnAccess.Execute sqlMain
            sqlMain = "update st_dept_income_detail_o a,code_mz b set a.perform_by=b.code where a.perform_by_name=b.department"
            ConnAccess.Execute sqlMain
            '下面处理本科开单，本科实行
            sqlMain = "update st_dept_income_detail_o  set perform_by_name=ordered_by_name,perform_by=ordered_by where perform_by_name='k'"
            ConnAccess.Execute sqlMain
            sqlMain = "update st_dept_income_detail_o  set perform_by=ordered_by where perform_by is null"
            ConnAccess.Execute sqlMain
            MsgBox "更新成功！门诊月报表中的数据现已经完整了！", vbInformation, "提示"
        End If
End Select
End Sub

Private Sub dtpDate_Click(Index As Integer)
cmdOK(0).Enabled = True
cmdOK(1).Enabled = True
End Sub

Private Sub Form_Load()
Dim A As String
Dim B As String
Dim C As String
Dim D As String
Dim sD As String
Dim eD As String

Call connectionT

A = Format(Year(Date)): D = A
B = Format(Month(Date) - 1, "00")
If B = "00" Then
    A = A - 1
    B = "12"
End If
C = Format(Month(Date), "00")
dtpDate(0).Value = Format(A & "-" & B & "-16", "yyyy年mm月dd日")
dtpDate(1).Value = Format(D & "-" & C & "-15", "yyyy年mm月dd日")
sD = Format(dtpDate(0).Value, "yyyy-mm-dd")
eD = Format(dtpDate(1).Value, "yyyy-mm-dd")
optSel(0).Value = True
End Sub

Private Sub Form_Resize()
dtpDate(0).SetFocus
End Sub


Private Function TJfunction(flagClass As String, DateHeadTmp As String, DateTtmp As String, DateEtmp As String) As Boolean
Dim rsT As New ADODB.Recordset
Dim sqlT As String: Dim numT As Double

On Error GoTo ErrA:
Dim ClassName As String
Select Case flagClass
    Case "zytj" '住院医疗收入统计月报
        'sqlMain = "exec stp_zyc_cfk_yb_my '" & DateHeadTmp & "','" & Format(DateTtmp, "yyyymmdd") & "','" & Format(DateEtmp, "yyyymmdd") & "'"
        ' sqlMain = "exec stp_zyc_cfk_yb_my_new '" & DateHeadTmp & "','" & Format(DateTtmp, "yyyy-mm-dd") & "','" & Format(DateEtmp, "yyyy-mm-dd") & "'"
          'Conn.Execute "delete from tmp_zyc_cfk_cy_tmppp"
          sqlMain = "exec droptmptable_tmp_zy"
          Conn.Execute sqlMain
          sqlMain = "select a.编码,a.名称,a.单价*a.数量 AS 金额,a.数量 as 例数,b.核算科别,b.统计类别,处方类别,a.处方号 as 记账代码,b.处方号 as 核算代码, b.日结日期 as 日期 into tmp_zyc_cfk_cy_tmppp from zyc_cfk_cy_xm a,zyc_cfk_cy b" _
& " where a.处方号=b.处方号 and 收款标记=1  and b.日结日期>='" & DateTtmp & "' and b.日结日期<='" & DateEtmp & "' and b.结算单序号 in (select 结算单号 from zyc_jsd where 是否婴儿=0 ) "



        Conn.Execute sqlMain
        sqlMain = "update tmp_zyc_cfk_cy_tmppp set 日期='" & DateEtmp & "'"
        Conn.Execute sqlMain
        With rsMain
            If .State = adStateOpen Then .Close
            .CursorLocation = adUseClient
           ' .Open "select 日期,记账科别,核算科别,统计类别,sum(金额) as 金额 from tmp_zyc_cfk_tj group by 日期,记账科别,核算科别,统计类别 order by 记账科别", Conn, adOpenStatic, adLockOptimistic, adCmdText
           .Open "select 日期,核算科别,统计类别,处方类别, sum(金额) as 金额,编码,名称,sum(例数) as 例数 from tmp_zyc_cfk_cy_tmppp group by 编码,名称,核算科别,处方类别,统计类别,日期 order by 核算科别", Conn, adOpenStatic, adLockOptimistic, adCmdText
            If .EOF And .BOF Then
                MsgBox "无数据统计！", vbInformation, "提示"
                dtpDate(0).SetFocus
                rsMain.Close
                Set rsMain = Nothing
                TJfunction = False
                Exit Function
            Else
                ConnAccess.Execute "delete from st_dept_income_detail_i"
                .MoveLast
                .MoveFirst
                pb.Visible = True
                pb.Min = 1
                pb.Max = .RecordCount
                Do While Not .EOF
                    ClassName = ""

                    sqlMain = "insert into st_dept_income_detail_i(year_month,charge_detail_code,charge_detail_name,Charge_kind_code,Charge_kind_name,ordered_by_name,perform_by_name,amount,workload)values('" & Trim(Format(.Fields("日期"), "yyyymm") & "") & "','" & Trim(.Fields("编码")) & "','" & Trim(.Fields("名称")) & "','','" & Trim(.Fields("处方类别") & "") & "','" & Trim(.Fields("核算科别") & "") & "','" & Trim(.Fields("统计类别") & "") & "'," & CCur(Val(.Fields("金额") & "")) & "," & Trim(.Fields("例数")) & ")"
                    ConnAccess.Execute sqlMain
                    pb.Value = .AbsolutePosition
                    .MoveNext
                Loop

                ProcessMDB 0

                sqlMain = "update st_dept_income_detail_i a,dict_kbb_zy b set a.ordered_by=b.code  where a.ordered_by_name=b.name"
                ConnAccess.Execute sqlMain
                sqlMain = "update st_dept_income_detail_i a,dict_kbb_zy b set a.perform_by=b.code  where a.perform_by_name=b.name"
                ConnAccess.Execute sqlMain
            End If
        End With
        rsMain.Close
        Set rsMain = Nothing
        pb.Visible = False
    Case "mztj"
        DateTtmp = DateTtmp & " 00:00:01"
        DateEtmp = DateEtmp & " 23:59:59"
        sqlMain = "exec droptmptable_mz"
        Conn.Execute sqlMain
        sqlMain = "select a.编码,a.名称,a.单价*a.数量*a.剂数 AS 金额,a.数量*a.剂数 as 例数,b.统计类别,b.核算科别,处方类别,a.处方号 as 记账代码,b.处方号 as 核算代码, b.日结日期 as 日期 into tmp_mz_gq_tmppp from mz_cfk_gq_xm a,mz_cfk_gq b where 收款标记=1 and a.处方号=b.处方号  and a.日结日期>='" & DateTtmp & "' and a.日结日期<='" & DateEtmp & "' "
        Conn.Execute sqlMain
        sqlMain = "update tmp_mz_gq_tmppp set 日期='" & DateEtmp & "'"
        Conn.Execute sqlMain
        With rsMain
            If .State = adStateOpen Then .Close
            .CursorLocation = adUseClient
           .Open "select 日期,处方类别,核算科别,统计类别,sum(金额) as 金额,编码,名称,sum(例数) as 例数 from tmp_mz_gq_tmppp  group by 编码,名称,统计类别,处方类别,核算科别,日期  order by 核算科别", Conn, adOpenStatic, adLockOptimistic, adCmdText
            If .EOF And .BOF Then
                MsgBox "无数据可统计！", vbInformation, "提示"
                dtpDate(0).SetFocus
                TJfunction = False
                Exit Function
            Else
                ConnAccess.Execute "delete from st_dept_income_detail_o"
                .MoveLast
                .MoveFirst
                pb.Visible = True
                pb.Min = 1
                pb.Max = .RecordCount
                Do While Not .EOF
                    ClassName = ""
                    sqlMain = "insert into st_dept_income_detail_o(year_month,charge_detail_code,charge_detail_name,Charge_kind_code,Charge_kind_name,ordered_by_name,perform_by_name,amount,workload) values('" & Trim(Format(.Fields("日期"), "yyyymm") & "") & "','" & Trim(.Fields("编码")) & "','" & Trim(.Fields("名称")) & "','','" & Trim(.Fields("处方类别") & "") & "','" & Trim(.Fields("核算科别") & "") & "','" & Trim(.Fields("统计类别") & "") & "'," & CCur(Val(.Fields("金额") & "")) & "," & Trim(.Fields("例数")) & ")"
                    ConnAccess.Execute sqlMain
                    pb.Value = .AbsolutePosition
                    .MoveNext
                Loop
                ProcessMDB 1
                sqlMain = "update st_dept_income_detail_o a,dict_kbb_mz b set a.ordered_by=b.code  where a.ordered_by_name=b.name"
                ConnAccess.Execute sqlMain
                sqlMain = "update st_dept_income_detail_o a,dict_kbb_mz b set a.perform_by=b.code  where a.perform_by_name=b.name"
                ConnAccess.Execute sqlMain
            End If
        End With
        pb.Visible = False
    Case "zyll" '住院流量
        sqlMain = "exec stp_zyc_hz_ll '" & DateHeadTmp & "','" & DateTtmp & "','" & DateEtmp & "'"
        Conn.Execute sqlMain
        sqlMain = "select * from tmp_zyc_hz_tj"
        If rsMain.State = adStateOpen Then rsMain.Close
        rsMain.CursorLocation = adUseClient
        rsMain.Open sqlMain, Conn, adOpenStatic, adLockOptimistic, adCmdText
        If rsMain.EOF And rsMain.BOF Then
            MsgBox "无数据统计！", vbInformation, "提示"
            dtpDate(0).SetFocus
            TJfunction = False
            Exit Function
        End If
        
        On Error Resume Next
        Conn.Execute "Drop Table tmpHZLL"
        Conn.Execute "Drop Table tmpHZLL1"
        On Error GoTo 0
        sqlMain = "select 日期,科别名称,收费类别,sum(住院天数) as 天数 into tmpHZLL from tmp_zyc_hz_tj group by 日期,科别名称,收费类别 order by 科别名称,收费类别"
        Conn.Execute sqlMain
        sqlMain = "select 日期,编码 as kbbm,收费类别,b.科别名称 as kbmc,天数 into tmpHZLL1 from dict_kbb a Right Join tmpHZLL b ON a.科别名称=b.科别名称"
        Conn.Execute sqlMain
        sqlMain = "select 日期,kbbm,编码 as sflb,kbmc,b.收费类别 as sflbmc,天数 from zyc_dict_sflb a Right Join tmpHZLL1 b ON a.收费类别=b.收费类别"
        With rsMain
            If .State = adStateOpen Then .Close
            .CursorLocation = adUseClient
            .Open sqlMain, Conn, adOpenStatic, adLockOptimistic, adCmdText
                
                ConnAccess.Execute "delete from st_efficiency_dept"
                .MoveLast
                .MoveFirst
                pb.Visible = True
                pb.Min = 1
                pb.Max = .RecordCount
                Do While Not .EOF
                    sqlMain = "insert into st_efficiency_dept(year_month,dept_code,dept_name,charge_type_code,charge_type_name,total_bed_used_days)values('" & Trim(.Fields("日期") & "") & "','" & Trim(.Fields("kbbm") & "") & "','" & Trim(.Fields("kbmc") & "") & "','" & Trim(.Fields("sflb") & "") & "','" & Trim(.Fields("sflbmc") & "") & "'," & Val(.Fields("天数") & "") & ")"
                    ConnAccess.Execute sqlMain