unit UMainSCPDemo;

interface

{$WARN SYMBOL_PLATFORM OFF}
{$WARN UNIT_PLATFORM OFF}

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, DicomObjects8_TLB, Vcl.OleServer,
  RzShellDialogs, Vcl.StdCtrls, Vcl.ExtCtrls, ipwcore, ipwipdaemon, DOWrappers;

type
  TfrmMain = class(TForm)
    Panel1: TPanel;
    Label1: TLabel;
    edtOutputFolder: TButtonedEdit;
    memLog: TMemo;
    RzSelectFolderDialog1: TRzSelectFolderDialog;
    SCPStore: TDicomServer;
    btnUnlisten: TButton;
    btnListen: TButton;
    edtListeningPort: TEdit;
    Label7: TLabel;
    procedure SCPStoreActionComplete(ASender: TObject;
      const DCMConnection: IDicomConnection; const Action: WideString;
      Tag: OleVariant; Success: WordBool; const ErrorMessage: WideString);
    procedure SCPStoreAssociationClosed(ASender: TObject;
      const Connection: IDicomConnection);
    procedure SCPStoreAssociationRequest(ASender: TObject;
      const Connection: IDicomConnection; var isOK: WordBool);
    procedure SCPStoreInstanceReceived(ASender: TObject;
      const DCMConnection: IDicomConnection; const dataset: IDicomDataSet);
    procedure SCPStoreVerifyReceived(ASender: TObject; var Status: Integer);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnUnlistenClick(Sender: TObject);
    procedure btnListenClick(Sender: TObject);
    procedure SCPStoreInfoMessage(ASender: TObject; InfoType: SmallInt;
      const Text: WideString);
  private
    { Private declarations }
    FDcmServerWrapper: TDicomServerWrapper;
    procedure LogEvent(const msg: string);
    procedure LogError(const msg: string);
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.dfm}

procedure TfrmMain.btnListenClick(Sender: TObject);
begin
  FDcmServerWrapper.Listen(StrToIntDef(edtListeningPort.Text, 104));
end;

procedure TfrmMain.btnUnlistenClick(Sender: TObject);
begin
  FDcmServerWrapper.Unlisten(StrToIntDef(edtListeningPort.Text, 104));
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  FDcmServerWrapper := TDicomServerWrapper.Create(SCPStore);
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  FDcmServerWrapper.Free;
end;

procedure TfrmMain.LogError(const msg: string);
begin
  memLog.Lines.Add(FormatDateTime('hh:nn:ss: ERROR: ', Now) + msg);
end;

procedure TfrmMain.LogEvent(const msg: string);
begin
  memLog.Lines.Add(FormatDateTime('hh:nn:ss:', Now) + msg);
end;

procedure TfrmMain.SCPStoreActionComplete(ASender: TObject;
  const DCMConnection: IDicomConnection; const Action: WideString; Tag: OleVariant;
  Success: WordBool; const ErrorMessage: WideString);
var
  Wrapper: TDicomConnectionWrapper;
begin
  Wrapper := LookupWrapper(DCMConnection);
  if (Action = 'SaveImage') then
  begin
    if Success then
    begin
      LogEvent('Assoc#' + IntToStr(Wrapper.Association) + ': Image '+Wrapper.Tag+' saved');
      Wrapper.Tag := '';
      try
        Wrapper.SendStatus(0);
      except
        LogError('Unable to return success status to sender');
      end;
    end
    else
    begin
      LogError('Assoc#' + IntToStr(Wrapper.Association) + ': Error saving image '+Wrapper.Tag);
      LogError('Error message: ' + ErrorMessage);
      Wrapper.Tag := '';
      Wrapper.SendStatus($A700);
    end;
  end
  else if (Action = 'SendStatus') then
  begin
    try
      if Wrapper.Tag = '' then
        Wrapper.Close;
    except
      LogError('Assoc#' + IntToStr(Wrapper.Association) + ': Unable to close connection; may be due to prior errors on this connection');
    end;
  end;
  // we shouldn't get any actions other than those listed above
end;

procedure TfrmMain.SCPStoreAssociationClosed(ASender: TObject;
  const Connection: IDicomConnection);
var
  Wrapper: TDicomConnectionWrapper;
begin
  Wrapper := LookupWrapper(Connection);
  LogEvent('Association #' + IntToStr(Wrapper.Association) + ' closed (wrapper)');
end;

procedure TfrmMain.SCPStoreAssociationRequest(ASender: TObject;
  const Connection: IDicomConnection; var isOK: WordBool);
var
  Wrapper: TDicomConnectionWrapper;
begin
  Wrapper := LookupWrapper(Connection);
  LogEvent('Association #' + IntToStr(Wrapper.Association) + ' requested by '+Trim(Wrapper.CallingAET)
      +' on address '+Trim(Wrapper.RemoteIP) + ', port ' + IntToStr(Wrapper.LocalPort) + ' to local IP ' + Wrapper.LocalIP);
  isOK := true;
end;

procedure TfrmMain.SCPStoreInfoMessage(ASender: TObject; InfoType: SmallInt;
  const Text: WideString);
begin
  if InfoType <= 3 then
    LogEvent(Text);
end;

procedure TfrmMain.SCPStoreInstanceReceived(ASender: TObject;
  const DCMConnection: IDicomConnection; const dataset: IDicomDataSet);
var
  i: Integer;
  UID, dcmFN, Syntax, Modality: string;
  Wrapper: TDicomConnectionWrapper;
begin
  Wrapper := LookupWrapper(DCMConnection);
  try
    Modality := DataSet.Attributes.Item[$0008,$0060].Value;
  except
    Modality := '';
  end;
  UID := dataset.InstanceUID;
  Syntax := dataset.ReceivedSyntax;
  LogEvent('Syntax: ' + Syntax);
  if length(Syntax) = 0 then
    Syntax := 'Null';

  //create unique filename
  dcmFN := Modality+'.'+UID+'.dcm';
  i := 0;
  while (FileExists(IncludeTrailingPathDelimiter(edtOutputFolder.Text) + dcmFN)) do
  begin
    Inc(i,1);
    dcmFN := Modality + '.' + UID + '.' + IntToStr(i) + '.dcm';
  end; // while file exists
  Wrapper.Tag := dcmFN;
  try
    dataset.WriteFile(IncludeTrailingPathDelimiter(edtOutputFolder.Text)+dcmFN,True,Syntax,NULL);
    LogEvent('Assoc#' + IntToStr(Wrapper.Association) + ': Image '+Wrapper.Tag+' saved');
    Wrapper.Tag := '';
    try
      Wrapper.SendStatus(0);
    except
      LogError('Unable to return success status to sender');
    end;
  except
    on E: Exception do
    begin
      LogError('Assoc#' + IntToStr(Wrapper.Association) + ': Error saving image '+Wrapper.Tag);
      LogError('Error message: ' + E.Message);
      Wrapper.Tag := '';
      Wrapper.SendStatus($A700);
    end;
  end;
end;

procedure TfrmMain.SCPStoreVerifyReceived(ASender: TObject;
  var Status: Integer);
begin
  Status := 0;
end;

end.
