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