home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 October / Chip_2001-10_cd1.bin / zkuste / delphi / navody / DICOMSRC.ZIP / dicom.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-07-09  |  136.8 KB  |  3,404 lines
  1. unit DICOM;
  2. // Limitations
  3. //- compiling for Pascal other than Delphi 2.0+: gDynStr gets VERY big
  4. //- does not extract encapsulated/compressed images
  5. //- write_dicom: currently only writes little endian, data should be little_endian
  6. //- chris.rorden@nottingham.ac.uk
  7. //- rev 7 has disk caching: speeds DCOM header reading
  8. //- rev 8 can read interfile format images
  9. //- rev 9 Siemens Magnetom, GELX
  10. //- rev 10 EC*T6/7, DICOM runlengthencoding[RLE] parameters
  11. //  *NOTE: RLE compressed DICOM images no longer generate ImgFormatOK errors:
  12. //   if your software can not read RLE images, then refuse to open images which
  13. //   return DICOMdata.CompressOffset > 0
  14. interface
  15. uses
  16.   SysUtils,Dialogs,Controls;
  17. {$H+} //use long, dynamic strings
  18. type
  19. ByteRA = array [1..1] of byte;
  20. Bytep = ^ByteRA;
  21. WordRA = array [1..1] of Word;
  22. Wordp = ^WordRA;
  23. LongRA = array [1..1] of LongInt;
  24. Longp = ^LongRA;
  25. {SingleRA = array [1..1] of Single;
  26. Singlep = ^SingleRA;}
  27.   DICOMdata = record
  28.    XYZdim: array [1..4] of integer;   //4=volume, eg time: some EC*T7 images
  29.    XYZori: array [1..3] of integer;
  30.    XYZmm: array [1..3] of double;
  31.    Float,RunLengthEncoding,GenesisCpt,JPEGlosslessCpt,JPEGlossyCpt,ElscintCompress: boolean;
  32.    IntenScale: single;
  33.    CompressSz,CompressOffset,AcquNum,ImageNum,Monochrome,SamplesPerPixel,PlanarConfig,ImageStart,little_endian,
  34.    Allocbits_per_pixel,Storedbits_per_pixel,ImageSz,
  35.    WindowWidth,WindowCenter,GenesisPackHdr, NamePos,StudyDatePos: integer;
  36.   end;
  37.     int32  = LongInt;
  38.     uint32 = Cardinal;
  39.     int16  = SmallInt;
  40.     uint16 = Word;
  41.     int8   = ShortInt;
  42.     uint8  = Byte;
  43. const
  44. kCR = chr (13);//PC EOLN
  45. kA = ord('A');
  46. kB = ord('B');
  47. kC = ord('C');
  48. kD = ord('D');
  49. kE = ord('E');
  50. kF = ord('F');
  51. kH = ord('H');
  52. kI = ord('I');
  53. kL = ord('L');
  54. kM = ord('M');
  55. kN = ord('N');
  56. kO = ord('O');
  57. kP = ord('P');
  58. kQ = ord('Q');
  59. kS = ord('S');
  60. kT = ord('T');
  61. kU = ord('U');
  62. kW = ord('W');
  63. procedure read_ecat_data(var lDICOMdata: DICOMdata;lVerboseRead,lReadECAToffsetTables:boolean; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string);
  64.   {- if lReadECAToffsetTables is true, you will need to freemem gECAT_slice_table if it is filled: see example}
  65.  {-for analysis, you should also take scaling and calibration factors into account!}
  66. procedure read_siemens_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string);
  67. procedure write_slc (lFileName: string; var pDICOMdata: DICOMdata;var lSz: integer; lDICOM3: boolean);
  68. procedure read_ge_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string);
  69. procedure read_interfile_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string);
  70. procedure read_PAR_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string);
  71. procedure read_picker_data(lVerboseRead: boolean; var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string);
  72. procedure write_dicom (lFileName: string; var pDICOMdata: DICOMdata;var lSz: integer; lDICOM3: boolean);
  73. 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);
  74. procedure clear_dicom_data (var lDicomdata:Dicomdata);
  75.   {- if lReadECAToffsetTables is true, you will need to freemem gECAT_slice_table if it is filled: see example}
  76.   {- if lReadColorTables is true, you will need to freemem red_table/green_table/blue_table if it is filled: see example}
  77. procedure write_interfile_hdr (lHdrName,lImgName: string; var pDICOMdata: DICOMdata);
  78. var
  79.   gSizeMMWarningShown : boolean = false;
  80.   gECATJPEG_table_entries: integer = 0;
  81.   gECATJPEG_pos_table,gECATJPEG_size_table : LongP;
  82.   red_table_size : Integer = 0;
  83.   green_table_size : Integer = 0;
  84.   blue_table_size : Integer = 0;
  85.   red_table   : ByteP;
  86.   green_table : ByteP;
  87.   blue_table  : ByteP;
  88. implementation
  89. procedure write_interfile_hdr (lHdrName,lImgName: string; var pDICOMdata: DICOMdata);
  90. var
  91.    lTextFile: textfile;
  92. //creates interfile text header "lHdrName" that points to the image "lImgName")
  93. //pass pDICOMdata that contains the relevant image details
  94. begin
  95.               if (pDICOMdata.Allocbits_per_pixel <> 8) and (pDICOMdata.Allocbits_per_pixel <> 16) then begin
  96.                   showmessage('Can only create Interfile headers for 8 or 16 bit images.');
  97.               end;
  98.               if  fileexists(lHdrName) then begin
  99.                  showmessage('The file '+lHdrName+' already exists. Unable to create Interfile format header.');
  100.                  exit;
  101.               end;
  102.               assignfile(lTextFile,lHdrName);
  103.               rewrite(lTextFile);
  104.               writeln(lTextFile,'!INTERFILE :=');
  105.               writeln(lTextFile,'!imaging modality:=nucmed');
  106.               writeln(lTextFile,'!originating system:=MS-DOS');
  107.               writeln(lTextFile,'!version of keys:=3.3');
  108.               writeln(lTextFile,'conversion program:=DICOMxv');
  109.               writeln(lTextFile,'program author:=C. Rorden');
  110.               writeln(lTextFile,'!GENERAL DATA:=');
  111.               writeln(lTextFile,'!data offset in bytes:='+inttostr(pDicomData.imagestart));
  112.               writeln(lTextFile,'!name of data file:='+extractfilename(lImgName));
  113.               writeln(lTextFile,'data compression:=none');
  114.               writeln(lTextFile,'data encode:=none');
  115.               writeln(lTextFile,'!GENERAL IMAGE DATA :=');
  116.               if pDICOMdata.little_endian = 1 then
  117.                   writeln(lTextFile,'imagedata byte order := LITTLEENDIAN')
  118.               else
  119.                   writeln(lTextFile,'imagedata byte order := BIGENDIAN');
  120.               writeln(lTextFile,'!matrix size [1] :='+inttostr(pDICOMdata.XYZdim[1]));
  121.               writeln(lTextFile,'!matrix size [2] :='+inttostr(pDICOMdata.XYZdim[2]));
  122.               writeln(lTextFile,'!matrix size [3] :='+inttostr(pDICOMdata.XYZdim[3]));
  123.               if pDICOMdata.Allocbits_per_pixel = 8 then begin
  124.                  writeln(lTextFile,'!number format := unsigned integer');
  125.                  writeln(lTextFile,'!number of bytes per pixel := 1');
  126.               end else begin
  127.                  writeln(lTextFile,'!number format := signed integer');
  128.                  writeln(lTextFile,'!number of bytes per pixel := 2');
  129.               end;
  130.               writeln(lTextFile,'scaling factor (mm/pixel) [1] :='+floattostrf(pDicomData.XYZmm[1],ffFixed,7,7));
  131.               writeln(lTextFile,'scaling factor (mm/pixel) [2] :='+floattostrf(pDicomData.XYZmm[2],ffFixed,7,7));
  132.               writeln(lTextFile,'scaling factor (mm/pixel) [3] :='+floattostrf(pDicomData.XYZmm[3],ffFixed,7,7));
  133.               writeln(lTextFile,'!number of slices :='+inttostr(pDICOMdata.XYZdim[3]));
  134.               writeln(lTextFile,'slice thickness := '+floattostrf(pDicomData.XYZmm[3],ffFixed,7,7));
  135.               writeln(lTextFile,'!END OF INTERFILE:=');
  136.               closefile(lTextFile);
  137. end; (**)
  138. procedure clear_dicom_data (var lDicomdata:Dicomdata);
  139. begin
  140.   red_table_size   := 0;
  141.   green_table_size := 0;
  142.   blue_table_size  := 0;
  143.   red_table        := nil;
  144.   green_table      := nil;
  145.   blue_table       := nil;
  146.   with lDicomData do begin
  147.         ElscintCompress := false;
  148.         Float := false;
  149.         ImageNum := 0;
  150.         IntenScale := 1;
  151.         AcquNum := 0;
  152.         PlanarConfig:= 1; //only used in RGB values
  153.         runlengthencoding := false;
  154.         CompressSz := 0;
  155.         CompressOffset := 0;
  156.         SamplesPerPixel := 1;
  157.         WindowCenter := 0;
  158.         WindowWidth := 0;
  159.         monochrome := 2; {most common}
  160.         XYZmm[1] := 1;
  161.         XYZmm[2] := 1;
  162.         XYZmm[3] := 1;
  163.         XYZdim[1] := 1;
  164.         XYZdim[2] := 1;
  165.         XYZdim[3] := 1;
  166.         XYZdim[4] := 1;
  167.         ImageStart := 0;
  168.         Little_Endian := 0;
  169.         Allocbits_per_pixel := 16;//bits
  170.         Storedbits_per_pixel:= Allocbits_per_pixel;
  171.         GenesisCpt := false;
  172.         JPEGlosslesscpt := false;
  173.         JPEGlossycpt := false;
  174.         GenesisPackHdr := 0;
  175.         StudyDatePos := 0;
  176.         NamePos := 0;
  177.   end;
  178. end;
  179.  
  180. procedure read_ecat_data(var lDICOMdata: DICOMdata;lVerboseRead,lReadECAToffsetTables:boolean; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string);
  181. label
  182.   121,539;
  183. const
  184.      kMaxnSLices = 6000;
  185.      kStrSz = 40;
  186. var
  187.    lLongRA: Longp;
  188.    lECAT7sigUpcase,lECAT7sig  : array [0..6] of Char;
  189.   lParse,lSPos,lFPos{,lScomplement},lF,lS,lYear,lFrames,lVox,lHlfVox,lJ,lPass,lVolume,lNextDirectory,lSlice,lSliceSz,lVoxelType,lPos,lEntry,
  190.   lSlicePos,lLongRApos,lLongRAsz,{lSingleRApos,lSingleRAsz,}{lMatri,}lX,lY,lZ,lCacheSz,lImgSz,lTransferred,lSubHeadStart,lMatrixStart,lMatrixEnd,lInt,lInt2,lInt3,lINt4,n,filesz: LongInt;
  191.   lPlanes,lGates,lAqcType,lFileType,lI,lWord, lWord22: word;
  192.   lXmm,lYmm,lZmm,lCalibrationFactor, lQuantScale: real;
  193.   FP: file;
  194.   lCreateTable,lSwapBytes,lMR,lECAT6: boolean;
  195. function xWord(lPos: longint): word;
  196. var
  197. s: word;
  198. begin
  199.      seek(fp,lPos);
  200.      BlockRead(fp, s, 2, n);
  201.      if lSwapBytes then
  202.         result := swap(s)
  203.      else result := s; //assign address of s to inguy
  204. end;
  205.  
  206. function swap32i(lPos: longint): Longint;
  207. type
  208.   swaptype = packed record
  209.     case byte of
  210.       0:(Word1,Word2 : word); //word is 16 bit
  211.       1:(Long:LongInt);
  212.   end;
  213.   swaptypep = ^swaptype;
  214. var
  215.    s : LongInt;
  216.   inguy:swaptypep;
  217.   outguy:swaptype;
  218. begin
  219.      seek(fp,lPos);
  220.   BlockRead(fp, s, 4, n);
  221.   inguy := @s; //assign address of s to inguy
  222.   if not lSwapBytes then begin
  223.       result := inguy.long;
  224.       exit;
  225.   end;
  226.   outguy.Word1 := swap(inguy^.Word2);
  227.   outguy.Word2 := swap(inguy^.Word1);
  228.   swap32i:=outguy.Long;
  229. end;
  230. function StrRead (lPos, lSz: longint) : string;
  231. var
  232.    I: integer;
  233.    tx  : array [1..kStrSz] of Char;
  234. begin
  235.   result := '';
  236.   if lSz > kStrSz then exit;
  237.   seek(fp, lPos{-1});
  238.   BlockRead(fp, tx, lSz*SizeOf(Char), n);
  239.   for I := 1 to (lSz-1) do begin
  240.       if tx[I] in [' ','[',']','+','-','.','\','~','/', '0'..'9','a'..'z','A'..'Z'] then
  241.       {if (tx[I] <> kCR) and (tx[I] <> UNIXeoln) then}
  242.       result := result + tx[I];
  243.   end;
  244. end;
  245. function fswap4r (lPos: longint): single;
  246. type
  247.   swaptype = packed record
  248.     case byte of
  249.       0:(Word1,Word2 : word); //word is 16 bit
  250.       1:(float:single);
  251.   end;
  252.   swaptypep = ^swaptype;
  253. var
  254.    s:single;
  255.   inguy:swaptypep;
  256.   outguy:swaptype;
  257. begin
  258.      seek(fp,lPos);
  259.      if not lSwapBytes then begin
  260.         BlockRead(fp, result, 4, n);
  261.         exit;
  262.      end;
  263.   BlockRead(fp, s, 4, n);
  264.   inguy := @s; //assign address of s to inguy
  265.   outguy.Word1 := swap(inguy^.Word2);
  266.   outguy.Word2 := swap(inguy^.Word1);
  267.   fswap4r:=outguy.float;
  268. end;
  269. function fvax4r (lPos: longint): single;
  270. type
  271.   swaptype = packed record
  272.     case byte of
  273.       0:(Word1,Word2 : word); //word is 16 bit
  274.       1:(float:single);
  275.   end;
  276.   swaptypep = ^swaptype;
  277. var
  278.    s:single;
  279.    lT1,lT2 : word;
  280.   inguy:swaptypep;
  281. begin
  282.      seek(fp,lPos);
  283.      BlockRead(fp, s, 4, n);
  284.      inguy := @s;
  285.      if (inguy.Word1 =0) and (inguy.Word2 = 0) then begin
  286.         result := 0;
  287.         exit;
  288.      end;
  289.      lT1 := inguy.Word1 and $80FF;
  290.      lT2 := ((inguy.Word1 and $7F00) +$FF00) and $7F00;
  291.      inguy.Word1 := inguy.Word2;
  292.      inguy.Word2 := (lt1+lT2);
  293.      fvax4r:=inguy.float;
  294. end;                    
  295. begin
  296.   Clear_Dicom_Data(lDicomData);
  297.   if gECATJPEG_table_entries <> 0 then begin
  298.      freemem (gECATJPEG_pos_table);
  299.      freemem (gECATJPEG_size_table);
  300.      gECATJPEG_table_entries := 0;
  301.   end;
  302.   lHdrOK:= false;
  303.   lQuantScale:= 1;
  304.   lCalibrationFactor := 1;
  305.   lLongRASz := 0;
  306.   lLongRAPos := 0;
  307.   lImageFormatOK := false;
  308.   lVolume := 1;
  309.   if not fileexists(lFileName) then begin
  310.      showmessage('Unable to find the image '+lFileName);
  311.      exit;
  312.   end;
  313.   FileMode := 0; //set to readonly
  314.   AssignFile(fp, lFileName);
  315.   Reset(fp, 1);
  316.   FIleSz := FileSize(fp);
  317.      if filesz < (2048) then begin
  318.         showmessage('This file is to small to be a ECAT format image.');
  319.         goto 539;
  320.      end;
  321.   seek(fp, 0);
  322.   BlockRead(fp, lECAT7Sig, 6*SizeOf(Char){, n});
  323.   for lInt4 := 0 to (5) do begin
  324.       if lECAT7Sig[lInt4] in ['a'..'z','A'..'Z'] then
  325.          lECAT7SigUpCase[lInt4] := upcase(lECAT7Sig[lInt4])
  326.       else
  327.           lECAT7SigUpCase[lInt4] := ' ';
  328.   end;
  329.   if (lECAT7SigUpCase[0]='M') and (lECAT7SigUpCase[1]='A') and (lECAT7SigUpCase[2]='T') and (lECAT7SigUpCase[3]='R') and
  330.   (lECAT7SigUpCase[4]='I') and (lECAT7SigUpCase[5]='X') then
  331.     lECAT6 := false
  332.   else
  333.       lECAT6 := true;
  334.    if lEcat6 then begin
  335.       lSwapBytes := false;
  336.       lFileType := xWord(27*2);
  337.       if lFileType > 255 then lSwapBytes := not lSwapBytes;
  338.       lFileType := xWord(27*2);
  339.       lAqcType := xWord(175*2);
  340.       lPlanes := xWord(188*2);
  341.       lFrames := xword(189*2);
  342.       lGates := xWord(190*2);
  343.       lYear := xWord(70);
  344.       if (lPlanes < 1) or (lFrames < 1) or (lGates < 1) then begin
  345.          case MessageDlg('Warning: one of the planes/frames/gates values is less than 1 ['+inttostr(lPlanes)+'/'+inttostr(lFrames)+'/'+inttostr(lGates)+']. Is this file really ECAT 6 format? Press abort to cancel conversion. ',
  346.              mterror,[mbOK,mbAbort], 0) of
  347.              mrAbort: goto 539;
  348.          end; //case
  349.       end else if (lYear < 1940) or (lYear > 3000) then begin
  350.         case MessageDlg('Warning: the year value appears invlaid ['+inttostr(lYear)+']. Is this file really ECAT 6 format? Press abort to cancel conversion. ',
  351.              mterror,[mbOK,mbAbort], 0) of
  352.              mrAbort: goto 539;
  353.         end; //case
  354.      end;
  355.      if lVerboseRead then begin
  356.         lDynStr :='ECAT6 data';
  357.         lDynStr :=lDynStr+kCR+('Patient Name:'+StrRead(190,32));
  358.         lDynStr :=lDynStr+kCR+('Patient ID:'+StrRead(174,16));
  359.         lDynStr :=lDynStr+kCR+('Study Desc:'+StrRead(318,32));
  360.         lDynStr := lDynStr+kCR+('Facility: '+StrRead(356,20));
  361.         lDynStr := lDynStr+kCR+('Planes: '+inttostr(lPlanes));
  362.         lDynStr := lDynStr+kCR+('Frames: '+inttostr(lFrames));
  363.         lDynStr := lDynStr+kCR+('Gates: '+inttostr(lGates));
  364.         lDynStr := lDynStr+kCR+('Date DD/MM/YY: '+ inttostr(xWord(66))+'/'+inttostr(xWord(68))+'/'+inttostr(lYear));
  365.      end; {show summary}
  366.    end else begin //NOT ECAT6
  367.        lSwapBytes := true;
  368.      lFileType := xWord(50);
  369.      if lFileType > 255 then lSwapBytes := not lSwapBytes;
  370.      lFileType := xWord(50);
  371.      lAqcType := xWord(328);
  372.      lPlanes := xWord(352);
  373.      lFrames := xWord(354);
  374.      lGates := xWord(356);
  375.      lCalibrationFactor := fswap4r(144);
  376.      if {(true) or} (lPlanes < 1) or (lFrames < 1) or (lGates < 1) then begin
  377.         case MessageDlg('Warning: on of the planes/frames/gates values is less than 1 ['+inttostr(lPlanes)+'/'+inttostr(lFrames)+'/'+inttostr(lGates)+']. Is this file really ECAT 7 format? Press abort to cancel conversion. ',
  378.              mterror,[mbOK,mbAbort], 0) of
  379.              mrAbort: goto 539;
  380.         end; //case
  381.      end; //error
  382.      if lVerboseRead then begin
  383.           lDynStr := 'ECAT 7 format';
  384.           lDynStr := lDynStr+kCR+('Serial Number:'+StrRead(52,10));
  385.           lDynStr := lDynStr+kCR+('Patient Name:'+StrRead(182,32));
  386.           lDynStr := lDynStr+kCR+('Patient ID:'+StrRead(166,16));
  387.           lDynStr := lDynStr+kCR+('Study Desc:'+StrRead(296,32));
  388.           lDynStr := lDynStr+kCR+('Facility: '+StrRead(332,20));
  389.           lDynStr := lDynStr+kCR+('Scanner: '+inttostr(xWord(48)));
  390.           lDynStr := lDynStr+kCR+('Planes: '+inttostr(lPlanes));
  391.           lDynStr := lDynStr+kCR+('Frames: '+inttostr(lFrames));
  392.           lDynStr := lDynStr+kCR+('Gates: '+inttostr(lGates));
  393.           lDynStr := lDynStr+kCR+'Calibration: '+floattostr(lCalibrationFactor);
  394.      end; {lShow Summary}
  395.    end; //lECAT7
  396. if not (lFileType in [1,2,3,4,7]) then begin
  397.    Showmessage('This software does not recognize the ECAT file type. Selected filetype: '+inttostr(lFileType));
  398.    goto 539;
  399. end;
  400. lVoxelType := 2;
  401. if lFileType = 3 then lVoxelType := 4;
  402. if lVerboseRead then begin
  403.   case lFileType of
  404.     1: lDynStr := lDynStr+kCR+('File type: Scan File');
  405.     2: lDynStr := lDynStr+kCR+('File type: Image File'); //x
  406.     3: lDynStr := lDynStr+kCR+('File type: Attn File');
  407.     4: lDynStr := lDynStr+kCR+('File type: Norm File');
  408.     7: lDynStr := lDynStr+kCR+('File type: Volume 16'); //x
  409.   end; //lfiletye case
  410.   case lAqcType of
  411.      1:lDynStr := lDynStr+kCR+('Acquisition type: Blank');
  412.      2:lDynStr := lDynStr+kCR+('Acquisition type: Transmission');
  413.      3:lDynStr := lDynStr+kCR+('Acquisition type: Static Emission');
  414.      4:lDynStr := lDynStr+kCR+('Acquisition type: Dynamic Emission');
  415.      5:lDynStr := lDynStr+kCR+('Acquisition type: Gated Emission');
  416.      6:lDynStr := lDynStr+kCR+('Acquisition type: Transmission Rect');
  417.      7:lDynStr := lDynStr+kCR+('Acquisition type: Emission Rect');
  418.      8:lDynStr := lDynStr+kCR+('Acquisition type: Whole Body Transm');
  419.      9:lDynStr := lDynStr+kCR+('Acquisition type: Whole Body Static');
  420.      else lDynStr := lDynStr+kCR+('Acquisition type: Undefined');
  421.   end; //case AqcType
  422. end; //verbose read
  423. if ((lECAT6) and (lFiletype =2)) or ((not lECAT6) and (lFileType=7)) then
  424. else begin
  425.      Showmessage('Unusual ECAT filetype. Please contact the author.');
  426.      goto 539;
  427. end;
  428. lHdrOK:= true;
  429. lImageFormatOK := true;
  430. lLongRASz := kMaxnSlices * sizeof(longint);
  431. getmem(lLongRA,lLongRAsz);
  432. lPos := 512;
  433. //lSingleRASz := kMaxnSlices * sizeof(single);
  434. //getmem(lSingleRA,lSingleRAsz);
  435. //lMatri := 0;
  436. lVolume := 1;
  437. lPass := 0;
  438. 121:
  439.      lEntry := 1;
  440.      lInt := swap32i(lPos);
  441.      lInt2 := swap32i(lPos+4);
  442.    lNextDirectory := lInt2;
  443.    while true do begin
  444.       inc(lEntry);
  445.      lPos := lPos + 16;
  446.      lInt := swap32i(lPos);
  447.      lInt2 := swap32i(lPos+4);
  448.      lInt3 := swap32i(lPos+8);
  449.      lInt4 := swap32i(lPos+12);
  450.      lInt2 := lInt2 - 1;
  451.      lSubHeadStart := lINt2 *512;
  452.      lMatrixStart := ((lInt2) * 512)+512 {add subhead sz};
  453.      lMatrixEnd := lInt3 * 512;
  454.      if  (lInt4 = 1) and (lMatrixStart < FileSz) and (lMatrixEnd <= FileSz) then begin
  455.         if (lFileType= 7) {or (lFileType = 4) } or (lFileType = 2) then begin //Volume of 16-bit integers
  456.            if lEcat6 then begin
  457.                lX := xWord(lSubHeadStart+(66*2));
  458.                lY := xWord(lSubHeadStart+(67*2));
  459.                lZ := 1;//uxWord(lSubHeadStart+8);
  460.                lXmm := 10*fvax4r(lSubHeadStart+(92*2));// fswap4r(lSubHeadStart+(92*2));
  461.                lYmm := lXmm;//read32r(lSubHeadStart+(94*2));
  462.                lZmm := 10 * fvax4r(lSubHeadStart+(94*2));
  463.                lCalibrationFactor :=  fvax4r(lSubHeadStart+(194*2));
  464.                lQuantScale := fvax4r(lSubHeadStart+(86*2));
  465.                if lVerboseRead then
  466.                   lDynStr := lDynStr+kCR+'Plane '+inttostr(lPass+1)+' Calibration/Scale Factor: '+floattostr(lCalibrationFactor)+'/'+floattostr(lQuantScale);
  467.            end else begin
  468.            //02 or 07
  469.                lX := xWord(lSubHeadStart+4);
  470.                lY := xWord(lSubHeadStart+6);
  471.                lZ := xWord(lSubHeadStart+8);
  472.                //if lFileType <> 4 then begin
  473.                lXmm := 10*fswap4r(lSubHeadStart+34);
  474.                lYmm := 10*fswap4r(lSubHeadStart+38);
  475.                lZmm := 10*fswap4r(lSubHeadStart+42);
  476.                lQuantScale := fswap4r(lSubHeadStart+26);
  477.                if lVerboseRead then
  478.                   lDynStr := lDynStr+kCR+'Volume: '+inttostr(lPass+1)+' Scale Factor: '+floattostr(lQuantScale);
  479.                //end; //filetype <> 4
  480.            end;  //ecat7
  481.            if true then begin
  482.            //FileMode := 2; //set to read/write
  483.            inc(lPass);
  484.            lImgSz := lX * lY * lZ * lVoxelType; {2 bytes per voxel}
  485.            lSliceSz := lX * lY * lVoxelType;
  486.            if lZ < 1 then begin
  487.               lHdrOK := false;
  488.               goto 539;
  489.            end;
  490.            lSlicePos := lMatrixStart;
  491.            if ((lECAT6) and (lPass = 1)) or ( (not lECAT6)) then begin
  492.              lDICOMdata.XYZdim[1] := lX;
  493.              lDICOMdata.XYZdim[2] := lY;
  494.              lDICOMdata.XYZdim[3] := lZ;
  495.              lDICOMdata.XYZmm[1] := lXmm;
  496.              lDICOMdata.XYZmm[2] := lYmm;
  497.              lDICOMdata.XYZmm[3] := lZmm;
  498.              case lVoxelType of
  499.                   1: begin
  500.                      Showmessage('Error: 8-bit data not supported [yet]. Please contact the author.');
  501.                      lDicomData.Allocbits_per_pixel := 8;
  502.                      lHdrOK := false;
  503.                      goto 539;
  504.                   end;
  505.                   4: begin
  506.                      Showmessage('Error: 32-bit data not supported [yet]. Please contact the author.');
  507.                      lHdrOK := false;
  508.                      goto 539;
  509.                   end;
  510.                   else begin //16-bit integers
  511.                      lDicomData.Allocbits_per_pixel := 16;
  512.                   end;
  513.              end; {case lVoxelType}
  514.            end else begin //if lECAT6
  515.                if (lDICOMdata.XYZdim[1] <> lX) or (lDICOMdata.XYZdim[2] <> lY) or (lDICOMdata.XYZdim[3] <> lZ) then begin
  516.                   Showmessage('Error: different slices in this volume have different slice sizes. Please contact the author.');
  517.                   lHdrOK := false;
  518.                   goto 539;
  519.                end; //dimensions have changed
  520.                //lSlicePos :=((lMatri-1)*lImgSz);
  521.            end; //ECAT6
  522.            lVox := lSliceSz div 2;
  523.            lHlfVox := lSliceSz div 4;
  524.            for lSlice := 1 to lZ do begin
  525.               if (not lECAT6) then
  526.                  lSlicePos := ((lSlice-1)*lSliceSz)+lMatrixStart;
  527.                if lLongRAPos >= kMaxnSLices then begin
  528.                   lHdrOK := false;
  529.                   goto 539;
  530.                end;
  531.                inc(lLongRAPos);
  532.                lLongRA[lLongRAPos] := lSlicePos;
  533.                {inc(lSingleRAPos);
  534.                if lCalibTableType = 1 then
  535.                   lSingleRA[lSingleRAPos] := lQuantScale
  536.                else
  537.                   lSingleRA[lSingleRAPos] := lCalibrationFactor *lQuantScale;}
  538.  
  539.            end; //slice 1..lZ
  540.            if not lECAT6 then inc(lVolume);
  541.           end; //fileexistsex
  542.         end; //correct filetype
  543.      end; //matrix start/end within filesz
  544.      if (lMatrixStart > FileSz) or (lMatrixEnd >= FileSz) then goto 539;
  545.      if ((lEntry mod 32) = 0) then begin
  546.         if ((lNextDirectory-1)*512) <= lPos then goto 539; //no more directories
  547.         lPos := (lNextDirectory-1)*512;
  548.         goto 121;
  549.      end;  //entry 32
  550.      end ;  //while true
  551. 539:
  552.   CloseFile(fp);
  553.   FileMode := 2; //set to read/write
  554.   lDicomData.XYZdim[3] := lLongRApos;
  555.   lDicomData.XYZdim[4] :=(lVolume);
  556.   if lSwapBytes then
  557.      lDicomData.little_endian := 0
  558.   else
  559.       lDicomData.little_endian := 1;
  560.   if (lLongRApos > 0) and (lHdrOK) then begin
  561.      lDicomData.ImageStart := lLongRA[1];
  562.      lCreateTable := false;
  563.      if (lLongRApos > 1) then begin
  564.         lFPos := lDICOMdata.ImageStart;
  565.         for lS := 2 to lLongRApos do begin
  566.             lFPos := lFPos + lSliceSz;
  567.             if lFPos <> lLongRA[lS] then lCreateTable := true;
  568.         end;
  569.         if (lCreateTable) and (lReadECAToffsetTables) then begin
  570.            gECATJPEG_table_entries := lLongRApos;
  571.            getmem (gECATJPEG_pos_table, gECATJPEG_table_entries*sizeof(longint));
  572.            getmem (gECATJPEG_size_table, gECATJPEG_table_entries*sizeof(longint));
  573.            for lS := 1 to gECATJPEG_table_entries do
  574.                gECATJPEG_pos_table[lS] := lLongRA[lS]
  575.         end else if (lCreateTable) then
  576.             lImageFormatOK := false;  //slices are offset within this file
  577.      end;
  578.      if (lVerboseRead) and (lHdrOK) then begin
  579.         lDynStr :=lDynStr+kCR+('XYZdim:'+inttostr(lX)+'/'+inttostr(lY)+'/'+inttostr(gECATJPEG_table_entries));
  580.         lDynStr :=lDynStr+kCR+('XYZmm: '+floattostrf(lDicomData.XYZmm[1],ffFixed,7,7)+'/'+floattostrf(lDicomData.XYZmm[2],ffFixed,7,7)
  581.         +'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,7,7));
  582.         lDynStr :=lDynStr+kCR+('Bits per voxel: '+inttostr(lDicomData.Storedbits_per_pixel));
  583.         lDynStr :=lDynStr+kCR+('Image Start: '+inttostr(lDicomData.ImageStart));
  584.         if lCreateTable then
  585.            lDynStr :=lDynStr+kCR+('Note: staggered slice offsets');
  586.      end
  587.   end;
  588.   lDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel;
  589.   if lLongRASz > 0 then
  590.      freemem(lLongRA);
  591.   (*if (lSingleRApos > 0) and (lHdrOK) and (lCalibTableType <> 0) then begin
  592.            gECAT_scalefactor_entries := lSingleRApos;
  593.            getmem (gECAT_scalefactor_table, gECAT_scalefactor_entries*sizeof(single));
  594.            for lS := 1 to gECAT_scalefactor_entries do
  595.                gECAT_scalefactor_table[lS] := lSingleRA[lS];
  596.   end;
  597.   if lSingleRASz > 0 then
  598.      freemem(lSingleRA);*)
  599. end;
  600. procedure write_slc (lFileName: string; var pDICOMdata: DICOMdata;var lSz: integer; lDICOM3: boolean);
  601. const kMaxRA = 41;
  602.      lXra: array [1..kMaxRA] of byte = (7,8,9,21,22,26,27,
  603.      35,36,44,45,
  604.      50,62,66,78,
  605.      81,95,
  606.      97,103,104,105,106,111,
  607.      113,123,127,
  608.      129,139,142,
  609.      146,147,148,149,155,156,157,
  610.      166,167,168,169,170);
  611. var
  612.    fp: file;
  613.    lX,lClr,lPos,lRApos: integer;
  614.    lP: bytep;
  615. procedure WriteString(lStr: string; lCR: boolean);
  616. var
  617.      n,lStrLen      : Integer;
  618. begin
  619.      lStrLen := length(lStr);
  620.      for n := 1 to lstrlen do begin
  621.             lPos := lPos + 1;
  622.             lP[lPos] := ord(lStr[n]);
  623.      end;
  624.      if lCR then begin
  625.         lPos := lPos + 1;
  626.         lP[lPos] := ord(kCR);
  627.      end;
  628. end;
  629.  
  630. begin
  631.   lSz := 0;
  632.   getmem(lP,2048);
  633.   lPos := 0;
  634.   WriteString('11111',true);
  635.   WriteString(inttostr(pDicomData.XYZdim[1])+' '+inttostr(pDicomData.XYZdim[2])+' '+inttostr(pDicomData.XYZdim[3])+' 8',true);
  636.   WriteString(floattostrf(pDicomData.XYZmm[1],ffFixed,7,7)+' '+floattostrf(pDicomData.XYZmm[2],ffFixed,7,7)+' '+floattostrf(pDicomData.XYZmm[3],ffFixed,7,7),true);
  637.   WriteString('1 1 0 0',true); //mmunits,MR,original,nocompress
  638.   WriteString('16 12 X',false); //icon is 8x8 grid, so 64 bytes for red,green blue
  639.   for lClr := 1 to 3 do begin
  640.     lRApos := 1;
  641.     for lX := 1 to 192 do begin
  642.       inc(lPos);
  643.       if (lRApos <= kMaxRA) and (lX = lXra[lRApos]) then begin
  644.          inc(lRApos);
  645.          lP[lPos] := 200;
  646.       end else
  647.           lP[lPos] := 0;
  648.     end; {icongrid 1..192}
  649.   end; {RGB}
  650.   if lFileName <> '' then begin
  651.      AssignFile(fp, lFileName);
  652.      Rewrite(fp, 1);
  653.      blockwrite(fp,lP^,lPos);
  654.      close(fp);
  655.   end;
  656.   freemem(lP);
  657.   lSz := lPos;
  658. end;
  659. procedure read_interfile_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string);
  660. label 333;
  661. const UNIXeoln = chr(10);
  662. var lTmpStr,lInStr,lUpCaseStr: string;
  663. lHdrEnd,lFloat,lUnsigned: boolean;
  664. lPos,lLen,FileSz,linPos: integer;
  665. fp: file;
  666. lCharRA: bytep;
  667. function readInterFloat:real;
  668. var lStr: string;
  669. begin
  670.   lStr := '';
  671.   While (lPos <= lLen) and (lInStr[lPos] <> ';') do begin
  672.         if lInStr[lPos] in ['+','-','e','E','.','0'..'9'] then
  673.            lStr := lStr+(linStr[lPos]);
  674.         inc(lPos);
  675.   end;
  676.     try
  677.        result := strtofloat(lStr);
  678.     except
  679.           on EConvertError do begin
  680.              showmessage('Unable to convert the string '+lStr+' to a number');
  681.              result := 1;
  682.              exit;
  683.           end;
  684.     end; {except}
  685.   end;
  686. function readInterStr:string;
  687. var lStr: string;
  688. begin
  689.   lStr := '';
  690.   While (lPos <= lLen) and (lInStr[lPos] = ' ') do begin
  691.         inc(lPos);
  692.   end;
  693.   While (lPos <= lLen) and (lInStr[lPos] <> ';') do begin
  694.         lStr := lStr+upcase(linStr[lPos]); //zebra upcase
  695.         inc(lPos);
  696.   end;
  697.   result := lStr;
  698. end; //interstr func
  699. begin
  700.   lHdrOK := false;
  701.   lFloat := false;
  702.   lUnsigned := false;
  703.   lImageFormatOK := true;
  704.   Clear_Dicom_Data(lDicomData);
  705.   lDynStr := '';
  706.   FileMode := 0; //set to readonly
  707.   AssignFile(fp, lFileName);
  708.   Reset(fp, 1);
  709.   FileSz := FileSize(fp);
  710.   lHdrEnd := false;
  711.   //lDicomData.ImageStart := FileSz;
  712.   GetMem( lCharRA, FileSz+1 );
  713.   BlockRead(fp, lCharRA^, FileSz, linpos);
  714.   if lInPos <> FileSz then showmessage('Disk error: Unable to read full input file.');
  715.   linPos := 1;
  716.   CloseFile(fp);
  717.   FileMode := 2; //set to read/write
  718. repeat
  719.   linstr := '';
  720.   while (linPos < FileSz) and (lCharRA[linPos] <> ord(kCR)) and (lCharRA[linPos] <> ord(UNIXeoln)) do begin
  721.       lInStr := lInstr + chr(lCharRA[linPos]);
  722.       inc(linPos);
  723.   end;
  724.   inc(lInPos);  //read EOLN
  725.   lLen := length(lInStr);
  726.   lPos := 1;
  727.   lUpcaseStr := '';
  728.   While (lPos <= lLen) and (lInStr[lPos] <> ';') and (lInStr[lPos] <> '=') and (lUpCaseStr <>'INTERFILE') do begin
  729.         if lInStr[lPos] in ['[',']','(',')','/','+','-',{' ',} '0'..'9','a'..'z','A'..'Z'] then
  730.            lUpCaseStr := lUpCaseStr+upcase(linStr[lPos]);
  731.         inc(lPos);
  732.   end;
  733.   inc(lPos); {read equal sign in := statement}
  734.   if lUpCaseStr ='INTERFILE' then begin
  735.      lHdrOK := true;
  736.      lDicomData.little_endian := 0;
  737.      end;
  738.   if lUpCaseStr ='DATASTARTINGBLOCK'then lDicomData.ImageStart := 2048 * round(readInterFloat);
  739.   if lUpCaseStr ='DATAOFFSETINBYTES'then lDicomData.ImageStart := round(readInterFloat);
  740.   if (lUpCaseStr ='MATRIXSIZE[1]') or (lUpCaseStr ='MATRIXSIZE[X]') then lDicomData.XYZdim[1] :=  round(readInterFloat);
  741.   if (lUpCaseStr ='MATRIXSIZE[2]')or (lUpCaseStr ='MATRIXSIZE[Y]')then lDicomData.XYZdim[2] :=  round(readInterFloat);
  742.   if (lUpCaseStr ='MATRIXSIZE[3]')or (lUpCaseStr ='MATRIXSIZE[Z]') or (lUpCaseStr ='NUMBEROFSLICES') or (lUpCaseStr ='TOTALNUMBEROFIMAGES') then begin
  743.      lDicomData.XYZdim[3] :=  round(readInterFloat);
  744.   end;
  745.   if lUpCaseStr ='IMAGEDATABYTEORDER' then begin
  746.      if readInterStr = 'LITTLEENDIAN' then lDicomData.little_endian := 1;
  747.   end;
  748.   if lUpCaseStr ='NUMBERFORMAT' then begin
  749.       lTmpStr := readInterStr;
  750.       if (lTmpStr = 'ASCII') or (lTmpStr='BIT') then begin
  751.          lHdrOK := false;
  752.          showmessage('This software can not convert '+lTmpStr+' data type.');
  753.          goto 333;
  754.       end;
  755.       if lTmpStr = 'UNSIGNEDINTEGER' then lUnsigned := true;
  756.       if (lTmpStr='FLOAT') or (lTmpStr='SHORTFLOAT') or (lTmpStr='LONGFLOAT') then begin
  757.          lFloat := true;
  758.       end;
  759.   end;
  760.   if lUpCaseStr ='NAMEOFDATAFILE' then lFileName := ExtractFilePath(lFileName)+readInterStr;
  761.   if lUpCaseStr ='NUMBEROFBYTESPERPIXEL' then
  762.      lDicomData.Allocbits_per_pixel :=  round(readInterFloat)*8;
  763.   if (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[1]') or (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[X]') then
  764.      lDicomData.XYZmm[1] :=  (readInterFloat);
  765.   if (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[2]') or (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[Y]')then lDicomData.XYZmm[2] :=  (readInterFloat);
  766.   if (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[3]')or (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[Z]')or (lUpCaseStr ='SLICETHICKNESS')then lDicomData.XYZmm[3] :=  (readInterFloat);
  767.   if (lUpCaseStr ='ENDOFINTERFILE') then lHdrEnd := true;
  768.   if not lHdrOK then goto 333;
  769.   if lInStr <> '' then
  770.      lDynStr := lDynStr + lInStr+kCr;
  771.   lHdrOK := true;
  772. until (linPos >= FileSz) or (lHdrEnd){EOF(fp)};
  773. lDicomData.Storedbits_per_pixel := lDicomData.Allocbits_per_pixel;
  774. lImageFormatOK := true;
  775. if (not lFLoat) and (lUnsigned) and ((lDicomData.Storedbits_per_pixel = 16)) then begin
  776.    showmessage('Warning: this Interfile image uses UNSIGNED 16-bit data [values 0..65535]. Analyze specifies SIGNED 16-bit data [-32768..32767]. Some images may not transfer well. [Future versions of MRIcro should fix this].');
  777.    lImageFormatOK := false;
  778. end else if (not lFLoat) and (lDicomData.Storedbits_per_pixel > 16) then begin
  779.    showmessage('WARNING: The image '+lFileName+' is a '+inttostr(lDicomData.Storedbits_per_pixel)+'-bit integer data type. This software may display this as SIGNED data. Bits per voxel: '+inttostr(lDicomData.Storedbits_per_pixel));
  780.    lImageFormatOK := false;
  781. end else if (lFloat) then begin //zebra change float check
  782.    //showmessage('WARNING: The image '+lFileName+' uses floating point [real] numbers. The current software can only read integer data type Interfile images.');
  783.    lDicomData.Float := true;
  784.    //lImageFormatOK := false;
  785. end;
  786. 333:
  787. FreeMem( lCharRA);
  788. end;
  789.  
  790. (*procedure read_PAR_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string);
  791. label 333;
  792. const UNIXeoln = chr(10);
  793. var lInStr,lUpCaseStr: string;
  794. lFirstSlope: boolean;
  795. lPos,lLen,FileSz,linPos,lInc{,lIndex,lIndexOld},lScanResX,lScanResY: integer;
  796. lSlope,lSlopeOld : single;
  797. fp: file;
  798. lCharRA: bytep;
  799. function readParFloat:single;
  800. var lStr: string;
  801. begin
  802.   lStr := '';
  803.   While (lPos <= lLen) and ((lStr='')  or(lInStr[lPos] <> ' ')) do begin
  804.         if lInStr[lPos] in ['+','-','e','E','.','0'..'9'] then
  805.            lStr := lStr+(linStr[lPos]);
  806.         inc(lPos);
  807.   end;
  808.     try
  809.        result := strtofloat(lStr);
  810.     except
  811.           on EConvertError do begin
  812.              showmessage('Unable to convert the string '+lStr+' to a number');
  813.              result := 1;
  814.              exit;
  815.           end;
  816.     end; {except}
  817.   end;
  818. begin
  819.   lHdrOK := false;
  820.   lImageFormatOK := true;
  821.   lFirstSlope := true;
  822.   lScanResX := 0;
  823.   lScanResY := 0;
  824.   lSlopeOld := 0;
  825.   //lIndexOld := -1;
  826.   Clear_Dicom_Data(lDicomData);
  827.   lDynStr := '';
  828.   FileMode := 0; //set to readonly
  829.   AssignFile(fp, lFileName);
  830.   Reset(fp, 1);
  831.   FileSz := FileSize(fp);
  832.   GetMem( lCharRA, FileSz+1 );
  833.   BlockRead(fp, lCharRA^, FileSz, linpos);
  834.   if lInPos <> FileSz then showmessage('Disk error: Unable to read full input file.');
  835.   linPos := 1;
  836.   CloseFile(fp);
  837.   FileMode := 2; //set to read/write
  838.   repeat
  839.     linstr := '';
  840.     while (linPos < FileSz) and (lCharRA[linPos] <> ord(kCR)) and (lCharRA[linPos] <> ord(UNIXeoln)) do begin
  841.       lInStr := lInstr + chr(lCharRA[linPos]);
  842.       inc(linPos);
  843.     end;
  844.     inc(lInPos);  //read EOLN
  845.     lDynStr := lDynStr + lInStr;
  846.     lDynStr := lDynStr+kCr;
  847.     lLen := length(lInStr);
  848.     lPos := 1;
  849.     lUpcaseStr := '';
  850.     if lLen < 1 then
  851.  
  852.     else if (lInStr[1] = '#') and (lHdrOK) then  //# => comment
  853.      //ignore comment
  854.      else if (lInStr[1] <> '.') and (lHdrOK) then begin  // SliceIndexData
  855.           for lInc := 1 to 6 do //1=slicenum,2=echonum,3=dynScanNum,4=CardiacPhase,5=ImageType,6=SequenceType
  856.               readParFloat;
  857.           readparfloat; //7=index
  858.           {lIndex :=  trunc(readParFloat);
  859.           if lIndex < lIndexOld then begin
  860.              Showmessage('Warning: Par file images were not stored in sequential order. Conversion is being aborted.');
  861.              goto 333;
  862.           end;
  863.           lIndexOld := lIndex; }
  864.           readParFloat; //8=intercept
  865.           lSlope :=  readParFloat; //9=lslope
  866.           //Showmessage(inttostr(lIndex)+':'+floattostr(lSlope));
  867.           if (not lFirstSlope) and (lSlope <> lSlopeOld) then begin
  868.              Showmessage('Warning: Par file conversion is being aborted: scaling slope varies between slices.');
  869.              goto 333;
  870.           end;
  871.           lFirstSlope := false;
  872.           lSlopeOld := lSlope;
  873.           lDicomData.IntenScale := lSlope;
  874.     end else begin  // Signature not yet found or '.' starts all data except slice index
  875.       While (lPos <= lLen) and (lInStr[lPos] <> ':') and ((not lHdrOK) or (lInStr[lPos] <> '#')) do begin
  876.         if lInStr[lPos] in ['[',']','(',')','/','+','-',{' ',} '0'..'9','a'..'z','A'..'Z'] then
  877.            lUpCaseStr := lUpCaseStr+upcase(linStr[lPos]);
  878.         inc(lPos);
  879.       end;
  880.       inc(lPos); {read equal sign in := statement}
  881.       if lUpCaseStr = ('DATADESCRIPTIONFILE') then begin //PAR file
  882.          lHdrOK := true;
  883.          lDicomData.little_endian := 1;
  884.          lFileName := changefileext(lFilename,'.rec');
  885.       end;
  886.       if (lUpCaseStr ='MAXNUMBEROFSLICES/LOCATIONS') then
  887.          lDicomData.XYZdim[3] :=  round(readParFloat);
  888.       if lUpCaseStr = 'FOV(APFHRL)[MM]' then begin
  889.          lDicomData.XYZmm[1] :=  (readParFloat);
  890.          lDicomData.XYZmm[3] :=  (readParFloat);
  891.          lDicomData.XYZmm[2] :=  (readParFloat);
  892.       end;
  893.       if lUpCaseStr = 'SCANRESOLUTION(XY)' then begin
  894.          lScanResX :=  round(readParFloat);
  895.          lScanResY :=  round(readParFloat);
  896.       end;
  897.       if lUpCaseStr = 'RECONRESOLUTION(XY)' then begin
  898.          lDicomData.XYZdim[1] :=  round(readParFloat);
  899.          lDicomData.XYZdim[2] :=  round(readParFloat);
  900.       end;
  901.       if lUpCaseStr ='IMAGEPIXELSIZE[8OR16BITS]' then
  902.          lDicomData.Allocbits_per_pixel :=  round(readPARFloat);
  903.       if not lHdrOK then goto 333;
  904.       lHdrOK := true;
  905.     end;
  906.   until (linPos >= FileSz) {or (lHdrEnd){EOF(fp)};
  907.   if (lScanResX > 0) then //Convert FOV to slice thickness
  908.      lDicomData.XYZmm[1] :=  lDicomData.XYZmm[1]/lScanResX;
  909.   if (lScanResY > 0) then //Convert FOV to slice thickness
  910.      lDicomData.XYZmm[2] :=  lDicomData.XYZmm[2]/lScanResY;
  911.   if (lDicomdata.XYZdim[1] > 0) then //Convert FOV to slice thickness
  912.      lDicomData.XYZmm[3] :=  lDicomData.XYZmm[3]/lDicomdata.XYZdim[3];
  913.   lDicomData.Storedbits_per_pixel := lDicomData.Allocbits_per_pixel;
  914.   lImageFormatOK := true;
  915.   //if (lUnsigned) and ((lDicomData.Storedbits_per_pixel = 16)) then
  916.   //showmessage('Warning: this Interfile image uses UNSIGNED 16-bit data [values 0..65535]. Analyze specifies SIGNED 16-bit data [-32768..32767]. Some images may not transfer well. [Future versions of MRIcro should fix this].');
  917.   //if (lDicomData.Storedbits_per_pixel > 16) then
  918.   //showmessage('WARNING: The image '+lFileName+' is a '+inttostr(lDicomData.Storedbits_per_pixel)+'-bit UNSIGNED integer data type. This software may display this as SIGNED data. Bits per voxel: '+inttostr(lDicomData.Storedbits_per_pixel));
  919.    //if (lFloat) then begin
  920.    //   showmessage('WARNING: The image '+lFileName+' uses floating point [real] numbers. The current software can only read integer data type Interfile images.');
  921.    //lImageFormatOK := false;
  922.   //end;
  923.   333:
  924.   FreeMem( lCharRA);
  925. end;*)
  926. procedure read_PAR_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string);
  927. label 333;
  928. const UNIXeoln = chr(10);
  929. var lInStr,lUpCaseStr: string;
  930. lFirstSlope: boolean;
  931. lPos,lLen,FileSz,linPos,lInc{,lIndex,lIndexOld},lScanResX,lScanResY: integer;
  932. lSlope,lSlopeOld : single;
  933. fp: file;
  934. lCharRA: bytep;
  935. function readParFloat:single;
  936. var lStr: string;
  937. begin
  938.   lStr := '';
  939.   While (lPos <= lLen) and ((lStr='')  or(lInStr[lPos] <> ' ')) do begin
  940.         if lInStr[lPos] in ['+','-','e','E','.','0'..'9'] then
  941.            lStr := lStr+(linStr[lPos]);
  942.         inc(lPos);
  943.   end;
  944.     try
  945.        result := strtofloat(lStr);
  946.     except
  947.           on EConvertError do begin
  948.              showmessage('Unable to convert the string '+lStr+' to a number');
  949.              result := 1;
  950.              exit;
  951.           end;
  952.     end; {except}
  953.   end;
  954. begin
  955.   lHdrOK := false;
  956.   lImageFormatOK := true;
  957.   lFirstSlope := true;
  958.   lScanResX := 0;
  959.   lScanResY := 0;
  960.   lSlopeOld := 0;
  961.   //lIndexOld := -1;
  962.   Clear_Dicom_Data(lDicomData);
  963.   lDynStr := '';
  964.   FileMode := 0; //set to readonly
  965.   AssignFile(fp, lFileName);
  966.   Reset(fp, 1);
  967.   FileSz := FileSize(fp);
  968.   GetMem( lCharRA, FileSz+1 );
  969.   BlockRead(fp, lCharRA^, FileSz, linpos);
  970.   if lInPos <> FileSz then showmessage('Disk error: Unable to read full input file.');
  971.   linPos := 1;
  972.   CloseFile(fp);
  973.   FileMode := 2; //set to read/write
  974.   repeat
  975.     linstr := '';
  976.     while (linPos < FileSz) and (lCharRA[linPos] <> ord(kCR)) and (lCharRA[linPos] <> ord(UNIXeoln)) do begin
  977.       lInStr := lInstr + chr(lCharRA[linPos]);
  978.       inc(linPos);
  979.     end;
  980.     inc(lInPos);  //read EOLN
  981.     {lDynStr := lDynStr + lInStr;
  982.     lDynStr := lDynStr+kCr;}
  983.     lLen := length(lInStr);
  984.     lPos := 1;
  985.     lUpcaseStr := '';
  986.     if lLen < 1 then
  987.  
  988.     else if (lInStr[1] = '#') and (lHdrOK) then  //# => comment
  989.      //ignore comment
  990.      else if (lInStr[1] <> '.') and (lHdrOK) then begin  // SliceIndexData
  991.           for lInc := 1 to 6 do //1=slicenum,2=echonum,3=dynScanNum,4=CardiacPhase,5=ImageType,6=SequenceType
  992.               readParFloat;
  993.           readparfloat; //7=index
  994.           {lIndex :=  trunc(readParFloat);
  995.           if lIndex < lIndexOld then begin
  996.              Showmessage('Warning: Par file images were not stored in sequential order. Conversion is being aborted.');
  997.              goto 333;
  998.           end;
  999.           lIndexOld := lIndex; }
  1000.           readParFloat; //8=intercept
  1001.           lSlope :=  readParFloat; //9=lslope
  1002.           //Showmessage(inttostr(lIndex)+':'+floattostr(lSlope));
  1003.           if (not lFirstSlope) and (lSlope <> lSlopeOld) then begin
  1004.              Showmessage('Warning: PAR file conversion is being aborted: scaling slope varies between slices.');
  1005.              goto 333;
  1006.           end;
  1007.           lFirstSlope := false;
  1008.           lSlopeOld := lSlope;
  1009.           lDicomData.IntenScale := lSlope;
  1010.     end else begin  // Signature not yet found or '.' starts all data except slice index
  1011.       While (lPos <= lLen) and (lInStr[lPos] <> ':') and ((not lHdrOK) or (lInStr[lPos] <> '#')) do begin
  1012.         if lInStr[lPos] in ['[',']','(',')','/','+','-',{' ',} '0'..'9','a'..'z','A'..'Z'] then
  1013.            lUpCaseStr := lUpCaseStr+upcase(linStr[lPos]);
  1014.         inc(lPos);
  1015.       end;
  1016.       inc(lPos); {read equal sign in := statement}
  1017.       if lUpCaseStr = ('DATADESCRIPTIONFILE') then begin //PAR file
  1018.          lHdrOK := true;
  1019.          lDicomData.little_endian := 1;
  1020.          lFileName := changefileext(lFilename,'.rec');
  1021.       end;
  1022.       if (lUpCaseStr ='MAXNUMBEROFSLICES/LOCATIONS') then
  1023.          lDicomData.XYZdim[3] :=  round(readParFloat);
  1024.       if lUpCaseStr = 'FOV(APFHRL)[MM]' then begin
  1025.          lDicomData.XYZmm[2] :=  (readParFloat); //AP anterior->posterior
  1026.          lDicomData.XYZmm[3] :=  (readParFloat); //FH foot head
  1027.          lDicomData.XYZmm[1] :=  (readParFloat); //RL Right-Left
  1028.       end;
  1029.       if lUpCaseStr = 'SCANRESOLUTION(XY)' then begin
  1030.          lScanResX :=  round(readParFloat);
  1031.          lScanResY :=  round(readParFloat);
  1032.       end;
  1033.       if lUpCaseStr = 'RECONRESOLUTION(XY)' then begin
  1034.          lDicomData.XYZdim[1] :=  round(readParFloat);
  1035.          lDicomData.XYZdim[2] :=  round(readParFloat);
  1036.       end;
  1037.       if lUpCaseStr = 'MAXNUMBEROFDYNAMICS' then begin
  1038.          lDicomData.XYZdim[4] :=  round(readParFloat);
  1039.       end;
  1040.       if lUpCaseStr ='IMAGEPIXELSIZE[8OR16BITS]' then
  1041.          lDicomData.Allocbits_per_pixel :=  round(readPARFloat);
  1042.       if not lHdrOK then goto 333;
  1043.       lHdrOK := true;
  1044.     end;
  1045.   until (linPos >= FileSz) {or (lHdrEnd){EOF(fp)};
  1046.   if (lScanResX > 0) then //Convert FOV to slice thickness
  1047.      lDicomData.XYZmm[1] :=  lDicomData.XYZmm[1]/lScanResX;
  1048.   if (lScanResY > 0) then //Convert FOV to slice thickness
  1049.      lDicomData.XYZmm[2] :=  lDicomData.XYZmm[2]/lScanResY;
  1050.   if (lDicomdata.XYZdim[1] > 0) then //Convert FOV to slice thickness
  1051.      lDicomData.XYZmm[3] :=  lDicomData.XYZmm[3]/lDicomdata.XYZdim[3];
  1052.   lDicomData.Storedbits_per_pixel := lDicomData.Allocbits_per_pixel;
  1053.   lImageFormatOK := true;
  1054.   lDynStr := 'PAR/REC Format'
  1055.     +kCR+ 'XYZ dim: ' +inttostr(lDicomData.XYZdim[1])+'/'+inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3])
  1056.      +kCR+'Volumes: ' +inttostr(lDicomData.XYZdim[4])
  1057.      +kCR+'XYZ mm: '+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/'
  1058.      +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2);
  1059.   333:
  1060.   FreeMem( lCharRA);
  1061. end;
  1062.  
  1063.  
  1064.  
  1065. procedure read_ge_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string);
  1066. label
  1067.   539;
  1068. var
  1069.   lI: word;
  1070.   lExamHdr,lImgHdr,lDATFormatOffset,lHdrOffset,lCompress,linitialoffset,n,filesz: LongInt;
  1071.   tx     : array [0..26] of Char;
  1072.   FP: file;
  1073.   lGEodd,lGEFlag,{lSpecial,}lMR: boolean;
  1074. function GEflag: boolean;
  1075. begin
  1076.      if (tx[0] = 'I') AND (tx[1]= 'M') AND (tx[2] = 'G')AND (tx[3]= 'F') then
  1077.         result := true
  1078.      else
  1079.          result := false;
  1080. end;
  1081. function swap16i(lPos: longint): word;
  1082. var
  1083.    w : Word;
  1084. begin
  1085.   seek(fp,lPos-2);
  1086.   BlockRead(fp, W, 2);
  1087.   result := swap(W);
  1088. end;
  1089.  
  1090. function swap32i(lPos: longint): Longint;
  1091. type
  1092.   swaptype = packed record
  1093.     case byte of
  1094.       0:(Word1,Word2 : word); //word is 16 bit
  1095.       1:(Long:LongInt);
  1096.   end;
  1097.   swaptypep = ^swaptype;
  1098. var
  1099.    s : LongInt;
  1100.   inguy:swaptypep;
  1101.   outguy:swaptype;
  1102. begin
  1103.      seek(fp,lPos);
  1104.   BlockRead(fp, s, 4, n);
  1105.   inguy := @s; //assign address of s to inguy
  1106.   outguy.Word1 := swap(inguy^.Word2);
  1107.   outguy.Word2 := swap(inguy^.Word1);
  1108.   swap32i:=outguy.Long;
  1109. end;
  1110. function fswap4r (lPos: longint): single;
  1111. type
  1112.   swaptype = packed record
  1113.     case byte of
  1114.       0:(Word1,Word2 : word); //word is 16 bit
  1115.       1:(float:single);
  1116.   end;
  1117.   swaptypep = ^swaptype;
  1118. var
  1119.    s:single;
  1120.   inguy:swaptypep;
  1121.   outguy:swaptype;
  1122. begin
  1123.      seek(fp,lPos);
  1124.   BlockRead(fp, s, 4, n);
  1125.   inguy := @s; //assign address of s to inguy
  1126.   outguy.Word1 := swap(inguy^.Word2);
  1127.   outguy.Word2 := swap(inguy^.Word1);
  1128.   fswap4r:=outguy.float;
  1129. end;
  1130. begin
  1131.   lImageFormatOK := true;
  1132.   lHdrOK := false;
  1133.   lHdrOffset := 0;
  1134.   if not fileexists(lFileName) then begin
  1135.      lImageFormatOK := false;
  1136.      exit;
  1137.   end;
  1138.   FileMode := 0; //set to readonly
  1139.   AssignFile(fp, lFileName);
  1140.   Reset(fp, 1);
  1141.   FIleSz := FileSize(fp);
  1142.   lDATFormatOffset := 0;
  1143.   Clear_Dicom_Data(lDicomData);
  1144.      if filesz < (3240) then begin
  1145.         showmessage('This file is too small to be a Genesis DAT format image.');
  1146.         goto 539;
  1147.      end;
  1148.      lDynStr:= '';
  1149.      //lGEFlag := false;
  1150.      lInitialOffset := 3228;//3240;
  1151.      seek(fp, lInitialOffset);
  1152.      BlockRead(fp, tx, 4*SizeOf(Char), n);
  1153.      lGEflag := GEFlag;
  1154.      if not lGEFlag then begin
  1155.         lInitialOffset := 3240;
  1156.         seek(fp, lInitialOffset);
  1157.         BlockRead(fp, tx, 4*SizeOf(Char), n);
  1158.         lGEflag := GEFlag;
  1159.      end;
  1160.      lGEodd := lGEFlag;
  1161.      if not lGEFlag then begin
  1162.         lInitialOffset := 0;
  1163.         seek(fp, lInitialOffset);
  1164.         BlockRead(fp, tx, 4*SizeOf(Char), n);
  1165.         if not GEflag then begin {DAT format}
  1166.            lDynStr := lDynStr+'GE Genesis Signa DAT tape format'+kCR;
  1167.            seek(fp,114+97);
  1168.            BlockRead(fp, tx, 25*SizeOf(Char), n);
  1169.            lDynStr := lDynStr + 'Patient Name: ';
  1170.            for lI := 0 to 24 do
  1171.             lDynStr := lDynStr + tx[lI];
  1172.            lDynStr := lDynStr + kCR;
  1173.            seek(fp,114+84);
  1174.            BlockRead(fp, tx, 13*SizeOf(Char), n);
  1175.            lDynStr := lDynStr + 'Patient ID: ';
  1176.            for lI := 0 to 12 do
  1177.                lDynStr := lDynStr + tx[lI];
  1178.            lDynStr := lDynStr + kCR;
  1179.            seek(fp, 114+305);
  1180.            BlockRead(fp, tx, 3*SizeOf(Char), n);
  1181.            if (tx[0]='M') and (tx[1] = 'R') then
  1182.               lMR := true
  1183.            else if (tx[0] = 'C') and(tx[1] = 'T') then
  1184.              lMR := false
  1185.            else begin
  1186.                 Showmessage('Is this a Genesis DAT image? The modality is '+tx[0]+tx[1]+tx[3]
  1187.               +'. Expected ''MR'' or ''CT''.');
  1188.               goto 539;
  1189.            end;
  1190.            if lMR then
  1191.               lInitialOffset := 3180
  1192.            else
  1193.                lInitialOffset := 3178;
  1194.            seek(fp, lInitialOffset);
  1195.            BlockRead(fp, tx, 4*SizeOf(Char), n);
  1196.            if (tx[0] <> 'I') OR (tx[1] <> 'M') OR (tx[2] <> 'G') OR (tx[3] <> 'F') then begin
  1197.               showmessage('This image does not have the required label ''IMGF''. This is not a Genesis DAT image.');
  1198.               goto 539;
  1199.            end else
  1200.         lDicomData.ImageNum := swap16i(2158+12);
  1201.         lDicomData.XYZmm[3] := fswap4r (2158+26);// slice thickness mm
  1202.         lDicomData.XYZmm[1] := fswap4r (2158+50);// pixel size- X
  1203.         lDicomData.XYZmm[2] := fswap4r (2158+54);//pixel size - Y
  1204.         lDATFormatOffset := 4;
  1205.      end; {DAT format}
  1206. end;
  1207.      lDicomData.ImageStart := lDATFormatOffset+linitialoffset + swap32i(linitialoffset+4);//byte displacement to image data
  1208.      lDicomData.XYZdim[1] := swap32i(linitialoffset+8); //width
  1209.      lDicomData.XYZdim[2] := swap32i(linitialoffset+12);//height
  1210.      lDicomData.Allocbits_per_pixel := swap32i(linitialoffset+16);//bits
  1211.      lDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel;
  1212.      lCompress := swap32i(linitialoffset+20); //compression
  1213.      lExamHdr :=  swap32i(linitialoffset+136);
  1214.      lImgHdr :=  swap32i(linitialoffset+152);
  1215.      if (lImgHdr = 0) and (lDicomData.ImageStart = 8432) then begin
  1216.         lDicomData.ImageNum := swap16i(2310+12);
  1217.         //showmessage(inttostr(lDicomData.ImageNum));
  1218.         lDicomData.XYZmm[3] := fswap4r (2310+26);// slice thickness mm
  1219.         lDicomData.XYZmm[1] := fswap4r (2310+50);// pixel size- X
  1220.         lDicomData.XYZmm[2] := fswap4r (2310+54);//pixel size - Y
  1221.      end else if {(lSpecial = false) and} (lDATFormatOffset = 0) then begin
  1222.         lDynStr := lDynStr+'GE Genesis Signa format'+kCR;
  1223.         if (not lGEodd) and (lExamHdr <> 0) then begin
  1224.            lHdrOffset := swap32i(linitialoffset+132);//x132- int ptr to exam heade
  1225.            seek(fp,lHdrOffset+97);
  1226.            BlockRead(fp, tx, 25*SizeOf(Char), n);
  1227.            lDynStr := lDynStr + 'Patient Name: ';
  1228.            for lI := 0 to 24 do
  1229.             lDynStr := lDynStr + tx[lI];
  1230.            lDynStr := lDynStr + kCR;
  1231.            seek(fp,lHdrOffset+84);
  1232.            BlockRead(fp, tx, 13*SizeOf(Char), n);
  1233.            lDynStr := lDynStr + 'Patient ID: ';
  1234.            for lI := 0 to 12 do
  1235.             lDynStr := lDynStr + tx[lI];
  1236.            lDynStr := lDynStr + kCR;
  1237.         lHdrOffset := swap32i(linitialoffset+148);//x148- int ptr to image heade
  1238.         end;
  1239.         if lGEodd then
  1240.            lHdrOffset := 2158+28;
  1241.         if ((lHdrOffset +16) < FileSz) and (lImgHdr <> 0) then begin
  1242.            //showmessage(inttostr(lHdrOffset));
  1243.            lDicomData.ImageNum := swap16i(lHdrOffset+12);
  1244.            lDicomData.XYZmm[3] := fswap4r ({}lHdrOffset{linitialoffset+lHdrOffset}+26);// slice thickness mm
  1245.            lDicomData.XYZmm[1] := fswap4r ({}lHdrOffset{linitialoffset+lHdrOffset}+50);// pixel size- X
  1246.            lDicomData.XYZmm[2] := fswap4r ({}lHdrOffset{linitialoffset+lHdrOffset}+54);//pixel size - Y
  1247.         end;
  1248.      end;
  1249.  
  1250.      if (lCompress = 3) or (lCompress = 4) then begin
  1251.         lDicomData.GenesisCpt := true;
  1252.         lDynStr := lDynStr+'Compressed data'+kCR;
  1253.      end else
  1254.          lDicomData.GenesisCpt := false;
  1255.      if (lCompress = 2) or (lCompress = 4) then begin
  1256.         lDicomData.GenesisPackHdr := swap32i(linitialoffset+64);
  1257.         lDynStr := lDynStr+'Packed data'+kCR;
  1258.      end else
  1259.          lDicomData.GenesisPackHdr := 0;
  1260.      lDynStr := lDynStr+'Image Number: '+inttostr(lDicomData.ImageNum)+kCR
  1261.      +'XYZ dim: ' +inttostr(lDicomData.XYZdim[1])+'/'
  1262.      +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3])
  1263.      +kCR+'XYZ mm: '+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/'
  1264.      +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2);
  1265.   lHdrOK := true;
  1266.   539:
  1267.        CloseFile(fp);
  1268.   FileMode := 2; //set to read/write
  1269. end;//read_ge
  1270.  
  1271. procedure write_dicom (lFileName: string; var pDICOMdata: DICOMdata;var lSz: integer; lDICOM3: boolean);
  1272. var
  1273.    fp: file;
  1274.    lHiBit,lGrpError,lStart,lEnd,lInc,lPos: integer;
  1275.    lP: bytep;
  1276. //     WriteGroupElement(lDICOM3,-1,lPos,$0002,$0010,'U','I','1.2.840.10008.1.2')//implicit xfer syntax
  1277. procedure WriteGroupElement(lExplicit: boolean; lInt2,lInt4: integer; var lPos: integer;lGrp,lEle: integer;lChar1,lChar2: char;lInStr: string);
  1278. var
  1279.      lStr: string;
  1280.      lPad: boolean;
  1281.   n,lStrLen      : Integer;
  1282.      lT0,lT1: byte;
  1283. begin
  1284.      lStr := lInStr;
  1285.      lPad := false;
  1286.      lT0 := ord(lChar1);
  1287.      lT1 := ord(lChar2);
  1288.       //if (lGrp = $18) and (lEle = $50) then
  1289.        //  lStr := lStr+'0';
  1290.       if (lInt2 >= 0) then
  1291.         lStrLen := 2
  1292.      else if (lInt4 >= 0) then
  1293.         lStrLen := 4
  1294.      else begin
  1295.           lStrLen := length(lStr);
  1296.           if odd(lStrLen) then begin
  1297.              inc(lStrLen);
  1298.              lPad := true;
  1299.              //lStr := lStr + ' ';
  1300.           end;
  1301.      end;
  1302.      lP[lPos+1] := lGrp and $00FF;
  1303.      lP[lPos+2] := (lGrp and $FF00) shr 8;
  1304.      lP[lPos+3] := lEle and $00FF;
  1305.      lP[lPos+4] := (lEle and $FF00) shr 8;
  1306.      lInc := 4; //how many bytes have we added;
  1307.  
  1308.  
  1309.      if (lExplicit) and ( ((lT0=kO) and (lT1=kB)) or ((lT0=kO) and (lT1=kW))
  1310.       or ((lT0=kS) and (lT1=kQ)) )
  1311.       then begin
  1312.            lP[lPos+5] := lT0;
  1313.            lP[lPos+6] := lT1;
  1314.            lP[lPos+7] := 0;
  1315.            lP[lPos+8] := 0;
  1316.            lInc := lInc + 4;
  1317.            if lgrp <> $7FE0 then begin
  1318.               lP[lPos+9] := lStrLen and $000000FF;
  1319.               lP[lPos+10] := lStrLen and $0000FF00;
  1320.               lP[lPos+11] := lStrLen and $00FF0000;
  1321.               lP[lPos+12] := lStrLen and $FF000000;
  1322.               lInc := lInc + 4;
  1323.            end;
  1324.    end else
  1325.    if (lExplicit) and ( ((lT0=kA) and (lT1=kE)) or ((lT0=kA) and (lT1=kS))
  1326.       or ((lT0=kA) and (lT1=kT)) or ((lT0=kC) and (lT1=kS)) or ((lT0=kD) and (lT1=kA))
  1327.       or ((lT0=kD) and (lT1=kS))
  1328.       or ((lT0=kD) and (lT1=kT)) or ((lT0=kF) and (lT1=kL)) or ((lT0=kF) and (lT1=kD))
  1329.       or ((lT0=kI) and (lT1=kS)) or ((lT0=kL) and (lT1=kO))or ((lT0=kL) and (lT1=kT))
  1330.       or ((lT0=kP) and (lT1=kN)) or ((lT0=kS) and (lT1=kH)) or ((lT0=kS) and (lT1=kL))
  1331.       or ((lT0=kS) and (lT1=kS)) or ((lT0=kS) and (lT1=kT)) or ((lT0=kT) and (lT1=kM))
  1332.       or ((lT0=kU) and (lT1=kI)) or ((lT0=kU) and (lT1=kL)) or ((lT0=kU) and (lT1=kS))
  1333.       or ((lT0=kA) and (lT1=kE)) or ((lT0=kA) and (lT1=kS)) )
  1334.       then begin
  1335.            lP[lPos+5] := lT0;
  1336.            lP[lPos+6] := lT1;
  1337.            lP[lPos+7] := lStrLen and $000000FF;
  1338.            lP[lPos+8] := lStrLen and $00000FF00;
  1339.            lInc := lInc + 4;
  1340.  
  1341.       //if (lGrp = $18) and (lEle = $50) then
  1342.       //   if lPad then showmessage('bPad'+lStr);
  1343.  
  1344.  
  1345.    end else if (not ( ((lT0=kO) and (lT1=kB)) or ((lT0=kO) and (lT1=kW))
  1346.       or ((lT0=kS) and (lT1=kQ)) )) then begin {Not explicit}
  1347.            lP[lPos+5] := lStrLen and $000000FF;
  1348.            lP[lPos+6] := lStrLen and $0000FF00;
  1349.            lP[lPos+7] := lStrLen and $00FF0000;
  1350.            lP[lPos+8] := lStrLen and $FF000000;
  1351.            lInc := lInc + 4;
  1352.    end;
  1353.    if lstrlen = 0 then exit;
  1354.    lPos := lPos + lInc;
  1355.    if lInt2 >= 0 then begin
  1356.        inc(lPos);
  1357.        lP[lPos] := lInt2 and $00FF;
  1358.        inc(lPos);
  1359.        lP[lPos] := (lInt2 and $FF00) shr 8;
  1360.        exit;
  1361.    end;
  1362.    if lInt4 >= 0 then begin
  1363.        inc(lPos);
  1364.        lP[lPos] := lInt4 and $000000FF;
  1365.        inc(lPos);
  1366.        lP[lPos] := (lInt4 and $0000FF00) shr 8;
  1367.        inc(lPos);
  1368.        lP[lPos] := (lInt4 and $00FF0000) shr 16;
  1369.        inc(lPos);
  1370.        lP[lPos] := (lInt4 and $FF000000) shr 24;
  1371.        exit;
  1372.    end;
  1373.    if lPad then begin
  1374.       //if (lGrp = $18) and (lEle = $50) then
  1375.       //if lPad then showmessage('A Pad'+lStr);
  1376.  
  1377.        for n := 1 to (lstrlen-1) do begin
  1378.             lPos := lPos + 1;
  1379.             lP[lPos] := ord(lStr[n]);
  1380.        end;
  1381.        lPos := lPos + 1;
  1382.        lP[lPos] := 0;
  1383.    end else begin
  1384.        for n := 1 to lstrlen do begin
  1385.             lPos := lPos + 1;
  1386.             lP[lPos] := ord(lStr[n]);
  1387.        end;
  1388.    end;
  1389. end;
  1390.  
  1391. begin
  1392.      lSz := 0;
  1393.   getmem(lP,1024);
  1394.   if lDiCOM3 then begin
  1395.      for lInc := 1 to 127 do
  1396.       lP[lInc] := 0;
  1397.      lP[lInc+1] := ord('D');
  1398.      lP[lInc+2] := ord('I');
  1399.      lP[lInc+3] := ord('C');
  1400.      lP[lInc+4] := ord('M');
  1401.      lPos := 128 + 4;
  1402.      lGrpError := 12;
  1403.   end else begin
  1404.       lPos := 0;
  1405.       lGrpError := 12;
  1406.   end;
  1407. if lDICOM3 then begin
  1408.   lStart := lPos;
  1409.   WriteGroupElement(lDICOM3,-1,2,lPos,$0002,$0000,'U','L','');//length
  1410.  //xx  WriteGroupElement(lDICOM3,256,-1,lPos,$0002,$0001,'O','B','');//meta info
  1411.   WriteGroupElement(lDICOM3,256,-1,lPos,$0002,$0001,'O','B',' ');//256
  1412.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0002,$0002,'U','I','1.2.840.10008.5.1.4.1.1.4');//implicit xfer syntax
  1413.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0002,$0003,'U','I','999.999.2.19960619.163000.1.103');//implicit xfer syntax
  1414.   if not lDICOM3 then
  1415.      WriteGroupElement(lDICOM3,-1,-1,lPos,$0002,$0010,'U','I','1.2.840.10008.1.2')//implicit xfer syntax
  1416.   else if pDicomData.little_endian = 1 then
  1417.      WriteGroupElement(lDICOM3,-1,-1,lPos,$0002,$0010,'U','I','1.2.840.10008.1.2.1')//little xfer syntax
  1418.   else
  1419.      WriteGroupElement(lDICOM3,-1,-1,lPos,$0002,$0010,'U','I','1.2.840.10008.1.2.2');//furezx should be 2//big xfer syntax
  1420.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0002,$0012,'U','I','999.999');//implicit xfer syntax
  1421.   lEnd := lPos;
  1422.   lPos := lStart;
  1423.   WriteGroupElement(lDICOM3,-1,lEnd-lStart-lGrpError,lPos,$0002,$0000,'U','L','');//length
  1424.   lPos := lEnd;
  1425. end;
  1426.   lStart := lPos;
  1427.   WriteGroupElement(lDICOM3,-1,18,lPos,$0008,$0000,'U','L','');//length
  1428. //DICOM part 3: 0008,0008 required for MR
  1429.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0008,'C','S','ORIGINAL\PRIMARY');//
  1430.  if not lDICOM3 then
  1431.      WriteGroupElement(lDICOM3,-1,2,lPos,$0008,$0010,'L','O','ACR-NEMA 2.0');//length
  1432.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0016,'U','I','1.2.840.10008.5.1.4.1.1.4');//
  1433.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0018,'U','I','999.999.2.19960619.163000.1.103');
  1434. //a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0020,'D','A','1995.06.26');//implicit xfer syntax
  1435. //a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0023,'D','A','1995.06.26');//implicit xfer syntax
  1436. //a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0030,'T','M','11:20:00');//implicit xfer syntax
  1437.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0060,'C','S','OT');//modality
  1438.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0070,'L','O','MRIcro');//modality
  1439. //a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0080,'L','O','Community Hospital');//modality
  1440. //a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0081,'S','T','Anytown');//modality
  1441.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$0090,'P','N','Anonymized');//name
  1442.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0008,$1030,'L','O','MRI');//modality
  1443.   lEnd := lPos;
  1444.   lPos := lStart;
  1445.   WriteGroupElement(lDICOM3,-1,lEnd-lStart-lGrpError,lPos,$0008,$0000,'U','L','');//length
  1446.   lPos := lEnd;
  1447.  
  1448.   lStart := lPos;
  1449.   WriteGroupElement(lDICOM3,-1,18,lPos,$0010,$0000,'U','L','');//length
  1450.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0010,$0010,'P','N','Anonymized');//name
  1451.   lEnd := lPos;
  1452.   lPos := lStart;
  1453.   WriteGroupElement(lDICOM3,-1,lEnd-lStart-lGrpError,lPos,$0010,$0000,'U','L','');//length
  1454.   lPos := lEnd;
  1455.  
  1456.   lStart := lPos;
  1457.   WriteGroupElement(lDICOM3,-1,18,lPos,$0018,$0000,'U','L','');//length
  1458. //z DICOM part 3: 0018,0020 required for MR
  1459. //z DICOM part 3: 0018,0021 required for MR
  1460. //z DICOM part 3: 0018,0022 required for MR
  1461. //z DICOM part 3: 0018,0023 required for MR
  1462.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0018,$0050,'D','S',floattostrf(pDicomData.XYZmm[3],ffFixed,8,2));//slice thickness
  1463. //z DICOM part 3: 0018,0080 required for MR
  1464. //z  WriteGroupElement(lDICOM3,-1,-1,lPos,$0018,$0080,'D','S',floattostrf(1333.33,ffFixed,8,2));//
  1465. //z DICOM part 3: 0018,0081 required for MR
  1466. //z  WriteGroupElement(lDICOM3,-1,-1,lPos,$0018,$0081,'D','S',floattostrf(11.98,ffFixed,8,2));//
  1467. //z DICOM part 3: 0018,0091 required for MR
  1468. WriteGroupElement(lDICOM3,-1,-1,lPos,$0018,$1020,'L','O',inttostr(pDicomData.XYZori[1])+'\'+inttostr(pDicomData.XYZori[2])+'\'+inttostr(pDicomData.XYZori[3]));//software version
  1469. //a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0018,$1149,'I','S','350');//Study UID
  1470.  
  1471. //b 0018,1314 found in demo MRs:
  1472. //a  WriteGroupElement(lDICOM3,-1,-1,lPos,$0018,$1314,'D','S','50');//
  1473.   lEnd := lPos;
  1474.   lPos := lStart;
  1475.   WriteGroupElement(lDICOM3,-1,lEnd-lStart-lGrpError,lPos,$0018,$0000,'U','L','');//length
  1476.   lPos := lEnd;
  1477.   lStart := lPos;
  1478.   WriteGroupElement(lDICOM3,-1,18,lPos,$0020,$0000,'U','L','');//length
  1479.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0020,$000D,'U','I','999.999.2.19960619.163000');//Study UID
  1480.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0020,$000E,'U','I','999.999.2.19960619.163000.1');//Study UID
  1481.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0020,$0011,'I','S','1');//Study UID
  1482.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0020,$0013,'I','S','103');//Study UID
  1483. //  WriteGroupElement(lDICOM3,-1,-1,lPos,$0020,$1041,'D','S',floattostrf(1-pDicomData.XYZdim[3],ffFixed,8,2));//$1041: info := 'Slice Location';
  1484.   lEnd := lPos;
  1485.   lPos := lStart;
  1486.   WriteGroupElement(lDICOM3,-1,lEnd-lStart-lGrpError,lPos,$0020,$0000,'U','L','');//length
  1487.   lPos := lEnd;
  1488.  
  1489.   lStart := lPos;
  1490.   WriteGroupElement(lDICOM3,-1,28,lPos,$0028,$0000,'U','L','');//length
  1491.   //0028,0002: set value to 1 [plane]: greyscale, required by DICOM part 3 for MR
  1492.   WriteGroupElement(lDICOM3,1,-1,lPos,$0028,$0002,'U','S','');
  1493.   //MONOCHROME1: low values = white, MONOCHROME2: low values = dark, 0028,0004 required for MR
  1494.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0028,$0004,'C','S','MONOCHROME2');
  1495.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0028,$0008,'I','S',inttostr(pDicomData.XYZdim[3]));//num frames
  1496.   //Part 3 of DICOM standard: 0028,0009 is REQUIRED for Multiframe images: 1063/18 for time, 1065/18 for time vector and 13/20 for image number [space]
  1497.   WriteGroupElement(lDICOM3,-1,($0013 shl 16)+($20 ),lPos,$0028,$0009,'A','T','');//frame ptr
  1498.   WriteGroupElement(lDICOM3,pDicomData.XYZdim[2],-1,lPos,$0028,$0010,'U','S',' ');//inttostr(lDicomData.XYZdim[2]));//row
  1499.   WriteGroupElement(lDICOM3,pDicomData.XYZdim[1],-1,lPos,$0028,$0011,'U','S',' ');//inttostr(lDicomData.XYZdim[1]));//col
  1500.   //0030 order: row spacing[y], column spacing[x]: see DICOM part 3
  1501.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0028,$0030,'D','S',floattostrf(pDicomData.XYZmm[2],ffFixed,8,2)+'\'+floattostrf(pDicomData.XYZmm[1],ffFixed,8,2));//pixel spacing
  1502. //DICOM part 3: 0028,0100 required for MR
  1503.   WriteGroupElement(lDICOM3,pDicomData.Allocbits_per_pixel,-1,lPos,$0028,$0100,'U','S',' ');//inttostr(lDicomData.Allocbits_per_pixel));//bitds alloc
  1504.   WriteGroupElement(lDICOM3,pDicomData.Storedbits_per_pixel,-1,lPos,$0028,$0101,'U','S',' ');//inttostr(lDicomData.Storedbits_per_pixel));//bits stored
  1505.   if pDicomData.little_endian <> 1 then
  1506.      lHiBit := 0
  1507.   else
  1508.       lHiBit := pDicomData.Storedbits_per_pixel -1;
  1509.   WriteGroupElement(lDICOM3,lHiBit,-1,lPos,$0028,$0102,'U','S',' ');//inttostr(lDicomData.Storedbits_per_pixel -1));//high bit
  1510.   WriteGroupElement(lDICOM3,0,-1,lPos,$0028,$0103,'U','S',' ');//pixel representation//inttostr(lDicomData.Storedbits_per_pixel -1));//high bit
  1511.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0028,$1052,'D','S',floattostrf(0,ffFixed,8,2));//rescale intercept
  1512.   WriteGroupElement(lDICOM3,-1,-1,lPos,$0028,$1053,'D','S',floattostrf(pDicomData.IntenScale,ffGeneral,7,2));//slice thickness
  1513.   lEnd := lPos;
  1514.   lPos := lStart;
  1515.   WriteGroupElement(lDICOM3,-1,lEnd-lStart-lGrpError,lPos,$0028,$0000,'U','L','');//length
  1516.   lPos := lEnd;
  1517.   WriteGroupElement(lDICOM3,-1,pDicomData.ImageSz+12,lPos,($7FE0),$0000,'U','L','');//data size
  1518.   if pDicomdata.Storedbits_per_pixel = 16 then
  1519.      WriteGroupElement(lDICOM3,-1,pDicomData.ImageSz,lPos,($7FE0),$0010,'O','W','')//data size
  1520.   else
  1521.       WriteGroupElement(lDICOM3,-1,pDicomData.ImageSz,lPos,($7FE0),$0010,'O','B','');//data size
  1522.   if lFileName <> '' then begin
  1523.      AssignFile(fp, lFileName);
  1524.      Rewrite(fp, 1);
  1525.      blockwrite(fp,lP^,lPos);
  1526.      close(fp);
  1527.   end;
  1528.   freemem(lP);
  1529.   lSz := lPos;
  1530. end;
  1531. //start siemens
  1532. procedure read_siemens_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string);
  1533. label
  1534.   567;
  1535. var
  1536.   lI: word;
  1537.  lYear,lMonth,lDay,n,filesz,lFullSz,lMatrixSz,lIHour,lIMin,lISec: LongInt;
  1538.   tx     : array [0..26] of Char;
  1539.   lMagField,lTE,lTR: double;
  1540.   lInstitution,lName, lID,lMinStr,lSecStr: String;
  1541.   FP: file;
  1542. function swap32i(lPos: longint): Longint;
  1543. type
  1544.   swaptype = packed record
  1545.     case byte of
  1546.       0:(Word1,Word2 : word); //word is 16 bit
  1547.       1:(Long:LongInt);
  1548.   end;
  1549.   swaptypep = ^swaptype;
  1550. var
  1551.    s : LongInt;
  1552.   inguy:swaptypep;
  1553.   outguy:swaptype;
  1554. begin
  1555.      seek(fp,lPos);
  1556.   BlockRead(fp, s, 4, n);
  1557.   inguy := @s; //assign address of s to inguy
  1558.   outguy.Word1 := swap(inguy^.Word2);
  1559.   outguy.Word2 := swap(inguy^.Word1);
  1560.   swap32i:=outguy.Long;
  1561. end;
  1562. function fswap8r (lPos: longint): double;
  1563. type
  1564.   swaptype = packed record
  1565.     case byte of
  1566.       0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit
  1567.       1:(float:double);
  1568.   end;
  1569.   swaptypep = ^swaptype;
  1570. var
  1571.    s:double;
  1572.   inguy:swaptypep;
  1573.   outguy:swaptype;
  1574. begin
  1575.      seek(fp,lPos);
  1576.   BlockRead(fp, s, 8, n);
  1577.   inguy := @s; //assign address of s to inguy
  1578.   outguy.Word1 := swap(inguy^.Word4);
  1579.   outguy.Word2 := swap(inguy^.Word3);
  1580.   outguy.Word3 := swap(inguy^.Word2);
  1581.   outguy.Word4 := swap(inguy^.Word1);
  1582.   fswap8r:=outguy.float;
  1583. end;
  1584. begin
  1585.   lImageFormatOK := true;
  1586.   lHdrOK := false;
  1587.   if not fileexists(lFileName) then begin
  1588.      lImageFormatOK := false;
  1589.      exit;
  1590.   end;
  1591.   FileMode := 0; //set to readonly
  1592.   AssignFile(fp, lFileName);
  1593.   Reset(fp, 1);
  1594.   FIleSz := FileSize(fp);
  1595.   Clear_Dicom_Data(lDicomData);
  1596.      if filesz < (6144) then begin
  1597.         showmessage('This file is to small to be a Siemens Magnetom Vision image.');
  1598.         goto 567;
  1599.      end;
  1600.      seek(fp, 96);
  1601.      BlockRead(fp, tx, 7*SizeOf(Char), n);
  1602.   if (tx[0] <> 'S') OR (tx[1] <> 'I') OR (tx[2] <> 'E') OR (tx[3] <> 'M') then begin {manufacturer is not SIEMENS}
  1603.         showmessage('Is this a Siemens Magnetom Vision image [Manufacturer tag should be ''SIEMENS''].');
  1604.         goto 567;
  1605.   end; {manufacturer not siemens}
  1606.   seek(fp, 105);
  1607.   BlockRead(fp, Tx, 25*SizeOf(Char), n);
  1608.   lINstitution := '';
  1609.   for lI := 0 to 24 do begin
  1610.       if tx[lI] in ['/','\','a'..'z','A'..'Z',' ','+','-','.',',','0'..'9'] then lINstitution := lINstitution + tx[lI];
  1611.   end;  seek(fp, 768);
  1612.   BlockRead(fp, Tx, 25*SizeOf(Char), n);
  1613.   lName := '';
  1614.   for lI := 0 to 24 do begin
  1615.       if tx[lI] in ['/','\','a'..'z','A'..'Z',' ','+','-','.',',','0'..'9'] then lName := lName + tx[lI];
  1616.   end;
  1617.   seek(fp, 795);
  1618.   BlockRead(fp, Tx, 12*SizeOf(Char), n);
  1619.   lID := '';
  1620.   for lI := 0 to 11 do begin
  1621.       if tx[lI] in ['/','\','a'..'z','A'..'Z',' ','+','-','.',',','0'..'9'] then lID := lID + tx[lI];
  1622.   end;
  1623.      lDicomData.ImageStart := 6144;
  1624.      lYear := swap32i(0);
  1625.      lMonth := swap32i(4);
  1626.      lDay := swap32i(8);
  1627.      lIHour := swap32i(68);
  1628.      lIMin := swap32i(72);
  1629.      lISec := swap32i(76);
  1630.      lDicomData.XYZmm[3] := fswap8r (1544);
  1631.      lMagField := fswap8r (2560);
  1632.      lTR := fswap8r (1560);
  1633.      lTE := fswap8r (1568);
  1634.      lMatrixSz := swap32i(2864);
  1635.      lFullSz := (2*lMatrixSz*lMatrixSz);//16bitdata
  1636.      if ((FileSz - 6144) mod lFullSz) = 0 then begin
  1637.         case ((FileSz-6144) div lFullSz) of
  1638.              4: lFullSz := 2*lMatrixSz;
  1639.              9: lFullSz := 3*lMatrixSz;
  1640.              16: lFullSz := 4*lMatrixSz;
  1641.              25: lFullSz := 5*lMatrixSz;
  1642.              36: lFullSz := 6*lMatrixSz;
  1643.              49: lFullSz := 7*lMatrixSz;
  1644.              64: lFullSz := 8*lMatrixSz;
  1645.              else lFullSz := lMatrixSz;
  1646.         end;
  1647.      end else lFullSz := lMatrixSz;
  1648.      {3744/3752 are XY FOV in mm!}
  1649.      lDicomData.XYZdim[1] := lFullSz;//lMatrixSz; //width
  1650.      lDicomData.XYZdim[2] := lFullSz;//lMatrixSz;//height
  1651.      {5000/5008 are size in mm, but wrong for mosaics}
  1652.      if lMatrixSz <> 0 then begin
  1653.         lDicomData.XYZmm[2] := fswap8r (3744)/lMatrixSz;
  1654.         lDicomData.XYZmm[1] := fswap8r (3752)/lMatrixSz;
  1655.      end;
  1656. {     lDicomData.XYZmm[2] := fswap8r (5000);
  1657.      lDicomData.XYZmm[1] := fswap8r (5008);}
  1658.      lDicomData.Allocbits_per_pixel := 16;//bits
  1659.      lDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel;
  1660.      lDicomData.GenesisCpt := false;
  1661.      lDicomData.GenesisPackHdr := 0;
  1662.      lMinStr := inttostr(lIMin);
  1663.      if length(lMinStr) = 1 then lMinStr := '0'+lMinStr;
  1664.      lSecStr := inttostr(lISec);
  1665.      if length(lSecStr) = 1 then lSecStr := '0'+lSecStr;
  1666.      lDynStr := 'Siemens Magnetom Vision Format'+kCR+'Name: '+lName+kCR+'ID: '+lID+kCR+'Institution: '+lInstitution+kCR+
  1667.      'Study DD/MM/YYYY: '+inttostr(lDay)+'/'+inttostr(lMonth)+'/'+inttostr(lYear)+kCR+
  1668.      'Image Hour/Min/Sec: '+inttostr(lIHour)+':'+lMinStr+':'+lSecStr+kCR+
  1669.      'Magnetic Field Strength: '+ floattostrf(lMagField,ffFixed,8,2)+kCR+
  1670.      'Time Repitition/Echo [TR/TE]: '+ floattostrf(lTR,ffFixed,8,2)+'/'+ floattostrf(lTE,ffFixed,8,2)+kCR+
  1671.      'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/'
  1672.      +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3])
  1673.      +kCR+'XYZ mm:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/'
  1674.      +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2);
  1675.   lHdrOK := true;
  1676. 567:
  1677.        CloseFile(fp);
  1678.   FileMode := 2; //set to read/write
  1679. end;
  1680. //end siemens
  1681. //start picker
  1682. procedure read_picker_data(lVerboseRead: boolean; var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string);
  1683. label 423;
  1684. const kPickerHeader =8192;
  1685. kRecStart = 280; //is this a constant?
  1686. var
  1687.   lDataStart,lVal,lDBPos,lPos,lRecSz, lNumRecs,lRec,FileSz,n: Longint;
  1688.   lThkM,lThkN,lSiz: double;
  1689.   tx     : array [0..6] of Char;
  1690.   FP: file;
  1691.   lDiskCacheRA: pChar;
  1692. function ReadRec(lRecNum: integer): boolean;
  1693. var
  1694.    lNameStr,lValStr: string;
  1695.    lOffset,lLen,lFPOs,lFEnd: integer;
  1696. function ValStrToFloat: double;
  1697. var lConvStr: string;
  1698.     lI: integer;
  1699. begin
  1700.      Result := 0.0;
  1701.      lLen := Length(lValStr);
  1702.      if lLen < 1 then exit;
  1703.      lConvStr := '';
  1704.      for lI := 1 to lLen do
  1705.          if lValStr[lI] in ['0'..'9'] then
  1706.             lConvStr := lConvStr+ lValStr[lI];
  1707.      if Length(lConvStr) < 1 then exit;
  1708.      Result := strtofloat(lConvStr);
  1709. end;
  1710. begin
  1711.   Result := false;
  1712.   lFPos := ((lRecNum-1) * lRecSz)+ kRecStart;
  1713.   lFEnd := lFpos + 6;
  1714.   lNameStr := '';
  1715.   for lFPos := lFPos to lFEnd do
  1716.          if ord(lDiskCacheRA[lFPos]) <> 0 then
  1717.             lNameStr := lNameStr +lDiskCacheRA[lFPos];
  1718.   if (lVerboseRead) or (lNameStr = 'RCNFSIZ') or (lNameStr='SCNTHKM') or (lNameStr='SCNTHKN') then begin
  1719.      lFPos := ((lRecNum-1) * lRecSz)+ kRecStart+8;
  1720.      lFEnd := lFPos+1;
  1721.      lOffset := 0;
  1722.      for lFPos := lFPos to lFend do
  1723.          lOffset := ((lOffset)shl 8)+(ord(lDiskCacheRA[lFPos]));
  1724.      lFPos := ((lRecNum-1) * lRecSz)+ kRecStart+10;
  1725.      lFEnd := lFPos+1;
  1726.      lLen := 0;
  1727.      for lFPos := lFPos to lFend do
  1728.          lLen := ((lLen)shl 8)+(ord(lDiskCacheRA[lFPos]));
  1729.      lOffset := lDataStart+lOffset+1;
  1730.      lFEnd := lOffset+lLen-1;
  1731.      if (lLen < 1) or  (lFEnd > kPickerHeader) then exit;
  1732.      lValStr := '';
  1733.      for lFPos := (lOffset) to lFEnd  do begin
  1734.          lValStr := lValStr+lDiskCacheRA[lFPos];
  1735.      end;
  1736.      if lVerboseRead then lDynStr := lDynStr+kCR+lNameStr+': '+ lValStr;
  1737.      if (lNameStr = 'RCNFSIZ') then lSiz := ValStrToFloat;
  1738.      if (lNameStr='SCNTHKM') then lThkM := ValStrToFloat;
  1739.      if (lNameStr='SCNTHKN') then lThkN := ValStrToFloat;
  1740.   end; //verboseread, or vital value
  1741.   result := true;
  1742. end;
  1743. function FindStr(l1,l2,l3,l4,l5: Char; lReadNum: boolean; var lNum: integer): boolean;
  1744. var //lMarker: integer;
  1745.     lNumStr: String;
  1746. begin
  1747.      Result := false;
  1748.      repeat
  1749.            if (lDiskCacheRA[lPos-4]=l1) and (lDiskCacheRA[lPos-3]=l2)
  1750.            and (lDiskCacheRA[lPos-2]=l3) and (lDiskCacheRA[lPos-1]=l4)
  1751.            and (lDiskCacheRA[lPos]=l5) then Result := true;
  1752.            inc (lPos);
  1753.      until (Result) or (lPos >= kPickerHeader);
  1754.      if not Result then exit;
  1755.      if not lReadNum then exit;
  1756.      Result := false;
  1757.      lNumStr := '';
  1758.      repeat
  1759.            if (lDiskCacheRA[lPos] in ['0'..'9']) then
  1760.            lNumStr := lNumStr + lDiskCacheRA[lPos]
  1761.            else if lNumStr <> '' then Result := true;
  1762.            inc(lPos);
  1763.      until (Result) or (lPos = kPickerHeader);
  1764.      lNum := strtoint(lNumStr);
  1765. end;
  1766. begin
  1767.   lSiz := 0.0;
  1768.   lThkM := 0.0;
  1769.   lThkN := 0.0;
  1770.   lImageFormatOK := true;
  1771.   lHdrOK := false;
  1772.   if not fileexists(lFileName) then begin
  1773.      lImageFormatOK := false;
  1774.      exit;
  1775.   end;
  1776.   FileMode := 0; //set to readonly
  1777.   AssignFile(fp, lFileName);
  1778.   Reset(fp, 1);
  1779.   FIleSz := FileSize(fp);
  1780.   Clear_Dicom_Data(lDicomData);
  1781.      if filesz < (kPickerHeader) then begin
  1782.         showmessage('This file is to small to be a Picker image.');
  1783.        CloseFile(fp);
  1784.        FileMode := 2; //set to read/write
  1785.        exit;
  1786.      end;
  1787.      seek(fp, 0);
  1788.      BlockRead(fp, tx, 4*SizeOf(Char), n);
  1789.      if (tx[0] <> '*') OR (tx[1] <> '*') OR (tx[2] <> '*') OR (tx[3] <> ' ') then begin {manufacturer is not SIEMENS}
  1790.         showmessage('Is this a Picker image? Expected ''*** '' at the start of the file.');
  1791.        CloseFile(fp);
  1792.        FileMode := 2; //set to read/write
  1793.        exit;
  1794.      end; {not picker}
  1795.      if filesz = (kPickerHeader + (1024*1024*2)) then begin
  1796.         lDICOMdata.XYZdim[1] := 1024;
  1797.         lDICOMdata.XYZdim[2] := 1024;
  1798.         lDICOMdata.XYZdim[3] := 1;
  1799.         lDICOMdata.ImageStart := 8192;
  1800.      end else
  1801.      if filesz = (kPickerHeader + (512*512*2)) then begin
  1802.         lDICOMdata.XYZdim[1] := 512;
  1803.         lDICOMdata.XYZdim[2] := 512;
  1804.         lDICOMdata.XYZdim[3] := 1;
  1805.         lDICOMdata.ImageStart := 8192;
  1806.      end else
  1807.      if filesz = (8192 + (256*256*2)) then begin
  1808.         lDICOMdata.XYZdim[1] := 256;
  1809.         lDICOMdata.XYZdim[2] := 256;
  1810.         lDICOMdata.XYZdim[3] := 1;
  1811.         lDICOMdata.ImageStart := 8192;
  1812.      end else begin
  1813.         showmessage('This file is the incorrect size to be a Picker image.');
  1814.        CloseFile(fp);
  1815.        FileMode := 2; //set to read/write
  1816.        exit;
  1817.      end;
  1818.      getmem(lDiskCacheRA,kPickerHeader*sizeof(char));
  1819.      seek(fp, 0);
  1820.      BlockRead(fp, lDiskCacheRA^, kPickerHeader, n);
  1821.      lRecSz := 0;
  1822.      lNumRecs := 0;
  1823.      lPos := 5;
  1824.      if not FindStr('d','b','r','e','c',false, lVal) then goto 423;
  1825.      lDBPos := lPos;
  1826.      if not FindStr('r','e','c','s','z',true, lRecSz) then goto 423;
  1827.      lPos := lDBPos;
  1828.      if not FindStr('n','r','e','c','s',true, lnumRecs) then goto 423;
  1829.      lPos := kRecStart; // IS THIS A CONSTANT???
  1830.      lDataStart :=kRecStart + (lRecSz*lnumRecs)-1; //file starts at 0, so -1
  1831.      if (lNumRecs = 0) or (lDataStart> kPickerHeader) then goto 423;
  1832.      lRec := 0;
  1833.      lDynStr := 'Picker Format';
  1834.      repeat
  1835.           inc(lRec);
  1836.      until (not (ReadRec(lRec))) or (lRec >= lnumRecs);
  1837.      if lSiz <> 0 then begin
  1838.         lDICOMdata.XYZmm[1] := lSiz/lDICOMdata.XYZdim[1];
  1839.         lDICOMdata.XYZmm[2] := lSiz/lDICOMdata.XYZdim[2];
  1840.         if lVerboseRead then
  1841.            lDynStr := lDynStr+kCR+'Voxel Size: '+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)
  1842.            +'x'+ floattostrf(lDicomData.XYZmm[2],ffFixed,8,2);
  1843.      end;
  1844.      if (lThkM <> 0) and (lThkN <> 0) then begin
  1845.         lDICOMdata.XYZmm[3] := lThkN/lThkM;
  1846.         if lVerboseRead then
  1847.            lDynStr := lDynStr+kCR+'Slice Thickness: '+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2);
  1848.      end;
  1849.   423:
  1850.      freemem(lDiskCacheRA);
  1851.      lHdrOK := true;
  1852.      CloseFile(fp);
  1853.      FileMode := 2; //set to read/write
  1854. end;
  1855. //end picker
  1856. (*procedure read_picker_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string);
  1857. var
  1858.   FileSz,n: Longint;
  1859.   tx     : array [0..6] of Char;
  1860.   FP: file;
  1861. begin
  1862.   lImageFormatOK := true;
  1863.   lHdrOK := false;
  1864.   if not fileexists(lFileName) then begin
  1865.      lImageFormatOK := false;
  1866.      exit;
  1867.   end;
  1868.   FileMode := 0; //set to readonly
  1869.   AssignFile(fp, lFileName);
  1870.   Reset(fp, 1);
  1871.   FIleSz := FileSize(fp);
  1872.   Clear_Dicom_Data(lDicomData);
  1873.      if filesz < (8192) then begin
  1874.         showmessage('This file is to small to be a Picker image.');
  1875.        CloseFile(fp);
  1876.        FileMode := 2; //set to read/write
  1877.        exit;
  1878.      end;
  1879.      seek(fp, 0);
  1880.      BlockRead(fp, tx, 4*SizeOf(Char), n);
  1881.      if (tx[0] <> '*') OR (tx[1] <> '*') OR (tx[2] <> '*') OR (tx[3] <> ' ') then begin {manufacturer is not SIEMENS}
  1882.         showmessage('Is this a Picker image? Expected ''*** '' at the start of the file.');
  1883.        CloseFile(fp);
  1884.        FileMode := 2; //set to read/write
  1885.        exit;
  1886.      end; {not picker}
  1887.      if filesz = (8192 + (1024*1024*2)) then begin
  1888.         lDICOMdata.XYZdim[1] := 1024;
  1889.         lDICOMdata.XYZdim[2] := 1024;
  1890.         lDICOMdata.XYZdim[3] := 1;
  1891.         lDICOMdata.ImageStart := 8192;
  1892.      end else
  1893.      if filesz = (8192 + (512*512*2)) then begin
  1894.         lDICOMdata.XYZdim[1] := 512;
  1895.         lDICOMdata.XYZdim[2] := 512;
  1896.         lDICOMdata.XYZdim[3] := 1;
  1897.         lDICOMdata.ImageStart := 8192;
  1898.      end else
  1899.      if filesz = (8192 + (256*256*2)) then begin
  1900.         lDICOMdata.XYZdim[1] := 256;
  1901.         lDICOMdata.XYZdim[2] := 256;
  1902.         lDICOMdata.XYZdim[3] := 1;
  1903.         lDICOMdata.ImageStart := 8192;
  1904.      end else begin
  1905.         showmessage('This file is the incorrect size to be a Picker image.');
  1906.        CloseFile(fp);
  1907.        FileMode := 2; //set to read/write
  1908.      end;
  1909.      if not gSizeMMWarningShown then begin
  1910.         gSizeMMWarningShown := true;
  1911.         showmessage('Warning: this software does not read the size[mm] fields for Picker images.');
  1912.      end;
  1913.      lDynStr := 'Picker Format'+kCR+     'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/'
  1914.      +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3])
  1915.      +kCR+'XYZ mm:'+{floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)}'?'+'/?/?'
  1916.      +kCR+'VOXEL SIZE[mm] UNKNOWN';
  1917.   lHdrOK := true;
  1918.        CloseFile(fp);
  1919.   FileMode := 2; //set to read/write
  1920. end;*)
  1921.  
  1922.  
  1923. 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);
  1924. label 666,777;
  1925. const
  1926. kMaxTextBuf = 50000; //maximum for screen output
  1927. kDiskCache = 16384; //size of disk buffer
  1928. type
  1929.   dicom_types = (unknown, i8, i16, i32, ui8, ui16, ui32, _string );
  1930. var
  1931.  lWord: word;
  1932.  lWordRA: Wordp;
  1933.  lDiskCacheRA: pChar{ByteP};
  1934.    FP: file;
  1935.    lT0,lT1,lT2,lT3:byte;
  1936.    lTextOverFlow,lGenesis,lFirstPass,lrOK,lBig,lBigSet,lGrp,explicitVR,first_one    : Boolean;
  1937.   {lTestError,}lByteSwap,lGELX,time_to_quit,lFirstFragment : Boolean;
  1938.   group, element, dummy, e_len, remaining, tmp : uint32;
  1939.   lgrpstr,tmpstr,lStr,info   : string;
  1940.   t      : dicom_types;
  1941.   lfloat1,lfloat2: double;
  1942.   lJPEGentries,lErr,liPos,lCacheStart,lCachePos,lDiskCacheSz,n, i,j,value, Width, max16,min16,slicesz,filesz,where,lStart,lEnd : LongInt;
  1943.   tx     : array [0..21] of Char;
  1944.   buff: pCHar;
  1945.   lColorRA: bytep;
  1946. procedure ByteSwap (var lInOut: integer);
  1947. var lWord: word;
  1948. begin
  1949.      lWord := lInOut;
  1950.      lWord := swap(lWord);
  1951.      lInOut := lWord;
  1952. end;
  1953. procedure dReadCache (lFileStart: integer);
  1954. begin
  1955.   lCacheStart := lFileStart{lCacheStart + lDiskCacheSz};//eliminate old start
  1956.   if lCacheStart < 0 then lCacheStart := 0;
  1957.   if lDiskCacheSz > 0 then freemem(lDiskCacheRA);
  1958.   if (FileSz-(lCacheStart)) < kDiskCache then
  1959.      lDiskCacheSz := FileSz - (lCacheStart)
  1960.   else
  1961.       lDiskCacheSz := kDiskCache;
  1962.   lCachePos := 0;
  1963.   if (lDiskCacheSz < 1) then exit{goto 666};
  1964.   if (lDiskCacheSz+lCacheStart) > FileSz then exit;
  1965.    //showmessage(inttostr(FileSz)+' / '+INTTOSTR(lDiskCacheSz)+ ' / '+inttostr(lCacheStart));
  1966.   Seek(fp, lCacheStart);
  1967.   GetMem(lDiskCacheRA, lDiskCacheSz {bytes});
  1968.   BlockRead(fp, lDiskCacheRA^, lDiskCacheSz, n);
  1969. end;
  1970.  
  1971. function dFilePos (var lInFP: file): integer;
  1972. begin
  1973.      Result := lCacheStart + lCachePos;
  1974. end;
  1975. procedure dSeek (var lInFP: file; lPos: integer);
  1976. begin
  1977.   if (lPos >= lCacheStart) and (lPos < (lDiskCacheSz+lCacheStart)) then begin
  1978.      lCachePos := lPos-lCacheStart;
  1979.      exit;
  1980.   end;
  1981.   dReadCache(lPos);
  1982. end;
  1983.  
  1984. procedure dBlockRead (var lInfp: file; lInbuff: pChar; e_len: integer; var n: integer);
  1985. var lN: integer;
  1986. begin
  1987.      N := 0;
  1988.      if e_len < 0 then exit;
  1989.      for lN := 0 to (e_len-1) do begin
  1990.          if lCachePos >= lDiskCacheSz then begin
  1991.             dReadCache(lCacheStart+lDiskCacheSz);
  1992.             if lDiskCacheSz < 1 then exit;
  1993.             lCachePos := 0;
  1994.          end;
  1995.          N := lN;
  1996.          lInBuff[N] := lDiskCacheRA[lCachePos];
  1997.          inc(lCachePos);
  1998.      end;
  1999. end;
  2000. procedure readfloats (var fp: file; remaining: integer; var lOutStr: string; var lf1, lf2: double; var lReadOK: boolean);
  2001. var  lDigit : boolean;
  2002.    li,lLen,n: integer;
  2003.     lfStr: string;
  2004. begin
  2005.     lf1 := 1;
  2006.     lf2 := 2;
  2007.     if e_len = 0 then begin
  2008.        lReadOK := true;
  2009.        exit;
  2010.     end;
  2011.     if (dFilePos(fp) > (filesz-remaining)) or (remaining < 1) then begin
  2012.        lOutStr := '';
  2013.        lReadOK := false;
  2014.        exit;
  2015.     end else
  2016.         lReadOK := true;
  2017.  
  2018.     lOutStr := '';
  2019.     GetMem( buff, e_len);
  2020.     dBlockRead(fp, buff{^}, e_len, n);
  2021.     for li := 0 to e_len-1 do
  2022.         if Char(buff[li]) in ['/','\','e','E','+','-','.','0'..'9']
  2023.            then lOutStr := lOutStr +(Char(buff[li]))
  2024.         else lOutStr := lOutStr + ' ';
  2025.     FreeMem( buff);
  2026.     lfStr := '';
  2027.     lLen := length(lOutStr);
  2028.     li := 1;
  2029.     lDigit := false;
  2030.     repeat
  2031.       if (lOutStr[li] in ['+','-','e','E','.','0'..'9']) then
  2032.          lfStr := lfStr + lOutStr[li];
  2033.       if lOutStr[li] in ['0'..'9'] then lDigit := true;
  2034.       inc(li);
  2035.     until (li > lLen) or (lDigit);
  2036.     if not lDigit then exit;
  2037.     if li <= li then begin
  2038.        repeat
  2039.              if not (lOutStr[li] in ['+','-','e','E','.','0'..'9']) then lDigit := false
  2040.              else begin
  2041.                   if lOutStr[li] = 'E' then lfStr := lfStr+'e'
  2042.                   else
  2043.                       lfStr := lfStr + lOutStr[li];
  2044.              end;
  2045.              inc(li);
  2046.        until (li > lLen) or (not lDigit);
  2047.     end;
  2048.     //QStr(lfStr);
  2049.     try
  2050.        lf1 := strtofloat(lfStr);
  2051.     except
  2052.           on EConvertError do begin
  2053.              showmessage('Unable to convert the string '+lfStr+' to a real number');
  2054.              lf1 := 1;
  2055.              exit;
  2056.           end;
  2057.     end; {except}
  2058.     lfStr := '';
  2059.     if li > llen then exit;
  2060.     repeat
  2061.              if (lOutStr[li] in ['+','E','e','.','-','0'..'9']) then begin
  2062.                   if lOutStr[li] = 'E' then lfStr := lfStr+'e'
  2063.                   else
  2064.                       lfStr := lfStr + lOutStr[li];
  2065.              end;
  2066.              if (lOutStr[li] in ['0'..'9']) then lDigit := true;
  2067.              inc(li);
  2068.     until (li > lLen);
  2069.     if not lDigit then exit;
  2070.     //QStr(lfStr);
  2071.     try
  2072.        lf2 := strtofloat(lfStr);
  2073.     except
  2074.           on EConvertError do begin
  2075.              showmessage('Unable to convert the string '+lfStr+' to a real number');
  2076.              exit;
  2077.           end;
  2078.     end;
  2079.  
  2080. end;
  2081. function read16( var fp : File; var lReadOK: boolean ): uint16;
  2082. var
  2083.     t1, t2 : uint8;
  2084.   n      : Integer;
  2085. begin
  2086. if dFilePos(fp) > (filesz-2) then begin
  2087.    read16 := 0;
  2088.    lReadOK := false;
  2089.    exit;
  2090. end else
  2091.     lReadOK := true;
  2092.     GetMem( buff, 2);
  2093.     dBlockRead(fp, buff{^}, 2, n);
  2094.     T1 := ord(buff[0]);
  2095.     T2 := ord(buff[1]);
  2096.     freemem(buff);
  2097.     if lDICOMdata.little_endian <> 0
  2098.       then Result := (t1 + t2*256) AND $FFFF
  2099.       else Result := (t1*256 + t2) AND $FFFF;
  2100. end;
  2101.  
  2102. function  ReadStr(var fp: file; remaining: integer; var lReadOK: boolean) : string;
  2103. var lInc, lN,Val,n: integer;
  2104.     t1, t2 : uint8;
  2105.      lStr : String;
  2106. begin
  2107. if dFilePos(fp) > (filesz-remaining) then begin
  2108.    lReadOK := false;
  2109.    exit;
  2110. end else
  2111.     lReadOK := true;
  2112.     Result := '';
  2113.     lN := remaining div 2;
  2114.     if lN < 1 then exit;
  2115.     lStr := '';
  2116.     for lInc := 1 to lN do begin
  2117.     GetMem( buff, 2);
  2118.     dBlockRead(fp, buff{^}, 2, n);
  2119.     T1 := ord(buff[0]);
  2120.     T2 := ord(buff[1]);
  2121.     freemem(buff);
  2122.      if lDICOMdata.little_endian <> 0 then
  2123.         Val := (t1 + t2*256) AND $FFFF
  2124.      else
  2125.          Val := (t1*256 + t2) AND $FFFF;
  2126.      if lInc < lN then lStr := lStr + inttostr(Val)+ ', '
  2127.      else lStr := lStr + inttostr(Val);
  2128.     end;
  2129.     Result := lStr;
  2130.     if odd(remaining) then begin
  2131.            getmem(buff,1);
  2132.        dBlockRead(fp, buff{t1}, SizeOf(uint8), n);
  2133.            freemem(buff);
  2134.     end;
  2135. end;
  2136. function  ReadStrHex(var fp: file; remaining: integer; var lReadOK: boolean) : string;
  2137. var lInc, lN,Val,n: integer;
  2138.     t1, t2 : uint8;
  2139.      lStr : String;
  2140. begin
  2141. if dFilePos(fp) > (filesz-remaining) then begin
  2142.    lReadOK := false;
  2143.    exit;
  2144. end else
  2145.     lReadOK := true;
  2146.     Result := '';
  2147.     lN := remaining div 2;
  2148.     if lN < 1 then exit;
  2149.     lStr := '';
  2150.     for lInc := 1 to lN do begin
  2151.          GetMem( buff, 2);
  2152.     dBlockRead(fp, buff, 2, n);
  2153.     T1 := ord(buff[0]);
  2154.     T2 := ord(buff[1]);
  2155.     freemem(buff);
  2156.      if lDICOMdata.little_endian <> 0 then
  2157.         Val := (t1 + t2*256) AND $FFFF
  2158.      else
  2159.          Val := (t1*256 + t2) AND $FFFF;
  2160.      if lInc < lN then lStr := lStr + 'x'+inttohex(Val,4)+ ', '
  2161.      else lStr := lStr + 'x'+inttohex(Val,4);
  2162.     end;
  2163.     Result := lStr;
  2164.     if odd(remaining) then begin
  2165.        getmem(buff,1);
  2166.        dBlockRead(fp, {t1}buff, SizeOf(uint8), n);
  2167.        freemem(buff);
  2168.     end;
  2169. end;
  2170. function SomaTomFloat: double;
  2171. var lSomaStr: String;
  2172. begin
  2173.      //dSeek(fp,5992); //Slice Thickness from 5790 "SL   3.0"
  2174.      //dSeek(fp,5841); //Field of View from 5838 "FoV   281"
  2175.      //dSeek(fp,lPos);
  2176.      lSomaStr := '';
  2177.      tx[0] := 'x';
  2178.      while (length(lSomaStr) < 64) and (tx[0] <> chr(0))  and (tx[0] <> '/') do begin
  2179.                 dBlockRead(fp, tx, 1, n);
  2180.                 if tx[0] in ['+','-','.','0'..'9','e','E'] then
  2181.                    lSomaStr := lSomaStr + tx[0];
  2182.      end;
  2183.      //showmessage(lSomaStr+':'+inttostr(length(lSOmaStr)));
  2184.      //showmessage(inttostr(length(lSOmaStr)));
  2185.  
  2186.      if length(lSOmaStr) > 0 then
  2187.         result := StrToFloat(lSomaStr)
  2188.      else      
  2189.          result := 0;
  2190. end;
  2191. function read32 ( var fp : File; var lReadOK: boolean ): uint32;
  2192. var
  2193.     t1, t2, t3, t4 : byte;
  2194.   n : Integer;
  2195. begin
  2196. if dFilePos(fp) > (filesz-4) then begin
  2197.    Read32 := 0;
  2198.    lReadOK := false;
  2199.    exit;
  2200. end else
  2201.     lReadOK := true;
  2202.     GetMem( buff, 4);
  2203.     dBlockRead(fp, buff{^}, 4, n);
  2204.     T1 := ord(buff[0]);
  2205.     T2 := ord(buff[1]);
  2206.     T3 := ord(buff[2]);
  2207.     T4 := ord(buff[3]);
  2208.     freemem(buff);
  2209.     if lDICOMdata.little_endian <> 0 then
  2210.         Result := t1 + (t2 shl 8) + (t3 shl 16) + (t4 shl 24)
  2211.     else
  2212.         Result := t4 + (t3 shl 8) + (t2 shl 16) + (t1 shl 24)
  2213.     //if lDICOMdata.little_endian <> 0
  2214.     //then Result := (t1 + t2*256 + t3*256*256 + t4*256*256*256) AND $FFFFFFFF
  2215.     //else Result := (t1*256*256*256 + t2*256*256 + t3*256 + t4) AND $FFFFFFFF;
  2216. end;
  2217.  
  2218. function read64 ( var fp : File; var lReadOK: boolean ): double;
  2219. type
  2220.   swaptype = packed record
  2221.     case byte of
  2222.       0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit
  2223.       1:(float:double);
  2224.   end;
  2225.   swaptypep = ^swaptype;
  2226. var
  2227.    s:double;
  2228.   inguy:swaptypep;
  2229.   outguy:swaptype;
  2230. begin
  2231.   if dFilePos(fp) > (filesz-8) then begin
  2232.      Read64 := 0;
  2233.      lReadOK := false;
  2234.      exit;
  2235.   end else
  2236.     lReadOK := true;
  2237.     //GetMem( buff, 8);
  2238.   dBlockRead(fp, @s, 8, n);
  2239.   inguy := @s; //assign address of s to inguy
  2240.   if lDICOMdata.little_endian <> 1 then begin
  2241.      outguy.Word1 := swap(inguy^.Word4);
  2242.      outguy.Word2 := swap(inguy^.Word3);
  2243.      outguy.Word3 := swap(inguy^.Word2);
  2244.      outguy.Word4 := swap(inguy^.Word1);
  2245.   end;
  2246.   read64:=outguy.float;
  2247. end;
  2248.  
  2249.  
  2250. begin
  2251.   //lTestError := false;
  2252.   lCacheStart := 0;
  2253.   lDiskCacheSz := 0;
  2254.   lFirstFragment := true;
  2255.   lTextOverFlow := false;
  2256.   lImageFormatOK := true;
  2257.   lHdrOK := false;
  2258.   if not fileexists(lFileName) then begin
  2259.      lImageFormatOK := false;
  2260.      exit;
  2261.   end;
  2262.   lGELX := false;
  2263.   lByteSwap := false;
  2264.   Clear_Dicom_Data(lDicomData);
  2265.   FileMode := 0; //set to readonly
  2266.   AssignFile(fp, lFileName);
  2267.   Reset(fp, 1);
  2268.   FIleSz := FileSize(fp);
  2269.   if fileSz < 1 then begin
  2270.      lImageFormatOK := false;
  2271.      exit;
  2272.   end;
  2273.      lDICOMdata.Little_Endian := 1;
  2274.   lDynStr:= '';
  2275.   lJPEGEntries := 0;
  2276.   first_one    := true;
  2277.   info := '';
  2278.   lGrp:= false;
  2279.   lBigSet := false;
  2280.   if (lAutoDetectGenesis) and (FileSz > (5820{114+35+4})) then begin
  2281.      dseek(fp, 0);
  2282.      dBlockRead(fp, tx, 4*SizeOf(Char), n);
  2283.      //showmessage(tx[0]+tx[1]+tx[2]+tx[3]);
  2284.      lGenesis := false;
  2285.      if ((tx[0] <> 'I') OR (tx[1] <> 'M') OR (tx[2] <> 'G') OR (tx[3] <> 'F')) then begin {DAT format}
  2286.         {if (FileSz > 114+305+4) then begin
  2287.            dseek(fp, 114+305);
  2288.            dBlockRead(fp, tx, 3*SizeOf(Char), n);
  2289.            if ((tx[0]='M') and (tx[1] = 'R')) or ((tx[0] = 'C') and(tx[1] = 'T')) then
  2290.               lGenesis := true;
  2291.         end;}
  2292.      end else
  2293.          lGenesis := true;
  2294.      if (not lGenesis) and (FileSz > 3252) then begin
  2295.         dseek(fp, 3240);
  2296.         dBlockRead(fp, tx, 4*SizeOf(Char), n);
  2297.         if ((tx[0] = 'I') AND (tx[1] = 'M')AND (tx[2] = 'G') AND (tx[3] = 'F')) then
  2298.            lGenesis := true;
  2299.         if (not lGenesis) then begin
  2300.            dseek(fp, 3178);
  2301.            dBlockRead(fp, tx, 4*SizeOf(Char), n);
  2302.            if ((tx[0] = 'I') AND (tx[1] = 'M')AND (tx[2] = 'G') AND (tx[3] = 'F')) then
  2303.               lGenesis := true;
  2304.         end;
  2305.         if (not lGenesis) then begin
  2306.            dseek(fp, 3180);
  2307.            dBlockRead(fp, tx, 4*SizeOf(Char), n);
  2308.            if ((tx[0] = 'I') AND (tx[1] = 'M')AND (tx[2] = 'G') AND (tx[3] = 'F')) then
  2309.               lGenesis := true;
  2310.         end;
  2311.  
  2312.      end;
  2313.      if (not lGenesis) and (FileSz > 3252) then begin
  2314.            dseek(fp, 3228);
  2315.            dBlockRead(fp, tx, 4*SizeOf(Char), n);
  2316.            if (tx[0] = 'I') AND (tx[1]= 'M') AND (tx[2] = 'G')AND (tx[3]= 'F') then
  2317.               lGenesis := true;
  2318.      end;
  2319.      if lGenesis then begin
  2320.         CloseFile(fp);
  2321.         if lDiskCacheSz > 0 then
  2322.            freemem(lDiskCacheRA);
  2323.         FileMode := 2; //set to read/write
  2324.         read_ge_data(lDICOMdata, lHdrOK, lImageFormatOK,lDynStr,lFileName);
  2325.         exit;
  2326.      end;
  2327.   end;
  2328.   //AutodetectGenesis
  2329.  
  2330.   if (lAutoDetectInterfile) and (FileSz > 30) then begin
  2331.      dseek(fp, 0);
  2332.      dBlockRead(fp, tx, 20*SizeOf(Char), n);
  2333.      liPos := 1;
  2334.      lStr :='';
  2335.      While (liPos <= 20) and (lStr <> 'INTERFILE') do begin
  2336.         if tx[liPos] in ['i','n','t','e','r', 'f','i','l','e','I','N','T','E','R', 'F','I','L','E'] then
  2337.            lStr := lStr+upcase(tx[liPos]);
  2338.         inc(liPos);
  2339.      end;
  2340.      if lStr = 'INTERFILE' then begin
  2341.         CloseFile(fp);
  2342.         if lDiskCacheSz > 0 then
  2343.            freemem(lDiskCacheRA);
  2344.         FileMode := 2; //set to read/write
  2345.         read_interfile_data(lDICOMdata, lHdrOK, lImageFormatOK, lDynStr, lFileName);
  2346.         if lHdrOk then exit;
  2347.         exit;
  2348.      end; //'INTERFILE' in first 20 char
  2349.      //begin parfile
  2350.      liPos := 1;
  2351.      lStr :='';
  2352.      While (liPos <= 20) and (lStr <> 'DATADESC') do begin
  2353.         if tx[liPos] in ['A'..'Z','a'..'z'] then
  2354.            lStr := lStr+upcase(tx[liPos]);
  2355.         inc(liPos);
  2356.      end;
  2357.      if lStr = 'DATADESC' then begin
  2358.         CloseFile(fp);
  2359.         if lDiskCacheSz > 0 then
  2360.            freemem(lDiskCacheRA);
  2361.         FileMode := 2; //set to read/write
  2362.         read_par_data(lDICOMdata, lHdrOK, lImageFormatOK, lDynStr, lFileName);
  2363.         if lHdrOk then exit;
  2364.         exit;
  2365.      end; //'DATADESC' in first 20 char ->parfile
  2366.      //end parfile
  2367.   end;//detectint
  2368.   // try DICOM part 10 i.e. a 128 byte file preamble followed by "DICM"
  2369.   if filesz <= 300 then goto 666;
  2370.   {begin siemens somatom: DO THIS BEFORE MAGNETOM: BOTH HAVE 'SIEMENS' SIGNATURE, SO CHECK FOR 'SOMATOM'}
  2371.   if filesz = 530432 then begin
  2372.      dseek(fp, 281);
  2373.      dBlockRead(fp, tx, 8*SizeOf(Char), n);
  2374.      if (tx[0] = 'S') and (tx[1] = 'O') and (tx[2] = 'M') and (tx[3] = 'A') and (tx[4] = 'T') and (tx[5] = 'O') and (tx[6] = 'M') then begin
  2375.         //Showmessage('somatom');
  2376.         lDicomData.ImageStart := 6144;
  2377.         lDicomData.Allocbits_per_pixel := 16;
  2378.         lDicomData.Storedbits_per_pixel := 16;
  2379.         lDicomData.little_endian := 0;
  2380.         lDicomData.XYZdim[1] := 512;
  2381.         lDicomData.XYZdim[2] := 512;
  2382.         lDicomData.XYZdim[3] := 1;
  2383.         dSeek(fp,5999); //Study/Image from 5292 "STU/IMA   1070/16"
  2384.         lDicomData.AcquNum := trunc(SomaTomFloat);//Slice Thickness from 5790 "SL   3.0"
  2385.         lDicomData.ImageNum := trunc(SomaTomFloat);//Slice Thickness from 5790 "SL   3.0"
  2386.         dSeek(fp,5792); //Slice Thickness from 5790 "SL   3.0"
  2387.         lDicomData.XYZmm[3] := SomaTomFloat;//Slice Thickness from 5790 "SL   3.0"
  2388.         dSeek(fp,5841); //Field of View from 5838 "FoV   281"
  2389.         lDicomData.XYZmm[1] := SomaTomFloat; //Field of View from 5838 "FoV   281"
  2390.         lDicomData.XYZmm[2] := lDicomData.XYZmm[1]/lDicomData.XYZdim[2];//do mm[2] first before FOV is overwritten
  2391.         lDicomData.XYZmm[1] := lDicomData.XYZmm[1]/lDicomData.XYZdim[1];
  2392.         if lVerboseRead then
  2393.            lDynStr := 'Siemens Somatom Format'+kCR+
  2394.            'Image Series/Number: '+inttostr(lDicomData.AcquNum)+'/'+inttostr(lDicomData.ImageNum)+kCR+
  2395.            'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/'
  2396.            +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3])
  2397.            +kCR+'XYZ mm:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/'
  2398.            +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2);
  2399.         CloseFile(fp);
  2400.         if lDiskCacheSz > 0 then
  2401.            freemem(lDiskCacheRA);
  2402.         FileMode := 2; //set to read/write
  2403.         lImageFormatOK := true;
  2404.         lHdrOK := true;
  2405.         exit;
  2406.      end; //signature found
  2407.   end; //correctsize for somatom
  2408.   {end siemens somatom}
  2409.  
  2410. {siemens magnetom}
  2411.   dseek(fp,96);
  2412.   dBlockRead(fp, tx, 7*SizeOf(Char), n);
  2413.   if (tx[0] = 'S') and (tx[1] = 'I') and (tx[2] = 'E') and (tx[3] = 'M') and (tx[4] = 'E') and (tx[5] = 'N') and (tx[6] = 'S') then begin
  2414.         CloseFile(fp);
  2415.         if lDiskCacheSz > 0 then
  2416.            freemem(lDiskCacheRA);
  2417.         FileMode := 2; //set to read/write
  2418.         read_siemens_data(lDICOMdata, lHdrOK, lImageFormatOK, lDynStr, lFileName);
  2419.         exit;
  2420.   end;
  2421.   {end siemens magnetom vision}
  2422.   {siemens somatom plus}
  2423.      dseek(fp, 0);
  2424.      dBlockRead(fp, tx, 8*SizeOf(Char), n);
  2425.   if (tx[0] = 'S') and (tx[1] = 'I') and (tx[2] = 'E') and (tx[3] = 'M') and (tx[4] = 'E') and (tx[5] = 'N') and (tx[6] = 'S') then begin
  2426.         lDicomData.ImageStart := 8192;
  2427.         lDicomData.Allocbits_per_pixel := 16;
  2428.         lDicomData.Storedbits_per_pixel := 16;
  2429.         lDicomData.little_endian := 0;
  2430.         dseek(fp, 1800); //slice thickness
  2431.         lDicomData.XYZmm[3] := read64(fp,lrOK);
  2432.         dseek(fp, 4100);
  2433.         lDicomData.AcquNum := read32(fp,lrOK);
  2434.         dseek(fp, 4108);
  2435.         lDicomData.ImageNum := read32(fp,lrOK);
  2436.         dseek(fp, 4992); //X FOV
  2437.         lDicomData.XYZmm[1] := read64(fp,lrOK);
  2438.         dseek(fp, 5000); //Y FOV
  2439.         lDicomData.XYZmm[2] := read64(fp,lrOK);
  2440.         dseek(fp, 5340);
  2441.         lDicomData.XYZdim[1] := read32(fp,lrOK);
  2442.         dseek(fp, 5344);
  2443.         lDicomData.XYZdim[2] := read32(fp,lrOK);
  2444.         lDicomData.XYZdim[3] := 1;
  2445.         if lDicomData.XYZdim[1] > 0 then
  2446.            lDicomData.XYZmm[1] := lDicomData.XYZmm[1]/lDicomData.XYZdim[1];
  2447.         if lDicomData.XYZdim[2] > 0 then
  2448.            lDicomData.XYZmm[2] := lDicomData.XYZmm[2]/lDicomData.XYZdim[2];
  2449.         if lVerboseRead then
  2450.            lDynStr := 'Siemens Somatom Plus Format'+kCR+
  2451.      'Image Series/Number: '+inttostr(lDicomData.AcquNum)+'/'+inttostr(lDicomData.ImageNum)+kCR+
  2452.      'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/'
  2453.      +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3])
  2454.      +kCR+'XYZ mm:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/'
  2455.      +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2);
  2456.  
  2457.         CloseFile(fp);
  2458.         if lDiskCacheSz > 0 then
  2459.            freemem(lDiskCacheRA);
  2460.         FileMode := 2; //set to read/write
  2461.         lImageFormatOK := true;
  2462.         lHdrOK := true;
  2463.         exit;
  2464.   end;
  2465.   {end siemens somatom plus }
  2466.   {picker}
  2467.   dseek(fp,0);
  2468.   dBlockRead(fp, tx, 8*SizeOf(Char), n);
  2469.   if (lAutoDECAT7) and (tx[0]='M') and (tx[1]='A') and (tx[2]='T') and (tx[3]='R') and (tx[4]='I') and (tx[5]='X') then begin
  2470.         CloseFile(fp);
  2471.         if lDiskCacheSz > 0 then
  2472.            freemem(lDiskCacheRA);
  2473.         FileMode := 2; //set to read/write
  2474.         read_ecat_data(lDICOMdata, lVerboseRead,lReadECAToffsetTables,lHdrOK, lImageFormatOK, lDynStr, lFileName);
  2475.         exit;
  2476.   end;
  2477.   if (tx[0] = '*') AND (tx[1] = '*') AND (tx[2] = '*') AND (tx[3] = ' ') then begin {manufacturer is not SIEMENS}
  2478.         CloseFile(fp);
  2479.         if lDiskCacheSz > 0 then
  2480.            freemem(lDiskCacheRA);
  2481.         FileMode := 2; //set to read/write
  2482.         read_picker_data(lVerboseRead,lDICOMdata, lHdrOK, lImageFormatOK, lDynStr, lFileName);
  2483.         exit;
  2484.   end; {not picker}
  2485.   {end picker}
  2486.   lBig := false;
  2487.   dseek(fp, {0}128);
  2488.   //where := FilePos(fp);
  2489.   dBlockRead(fp, tx, 4*SizeOf(Char), n);
  2490.   if (tx[0] <> 'D') OR (tx[1] <> 'I') OR (tx[2] <> 'C') OR (tx[3] <> 'M') then begin
  2491.      //if filesz > 132 then begin
  2492.         dseek(fp, 0{128}); //skip the preamble - next 4 bytes should be 'DICM'
  2493.          //where := FilePos(fp);
  2494.         dBlockRead(fp, tx, 4*SizeOf(Char), n);
  2495.      //end;
  2496.      if (tx[0] <> 'D') OR (tx[1] <> 'I') OR (tx[2] <> 'C') OR (tx[3] <> 'M') then begin
  2497.         //showmessage('DICM not at 0 or 128');
  2498.         dseek(fp, 0);
  2499.         group   := read16(fp,lrOK);
  2500.         if not lrOK then goto 666;
  2501.         if group > $0008 then begin
  2502.            group := swap(group);
  2503.            lBig := true;
  2504.         end;
  2505.         if NOT (group in [$0000, $0001, $0002,$0003, $0004, $0008]) then // one more group added
  2506.         begin
  2507.            goto 666;
  2508.         end;
  2509.         dseek(fp, 0);
  2510.      end;
  2511.   end; //else showmessage('DICM at 128{0}');;
  2512.   // Read DICOM Tags
  2513.     time_to_quit := FALSE;
  2514.      explicitVR := false;
  2515.     tmpstr := '';
  2516.  
  2517.       tmp := 0;
  2518.     //lDicomData.RunLengthEncoding := true; //abba17
  2519.     //lDicomData.JPEGlossyCpt := true;//abba17
  2520.     while NOT time_to_quit do begin
  2521.   t := unknown;
  2522.       where     := dFilePos(fp);
  2523.      lFirstPass := true;
  2524. 777:
  2525.        group     := read16(fp,lrOK);
  2526.      if not lrOK then goto 666;
  2527.  
  2528.      if (lFirstPass) and (group = 2048) then begin
  2529.          if lDicomData.little_endian = 1 then lDicomData.Little_endian := 0
  2530.          else lDicomData.little_endian := 1;
  2531.          dseek(fp,where);
  2532.          lFirstPass := false;
  2533.          goto 777;
  2534.      end;
  2535.      element   := read16(fp,lrOK);
  2536.      if not lrOK then goto 666;
  2537.      e_len:= read32(fp,lrOK);
  2538.      if not lrOK then goto 666;
  2539. lGrpStr := '';
  2540.     lt0 := e_len and 255;
  2541.     lt1 := (e_len shr 8) and 255;
  2542.     lt2 := (e_len shr 16) and 255;
  2543.     lt3 := (e_len shr 24) and 255;
  2544.  if (explicitVR) and (lT0=13) and (lT1=0) and (lT2=0) and (lT3=0) then
  2545.    e_len := 10;  //hack for some GE Dicom images
  2546.  if explicitVR or first_one then begin
  2547.    if  ((lT0=kO) and (lT1=kB)) or ((lT0=kU) and (lT1=kN)){<-UN added} or ((lT0=kO) and (lT1=kW)) or ((lT0=kS) and (lT1=kQ)) then begin
  2548.        lGrpStr := chr(lT0)+chr(lT1);
  2549.            e_len:= read32(fp,lrOK);
  2550.            if not lrOK then goto 666;
  2551.            if first_one then explicitVR := true;
  2552.    end else if ((lT3=kO) and (lT2=kB)) or ((lT3=kU) and (lT2=kN)){<-UN added} or((lT3=kO) and (lT2=kW)) or ((lT3=kS) and (lT2=kQ)) then begin
  2553.            e_len:= read32(fp,lrOK);
  2554.            if not lrOK then goto 666;
  2555.            if first_one then explicitVR := true;
  2556.    end else
  2557.    if  ( ((lT0=kA) and (lT1=kE)) or ((lT0=kA) and (lT1=kS))
  2558.       or ((lT0=kA) and (lT1=kT)) or ((lT0=kC) and (lT1=kS)) or ((lT0=kD) and (lT1=kA))
  2559.       or ((lT0=kD) and (lT1=kS))
  2560.       or ((lT0=kD) and (lT1=kT)) or ((lT0=kF) and (lT1=kL)) or ((lT0=kF) and (lT1=kD))
  2561.       or ((lT0=kI) and (lT1=kS)) or ((lT0=kL) and (lT1=kO))or ((lT0=kL) and (lT1=kT))
  2562.       or ((lT0=kP) and (lT1=kN)) or ((lT0=kS) and (lT1=kH)) or ((lT0=kS) and (lT1=kL))
  2563.       or ((lT0=kS) and (lT1=kS)) or ((lT0=kS) and (lT1=kT)) or ((lT0=kT) and (lT1=kM))
  2564.       or ((lT0=kU) and (lT1=kI)) or ((lT0=kU) and (lT1=kL)) or ((lT0=kU) and (lT1=kS))
  2565.       or ((lT0=kA) and (lT1=kE)) or ((lT0=kA) and (lT1=kS)) )
  2566.       then begin
  2567.            lGrpStr := chr(lT0) + chr(lT1);
  2568.            if lDicomData.little_endian = 1 then
  2569.               e_len := (e_len and $ffff0000) shr 16
  2570.            else
  2571.               e_len := swap((e_len and $ffff0000) shr 16);
  2572.            if first_one then begin
  2573.               explicitVR := true;
  2574.            end;
  2575.    end else if (
  2576.            ((lT3=kA) and (lT2=kT)) or ((lT3=kC) and (lT2=kS)) or ((lT3=kD) and (lT2=kA))
  2577.            or ((lT3=kD) and (lT2=kS))
  2578.       or ((lT3=kD) and (lT2=kT)) or ((lT3=kF) and (lT2=kL)) or ((lT3=kF) and (lT2=kD))
  2579.       or ((lT3=kI) and (lT2=kS)) or ((lT3=kL) and (lT2=kO))or ((lT3=kL) and (lT2=kT))
  2580.       or ((lT3=kP) and (lT2=kN)) or ((lT3=kS) and (lT2=kH)) or ((lT3=kS) and (lT2=kL))
  2581.       or ((lT3=kS) and (lT2=kS)) or ((lT3=kS) and (lT2=kT)) or ((lT3=kT) and (lT2=kM))
  2582.       or ((lT3=kU) and (lT2=kI)) or ((lT3=kU) and (lT2=kL)) or ((lT3=kU) and (lT2=kS)))
  2583.       then begin
  2584.            if lDicomData.little_endian = 1 then
  2585.               e_len := (256 * lT0) + lT1
  2586.            else
  2587.               e_len := (lT0) + (256*lT1);
  2588.            if first_one then begin
  2589.               explicitVR := true;
  2590.            end;
  2591.    end;
  2592. end; //not first_one or explicit
  2593.    if (first_one) and (lDicomdata.little_endian =0) and (e_len = $04000000) then begin
  2594.       ShowMessage('Switching to little endian');
  2595.       lDicomData.little_endian := 1;
  2596.       dseek(fp, where);
  2597.       first_one := false;
  2598.       goto 777;
  2599.    end else if (first_one) and (lDicomData.little_endian =1) and (e_len = $04000000) then begin
  2600.        ShowMessage('Switching to little endian');
  2601.        lDicomData.little_endian := 0;
  2602.        dseek(fp, where);
  2603.        first_one := false;
  2604.        goto 777;
  2605.    end;
  2606. if e_len = ($FFFFFFFF) then begin
  2607.     e_len := 0;
  2608. end;
  2609. if lGELX then begin
  2610.    e_len := e_len and $FFFF;
  2611. end;
  2612.    first_one    := false;
  2613.     remaining := e_len;
  2614.     info := '?';
  2615.     tmpstr := '';
  2616. (*if lTestError then begin
  2617.     showmessage(inttostr(group)+'pwr'+inttostr(element));
  2618. end;*)
  2619.     case group of
  2620.         $0001 : // group for normal reading elscint DICOM
  2621.         case element of
  2622.           $0010 : info := 'Name';
  2623.           $1001 : info := 'Elscint info';
  2624.          end;
  2625.         $0002 :
  2626.           case element of
  2627.             $00 :  info := 'File Meta Elements Group Len';
  2628.           $01 :  info := 'File Meta Info Version';
  2629.           $02 :  info := 'Media Storage SOP Class UID';
  2630.           $03 :  info := 'Media Storage SOP Inst UID';
  2631.           $10 :  begin
  2632.               info := 'Transfer Syntax UID';
  2633.               TmpStr := '';
  2634.               if dFilePos(fp) > (filesz-e_len) then goto 666;
  2635.               GetMem( buff, e_len);
  2636.               dBlockRead(fp, buff{^}, e_len, n);
  2637.               for i := 0 to e_len-1 do
  2638.                        if Char(buff[i]) in ['+','-',' ', '0'..'9','a'..'z','A'..'Z']
  2639.                          then TmpStr := TmpStr +(Char(buff[i]))
  2640.                       else TmpStr := TmpStr +('.');
  2641.               FreeMem( buff);
  2642.               lStr := '';
  2643.               if TmpStr = '1.2.840.113619.5.2' then begin
  2644.                  lGELX := true;
  2645.                  LBigSet := true;
  2646.                  lBig := true;
  2647.               end;
  2648.               if length(TmpStr) >= 19 then begin
  2649.                   if TmpStr[19] = '1' then begin
  2650.                      lBigSet:= true;
  2651.                      explicitVR := true; //duran
  2652.                      lBig := false;
  2653.                   end else if TmpStr[19] = '2' then begin
  2654.                      lBigSet:= true;
  2655.                      explicitVR := true; //duran
  2656.                      lBig := true;
  2657.                   end else if TmpStr[19] = '4' then begin
  2658.                       if length(TmpStr) >= 21 then begin
  2659.                          //ShowMessage('Unable to extract JPEG: '+TmpStr[21]+TmpStr[22])
  2660.                          //lDicomData.JPEGCpt := true;
  2661.                          if not lReadJPEGtables then begin
  2662.                             lImageFormatOK := false;
  2663.                             //showmessage('Unable to extract JPEG compressed DICOM files. Use MRIcro to convert this file.');
  2664.                          end else begin
  2665.                              i := strtoint(TmpStr[21]+TmpStr[22]);
  2666.                              //showmessage(inttostr(i));
  2667.                              //if (TmpStr[22] <> '0') or ((TmpStr[21] <> '7') or (TmpStr[21] <> '0'))
  2668.                              if (i <> 57) and (i <> 70) then
  2669.                                 lDicomData.JPEGLossyCpt := true
  2670.                              else lDicomData.JPEGLosslessCpt := true;
  2671.                          end;
  2672.                       end else begin
  2673.                           Showmessage('Unknown Transfer Syntax: JPEG?');
  2674.                           lImageFormatOK := false;
  2675.                       end;
  2676.                   end else if TmpStr[19] = '5' then begin
  2677.                       lDicomData.RunLengthEncoding := true;
  2678.                       //ShowMessage('Note: Unable to extract lossless run length encoding: '+TmpStr[17]);
  2679.                       //lImageFormatOK := false;
  2680.                   end else begin
  2681.                       ShowMessage('Unable to extract unknown data type: '+TmpStr[17]);
  2682.                       lImageFormatOK := false;
  2683.                   end;
  2684.               end; {length}
  2685.                   remaining := 0;
  2686.                   e_len := 0; {use tempstr}
  2687.               end;
  2688.           $12 :  begin
  2689.               info := 'Implementation Class UID';
  2690.               end;
  2691.           $13 :
  2692.               info := 'Implementation Version Name';
  2693.           $16 :  info := 'Source App Entity Title';
  2694.           $100:  info := 'Private Info Creator UID';
  2695.           $102:  info := 'Private Info';
  2696.                 end;
  2697.       $0008 :
  2698.         case element of
  2699.           $00 :  begin
  2700.               info := 'Identifying Group Length';
  2701.           end;
  2702.           $01 :  info := 'Length to End';
  2703.           $05 :  info := 'Specific Character Set';
  2704.           $08 :  begin
  2705.               info := 'Image Type';
  2706.               t := _string;
  2707.               end;
  2708.           $10 :  info := 'Recognition Code';
  2709.           $12 :  info := 'Instance Creation Date';
  2710.           $13 :  info := 'Instance Creation Time';
  2711.           $14 :  info := 'Instance Creator UID';
  2712.           $16 :  info := 'SOP Class UID';
  2713.           $18 :  info := 'SOP Instance UID';
  2714.           $20 :  begin
  2715.               info := 'Study Date';
  2716.               lDicomData.StudyDatePos  := dFilePos(fp);
  2717.               end;
  2718.           $21 :  info := 'Series Date';
  2719.           $22 :  info := 'Acquisition Date';
  2720.           $23 :  info := 'Image Date';
  2721.           $30 :  info := 'Study Time';
  2722.           $31 :  info := 'Series Time';
  2723.           $32 :  info := 'Acquisition Time';
  2724.           $33 :  info := 'Image Time';
  2725.           $40 :  info := 'Data Set Type';
  2726.           $41 :  info := 'Data Set Subtype';
  2727.           $50 :  info := 'Accession Number';
  2728.           $60 :  begin info := 'Modality';  t := _string; end;
  2729.           $64 :  begin info := 'Conversion Type';  t := _string; end;
  2730.           $70 :  info := 'Manufacturer';
  2731.           $80 :  info := 'Institution Name';
  2732.           $81 :  info := 'City Name';
  2733.           $90 :  info := 'Referring Physician''s Name';
  2734.           $1010: info := 'Station Name';
  2735.           $1030: begin info := 'Study Description'; t := _string; end;
  2736.           $103e: info := 'Series Description';
  2737.           $1040: info := 'Institutional Dept. Name';
  2738.           $1050: info := 'Performing Physician''s Name';
  2739.           $1060: info := 'Name Phys(s) Read Study';
  2740.           $1070: begin info := 'Operator''s Name';  t := _string; end;
  2741.           $1080: info := 'Admitting Diagnosis Description';
  2742.           $1090: begin info := 'Manufacturer''s Model Name';t := _string; end;
  2743.           $1140: info := 'Referenced Image Sequence';
  2744.           $2120: info := 'Stage Name';
  2745.           $2122: begin info := 'Stage Number';t := _string; end;
  2746.           $2124: begin info := 'Number of Stages';t := _string; end;
  2747.           $2128: begin info := 'View Number';t := _string; end;
  2748.           $212A: begin info := 'Number of Views in stage';t := _string; end;
  2749.           $2204: info := 'Transducer Orientation';
  2750.  
  2751.  
  2752.         end;
  2753. (*    $0009: case element of
  2754.         $1215:
  2755.              begin info := 'Image Number';        t := _string;
  2756.               lStr := '';
  2757.               if dFilePos(fp) > (filesz-e_len) then goto 666;
  2758.               GetMem( buff, e_len);
  2759.               dBlockRead(fp, buff{^}, e_len, n);
  2760.               tmp := e_len -1;
  2761.               if tmp > 7 then
  2762.                  tmp := tmp - 8
  2763.               else
  2764.                   tmp := 0;
  2765.               for i := tmp to e_len-1 do
  2766.                        if Char(buff[i]) in ['+','-','0'..'9']
  2767.                          then lStr := lStr +(Char(buff[i]));
  2768.               FreeMem( buff);
  2769.               Val(lStr,i,lErr);
  2770.               if lErr = 0 then lDicomData.ImageNum := i;//strtoint(lStr);
  2771.               remaining := 0;
  2772.               tmp := lDicomData.ImageNum;
  2773.               //showmessage(lStr+' : '+inttostr(i)+' = '+inttostr(lErr));
  2774.         end; //element 1215
  2775.     end;//group 0009 *)
  2776.         $0010 :
  2777.         case element of
  2778.             $00 :  info := 'Patient Group Length';
  2779.           $10 :  begin info := 'Patient''s Name'; t := _string;
  2780.               lDicomData.NamePos := dFilePos(fp);
  2781.           end;
  2782.           $20 :  info := 'Patient ID';
  2783.           $30 :  info := 'Patient Date of Birth';
  2784.           $40 :  begin info := 'Patient Sex';  t := _string; end;
  2785.           $1005: info := 'Patient''s Birth Name';
  2786.           $1010: info := 'Patient Age';
  2787.           $1030: info := 'Patient Weight';
  2788.           $21b0: info := 'Additional Patient History';
  2789.                 end;
  2790.     $0018 :
  2791.         case element of
  2792.              $00 :  info := 'Acquisition Group Length';
  2793.           $10 :  begin info := 'Contrast/Bolus Agent'; t := _string; end;
  2794.           $15: info := 'Body Part Examined';
  2795.           $20 :  begin info := 'Scanning Sequence';t := _string; end;
  2796.           $21 :  begin info := 'Sequence Variant';t := _string; end;
  2797.           $22 :  info := 'Scan Options';
  2798.           $23 :  begin info := 'MR Acquisition Type'; t := _string; end;
  2799.           $24 :  info := 'Sequence Name';
  2800.           $25 :  begin info := 'Angio Flag';t := _string; end;
  2801.           $30 :  info := 'Radionuclide';
  2802.           $50 :  begin info := 'Slice Thickness';
  2803.             readfloats (fp, remaining, TmpStr, lfloat1, lfloat2, lROK);
  2804.               if not lrOK then goto 666;
  2805.               e_len := 0;      remaining := 0;
  2806.              lDICOMdata.XYZmm[3] := lfloat1;
  2807.           end;
  2808.           $60: info := 'KVP';
  2809.           $70: begin t := _string; info := 'Counts Accumulated'; end;
  2810.           $71: begin t := _string; info := 'Acquisition Condition'; end;
  2811.           $80 :  info := 'Repetition Time';
  2812.           $81 :  info := 'Echo Time';
  2813.           $82 :  begin t := _string; info := 'Inversion Time'; end;
  2814.           $83 :  begin t := _string; info := 'Number of Averages'; end;
  2815.           $84 :  info := 'Imaging Frequency';
  2816.           $85 :  begin info := 'Imaged Nucleus';  t := _string; end;
  2817.           $86 :  begin info := 'Echo Number';t := _string; end;
  2818.           $87 :  info := 'Magnetic Field Strength';
  2819.           $88 :  info := 'Spacing Between Slices';
  2820.           $89 : begin
  2821.               t := _string;
  2822.               info := 'Number of Phase Encoding Steps';
  2823.               end;
  2824.           $90 :  info := 'Data collection diameter';
  2825.           $91 :  begin info := 'Echo Train Length';t := _string; end;
  2826.           $93: info := 'Percent Sampling';
  2827.           $94: info := 'Percent Phase Field View';
  2828.           $95 :  info := 'Pixel Bandwidth';
  2829.           $1000: begin t := _string; info := 'Device Serial Number'; end;
  2830.           $1020: begin info := 'Software Version';t := _string; end;
  2831.           $1030: info := 'Protocol Name';
  2832.           $1040: info := 'Contrast/Bolus Route';
  2833.           $1050 :  begin
  2834.               t := _string; info := 'Spatial Resolution'; end;
  2835.           $1060: info := 'Trigger Time';
  2836.           $1062: info := 'Nominal Interval';
  2837.           $1063: info := 'Frame Time';
  2838.           $1081: info := 'Low R-R Value';
  2839.           $1082: info := 'High R-R Value';
  2840.           $1083: info := 'Intervals Acquired';
  2841.           $1084: info := 'Intervals Rejected';
  2842.           $1088: begin info := 'Heart Rate'; t := _string; end;
  2843.           $1090: begin info :=  'Cardiac Number of Images'; t := _string; end;
  2844.           $1094: begin info :=  'Trigger Window';t := _string; end;
  2845.           $1100: info := 'Reconstruction Diameter';
  2846.           $1110: info := 'Distance Source to Detector';
  2847.           $1111: info := 'Distance Source to Patient';
  2848.           $1120: info := 'Gantry/Detector Tilt';
  2849.           $1130: info := 'Table Height';
  2850.           $1140: info := 'Rotation Direction';
  2851.           $1149: begin
  2852.               t := _string; info := 'Field of View Dimension[s]'; end;
  2853.           $1150: info := 'Exposure Time';
  2854.           $1151: info := 'X-ray Tube Current';
  2855.           $1152 :  info := 'Exposure';
  2856.           $1155: info := 'Radiation Setting';
  2857.           $1160: info := 'Filter Type';
  2858.           $1170 :  info := 'Generator Power';
  2859.           $1190 :  info := 'Focal Spot[s]';
  2860.           $1200 :  info := 'Date of Last Calibration';
  2861.           $1201 :  info := 'Time of Last Calibration';
  2862.           $1210: info := 'Convolution Kernel';
  2863.           $1250: begin t := _string; info := 'Receiving Coil'; end;
  2864.           $1251: begin t := _string; info := 'Transmitting Coil'; end;
  2865.           $1260 :  begin
  2866.               t := _string; info := 'Plate Type'; end;
  2867.           $1261 :  begin
  2868.               t := _string; info := 'Phosphor Type';  end;
  2869.           $1310: begin info := 'Acquisition Matrix'; TmpStr := ReadStr(fp, remaining,lrOK);
  2870.                      if not lrOK then goto 666;
  2871. e_len := 0; remaining := 0; end;
  2872.           $1312: begin
  2873.               t := _string; info := 'Phase Encoding Direction'; end;
  2874.           $1314: begin
  2875.               t := _string; info := 'Flip Angle'; end;
  2876.           $1315: begin
  2877.               t := _string;info := 'Variable Flip Angle Flag'; end;
  2878.           $1316: begin
  2879.               t := _string;info := 'SAR'; end;
  2880.           $1400: info := 'Acquisition Device Processing Description';
  2881.           $1401: begin info := 'Acquisition Device Processing Code';t := _string; end;
  2882.           $1402: info := 'Cassette Orientation';
  2883.           $1403: info := 'Cassette Size';
  2884.           $1500: info := 'Positioner Motion';
  2885.           $1510: info := 'Positioner Primary Angle';
  2886.           $1511: info := 'Positioner Secondary Angle';
  2887.           $5020: info := 'Processing Function';
  2888.           $5100: begin
  2889.               t := _string; info := 'Patient Position';  end;
  2890.           $5101: begin info := 'View Position';t := _string; end;
  2891.           $6000: begin info := 'Sensitivity'; t := _string; end;
  2892.                 end;
  2893.  
  2894. $0020 :
  2895.         case element of
  2896.                     $00 :  info := 'Relationship Group Length';
  2897.           $0d :  info := 'Study Instance UID';
  2898.           $0e :  info := 'Series Instance UID';
  2899.           $10 :  info := 'Study ID';
  2900.           $11 :  begin info := 'Series Number';       t := _string; end;
  2901.           $12 : // begin info := 'Acquisition Number';  t := _string; end;
  2902.           begin info := 'Acquisition Number';        t := _string;
  2903.               lStr := '';
  2904.               if dFilePos(fp) > (filesz-e_len) then goto 666;
  2905.               GetMem( buff, e_len);
  2906.               dBlockRead(fp, buff{^}, e_len, n);
  2907.               for i := 0 to e_len-1 do
  2908.                        if Char(buff[i]) in ['+','-','0'..'9']
  2909.                          then lStr := lStr +(Char(buff[i]));
  2910.               FreeMem( buff);
  2911.               Val(lStr,i,lErr);
  2912.               if lErr = 0 then lDicomData.AcquNum := i;//strtoint(lStr);
  2913.               remaining := 0;
  2914.               tmp := lDicomData.AcquNum;
  2915.               //showmessage(inttostr(tmp));
  2916.           end;
  2917.  
  2918.           $13 :  begin info := 'Image Number';        t := _string;
  2919.               lStr := '';
  2920.               if dFilePos(fp) > (filesz-e_len) then goto 666;
  2921.               GetMem( buff, e_len);
  2922.               dBlockRead(fp, buff{^}, e_len, n);
  2923.               for i := 0 to e_len-1 do
  2924.                        if Char(buff[i]) in ['+','-','0'..'9']
  2925.                          then lStr := lStr +(Char(buff[i]));
  2926.               FreeMem( buff);
  2927.               Val(lStr,i,lErr);
  2928.               if lErr = 0 then lDicomData.ImageNum := i;//strtoint(lStr);
  2929.               remaining := 0;
  2930.               tmp := lDicomData.ImageNum;
  2931.           end;
  2932.           $20 :  begin info := 'Patient Orientation'; t := _string; end;
  2933.           $30 :  info := 'Image Position';
  2934.           $32 :  info := 'Image Position Patient';
  2935.           $35 :  info := 'Image Orientation';
  2936.           $37 :  info := 'Image Orientation (Patient)';
  2937.           $50 :  info := 'Location';
  2938.           $52 :  info := 'Frame of Reference UID';
  2939.           $91 :  info := 'Echo Train Length';
  2940.           $70 :  info := 'Image Geometry Type';
  2941.           $60 :  info := 'Laterality';
  2942.           $1001: info := 'Acquisitions in Series';
  2943.           $1002: info := 'Images in Acquisition';
  2944.           $1020: info := 'Reference';
  2945.           $1040: begin info :=  'Position Reference';  t := _string; end;
  2946.           $1041: info := 'Slice Location';
  2947.           $3401: info := 'Modifying Device ID';
  2948.           $3402: info := 'Modified Image ID';
  2949.           $3403: info := 'Modified Image Date';
  2950.           $3404: info := 'Modifying Device Mfg.';
  2951.           $3405: info := 'Modified Image Time';
  2952.           $3406: info := 'Modified Image Desc.';
  2953.           $4000: info := 'Image Comments';
  2954.           $5000: info := 'Original Image ID';
  2955.           $5002: info := 'Original Image... Nomenclature';
  2956.                 end;
  2957.             $0028 :
  2958.         case element of
  2959.             $00 :  info := 'Image Presentation Group Length';
  2960.           $02 :  begin
  2961.               info := 'Samples Per Pixel';
  2962.                           tmp := read16(fp,lrOK);
  2963.                                         if not lrOK then goto 666;
  2964.                           lDicomData.SamplesPerPixel :=tmp;
  2965.                   remaining := 0;
  2966.               end;
  2967.  
  2968.           $04 :  begin
  2969.               info := 'Photometric Interpretation';{help}
  2970.               TmpStr := '';
  2971.               if dFilePos(fp) > (filesz-e_len) then goto 666;
  2972.               GetMem( buff, e_len);
  2973.               dBlockRead(fp, buff{^}, e_len, n);
  2974.               for i := 0 to e_len-1 do
  2975.                        if Char(buff[i]) in [{'+','-',' ', }'0'..'9','a'..'z','A'..'Z']
  2976.                          then TmpStr := TmpStr +(Char(buff[i]));
  2977.               FreeMem( buff);
  2978.               if TmpStr = 'MONOCHROME1' then lDicomdata.monochrome := 1
  2979.               else if TmpStr = 'MONOCHROME2' then lDicomdata.monochrome := 2
  2980.               else if TmpStr[1] = 'Y' then lDICOMdata.monochrome := 4
  2981.               else lDICOMdata.monochrome := 3;
  2982.                   remaining := 0;
  2983.                   e_len := 0; {use tempstr}
  2984.  
  2985.           end;
  2986.           $05 :  info := 'Image Dimensions (ret)';
  2987.           $06 : begin
  2988.               info := 'Planar Configuration';
  2989.                                         tmp := read16(fp,lrOK);
  2990.                                         if not lrOK then goto 666;
  2991.                           lDicomData.PlanarConfig :=tmp;
  2992.                   remaining := 0;
  2993.               end;
  2994.  
  2995.           $08 :  begin
  2996.               t := _string;
  2997.               lStr := '';
  2998.               if dFilePos(fp) > (filesz-e_len) then goto 666;
  2999.               GetMem( buff, e_len);
  3000.               dBlockRead(fp, buff{^}, e_len, n);
  3001.               for i := 0 to e_len-1 do
  3002.                        if Char(buff[i]) in ['+','-','0'..'9']
  3003.                          then lStr := lStr +(Char(buff[i]));
  3004.               FreeMem( buff);
  3005.               Val(lStr,i,lErr);
  3006.               if lErr = 0 then
  3007.                  lDicomData.XYZdim[3] := i;//strtoint(lStr);
  3008.               tmp := lDicomData.XYZdim[3];
  3009.               remaining := 0;
  3010.                   if lDicomData.XYZdim[3] < 1 then lDicomData.XYZdim[3] := 1;
  3011.                info := 'Number of Frames';
  3012.                  end;
  3013.           $09: begin info := 'Frame Increment Pointer'; TmpStr := ReadStrHex(fp, remaining,lrOK);           if not lrOK then goto 666;
  3014.  e_len := 0; remaining := 0; end;
  3015.           $10 :  begin info := 'Rows';
  3016.                           lDicomData.XYZdim[2] := read16(fp,lrOK);
  3017.                                         if not lrOK then goto 666;
  3018.                           tmp := lDicomData.XYZdim[2];
  3019.                   remaining := 0;
  3020.                  end;
  3021.           $11 :  begin info := 'Columns';
  3022.                           lDicomData.XYZdim[1] := read16(fp,lrOK);
  3023.                              if not lrOK then goto 666;
  3024.                           tmp := lDicomData.XYZdim[1];
  3025.                   remaining := 0;
  3026.                  end;
  3027.           $30 :  begin info := 'Pixel Spacing';
  3028.            readfloats (fp, remaining, TmpStr, lfloat1, lfloat2, lROK);
  3029.           if not lrOK then goto 666;
  3030.           //row spacing [y], then column spacing [x]: see part 3 of DICOM
  3031.           e_len := 0;      remaining := 0;
  3032.              lDICOMdata.XYZmm[2] := lfloat1;
  3033.              lDICOMdata.XYZmm[1] := lfloat2;
  3034.           end;
  3035.           $31: info := 'Zoom Factor';
  3036.           $32: info := 'Zoom Center';
  3037.           $34: begin info :='Pixel Aspect Ratio';t := _string; end;
  3038.           $40: info := 'Image Format [ret]';
  3039.           $50 :  info := 'Manipulated Image [ret]';
  3040.           $51: info := 'Corrected Image';
  3041.           $60: begin info := 'Compression Code [ret]';t := _string; end;
  3042.           $0100: begin info := 'Bits Allocated';
  3043.                  tmp := read16(fp,lrOK);
  3044.                             if not lrOK then goto 666;
  3045.                   if tmp = 8 then lDicomData.Allocbits_per_pixel := 8
  3046.                   else if tmp = 12 then lDicomData.Allocbits_per_pixel := 12
  3047.                   else if tmp = 16 then lDicomData.Allocbits_per_pixel := 16
  3048.                   else begin
  3049.                     lWord := tmp;
  3050.                     lWord := swap(lWord);
  3051.                     if lWord in [8,12,16] then begin
  3052.                        //showmessage(inttostr(lWord));
  3053.                        lDicomData.Allocbits_per_pixel := tmp;
  3054.                        lByteSwap := true;
  3055.                     end else begin
  3056.                         //lDicomData.Allocbits_per_pixel := 8; //asdf
  3057.                         if lImageFormatOK then
  3058.                        Showmessage('This software can only read 8, 12 and 16 bit DICOM files. This file allocates '+inttostr(tmp)+' bits per voxel.');
  3059.                       lImageFormatOK := false;{}
  3060.                     end;
  3061.                   end;
  3062.  
  3063.                   remaining := 0;
  3064.                  end;
  3065.             $0101: begin info := 'Bits Stored';
  3066.                           tmp := read16(fp,lrOK);
  3067.                              if not lrOK then goto 666;
  3068.  
  3069.                   if tmp <= 8 then lDicomData.Storedbits_per_pixel := 8
  3070.                   else if tmp <= 16 then lDicomData.Storedbits_per_pixel := 16
  3071.                   else begin
  3072.                        //lDicomData.Storedbits_per_pixel := 8; //asdf
  3073.                        lWord := tmp;
  3074.                        lWord := swap(lWord);
  3075.                        if lWord in [8,12,16] then begin
  3076.                           //showmessage(inttostr(lWord));
  3077.                           lDicomData.Storedbits_per_pixel := tmp;
  3078.                           lByteSwap := true;
  3079.                        end else begin
  3080.                            if lImageFormatOK then
  3081.                               Showmessage('This software can only read 8, 12 and 16 bit DICOM files. This file stores '+inttostr(tmp)+' bits per voxel.');
  3082.                            lDicomData.Storedbits_per_pixel := tmp;
  3083.                            lImageFormatOK := false;{ }
  3084.                        end;
  3085.                   end;
  3086.                   remaining := 0;
  3087.                        end;
  3088.           $0102: begin info := 'High Bit';
  3089.                           tmp := read16(fp,lrOK);
  3090.                                         if not lrOK then
  3091.                                            goto 666;
  3092.  
  3093.                                  (*
  3094.                                  could be 11 for 12 bit cr images so just
  3095.                                  skip checking it
  3096.                                  assert(tmp == 7 || tmp == 15);
  3097.                                  *)
  3098.                   remaining := 0;
  3099.                  end;
  3100.           $0103: info := 'Pixel Representation';
  3101.           $0104: info := 'Smallest Valid Pixel Value';
  3102.           $0105: info := 'Largest Valid Pixel Value';
  3103.           $0106: info := 'Smallest Image Pixel Value';
  3104.           $0107: info := 'Largest Image Pixel Value';
  3105.           $120: info := 'Pixel Padding Value';
  3106.           $200: info := 'Image Location [ret]';
  3107.           $1040: begin t := _string; info := 'Pixel Intensity Relationship'; end;
  3108.           $1050: begin
  3109.               //t := _string;
  3110.               info := 'Window Center';
  3111.              readfloats (fp, remaining, TmpStr, lfloat1, lfloat2, lROK);
  3112.               if not lrOK then goto 666;
  3113. e_len := 0;      remaining := 0;
  3114.              lDICOMdata.WindowCenter := round(lfloat1);
  3115.  
  3116.               end;{float}
  3117.           $1051: begin info := 'Window Width';
  3118.           //t := _string;
  3119.              readfloats (fp, remaining, TmpStr, lfloat1, lfloat2, lROK);
  3120.               if not lrOK then goto 666;
  3121. e_len := 0;      remaining := 0;
  3122.              lDICOMdata.WindowWidth := round(lfloat1);
  3123.   end;
  3124.           $1052: begin t := _string;info :='Rescale Intercept';
  3125.           end;  {float}
  3126.           $1053:begin
  3127.              t := _string; info :=  'Rescale Slope';
  3128.              readfloats (fp, remaining, TmpStr, lfloat1, lfloat2, lROK);
  3129.               if not lrOK then goto 666;
  3130.               e_len := 0;      remaining := 0;
  3131.              lDICOMdata.intenScale := lfloat1;
  3132.                      end; {float}
  3133.           $1054:begin t := _string; info := 'Rescale Type';end;
  3134.           $1100: info := 'Gray Lookup Table [ret]';
  3135.           $1101: begin  info := 'Red Palette Descriptor'; TmpStr := ReadStr(fp, remaining,lrOK);
  3136.                      if not lrOK then goto 666;
  3137. e_len := 0; remaining := 0; end;
  3138.           $1102: begin info := 'Green Palette Descriptor'; TmpStr := ReadStr(fp, remaining,lrOK);
  3139.                      if not lrOK then goto 666;
  3140. e_len := 0; remaining := 0; end;
  3141.           $1103: begin info := 'Blue Palette Descriptor'; TmpStr := ReadStr(fp, remaining,lrOK);
  3142.                      if not lrOK then goto 666;
  3143. e_len := 0; remaining := 0; end;
  3144.          $1199: info := 'Palette Color Lookup Table UID';
  3145.           $1200: info := 'Gray Lookup Data [ret]';
  3146.           $1201, $1202,$1203: begin
  3147.                  case element of
  3148.                       $1201: info := 'Red Table'; {future}
  3149.                       $1202: info := 'Green Table'; {future}
  3150.                       $1203: info := 'Blue Table'; {future}
  3151.                  end;
  3152.  
  3153.                  if dFilePos(fp) > (filesz-remaining) then
  3154.                     goto 666;
  3155.                  if not lReadColorTables then begin
  3156.                     dSeek(fp, dFilePos(fp) + remaining);
  3157.                  end else begin {load color}
  3158.                    width := remaining div 2;
  3159.                    if width > 0 then begin
  3160.                      getmem(lWordRA,width*2);
  3161.                      for i := (width) downto 1 do
  3162.                          lWordRA[i] := read16(fp,lrOK);
  3163.                      value := 159;
  3164.                      //showmessage(inttostr(lWordRA[value]));
  3165.                      //lWordRA[width] := 65000;
  3166.                      //if (lDICOMdata.little_endian=1) then
  3167.                      //   showmessage('little.');
  3168.                      value := lWordRA[1];
  3169.                     max16 := value;
  3170.                       min16 := value;
  3171.                      for i := (width) downto 1 do begin
  3172.                          value := lWordRA[i];
  3173.                     if value < min16 then min16 := value;
  3174.                           if value > max16 then max16 := value;
  3175.                      end; //width..1
  3176.                      if max16 - min16 = 0 then
  3177.                         max16 := min16+1; {avoid divide by 0}
  3178.                      GetMem( lColorRA, width );(**)
  3179.                      for i := width downto 1 do
  3180.                          lColorRA[i] := (lWordRA[i] shr 8) {and 255};
  3181.                      FreeMem( lWordRA );
  3182.                      case element of
  3183.                           $1201: begin
  3184.                              red_table_size := width;
  3185.                              red_table   :=lColorRA;;
  3186.                           end;
  3187.                           $1202: begin
  3188.                              green_table_size := width;
  3189.                              green_table   :=lColorRA;;
  3190.                              end;
  3191.                           else {x$1203:} begin
  3192.                              blue_table_size := width;
  3193.                              blue_table   :=lColorRA;;
  3194.                           end; {else}
  3195.                      end; {case}
  3196.                    end; //width > 0;
  3197.                    if odd(remaining) then
  3198.                       dSeek(fp, dFilePos(fp) + 1{remaining});
  3199.                  end; {load color}
  3200.                  tmpstr := 'Custom';
  3201.                  remaining := 0;
  3202.                  e_len := 0; {show tempstr}
  3203.                  end;
  3204.      end;
  3205.      $54: case element of
  3206.           $0: info := 'Nuclear Acquisition Group Length';
  3207.           $11: info := 'Number of Energy Windows';
  3208.           $21: info := 'Number of Detectors';
  3209.           $51: info := 'Number of Rotations';
  3210.           $80: begin info :=  'Slice Vector'; TmpStr := ReadStr(fp, remaining,lrOK);           if not lrOK then goto 666;
  3211.  e_len := 0; remaining := 0; end;
  3212.           $81: info := 'Number of Slices';
  3213.           $202: info := 'Type of Detector Motion';
  3214.           $400: info := 'Image ID';
  3215.  
  3216.           end;
  3217.      $2010 :
  3218.         case element of
  3219.              $0: info := 'Film Box Group Length';
  3220.              $100: info := 'Border Density';
  3221.         end;
  3222.       $4000 : info := 'Text';
  3223.       $FFFE : begin
  3224.             //lVerbose := false;
  3225.         case element of
  3226.         $E000 : begin
  3227.         if (lReadJPEGtables) and ((lDICOMdata.JPEGLossyCpt) or (lDICOMdata.JPEGLosslessCpt)) and (not lFirstFragment) and (e_len > 1024) and ( (e_len+dFilePos(fp)) <= FileSz) then begin
  3228.            //first fragment is the index table, so the previous line skips the first fragment
  3229.            if (gECATJPEG_table_entries = 0) then begin
  3230.               gECATJPEG_table_entries := lDICOMdata.XYZDim[3];
  3231.               getmem (gECATJPEG_pos_table, gECATJPEG_table_entries*sizeof(longint));
  3232.               getmem (gECATJPEG_size_table, gECATJPEG_table_entries*sizeof(longint));
  3233.            end;
  3234.            if lJPEGentries < gECATJPEG_table_entries then begin
  3235.                inc(lJPEGentries);
  3236.                gECATJPEG_pos_table[lJPEGEntries] := dFilePos(fp);
  3237.                gECATJPEG_size_table[lJPEGEntries] := e_len;
  3238.            end;
  3239.         end;
  3240.         lFirstFragment := false;
  3241.         if (lDICOMdata.CompressOffset =0) and ( (e_len+dFilePos(fp)) <= FileSz) then begin
  3242.               lDICOMdata.CompressOffset := dFilePos(fp);
  3243.               lDICOMdata.CompressSz := e_len;
  3244.         end;
  3245.         //if e_len > lDICOMdata.CompressSz then lDICOMdata.CompressSz := e_len;
  3246.         if e_len > lDICOMdata.CompressSz then lDICOMdata.CompressSz := e_len;
  3247.               info := 'Image Fragment';
  3248.               //lJPEGOffset := true;
  3249.               dSeek(fp, dFilePos(fp) + e_len);
  3250.                  tmpstr := inttostr(e_len);
  3251.                  remaining := 0;
  3252.                  e_len := 0; {show tempstr}
  3253.               end;
  3254.         $E0DD : begin
  3255.               info := 'Sequence Delimiter';
  3256. //              showmessage('Sequence Delimiter'+ inttostr(e_len));
  3257.               if (lDicomData.RunLengthEncoding) or ( ((lDicomData.JPEGLossycpt) or (lDicomData.JPEGLosslesscpt)) and (gECATJPEG_table_entries >= lDICOMdata.XYZdim[3])) then time_to_quit := TRUE;
  3258.               dSeek(fp, dFilePos(fp) + e_len);
  3259.                  tmpstr := inttostr(e_len);
  3260.                  remaining := 0;
  3261.                  e_len := 0; {show tempstr}
  3262.               end;
  3263.         end;
  3264.         end;
  3265.         $FFFC : begin
  3266.               dSeek(fp, dFilePos(fp) + e_len);
  3267.                  tmpstr := inttostr(e_len);
  3268.                  remaining := 0;
  3269.                  e_len := 0; {show tempstr}
  3270.               end;
  3271.  
  3272.       $7FE0 :
  3273.         case element of
  3274.             $00 :  begin
  3275.            info := 'Pixel Data Group Length';
  3276.            if not lImageFormatOK then time_to_quit := TRUE;
  3277.            end;
  3278.           $10 :  begin info := 'Pixel Data';
  3279.           if (not lDicomData.RunLengthEncoding) and (not lDicomData.JPEGLossycpt) and (not lDicomData.JPEGLosslesscpt) then time_to_quit := TRUE;
  3280.           lDicomData.ImageSz := e_len; TmpStr := inttostr(e_len);e_len := 0; end;
  3281.                 end;
  3282.       else
  3283.           begin
  3284.  
  3285.           if (group >= $6000) AND (group <= $601e) AND ((group AND 1) = 0)
  3286.               then  info := 'Overlay';
  3287.           if element = $0000 then info := 'Group Length';
  3288.           if element = $4000 then info := 'Comments';
  3289.                 end;
  3290.     end;
  3291. lStr := '';
  3292. if (Time_TO_Quit) and (not lImageFormatOK) then begin
  3293.    lHdrOK := true; {header was OK}
  3294.    goto 666;
  3295. end;
  3296.  if (e_len + dfilepos(fp)) > FileSz then //patch for GE files that only fill top 16-bytes w Random data
  3297.     e_len := e_len and $FFFF;
  3298.     if (e_len > $FFFF) {and (dfilepos(fp) > FileSz)} then begin
  3299.         showmessage('Very large DICOM header: is this really a DICOM file? '+inttostr(dfilepos(fp)));
  3300.         goto 666;
  3301.     end;//zebra
  3302.     if (NOT time_to_quit) AND (e_len > 0) and (remaining > 0) then begin
  3303.      if (e_len + dfilepos(fp)) > FileSz then begin
  3304.         if (lDICOMdata.GenesisCpt) or (lDICOMdata.JPEGlosslessCpt) or (lDICOMdata.JPEGlossyCpt) then
  3305.           lHdrOK := true
  3306.         else  showmessage('Error: Dicom header exceeds file size.');
  3307.         goto 666;
  3308.      end;
  3309.      if e_len > 0 then begin
  3310.         GetMem( buff, e_len);
  3311.      dBlockRead(fp, buff{^}, e_len, n);
  3312.      if lVerboseRead then
  3313.       case t of
  3314.            unknown :
  3315.                case e_len of
  3316.                1 : lStr := ( IntToStr(Integer(buff[0])));
  3317.             2 : Begin
  3318.                      if lDicomData.little_endian <> 0
  3319.                        then i := Integer(buff[0]) + 256*Integer(buff[1])
  3320.                     else i := Integer(buff[0])*256 + Integer(buff[1]);
  3321.                   lStr :=( IntToStr(i));
  3322.                               end;
  3323.             4 : Begin
  3324.                      if lDicomData.little_endian <> 0
  3325.                        then i :=               Integer(buff[0])
  3326.                               +         256*Integer(buff[1])
  3327.                               +     256*256*Integer(buff[2])
  3328.                               + 256*256*256*Integer(buff[3])
  3329.                     else i :=   Integer(buff[0])*256*256*256
  3330.                               + Integer(buff[1])*256*256
  3331.                               + Integer(buff[2])*256
  3332.                               + Integer(buff[3]);
  3333.                   lStr := (IntToStr(i));
  3334.                 end;
  3335.                 else begin
  3336.                          if e_len > 0 then begin
  3337.                             for i := 0 to e_len-1 do begin
  3338.                                 if Char(buff[i]) in ['+','-','/','\',' ', '0'..'9','a'..'z','A'..'Z'] then
  3339.                                    lStr := lStr+(Char(buff[i]))
  3340.                                 else
  3341.                                     lStr := lStr+('.');
  3342.                             end; {for i..e_len}
  3343.                          end else
  3344.                              lStr := '*NO DATA*';
  3345.             end;
  3346.            end;
  3347.  
  3348.         i8, i16, i32, ui8, ui16, ui32,
  3349.         _string  : for i := 0 to e_len-1 do
  3350.                        if Char(buff[i]) in ['+','-','/','\',' ', '0'..'9','a'..'z','A'..'Z']
  3351.                          then lStr := lStr +(Char(buff[i]))
  3352.                       else lStr := lStr +('.');
  3353.       end;
  3354.       FreeMem(buff);
  3355.  
  3356.       end; {e_len > 0... get mem}
  3357.     end
  3358.     else if e_len > 0 then lStr := (IntToStr(tmp))
  3359.     else {if e_len = 0 then} begin
  3360.          //TmpStr := '?';
  3361.          lStr := TmpStr;
  3362.     end;
  3363. {add this to show length size ->}//  lStr := lStr +'/'+inttostr(e_len);
  3364.  if (lGrp{info = 'identifying group'{})  then if MessageDlg(lStr+'= '+info+' '+IntToHex(where,4)+': ('+IntToHex(group,4)+','+IntToHex(element,4)+')'+IntToStr(e_len)+'. Continue?',
  3365.     mtConfirmation, [mbYes, mbNo], 0) = mrNo then  GOTO 666;
  3366. // if info = 'UNKNOWN' then showmessage(IntToHex(group,4)+','+IntToHex(element,4));
  3367. if lverboseRead then begin
  3368. if length(lDynStr) > kMaxTextBuf then begin
  3369.    if not lTextOverFlow  then begin
  3370.       lDynStr := lDynStr + 'Only showing the first '+inttostr(kMaxTextBuf) +' characters of this LARGE header';
  3371.       lTextOverFlow := true;
  3372.    end;
  3373.    //showmessage('Unable to display the entire header.');
  3374.    //goto 666;
  3375. end else
  3376.    lDynStr := lDynStr +IntToHex(group,4)+','+IntToHex(element,4)+','{+inttostr(where)+': '+lGrpStr}+Info+': '+lStr+kCR ;
  3377. end; //not verbose read
  3378.   end;    // end for
  3379.   lDicomData.ImageStart := dfilepos(fp);
  3380.   if lBigSet then begin
  3381.       if LBig then lDicomData.little_endian := 0
  3382.       else lDicomData.little_endian := 1;
  3383.   end;
  3384.   lHdrOK := true;
  3385. if lByteSwap then begin
  3386.     ByteSwap(lDicomdata.XYZdim[1]);
  3387.     ByteSwap(lDicomdata.XYZdim[2]);
  3388.     if lDicomdata.XYZdim[3] <> 1 then
  3389.      ByteSwap(lDicomdata.XYZdim[3]);
  3390.      ByteSwap(lDicomdata.SamplesPerPixel);
  3391.      ByteSwap(lDicomData.Allocbits_per_pixel);
  3392.      ByteSwap(lDicomData.Storedbits_per_pixel);
  3393. end;
  3394.   666:
  3395.   if lDiskCacheSz > 0 then
  3396.      freemem(lDiskCacheRA);
  3397.   if not lHdrOK then lImageFormatOK := false;
  3398.   CloseFile(fp);
  3399.   FileMode := 2; //set to read/write
  3400. end;
  3401.  
  3402.  
  3403. end.
  3404.