global.bas

医务收费系统,主要的功能不用我说大家都知道的

Attribute VB_Name = "Global"

Public second As Boolean            '是否为第二次调用该窗体
Public who As String                '判断输入号码到底是何人员类别
Public database_data As String
Public YY1 As String
Public MM1 As String
Public nodename As String
Public czry_flag As String
Public Startmonth As Integer
Public Endmonth As Integer
Public iscx As Boolean
Public isadd As Boolean
Public isxg As Boolean              '判段该密码是否用来修改还是新添
Public cn As ADODB.Connection       '总的数据源
Public rsrmkbh As ADODB.Recordset
Public rsrmkpcl As ADODB.Recordset
Public rspsw As ADODB.Recordset
Public rsdoctor As ADODB.Recordset
Public rsYF As ADODB.Recordset
Public cntemp As ADODB.Connection    '用在学生信息数据导入
Public rsrate As ADODB.Recordset
Public rsleibie As ADODB.Recordset   '连接到leibie的记录集
Public rsfeiyong As ADODB.Recordset  '连接到feiyong的记录集
Public rsload As ADODB.Recordset
Public rsrmk As ADODB.Recordset      '连接rmk的记录集

Public Sub condatabase()           '创建连接到feiyong数据库的记录源                                     '连接本地数据库(local)
    Set cn = New ADODB.Connection
        cn.Provider = "sqloledb"
        cn.Properties("Data Source").Value = "(local)"       '建立与本地数据库的连接
        cn.Properties("Initial Catalog").Value = "YAOFEI"   '数据库的名称
        cn.Properties("Integrated Security").Value = "SSPI"
        cn.open
End Sub

Public Sub check_condatabase()
If cn.State = 1 Then
Else
   Call condatabase
End If
End Sub

Public Sub close_condatabase()   '关闭数据源
If cn.State = 1 Then
   cn.close
End If
End Sub
'***************************************************************
'作为检查操作员使用权限的函数，该函数通过截取load表中的ql_flag字段来
'判断该操作员所具有的权限和使用范围
'ql_flag字段的设置
'第一位：编辑查询人员              '第二位：批处理人员信息
'第三位：学生数据导入              '第四位：医生信息维护
'第五位：医疗费用调整              '第六位：药费输入
'第七位：打印日明细表              '第八位：打印日报表
'第九位：打印月报表                '第十位：打印年报表
'第十一位：查询帐单                '第十二位：查询报表
'第十三位：数据备份                '第十四位：数据恢复
'第十五位：操作员维护              '第十六位：系统工具
'第十七位：导出每月数据
Public Function check_qx(qx_flag As String, i As Integer) As Boolean
Dim temp As Integer
If qx_flag <> "" Then
    temp = Mid(qx_flag, i, 1)
    If temp = 0 Then
       MsgBox "您无权限使用该功能！", vbOKOnly + vbExclamation, "注意了:)"
       check_qx = False
    Else
       check_qx = True
    End If
Else
    MsgBox "未经管理员授权，您无权限使用所有功能！", vbOKOnly + vbExclamation, "注意了:)"
    check_qx = False
End If
End Function


Public Function Mtable_name() As String 'earn the month table's name of nowtime
Dim mon As String
mon = Month(Date)
If mon < 10 Then               'if the month less than 10
   Mtable_name = "YF0" & mon
Else
   Mtable_name = "YF" & mon   ' if the month more than 10
End If
End Function

'两个记录集之间的数据拷贝

Public Function RescordSet_Copy(rs_source As ADODB.Recordset, rs_destinate As ADODB.Recordset)
On Error Resume Next
'检查源记录表中是否有数据,如果没有,跳出该函数
If rs_source.EOF <> True Then
    If rs_destinate.EOF <> True And rs_destinate.BOF <> True Then  '如果目的表的记录不为空
            Do Until rs_destinate.EOF
               rs_destinate.Delete
               rs_destinate.MoveNext
            Loop
            Dim id As String
            id = rs_destinate.Fields(0)  '记录编号的变化
            Do Until rs_source.EOF
               rs_destinate.AddNew
               For i = 1 To 7
                   rs_destinate.Fields(i).Value = rs_source.Fields(i).Value
               Next
               id = id + 1
               rs_destinate.Fields(0).Value = id
               rs_destinate.Update
               rs_destinate.MoveNext
               rs_source.MoveNext
            Loop
    
    Else              '**************如果目的表的记录为空
            Do Until rs_source.EOF
           rs_destinate.AddNew
           For i = 0 To 7
               rs_destinate.Fields(i).Value = rs_source.Fields(i).Value
           Next
           rs_destinate.Update
           rs_destinate.MoveNext
           rs_source.MoveNext
        Loop

    End If
End If
End Function

Public Sub crystal_init()    '对水晶报表进行初始化

Call check_condatabase
Dim rs_rpt As ADODB.Recordset
Dim rs_feiyong As ADODB.Recordset
Set rs_rpt = New ADODB.Recordset
Set rs_feiyong = New ADODB.Recordset

rs_rpt.open "select * from feiyong_rpt", cn, adOpenStatic, adLockPessimistic
rs_feiyong.open "select * from feiyong", cn, adOpenStatic, adLockPessimistic

If rs_rpt.BOF <> True Then
  If rs_feiyong.BOF <> True Then rs_feiyong.MoveFirst
    Do Until rs_feiyong.EOF
       If rs_rpt.EOF <> True Then
          For i = 0 To 7
              rs_rpt.Fields(i).Value = rs_feiyong.Fields(i).Value
          Next
       Else
          rs_rpt.AddNew
          For i = 0 To 7
              rs_rpt.Fields(i).Value = rs_feiyong.Fields(i).Value
          Next
       End If
       rs_rpt.Update
       rs_rpt.MoveNext
       rs_feiyong.MoveNext
    Loop
Else
    If rs_rpt.BOF <> True Then rs_rpt.MoveLast
   
    If rs_feiyong.BOF <> True Then rs_feiyong.MoveFirst
    Do Until rs_feiyong.EOF
       rs_rpt.AddNew
       For i = 0 To 7
           rs_rpt.Fields(i).Value = rs_feiyong.Fields(i).Value
       Next
       rs_rpt.Update
       rs_rpt.MoveNext
       rs_feiyong.MoveNext
    Loop
    Exit Sub
End If

If rs_rpt.EOF <> True Then
   Do Until rs_rpt.EOF
      rs_rpt.Delete
      rs_rpt.MoveNext
   Loop
End If

End Sub

Public Sub import_server() 'put the daily data into the month's table
Call check_condatabase     'use the function to check the connect
Dim rs_month As ADODB.Recordset
Dim rs_feiyong_bak As ADODB.Recordset
Set rs_month = New ADODB.Recordset
Set rs_feiyong_bak = New ADODB.Recordset
    rs_month.open "select * from " & Mtable_name & "", cn, adOpenStatic, adLockPessimistic
    rs_feiyong_bak.open "select * from feiyong", cn, adOpenStatic, adLockPessimistic
'copy the source's rescordset to the destination's rescordset
Call RescordSet_Copy_Month(rs_feiyong_bak, rs_month)
End Sub

'打印日报表
Public Sub printrbb()
'**********按医生人数进行医药费的汇总***************
Call check_condatabase
Dim rsdatareport As ADODB.Recordset
Set rsdatareport = New ADODB.Recordset
    rsdatareport.open "SELECT doctor.id,doctor.DOCTOR_NAME AS 医生, COUNT(feiyong.医生) AS 处方量," & _
                      "SUM(feiyong.医药费) AS 医药费, " & _
                      "SUM(feiyong.自负金) As 自负金 " & _
                      "From doctor, feiyong " & _
                      "Where doctor.Id = feiyong.医生 " & _
                      "GROUP BY doctor.DOCTOR_NAME,doctor.id ", cn, adOpenStatic, adLockPessimistic


'****************************************************************
'以上为从FEIYONG表中获取统计和获取数据
If rsdatareport.BOF <> True And rsdatareport.EOF <> True Then
    '复制数据到DATAREPORT表中
    Set rstemp = New ADODB.Recordset
        rstemp.open "select * from datareport", cn, adOpenStatic, adLockPessimistic
    If rstemp.BOF <> True And rstemp.EOF <> True Then
       Do Until rstemp.EOF
          rstemp.Delete
          rstemp.MoveNext
       Loop
    End If
    If rstemp.State = 1 Then rstemp.close
    rstemp.open "select * from datareport", cn, adOpenStatic, adLockPessimistic

    '设置中间记录，当复制时删除原来的记录，再打开该表
    Do Until rsdatareport.EOF
       rstemp.AddNew
       For i = 0 To 4
           If i = 4 Then
              rstemp.Fields(i + 1).Value = rsdatareport.Fields(i).Value
              rstemp.Fields(i).Value = rsdatareport.Fields(3) / rsdatareport.Fields(2)
           Else
               rstemp.Fields(i).Value = rsdatareport.Fields(i).Value
           End If
       Next i
       rstemp.Update
       rsdatareport.MoveNext
    Loop
    '使数据能够按照医生的实际人数进行汇总（有可能某医生当天未参加门诊）
    Set rsdoctor = New ADODB.Recordset
    If rsdoctor.State = 0 Then rsdoctor.open "select * from doctor", cn, adOpenStatic, adLockPessimistic
    '如果的确有医生未参加该天的门诊，则进行数据的人工辅助汇总
    If rsdatareport.recordcount <> rsdoctor.recordcount Then
       rstemp.close
       rstemp.open "select * from datareport", cn, adOpenStatic, adLockPessimistic
       Do Until rsdoctor.EOF
           If rstemp.EOF Then
              Do Until rsdoctor.EOF
                 rstemp.AddNew
                 rstemp.Fields(0).Value = rsdoctor.Fields("id").Value
                 rstemp.Fields(1).Value = rsdoctor.Fields("doctor_name").Value
                 For i = 2 To 5
                     rstemp.Fields(i).Value = 0
                 Next i
                 rstemp.Update
                 rsdoctor.MoveNext
              Loop
           Else
              If rsdoctor.Fields("id").Value <> rstemp.Fields("id").Value Then
                 rstemp.AddNew
                 rstemp.Fields(0).Value = rsdoctor.Fields("id").Value
                 rstemp.Fields(1).Value = rsdoctor.Fields("doctor_name").Value
                 For i = 2 To 5
                     rstemp.Fields(i).Value = 0
                 Next i
                 With rstemp
                      .Update
                      .close
                      .open "select * from datareport", cn, adOpenStatic, adLockPessimistic
                 End With
                 rsdoctor.MoveFirst
              Else
                 rstemp.MoveNext