Due to some technical error All Project source code & Project report are now available on www.ignousupport.blogspot.com Download all project for free
Discharge Ticket
Dim rst As New ADODB.Recordset
Private Sub cmd1_Click()
Unload Me
registration.Show
End Sub
Private Sub Cmd2_Click()
Me.TxtAge = ""
Me.TxtRegno = ""
Me.TxtRegno.Locked = False
Me.TxtName = ""
Me.TxtSex = ""
Me.TxtBed = ""
Me.TxtCategory = ""
Combo4(0) = ""
Text7 = ""
Text8 = ""
Text9 = ""
Command1.Enabled = False
Command2.Enabled = False
Command3.Enabled = False
Command4.Enabled = False
End Sub
Private Sub Combo2_Click()
Text9 = Text9 + " " + Combo2 + vbCrLf
End Sub
Private Sub Command2_Click()
Dim s As String
On Error GoTo ErHand
If Command2.Caption = "&Edit" Then
s = InputBox("Enter the Reg. no. to update.")
If s = "" Then
Exit Sub
End If
Set rst = New Recordset
rst.Open "select * from DischargeTicket where regno = " & s & " ", Conn, adOpenDynamic, adLockOptimistic
If rst.EOF = True Then
MsgBox "No Record Found", vbInformation
rst.Close
Exit Sub
End If
TxtRegno = rst!regno
TxtName = rst!Name
TxtAge = rst!Age
TxtSex = rst!sex
TxtBed = rst!bno
TxtCategory = rst!bcateg
TxtAdmissionDate = rst!doa
TxtDischargeDate = rst!dod
TxtDischargeTime = rst!tod
TxtAdmissionTime = rst!toa
Combo4(0).Text = rst!diag
Text7 = Replace(rst!invest, "@", vbTab)
Text8 = rst!treat
Text9 = rst!advise
End If
If Command2.Caption = "&Update" Then
s = TxtRegno
Conn.Execute "update DischargeTicket set name='" & TxtName & "' where regno=" & Val(s) & ""
Conn.Execute "update DischargeTicket set age =" & TxtAge & " where regno=" & Val(s) & ""
Conn.Execute "update DischargeTicket set sex ='" & TxtSex & "' where regno=" & Val(s) & ""
Conn.Execute "update DischargeTicket set dname ='" & Combo1(0) & "' where regno=" & Val(s) & ""
Conn.Execute "update DischargeTicket set doa='" & TxtAdmissionDate & "' where regno=" & Val(s) & ""
Conn.Execute "update DischargeTicket set toa='" & TxtAdmissionTime & "' where regno=" & Val(s) & ""
Conn.Execute "update DischargeTicket set bno =" & TxtBed & " where regno=" & Val(s) & ""
Conn.Execute "update DischargeTicket set bcateg ='" & TxtCategory & "' where regno=" & Val(s) & ""
Conn.Execute "update DischargeTicket set dod ='" & TxtDischargeDate & "' where regno=" & Val(s) & ""
Conn.Execute "update DischargeTicket set tod ='" & TxtDischargeTime & "' where regno=" & Val(s) & ""
Conn.Execute "update DischargeTicket set diag ='" & Combo4(0) & "' where regno=" & Val(s) & ""
Conn.Execute "update DischargeTicket set invest ='" & Text7 & "' where regno=" & Val(s) & ""
Conn.Execute "update DischargeTicket set treat ='" & Text8 & "' where regno=" & Val(s) & ""
Conn.Execute "update DischargeTicket set advise ='" & ChangeStr(Text9) & "' where regno=" & Val(s) & ""
End If
If Command2.Caption = "&Edit" Then
Command2.Caption = "&Update"
Else
If Command2.Caption = "&Update" Then
Command2.Caption = "&Edit"
End If
End If
ErHand:
ErrHandler "DischargeTicket.Command2_Click() [Edit]"
End Sub
Private Sub Command1_Click()
On Error GoTo ErHand
Dim a As String
a = InputBox("Enter the Refference No. to Delete")
Set rst = New ADODB.Recordset
rst.Open "select * from DischargeTicket where regno = " & Val(a) & "", Conn, adOpenDynamic, adLockOptimistic
If rst.EOF = True Then
MsgBox "No Record Matched with Registration No", vbInformation
rst.Close
Exit Sub
Else
i = MsgBox("Are you Sure ! To Delete the Record.?", vbYesNo + vbQuestion)
End If
If i = 6 Then
Conn.Execute "delete from DischargeTicket where regno = " & Val(a) & ""
MsgBox "Record ... Deleted!"
Else
Exit Sub
End If
ErHand:
ErrHandler "DischargeTicket.Command1_Click() [Delete]"
End Sub
Private Sub Command3_Click()
On Error GoTo ErHand
If TxtRegno.Text = "" Then MsgBox "Registration Should Not Be Empty", vbExclamation, App.Title: Exit Sub
Set rst = New ADODB.Recordset
rst.Open "select * from dischargeticket where regno=" & TxtRegno & "", Conn, adOpenDynamic, adLockOptimistic
If rst.EOF = False Then
MsgBox " This record already exist !", vbInformation
Exit Sub
End If
rst.AddNew
rst.Fields(0) = TxtRegno.Text
rst.Fields(1) = TxtName.Text
rst.Fields(2) = Val(TxtAge.Text)
rst.Fields(3) = TxtSex.Text
rst.Fields(4) = Combo1(0).Text
rst.Fields(5) = TxtAdmissionDate
rst.Fields(6) = TxtBed.Text
rst.Fields(7) = TxtCategory.Text
rst.Fields(8) = TxtDischargeDate
rst.Fields(9) = Combo4(0).Text
rst.Fields(10) = Replace(StrConv(Text7.Text, vbProperCase), CStr(vbTab), "@")
rst.Fields(11) = Text8.Text
rst.Fields(12) = ChangeStr(Text9.Text)
rst.Fields(13) = TxtAdmissionTime
rst.Fields(14) = TxtDischargeTime
rst.UpdateBatch
Set rst = Nothing
Call Cmd2_Click
ErHand:
ErrHandler "DischargeTicket.Command3_Click() [Save]"
End Sub
Private Sub Command4_Click()
On Error GoTo ErHand
DataEnvironment1.Recordsets.Item("Discharge_ticket").Open "select * from DischargeTicket where regno =" & Val(TxtRegno) & "", Conn, adOpenDynamic, adLockOptimistic
Disticket.Sections(1).Controls.Item("label57").Caption = hos_name
Disticket.Sections(1).Controls.Item("label58").Caption = hos_add
Disticket.Show
ErHand:
ErrHandler "DischargeTicket.Command4_Click() [Print]"
End Sub
Private Sub Form_Load()
On Error GoTo ErHand
Me.Top = (MDIForm1.ScaleHeight - Me.Height) / 2
Me.Left = (MDIForm1.ScaleWidth - Me.Width) / 2
Me.TxtDischargeDate = Date
TxtDischargeTime = Time
Me.TxtRegno = registration.TxtRegno
Me.TxtAge = registration.TxtAge
Me.TxtSex = registration.TxtSex
Me.TxtName = registration.TxtTitle + " " + registration.txtfirst + " " + registration.txtmiddle + " " + registration.txtlast
Me.Combo1(0) = registration.TxtDoctorIncharge.Text
Set rst = New ADODB.Recordset
rst.Open "select doa,catname,bedno,diagnosis,doa,aot from addmission where refno=" & registration.TxtRegno & " order by doa desc", Conn, adOpenDynamic, adLockOptimistic
If rst.EOF = False Then
'Rst.MoveLast
Me.TxtCategory = rst!catname & ""
Me.TxtAdmissionDate = rst!doa & ""
Me.TxtAdmissionTime = rst!aot & ""
Me.TxtBed = rst!bedno & ""
Me.Combo4(0) = rst!Diagnosis & ""
Else
rst.Close
End If
Set rst = New Recordset
rst.Open "select * from remark ", Conn, adOpenDynamic, adLockOptimistic
If rst.EOF = False Then
Do While Not rst.EOF = True
Combo2.AddItem rst!remark1
rst.MoveNext
Loop
End If
rst.Close
Call TxtRegNo_KeyPress(13)
ErHand:
ErrHandler "DischargeTicket.Form_Load()"
End Sub
Private Sub Form_Unload(Cancel As Integer)
registration.Enabled = True
End Sub
Private Sub TxtRegNo_KeyPress(KeyAscii As Integer)
On Error GoTo ErHand
If TxtRegno = "" Then
Exit Sub
End If
If KeyAscii = vbKeyReturn Then
Set rst = New Recordset
rst.Open "select * from Hospital where Registration = " & TxtRegno & " ", Conn, adOpenDynamic, adLockOptimistic
If rst.EOF = True Then
MsgBox "No Record Found", vbInformation
rst.Close
Exit Sub
End If
TxtName = rst.Fields(6) & " " + rst.Fields(7) & " " + rst.Fields(8) & " "
TxtAge = rst!Age & ""
TxtSex = rst!sex & ""
rst.Close
Set rst = New Recordset
rst.Open "select * from Addmission where refno =" & TxtRegno.Text & " ", Conn, adOpenDynamic, adLockOptimistic
If rst.EOF = True Then
rst.Close
Exit Sub
End If
TxtBed = rst.Fields("bedno") & " "
TxtCategory = rst.Fields("catname") & ""
Combo1(0) = rst.Fields("docincharge")
TxtAdmissionDate = Format(rst.Fields("doa"), "dd-MMM-yyyy")
TxtAdmissionTime = IIf(IsNull(rst.Fields("aot")) = True, "12:00", rst.Fields("aot"))
TxtDischargeDate = IIf(IsNull(rst.Fields("dod")) = True, Format(Date, "dd-MMM-yyyy"), rst.Fields("dod"))
Me.TxtDischargeTime = IIf(IsNull(rst.Fields("dot")) = True, "12:00", rst.Fields("dot"))
Combo4(0) = rst.Fields("diagnosis")
Call Investigation
Command1.Enabled = True
Command2.Enabled = True
Command3.Enabled = True
Command4.Enabled = True
If IsNull(rst.Fields("dod")) = True Then
MsgBox "First Discharge The Patient", vbInformation
Command1.Enabled = False
Command2.Enabled = False
Command3.Enabled = False
Command4.Enabled = False
rst.Close
Exit Sub
End If
End If
ErHand:
ErrHandler "DischargeTicket.TxtRegNo_KeyPress()"
End Sub
Private Sub Investigation()
On Error GoTo ErHand
Dim STR As String
Dim RstInv As New ADODB.Recordset
RstInv.Open "select * from datewiseinvest where regno=" & Val(TxtRegno) & "", Conn, adOpenDynamic, adLockOptimistic
If RstInv.EOF = True Then
RstInv.Close
Exit Sub
End If
Do While (RstInv.EOF = False)
If Not RstInv!invest_date = "" Then
s = s & vbTab & vbTab & "Date :" + Format(RstInv!invest_date, "dd/MM/yyyy") & vbCrLf
End If
If Not RstInv!XRAY = "" Then
s = s + "XRAY :" + CStr(RstInv!XRAY) & vbTab
End If
If Not RstInv!EDD = "" Then
s = s + "EDD :" + RstInv!EDD & vbTab
End If
If Not RstInv!HIV = "" Then
s = s + "HIV :" + RstInv!HIV & vbCrLf
End If
If Not RstInv!HBS = "" Then
s = s + "HBsAg :" + RstInv!HBS & vbTab
End If
If Not RstInv!GPRH = "" Then
s = s + "GpRH :" + RstInv!GPRH & vbTab
End If
If Not RstInv!VDRL = "" Then
s = s + "VDRL :" + RstInv!VDRL & vbCrLf
End If
If Not RstInv!Gravindex_text = "" Then
s = s + "Gravindex Test :" + RstInv!Gravindex_text & vbTab
End If
If Not RstInv!PPBS = "" Then
s = s + "PPBS :" + RstInv!PPBS & vbTab
End If
If Not RstInv!FBS = "" Then
s = s + "FBS :" + RstInv!FBS & vbCrLf
End If
If Not RstInv!MH = "" Then
s = s + "MH :" + RstInv!MH & vbTab
End If
If Not RstInv!HB = "" Then
s = s + "HB % :" + RstInv!HB & vbTab
End If
If Not RstInv!OBST = "" Then
s = s + "OBST :" + RstInv!OBST & vbCrLf
End If
If Not RstInv!URINE = "" Then
s = s + "URINE :" + RstInv!URINE & vbTab
End If
If Not RstInv!USG = "" Then
s = s + "USG :" + RstInv!USG & vbTab
End If
If Not RstInv!DIABETES = "" Then
s = s + "DIABETES :" + RstInv!DIABETES & vbCrLf
End If
If Not RstInv!HYPER = "" Then
s = s + "HYPERTENSION :" + RstInv!HYPER & vbTab
End If
If Not RstInv!GENERALcase = "" Then
s = s + "GENERAL EXAMINATION :" + RstInv!GENERALcase & vbTab
End If
If Not RstInv!Pcase = "" Then
s = s + "CASE HISTORY :" + RstInv!Pcase & vbCrLf
End If
Text7 = Text7 + s & vbCrLf
Text7.Text = StrConv(Text7.Text, vbProperCase)
s = ""
RstInv.MoveNext
Loop
ErHand:
ErrHandler "DischargeTicket.Investigation()"
End Sub
Sponsored Links