frmfirstacc.frm

医院门诊医生工作站,vb6 SqlServer

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{B02F3647-766B-11CE-AF28-C3A2FBE76A13}#2.5#0"; "SS32X25.OCX"
Begin VB.Form frmFirstAcc 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "药品维护"
   ClientHeight    =   5505
   ClientLeft      =   375
   ClientTop       =   1080
   ClientWidth     =   9000
   DrawMode        =   1  'Blackness
   DrawWidth       =   4
   Icon            =   "frmFirstAcc.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   Moveable        =   0   'False
   ScaleHeight     =   5505
   ScaleWidth      =   9000
   Begin FPSpread.vaSpread spd 
      Height          =   4785
      Left            =   2850
      OleObjectBlob   =   "frmFirstAcc.frx":0442
      TabIndex        =   1
      Top             =   120
      Width           =   6135
   End
   Begin VB.CommandButton Command1 
      Caption         =   "&A.建帐"
      Height          =   435
      Left            =   6180
      TabIndex        =   5
      Top             =   5010
      Width           =   1155
   End
   Begin VB.TextBox txtselect 
      Height          =   285
      Left            =   3750
      TabIndex        =   3
      Top             =   5040
      Width           =   1725
   End
   Begin VB.CommandButton cmdExit 
      Caption         =   "&E.关闭"
      Height          =   435
      Left            =   7770
      TabIndex        =   2
      Top             =   5010
      Width           =   1155
   End
   Begin MSComctlLib.TreeView tvw 
      Height          =   5310
      Left            =   0
      TabIndex        =   0
      Top             =   105
      Width           =   2835
      _ExtentX        =   5001
      _ExtentY        =   9366
      _Version        =   393217
      HideSelection   =   0   'False
      Indentation     =   706
      LabelEdit       =   1
      Style           =   7
      ImageList       =   "img"
      Appearance      =   1
   End
   Begin MSComctlLib.ImageList img 
      Left            =   0
      Top             =   0
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   4
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmFirstAcc.frx":0AE0
            Key             =   ""
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmFirstAcc.frx":0F34
            Key             =   ""
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmFirstAcc.frx":1388
            Key             =   ""
         EndProperty
         BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmFirstAcc.frx":17DC
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin VB.Label label1 
      Caption         =   "选择药品"
      Height          =   285
      Left            =   2970
      TabIndex        =   4
      Top             =   5100
      Width           =   1245
   End
End
Attribute VB_Name = "frmFirstAcc"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private WithEvents CmnHlp As frmInputHelp
Attribute CmnHlp.VB_VarHelpID = -1

Private Sub Acc()
    Dim SQL As String
    Dim Serial As String
    Dim flag As Integer
    Dim Num As Integer
    SQL = "select House_drug.*,m_Drug.BaseUnit,m_Drug.Gprice,House_Drug.Amount*m_Drug.Gprice as GMoney " _
        & ",m_Drug.Cprice,House_Drug.Amount*m_Drug.Cprice as CMoney from House_Drug " _
        & "inner join m_drug on m_drug.itemcode=House_drug.itemCode " _
        & "where dsCode='" & gtydSysConfig.DepCode & "'and  Amount<>0"
    
    gDbObj.CNExe.BeginTrans
    If Not gDbObj.DBExec("DELETE House_BusSub FROM House_BusSub INNER JOIN House_BusMain " _
                        & "ON House_BusSub.busSerial=House_BusMain.BusSerial Where dscode='" & gtydSysConfig.DepCode & "'") Then
        GoTo ErrAcc
    End If
    If Not gDbObj.DBExec("Delete from House_BusMain where dsCode='" & gtydSysConfig.DepCode & "'") Then
        GoTo ErrAcc
    End If
    If Not Update_House_BusMain(HISDbInsert, Format(Date, "yymmdd") & gtydSysConfig.DepCode, gtydSysConfig.DepCode, "00", 1, Format(Date, "yyyy-mm-dd"), _
                   gtydSysConfig.HdCode, "", "", 0, "初始建帐") Then
        GoTo ErrAcc
    End If
    If gDbObj.GetRs(SQL) >= 0 Then
        If gDbObj.Rs.RecordCount = 0 Then
            flag = 1
            GoTo ErrAcc
        End If
        Num = 1
        Do While Not gDbObj.Rs.EOF
            If Not Update_House_BusSub(HISDbInsert, Format(Date, "yymmdd") & gtydSysConfig.DepCode, Num, gDbObj.Rs!ItemCode, gDbObj.Rs!Amount, _
                   gDbObj.Rs!Gprice, gDbObj.Rs!GMoney, gDbObj.Rs!CPrice, gDbObj.Rs!CMoney, _
                   gDbObj.Rs!BaseUnit, 1) Then
                GoTo ErrAcc
            End If
            gDbObj.Rs.MoveNext
            Num = Num + 1
        Loop
    End If
    gDbObj.CNExe.CommitTrans
    MsgBox "初始建帐完毕！", vbInformation
    Exit Sub
ErrAcc:
    gDbObj.CNExe.RollbackTrans
    If flag = 0 Then
        MsgBox gDbObj.ErrDes, vbCritical
    Else
        MsgBox "没有输入初始数据！", vbCritical
    End If
    
    
    
End Sub

Private Sub findspd(key As String)
    Dim i As Integer
    Dim TmpStr As String
    For i = 1 To spd.MaxRows
        spd.Row = i
        spd.Col = 1
        If spd.Text = key Then
            spd.SetFocus
            spd.Action = SS_ACTION_ACTIVE_CELL
            spd.EditMode = True
        End If
    Next i
End Sub

Private Sub FindDrug(key As String)
    Dim i As Integer
    Dim TmpStr As String
    For i = 1 To tvw.Nodes.Count
        TmpStr = Right(tvw.Nodes(i).key, Len(tvw.Nodes(i).key) - 1)
        If InStr(key, TmpStr) > 0 And tvw.Nodes(i).Children = 0 Then
            tvw.Nodes(i).Selected = True
            FillData TmpStr
            findspd key
        End If
    Next i
End Sub

Private Sub FillData(key As String)
    Dim SQL As String
    SQL = "Select m_Drug.ItemCode,m_Drug.ItemName,m_Drug.model,m_Drug.baseUnit,m_Drug.Gprice,m_Drug.Cprice,amount " _
        & "From m_Drug " _
        & "LEft join House_drug on House_drug.itemCode=m_drug.ItemCode and dsCode='" & gtydSysConfig.DepCode & "' " _
        & "where m_Drug.ItemCode like '" & key & "%'"
    If gDbObj.GetRs(SQL) > 0 Then
        spd.MaxRows = gDbObj.RecordCount
        spd.BlockMode = True
        spd.Col = 1
        spd.Col2 = spd.MaxCols
        spd.Row = 1
        spd.Row2 = gDbObj.RecordCount
        spd.Clip = gDbObj.Rs.GetString(, gDbObj.RecordCount)
        spd.BlockMode = False
    End If


End Sub
Private Sub InitForm()
    Dim SQL As String
    Dim PNode As Node
    
    hisFormClear Me
    
    tvw.Nodes.Clear
    Screen.MousePointer = 11
    frmMain.Note = "正在装入项目...请等候"
    tvw.Nodes.Clear
    Set PNode = tvw.Nodes.Add(, , "Root", "全院")
    PNode.Expanded = True
    
    SQL = "SELECT ItemCode,ItemName,0 As 'Kind' FROM m_ItemCati " _
        & "WHERE Flag & 1 = 1 " & gfnMakeLimit(gtydSysConfig.ItemCode, "ItemCode") _
        & " ORDER BY ItemCode"
    If gDbObj.GetRs(SQL) > 0 Then
        Do Until gDbObj.Rs.EOF
            Set PNode = gfnFindParent(PNode, gDbObj.Rs!ItemCode)
            Set PNode = tvw.Nodes.Add(PNode, tvwChild, "S" & gDbObj.Rs!ItemCode, gDbObj.Rs!ItemCode & " " & gDbObj.Rs!itemname)
            If gDbObj.Rs!Kind = 0 Then
                PNode.Parent.Image = 2
                PNode.Image = 3
            Else
                PNode.Image = 4
            End If
            gDbObj.Rs.MoveNext
        Loop
    End If
    tvw.Nodes.Item(1).Image = 1
    tvw.Nodes.Item(1).Selected = True
    tvw_NodeClick tvw.Nodes.Item(1)
    frmMain.Note = ""
    Screen.MousePointer = 0
End Sub
Private Sub Init()
    Dim i As Integer
    
    hisFormClear Me
    spd.MaxRows = 0
End Sub


Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub CmnHlp_ResSelect(ByVal SelData As Variant, ByVal STag As String)
    Dim key As String
    If TypeName(SelData) <> "Nothing" Then
        key = SelData(0)
        FindDrug key
        txtselect = ""
    End If
End Sub

Private Sub Command1_Click()
    If gtydSysConfig.Status = 2 Then
        MsgBox "正式运行后禁止此操作!", vbCritical
        Exit Sub
    End If
        
    If MsgBox("此操作将删除所有的业务记录！初次使用时才可执行，执行吗？", vbYesNo + 32) = vbYes Then Acc
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        hisToActiveCtl(Me).SetFocus
    End If
        
End Sub

Private Sub Form_Load()
    Call hisFormToCenter(Me, frmMain)
    Set CmnHlp = New frmInputHelp
    Set CmnHlp.CN = gDbObj.CN
    If gtydSysConfig.Status = 2 Then Command1.Visible = False
    InitForm
End Sub

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

Private Sub spd_EditMode(ByVal Col As Long, ByVal Row As Long, ByVal Mode As Integer, ByVal ChangeMade As Boolean)
    If ChangeMade Then
        spd.Col = Col
        spd.Row = Row
        Select Case Col
        Case 7
            If UpDateDataBase(Row) Then
                If Row < spd.MaxRows Then
                    spd.Row = spd.Row + 1
                    spd.Action = SS_ACTION_ACTIVE_CELL
                End If
            Else
                MsgBox "更新数据库错误！可能服务器忙，请重新输入库存", vbCritical
                spd.Text = ""
            End If
        End Select
    
    End If
End Sub

Private Sub tvw_NodeClick(ByVal Node As msComctlLib.Node)
    Dim ItemCode As String
    If Node.key <> "Root" Then
        ItemCode = Right(Node.key, Len(Node.key) - 1)
        FillData ItemCode
    Else
        Init
    End If
End Sub

Private Function UpDateDataBase(ByVal Row As Integer) As Boolean
    Dim ItemCode As String
    Dim Amount As Long
    Dim SQL As String
On Error GoTo ErrUp
    spd.Row = Row
    spd.Col = 1
    ItemCode = spd.Text
    spd.Col = 7
    Amount = Val(spd.Text)
    SQL = "Update House_drugBus set Amount=" & Amount & " " _
        & "where dsCode='" & gtydSysConfig.DepCode & "' and ItemCode='" & ItemCode & "'"
    gDbObj.CNExe.BeginTrans
    If Not Update_House_DrugBus(HISDbInsert, gtydSysConfig.DepCode, ItemCode, Amount) Then
        If Not gDbObj.DBExec(SQL) Then
            GoTo ErrUp
        End If
    End If
    If Not gDbObj.DBExec("delete house_DrugOpen where dsCode='" & gtydSysConfig.DepCode & "' and ItemCode='" & ItemCode & "'") Then
        GoTo ErrUp
    End If
    If Not gDbObj.DBExec("delete house_DrugInpati where dsCode='" & gtydSysConfig.DepCode & "' and ItemCode='" & ItemCode & "'") Then
        GoTo ErrUp
    End If
    UpDateDataBase = True
    gDbObj.CNExe.CommitTrans
    Exit Function
ErrUp:
    gDbObj.CNExe.RollbackTrans
End Function


Private Sub txtselect_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        If txtselect = "" Then Exit Sub
        CmnHlp.SQL = "SELECT m_Drug.ItemCode,m_Drug.ItemName,m_Drug.ItemName,m_Drug.Model," _
                & "M_Drug.BaseUnit,M_Drug.GenalUnit,M_Drug.factor," _
                & "m_Drug.GPrice,m_Drug.Cprice " _
                & "FROM m_Drug WHERE Brief Like '##%' " _
                & gfnMakeLimit(gtydSysConfig.ItemCode, "m_Drug.ItemCode") _
                & "UNION SELECT m_Drug.ItemCode,m_DrugAlias.AliasName,m_Drug.ItemName,m_Drug.Model," _
                & "M_Drug.BaseUnit,M_Drug.GenalUnit,M_Drug.factor," _
                & "m_Drug.GPrice,m_Drug.Cprice " _
                & "FROM m_Drug INNER JOIN M_DrugAlias " _
                & "ON m_Drug.ItemCode = m_DrugAlias.ItemCode " _
                & "WHERE m_DrugAlias.Brief Like '##%'" _
                & gfnMakeLimit(gtydSysConfig.ItemCode, "m_Drug.ItemCode")
        CmnHlp.FormatHead = _
            "|名              称         ||规              格|基本单位|包装单位|| 批发价| 零售价"
        CmnHlp.InitPut = txtselect.Text
        CmnHlp.WidthRate = 1.8
        CmnHlp.ParmTag = "Item"
        CmnHlp.ShowHelp vbModal
        spd.SetFocus
    End If
End Sub