Health Organizer Code

{

    Health Organizer (http://sourceforge.net/projects/hor/,
                      http://hor.sourceforge.net/)
    Copyright (C) 2014-2015  Andrea Urbani ( matfanjol@users.sf.net,
	                                     matfanjol@mail.com )

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.

}
unit hor_main;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, pqconnection, sqldb, FileUtil, Forms, Controls, Graphics,
  Dialogs, defaulttranslator, ComCtrls, Menus, ActnList, XMLPropStorage;

type

  { TfrmMain }

  TfrmMain = class(TForm)
    actDbConnect: TAction;
    actHeAbout: TAction;
    actCountriesAdd: TAction;
    actCountriesList: TAction;
    actDbCheckSystemTables: TAction;
    actHospitalsAdd: TAction;
    actHospitalsList: TAction;
    actExaminationsNamesAdd: TAction;
    actExaminationsNamesList: TAction;
    actExaminationsAdd: TAction;
    actExaminationsList: TAction;
    actExaminationsNamesCategoriesAdd: TAction;
    actExaminationsNamesCategoriesList: TAction;
    actDocumentsAdd: TAction;
    actDocumentsList: TAction;
    actPrescriptionsList: TAction;
    actPrescriptionsAdd: TAction;
    actMeasurementsList: TAction;
    actPathologiesAdd: TAction;
    actPathologiesList: TAction;
    actMeasurementsAdd: TAction;
    actPersonsAdd: TAction;
    actPersonsList: TAction;
    actQuit: TAction;
    MainActionList: TActionList;
    MainMenu: TMainMenu;
    MenuItem1: TMenuItem;
    MenuItem2: TMenuItem;
    MenuItem6: TMenuItem;
    miPrescriptionsList: TMenuItem;
    miPrescriptionsAdd: TMenuItem;
    miPatientsPrescriptions: TMenuItem;
    miDocumentsList: TMenuItem;
    miDocumentsAdd: TMenuItem;
    miPersonsDocuments: TMenuItem;
    miExaminationsNamesCategoriesList: TMenuItem;
    miExaminationsNamesCategoriesAdd: TMenuItem;
    miGeneralDataExaminationsNamesCategories: TMenuItem;
    miExaminationsList: TMenuItem;
    miExaminationsAdd: TMenuItem;
    miPatientsExaminations: TMenuItem;
    miMeasurementsList: TMenuItem;
    miExaminationsNamesList: TMenuItem;
    MenuItem7: TMenuItem;
    miGeneralDataExaminationsNames: TMenuItem;
    miHospitalsAdd: TMenuItem;
    miGeneralDataHospitals: TMenuItem;
    miPathologiesList: TMenuItem;
    miPathologiesAdd: TMenuItem;
    miGeneralDataPathologies: TMenuItem;
    miGeneralData: TMenuItem;
    miLaFrancais: TMenuItem;
    miLaPortuguese: TMenuItem;
    miMeasurementsAdd: TMenuItem;
    miPatientsMeasurements: TMenuItem;
    miPatients: TMenuItem;
    miDbCheckST: TMenuItem;
    MenuItem5: TMenuItem;
    miCountriesList: TMenuItem;
    miCountriesAdd: TMenuItem;
    miGdCountries: TMenuItem;
    miGeneralDataGeographical: TMenuItem;
    miPersons: TMenuItem;
    MenuItem3: TMenuItem;
    MenuItem4: TMenuItem;
    miHeAbout: TMenuItem;
    miHelp: TMenuItem;
    miLaItaliano: TMenuItem;
    miLaEnglish: TMenuItem;
    miLanguage: TMenuItem;
    miDbQuit: TMenuItem;
    miDbOpen: TMenuItem;
    miDatabase: TMenuItem;
    pgConnection: TPQConnection;
    pgConnectionDefData: TPQConnection;
    pgQuery: TSQLQuery;
    pgQueryDefData: TSQLQuery;
    pgTransaction: TSQLTransaction;
    pgScript: TSQLScript;
    pgTransactionDefData: TSQLTransaction;
    StatusBar: TStatusBar;
    XmlPropStor: TXMLPropStorage;
    procedure actCountriesAddExecute(Sender: TObject);
    procedure actCountriesListExecute(Sender: TObject);
    procedure actDbCheckSystemTablesExecute(Sender: TObject);
    procedure actDbConnectExecute(Sender: TObject);
    procedure actDocumentsAddExecute(Sender: TObject);
    procedure actDocumentsListExecute(Sender: TObject);
    procedure actExaminationsAddExecute(Sender: TObject);
    procedure actExaminationsListExecute(Sender: TObject);
    procedure actExaminationsNamesAddExecute(Sender: TObject);
    procedure actExaminationsNamesCategoriesAddExecute(Sender: TObject);
    procedure actExaminationsNamesCategoriesListExecute(Sender: TObject);
    procedure actExaminationsNamesListExecute(Sender: TObject);
    procedure actHeAboutExecute(Sender: TObject);
    procedure actHospitalsAddExecute(Sender: TObject);
    procedure actHospitalsListExecute(Sender: TObject);
    procedure actMeasurementsAddExecute(Sender: TObject);
    procedure actMeasurementsListExecute(Sender: TObject);
    procedure actPathologiesAddExecute(Sender: TObject);
    procedure actPathologiesListExecute(Sender: TObject);
    procedure actPersonsAddExecute(Sender: TObject);
    procedure actPersonsListExecute(Sender: TObject);
    procedure actPrescriptionsAddExecute(Sender: TObject);
    procedure actPrescriptionsListExecute(Sender: TObject);
    procedure actProblemsAddExecute(Sender: TObject);
    procedure actQuitExecute(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure miLaEnglishClick(Sender: TObject);
    procedure pgConnectionAfterConnect(Sender: TObject);
    procedure pgConnectionAfterDisconnect(Sender: TObject);
    procedure pgScriptException(Sender: TObject; Statement: TStrings;
      TheException: Exception; var Continue: boolean);
  protected
    procedure SelectLanguage( MenuItem : TMenuItem );
    procedure BuildTitle;
    procedure EnableDisableDatabaseRelativeFunction( const EnableThem :
      boolean);
  private
    { private declarations }
  public
    var ReadOnlyMode: boolean;

    // It asks to the user to select a patient.
    // If no patient exists, the user can create a new one
    // If only one patient exists, that one is returned
    // Otherwise the selection mask is showed in modal form
    // Returns true if PatientID and PatientName contain valid data.
    function SelectPatient( var PatientID : LongInt; var PatientName : string ):
      boolean;

    // It asks to the user to select a person.
    // If no person exists, the user can create a new one
    // If only one person exists, that one is returned
    // Otherwise the selection mask is showed in modal form
    // Returns true if PersonID and PersonName contain valid data.
    function SelectPerson( var PersonID : LongInt; var PersonName : string ):
      boolean;
  end;

var
  frmMain: TfrmMain;
  Traduzioni: string;

const
  constMyLatestKnownDbVersion=1;
  constMyLatestKnownDbDefDataVersion=1;

  // The default data database is built with the <database name> +
  // constDefaultDataDatabaseSuffix name and will contain default data like the
  // list of countries, cities, drugs, etc..
  // The idea is to store inside the main database just the used data.
  constDefaultDataDatabaseSuffix='_defdata';

implementation

{$R *.lfm}

{ TfrmMain }

Uses hor_dbopen, hor_about, hor_navigation_persons,
  hor_edit_persons, hor_navigation_countries, hor_edit_countries, LCLTranslator,
  hor_messages, hor_database, hor_combobox_patient, hor_edit_mdl_measurements,
  hor_navigation_pathologies, hor_edit_pathologies, hor_navigation_hospitals,
  hor_edit_hospitals, hor_navigation_examinations_names,
  hor_edit_examinations_names, hor_navigation_measurements,
  hor_edit_examinations, hor_navigation_examinations,
  hor_navigation_examinations_names_categories,
  hor_edit_examinations_names_categories, hor_edit_documents,
  hor_navigation_documents, hor_combobox_person, hor_edit_prescriptions,
  hor_navigation_prescriptions;

procedure TfrmMain.actQuitExecute(Sender: TObject);
begin
  Application.Terminate;
end;

procedure TfrmMain.FormActivate(Sender: TObject);
begin
  if ( not pgConnection.Connected ) then
    // I automatically start the connection action if no connection is available
    actDbConnect.Execute;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  XmlPropStor.FileName:=GetAppConfigFileUTF8(false,false,true);
  ReadOnlyMode := false;
  BuildTitle;
  // At the beginning, that there is no database connection, all the function
  // relative to the database has to be disabled
  EnableDisableDatabaseRelativeFunction(false);
end;

procedure TfrmMain.actDbConnectExecute(Sender: TObject);
begin
  Application.CreateForm(TfrmDbConnect,frmDbConnect);
  frmDbConnect.ShowModal;
//  if ( frmDbConnect.ShowModal = mrOK ) then
//    DatabaseChanged
  frmDbConnect.Release;
end;

procedure TfrmMain.actDocumentsAddExecute(Sender: TObject);
var
  vPersonID : LongInt;
  vPersonName : string;
begin
  // First of all I have to request for which person
  vPersonID:=0;
  vPersonName:='';
  if ( SelectPerson( vPersonID, vPersonName ) ) then
  begin
    with TfrmEditDocuments.Create( Application ) do
    begin
      Caption := Format( Caption, [ vPersonName ] );
      lblTitle.Caption := Caption;
      NewRecord;
      qDataID_Person.Value:=vPersonID;
      Show;
    end;
  end;
end;

procedure TfrmMain.actDocumentsListExecute(Sender: TObject);
var
  vPersonID : LongInt;
  vPersonName : string;
begin
  // First of all I have to request for which person
  vPersonID:=0;
  vPersonName:='';
  if ( SelectPerson( vPersonID, vPersonName ) ) then
  begin
    with TfrmNavigationDocuments.Create( Application ) do
    begin
      qList.ParamByName('ID').Value := vPersonID;
      PersonName := vPersonName;
      PersonID := vPersonID;
      Show();
    end;
  end;
end;

procedure TfrmMain.actExaminationsAddExecute(Sender: TObject);
var
  vPatientID : LongInt;
  vPatientName : string;
begin
  // First of all I have to request for which patiente
  vPatientID:=0;
  vPatientName:='';
  if ( SelectPatient( vPatientID, vPatientName ) ) then
  begin
    with TfrmEditExaminations.Create( Application ) do
    begin
      PatientName:=vPatientName;
      PatientID:=vPatientID;
      Caption := Format( Caption, [ vPatientName ] );
      lblTitle.Caption := Caption;
      NewRecord;
      qDataID_Patient.Value:=vPatientID;
      Show;
    end;
  end;
end;

procedure TfrmMain.actExaminationsListExecute(Sender: TObject);
var
  vPatientID : LongInt;
  vPatientName : string;
begin
  // First of all I have to request for which patiente
  vPatientID:=0;
  vPatientName:='';
  if ( SelectPatient( vPatientID, vPatientName ) ) then
  begin
    with TfrmNavigationExaminations.Create( Application ) do
    begin
      qList.ParamByName('ID').Value := vPatientID;
      PatientName := vPatientName;
      PatientID := vPatientID;
      Show;
    end;
  end;
end;

procedure TfrmMain.actExaminationsNamesAddExecute(Sender: TObject);
begin
  with TfrmEditExaminations_Names.Create(Self) do
  begin
    NewRecord;
    Show;
  end;
end;

procedure TfrmMain.actExaminationsNamesCategoriesAddExecute(Sender: TObject);
begin
  with TfrmEditExaminations_Names_Categories.Create(Self) do
  begin
    NewRecord;
    Show;
  end;
end;

procedure TfrmMain.actExaminationsNamesCategoriesListExecute(Sender: TObject);
begin
  TfrmNavigationExaminations_Names_Categories.Create(Self).Show();
end;

procedure TfrmMain.actExaminationsNamesListExecute(Sender: TObject);
begin
  TfrmNavigationExaminations_Names.Create(Self).Show();
end;

procedure TfrmMain.actCountriesListExecute(Sender: TObject);
begin
  TfrmNavigationCountries.Create(Self).Show();
end;

procedure TfrmMain.actDbCheckSystemTablesExecute(Sender: TObject);
begin
  Screen.Cursor := crSQLWait;
  try
    try
      if ( DB_CheckSystemData() ) then
        MessageDlg( rsMsgDone, rsMsgCheckSuccess, mtInformation, [mbOk], 0 )
      else
        MessageDlg( rsMsgError, rsMsgUnknown, mtError, [mbOk], 0 );
    except
      on E: Exception do
        MessageDlg( rsMsgError, Format( rsMsgErrorCheckingSystemData, [
          e.Message ] ), mtError, [mbOk], 0 );
    end;
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TfrmMain.actCountriesAddExecute(Sender: TObject);
begin
  with TfrmEditCountries.Create(Self) do
  begin
    NewRecord;
    Show;
  end;
end;

procedure TfrmMain.actHeAboutExecute(Sender: TObject);
begin
  Application.CreateForm(TfrmAbout, frmAbout);
  frmAbout.ShowModal;
  frmAbout.Release;
end;

procedure TfrmMain.actHospitalsAddExecute(Sender: TObject);
begin
  with TfrmEditHospitals.Create(Self) do
  begin
    NewRecord;
    Show;
  end;
end;

procedure TfrmMain.actHospitalsListExecute(Sender: TObject);
begin
  TfrmNavigationHospitals.Create(Self).Show();
end;

procedure TfrmMain.actMeasurementsAddExecute(Sender: TObject);
var
  vPatientID : LongInt;
  vPatientName : string;
begin
  // First of all I have to request for which patiente
  vPatientID:=0;
  vPatientName:='';
  if ( SelectPatient( vPatientID, vPatientName ) ) then
  begin
    with TfrmEditMdlMeasurements.Create( Application ) do
    begin
      Caption := Format( Caption, [ vPatientName ] );
      lblTitle.Caption := Caption;
      NewRecord;
      qDataID_Patient.Value:=vPatientID;
      Show;
    end;
  end;
end;

procedure TfrmMain.actMeasurementsListExecute(Sender: TObject);
var
  vPatientID : LongInt;
  vPatientName : string;
begin
  // First of all I have to request for which patiente
  vPatientID:=0;
  vPatientName:='';
  if ( SelectPatient( vPatientID, vPatientName ) ) then
  begin
    with TfrmNavigationMeasurements.Create( Application ) do
    begin
      qList.ParamByName('ID').Value := vPatientID;
      PatientName := vPatientName;
      PatientID := vPatientID;
      Show;
    end;
  end;
end;

procedure TfrmMain.actPathologiesAddExecute(Sender: TObject);
begin
  with TfrmEditPathologies.Create(Self) do
  begin
    NewRecord;
    Show;
  end;
end;

procedure TfrmMain.actPathologiesListExecute(Sender: TObject);
begin
  TfrmNavigationPathologies.Create(Self).Show();
end;

procedure TfrmMain.actPersonsAddExecute(Sender: TObject);
begin
  with TfrmEditPersons.Create(Self) do
  begin
    NewRecord;
    Show;
  end;
end;

procedure TfrmMain.actPersonsListExecute(Sender: TObject);
begin
  TfrmNavigationPersons.Create(Self).Show();
end;

procedure TfrmMain.actPrescriptionsAddExecute(Sender: TObject);
var
  vPatientID : LongInt;
  vPatientName : string;
begin
  // First of all I have to request for which patiente
  vPatientID:=0;
  vPatientName:='';
  if ( SelectPatient( vPatientID, vPatientName ) ) then
  begin
    with TfrmEditPrescriptions.Create( Application ) do
    begin
      PatientID:=vPatientID;
      PatientName:=vPatientName;
      Caption := Format( Caption, [ vPatientName ] );
      lblTitle.Caption := Caption;
      NewRecord;
      qDataID_Patient.Value:=vPatientID;
      Show;
    end;
  end;
end;

procedure TfrmMain.actPrescriptionsListExecute(Sender: TObject);
var
  vPatientID : LongInt;
  vPatientName : string;
begin
  // First of all I have to request for which patiente
  vPatientID:=0;
  vPatientName:='';
  if ( SelectPatient( vPatientID, vPatientName ) ) then
  begin
    with TfrmNavigationPrescriptions.Create( Application ) do
    begin
      qList.ParamByName('ID').Value := vPatientID;
      PatientName := vPatientName;
      PatientID := vPatientID;
      Show;
    end;
  end;
end;

procedure TfrmMain.actProblemsAddExecute(Sender: TObject);
begin
end;

procedure TfrmMain.miLaEnglishClick(Sender: TObject);
begin
  if ( Sender is TMenuItem ) then
    SelectLanguage( Sender as TMenuItem );
end;

procedure TfrmMain.pgConnectionAfterConnect(Sender: TObject);
begin
  EnableDisableDatabaseRelativeFunction(true);
end;

procedure TfrmMain.pgConnectionAfterDisconnect(Sender: TObject);
begin
  EnableDisableDatabaseRelativeFunction(false);
  if ( pgConnectionDefData.Connected ) then
    pgConnectionDefData.Connected:=false;
end;

procedure TfrmMain.pgScriptException(Sender: TObject; Statement: TStrings;
  TheException: Exception; var Continue: boolean);
begin
  Continue := false;
  raise Exception.Create( Statement.Text + LineEnding + TheException.Message );
end;

procedure TfrmMain.SelectLanguage(MenuItem: TMenuItem);
var
  I : integer;
  Language : string;
begin
  I := miLanguage.Count-1;
  while ( I >= 0 ) do
  begin
    if ( miLanguage.Items[I] = MenuItem ) then
    begin
      miLanguage.Items[I].Checked:=true;
      if ( miLanguage.Items[I] = miLaItaliano ) then
        Language := 'it'
      else if ( miLanguage.Items[I] = miLaPortuguese ) then
      Language := 'pt_PT'
      else if ( miLanguage.Items[I] = miLaFrancais ) then
      Language := 'fr_FR'
      else
        // The default in the case of not already handled language
        Language := 'en';

      SetDefaultLang( Language );
      BuildTitle;
    end
    else
      miLanguage.Items[I].Checked:=false;
    Dec(I);
  end;
end;

procedure TfrmMain.BuildTitle;
begin
  Caption := rsAboutTitle + ' - ' + rsAboutBrief;
end;


procedure TfrmMain.EnableDisableDatabaseRelativeFunction(
  const EnableThem: boolean);
var
  I : integer;
begin
  // It enables or disables (according to the EnableThem parameter) all the
  // functions that needs an established database connection to work properly
  // In other words, all the commands except the language selection, information
  // and database connection
  for I := 1 to MainActionList.ActionCount do
  begin
    (MainActionList.Actions[I-1] as TAction).Enabled :=
      EnableThem;
  end;
  if ( not EnableThem ) then
  Begin
    // I enable some standard features
    actDbConnect.Enabled:=true;
    actHeAbout.Enabled:=true;
    actQuit.Enabled:=true;
  end;
end;

function TfrmMain.SelectPatient(var PatientID: LongInt; var PatientName: string
  ): boolean;
begin
  result := false;
  with TfrmComboBoxPatient.Create( Application ) do
  begin
    if ShowModal=mrOK then
    begin
      PatientID:= Patient__ID;
      PatientName := Patient__Name;
      result := true;
    end;
    Release;
  end;
end;

function TfrmMain.SelectPerson(var PersonID: LongInt; var PersonName: string
  ): boolean;
begin
  result := false;
  with TfrmComboBoxPerson.Create( Application ) do
  begin
    if ShowModal=mrOK then
    begin
      PersonID:= Person__ID;
      PersonName := Person__Name;
      result := true;
    end;
    Release;
  end;
end;

end.