frmmian.frm

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

                    pb.Value = .AbsolutePosition
                    .MoveNext
                Loop
        End With
        pb.Visible = False
        On Error Resume Next
        Conn.Execute "Drop Table tmpHZLL"
        Conn.Execute "Drop Table tmpHZLL1"
        On Error GoTo 0
        
    Case "zydm" '住院项目
        sqlMain = "select distinct 编码,名称,统计类别 as 类别 from zyc_jczlb order by 名称"
        If rsMain.State = adStateOpen Then rsMain.Close
        rsMain.CursorLocation = adUseClient
        rsMain.Open sqlMain, Conn, adOpenStatic, adLockOptimistic, adCmdText
        If rsMain.EOF And rsMain.BOF Then
        Else
            ConnAccess.Execute "delete from dict_charge_detail_zy"
            rsMain.MoveLast
            rsMain.MoveFirst
            pb.Visible = True
            pb.Min = 1
            pb.Max = rsMain.RecordCount
            Do While Not rsMain.EOF
                If rsMain![名称] & "" = "" Then
                Else
                    sqlMain = "insert into dict_charge_detail_zy(charge_detail_code,charge_kind_name,charge_detail_name)values('" & rsMain![编码] & "" & "','" & rsMain![类别] & "" & "','" & Replace(rsMain![名称] & "", "'", "''") & "')"
                    ConnAccess.Execute sqlMain
                End If
                pb.Value = rsMain.AbsolutePosition
                rsMain.MoveNext
            Loop
        End If
        pb.Visible = False
    Case "mzdm" '门诊项目
        sqlMain = "select distinct 编码,名称,统计类别 as 类别 from mz_jczlb order by 名称"
        If rsMain.State = adStateOpen Then rsMain.Close
        rsMain.CursorLocation = adUseClient
        rsMain.Open sqlMain, Conn, adOpenStatic, adLockOptimistic, adCmdText
        If rsMain.EOF And rsMain.BOF Then
        Else
            ConnAccess.Execute "delete from dict_charge_detail_mz"
            rsMain.MoveLast
            rsMain.MoveFirst
            pb.Visible = True
            pb.Min = 1
            pb.Max = rsMain.RecordCount
            Do While Not rsMain.EOF
                If rsMain![名称] & "" = "" Then
                Else
                    sqlMain = "insert into dict_charge_detail_mz(charge_detail_code,charge_kind_name,charge_detail_name)values('" & rsMain![编码] & "" & "','" & rsMain![类别] & "" & "','" & Replace(rsMain![名称] & "", "'", "''") & "')"
                    ConnAccess.Execute sqlMain
                End If
                pb.Value = rsMain.AbsolutePosition
                rsMain.MoveNext
            Loop
        End If
        pb.Visible = False
    Case "ksdm_zy" '科室表_住院
        'sqlMain = "select distinct 编码,科别名称 as 名称 from dict_kbb_zy order by 名称"   我注释060809
        sqlMain = "select distinct 编码,科别名称 as 名称 from dict_kbb order by 名称"
        If rsMain.State = adStateOpen Then rsMain.Close
        rsMain.CursorLocation = adUseClient
        rsMain.Open sqlMain, Conn, adOpenStatic, adLockOptimistic, adCmdText
        If rsMain.EOF And rsMain.BOF Then
        Else
            ConnAccess.Execute "delete from dict_kbb_zy"
           
            rsMain.MoveLast
            rsMain.MoveFirst
            pb.Visible = True
            pb.Min = 1
            pb.Max = rsMain.RecordCount
            Do While Not rsMain.EOF
                If rsMain![名称] & "" = "" Then
                Else
                    sqlMain = "insert into dict_kbb_zy(code,name)values('" & Trim(rsMain![编码] & "") & "','" & Trim(rsMain![名称] & "") & "')"
                    ConnAccess.Execute sqlMain
                End If
                pb.Value = rsMain.AbsolutePosition
                rsMain.MoveNext
            Loop
        End If
        pb.Visible = False
    Case "ksdm_mz" '科室表_门诊
        sqlMain = "select distinct 编码,科别名称 as 名称 from dict_kbb order by 名称"
        If rsMain.State = adStateOpen Then rsMain.Close
        rsMain.CursorLocation = adUseClient
        rsMain.Open sqlMain, Conn, adOpenStatic, adLockOptimistic, adCmdText
        If rsMain.EOF And rsMain.BOF Then
        Else
            ConnAccess.Execute "delete from dict_kbb_mz"
            rsMain.MoveLast
            rsMain.MoveFirst
            pb.Visible = True
            pb.Min = 1
            pb.Max = rsMain.RecordCount
            Do While Not rsMain.EOF
                If rsMain![名称] & "" = "" Then
                Else
                    sqlMain = "insert into dict_kbb_mz(code,name)values('" & rsMain![编码] & "" & "','" & rsMain![名称] & "" & "')"
                    ConnAccess.Execute sqlMain
                End If
                pb.Value = rsMain.AbsolutePosition
                rsMain.MoveNext
            Loop
        End If
        pb.Visible = False
        
    Case "ypdm" '药品字典
        On Error Resume Next
        Conn.Execute "Drop Table tmpYFKCB_tj"
        On Error GoTo 0
        sqlMain = "select distinct 编码,名称,类别 into tmpYFKCB_tj from yk_yfkcb  order by 名称"
        Conn.Execute sqlMain
        sqlMain = "select 编码,序号,名称,类别 from dict_lbmc a Left Join tmpYFKCB_tj b ON a.类别名称=b.类别"
        If rsMain.State = adStateOpen Then rsMain.Close
        rsMain.CursorLocation = adUseClient
        rsMain.Open sqlMain, Conn, adOpenStatic, adLockOptimistic, adCmdText
        If rsMain.EOF And rsMain.BOF Then
        Else
            ConnAccess.Execute "delete from dict_charge_detail_yp"
            rsMain.MoveLast
            rsMain.MoveFirst
            pb.Visible = True
            pb.Min = 1
            pb.Max = rsMain.RecordCount
            Do While Not rsMain.EOF
                If rsMain![名称] & "" = "" Then
                Else
                    sqlMain = "insert into dict_charge_detail_yp(charge_detail_code,charge_kind_code,charge_detail_name,charge_kind_name)values('" & rsMain![编码] & "" & "','" & rsMain![序号] & "" & "','" & Replace(rsMain![名称] & "", "'", "''") & "','" & rsMain![类别] & "" & "')"
                    ConnAccess.Execute sqlMain
                End If
                pb.Value = rsMain.AbsolutePosition
                rsMain.MoveNext
            Loop
        End If
        pb.Visible = False
        On Error Resume Next
        Conn.Execute "Drop Table tmpYFKCB_tj"
        On Error GoTo 0
    Case "clkc"
        sqlMain = "select distinct 编码,名称,规格,单位,单价,类别,助记码 from zyc_clkcb where 编码 is not null order by 名称 "
        If rsMain.State = adStateOpen Then rsMain.Close
        rsMain.CursorLocation = adUseClient
        rsMain.Open sqlMain, Conn, adOpenStatic, adLockOptimistic, adCmdText
        If rsMain.EOF And rsMain.BOF Then
        Else
            ConnAccess.Execute "delete from dict_clb"
            rsMain.MoveLast
            rsMain.MoveFirst
            pb.Visible = True
            pb.Min = 1
            pb.Max = rsMain.RecordCount
            Do While Not rsMain.EOF
                If rsMain![名称] & "" = "" Then
                Else
                    sqlMain = "insert into dict_clb(code,name,spec,unit,price,simplecode,type)values('" & rsMain![编码] & "" & "','" & rsMain![名称] & "" & "','" & Replace(rsMain![规格] & "", "'", "''") & "','" & Replace(rsMain![单位] & "", "'", "''") & "'," & rsMain![单价] & "" & ",'" & rsMain![助记码] & "" & "','" & Replace(rsMain![类别] & "", "'", "''") & "')"
                    ConnAccess.Execute sqlMain
                End If
                pb.Value = rsMain.AbsolutePosition
                rsMain.MoveNext
            Loop
        End If
        pb.Visible = False
    Case "mzll"
        On Error Resume Next
        Conn.Execute "Drop table tmpMZLL"
        Conn.Execute "Drop Table tmpMZLL1"
        On Error GoTo 0
        
        sqlMain = "select 人员类别,就诊科别,sum(convert(int,退号标志)) num into tmpMZLL from gh_gq where 日结日期>='" & DateTtmp & "' and 日结日期<='" & DateEtmp & "' group by 人员类别,就诊科别"
        Conn.Execute sqlMain
        sqlMain = "select 就诊科别,num into tmpmzll1 from tmpmzll"
        Conn.Execute sqlMain
        sqlMain = "select 编码 as kbbm,a.科别名称 as kbmc,num from dict_kbb a Left Join tmpMZLL1 b ON a.科别名称=b.就诊科别 and num>0"
        If rsMain.State = adStateOpen Then rsMain.Close
        rsMain.CursorLocation = adUseClient
        rsMain.Open sqlMain, Conn, adOpenStatic, adLockOptimistic, adCmdText
        If rsMain.EOF And rsMain.BOF Then
        Else
            ConnAccess.Execute "delete from st_outp_clinic"
            rsMain.MoveLast
            rsMain.MoveFirst
            pb.Visible = True
            pb.Min = 1
            pb.Max = rsMain.RecordCount
            Do While Not rsMain.EOF
                If rsMain![kbbm] & "" = "" Then
                Else
                     sqlMain = "insert into st_outp_clinic(year_month,dept_code,dept_name,outp_num)values('" & DateHeadTmp & "','" & rsMain![kbbm] & "" & "','" & rsMain![kbmc] & "" & "'," & Val(rsMain![num] & "") & ")"
                    ConnAccess.Execute sqlMain
                End If
                pb.Value = rsMain.AbsolutePosition
                rsMain.MoveNext
            Loop
        End If
        pb.Visible = False
        On Error Resume Next
        Conn.Execute "Drop table tmpMZLL"
        Conn.Execute "Drop Table tmpMZLL1"
        On Error GoTo 0
    Case "lb_zy"
        With rsT
            If .State = adStateOpen Then .Close
            .CursorLocation = adUseClient
         '   sqlT = "select distinct charge_detail_name as 类别 from st_dept_income_detail_i"
             sqlT = "select distinct  Charge_kind_name  as 类别 from st_dept_income_detail_i"
            .Open sqlT, ConnAccess, adOpenStatic, adLockOptimistic, adCmdText
            If .EOF And .BOF Then
            Else
                .MoveLast
                .MoveFirst
                pb.Visible = True
                pb.Min = 1
                pb.Max = .RecordCount
                Do While Not .EOF
                    sqlT = "insert into Kind_zy(income_type)values('" & Trim(![类别] & "") & "')"
                    ConnAccess.Execute sqlT
                    pb.Value = .AbsolutePosition
                    .MoveNext
                Loop
            End If
        End With
        pb.Visible = False
    Case "lb_mz"
        With rsT
            If .State = adStateOpen Then .Close
            .CursorLocation = adUseClient
           ' sqlT = "select distinct charge_detail_name as 类别 from st_dept_income_detail_o"
             sqlT = "SELECT distinct Charge_kind_name as 类别 from st_dept_income_detail_o"
            .Open sqlT, ConnAccess, adOpenStatic, adLockOptimistic, adCmdText
            If .EOF And .BOF Then
            Else
                .MoveLast
                .MoveFirst
                pb.Visible = True
                pb.Min = 1
                pb.Max = .RecordCount
                Do While Not .EOF
                    sqlT = "insert into Kind_mz(income_type)values('" & Trim(![类别] & "") & "')"
                    ConnAccess.Execute sqlT
                    pb.Value = .AbsolutePosition
                    .MoveNext
                Loop
            End If
        End With
        pb.Visible = False
        
 End Select
TJfunction = True
Exit Function
ErrA:
TJfunction = False
MsgBox Err.Description
End Function

Private Sub optSel_Click(Index As Integer)
cmdOK(0).Enabled = True
cmdOK(1).Enabled = True
Select Case Index
    Case 3, 4, 5, 6, 7, 9, 10, 11
        Label1(0).Enabled = False
        Label1(1).Enabled = False
        dtpDate(0).Enabled = False
        dtpDate(1).Enabled = False
    Case Else
        Label1(0).Enabled = True
        Label1(1).Enabled = True
        dtpDate(0).Enabled = True
        dtpDate(1).Enabled = True
End Select
End Sub

Private Sub connectionT()
If Conn.State = adStateOpen Then Conn.Close
Conn.CommandTimeout = 9999
Conn.ConnectionString = "dsn=hos;uid=sa;pwd=sunway;"
Conn.Open
If ConnAccess.State = adStateOpen Then ConnAccess.Close
ConnAccess.ConnectionString = "dsn=HisData;uid=admin;pwd=;"
ConnAccess.Open

End Sub

Private Sub ProcessMDB(flgSys As String)
Dim sqlTmp As String

Select Case flgSys
    Case 0 '住院
        sqlTmp = "update st_dept_income_detail_i a,dict_CollateKbb_zy b set a.perform_by_name=b.CollateName  where a.perform_by_name=b.name"
        ConnAccess.Execute sqlTmp
        sqlTmp = "update st_dept_income_detail_i set perform_by_name=ordered_by_name where perform_by_name='开单'"
        ConnAccess.Execute sqlTmp
        sqlTmp = "update st_dept_income_detail_i set ordered_by_name='保健科门诊' where perform_by_name='保健科门诊'"
        ConnAccess.Execute sqlTmp
    Case 1 '门诊
        sqlTmp = "update st_dept_income_detail_o a,dict_CollateKbb_mz b set a.perform_by_name=b.CollateName  where a.perform_by_name=b.name"
        ConnAccess.Execute sqlTmp
        sqlTmp = "update st_dept_income_detail_o set perform_by_name=ordered_by_name where perform_by_name='开单'"
        ConnAccess.Execute sqlTmp
        sqlTmp = "update st_dept_income_detail_o set ordered_by_name='保健科门诊' where perform_by_name='保健科门诊'"
        ConnAccess.Execute sqlTmp
End Select
End Sub