Next Chapter 65 Work Done
PROJECT SOURCE CODE
SPONSORED LINKS
Work Done
Dim ADDMode As Boolean
Dim DelMode As Boolean
Dim ADDChargeMode As Boolean
Dim EditMode As Boolean
Dim EmptyTable As Boolean
Dim rst As New ADODB.Recordset
Dim s As String
Private Sub SetControls()
'Set Forms Control's status
'Called in Form_Load(), Navigation Buttons Click()
AddCmd.Enabled = Not (ADDMode Or EditMode)
EditCmd.Enabled = Not (EmptyTable Or ADDMode Or EditMode)
SaveCmd.Enabled = (ADDMode Or EditMode)
ChargeCmd.Enabled = (ADDMode Or EditMode)
CancelCmd.Enabled = (ADDMode Or EditMode)
ExitCmd.Enabled = Not (ADDMode Or EditMode)
TxtVisitDate.Visible = (EditMode)
TxtDate.Visible = Not (EditMode)
DelCmd.Enabled = (EditMode)
Set VisitSrch.BoundTextBox = IIf(EditMode, Me.TxtVisitDate, Nothing)
If Not (EditMode) Then VisitSrch.HideList
End Sub
Private Sub ChargeCmd_Click()
If Not SavedData Then Exit Sub
ADDChargeMode = True
Call SetFieldsValues(TxtRegno.Text, TxtDate.Value)
End Sub
Private Sub TxtWork_Click()
Set rst = New Recordset
rst.Open "select * from billmast where discription = '" & TxtWork & "'", Conn, adOpenDynamic, adLockOptimistic
If rst.EOF Or rst.BOF = True Then Exit Sub
TxtAmount = rst!amount
rst.Close
End Sub
Private Sub AddCmd_Click()
On Error GoTo ErHand
ADDMode = True
Call ClearFields
Call SetControls
Conn.BeginTrans
ErHand:
ErrHandler "Work.AddCmd_Click()"
End Sub
Private Sub CancelCmd_Click()
On Error GoTo ErHand
ADDMode = False
EditMode = False
If ADDChargeMode = True Then MsgBox "You Have Added Some New Charges In This Patient's Record " & vbCrLf & "First Save Theses Item By Pressing Save Button " & vbCrLf & " Otherwise Records Will Not Save in Database ", vbQuestion + vbOKOnly + vbDefaultButton2, App.Title: Exit Sub
If DelMode = True Then MsgBox "You Have Deleted Some Charges In This Patient's Record " & vbCrLf & "First Save Theses Item By Pressing Save Button " & vbCrLf & " Otherwise Records Will Not Be Delete From Database ", vbQuestion + vbOKOnly + vbDefaultButton2, App.Title: Exit Sub
ADDChargeMode = False
Call ClearFields
Call SetControls
Conn.RollbackTrans
ErHand:
ErrHandler "Work.AddCmd_Click()"
End Sub
Private Sub DelCmd_Click()
On Error GoTo ErHand
Dim Cancelled As Boolean
Dim SQL As String
Dim rst As New ADODB.Recordset
rst.CursorLocation = adUseClient
If Me.TxtRegno = "" Then MsgBox "Please Enter Patient Registration From list to delete.", vbCritical, "Patient Id Not Found": Exit Sub
If MSFlexGrid1.RowSel = 0 Then Exit Sub
If MsgBox("This will Delete Selected Item [" & MSFlexGrid1.TextMatrix(MSFlexGrid1.RowSel, 2) & "] Of Date [ " & MSFlexGrid1.TextMatrix(MSFlexGrid1.RowSel, 1) & " ] . Are you sure to delete it ?", vbQuestion + vbYesNo + vbDefaultButton2, "Deletion Confirmation") = vbNo Then Cancelled = True: GoTo ExitLable
'Delete Item
SQL = "delete from workdone where Serialno = " & MSFlexGrid1.TextMatrix(MSFlexGrid1.RowSel, 0) & " and regno=" & TxtRegno & ""
Conn.Execute SQL, , adCmdText
DelMode = True
Call SetFieldsValues(TxtRegno.Text, TxtVisitDate.Text)
ExitLable:
ErHand:
ErrHandler "Work.DelCmd_Click"
If Cancelled Then Conn.RollbackTrans
ADDMode = False
'Call ClearFields
Call SetControls
End Sub
Private Sub EditCmd_Click()
EditMode = True
Call SetControls
Call ClearFields
Conn.BeginTrans
Me.TxtVisitDate.SetFocus
End Sub
Private Sub ExitCmd_Click()
Unload Me
End Sub
Private Sub SetSearchEngines()
'Called in Form_Load()
With DocSrch
.DBConnectString = ConnectString
.SQLString = "SELECT ID, Title + space(1) + FName + space(1) + MName + space(1) + LName FROM DocMast Order by ID "
.PopulateList
Set .BoundTextBox = Me.TxtDoctor
End With
With VisitSrch
.DBConnectString = ConnectString
.SQLString = "SELECT RegNo,VisitDate from WorkQuery where Regno=" & Val(TxtRegno.Text)
.PopulateList
Set .BoundTextBox = Me.TxtVisitDate
End With
End Sub
Private Sub Form_Load()
On Error GoTo ErHand
Me.Top = 0
Me.Left = 100
Me.TxtDate = Date
TxtRegno = registration.TxtRegno
TxtPatient = registration.TxtTitle + " " + registration.txtfirst + " " + registration.txtmiddle + " " + registration.txtlast
TxtDoctor.Text = registration.TxtDoctorIncharge
Set rst = New Recordset
rst.Open "select Distinct discription from billmast", Conn, adOpenDynamic, adLockOptimistic
While Not rst.EOF
TxtWork.AddItem rst!Discription & ""
rst.MoveNext
Wend
If TxtRegno = "" Then MsgBox "Go To Patient Registration Form & Enter Registration No.", vbInformation: Exit Sub
Call SetSearchEngines
Call SetControls
Call SetFieldsValues(TxtRegno.Text)
ErHand:
ErrHandler "Work.Form_Load"
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
If (ADDMode Or EditMode) Then
Cancel = True
Exit Sub
End If
registration.Enabled = True
Conn.RollbackTrans
End Sub
Private Sub ClearFields()
'To Clear forms fields
'Called in AddCmd_Click()
Me.TxtDate = Date
Me.TxtDoctor = ""
Me.TxtWork = ""
Me.TxtRemark = ""
TxtAmount = "0"
MSFlexGrid1.Clear
MSFlexGrid1.FormatString = " S. No. | Visit Date | Work Done |^Amount |^Attending Doctor "
MSFlexGrid1.Rows = 1
End Sub
Private Sub SetFieldsValues(DocID As String, Optional VisitDate As String)
'Set database values in the forms fields
'Called in ItemDBCtl_MoveComplete()
MSFlexGrid1.Clear
MSFlexGrid1.FormatString = " S. No. |^Visit Date |^Work Done |^Amount |^Attending Doctor "
MSFlexGrid1.Rows = 1
If DocID = "" Then Exit Sub
Set rst = New ADODB.Recordset
If Not VisitDate = "" Then
rst.Open "Select Serialno,VisitDate,Workdone,Amount,AttendingDoc from workdone where RegNo=" & DocID & " And VisitDate='" & Format(VisitDate, "dd-MMM-yyyy") & "'", Conn, adOpenDynamic, adLockOptimistic
Else
rst.Open "Select serialno,VisitDate,Workdone,Amount,AttendingDoc from workdone where RegNo=" & DocID & "", Conn, adOpenDynamic, adLockOptimistic
End If
On Error GoTo ErHand
If (rst.EOF = True) Then Call ClearFields: Exit Sub
If rst.EOF Then rst.MoveLast
If rst.BOF Then rst.MoveFirst
While Not rst.EOF
MSFlexGrid1.AddItem rst.Fields("SerialNo") & "" & Chr(9) & Format(rst.Fields("VisitDate"), "dd-MMM-yyyy") & "" & Chr(9) & rst.Fields("WorkDone") & "" & Chr(9) & rst.Fields("Amount") & "" & Chr(9) & rst.Fields("AttendingDoc") & ""
TxtDate = rst!VisitDate
TxtDoctor = rst!AttendingDoc
rst.MoveNext
Wend
With Me
MSFlexGrid1.ColWidth(0) = 0
TxtAmount = "0"
TxtRemark = ""
TxtWork = "Select One"
Label8 = ""
End With
ErHand:
ErrHandler "WorkFrm.SetFieldsValues()"
End Sub
Private Sub SaveCmd_Click()
Conn.CommitTrans
VisitSrch.PopulateList
ADDMode = False
EditMode = False
ADDChargeMode = False
DelMode = False
Call SetControls
End Sub
Private Sub TxtDoctor_GotFocus()
If Not EditMode Then Exit Sub
DocSrch.SearchValue TxtDoctor
DocSrch.PopulateList
End Sub
Private Function ValidateData() As Boolean
With Me
If Trim(.TxtAmount) = "" Then
MsgBox "Please Enter Amount.", vbCritical, "Missing values"
.TxtAmount.SetFocus
ElseIf TxtRegno = "" Then
MsgBox "Please Enter Registration No.", vbInformation
TxtRegno.SetFocus
Exit Function
ElseIf TxtWork = "" Then
MsgBox "Please Enter Work Field.", vbInformation
TxtWork.SetFocus
Exit Function
Else
ValidateData = True
End If
End With
End Function
Private Function GetItemCode()
Dim RS As New ADODB.Recordset
RS.Open "Select Max(SerialNo) From WorkDone", Conn, adOpenDynamic, adLockOptimistic
GetItemCode = GetProperCode(IIf(IsNull(RS(0)), "1", RS(0) + 1), 4)
End Function
Private Function SavedData() As Boolean
On Error GoTo ErrLbl
If Not ValidateData Then Exit Function
Dim RstCheck As New ADODB.Recordset
RstCheck.Open "Select * from WorkDone Where Regno=" & TxtRegno.Text & " And VisitDate='" & Format(TxtDate.Value, "dd-MMM-yyyy") & "' And WorkDone='" & TxtWork.Text & "'", Conn, adOpenDynamic, adLockBatchOptimistic
If Not RstCheck.EOF = True Then
Dim i As Integer
i = MsgBox("You Are Going To Add Duplicate Charge [ " & TxtWork.Text & " ] " & vbCrLf & "To Patient [" & TxtPatient.Text & " ] " & vbCrLf & "Date [" & Format(TxtDate.Value, "dd-MMM-yyyy") & " ]" & vbCrLf & " Do You Want To Continue........ ", vbYesNo + vbExclamation, App.Title)
If i = vbNo Then Exit Function
Set RstCheck = Nothing
End If
Dim SQL As String
Dim rst As New ADODB.Recordset
rst.CursorLocation = adUseClient
SQL = "SELECT * FROM Workdone "
rst.Open SQL, Conn, adOpenKeyset, adLockOptimistic, adCmdText
With Me
rst.AddNew
rst("SerialNo") = GetItemCode()
rst("Regno") = Trim(.TxtRegno) & ""
rst("VisitDate") = Trim(.TxtDate) & ""
rst("PatientName") = Trim(.TxtPatient) & ""
rst("AttendingDoc") = Trim(.TxtDoctor) & ""
rst("WorkDone") = Trim(.TxtWork) & ""
rst("Amount") = Trim(.TxtAmount) & ""
rst("Remark") = Trim(.TxtRemark) & ""
rst.UpdateBatch
End With
SavedData = True
Exit Function
ErrLbl:
ErrHandler "Function Work.SavedData"
End Function
Private Sub TxtvisitDate_GotFocus()
If Not EditMode Then Exit Sub
VisitSrch.SearchValue TxtDate
VisitSrch.PopulateList
End Sub
Private Sub TxtvisitDate_LostFocus()
If Not (ADDMode Or EditMode) Then Exit Sub
If TxtVisitDate.Text = "" Then MsgBox "Please Enter Visit Date", vbExclamation, App.Title: Exit Sub
Call SetFieldsValues(TxtRegno.Text, CDate(TxtVisitDate.Text))
End Sub