dicom.pas

用Delphi做的读取医学图片的控件及代码

unit dicom;
// Limitations
//- compiling for Pascal other than Delphi 2.0+: gDynStr gets VERY big, e.g. not standard Pascal string with maximum size of 256 bytes
//- write_dicom: currently only writes little endian, data should be little_endian
//- [e-mail]
//- rev 7 has disk caching: speeds DCOM header reading
//- rev 8 can read interfile format images
//- rev 9 Siemens Magnetom, GELX
//- rev 10 ECAT6/7, DICOM runlengthencoding[RLE] parameters
//  *NOTE: If your software does not decompress images, check to make sure that
//         DICOMdata.CompressOffset = 0
//        This value will be > 0 for any DICOM/GE/Elscint file with compressed image data
interface
{$IFDEF LINUX}
uses
  SysUtils,QDialogs,QControls,define_types,classes;
{$ELSE}
uses
  SysUtils,Dialogs,Controls,define_types,classes {tstrings};
{$ENDIF}
{$H+} //use long, dynamic strings
const
kCR = chr (13);//PC EOLN
kA = ord('A');
kB = ord('B');
kC = ord('C');
kD = ord('D');
kE = ord('E');
kF = ord('F');
kH = ord('H');
kI = ord('I');
kL = ord('L');
kM = ord('M');
kN = ord('N');                                   
kO = ord('O');
kP = ord('P');
kQ = ord('Q');
kS = ord('S');
kT = ord('T');
kU = ord('U');
kW = ord('W');
procedure write_vista (lAnzFileStrs: Tstrings);
procedure read_afni_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string; var lRotation1,lRotation2,lRotation3: integer);
procedure read_ecat_data(var lDICOMdata: DICOMdata;lVerboseRead,lReadECAToffsetTables:boolean; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string);
  {- if lReadECAToffsetTables is true, you will need to freemem gECAT_slice_table if it is filled: see example}
  {-for analysis, you should also take scaling and calibration factors into account!}
procedure read_siemens_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string);
//procedure write_slc (lFileName: string; var pDICOMdata: DICOMdata;var lSz: integer; lDICOM3: boolean);
procedure read_ge_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string);
procedure read_interfile_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string);
procedure read_vista_data(lConvertToAnalyze,lAnonymize: boolean; var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string);
procedure read_voxbo_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string);
procedure read_PAR_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string; lReadOffsetTables: boolean; var lOffset_pos_table: LongIntp; var lOffsetTableEntries: integer; lReadVaryingScaleFactors: boolean; var lVaryingScaleFactors_table,lVaryingIntercept_table: Singlep; var lVaryingScaleFactorsTableEntries, lnum4Ddatasets: integer);
procedure read_VFF_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string);
procedure read_picker_data(lVerboseRead: boolean; var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string);
procedure write_dicom (lFileName: string; var lInputDICOMdata: DICOMdata;var lSz: integer; lDICOM3: boolean);
procedure read_tiff_data(var lDICOMdata: DICOMdata; var lReadOffsets,lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string);
procedure read_dicom_data(lReadJPEGtables,lVerboseRead,lAutoDECAT7,lReadECAToffsetTables,lAutodetectInterfile,lAutoDetectGenesis,lReadColorTables: boolean; var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string);
procedure clear_dicom_data (var lDicomdata:Dicomdata);
  {- if lReadECAToffsetTables is true, you will need to freemem gECAT_slice_table if it is filled: see example}
  {- if lReadColorTables is true, you will need to freemem red_table/green_table/blue_table if it is filled: see example}
procedure write_interfile_hdr (lHdrName,lImgName: string; var pDICOMdata: DICOMdata);
var
  gSizeMMWarningShown : boolean = false;
  //gAnonymize: boolean = true;
  gECATJPEG_table_entries: integer = 0;
  gECATJPEG_pos_table,gECATJPEG_size_table : LongIntP;
  red_table_size : Integer = 0;
  green_table_size : Integer = 0;
  blue_table_size : Integer = 0;
  red_table   : ByteP;
  green_table : ByteP;
  blue_table  : ByteP;
implementation
procedure write_interfile_hdr (lHdrName,lImgName: string; var pDICOMdata: DICOMdata);
var
   lTextFile: textfile;
//creates interfile text header "lHdrName" that points to the image "lImgName")
//pass pDICOMdata that contains the relevant image details
begin
              if (pDICOMdata.Allocbits_per_pixel <> 8) and (pDICOMdata.Allocbits_per_pixel <> 16) then begin
                  showmessage('Can only create Interfile headers for 8 or 16 bit images.');
              end;
              if  fileexists(lHdrName) then begin
                 showmessage('The file '+lHdrName+' already exists. Unable to create Interfile format header.');
                 exit;
              end;
              assignfile(lTextFile,lHdrName);
              rewrite(lTextFile);
              writeln(lTextFile,'!INTERFILE :=');
              writeln(lTextFile,'!imaging modality:=nucmed');
              writeln(lTextFile,'!originating system:=MS-DOS');
              writeln(lTextFile,'!version of keys:=3.3');
              writeln(lTextFile,'conversion program:=DICOMxv');
              writeln(lTextFile,'program author:=C. Rorden');
              writeln(lTextFile,'!GENERAL DATA:=');
              writeln(lTextFile,'!data offset in bytes:='+inttostr(pDicomData.imagestart));
              writeln(lTextFile,'!name of data file:='+extractfilename(lImgName));
              writeln(lTextFile,'data compression:=none');
              writeln(lTextFile,'data encode:=none');
              writeln(lTextFile,'!GENERAL IMAGE DATA :=');
              if pDICOMdata.little_endian = 1 then
                  writeln(lTextFile,'imagedata byte order := LITTLEENDIAN')
              else
                  writeln(lTextFile,'imagedata byte order := BIGENDIAN');
              writeln(lTextFile,'!matrix size [1] :='+inttostr(pDICOMdata.XYZdim[1]));
              writeln(lTextFile,'!matrix size [2] :='+inttostr(pDICOMdata.XYZdim[2]));
              writeln(lTextFile,'!matrix size [3] :='+inttostr(pDICOMdata.XYZdim[3]));
              if pDICOMdata.Allocbits_per_pixel = 8 then begin
                 writeln(lTextFile,'!number format := unsigned integer');
                 writeln(lTextFile,'!number of bytes per pixel := 1');
              end else begin
                 writeln(lTextFile,'!number format := signed integer');
                 writeln(lTextFile,'!number of bytes per pixel := 2');
              end;
              writeln(lTextFile,'scaling factor (mm/pixel) [1] :='+floattostrf(pDicomData.XYZmm[1],ffFixed,7,7));
              writeln(lTextFile,'scaling factor (mm/pixel) [2] :='+floattostrf(pDicomData.XYZmm[2],ffFixed,7,7));
              writeln(lTextFile,'scaling factor (mm/pixel) [3] :='+floattostrf(pDicomData.XYZmm[3],ffFixed,7,7));
              writeln(lTextFile,'!number of slices :='+inttostr(pDICOMdata.XYZdim[3]));
              writeln(lTextFile,'slice thickness := '+floattostrf(pDicomData.XYZmm[3],ffFixed,7,7));
              writeln(lTextFile,'!END OF INTERFILE:=');
              closefile(lTextFile);
end; (**)
procedure clear_dicom_data (var lDicomdata:Dicomdata);
begin
  red_table_size   := 0;
  green_table_size := 0;
  blue_table_size  := 0;
  red_table        := nil;
  green_table      := nil;
  blue_table       := nil;
  with lDicomData do begin
       PatientIDInt := 0;
       PatientName := 'NO NAME';
       PatientID := 'NO ID';
       StudyDate := '';
       AcqTime := '';
       ImgTime := '';
        TR := 0;
        TE := 0;
        kV := 0;
        mA := 0;
          Rotate180deg := false;
        MaxIntensity := 0;
        MinIntensity := 0;
        MinIntensitySet := false;
        ElscintCompress := false;
        Float := false;
        ImageNum := 0;
        SiemensInterleaved := 2; //0=no,1=yes,2=undefined
        SiemensSlices := 0;
        SiemensMosaicX := 1;
        SiemensMosaicY := 1;
        IntenScale := 1;
        intenIntercept := 0;
        SeriesNum := 1;
        AcquNum := 0;
        ImageNum := 1;
        Accession := 1;
        PlanarConfig:= 0; //only used in RGB values
        runlengthencoding := false;
        CompressSz := 0;
        CompressOffset := 0;
        SamplesPerPixel := 1;
        WindowCenter := 0;
        WindowWidth := 0;
        monochrome := 2; {most common}
        XYZmm[1] := 1;
        XYZmm[2] := 1;
        XYZmm[3] := 1;
        XYZdim[1] := 1;
        XYZdim[2] := 1;
        XYZdim[3] := 1;
        XYZdim[4] := 1;
        lDicomData.XYZori[1] := 0;
        lDicomData.XYZori[2] := 0;
        lDicomData.XYZori[3] := 0;
        ImageStart := 0;
        Little_Endian := 0;
        Allocbits_per_pixel := 16;//bits
        Storedbits_per_pixel:= Allocbits_per_pixel;
        GenesisCpt := false;
        JPEGlosslesscpt := false;
        JPEGlossycpt := false;
        GenesisPackHdr := 0;
        StudyDatePos := 0;
        NamePos := 0;
        RLEredOffset:= 0;
        RLEgreenOffset:= 0;
        RLEblueOffset:= 0;
        RLEredSz:= 0;
        RLEgreenSz:= 0;
        RLEblueSz:= 0;
        Spacing:=0;
        Location:=0;
        //Frames:=1;
        Modality:='MR';
        serietag:='';
  end;
end;

procedure read_ecat_data(var lDICOMdata: DICOMdata;lVerboseRead,lReadECAToffsetTables:boolean; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string);
label
  121,539;
const
     kMaxnSLices = 6000;
     kStrSz = 40;
var
   lLongRA: LongIntp;
   lECAT7sigUpcase,lECAT7sig  : array [0..6] of Char;
  lParse,lSPos,lFPos{,lScomplement},lF,lS,lYear,lFrames,lVox,lHlfVox,lJ,lPass,lVolume,lNextDirectory,lSlice,lSliceSz,lVoxelType,lPos,lEntry,
  lSlicePos,lLongRApos,lLongRAsz,{lSingleRApos,lSingleRAsz,}{lMatri,}lX,lY,lZ,lCacheSz,lImgSz,lTransferred,lSubHeadStart,lMatrixStart,lMatrixEnd,lInt,lInt2,lInt3,lINt4,n,filesz: LongInt;
  lPlanes,lGates,lAqcType,lFileType,lI,lWord, lWord22: word;
  lXmm,lYmm,lZmm,lCalibrationFactor, lQuantScale: real;
  FP: file;
  lCreateTable,lSwapBytes,lMR,lECAT6: boolean;
function xWord(lPos: longint): word;
var
s: word;
begin
     seek(fp,lPos);
     BlockRead(fp, s, 2, n);
     if lSwapBytes then
        result := swap(s)
     else result := s; //assign address of s to inguy
end;

function swap32i(lPos: longint): Longint;
type
  swaptype = packed record
    case byte of
      0:(Word1,Word2 : word); //word is 16 bit
      1:(Long:LongInt);
  end;
  swaptypep = ^swaptype;
var
   s : LongInt;
  inguy:swaptypep;
  outguy:swaptype;
begin
     seek(fp,lPos);
  BlockRead(fp, s, 4, n);
  inguy := @s; //assign address of s to inguy
  if not lSwapBytes then begin
      result := inguy.long;
      exit;
  end;
  outguy.Word1 := swap(inguy^.Word2);
  outguy.Word2 := swap(inguy^.Word1);
  swap32i:=outguy.Long;
end;
function StrRead (lPos, lSz: longint) : string;
var
   I: integer;
   tx  : array [1..kStrSz] of Char;
begin
  result := '';
  if lSz > kStrSz then exit;
  seek(fp, lPos{-1});
  BlockRead(fp, tx, lSz*SizeOf(Char), n);
  for I := 1 to (lSz-1) do begin
      if tx[I] in [' ','[',']','+','-','.','\','~','/', '0'..'9','a'..'z','A'..'Z'] then
      {if (tx[I] <> kCR) and (tx[I] <> UNIXeoln) then}
      result := result + tx[I];
  end;
end;
function fswap4r (lPos: longint): single;
type
  swaptype = packed record
    case byte of
      0:(Word1,Word2 : word); //word is 16 bit
      1:(float:single);
  end;
  swaptypep = ^swaptype;
var
   s:single;
  inguy:swaptypep;
  outguy:swaptype;
begin
     seek(fp,lPos);
     if not lSwapBytes then begin
        BlockRead(fp, result, 4, n);
        exit;
     end;
  BlockRead(fp, s, 4, n);
  inguy := @s; //assign address of s to inguy
  outguy.Word1 := swap(inguy^.Word2);
  outguy.Word2 := swap(inguy^.Word1);
  fswap4r:=outguy.float;
end;
function fvax4r (lPos: longint): single;
type
  swaptype = packed record
    case byte of
      0:(Word1,Word2 : word); //word is 16 bit
      1:(float:single);
  end;
  swaptypep = ^swaptype;
var
   s:single;
   lT1,lT2 : word;
  inguy:swaptypep;
begin
     seek(fp,lPos);
     BlockRead(fp, s, 4, n);
     inguy := @s;
     if (inguy.Word1 =0) and (inguy.Word2 = 0) then begin
        result := 0;
        exit;
     end;