diff --git a/dependencies/zflate/zflate.pas b/dependencies/zflate/zflate.pas index 1a4dc8594..1d01e1283 100644 --- a/dependencies/zflate/zflate.pas +++ b/dependencies/zflate/zflate.pas @@ -1,930 +1,930 @@ -{ MIT License - - Copyright (c) 2023 fibodevy https://github.com/fibodevy - - Permission is hereby granted, free of charge, to any person obtaining a copy - of this software and associated documentation files (the "Software"), to - deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE - AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING - FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS - IN THE SOFTWARE. -} - -unit zflate; - -{$mode ObjFPC}{$H+} - -//comment out to disable error translation -//if disabled, zflatetranslatecode will return error code as string -{$define zflate_error_translation} - -interface - -uses - ZBase, ZInflate, ZDeflate; - -type - tzflate = record - z: z_stream; - totalout: dword; - bytesavailable: dword; - buffer: array of byte; - error: integer; - end; - - tzlibinfo = record - streamat: dword; - footerlen: dword; - end; - - tgzipinfo = record - modtime: dword; - filename: pchar; - comment: pchar; - streamat: dword; - footerlen: dword; - end; - - TBytes = array of byte; - -const - ZFLATE_ZLIB = 1; - ZFLATE_GZIP = 2; - - ZFLATE_OK = 0; - ZFLATE_ECHUNKTOOBIG = 101; //'chunk is too big' - ZFLATE_EBUFFER = 102; //'buffer too small' - ZFLATE_ESTREAM = 103; //'stream error' - ZFLATE_EDATA = 104; //'data error' - ZFLATE_EDEFLATE = 105; //'deflate error' - ZFLATE_EINFLATE = 106; //'inflate error' - ZFLATE_EDEFLATEINIT = 107; //'deflate init failed' - ZFLATE_EINFLATEINIT = 108; //'inflate init failed' - ZFLATE_EZLIBINVALID = 109; //'invalid zlib header' - ZFLATE_EGZIPINVALID = 110; //'invalid gzip header' - ZFLATE_ECHECKSUM = 111; //'invalid checksum' - ZFLATE_EOUTPUTSIZE = 112; //'output size doesnt match original file size' - ZFLATE_EABORTED = 113; //'aborted' - -var - zchunkmaxsize: dword = 1024*128; //128 KB default max chunk size - zbuffersize: dword = 1024*1024*64; //64 MB default buffer size - -threadvar - zlasterror: integer; - -//initialize zdeflate -function zdeflateinit(var z: tzflate; level: dword=9; buffersize: dword=0): boolean; -//deflate chunk -function zdeflatewrite(var z: tzflate; data: pointer; size: dword; lastchunk: boolean=false): boolean; - -//initialize zinflate -function zinflateinit(var z: tzflate; buffersize: dword=0): boolean; -//inflate chunk -function zinflatewrite(var z: tzflate; data: pointer; size: dword; lastchunk: boolean=false): boolean; - -//read zlib header -function zreadzlibheader(data: pointer; var info: tzlibinfo): boolean; -//read gzip header -function zreadgzipheader(data: pointer; var info: tgzipinfo): boolean; -//get stream basic info; by reading just few first bytes you will know the stream type, where is deflate start and how many bytes are trailing bytes (footer) -function zstreambasicinfo(data: pointer; var streamtype: dword; var startsat: dword; var trailing: dword): boolean; -//find out stream type, where deflate stream starts and what is its size -function zfindstream(data: pointer; size: dword; var streamtype: dword; var startsat: dword; var streamsize: dword): boolean; - -//compress whole buffer to DEFLATE at once -function gzdeflate(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9): boolean; -//compress whole string to DEFLATE at once -function gzdeflate(str: string; level: dword=9): string; -//compress whole bytes to DEFLATE at once -function gzdeflate(bytes : TBytes; level: dword=9): TBytes; -//decompress whole DEFLATE buffer at once -function gzinflate(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; -//decompress whole DEFLATE string at once -function gzinflate(str: string): string; -//decompress whole DEFLATE bytes at once -function gzinflate(bytes : TBytes): TBytes; - -//make ZLIB header -function makezlibheader(compressionlevel: integer): string; -//make ZLIB footer -function makezlibfooter(adler: dword): string; -//compress whole buffer to ZLIB at once -function gzcompress(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9): boolean; -//compress whole string to ZLIB at once -function gzcompress(str: string; level: dword=9): string; -//compress whole buffer to ZLIB at once -function gzcompress(bytes : TBytes; level: dword=9) : TBytes; -//dempress whole ZLIB buffer at once ! -function gzuncompress(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; -//dempress whole ZLIB string at once -function gzuncompress(str: string): string; -//dempress whole ZLIB buffer at once -function gzuncompress(bytes : TBytes) : TBytes; - -//make GZIP header -function makegzipheader(compressionlevel: integer; filename: string=''; comment: string=''): string; -//make GZIP footer -function makegzipfooter(originalsize: dword; crc: dword): string; -//compress whole buffer to GZIP at once -function gzencode(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9; filename: string=''; comment: string=''): boolean; -//compress whole string to GZIP at once -function gzencode(str: string; level: dword=9; filename: string=''; comment: string=''): string; -//compress whole string to GZIP at once -function gzencode(bytes: TBytes; level: dword=9; filename: string=''; comment: string=''): TBytes; -//decompress whole GZIP buffer at once -function gzdecode(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; -//decompress whole GZIP string at once -function gzdecode(str: string): string; -//decompress whole GZIP string at once -function gzdecode(bytes: TBytes): TBytes; - -//try to detect buffer format and decompress it at once -function zdecompress(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; -//try to detect string format and decompress it at once -function zdecompress(str: string): string; -//try to detect bytes format and decompress it at once -function zdecompress(bytes: TBytes): TBytes; - -//transalte error code to message -function zflatetranslatecode(code: integer): string; - -//compute crc32b checksum -function crc32b(crc: dword; buf: pbyte; len: dword): dword; -//compute adler32 checksum -function adler32(adler: dword; buf: pbyte; len: dword): dword; - -implementation - -function zerror(var z: tzflate; error: integer): boolean; -begin - z.error := error; - zlasterror := error; - result := false; -end; - -// -- deflate chunks ---------------------- - -function zdeflateinit(var z: tzflate; level: dword=9; buffersize: dword=0): boolean; -begin - result := false; - zlasterror := 0; - if buffersize = 0 then buffersize := zbuffersize; - fillchar(z, sizeof(z), 0); - setlength(z.buffer, buffersize); - if deflateInit2(z.z, level, Z_DEFLATED, -MAX_WBITS, DEF_MEM_LEVEL, 0) <> Z_OK then exit; - result := true; -end; - -function zdeflatewrite(var z: tzflate; data: pointer; size: dword; lastchunk: boolean=false): boolean; -var - i: integer; -begin - result := false; - - if size > zchunkmaxsize then exit(zerror(z, ZFLATE_ECHUNKTOOBIG)); - - z.z.next_in := data; - z.z.avail_in := size; - z.z.next_out := @z.buffer[0]; - z.z.avail_out := length(z.buffer); - - if lastchunk then - i := deflate(z.z, Z_FINISH) - else - i := deflate(z.z, Z_NO_FLUSH); - - if i = Z_BUF_ERROR then exit(zerror(z, ZFLATE_EBUFFER)); //buffer too small - if i = Z_STREAM_ERROR then exit(zerror(z, ZFLATE_ESTREAM)); - if i = Z_DATA_ERROR then exit(zerror(z, ZFLATE_EDATA)); - - if (i = Z_OK) or (i = Z_STREAM_END) then begin - z.bytesavailable := z.z.total_out-z.totalout; - z.totalout += z.bytesavailable; - result := true; - end else - exit(zerror(z, ZFLATE_EDEFLATE)); - - if lastchunk then begin - i := deflateEnd(z.z); - result := i = Z_OK; - end; -end; - -// -- inflate chunks ---------------------- - -function zinflateinit(var z: tzflate; buffersize: dword=0): boolean; -begin - result := false; - zlasterror := 0; - if buffersize = 0 then buffersize := zbuffersize; - fillchar(z, sizeof(z), 0); - setlength(z.buffer, buffersize); - if inflateInit2(z.z, -MAX_WBITS) <> Z_OK then exit; - result := true; -end; - -function zinflatewrite(var z: tzflate; data: pointer; size: dword; lastchunk: boolean=false): boolean; -var - i: integer; -begin - result := false; - - if size > zchunkmaxsize then exit(zerror(z, ZFLATE_ECHUNKTOOBIG)); - - z.z.next_in := data; - z.z.avail_in := size; - z.z.next_out := @z.buffer[0]; - z.z.avail_out := length(z.buffer); - - if lastchunk then - i := inflate(z.z, Z_FINISH) - else - i := inflate(z.z, Z_NO_FLUSH); - - if i = Z_BUF_ERROR then exit(zerror(z, ZFLATE_EBUFFER)); //buffer too small - if i = Z_STREAM_ERROR then exit(zerror(z, ZFLATE_ESTREAM)); - if i = Z_DATA_ERROR then exit(zerror(z, ZFLATE_EDATA)); - - if (i = Z_OK) or (i = Z_STREAM_END) then begin - z.bytesavailable := z.z.total_out-z.totalout; - z.totalout += z.bytesavailable; - result := true; - end else - exit(zerror(z, ZFLATE_EINFLATE)); - - if lastchunk then begin - i := inflateEnd(z.z); - result := i = Z_OK; - end; -end; - -function zreadzlibheader(data: pointer; var info: tzlibinfo): boolean; -begin - info.footerlen := 0; - info.streamat := 0; - - result := false; - try - fillchar(info, sizeof(info), 0); - result := (pbyte(data)^ = $78) and (pbyte(data+1)^ in [$01, $5e, $9c, $da]); - if not result then exit; - info.footerlen := 4; - info.streamat := 2; - except - end; -end; - -function zreadgzipheader(data: pointer; var info: tgzipinfo): boolean; -var - flags: byte; - w: word; -begin - result := false; - try - fillchar(info, sizeof(info), 0); - if not ((pbyte(data)^ = $1f) and (pbyte(data+1)^ = $8b)) then exit; - - info.footerlen := 8; - - //mod time - move((data+4)^, info.modtime, 4); - - //stream position - info.streamat := 10; - - //flags - flags := pbyte(data+3)^; - - //extra - if (flags and $04) <> 0 then begin - w := pword(data+info.streamat)^; - info.streamat += 2+w; - end; - - //filename - if (flags and $08) <> 0 then begin - info.filename := pchar(data+info.streamat); - info.streamat += length(info.filename)+1; - end; - - //comment - if (flags and $10) <> 0 then begin - info.comment := pchar(data+info.streamat); - info.streamat += length(info.comment)+1; - end; - - //crc16? - if (flags and $02) <> 0 then begin - info.streamat += 2; - end; - - result := true; - except - end; -end; - -function zstreambasicinfo(data: pointer; var streamtype: dword; var startsat: dword; var trailing: dword): boolean; -var - zlib: tzlibinfo; - gzip: tgzipinfo; -begin - result := false; - streamtype := 0; - - if zreadzlibheader(data, zlib) then begin - streamtype := ZFLATE_ZLIB; - startsat := zlib.streamat; - trailing := 4; //footer: adler32 - exit(true); - end; - - if zreadgzipheader(data, gzip) then begin - streamtype := ZFLATE_GZIP; - startsat := gzip.streamat; - trailing := 8; //footer: crc32 + original file size - exit(true); - end; -end; - -function zfindstream(data: pointer; size: dword; var streamtype: dword; var startsat: dword; var streamsize: dword): boolean; -var - trailing: dword; -begin - result := false; - - if size < 6 then exit; //6 bytes is minimum for ZLIB, 18 for GZIP - - if zstreambasicinfo(data, streamtype, startsat, trailing) then begin - streamsize := size-startsat-trailing; - result := true; - end; -end; - -// -- deflate ----------------------------- - -function gzdeflate(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9): boolean; -var - z: tzflate; - p, chunksize: dword; -begin - result := false; - if not zdeflateinit(z, level) then exit(zerror(z, ZFLATE_EDEFLATEINIT)); - - output := nil; - outputsize := 0; - p := 0; - - //compress - while size > 0 do begin - chunksize := size; - if chunksize > zchunkmaxsize then chunksize := zchunkmaxsize; - //deflate - if not zdeflatewrite(z, data, chunksize, chunksize 0 do begin - chunksize := size; - if chunksize > zchunkmaxsize then chunksize := zchunkmaxsize; - //inflate - if not zinflatewrite(z, data, chunksize, chunksize checksum) then exit(zerror(z, ZFLATE_ECHECKSUM)); - - result := true; -end; - -function gzuncompress(str: string): string; -var - p: pointer; - d: dword; -begin - result := ''; - if not gzuncompress(@str[1], length(str), p, d) then exit; - setlength(result, d); - move(p^, result[1], d); - freemem(p); -end; - -function gzuncompress(bytes : TBytes) : TBytes; -var - p: pointer; - d: dword; -begin - result := nil; - if not gzuncompress(@bytes[0], length(bytes), p, d) then exit; - try - setlength(result, d); - move(p^, result[0], d); - finally - freemem(p); - end; -end; - - -// -- GZIP compress ----------------------- - -function makegzipheader(compressionlevel: integer; filename: string=''; comment: string=''): string; -var - flags: byte; - modtime: dword; -begin - setlength(result, 10); - result[1] := #$1f; //signature - result[2] := #$8b; //signature - result[3] := #$08; //deflate algo - - //modification time - modtime := 0; - move(modtime, result[5], 4); - - result[9] := #$00; //compression level - if compressionlevel = 9 then result[9] := #$02; //best compression - if compressionlevel = 1 then result[9] := #$04; //best speed - - result[10] := #$FF; //file system (00 = FAT?) - //result[10] := #$00; - - //optional headers - flags := 0; - - //filename - if filename <> '' then begin - flags := flags or $08; - result += filename; - result += #$00; - end; - - //comment - if comment <> '' then begin - flags := flags or $10; - result += comment; - result += #00; - end; - - result[4] := chr(flags); -end; - -function makegzipfooter(originalsize: dword; crc: dword): string; -begin - setlength(result, 8); - move(crc, result[1], 4); - move(originalsize, result[1+4], 4); -end; - -function gzencode(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9; filename: string=''; comment: string=''): boolean; -var - header, footer: string; - deflated: pointer; - deflatedsize: dword; -begin - result := false; - - header := makegzipheader(level, filename, comment); - footer := makegzipfooter(size, crc32b(0, data, size)); - - if not gzdeflate(data, size, deflated, deflatedsize, level) then exit; - - outputsize := length(header)+deflatedsize+length(footer); - output := getmem(outputsize); - - move(header[1], output^, length(header)); - move(deflated^, (output+length(header))^, deflatedsize); - move(footer[1], (output+length(header)+deflatedsize)^, length(footer)); - - freemem(deflated); - - result := true; -end; - -function gzencode(str: string; level: dword=9; filename: string=''; comment: string=''): string; -var - p: pointer; - d: dword; -begin - result := ''; - if not gzencode(@str[1], length(str), p, d, level, filename, comment) then exit; - setlength(result, d); - move(p^, result[1], d); - freemem(p); -end; - -function gzencode(bytes: TBytes; level: dword=9; filename: string=''; comment: string=''): TBytes; -var - p: pointer; - d: dword; -begin - result := nil; - if not gzencode(@bytes[0], length(bytes), p, d, level, filename, comment) then exit; - setlength(result, d); - move(p^, result[0], d); - freemem(p); -end; - -// -- GZIP decompress --------------------- - -function gzdecode(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; -var - gzip: tgzipinfo; - z: tzflate; - originalsize, checksum: dword; -begin - result := false; - if not zreadgzipheader(data, gzip) then exit(zerror(z, ZFLATE_EGZIPINVALID)); - - originalsize := pdword(data+size-4)^; - checksum := pdword(data+size-8)^; - - data += gzip.streamat; - size -= gzip.streamat+gzip.footerlen; - if not gzinflate(data, size, output, outputsize) then exit; - - if originalsize <> outputsize then exit(zerror(z, ZFLATE_EOUTPUTSIZE)); - if crc32b(0, output, outputsize) <> checksum then exit(zerror(z, ZFLATE_ECHECKSUM)); - - result := true; -end; - -function gzdecode(str: string): string; -var - p: pointer; - d: dword; -begin - result := ''; - if not gzdecode(@str[1], length(str), p, d) then exit; - setlength(result, d); - move(p^, result[1], d); - freemem(p); -end; - -function gzdecode(bytes: TBytes): TBytes; -var - p: pointer; - d: dword; -begin - result := nil; - if not gzdecode(@bytes[0], length(bytes), p, d) then exit; - setlength(result, d); - move(p^, result[0], d); - freemem(p); -end; - -// -- decompress anything ----------------- - -function zdecompress(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; -var - streamsize, startsat, streamtype: dword; -begin - result := false; - - if not zfindstream(data, size, streamtype, startsat, streamsize) then begin - //stream not found, assume its pure deflate - startsat := 0; - streamsize := size; - end; - - if not gzinflate(data+startsat, streamsize, output, outputsize) then exit; - - result := true; -end; - -function zdecompress(str: string): string; -var - p: pointer; - d: dword; -begin - result := ''; - if not zdecompress(@str[1], length(str), p, d) then exit; - setlength(result, d); - move(p^, result[1], d); - freemem(p); -end; - -function zdecompress(bytes: TBytes): TBytes; -var - p: pointer; - d: dword; -begin - result := nil; - if not zdecompress(@bytes[0], length(bytes), p, d) then exit; - setlength(result, d); - move(p^, result[0], d); - freemem(p); -end; - -// -- error translation ------------------- - -function zflatetranslatecode(code: integer): string; -begin - {$ifdef zflate_error_translation} - result := 'unknown'; - - case code of - ZFLATE_ZLIB : result := 'ZLIB'; - ZFLATE_GZIP : result := 'GZIP'; - ZFLATE_OK : result := 'ok'; - ZFLATE_ECHUNKTOOBIG: result := 'chunk is too big'; - ZFLATE_EBUFFER : result := 'buffer too small'; - ZFLATE_ESTREAM : result := 'stream error'; - ZFLATE_EDATA : result := 'data error'; - ZFLATE_EDEFLATE : result := 'deflate error'; - ZFLATE_EINFLATE : result := 'inflate error'; - ZFLATE_EDEFLATEINIT: result := 'deflate init failed'; - ZFLATE_EINFLATEINIT: result := 'inflate init failed'; - ZFLATE_EZLIBINVALID: result := 'invalid zlib header'; - ZFLATE_EGZIPINVALID: result := 'invalid gzip header'; - ZFLATE_ECHECKSUM : result := 'invalid checksum'; - ZFLATE_EOUTPUTSIZE : result := 'output size doesnt match original file size'; - ZFLATE_EABORTED : result := 'aborted'; - end; - {$else} - system.Str(code, result); - {$endif} -end; - -// -- crc32b ------------------------------ - -var - crc32_table: array[byte] of dword; - crc32_table_empty: boolean = true; - -function crc32b(crc: dword; buf: pbyte; len: dword): dword; -procedure make_crc32_table; -var - d: dword; - n, k: integer; -begin - for n := 0 to 255 do begin - d := cardinal(n); - for k := 0 to 7 do begin - if (d and 1) <> 0 then - d := (d shr 1) xor uint32($edb88320) - else - d := (d shr 1); - end; - crc32_table[n] := d; - end; - crc32_table_empty := false; -end; -begin - if buf = nil then exit(0); - if crc32_table_empty then make_crc32_table; - - crc := crc xor $ffffffff; - while (len >= 4) do begin - crc := crc32_table[(crc xor buf[0]) and $ff] xor (crc shr 8); - crc := crc32_table[(crc xor buf[1]) and $ff] xor (crc shr 8); - crc := crc32_table[(crc xor buf[2]) and $ff] xor (crc shr 8); - crc := crc32_table[(crc xor buf[3]) and $ff] xor (crc shr 8); - inc(buf, 4); - dec(len, 4); - end; - - while (len > 0) do begin - crc := crc32_table[(crc xor buf^) and $ff] xor (crc shr 8); - inc(buf); - dec(len); - end; - - result := crc xor $ffffffff; -end; - -// -- adler32 ----------------------------- - -function adler32(adler: dword; buf: pbyte; len: dword): dword; -const - base = dword(65521); - nmax = 3854; -var - d1, d2: dword; - k: integer; -begin - if buf = nil then exit(1); - - d1 := adler and $ffff; - d2 := (adler shr 16) and $ffff; - - while (len > 0) do begin - if len < nmax then - k := len - else - k := nmax; - dec(len, k); - while (k > 0) do begin - inc(d1, buf^); - inc(d2, d1); - inc(buf); - dec(k); - end; - d1 := d1 mod base; - d2 := d2 mod base; - end; - result := (d2 shl 16) or d1; -end; - -end. - +{ MIT License + + Copyright (c) 2023 fibodevy https://github.com/fibodevy + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to + deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS + IN THE SOFTWARE. +} + +unit zflate; + +{$mode ObjFPC}{$H+} + +//comment out to disable error translation +//if disabled, zflatetranslatecode will return error code as string +{$define zflate_error_translation} + +interface + +uses + ZBase, ZInflate, ZDeflate; + +type + tzflate = record + z: z_stream; + totalout: dword; + bytesavailable: dword; + buffer: array of byte; + error: integer; + end; + + tzlibinfo = record + streamat: dword; + footerlen: dword; + end; + + tgzipinfo = record + modtime: dword; + filename: pchar; + comment: pchar; + streamat: dword; + footerlen: dword; + end; + + TBytes = array of byte; + +const + ZFLATE_ZLIB = 1; + ZFLATE_GZIP = 2; + + ZFLATE_OK = 0; + ZFLATE_ECHUNKTOOBIG = 101; //'chunk is too big' + ZFLATE_EBUFFER = 102; //'buffer too small' + ZFLATE_ESTREAM = 103; //'stream error' + ZFLATE_EDATA = 104; //'data error' + ZFLATE_EDEFLATE = 105; //'deflate error' + ZFLATE_EINFLATE = 106; //'inflate error' + ZFLATE_EDEFLATEINIT = 107; //'deflate init failed' + ZFLATE_EINFLATEINIT = 108; //'inflate init failed' + ZFLATE_EZLIBINVALID = 109; //'invalid zlib header' + ZFLATE_EGZIPINVALID = 110; //'invalid gzip header' + ZFLATE_ECHECKSUM = 111; //'invalid checksum' + ZFLATE_EOUTPUTSIZE = 112; //'output size doesnt match original file size' + ZFLATE_EABORTED = 113; //'aborted' + +var + zchunkmaxsize: dword = 1024*128; //128 KB default max chunk size + zbuffersize: dword = 1024*1024*64; //64 MB default buffer size + +threadvar + zlasterror: integer; + +//initialize zdeflate +function zdeflateinit(var z: tzflate; level: dword=9; buffersize: dword=0): boolean; +//deflate chunk +function zdeflatewrite(var z: tzflate; data: pointer; size: dword; lastchunk: boolean=false): boolean; + +//initialize zinflate +function zinflateinit(var z: tzflate; buffersize: dword=0): boolean; +//inflate chunk +function zinflatewrite(var z: tzflate; data: pointer; size: dword; lastchunk: boolean=false): boolean; + +//read zlib header +function zreadzlibheader(data: pointer; var info: tzlibinfo): boolean; +//read gzip header +function zreadgzipheader(data: pointer; var info: tgzipinfo): boolean; +//get stream basic info; by reading just few first bytes you will know the stream type, where is deflate start and how many bytes are trailing bytes (footer) +function zstreambasicinfo(data: pointer; var streamtype: dword; var startsat: dword; var trailing: dword): boolean; +//find out stream type, where deflate stream starts and what is its size +function zfindstream(data: pointer; size: dword; var streamtype: dword; var startsat: dword; var streamsize: dword): boolean; + +//compress whole buffer to DEFLATE at once +function gzdeflate(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9): boolean; +//compress whole string to DEFLATE at once +function gzdeflate(str: string; level: dword=9): string; +//compress whole bytes to DEFLATE at once +function gzdeflate(bytes : TBytes; level: dword=9): TBytes; +//decompress whole DEFLATE buffer at once +function gzinflate(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; +//decompress whole DEFLATE string at once +function gzinflate(str: string): string; +//decompress whole DEFLATE bytes at once +function gzinflate(bytes : TBytes): TBytes; + +//make ZLIB header +function makezlibheader(compressionlevel: integer): string; +//make ZLIB footer +function makezlibfooter(adler: dword): string; +//compress whole buffer to ZLIB at once +function gzcompress(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9): boolean; +//compress whole string to ZLIB at once +function gzcompress(str: string; level: dword=9): string; +//compress whole buffer to ZLIB at once +function gzcompress(bytes : TBytes; level: dword=9) : TBytes; +//dempress whole ZLIB buffer at once ! +function gzuncompress(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; +//dempress whole ZLIB string at once +function gzuncompress(str: string): string; +//dempress whole ZLIB buffer at once +function gzuncompress(bytes : TBytes) : TBytes; + +//make GZIP header +function makegzipheader(compressionlevel: integer; filename: string=''; comment: string=''): string; +//make GZIP footer +function makegzipfooter(originalsize: dword; crc: dword): string; +//compress whole buffer to GZIP at once +function gzencode(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9; filename: string=''; comment: string=''): boolean; +//compress whole string to GZIP at once +function gzencode(str: string; level: dword=9; filename: string=''; comment: string=''): string; +//compress whole string to GZIP at once +function gzencode(bytes: TBytes; level: dword=9; filename: string=''; comment: string=''): TBytes; +//decompress whole GZIP buffer at once +function gzdecode(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; +//decompress whole GZIP string at once +function gzdecode(str: string): string; +//decompress whole GZIP string at once +function gzdecode(bytes: TBytes): TBytes; + +//try to detect buffer format and decompress it at once +function zdecompress(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; +//try to detect string format and decompress it at once +function zdecompress(str: string): string; +//try to detect bytes format and decompress it at once +function zdecompress(bytes: TBytes): TBytes; + +//transalte error code to message +function zflatetranslatecode(code: integer): string; + +//compute crc32b checksum +function crc32b(crc: dword; buf: pbyte; len: dword): dword; +//compute adler32 checksum +function adler32(adler: dword; buf: pbyte; len: dword): dword; + +implementation + +function zerror(var z: tzflate; error: integer): boolean; +begin + z.error := error; + zlasterror := error; + result := false; +end; + +// -- deflate chunks ---------------------- + +function zdeflateinit(var z: tzflate; level: dword=9; buffersize: dword=0): boolean; +begin + result := false; + zlasterror := 0; + if buffersize = 0 then buffersize := zbuffersize; + fillchar(z, sizeof(z), 0); + setlength(z.buffer, buffersize); + if deflateInit2(z.z, level, Z_DEFLATED, -MAX_WBITS, DEF_MEM_LEVEL, 0) <> Z_OK then exit; + result := true; +end; + +function zdeflatewrite(var z: tzflate; data: pointer; size: dword; lastchunk: boolean=false): boolean; +var + i: integer; +begin + result := false; + + if size > zchunkmaxsize then exit(zerror(z, ZFLATE_ECHUNKTOOBIG)); + + z.z.next_in := data; + z.z.avail_in := size; + z.z.next_out := @z.buffer[0]; + z.z.avail_out := length(z.buffer); + + if lastchunk then + i := deflate(z.z, Z_FINISH) + else + i := deflate(z.z, Z_NO_FLUSH); + + if i = Z_BUF_ERROR then exit(zerror(z, ZFLATE_EBUFFER)); //buffer too small + if i = Z_STREAM_ERROR then exit(zerror(z, ZFLATE_ESTREAM)); + if i = Z_DATA_ERROR then exit(zerror(z, ZFLATE_EDATA)); + + if (i = Z_OK) or (i = Z_STREAM_END) then begin + z.bytesavailable := z.z.total_out-z.totalout; + z.totalout += z.bytesavailable; + result := true; + end else + exit(zerror(z, ZFLATE_EDEFLATE)); + + if lastchunk then begin + i := deflateEnd(z.z); + result := i = Z_OK; + end; +end; + +// -- inflate chunks ---------------------- + +function zinflateinit(var z: tzflate; buffersize: dword=0): boolean; +begin + result := false; + zlasterror := 0; + if buffersize = 0 then buffersize := zbuffersize; + fillchar(z, sizeof(z), 0); + setlength(z.buffer, buffersize); + if inflateInit2(z.z, -MAX_WBITS) <> Z_OK then exit; + result := true; +end; + +function zinflatewrite(var z: tzflate; data: pointer; size: dword; lastchunk: boolean=false): boolean; +var + i: integer; +begin + result := false; + + if size > zchunkmaxsize then exit(zerror(z, ZFLATE_ECHUNKTOOBIG)); + + z.z.next_in := data; + z.z.avail_in := size; + z.z.next_out := @z.buffer[0]; + z.z.avail_out := length(z.buffer); + + if lastchunk then + i := inflate(z.z, Z_FINISH) + else + i := inflate(z.z, Z_NO_FLUSH); + + if i = Z_BUF_ERROR then exit(zerror(z, ZFLATE_EBUFFER)); //buffer too small + if i = Z_STREAM_ERROR then exit(zerror(z, ZFLATE_ESTREAM)); + if i = Z_DATA_ERROR then exit(zerror(z, ZFLATE_EDATA)); + + if (i = Z_OK) or (i = Z_STREAM_END) then begin + z.bytesavailable := z.z.total_out-z.totalout; + z.totalout += z.bytesavailable; + result := true; + end else + exit(zerror(z, ZFLATE_EINFLATE)); + + if lastchunk then begin + i := inflateEnd(z.z); + result := i = Z_OK; + end; +end; + +function zreadzlibheader(data: pointer; var info: tzlibinfo): boolean; +begin + info.footerlen := 0; + info.streamat := 0; + + result := false; + try + fillchar(info, sizeof(info), 0); + result := (pbyte(data)^ = $78) and (pbyte(data+1)^ in [$01, $5e, $9c, $da]); + if not result then exit; + info.footerlen := 4; + info.streamat := 2; + except + end; +end; + +function zreadgzipheader(data: pointer; var info: tgzipinfo): boolean; +var + flags: byte; + w: word; +begin + result := false; + try + fillchar(info, sizeof(info), 0); + if not ((pbyte(data)^ = $1f) and (pbyte(data+1)^ = $8b)) then exit; + + info.footerlen := 8; + + //mod time + move((data+4)^, info.modtime, 4); + + //stream position + info.streamat := 10; + + //flags + flags := pbyte(data+3)^; + + //extra + if (flags and $04) <> 0 then begin + w := pword(data+info.streamat)^; + info.streamat += 2+w; + end; + + //filename + if (flags and $08) <> 0 then begin + info.filename := pchar(data+info.streamat); + info.streamat += length(info.filename)+1; + end; + + //comment + if (flags and $10) <> 0 then begin + info.comment := pchar(data+info.streamat); + info.streamat += length(info.comment)+1; + end; + + //crc16? + if (flags and $02) <> 0 then begin + info.streamat += 2; + end; + + result := true; + except + end; +end; + +function zstreambasicinfo(data: pointer; var streamtype: dword; var startsat: dword; var trailing: dword): boolean; +var + zlib: tzlibinfo; + gzip: tgzipinfo; +begin + result := false; + streamtype := 0; + + if zreadzlibheader(data, zlib) then begin + streamtype := ZFLATE_ZLIB; + startsat := zlib.streamat; + trailing := 4; //footer: adler32 + exit(true); + end; + + if zreadgzipheader(data, gzip) then begin + streamtype := ZFLATE_GZIP; + startsat := gzip.streamat; + trailing := 8; //footer: crc32 + original file size + exit(true); + end; +end; + +function zfindstream(data: pointer; size: dword; var streamtype: dword; var startsat: dword; var streamsize: dword): boolean; +var + trailing: dword; +begin + result := false; + + if size < 6 then exit; //6 bytes is minimum for ZLIB, 18 for GZIP + + if zstreambasicinfo(data, streamtype, startsat, trailing) then begin + streamsize := size-startsat-trailing; + result := true; + end; +end; + +// -- deflate ----------------------------- + +function gzdeflate(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9): boolean; +var + z: tzflate; + p, chunksize: dword; +begin + result := false; + if not zdeflateinit(z, level) then exit(zerror(z, ZFLATE_EDEFLATEINIT)); + + output := nil; + outputsize := 0; + p := 0; + + //compress + while size > 0 do begin + chunksize := size; + if chunksize > zchunkmaxsize then chunksize := zchunkmaxsize; + //deflate + if not zdeflatewrite(z, data, chunksize, chunksize 0 do begin + chunksize := size; + if chunksize > zchunkmaxsize then chunksize := zchunkmaxsize; + //inflate + if not zinflatewrite(z, data, chunksize, chunksize checksum) then exit(zerror(z, ZFLATE_ECHECKSUM)); + + result := true; +end; + +function gzuncompress(str: string): string; +var + p: pointer; + d: dword; +begin + result := ''; + if not gzuncompress(@str[1], length(str), p, d) then exit; + setlength(result, d); + move(p^, result[1], d); + freemem(p); +end; + +function gzuncompress(bytes : TBytes) : TBytes; +var + p: pointer; + d: dword; +begin + result := nil; + if not gzuncompress(@bytes[0], length(bytes), p, d) then exit; + try + setlength(result, d); + move(p^, result[0], d); + finally + freemem(p); + end; +end; + + +// -- GZIP compress ----------------------- + +function makegzipheader(compressionlevel: integer; filename: string=''; comment: string=''): string; +var + flags: byte; + modtime: dword; +begin + setlength(result, 10); + result[1] := #$1f; //signature + result[2] := #$8b; //signature + result[3] := #$08; //deflate algo + + //modification time + modtime := 0; + move(modtime, result[5], 4); + + result[9] := #$00; //compression level + if compressionlevel = 9 then result[9] := #$02; //best compression + if compressionlevel = 1 then result[9] := #$04; //best speed + + result[10] := #$FF; //file system (00 = FAT?) + //result[10] := #$00; + + //optional headers + flags := 0; + + //filename + if filename <> '' then begin + flags := flags or $08; + result += filename; + result += #$00; + end; + + //comment + if comment <> '' then begin + flags := flags or $10; + result += comment; + result += #00; + end; + + result[4] := chr(flags); +end; + +function makegzipfooter(originalsize: dword; crc: dword): string; +begin + setlength(result, 8); + move(crc, result[1], 4); + move(originalsize, result[1+4], 4); +end; + +function gzencode(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9; filename: string=''; comment: string=''): boolean; +var + header, footer: string; + deflated: pointer; + deflatedsize: dword; +begin + result := false; + + header := makegzipheader(level, filename, comment); + footer := makegzipfooter(size, crc32b(0, data, size)); + + if not gzdeflate(data, size, deflated, deflatedsize, level) then exit; + + outputsize := length(header)+deflatedsize+length(footer); + output := getmem(outputsize); + + move(header[1], output^, length(header)); + move(deflated^, (output+length(header))^, deflatedsize); + move(footer[1], (output+length(header)+deflatedsize)^, length(footer)); + + freemem(deflated); + + result := true; +end; + +function gzencode(str: string; level: dword=9; filename: string=''; comment: string=''): string; +var + p: pointer; + d: dword; +begin + result := ''; + if not gzencode(@str[1], length(str), p, d, level, filename, comment) then exit; + setlength(result, d); + move(p^, result[1], d); + freemem(p); +end; + +function gzencode(bytes: TBytes; level: dword=9; filename: string=''; comment: string=''): TBytes; +var + p: pointer; + d: dword; +begin + result := nil; + if not gzencode(@bytes[0], length(bytes), p, d, level, filename, comment) then exit; + setlength(result, d); + move(p^, result[0], d); + freemem(p); +end; + +// -- GZIP decompress --------------------- + +function gzdecode(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; +var + gzip: tgzipinfo; + z: tzflate; + originalsize, checksum: dword; +begin + result := false; + if not zreadgzipheader(data, gzip) then exit(zerror(z, ZFLATE_EGZIPINVALID)); + + originalsize := pdword(data+size-4)^; + checksum := pdword(data+size-8)^; + + data += gzip.streamat; + size -= gzip.streamat+gzip.footerlen; + if not gzinflate(data, size, output, outputsize) then exit; + + if originalsize <> outputsize then exit(zerror(z, ZFLATE_EOUTPUTSIZE)); + if crc32b(0, output, outputsize) <> checksum then exit(zerror(z, ZFLATE_ECHECKSUM)); + + result := true; +end; + +function gzdecode(str: string): string; +var + p: pointer; + d: dword; +begin + result := ''; + if not gzdecode(@str[1], length(str), p, d) then exit; + setlength(result, d); + move(p^, result[1], d); + freemem(p); +end; + +function gzdecode(bytes: TBytes): TBytes; +var + p: pointer; + d: dword; +begin + result := nil; + if not gzdecode(@bytes[0], length(bytes), p, d) then exit; + setlength(result, d); + move(p^, result[0], d); + freemem(p); +end; + +// -- decompress anything ----------------- + +function zdecompress(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; +var + streamsize, startsat, streamtype: dword; +begin + result := false; + + if not zfindstream(data, size, streamtype, startsat, streamsize) then begin + //stream not found, assume its pure deflate + startsat := 0; + streamsize := size; + end; + + if not gzinflate(data+startsat, streamsize, output, outputsize) then exit; + + result := true; +end; + +function zdecompress(str: string): string; +var + p: pointer; + d: dword; +begin + result := ''; + if not zdecompress(@str[1], length(str), p, d) then exit; + setlength(result, d); + move(p^, result[1], d); + freemem(p); +end; + +function zdecompress(bytes: TBytes): TBytes; +var + p: pointer; + d: dword; +begin + result := nil; + if not zdecompress(@bytes[0], length(bytes), p, d) then exit; + setlength(result, d); + move(p^, result[0], d); + freemem(p); +end; + +// -- error translation ------------------- + +function zflatetranslatecode(code: integer): string; +begin + {$ifdef zflate_error_translation} + result := 'unknown'; + + case code of + ZFLATE_ZLIB : result := 'ZLIB'; + ZFLATE_GZIP : result := 'GZIP'; + ZFLATE_OK : result := 'ok'; + ZFLATE_ECHUNKTOOBIG: result := 'chunk is too big'; + ZFLATE_EBUFFER : result := 'buffer too small'; + ZFLATE_ESTREAM : result := 'stream error'; + ZFLATE_EDATA : result := 'data error'; + ZFLATE_EDEFLATE : result := 'deflate error'; + ZFLATE_EINFLATE : result := 'inflate error'; + ZFLATE_EDEFLATEINIT: result := 'deflate init failed'; + ZFLATE_EINFLATEINIT: result := 'inflate init failed'; + ZFLATE_EZLIBINVALID: result := 'invalid zlib header'; + ZFLATE_EGZIPINVALID: result := 'invalid gzip header'; + ZFLATE_ECHECKSUM : result := 'invalid checksum'; + ZFLATE_EOUTPUTSIZE : result := 'output size doesnt match original file size'; + ZFLATE_EABORTED : result := 'aborted'; + end; + {$else} + system.Str(code, result); + {$endif} +end; + +// -- crc32b ------------------------------ + +var + crc32_table: array[byte] of dword; + crc32_table_empty: boolean = true; + +function crc32b(crc: dword; buf: pbyte; len: dword): dword; +procedure make_crc32_table; +var + d: dword; + n, k: integer; +begin + for n := 0 to 255 do begin + d := cardinal(n); + for k := 0 to 7 do begin + if (d and 1) <> 0 then + d := (d shr 1) xor uint32($edb88320) + else + d := (d shr 1); + end; + crc32_table[n] := d; + end; + crc32_table_empty := false; +end; +begin + if buf = nil then exit(0); + if crc32_table_empty then make_crc32_table; + + crc := crc xor $ffffffff; + while (len >= 4) do begin + crc := crc32_table[(crc xor buf[0]) and $ff] xor (crc shr 8); + crc := crc32_table[(crc xor buf[1]) and $ff] xor (crc shr 8); + crc := crc32_table[(crc xor buf[2]) and $ff] xor (crc shr 8); + crc := crc32_table[(crc xor buf[3]) and $ff] xor (crc shr 8); + inc(buf, 4); + dec(len, 4); + end; + + while (len > 0) do begin + crc := crc32_table[(crc xor buf^) and $ff] xor (crc shr 8); + inc(buf); + dec(len); + end; + + result := crc xor $ffffffff; +end; + +// -- adler32 ----------------------------- + +function adler32(adler: dword; buf: pbyte; len: dword): dword; +const + base = dword(65521); + nmax = 3854; +var + d1, d2: dword; + k: integer; +begin + if buf = nil then exit(1); + + d1 := adler and $ffff; + d2 := (adler shr 16) and $ffff; + + while (len > 0) do begin + if len < nmax then + k := len + else + k := nmax; + dec(len, k); + while (k > 0) do begin + inc(d1, buf^); + inc(d2, d1); + inc(buf); + dec(k); + end; + d1 := d1 mod base; + d2 := d2 mod base; + end; + result := (d2 shl 16) or d1; +end; + +end. + diff --git a/exec/pack/Messages.properties b/exec/pack/Messages.properties index 6dd50a982..cd8c2310e 100644 --- a/exec/pack/Messages.properties +++ b/exec/pack/Messages.properties @@ -551,6 +551,8 @@ XHTML_URL_INVALID_CHARS_one = URL contains Invalid Character ({1}) XHTML_URL_INVALID_CHARS_other = URL contains {0} Invalid Characters ({1}) TERMINOLOGY_TX_SYSTEM_HTTPS = The system URL ''{0}'' wrongly starts with https: not http: CODESYSTEM_CS_NO_VS_NOTCOMPLETE = Review the All Codes Value Set - incomplete CodeSystems generally should not have an all codes value set specified +CODESYSTEM_CS_NO_VS_SUPPLEMENT1 = CodeSystems supplements should not have an all codes value set specified, and if they do, it must match the base code system +CODESYSTEM_CS_NO_VS_SUPPLEMENT2 = CodeSystems supplements should not have an all codes value set specified, and if they do, it must match the base code system, and this one does not (''{0}'') TYPE_SPECIFIC_CHECKS_DT_IDENTIFIER_IETF_SYSTEM_VALUE = if identifier.system is ''urn:ietf:rfc:3986'', then the identifier.value must be a full URI (e.g. start with a scheme), not ''{0}'' TYPE_SPECIFIC_CHECKS_DT_ATT_SIZE_INVALID = Stated Attachment Size {0} is not valid TYPE_SPECIFIC_CHECKS_DT_ATT_SIZE_CORRECT = Stated Attachment Size {0} does not match actual attachment size {1} @@ -1056,7 +1058,6 @@ VALUESET_CIRCULAR_REFERENCE = Found a circularity pointing to {0} processing Val VALUESET_SUPPLEMENT_MISSING_one = Required supplement not found: {1} VALUESET_SUPPLEMENT_MISSING_other = Required supplements not found: {1} CONCEPTMAP_VS_TOO_MANY_CODES = The concept map has too many codes to validate ({0}) -CONCEPTMAP_VS_CONCEPT_CODE_UNKNOWN_SYSTEM = The code ''{1}'' comes from the system {0} which could not be found, so it''s not known whether it''s valid in the value set ''{2}'' CONCEPTMAP_VS_INVALID_CONCEPT_CODE = The code ''{1}'' in the system {0} is not valid in the value set ''{2}'' CONCEPTMAP_VS_INVALID_CONCEPT_CODE_VER = The code ''{2}'' in the system {0} version {1} is not valid in the value set ''{3}'' VALUESET_INC_TOO_MANY_CODES = The value set include has too many codes to validate ({0}), so each individual code has not been checked @@ -1108,7 +1109,7 @@ Validation_VAL_Profile_Minimum_SLICE_other = Slice ''{3}'': minimum required = { FHIRPATH_UNKNOWN_EXTENSION = Reference to an unknown extension - double check that the URL ''{0}'' is correct Type_Specific_Checks_DT_XHTML_Resolve = Hyperlink ''{0}'' at ''{1}'' for ''{2}''' does not resolve Type_Specific_Checks_DT_XHTML_Resolve_Img = Image source ''{0}'' at ''{1}'' does not resolve -TYPE_SPECIFIC_CHECKS_DT_XHTML_MULTIPLE_MATCHES = Hyperlink ''{0}'' at ''{1}'' for ''{2}''' resolves to multiple targets +TYPE_SPECIFIC_CHECKS_DT_XHTML_MULTIPLE_MATCHES = Hyperlink ''{0}'' at ''{1}'' for ''{2}'' resolves to multiple targets ({3}) CONTAINED_ORPHAN_DOM3 = The contained resource ''{0}'' is not referenced to from elsewhere in the containing resource nor does it refer to the containing resource (dom-3) VALUESET_INCLUDE_CS_NOT_CS = The include system ''{0}'' is a reference to a contained resource, but the contained resource with that id is not a CodeSystem, it's a {1} VALUESET_INCLUDE_CS_NOT_FOUND = No matching contained code system found for system ''{0}'' @@ -1117,3 +1118,16 @@ VALUESET_INCLUDE_CS_MULTI_FOUND = Multiple matching contained code systems found VALUESET_INCLUDE_CSVER_MULTI_FOUND = Multiple matching contained code systems found for system ''{0}'' version ''{1}'' CODE_CASE_DIFFERENCE = The code ''{0}'' differs from the correct code ''{1}'' by case. Although the code system ''{2}'' is case insensitive, implementers are strongly encouraged to use the correct case anyway SCT_NO_MRCM = Not validated against the Machine Readable Concept Model (MRCM) +ILLEGAL_PROPERTY = The property ''{0}'' is invalid +VALUESET_INCLUDE_SYSTEM_ABSOLUTE = URI values in ValueSet.compose.include.system must be absolute +VALUESET_INCLUDE_SYSTEM_ABSOLUTE_FRAG = URI values in ValueSet.compose.include.system must be absolute. To reference a contained code system, use the full CodeSystem URL and reference it using the http://hl7.org/fhir/StructureDefinition/valueset-system extension +CODESYSTEM_CS_SUPP_NO_SUPP = The code system is marked as a supplement, but it does not define what code system it supplements +VALUESET_INCLUDE_CS_CONTENT = The value set references CodeSystem ''{0}'' which has status ''{1}'' +VALUESET_INCLUDE_CSVER_CONTENT = The value set references CodeSystem ''{0}'' version ''{2}'' which has status ''{1}'' +VALUESET_INCLUDE_CS_SUPPLEMENT = The value set references CodeSystem ''{0}'' which is a supplement. It must reference the underlying CodeSystem ''{1}'' and use the http://hl7.org/fhir/StructureDefinition/valueset-supplement extension for the supplement +VALUESET_INCLUDE_CSVER_SUPPLEMENT = The value set references CodeSystem ''{0}'' version ''{2}'' which is a supplement. It must reference the underlying CodeSystem ''{1}'' and use the http://hl7.org/fhir/StructureDefinition/valueset-supplement extension for the supplement +CODESYSTEM_SUPP_NO_DISPLAY = This display (''{0}'') differs from that defined by the base code system (''{1}''). Both displays claim to be 'the "primary designation" for the same language (''{2}''), and the correct interpretation of this is undefined +CODESYSTEM_NOT_CONTAINED = CodeSystems are referred to directly from Coding.system, so it's generally best for them not to be contained resources +CODESYSTEM_THO_CHECK = Most code systems defined in HL7 IGs will need to move to THO later during the process. Consider giving this code system a THO URL now (See https://confluence.hl7.org/display/TSMG/Terminology+Play+Book) +TYPE_SPECIFIC_CHECKS_DT_CANONICAL_MULTIPLE_POSSIBLE_VERSIONS = There are multiple different potential matches for the url ''{0}''. It might be a good idea to fix to the correct version to reduce the likelihood of a wrong version being selected by an implementation/implementer. Using version ''{1}'', found versions: {2} +ABSTRACT_CODE_NOT_ALLOWED = Code ''{0}#{1}'' is abstract, and not allowed in this context diff --git a/ipsmanager/forms/frm_home.pas b/ipsmanager/forms/frm_home.pas index f7cdc9c6e..6ac295811 100644 --- a/ipsmanager/forms/frm_home.pas +++ b/ipsmanager/forms/frm_home.pas @@ -1,110 +1,138 @@ -unit frm_home; - -{$i fhir.inc} - -interface - -uses - Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, ComCtrls, - Menus, ActnList, laz.VirtualTrees, - mvBase, mvDataSources; - -type - - { TIPSManagerForm } - - TIPSManagerForm = class(TForm) - actionViewDataSources: TAction; - actionViewDocumentList: TAction; - ActionList1: TActionList; - ImageList1: TImageList; - imgMain: TImageList; - vtNavigator: TLazVirtualStringTree; - MainMenu1: TMainMenu; - mnuApple: TMenuItem; - MenuItem10: TMenuItem; - MenuItem11: TMenuItem; - MenuItem12: TMenuItem; - mnuItemSettings: TMenuItem; - MenuItem14: TMenuItem; - MenuItem2: TMenuItem; - MenuItem3: TMenuItem; - MenuItem4: TMenuItem; - MenuItem5: TMenuItem; - MenuItem6: TMenuItem; - mnuFileExit: TMenuItem; - MenuItem8: TMenuItem; - MenuItem9: TMenuItem; - Panel1: TPanel; - pnlPresentation: TPanel; - pnlNavigator: TPanel; - Splitter1: TSplitter; - StatusBar1: TStatusBar; - ToolBar1: TToolBar; - ToolButton2: TToolButton; - ToolButton3: TToolButton; - ToolButton4: TToolButton; - procedure actionViewDataSourcesExecute(Sender: TObject); - procedure FormCreate(Sender: TObject); - procedure FormDestroy(Sender: TObject); - procedure MenuItem2Click(Sender: TObject); - procedure mnuFileExitClick(Sender: TObject); - private - FView : TViewManager; - procedure SetView(AValue: TViewManager); - public - property View : TViewManager read FView write SetView; - end; - -var - IPSManagerForm: TIPSManagerForm; - -implementation - -{$R *.lfm} - -{ TIPSManagerForm } - -procedure TIPSManagerForm.MenuItem2Click(Sender: TObject); -begin - -end; - -procedure TIPSManagerForm.mnuFileExitClick(Sender: TObject); -begin - Close; -end; - -procedure TIPSManagerForm.SetView(AValue: TViewManager); -begin - FView.Free; - FView := AValue; - FView.navigator := vtNavigator; - FView.NavPanel := pnlNavigator; - FView.presentation := pnlPresentation; -end; - -procedure TIPSManagerForm.FormCreate(Sender: TObject); -begin - {$IFDEF OSX} - mnuApple.caption := #$EF#$A3#$BF; - mnuItemSettings.caption := 'Preferences...'; - {$ELSE} - mnuApple.Visible := false; - {$ENDIF} - self.actionViewDataSources.OnExecute(self); -end; - -procedure TIPSManagerForm.FormDestroy(Sender: TObject); -begin - FView.free; -end; - -procedure TIPSManagerForm.actionViewDataSourcesExecute(Sender: TObject); -begin - //View := TDataSourceViewManager.create(FIniFile); - //View.Initialize; -end; - -end. - +unit frm_home; + +{ +Copyright (c) 2011+, HL7 and Health Intersections Pty Ltd (http://www.healthintersections.com.au) +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of HL7 nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +} + +{$i fhir.inc} + +interface + +uses + Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, ComCtrls, + Menus, ActnList, laz.VirtualTrees, + mvBase, mvDataSources; + +type + + { TIPSManagerForm } + + TIPSManagerForm = class(TForm) + actionViewDataSources: TAction; + actionViewDocumentList: TAction; + ActionList1: TActionList; + ImageList1: TImageList; + imgMain: TImageList; + vtNavigator: TLazVirtualStringTree; + MainMenu1: TMainMenu; + mnuApple: TMenuItem; + MenuItem10: TMenuItem; + MenuItem11: TMenuItem; + MenuItem12: TMenuItem; + mnuItemSettings: TMenuItem; + MenuItem14: TMenuItem; + MenuItem2: TMenuItem; + MenuItem3: TMenuItem; + MenuItem4: TMenuItem; + MenuItem5: TMenuItem; + MenuItem6: TMenuItem; + mnuFileExit: TMenuItem; + MenuItem8: TMenuItem; + MenuItem9: TMenuItem; + Panel1: TPanel; + pnlPresentation: TPanel; + pnlNavigator: TPanel; + Splitter1: TSplitter; + StatusBar1: TStatusBar; + ToolBar1: TToolBar; + ToolButton2: TToolButton; + ToolButton3: TToolButton; + ToolButton4: TToolButton; + procedure actionViewDataSourcesExecute(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure MenuItem2Click(Sender: TObject); + procedure mnuFileExitClick(Sender: TObject); + private + FView : TViewManager; + procedure SetView(AValue: TViewManager); + public + property View : TViewManager read FView write SetView; + end; + +var + IPSManagerForm: TIPSManagerForm; + +implementation + +{$R *.lfm} + +{ TIPSManagerForm } + +procedure TIPSManagerForm.MenuItem2Click(Sender: TObject); +begin + +end; + +procedure TIPSManagerForm.mnuFileExitClick(Sender: TObject); +begin + Close; +end; + +procedure TIPSManagerForm.SetView(AValue: TViewManager); +begin + FView.Free; + FView := AValue; + FView.navigator := vtNavigator; + FView.NavPanel := pnlNavigator; + FView.presentation := pnlPresentation; +end; + +procedure TIPSManagerForm.FormCreate(Sender: TObject); +begin + {$IFDEF OSX} + mnuApple.caption := #$EF#$A3#$BF; + mnuItemSettings.caption := 'Preferences...'; + {$ELSE} + mnuApple.Visible := false; + {$ENDIF} + self.actionViewDataSources.OnExecute(self); +end; + +procedure TIPSManagerForm.FormDestroy(Sender: TObject); +begin + FView.free; +end; + +procedure TIPSManagerForm.actionViewDataSourcesExecute(Sender: TObject); +begin + //View := TDataSourceViewManager.create(FIniFile); + //View.Initialize; +end; + +end. + diff --git a/ipsmanager/ipsmanager.lpr b/ipsmanager/ipsmanager.lpr index 53450f9d4..2a35af76c 100644 --- a/ipsmanager/ipsmanager.lpr +++ b/ipsmanager/ipsmanager.lpr @@ -1,33 +1,33 @@ -program ipsmanager; - -{$I fhir.inc} - -uses - {$IFDEF WINDOWS} - FastMM4, - {$ELSE} - cmem, - cthreads, - {$ENDIF} - - Interfaces, // this includes the LCL widgetset - Forms, datetimectrls, - { you can add units after this } - fsl_base, fsl_threads, fsl_logging, fsl_utilities, fsl_collections, fsl_xml, - fsl_json, fui_lcl_managers, fhir_objects, fhir_xhtml, fsl_http, v2_dictionary, - fsl_ucum, fhir_client, fhir_oauth, fsl_web_init, - FrameViewer09, - frm_home, mvBase, mvDataSources; - -{$R *.res} - -begin - RequireDerivedFormResource := True; - Application.Title := 'Patient Summary Manager'; - Application.Scaled := True; - Application.Initialize; - - Application.CreateForm(TIPSManagerForm, IPSManagerForm); - Application.Run; -end. - +program ipsmanager; + +{$I fhir.inc} + +uses + {$IFDEF WINDOWS} + FastMM4, + {$ELSE} + cmem, + cthreads, + {$ENDIF} + + Interfaces, // this includes the LCL widgetset + Forms, datetimectrls, + { you can add units after this } + fsl_base, fsl_threads, fsl_logging, fsl_utilities, fsl_collections, fsl_xml, + fsl_json, fui_lcl_managers, fhir_objects, fhir_xhtml, fsl_http, v2_dictionary, + fsl_ucum, fhir_client, fhir_oauth, fsl_web_init, + FrameViewer09, + frm_home, mvBase, mvDataSources; + +{$R *.res} + +begin + RequireDerivedFormResource := True; + Application.Title := 'Patient Summary Manager'; + Application.Scaled := True; + Application.Initialize; + + Application.CreateForm(TIPSManagerForm, IPSManagerForm); + Application.Run; +end. + diff --git a/ipsmanager/views/mvbase.pas b/ipsmanager/views/mvbase.pas index ac99535a2..fb611852a 100644 --- a/ipsmanager/views/mvbase.pas +++ b/ipsmanager/views/mvbase.pas @@ -1,55 +1,83 @@ -unit mvbase; - -{$i fhir.inc} - -interface - -uses - Classes, SysUtils, - ExtCtrls, - laz.VirtualTrees, - fsl_base, - fhir4_client; - -type - - { TViewManager } - - TViewManager = class (TFslObject) - private - FClient: TFhirClient4; - FNavigator: TLazVirtualStringTree; - FNavPanel: TPanel; - FPresentation: TPanel; - procedure SetClient(AValue: TFhirClient4); - procedure SetNavigator(AValue: TLazVirtualStringTree); - public - property client : TFhirClient4 read FClient write SetClient; - property NavPanel : TPanel read FNavPanel write FNavPanel; - property navigator : TLazVirtualStringTree read FNavigator write SetNavigator; - property presentation : TPanel read FPresentation write FPresentation; - - procedure initialize; virtual; - end; - -implementation - -{ TViewManager } - -procedure TViewManager.SetClient(AValue: TFhirClient4); -begin - FClient.free; - FClient:=AValue; -end; - -procedure TViewManager.SetNavigator(AValue: TLazVirtualStringTree); -begin - FNavigator:=AValue; -end; - -procedure TViewManager.initialize; -begin - -end; - -end. +unit mvbase; + +{ +Copyright (c) 2011+, HL7 and Health Intersections Pty Ltd (http://www.healthintersections.com.au) +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of HL7 nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +} + +{$i fhir.inc} + +interface + +uses + Classes, SysUtils, + ExtCtrls, + laz.VirtualTrees, + fsl_base, + fhir4_client; + +type + + { TViewManager } + + TViewManager = class (TFslObject) + private + FClient: TFhirClient4; + FNavigator: TLazVirtualStringTree; + FNavPanel: TPanel; + FPresentation: TPanel; + procedure SetClient(AValue: TFhirClient4); + procedure SetNavigator(AValue: TLazVirtualStringTree); + public + property client : TFhirClient4 read FClient write SetClient; + property NavPanel : TPanel read FNavPanel write FNavPanel; + property navigator : TLazVirtualStringTree read FNavigator write SetNavigator; + property presentation : TPanel read FPresentation write FPresentation; + + procedure initialize; virtual; + end; + +implementation + +{ TViewManager } + +procedure TViewManager.SetClient(AValue: TFhirClient4); +begin + FClient.free; + FClient:=AValue; +end; + +procedure TViewManager.SetNavigator(AValue: TLazVirtualStringTree); +begin + FNavigator:=AValue; +end; + +procedure TViewManager.initialize; +begin + +end; + +end. diff --git a/ipsmanager/views/mvdatasources.pas b/ipsmanager/views/mvdatasources.pas index 13b1bd332..8a55982af 100644 --- a/ipsmanager/views/mvdatasources.pas +++ b/ipsmanager/views/mvdatasources.pas @@ -1,29 +1,57 @@ -unit mvdatasources; - -{$i fhir.inc} - -interface - -uses - Classes, SysUtils, - mvBase; - -type - { TDataSourceViewManager } - - TDataSourceViewManager = class (TViewManager) - private - public - procedure initialize; override; - end; - -implementation - -{ TDataSourceViewManager } - -procedure TDataSourceViewManager.initialize; -begin - inherited initialize; -end; - -end. +unit mvdatasources; + +{ +Copyright (c) 2011+, HL7 and Health Intersections Pty Ltd (http://www.healthintersections.com.au) +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of HL7 nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +} + +{$i fhir.inc} + +interface + +uses + Classes, SysUtils, + mvBase; + +type + { TDataSourceViewManager } + + TDataSourceViewManager = class (TViewManager) + private + public + procedure initialize; override; + end; + +implementation + +{ TDataSourceViewManager } + +procedure TDataSourceViewManager.initialize; +begin + inherited initialize; +end; + +end. diff --git a/library/cda/cda_base.pas b/library/cda/cda_base.pas index 549f0bd22..11b6c048c 100644 --- a/library/cda/cda_base.pas +++ b/library/cda/cda_base.pas @@ -463,6 +463,7 @@ constructor Tv3PropertyValueStringCollection.Create(aType: TRMPropertyDefinition var iLoop : Integer; begin +! FValue := TWideStringList.Create; if sValues <> '' Then FValue.Text := sValues; diff --git a/library/cda/cda_writer.pas b/library/cda/cda_writer.pas index 538345641..92b6bfd6c 100644 --- a/library/cda/cda_writer.pas +++ b/library/cda/cda_writer.pas @@ -961,7 +961,7 @@ procedure TCDAWriter.WriteCDA(oXml: TXmlBuilder; oDoc: TcdaClinicalDocument); if (oDT is Tv3PQ) Then WritePQ(sPath, oXml, sName, oDT as Tv3PQ, bOptional) Else if (oDT is Tv3CD) Then - WriteCD(sPath, oXml, sName, oDT as Tv3CD, bOptional, true) + WriteCD(sPath, oXml, sName, oDT as Tv3CD, bOptional) Else if (oDT is Tv3BL) Then WriteBL(sPath, oXml, sName, oDT as Tv3BL, bOptional) Else if (oDT is Tv3CS) Then diff --git a/library/fdb/fdb_fts.pas b/library/fdb/fdb_fts.pas index 484241a4a..685205697 100644 --- a/library/fdb/fdb_fts.pas +++ b/library/fdb/fdb_fts.pas @@ -1,165 +1,193 @@ -unit fdb_fts; - -{$i fhir.inc} - -interface - -uses - Classes, SysUtils, - fsl_base, fsl_utilities, - fdb_manager, fdb_sqlite3; - -Type - { TFDBFullTextSearchCompartment } - - TFDBFullTextSearchCompartment = class (TFslObject) - private - FName: String; - public - constructor Create(name : String); - property name : String read FName write FName; - end; - - { TFDBFullTextSearch } - - TFDBFullTextSearch = {abstract} class (TFslObject) - private - FName : string; - public - constructor Create(name : String); - function link : TFDBFullTextSearch; - - Property name : String read FName; - function createCompartment(name : String) : TFDBFullTextSearchCompartment; virtual; abstract; - procedure addText(compartment : TFDBFullTextSearchCompartment; id : String; name, text : string); virtual; abstract; - function closeCompartment(compartment : TFDBFullTextSearchCompartment) : String; virtual; abstract; - - procedure search(compartment : String; criteria : String; ids : TStringList); virtual; abstract; - end; - - { TFDBSqlLiteFullTextSearchCompartment } - - TFDBSqlLiteFullTextSearchCompartment = class (TFDBFullTextSearchCompartment) - private - FConn : TFDBConnection; - public - constructor create(name : String; Conn : TFDBConnection); - property Conn : TFDBConnection read FConn; - end; - - TFDBSqlLiteFullTextSearch = class (TFDBFullTextSearch) - private - FDB : TFDBSQLiteManager; - public - constructor create(name : string; db : TFDBSQLiteManager); - destructor Destroy; override; - - function createCompartment(name : String) : TFDBFullTextSearchCompartment; override; - procedure addText(compartment : TFDBFullTextSearchCompartment; id : String; name, text : string); override; - function closeCompartment(compartment : TFDBFullTextSearchCompartment) : String; override; - - procedure search(compartment : String; criteria : String; ids : TStringList); override; - end; - - { TFDBFullTextSearchFactory } - - TFDBFullTextSearchFactory = class (TFslObject) - public - class function makeSQLiteTextSearch(name : String) : TFDBFullTextSearch; - end; - -implementation - -{ TFDBFullTextSearchFactory } - -class function TFDBFullTextSearchFactory.makeSQLiteTextSearch(name : String): TFDBFullTextSearch; -var - fn : String; -begin - fn := FilePath(['[tmp]', 'fts-'+name+'.db']); - deleteFile(fn); - result := TFDBSqlLiteFullTextSearch.create(name, TFDBSQLiteManager.create('fts-'+name, fn, false, true)); -end; - -{ TFDBSqlLiteFullTextSearchCompartment } - -constructor TFDBSqlLiteFullTextSearchCompartment.create(name: String; Conn: TFDBConnection); -begin - inherited Create(name); - FConn := Conn; -end; - -{ TFDBFullTextSearchCompartment } - -constructor TFDBFullTextSearchCompartment.create(name: String); -begin - inherited Create; - FName := name; -end; - -{ TFDBSqlLiteFullTextSearch } - -constructor TFDBSqlLiteFullTextSearch.create(name : String; db: TFDBSQLiteManager); -begin - inherited create(name); - FDB := db; -end; - -destructor TFDBSqlLiteFullTextSearch.Destroy; -begin - FDB.Free; - inherited Destroy; -end; - -function TFDBSqlLiteFullTextSearch.createCompartment(name: String): TFDBFullTextSearchCompartment; -var - conn : TFDBConnection; -begin - conn := FDB.GetConnection('compartment'); - conn.ExecSQL('CREATE VIRTUAL TABLE '+name+' USING fts5(id, name, content);'); - conn.SQL := 'Insert into '+name+' (id, name, content) values (:id, :name, :content)'; - conn.Prepare; - result := TFDBSqlLiteFullTextSearchCompartment.create(name, conn); -end; - -procedure TFDBSqlLiteFullTextSearch.addText(compartment: TFDBFullTextSearchCompartment; id: String; name, text: string); -var - conn : TFDBConnection; -begin - conn := (compartment as TFDBSqlLiteFullTextSearchCompartment).Conn; - conn.BindString('id', id); - conn.BindString('name', name); - conn.BindString('content', text); - conn.Execute; -end; - -function TFDBSqlLiteFullTextSearch.closeCompartment(compartment: TFDBFullTextSearchCompartment) : String; -var - conn : TFDBConnection; -begin - conn := (compartment as TFDBSqlLiteFullTextSearchCompartment).Conn; - conn.Terminate; - result := inttostr(conn.CountSQL('Select count(*) from '+compartment.name))+' Entries'; - conn.Release; -end; - -procedure TFDBSqlLiteFullTextSearch.search(compartment: String; criteria: String; ids: TStringList); -begin - // not done yet -end; - -{ TFDBFullTextSearch } - -constructor TFDBFullTextSearch.Create(name: String); -begin - inherited Create; - FName := name; -end; - -function TFDBFullTextSearch.link: TFDBFullTextSearch; -begin - result := TFDBFullTextSearch(inherited link); -end; - -end. - +unit fdb_fts; + +{ +Copyright (c) 2011+, HL7 and Health Intersections Pty Ltd (http://www.healthintersections.com.au) +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of HL7 nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +} + +{$i fhir.inc} + +interface + +uses + Classes, SysUtils, + fsl_base, fsl_utilities, + fdb_manager, fdb_sqlite3; + +Type + { TFDBFullTextSearchCompartment } + + TFDBFullTextSearchCompartment = class (TFslObject) + private + FName: String; + public + constructor Create(name : String); + property name : String read FName write FName; + end; + + { TFDBFullTextSearch } + + TFDBFullTextSearch = {abstract} class (TFslObject) + private + FName : string; + public + constructor Create(name : String); + function link : TFDBFullTextSearch; + + Property name : String read FName; + function createCompartment(name : String) : TFDBFullTextSearchCompartment; virtual; abstract; + procedure addText(compartment : TFDBFullTextSearchCompartment; id : String; name, text : string); virtual; abstract; + function closeCompartment(compartment : TFDBFullTextSearchCompartment) : String; virtual; abstract; + + procedure search(compartment : String; criteria : String; ids : TStringList); virtual; abstract; + end; + + { TFDBSqlLiteFullTextSearchCompartment } + + TFDBSqlLiteFullTextSearchCompartment = class (TFDBFullTextSearchCompartment) + private + FConn : TFDBConnection; + public + constructor create(name : String; Conn : TFDBConnection); + property Conn : TFDBConnection read FConn; + end; + + TFDBSqlLiteFullTextSearch = class (TFDBFullTextSearch) + private + FDB : TFDBSQLiteManager; + public + constructor create(name : string; db : TFDBSQLiteManager); + destructor Destroy; override; + + function createCompartment(name : String) : TFDBFullTextSearchCompartment; override; + procedure addText(compartment : TFDBFullTextSearchCompartment; id : String; name, text : string); override; + function closeCompartment(compartment : TFDBFullTextSearchCompartment) : String; override; + + procedure search(compartment : String; criteria : String; ids : TStringList); override; + end; + + { TFDBFullTextSearchFactory } + + TFDBFullTextSearchFactory = class (TFslObject) + public + class function makeSQLiteTextSearch(name : String) : TFDBFullTextSearch; + end; + +implementation + +{ TFDBFullTextSearchFactory } + +class function TFDBFullTextSearchFactory.makeSQLiteTextSearch(name : String): TFDBFullTextSearch; +var + fn : String; +begin + fn := FilePath(['[tmp]', 'fts-'+name+'.db']); + deleteFile(fn); + result := TFDBSqlLiteFullTextSearch.create(name, TFDBSQLiteManager.create('fts-'+name, fn, false, true)); +end; + +{ TFDBSqlLiteFullTextSearchCompartment } + +constructor TFDBSqlLiteFullTextSearchCompartment.create(name: String; Conn: TFDBConnection); +begin + inherited Create(name); + FConn := Conn; +end; + +{ TFDBFullTextSearchCompartment } + +constructor TFDBFullTextSearchCompartment.create(name: String); +begin + inherited Create; + FName := name; +end; + +{ TFDBSqlLiteFullTextSearch } + +constructor TFDBSqlLiteFullTextSearch.create(name : String; db: TFDBSQLiteManager); +begin + inherited create(name); + FDB := db; +end; + +destructor TFDBSqlLiteFullTextSearch.Destroy; +begin + FDB.Free; + inherited Destroy; +end; + +function TFDBSqlLiteFullTextSearch.createCompartment(name: String): TFDBFullTextSearchCompartment; +var + conn : TFDBConnection; +begin + conn := FDB.GetConnection('compartment'); + conn.ExecSQL('CREATE VIRTUAL TABLE '+name+' USING fts5(id, name, content);'); + conn.SQL := 'Insert into '+name+' (id, name, content) values (:id, :name, :content)'; + conn.Prepare; + result := TFDBSqlLiteFullTextSearchCompartment.create(name, conn); +end; + +procedure TFDBSqlLiteFullTextSearch.addText(compartment: TFDBFullTextSearchCompartment; id: String; name, text: string); +var + conn : TFDBConnection; +begin + conn := (compartment as TFDBSqlLiteFullTextSearchCompartment).Conn; + conn.BindString('id', id); + conn.BindString('name', name); + conn.BindString('content', text); + conn.Execute; +end; + +function TFDBSqlLiteFullTextSearch.closeCompartment(compartment: TFDBFullTextSearchCompartment) : String; +var + conn : TFDBConnection; +begin + conn := (compartment as TFDBSqlLiteFullTextSearchCompartment).Conn; + conn.Terminate; + result := inttostr(conn.CountSQL('Select count(*) from '+compartment.name))+' Entries'; + conn.Release; +end; + +procedure TFDBSqlLiteFullTextSearch.search(compartment: String; criteria: String; ids: TStringList); +begin + // not done yet +end; + +{ TFDBFullTextSearch } + +constructor TFDBFullTextSearch.Create(name: String); +begin + inherited Create; + FName := name; +end; + +function TFDBFullTextSearch.link: TFDBFullTextSearch; +begin + result := TFDBFullTextSearch(inherited link); +end; + +end. + diff --git a/library/fhir-dev.inc b/library/fhir-dev.inc index edfecb17a..a17814ff3 100644 --- a/library/fhir-dev.inc +++ b/library/fhir-dev.inc @@ -1,10 +1,14 @@ -// there's a bug in the lazarus/FPC compiler where global settings -// such as assertions are not consistently the same across all units. -// this resets the global compile settings for development MODE - -// do not make changes in the file fhir-status.inc - it is overwritten by either fhir-dev.inc or fhir-prod.inc by the build scripts - -{$C+} // assertions on -{$I+} // IO checking on -{$Q+} // overflow checking on -{$R+} // range checking on +// there's a bug in the lazarus/FPC compiler where global settings +// such as assertions are not consistently the same across all units. +// this resets the global compile settings for development MODE + +// these settings are intended to be consistent between code and compile options in the project settings + +// do not make changes in the file fhir-status.inc - it is overwritten by either fhir-dev.inc or fhir-prod.inc by the build scripts + +{$C+} // assertions on - this is the important one - turns object tracking on and off consistently +{$I+} // IO checking on - though this is probably useless? +{$Q-} // overflow checking off - these are always off; doesn't run with them on +{$R-} // range checking off - these are always off; doesn't run with them on +{$OPTIMIZATION OFF} // all optimizations off for production +{$D+} // debugging info on for development diff --git a/library/fhir-prod.inc b/library/fhir-prod.inc index a7316f71f..4a809a60f 100644 --- a/library/fhir-prod.inc +++ b/library/fhir-prod.inc @@ -1,10 +1,14 @@ -// there's a bug in the lazarus/FPC compiler where global settings -// such as assertions are not consistently the same across all units. -// this resets the global compile settings for development MODE - -// do not make changes in the file fhir-status.inc - it is overwritten by either fhir-dev.inc or fhir-prod.inc by the build scripts - -{$C-} // assertions on -{$I-} // IO checking on -{$Q-} // overflow checking on -{$R-} // range checking on +// there's a bug in the lazarus/FPC compiler where global settings +// such as assertions are not consistently the same across all units. +// this resets the global compile settings for development MODE + +// these settings are intended to be consistent between code and compile options in the project settings + +// do not make changes in the file fhir-status.inc - it is overwritten by either fhir-dev.inc or fhir-prod.inc by the build scripts + +{$C-} // assertions off - this is the important one - turns object tracking off consistently +{$I-} // IO checking off +{$Q-} // overflow checking off - these are always off; doesn't run with them on +{$R-} // range checking off - these are always off; doesn't run with them on +{$OPTIMIZATION LEVEL3} // level 3 optimizations for production +{$D-} // debugging info off for production diff --git a/library/fhir-status.inc b/library/fhir-status.inc index 142320b4c..a17814ff3 100644 --- a/library/fhir-status.inc +++ b/library/fhir-status.inc @@ -1,11 +1,14 @@ -// there's a bug in the lazarus/FPC compiler where global settings -// such as assertions are not consistently the same across all units. -// this resets the global compile settings for development MODE - -// do not make changes in the file fhir-status.inc - it is overwritten by either fhir-dev.inc or fhir-prod.inc by the build scripts - -{$C+} // assertions on -{$I+} // IO checking on -{$Q+} // overflow checking on -{$R+} // range checking on - +// there's a bug in the lazarus/FPC compiler where global settings +// such as assertions are not consistently the same across all units. +// this resets the global compile settings for development MODE + +// these settings are intended to be consistent between code and compile options in the project settings + +// do not make changes in the file fhir-status.inc - it is overwritten by either fhir-dev.inc or fhir-prod.inc by the build scripts + +{$C+} // assertions on - this is the important one - turns object tracking on and off consistently +{$I+} // IO checking on - though this is probably useless? +{$Q-} // overflow checking off - these are always off; doesn't run with them on +{$R-} // range checking off - these are always off; doesn't run with them on +{$OPTIMIZATION OFF} // all optimizations off for production +{$D+} // debugging info on for development diff --git a/library/fhir/fhir_utilities.pas b/library/fhir/fhir_utilities.pas index 61f5d472c..171fa8bcd 100644 --- a/library/fhir/fhir_utilities.pas +++ b/library/fhir/fhir_utilities.pas @@ -88,6 +88,7 @@ function DetectFormat(bytes : TBytes) : TFHIRFormat; overload; function DetectFormat(oContent : TFslBuffer) : TFHIRFormat; overload; function csName(url : string) : String; +function csUriForProperty(code : String) : String; implementation @@ -509,5 +510,22 @@ function csName(url : string) : String; end; +function csUriForProperty(code : String) : String; +begin + if (code = 'status') then result := 'http://hl7.org/fhir/concept-properties#status' + else if (code = 'inactive') then result := 'http://hl7.org/fhir/concept-properties#inactive' + else if (code = 'effectiveDate') then result := 'http://hl7.org/fhir/concept-properties#effectiveDate' + else if (code = 'deprecationDate') then result := 'http://hl7.org/fhir/concept-properties#deprecationDate' + else if (code = 'retirementDate') then result := 'http://hl7.org/fhir/concept-properties#retirementDate' + else if (code = 'notSelectable') then result := 'http://hl7.org/fhir/concept-properties#notSelectable' + else if (code = 'parent') then result := 'http://hl7.org/fhir/concept-properties#parent' + else if (code = 'child') then result := 'http://hl7.org/fhir/concept-properties#child' + else if (code = 'partOf') then result := 'http://hl7.org/fhir/concept-properties#partOf' + else if (code = 'synonym') then result := 'http://hl7.org/fhir/concept-properties#synonym' + else if (code = 'comment') then result := 'http://hl7.org/fhir/concept-properties#comment' + else if (code = 'itemWeight') then result := 'http://hl7.org/fhir/concept-properties#itemWeight' + else + result := ''; +end; end. diff --git a/library/fhir2/fhir2_narrative2.pas b/library/fhir2/fhir2_narrative2.pas index 778eef933..240f7df76 100644 --- a/library/fhir2/fhir2_narrative2.pas +++ b/library/fhir2/fhir2_narrative2.pas @@ -110,7 +110,7 @@ implementation function TNarrativeGenerator.capitalize(s : String):String; begin - if( s = '') then + if (s = '') then result := '' else result := UpperCase(s.substring(0, 1)) + s.substring(1); diff --git a/library/fhir3/fhir3_utilities.pas b/library/fhir3/fhir3_utilities.pas index 7a0c01748..ee6508277 100644 --- a/library/fhir3/fhir3_utilities.pas +++ b/library/fhir3/fhir3_utilities.pas @@ -5148,6 +5148,8 @@ function TFhirCodeSystemHelper.GetSystem: String; function TFhirCodeSystemHelper.isAbstract(concept: TFhirCodeSystemConcept): boolean; var p : TFhirCodeSystemConceptProperty; + pd : TFhirCodeSystemProperty; + c, s : String; begin result := false; for p in concept.property_List do @@ -5155,8 +5157,18 @@ function TFhirCodeSystemHelper.isAbstract(concept: TFhirCodeSystemConcept): bool if (p.code = 'abstract') and (p.value is TFhirBoolean) and (TFHIRBoolean(p.value).value) then exit(true); end; + s := csUriForProperty('notSelectable'); + c := 'notSelectable'; + if (s <> '') then + for pd in property_List do + if pd.uri = s then + begin + c := pd.code; + break; + end; + for p in concept.property_List do - if (p.code = 'notSelectable') and (p.value is TFhirBoolean) and (TFHIRBoolean(p.value).value) then + if (p.code = c) and (p.value is TFhirBoolean) and (TFHIRBoolean(p.value).value) then exit(true); end; @@ -6023,7 +6035,7 @@ function TFhirReferenceHelper.GetEditString: String; if reference <> '' then result := reference else - result := '"'+display+'"'; + result := '''+display+'''; end; function TFhirReferenceHelper.getId: String; diff --git a/library/fhir4/fhir4_ips.pas b/library/fhir4/fhir4_ips.pas index b0285778b..7e69d3dfa 100644 --- a/library/fhir4/fhir4_ips.pas +++ b/library/fhir4/fhir4_ips.pas @@ -1,1144 +1,1172 @@ -unit fhir4_ips; - -{$i fhir.inc} - -interface - -uses - Classes, SysUtils, - fsl_base, fsl_json, fsl_stream, fsl_http, fsl_utilities, fsl_logging, - fhir_xhtml, fhir_objects, fhir_parser, - fhir4_resources, fhir4_resources_clinical, fhir4_types, fhir4_utilities, fhir4_json, fhir4_xml; - -const - ROOT = 'http://healthintersections.com.au/IPS/'; - -type - { TIPSGenerator } - - TIPSGenerator = class (TFslObject) - private - FFormatChoice : String; - FFile: TFslbuffer; - FParams: THTTPParameters; - FLastId : integer; - FPatDesc : String; - procedure SetFile(AValue: TFslbuffer); - procedure SetParams(AValue: THTTPParameters); - - function nextId(pfx : String) : String; - function makeCodeableConcept(systemUri, code, display, text : String) : TFhirCodeableConcept; - function makeAttachment(mimeType, title : String; content : TFslBuffer) : TFhirAttachment; overload; - function makeAttachment(mimeType, title : String; ref : String) : TFhirAttachment; overload; - function makeDiv(ext : boolean; out x : TFhirXHtmlNode) : TFHIRNarrative; - procedure addToBundle(bnd : TFhirBundle; resource : TFHIRResource); - function addSection(comp : TFhirComposition; title, systemUri, code : String; out x : TFhirXHtmlNode) : TFHIRCompositionSection; - - function makeBundle : TFhirBundle; - function makeComposition : TFHIRComposition; - function makePatient : TFhirPatient; - function makeFuncStatusCondition(sect : TFHIRCompositionSection; ul : TFhirXHtmlNode; paramName, text, systemUri, code, display : String) : TFHIRCondition; - function makeOrganRegistryEntry(sect : TFHIRCompositionSection; ul : TFhirXHtmlNode; paramName, text, systemUri, code, display : String) : TFHIRObservation; - function makeFuncStatusTextCondition(sect : TFHIRCompositionSection; x : TFhirXHtmlNode; paramName : string) : TFHIRCondition; - function makeCareAdvocate(sect : TFHIRCompositionSection; ul : TFhirXHtmlNode) : TFHIRRelatedPerson; - procedure makeAvoidanceRelationship(sect : TFHIRCompositionSection; ul : TFhirXHtmlNode; s : String); - function makeConsent(sect : TFHIRCompositionSection; ul : TFhirXHtmlNode; fwds : boolean; paramName, textYes, textNo, systemUri, code, display : String) : TFHIRConsent; - function makeDocRef(sect : TFHIRCompositionSection; ul : TFhirXHtmlNode) : TFHIRDocumentReference; - public - destructor Destroy; Override; - - property params : THTTPParameters read FParams write SetParams; - property attachment : TFslbuffer read FFile write SetFile; - - function generateBundle : TFhirBundle; - function generateBinary : TFslBuffer; - end; - - - { TIPSWrapper } - TIPSVersionKind = (ivkOriginal, ivkTransformed, ivkAnnotated); - TIPSAttachmentKind = (iakBrand, iakAuthored, iakAttachment, iakStylesheet); - - TIPSWrapper = class (TFslObject) - private - FManifest : TJsonObject; - FContent : TFslMap; - function writeManifest : TBytes; - public - constructor Create; override; - destructor Destroy; override; - - procedure startBuild(name : String); - procedure addIPS(ips : TFhirBundle; kind : TIPSVersionKind; agent : String); - procedure addAttachment(attachment : TFslBuffer; fn : String; kind : TIPSAttachmentKind); - - class function fromStream(stream : TStream) : TIPSWrapper; overload; - class function fromStream(stream : TFslStream) : TIPSWrapper; overload; - procedure saveToStream(stream : TStream); overload; - procedure saveToStream(stream : TFslStream); overload; - function saveToBytes : TBytes; - end; - -const - CODES_TIPSVersionKind : array [TIPSVersionKind] of String = ('original', 'transformed', 'annotated'); - CODES_TIPSAttachmentKind : array [TIPSAttachmentKind] of String = ('brand', 'authored', 'attachment', 'stylesheet'); - -implementation - -{ TIPSGenerator } - -destructor TIPSGenerator.Destroy; -begin - FParams.free; - FFile.free; - inherited Destroy; -end; - -procedure TIPSGenerator.SetParams(AValue: THTTPParameters); -begin - FParams.free; - FParams:=AValue; -end; - -procedure TIPSGenerator.SetFile(AValue: TFslbuffer); -begin - FFile.free; - FFile:=AValue; -end; - -function TIPSGenerator.nextId(pfx : String): String; -begin - inc(FLastId); - result := pfx+inttostr(FLastId); -end; - - -function TIPSGenerator.makeCodeableConcept(systemUri, code, display, text : String) : TFhirCodeableConcept; -begin - result := TFHIRCodeableConcept.Create(systemUri, code); - result.codingList[0].display := display; - result.text := text; -end; - -function TIPSGenerator.makeAttachment(mimeType, title: String; content: TFslBuffer): TFhirAttachment; -begin - result := TFhirAttachment.Create; - try - result.contentType := mimeType; - result.title := title; - result.data := content.AsBytes; - result.link; - finally - result.free; - end; -end; - -function TIPSGenerator.makeAttachment(mimeType, title: String; ref: String): TFhirAttachment; -begin - result := TFhirAttachment.Create; - try - result.contentType := mimeType; - result.title := title; - result.url := ref; - result.link; - finally - result.free; - end; -end; - -function TIPSGenerator.makeDiv(ext : boolean; out x : TFhirXHtmlNode): TFHIRNarrative; -begin - result := TFHIRNarrative.Create; - try - if ext then - result.status := NarrativeStatusExtensions - else - result.status := NarrativeStatusGenerated; - result.div_ := TFhirXHtmlNode.Create('div'); - result.div_.attribute('xmlns', 'http://www.w3.org/1999/xhtml'); - x := result.div_; - result.link; - finally - result.free; - end; -end; - -procedure TIPSGenerator.addToBundle(bnd : TFhirBundle; resource : TFHIRResource); -var - e : TFHIRBundleEntry; -begin - if (resource <> nil) then - begin - e := bnd.entryList.Append; - e.fullUrl := URLPath([ROOT, resource.fhirType, resource.id]); - e.resource := resource.Link; - end; -end; - -function TIPSGenerator.addSection(comp : TFhirComposition; title, systemUri, code : String; out x : TFhirXHtmlNode) : TFHIRCompositionSection; -begin - result := comp.sectionList.Append; - try - result.title := title; - result.code := makeCodeableConcept(systemUri, code, '', ''); - result.text := makeDiv(false, x); - result.link; - finally - result.free; - end; -end; - -function TIPSGenerator.makeBundle: TFhirBundle; -begin - result := TFhirBundle.Create; - try - result.id := newGuidId; - result.identifier := TFhirIdentifier.Create; - result.identifier.system := 'urn:ietf:rfc:3986'; - result.identifier.value := 'urn:uuid:'+result.id; - result.type_ := BundleTypeDocument; - result.timestamp := TFslDateTime.makeUTC; - result.link; - finally - result.free; - end; -end; - -function TIPSGenerator.makeComposition: TFHIRComposition; -var - ref : TFHIRReference; -begin - result := TFHIRComposition.Create; - try - result.id := nextId('cmp'); - result.status := CompositionStatusFinal; - result.type_ := makeCodeableConcept('http://loinc.org', '60591-5', '', ''); - result.subject := TFhirReference.Create; - result.subject.reference := 'Patient/p1'; - result.date := TFslDateTime.makeToday; - if (params.has('author')) then - result.authorList.Append.display := params['author'] - else - result.authorList.Append.reference := 'Patient/p1'; - result.title := 'Patient Passport (IPS)'; - result.link; - finally - result.free; - end; -end; - -function TIPSGenerator.makePatient: TFhirPatient; -var - id : TFhirIdentifier; - cp : TFhirContactPoint; - nok : TFHIRPatientContact; - x : TFhirXHtmlNode; - ext : TFHIRExtension; - l : TFhirPatientCommunication; - s, sg, cg, dg, tg, sp, cdp, dp, tp, sv, cdv, dv, tv : String; -begin - if (params.has('gender')) then - begin - if params['gender'] = 'f' then - begin - sg := 'http://snomed.info/sct'; - cg := '446141000124107'; - dg := 'Female gender identity'; - tg := 'Female'; - end - else if params['gender'] = 'm' then - begin - sg := 'http://snomed.info/sct'; - cg := '446151000124109'; - dg := 'Male gender identity'; - tg := 'Male'; - end - else if params['gender'] = 'n' then - begin - sg := 'http://snomed.info/sct'; - cg := '33791000087105'; - dg := 'Non-binary gender identity'; - tg := 'Non-binary'; - end - else if params['gender'] = 'u' then - begin - sg := 'http://terminology.hl7.org/CodeSystem/data-absent-reason'; - cg := 'asked-declined'; - dg := 'Asked But Declined'; - tg := ''; - end - else - raise EFslException.Create('Unknown value for gender: '+params['gender']); - end; - if (params.has('pronouns')) then - begin - if params['pronouns'] = 'f' then - begin - sp := 'http://loinc.org'; - cdp := 'LA29519-8'; - dp := 'she/her/her/hers/herself'; - tp := 'she/her'; - end - else if params['pronouns'] = 'm' then - begin - sp := 'http://loinc.org'; - cdp := 'LA29518-0'; - dp := 'he/him/his/his/himself'; - tp := 'he/him'; - end - else if params['pronouns'] = 'o' then - begin - sp := 'http://loinc.org'; - cdp := 'LA29520-6'; - dp := 'they/them/their/theirs/themselves'; - tp := 'they/them'; - end - else - raise EFslException.Create('Unknown value for pronouns: '+params['pronouns']); - end; - - if (params.has('sexchar')) then - begin - if params['sexchar'] = 'n' then - begin - sv := 'http://www.abs.gov.au/ausstats/XXXX'; - cdv := '2'; - dv := 'No'; - tv := 'Typical Sex Characterstics'; - end - else if params['sexchar'] = 'y' then - begin - sv := 'http://www.abs.gov.au/ausstats/XXXX'; - cdv := '1'; - dv := 'Yes'; - tv := 'Atypical Sex Characterstics'; - end - else if params['sexchar'] = 'u' then - begin - sv := 'http://www.abs.gov.au/ausstats/XXXX'; - cdv := '3'; - dv := 'Don''t know'; - tv := 'Unsure about sex characterstics'; - end - else - raise EFslException.Create('Unknown value for typical sex characteristics: '+params['sexchar']); - end; - - result := TFhirPatient.Create; - try - result.id := 'p1'; - result.text := makeDiv((tp <> '') or (tg <> ''), x); - if params.has('name') then - begin - result.nameList.Append.text := params['name']; - x.tx('Patient: '+params['name']); - FPatDesc := params['name']; - end; - if params.has('dob') then - begin - result.birthDate := TFslDateTime.fromXML(params['dob']); - x.sep(', '); - x.tx('born '+params['dob']); - FPatDesc := FPatDesc + ', '+params['dob']; - end; - - if (tg <> '') then - begin - x.sep(', '); - x.tx(' ('+tg+' gender'); - if (tp <> '') then - begin - x.tx(', '+tp); - FPatDesc := FPatDesc + '('+tg+':'+tp+')'; - end - else - FPatDesc := FPatDesc + '('+tg+')'; - x.tx(')'); - ext := result.addExtension('http://hl7.org/fhir/StructureDefinition/individual-genderIdentity'); - ext.addExtension('value', makeCodeableConcept(sg,cg,dg, params['gender-other'])); - end; - if (tp <> '') then - begin - if (tg = '') then - begin - x.sep(', '); - x.tx(' ('+tp+')'); - FPatDesc := FPatDesc + '('+tp+')'; - end; - - ext := result.addExtension('http://hl7.org/fhir/StructureDefinition/individual-pronouns'); - ext.addExtension('value', makeCodeableConcept(sp,cdp,dp, params['pronouns-other'])); - end; - if (tp <> '') then - begin - x.tx(' ('+tv+')'); - FPatDesc := FPatDesc + '('+tv+')'; - ext := result.addExtension('http://hl7.org.au/fhir/StructureDefinition/sex-characterstic-variation'); - ext.addExtension('value', makeCodeableConcept(sv,cdv,dv,'')); - end; - - if (params.has('community')) then - begin - ext := result.addExtension('http://hl7.org.au/fhir/StructureDefinition/community-affiliation'); - ext.addExtension('value', TFhirString.create(params['community'])); - end; - - if params.has('id') then - begin - id := result.identifierList.Append; - id.value := params['id']; - id.type_ := makeCodeableConcept('http://terminology.hl7.org/CodeSystem/v2-0203', 'NIIP', 'National Insurance Payor Identifier (Payor)', ''); - x.sep('. '); - x.tx('National ID '+params['id']); - FPatDesc := FPatDesc + ', National ID '+params['id']; - if params.has('country') then - x.tx(' for '+params['country']); - end; - if params.has('country') then - result.addressList.append.country := params['country']; - if (x.ChildNodes.Count > 0) then - x.br; - if params.has('culture') then - begin - result.addExtension('http://healthintersections.com.au/fhir/StructureDefinition/patient-cultural-background', TFHIRString.Create(params['culture'])); - x.tx('Cultural background: '+params['culture']); - x.br; - end; - - if params.has('email') or params.has('mobile') or params.has('phone') then - begin - x.tx('Contacts: '); - if params.has('email') then - begin - cp := result.telecomList.Append; - cp.system := ContactPointSystemEmail; - cp.value := params['email']; - x.tx('email: '); - x.ah('mailto:'+params['email']).tx(params['email']); - end; - if params.has('mobile') then - begin - if params.has('email') then - x.tx(', '); - cp := result.telecomList.Append; - cp.system := ContactPointSystemPhone; - cp.use := ContactPointUseMobile; - cp.value := params['mobile']; - x.tx('mobile: '); - x.ah('tel:'+params['mobile']).tx(params['mobile']); - end; - if params.has('phone') then - begin - if params.has('email') or params.has('mobile') then - x.tx(', '); - cp := result.telecomList.Append; - cp.system := ContactPointSystemPhone; - cp.value := params['phone']; - x.tx('phone: '); - x.ah('tel:'+params['phone']).tx(params['phone']); - end; - end; - - if (params.has('nok')) then - begin - x.br; - x.tx('Next of Kin: '+params['nok']); - nok := result.contactList.Append; - nok.name := TFhirHumanName.Create; - nok.name.text := params['nok']; - if params.has('nokemail') or params.has('nokmobile') or params.has('nokphone') then - begin - x.tx(', contacts: '); - if params.has('nokemail') then - begin - cp := nok.telecomList.Append; - cp.system := ContactPointSystemEmail; - cp.value := params['nokemail']; - x.tx('email: '); - x.ah('mailto:'+params['nokemail']).tx(params['nokemail']); - end; - if params.has('nokmobile') then - begin - if params.has('nokemail') then - x.tx(', '); - cp := nok.telecomList.Append; - cp.system := ContactPointSystemPhone; - cp.use := ContactPointUseMobile; - cp.value := params['nokmobile']; - x.tx('mobile: '); - x.ah('tel:'+params['nokmobile']).tx(params['nokmobile']); - end; - if params.has('nokphone') then - begin - if params.has('email') or params.has('mobile') then - x.tx(', '); - cp := nok.telecomList.Append; - cp.system := ContactPointSystemPhone; - cp.value := params['nokphone']; - x.tx('phone: '); - x.ah('tel:'+params['nokphone']).tx(params['nokphone']); - end; - end; - end; - if (params.has('language')) then - begin - s := params['language'].toLower; - l := result.communicationList.Append; - l.language := TFHIRCodeableConcept.create; - l.language.text := params['language']; - l.preferred := true; - if ((s = 'en') or (s = 'english')) then - if (params.has('english')) then - begin - l := result.communicationList.Append; - l.language := TFHIRCodeableConcept.create; - l.language.text := 'english'; - end; - end; - - result.link; - finally - result.free; - end; -end; - -function TIPSGenerator.makeFuncStatusCondition(sect: TFHIRCompositionSection; ul : TFhirXHtmlNode; paramName, text, systemUri, code, display: String): TFHIRCondition; -var - rx : TFhirXHtmlNode; -begin - if params[paramName] <> 'true' then - result := nil - else - begin - result := TFHIRCondition.Create; - try - result.id := nextId('cnd'); - result.text := makeDiv(false, rx); - result.clinicalStatus := makeCodeableConcept('http://terminology.hl7.org/CodeSystem/condition-clinical', 'active', 'Active', ''); - result.code := makeCodeableConcept(systemUri, code, display, ''); - result.code.text := text; - result.subject := TFHIRReference.Create('Patient/p1'); - sect.entryList.Append.reference := 'Condition/'+result.id; - ul.li.tx(text); - rx.p.tx('Condition for '+FPatDesc); - rx.p.tx(text); - result.link; - finally - result.free; - end; - end; -end; - -function organStatusCode(s : String) : String; -begin - if (s = 'ns') then - result := '' - else if (s = 'p') then - result := 'present' - else if (s = 'a') then - result := 'transplanted-in' - else if (s = 'i') then - result := 'implant' - else if (s = 'g') then - result := 'absent' - else if (s = 'np') then - result := 'congenitally-absent' - else if (s = 'pr') then - result := 'partially-excised' - else if (s = 'r') then - result := 'excised' - else - result := ''; -end; - - -function organStatusDisplay(s : String) : String; -begin - if (s = 'ns') then - result := '' - else if (s = 'present') then - result := 'present' - else if (s = 'transplanted-in') then - result := 'transplanted-in' - else if (s = 'implant') then - result := 'implant' - else if (s = 'absent') then - result := 'absent' - else if (s = 'congenitally-absent') then - result := 'congenitally-absent' - else if (s = 'partially-excised') then - result := 'partially-excised' - else if (s = 'excised') then - result := 'excised' - else - result := ''; -end; - - -function TIPSGenerator.makeOrganRegistryEntry(sect : TFHIRCompositionSection; ul : TFhirXHtmlNode; paramName, text, systemUri, code, display : String) : TFHIRObservation; -var - rx : TFhirXHtmlNode; - s : String; -begin - if params[paramName] = 'ns' then - result := nil - else - begin - result := TFHIRObservation.Create; - try - result.id := nextId('obs'); - result.text := makeDiv(false, rx); - result.categoryList.add(makeCodeableConcept('http://terminology.hl7.org/CodeSystem/observation-category', 'organ-inventory', 'Organ Inventory', '')); - result.code := makeCodeableConcept('http://loinc.org', 'XXXXX-Y', 'Organ status', ''); - result.code.text := text; - result.subject := TFHIRReference.Create('Patient/p1'); - result.effective := TFHIRDateTime.create(TFslDateTime.makeUTC); - result.bodySite := makeCodeableConcept(systemUri, code, display, ''); - s := organStatusCode(params[paramName]); - result.value := makeCodeableConcept('http://healthintersections.com.au/fhir/playground/CodeSystem/organ-inventory-status', s, organStatusDisplay(s), ''); - sect.entryList.Append.reference := 'Condition/'+result.id; - ul.li.tx(text); - rx.p.tx('Condition for '+FPatDesc); - rx.p.tx(text); - result.link; - finally - result.free; - end; - end; -end; - -function TIPSGenerator.makeFuncStatusTextCondition(sect: TFHIRCompositionSection; x: TFhirXHtmlNode; paramName: string): TFHIRCondition; -var - rx : TFhirXHtmlNode; -begin - if params[paramName] = '' then - result := nil - else - begin - result := TFHIRCondition.Create; - try - result.id := nextId('cnd'); - result.text := makeDiv(false, rx); - result.clinicalStatus := makeCodeableConcept('http://terminology.hl7.org/CodeSystem/condition-clinical', 'active', 'Active', ''); - result.code := TFhirCodeableConcept.Create; - result.code.text := params[paramName]; - result.subject := TFHIRReference.Create('Patient/p1'); - sect.entryList.Append.reference := 'Condition/'+result.id; - x.p.tx(params[paramName]); - rx.p.tx('Condition for '+FPatDesc); - rx.p.tx(params[paramName]); - result.link; - finally - result.free; - end; - end; -end; - -procedure TIPSGenerator.makeAvoidanceRelationship(sect: TFHIRCompositionSection; ul: TFhirXHtmlNode; s : String); -var - li: TFhirXHtmlNode; -var - ref : TFhirReference; -begin - li := ul.li; - li.tx(s); - ref := sect.entryList.Append; - ref.display := s; - ref.addExtension('http://www.healthintersections.com.au/fhir/StructureDefinition/do-not-contact', TFhirBoolean.create(true)); -end; - -function TIPSGenerator.makeCareAdvocate(sect: TFHIRCompositionSection; ul: TFhirXHtmlNode): TFHIRRelatedPerson; -var - li: TFhirXHtmlNode; -var - rx : TFhirXHtmlNode; - cp : TFHIRContactPoint; -begin - if params['ca'] = '' then - result := nil - else - begin - li := ul.li; - result := TFHIRRelatedPerson.Create; - try - result.id := nextId('rp'); - result.text := makeDiv(false, rx); - result.patient := TFHIRReference.Create('Patient/p1'); - li.tx('Care Advocate:'); - rx.p.tx('Care Advocate for '+FPatDesc+':'); - result.nameList.Append.text := params['caname']; - li.tx(params['caname']); - rx.tx(params['caname']); - if params.has('caemail') or params.has('camobile') or params.has('caphone') then - begin - li.tx('. Contacts: '); - rx.tx('. Contacts: '); - if params.has('caemail') then - begin - cp := result.telecomList.Append; - cp.system := ContactPointSystemEmail; - cp.value := params['caemail']; - li.tx('email: '); - li.ah('mailto:'+params['caemail']).tx(params['caemail']); - rx.tx('email: '); - rx.ah('mailto:'+params['caemail']).tx(params['caemail']); - end; - if params.has('camobile') then - begin - if params.has('caemail') then - begin - li.tx(', '); - rx.tx(', '); - end; - cp := result.telecomList.Append; - cp.system := ContactPointSystemPhone; - cp.use := ContactPointUseMobile; - cp.value := params['camobile']; - li.tx('mobile: '); - li.ah('tel:'+params['camobile']).tx(params['camobile']); - rx.tx('mobile: '); - rx.ah('tel:'+params['camobile']).tx(params['camobile']); - end; - if params.has('caphone') then - begin - if params.has('caemail') or params.has('camobile') then - begin - li.tx(', '); - rx.tx(', '); - end; - cp := result.telecomList.Append; - cp.system := ContactPointSystemPhone; - cp.value := params['caphone']; - li.tx('phone: '); - li.ah('tel:'+params['caphone']).tx(params['caphone']); - rx.tx('phone: '); - rx.ah('tel:'+params['caphone']).tx(params['caphone']); - end; - end; - if params['calegal'] = 'true' then - begin - result.relationshipList.Add(makeCodeableConcept('http://terminology.hl7.org/CodeSystem/v3-RoleCode', 'HPOWATT', 'healthcare power of attorney', '')); - rx.tx(' (legal power of attorney)'); - li.tx(' (legal power of attorney)'); - end - else - result.relationshipList.Add(makeCodeableConcept('http://terminology.hl7.org/CodeSystem/v3-RoleCode', 'NOK', 'next of kin', '')); - - sect.entryList.Append.reference := 'RelatedPerson/'+result.id; - result.link; - finally - result.free; - end; - end; -end; - -function TIPSGenerator.makeConsent(sect : TFHIRCompositionSection; ul : TFhirXHtmlNode; fwds : boolean; paramName, textYes, textNo, systemUri, code, display : String) : TFHIRConsent; -var - li: TFhirXHtmlNode; -var - rx : TFhirXHtmlNode; - cp : TFHIRContactPoint; -begin - if (params[paramName] = '') then - result := nil - else - begin - li := ul.li; - result := TFHIRConsent.Create; - try - result.id := nextId('cnst'); - result.text := makeDiv(false, rx); - li.tx('Consent: '); - rx.p.tx('Consent for '+FPatDesc+': '); - result.patient := TFHIRReference.Create('Patient/p1'); - result.status := ConsentStateCodesActive; - result.scope := makeCodeableConcept('http://terminology.hl7.org/CodeSystem/consentscope', 'adr', 'Advanced Care Directive', ''); - result.categoryList.Add(makeCodeableConcept('http://terminology.hl7.org/CodeSystem/consentcategorycodes', 'acd', 'Advance Directive', '')); - result.policyRule := TFhirCodeableConcept.Create; - result.policyRule.text := 'Unknown Policy'; - result.provision := TFHIRConsentProvision.Create; - if (params[paramName] = 'false') xor fwds then - begin - result.provision.type_ := ConsentProvisionTypePermit; - li.tx(textYes); - rx.tx(textYes); - end - else - begin - result.provision.type_ := ConsentProvisionTypeDeny; - li.tx(textNo); - rx.tx(textNo); - end; - result.provision.codeList.add(makeCodeableConcept(systemUri, code, display, '')); - - sect.entryList.Append.reference := 'Consent/'+result.id; - result.link; - finally - result.free; - end; - end; -end; - -function TIPSGenerator.makeDocRef(sect: TFHIRCompositionSection; ul: TFhirXHtmlNode): TFHIRDocumentReference; -var - li: TFhirXHtmlNode; -var - rx : TFhirXHtmlNode; - cp : TFHIRContactPoint; -begin - if attachment = nil then - result := nil - else - begin - li := ul.li; - result := TFHIRDocumentReference.Create; - try - result.id := nextId('dr'); - result.text := makeDiv(false, rx); - result.status := DocumentReferenceStatusCurrent; - result.subject := TFHIRReference.Create('Patient/p1'); - result.type_ := makeCodeableConcept('http://loinc.org', '75320-2', 'Advance directive', ''); - li.tx('Advance Care Directive:'); - rx.p.tx('Advance Care Directive '+FPatDesc+':'); - if FFormatChoice = 'z' then - result.contentList.Append.attachment := makeAttachment(attachment.Format, 'Advance directive', 'adr.pdf') - else - result.contentList.Append.attachment := makeAttachment(attachment.Format, 'Advance directive', attachment); - - sect.entryList.Append.reference := 'DocumentReference/'+result.id; - result.link; - finally - result.free; - end; - end; -end; - -function TIPSGenerator.generateBundle : TFhirBundle; -var - bnd : TFHIRBundle; - comp : TFHIRComposition; - sect : TFHIRCompositionSection; - cp : TFHIRCarePlan; - x, ul : TFhirXHtmlNode; - ts : TStringList; - s : String; -begin - FFormatChoice := params['format']; - - bnd := makeBundle; - try - comp := makeComposition; - addToBundle(bnd, comp); - addToBundle(bnd, makePatient); - - // functional concerns / needs - sect := addSection(comp, 'Functional Concerns', 'http://loinc.org', '47420-5', x); - ul := x.ul; - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-visual', 'Patient has concerns around Vision', 'http://snomed.info/sct', '397540003', 'Visual impairment')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-audio', 'Patient has concerns around Hearing / Listening', 'http://snomed.info/sct', '15188001', 'Hearing impaired')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-cognition', 'Patient has concerns around Cognition / thinking / understanding / information processing', 'http://snomed.info/sct', '386806002', 'Impaired cognition')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-speaking', 'Patient has concerns around Speaking / communicating / Conversation / Verbal interaction', 'http://snomed.info/sct', '29164008', 'Speech impairment')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-mobility', 'Patient has concerns around Mobility / moving myself around', 'http://snomed.info/sct', '82971005', 'Impaired mobility')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-gender', 'Patient has concerns around Use of gender specific areas', 'http://snomed.info/sct', '93461009', 'Gender dysphoria')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-memory', 'Patient has concerns around Memory', 'http://snomed.info/sct', '386807006', 'Memory impairment')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-trauma', 'Patient has concerns around dealing with Past Trauma', 'http://snomed.info/sct', '161472001', 'History of psychological trauma')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-focus', 'Patient has concerns around Staying focused / Concentration', 'http://snomed.info/sct', '1144748009', 'Impaired concentration')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-addiction', 'Patient has concerns around managing their addictions', 'http://snomed.info/sct', '32709003', 'Addiction')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-city', 'Cities and/or crowds are unfamiliar for the patient', 'http://snomed.info/sct', '5794003', 'Country dweller')); - - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'eating', 'Patient may need help with Eating / Drinking', 'http://snomed.info/sct', '110292000', 'Difficulty eating')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'toileting', 'Patient may need help with Toileting', 'http://snomed.info/sct', '284911003', 'Difficulty using toilet')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'bed-exit', 'Patient may need help with Getting out of bed', 'http://snomed.info/sct', '301666002', 'Difficulty getting on and off a bed')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'bed-in', 'Patient may need help with Moving in bed', 'http://snomed.info/sct', '301685004', 'Difficulty moving in bed')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'orientation', 'Patient may need help with Getting orientated in a new environment', 'http://snomed.info/sct', '72440003', ' Disorientated in place')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'dressing', 'Patient may need help with Dressing', 'http://snomed.info/sct', '284977008', 'Difficulty dressing')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'bathing', 'Patient may need help with Bathing / Cleaning', 'http://snomed.info/sct', '284807005', 'Difficulty bathing self')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'meds', 'Patient may need help with Taking my medications', 'http://snomed.info/sct', '715037005', 'Difficulty taking medication')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'reading', 'Patient may need help with Reading Documentation', 'http://snomed.info/sct', '309253009', 'Difficulty reading')); - - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'dog', 'Patient has a Guide Dog', 'http://snomed.info/sct', '105506000', 'Dependence on seeing eye dog')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'wheelchair', 'Patient has a Wheelchair', 'http://snomed.info/sct', '105503008', 'Dependence on wheelchair')); - addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'comm-device', 'Patient has a Communication Device', 'http://snomed.info/sct', '719369003', 'Uses communication device')); - - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Arm-l', 'Left Arm Status', 'http://snomed.info/sct', '368208006', 'Left upper arm structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Arm-r', 'Right Arm Status', 'http://snomed.info/sct', '368209003', 'Right upper arm structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Hand-l', 'Left Hand Status', 'http://snomed.info/sct', '85151006', 'Structure of left hand')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Hand-r', 'Right Hand Status', 'http://snomed.info/sct', '78791008', 'Structure of right hand')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Fingers-l', 'Left Fingers Status', 'http://snomed.info/sct', '786841006', 'Structure of all fingers of left hand')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Fingers-r', 'Right Fingers Status', 'http://snomed.info/sct', '786842004', 'Structure of all fingers of right hand')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Leg-l', 'Left Leg Status', 'http://snomed.info/sct', '48979004', 'Structure of left lower leg')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Leg-r', 'Right Leg Status', 'http://snomed.info/sct', '32696007', 'Structure of right lower leg')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Calf-l', 'Left Calf Status', 'http://snomed.info/sct', '48979004', 'Structure of left lower leg')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Calf-r', 'Right Calf Status', 'http://snomed.info/sct', '32696007', 'Structure of right lower leg')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Foot-l', 'Left Foot Status', 'http://snomed.info/sct', '22335008', 'Structure of left foot')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Foot-r', 'Right Foot Status', 'http://snomed.info/sct', '7769000', 'Structure of right foot')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Toe-l', 'Left Toe Status', 'http://snomed.info/sct', '785708006', 'Structure of all toes of left foot')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Toe-r', 'Right Toe Status', 'http://snomed.info/sct', '785709003', 'Structure of all toes of right foot')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Hip-l', 'Left Hip Status', 'http://snomed.info/sct', '287679003', 'Left hip region structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Hip-r', 'Right Hip Status', 'http://snomed.info/sct', '287579007', 'Right hip region structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Eye-l', 'Left Eye Status', 'http://snomed.info/sct', '1290041000', 'Entire left eye proper')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Eye-r', 'Right Eye Status', 'http://snomed.info/sct', '1290043002', 'Entire right eye proper')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Hypothalamus', 'Hypothalamus Status', 'http://snomed.info/sct', '67923007', 'Hypothalamic structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Pituitary', 'Pituitary Status', 'http://snomed.info/sct', '56329008', 'Pituitary structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Tongue', 'Tongue Status', 'http://snomed.info/sct', '21974007', 'Tongue structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Jaw', 'Jaw Status', 'http://snomed.info/sct', '661005', 'Jaw region structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Oesophagus', 'Oesophagus Status', 'http://snomed.info/sct', '32849002', 'Esophageal structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'LargeColon', 'Large Colon Status', 'http://snomed.info/sct', '71854001', 'Colon structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Stomach', 'Stomach Status', 'http://snomed.info/sct', '69695003', 'Stomach structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'GallBladder', 'Gall Bladder Status', 'http://snomed.info/sct', '28231008', 'Gallbladder structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Kidney-l', 'Left Kidney Status', 'http://snomed.info/sct', '18639004', 'Left kidney structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Kidney-r', 'Right Kidney Status', 'http://snomed.info/sct', '9846003', 'Right kidney structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Liver', 'Liver Status', 'http://snomed.info/sct', '10200004', '10200004')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Bladder', 'Bladder Status', 'http://snomed.info/sct', '89837001', 'Urinary bladder structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Lung-l', 'Left Lung Status', 'http://snomed.info/sct', '44029006', 'Left lung structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Lung-r', 'Right Lung Status', 'http://snomed.info/sct', '3341006', 'Right lung structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Breasts-l', 'Left Breast Status', 'http://snomed.info/sct', '80248007', 'Left breast structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Breasts-r', 'Right Breast Status', 'http://snomed.info/sct', '73056007', 'Right breast structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Ovary-l', 'Left Ovary Status', 'http://snomed.info/sct', '43981004', 'Structure of left ovary')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Ovary-r', 'Right Ovary Status', 'http://snomed.info/sct', '20837000', 'Structure of right ovary')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Uterus', 'Uterus Status', 'http://snomed.info/sct', '35039007', 'Uterine structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Cervix', 'Cervix Status', 'http://snomed.info/sct', '71252005', 'Cervix uteri structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Vagina', 'Vagina Status', 'http://snomed.info/sct', '76784001', 'Vaginal structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Penis', 'Penis Status', 'http://snomed.info/sct', '18911002', 'Penile structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Prostate', 'Prostate Status', 'http://snomed.info/sct', '41216001', 'Prostatic structure')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Testis-l', 'Left Testis Status', 'http://snomed.info/sct', '63239009', 'Structure of left testis')); - addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Testis-r', 'Right Testis Status', 'http://snomed.info/sct', '15598003', 'Structure of right testis')); - - addToBundle(bnd, makeFuncStatusTextCondition(sect, x, 'text')); - - // advance directive things - sect := addSection(comp, 'Care Directives', 'http://loinc.org', '42348-3', x); - ul := x.ul; - addToBundle(bnd, makeCareAdvocate(sect, ul)); - addToBundle(bnd, makeConsent(sect, ul, false, 'dnr', 'Please resuscitate if necessary', - 'Patient wishes to not be resuscitated (DNR)', 'http://snomed.info/sct', '439569004', 'Resuscitation')); - addToBundle(bnd, makeConsent(sect, ul, true, 'donor', 'Patient agrees to be an organ donor', - 'Patient does not agree to be an organ donor', 'http://snomed.info/sct', '1148553005', 'Post-mortem organ donation')); - addToBundle(bnd, makeConsent(sect, ul, true, 'bld', 'Patient agrees to accept a blood tranfusion if necessary', - 'Patient does not accept a blood transfusion', 'http://snomed.info/sct', '116859006', 'Blood transfusion')); - addToBundle(bnd, makeDocRef(sect, ul)); - - if (params.has('avoidance')) then - begin - x.p.tx('Plase avoid contacting/communicating with these individuals:'); - ul := x.ul; - ts := TStringList.create; - try - ts.text := params['avoidance']; - for s in ts do - makeAvoidanceRelationship(sect, ul, s); - finally - ts.free; - end; - end; - result := bnd.Link; - finally - bnd.free; - end; -end; - -function TIPSGenerator.generateBinary: TFslBuffer; -var - bnd : TFhirBundle; - comp : TFHIRComposer; - wrap : TIPSWrapper; -begin - bnd := generateBundle; - try - result := TFslBuffer.Create; - try - if FFormatChoice = 'j' then - begin - comp := TFHIRJsonComposer.Create(nil, OutputStylePretty, nil); - try - result.AsText := comp.Compose(bnd); - finally - comp.free; - end; - result.Format := 'application/fhir+json'; - end - else if FFormatChoice = 'x' then - begin - comp := TFHIRXmlComposer.Create(nil, OutputStylePretty, nil); - try - result.AsText := comp.Compose(bnd); - finally - comp.free; - end; - result.Format := 'application/fhir+xml'; - end - else - begin - wrap := TIPSWrapper.Create; - try - wrap.startBuild('Patient Authored Passport (IPS)'); - wrap.addIPS(bnd, ivkOriginal, 'Health Intersections Website'); - if attachment <> nil then - wrap.addAttachment(attachment, 'adr.pdf', iakAttachment); - result.AsBytes := wrap.saveToBytes; - finally - wrap.free; - end; - result.Format := 'application/health-document'; - end; - result.link; - finally - result.free; - end; - finally - bnd.free; - end; -end; - - -{ TIPSWrapper } - -function TIPSWrapper.writeManifest: TBytes; -begin - result := TJsonWriter.writeObject(FManifest, true); -end; - -constructor TIPSWrapper.Create; -begin - inherited Create; - FContent := TFslMap.Create; -end; - -destructor TIPSWrapper.Destroy; -begin - FContent.free; - FManifest.free; - inherited Destroy; -end; - -procedure TIPSWrapper.startBuild(name : String); -begin - FManifest := TJsonObject.Create; - FManifest.str['format'] := 'ips-wrapper/1'; - FManifest.str['description'] := name; -end; - -procedure TIPSWrapper.addIPS(ips: TFhirBundle; kind : TIPSVersionKind; agent : String); -var - comp : TFHIRComposer; - id : String; - e : TJsonObject; - bin : TFslBuffer; -begin - id := 'ips-'+CODES_TIPSVersionKind[kind]+'.json'; - if (FContent.ContainsKey(id)) then - id := newGuidId+'.json'; - e := FManifest.forceArr['ips-versions'].addObject; - e.str['source'] := id; - e.str['kind'] := CODES_TIPSVersionKind[kind]; - e.str['mimetype'] := 'application/fhir+json'; - bin := TFslBuffer.Create; - try - comp := TFHIRJsonComposer.Create(nil, OutputStylePretty, nil); - try - bin.AsText := comp.Compose(ips); - finally - comp.free; - end; - FContent.Add(id, bin.link); - finally - bin.free; - end; -end; - -procedure TIPSWrapper.addAttachment(attachment : TFslBuffer; fn : String; kind : TIPSAttachmentKind); -var - e : TJsonObject; -begin - e := FManifest.forceArr['attachments'].addObject; - e.str['source'] := fn; - e.str['kind'] := CODES_TIPSAttachmentKind[kind]; - if attachment.format <> '' then - e.str['mimetype'] := attachment.format; - FContent.Add(fn, attachment.link); -end; - -class function TIPSWrapper.fromStream(stream: TStream): TIPSWrapper; -begin - raise Exception.Create('Not done yet'); -end; - -class function TIPSWrapper.fromStream(stream: TFslStream): TIPSWrapper; -begin - raise Exception.Create('Not done yet'); -end; - -procedure TIPSWrapper.saveToStream(stream: TStream); -begin - raise Exception.Create('Not done yet'); -end; - -procedure TIPSWrapper.saveToStream(stream: TFslStream); -begin - raise Exception.Create('Not done yet'); -end; - - -procedure Decode(const sSource: TBytes); -var - buffer : TFslBuffer; - zip : TFslZipPartList; - reader : TFslZipReader; - ss : TFslStringStream; - i : integer; -Begin - ss := TFslStringStream.Create; - try - ss.Bytes := sSource; - zip := TFslZipPartList.Create; - reader := TFslZipReader.Create; - try - reader.Stream := ss.Link; - reader.Parts := zip.Link; - reader.ReadZip; - for i := 0 to zip.Count - 1 do - Logging.log(zip[i].Name); - finally - reader.free; - end; - finally - ss.free; - end; -end; - -function TIPSWrapper.saveToBytes: TBytes; -var - ss : TFslStringStream; - zip : TFslZipPartList; - writer : TFslZipWriter; - name : String; -begin - zip := TFslZipPartList.Create; - try - zip.Add('manifest.json', WriteManifest); - for name in FContent.Keys do - zip.Add(name, FContent[name].AsBytes); - writer := TFslZipWriter.Create; - try - writer.Parts := zip.Link; - ss := TFslStringStream.Create; - try - writer.Stream := ss.Link; - writer.WriteZip; - result := ss.Bytes; - finally - ss.free; - end; - finally - writer.free; - end; - finally - zip.free; - end; - // decode(result); -end; - - -end. - - +unit fhir4_ips; + +{ +Copyright (c) 2011+, HL7 and Health Intersections Pty Ltd (http://www.healthintersections.com.au) +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of HL7 nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +} + +{$i fhir.inc} + +interface + +uses + Classes, SysUtils, + fsl_base, fsl_json, fsl_stream, fsl_http, fsl_utilities, fsl_logging, + fhir_xhtml, fhir_objects, fhir_parser, + fhir4_resources, fhir4_resources_clinical, fhir4_types, fhir4_utilities, fhir4_json, fhir4_xml; + +const + ROOT = 'http://healthintersections.com.au/IPS/'; + +type + { TIPSGenerator } + + TIPSGenerator = class (TFslObject) + private + FFormatChoice : String; + FFile: TFslbuffer; + FParams: THTTPParameters; + FLastId : integer; + FPatDesc : String; + procedure SetFile(AValue: TFslbuffer); + procedure SetParams(AValue: THTTPParameters); + + function nextId(pfx : String) : String; + function makeCodeableConcept(systemUri, code, display, text : String) : TFhirCodeableConcept; + function makeAttachment(mimeType, title : String; content : TFslBuffer) : TFhirAttachment; overload; + function makeAttachment(mimeType, title : String; ref : String) : TFhirAttachment; overload; + function makeDiv(ext : boolean; out x : TFhirXHtmlNode) : TFHIRNarrative; + procedure addToBundle(bnd : TFhirBundle; resource : TFHIRResource); + function addSection(comp : TFhirComposition; title, systemUri, code : String; out x : TFhirXHtmlNode) : TFHIRCompositionSection; + + function makeBundle : TFhirBundle; + function makeComposition : TFHIRComposition; + function makePatient : TFhirPatient; + function makeFuncStatusCondition(sect : TFHIRCompositionSection; ul : TFhirXHtmlNode; paramName, text, systemUri, code, display : String) : TFHIRCondition; + function makeOrganRegistryEntry(sect : TFHIRCompositionSection; ul : TFhirXHtmlNode; paramName, text, systemUri, code, display : String) : TFHIRObservation; + function makeFuncStatusTextCondition(sect : TFHIRCompositionSection; x : TFhirXHtmlNode; paramName : string) : TFHIRCondition; + function makeCareAdvocate(sect : TFHIRCompositionSection; ul : TFhirXHtmlNode) : TFHIRRelatedPerson; + procedure makeAvoidanceRelationship(sect : TFHIRCompositionSection; ul : TFhirXHtmlNode; s : String); + function makeConsent(sect : TFHIRCompositionSection; ul : TFhirXHtmlNode; fwds : boolean; paramName, textYes, textNo, systemUri, code, display : String) : TFHIRConsent; + function makeDocRef(sect : TFHIRCompositionSection; ul : TFhirXHtmlNode) : TFHIRDocumentReference; + public + destructor Destroy; Override; + + property params : THTTPParameters read FParams write SetParams; + property attachment : TFslbuffer read FFile write SetFile; + + function generateBundle : TFhirBundle; + function generateBinary : TFslBuffer; + end; + + + { TIPSWrapper } + TIPSVersionKind = (ivkOriginal, ivkTransformed, ivkAnnotated); + TIPSAttachmentKind = (iakBrand, iakAuthored, iakAttachment, iakStylesheet); + + TIPSWrapper = class (TFslObject) + private + FManifest : TJsonObject; + FContent : TFslMap; + function writeManifest : TBytes; + public + constructor Create; override; + destructor Destroy; override; + + procedure startBuild(name : String); + procedure addIPS(ips : TFhirBundle; kind : TIPSVersionKind; agent : String); + procedure addAttachment(attachment : TFslBuffer; fn : String; kind : TIPSAttachmentKind); + + class function fromStream(stream : TStream) : TIPSWrapper; overload; + class function fromStream(stream : TFslStream) : TIPSWrapper; overload; + procedure saveToStream(stream : TStream); overload; + procedure saveToStream(stream : TFslStream); overload; + function saveToBytes : TBytes; + end; + +const + CODES_TIPSVersionKind : array [TIPSVersionKind] of String = ('original', 'transformed', 'annotated'); + CODES_TIPSAttachmentKind : array [TIPSAttachmentKind] of String = ('brand', 'authored', 'attachment', 'stylesheet'); + +implementation + +{ TIPSGenerator } + +destructor TIPSGenerator.Destroy; +begin + FParams.free; + FFile.free; + inherited Destroy; +end; + +procedure TIPSGenerator.SetParams(AValue: THTTPParameters); +begin + FParams.free; + FParams:=AValue; +end; + +procedure TIPSGenerator.SetFile(AValue: TFslbuffer); +begin + FFile.free; + FFile:=AValue; +end; + +function TIPSGenerator.nextId(pfx : String): String; +begin + inc(FLastId); + result := pfx+inttostr(FLastId); +end; + + +function TIPSGenerator.makeCodeableConcept(systemUri, code, display, text : String) : TFhirCodeableConcept; +begin + result := TFHIRCodeableConcept.Create(systemUri, code); + result.codingList[0].display := display; + result.text := text; +end; + +function TIPSGenerator.makeAttachment(mimeType, title: String; content: TFslBuffer): TFhirAttachment; +begin + result := TFhirAttachment.Create; + try + result.contentType := mimeType; + result.title := title; + result.data := content.AsBytes; + result.link; + finally + result.free; + end; +end; + +function TIPSGenerator.makeAttachment(mimeType, title: String; ref: String): TFhirAttachment; +begin + result := TFhirAttachment.Create; + try + result.contentType := mimeType; + result.title := title; + result.url := ref; + result.link; + finally + result.free; + end; +end; + +function TIPSGenerator.makeDiv(ext : boolean; out x : TFhirXHtmlNode): TFHIRNarrative; +begin + result := TFHIRNarrative.Create; + try + if ext then + result.status := NarrativeStatusExtensions + else + result.status := NarrativeStatusGenerated; + result.div_ := TFhirXHtmlNode.Create('div'); + result.div_.attribute('xmlns', 'http://www.w3.org/1999/xhtml'); + x := result.div_; + result.link; + finally + result.free; + end; +end; + +procedure TIPSGenerator.addToBundle(bnd : TFhirBundle; resource : TFHIRResource); +var + e : TFHIRBundleEntry; +begin + if (resource <> nil) then + begin + e := bnd.entryList.Append; + e.fullUrl := URLPath([ROOT, resource.fhirType, resource.id]); + e.resource := resource.Link; + end; +end; + +function TIPSGenerator.addSection(comp : TFhirComposition; title, systemUri, code : String; out x : TFhirXHtmlNode) : TFHIRCompositionSection; +begin + result := comp.sectionList.Append; + try + result.title := title; + result.code := makeCodeableConcept(systemUri, code, '', ''); + result.text := makeDiv(false, x); + result.link; + finally + result.free; + end; +end; + +function TIPSGenerator.makeBundle: TFhirBundle; +begin + result := TFhirBundle.Create; + try + result.id := newGuidId; + result.identifier := TFhirIdentifier.Create; + result.identifier.system := 'urn:ietf:rfc:3986'; + result.identifier.value := 'urn:uuid:'+result.id; + result.type_ := BundleTypeDocument; + result.timestamp := TFslDateTime.makeUTC; + result.link; + finally + result.free; + end; +end; + +function TIPSGenerator.makeComposition: TFHIRComposition; +var + ref : TFHIRReference; +begin + result := TFHIRComposition.Create; + try + result.id := nextId('cmp'); + result.status := CompositionStatusFinal; + result.type_ := makeCodeableConcept('http://loinc.org', '60591-5', '', ''); + result.subject := TFhirReference.Create; + result.subject.reference := 'Patient/p1'; + result.date := TFslDateTime.makeToday; + if (params.has('author')) then + result.authorList.Append.display := params['author'] + else + result.authorList.Append.reference := 'Patient/p1'; + result.title := 'Patient Passport (IPS)'; + result.link; + finally + result.free; + end; +end; + +function TIPSGenerator.makePatient: TFhirPatient; +var + id : TFhirIdentifier; + cp : TFhirContactPoint; + nok : TFHIRPatientContact; + x : TFhirXHtmlNode; + ext : TFHIRExtension; + l : TFhirPatientCommunication; + s, sg, cg, dg, tg, sp, cdp, dp, tp, sv, cdv, dv, tv : String; +begin + if (params.has('gender')) then + begin + if params['gender'] = 'f' then + begin + sg := 'http://snomed.info/sct'; + cg := '446141000124107'; + dg := 'Female gender identity'; + tg := 'Female'; + end + else if params['gender'] = 'm' then + begin + sg := 'http://snomed.info/sct'; + cg := '446151000124109'; + dg := 'Male gender identity'; + tg := 'Male'; + end + else if params['gender'] = 'n' then + begin + sg := 'http://snomed.info/sct'; + cg := '33791000087105'; + dg := 'Non-binary gender identity'; + tg := 'Non-binary'; + end + else if params['gender'] = 'u' then + begin + sg := 'http://terminology.hl7.org/CodeSystem/data-absent-reason'; + cg := 'asked-declined'; + dg := 'Asked But Declined'; + tg := ''; + end + else + raise EFslException.Create('Unknown value for gender: '+params['gender']); + end; + if (params.has('pronouns')) then + begin + if params['pronouns'] = 'f' then + begin + sp := 'http://loinc.org'; + cdp := 'LA29519-8'; + dp := 'she/her/her/hers/herself'; + tp := 'she/her'; + end + else if params['pronouns'] = 'm' then + begin + sp := 'http://loinc.org'; + cdp := 'LA29518-0'; + dp := 'he/him/his/his/himself'; + tp := 'he/him'; + end + else if params['pronouns'] = 'o' then + begin + sp := 'http://loinc.org'; + cdp := 'LA29520-6'; + dp := 'they/them/their/theirs/themselves'; + tp := 'they/them'; + end + else + raise EFslException.Create('Unknown value for pronouns: '+params['pronouns']); + end; + + if (params.has('sexchar')) then + begin + if params['sexchar'] = 'n' then + begin + sv := 'http://www.abs.gov.au/ausstats/XXXX'; + cdv := '2'; + dv := 'No'; + tv := 'Typical Sex Characterstics'; + end + else if params['sexchar'] = 'y' then + begin + sv := 'http://www.abs.gov.au/ausstats/XXXX'; + cdv := '1'; + dv := 'Yes'; + tv := 'Atypical Sex Characterstics'; + end + else if params['sexchar'] = 'u' then + begin + sv := 'http://www.abs.gov.au/ausstats/XXXX'; + cdv := '3'; + dv := 'Don''t know'; + tv := 'Unsure about sex characterstics'; + end + else + raise EFslException.Create('Unknown value for typical sex characteristics: '+params['sexchar']); + end; + + result := TFhirPatient.Create; + try + result.id := 'p1'; + result.text := makeDiv((tp <> '') or (tg <> ''), x); + if params.has('name') then + begin + result.nameList.Append.text := params['name']; + x.tx('Patient: '+params['name']); + FPatDesc := params['name']; + end; + if params.has('dob') then + begin + result.birthDate := TFslDateTime.fromXML(params['dob']); + x.sep(', '); + x.tx('born '+params['dob']); + FPatDesc := FPatDesc + ', '+params['dob']; + end; + + if (tg <> '') then + begin + x.sep(', '); + x.tx(' ('+tg+' gender'); + if (tp <> '') then + begin + x.tx(', '+tp); + FPatDesc := FPatDesc + '('+tg+':'+tp+')'; + end + else + FPatDesc := FPatDesc + '('+tg+')'; + x.tx(')'); + ext := result.addExtension('http://hl7.org/fhir/StructureDefinition/individual-genderIdentity'); + ext.addExtension('value', makeCodeableConcept(sg,cg,dg, params['gender-other'])); + end; + if (tp <> '') then + begin + if (tg = '') then + begin + x.sep(', '); + x.tx(' ('+tp+')'); + FPatDesc := FPatDesc + '('+tp+')'; + end; + + ext := result.addExtension('http://hl7.org/fhir/StructureDefinition/individual-pronouns'); + ext.addExtension('value', makeCodeableConcept(sp,cdp,dp, params['pronouns-other'])); + end; + if (tp <> '') then + begin + x.tx(' ('+tv+')'); + FPatDesc := FPatDesc + '('+tv+')'; + ext := result.addExtension('http://hl7.org.au/fhir/StructureDefinition/sex-characterstic-variation'); + ext.addExtension('value', makeCodeableConcept(sv,cdv,dv,'')); + end; + + if (params.has('community')) then + begin + ext := result.addExtension('http://hl7.org.au/fhir/StructureDefinition/community-affiliation'); + ext.addExtension('value', TFhirString.create(params['community'])); + end; + + if params.has('id') then + begin + id := result.identifierList.Append; + id.value := params['id']; + id.type_ := makeCodeableConcept('http://terminology.hl7.org/CodeSystem/v2-0203', 'NIIP', 'National Insurance Payor Identifier (Payor)', ''); + x.sep('. '); + x.tx('National ID '+params['id']); + FPatDesc := FPatDesc + ', National ID '+params['id']; + if params.has('country') then + x.tx(' for '+params['country']); + end; + if params.has('country') then + result.addressList.append.country := params['country']; + if (x.ChildNodes.Count > 0) then + x.br; + if params.has('culture') then + begin + result.addExtension('http://healthintersections.com.au/fhir/StructureDefinition/patient-cultural-background', TFHIRString.Create(params['culture'])); + x.tx('Cultural background: '+params['culture']); + x.br; + end; + + if params.has('email') or params.has('mobile') or params.has('phone') then + begin + x.tx('Contacts: '); + if params.has('email') then + begin + cp := result.telecomList.Append; + cp.system := ContactPointSystemEmail; + cp.value := params['email']; + x.tx('email: '); + x.ah('mailto:'+params['email']).tx(params['email']); + end; + if params.has('mobile') then + begin + if params.has('email') then + x.tx(', '); + cp := result.telecomList.Append; + cp.system := ContactPointSystemPhone; + cp.use := ContactPointUseMobile; + cp.value := params['mobile']; + x.tx('mobile: '); + x.ah('tel:'+params['mobile']).tx(params['mobile']); + end; + if params.has('phone') then + begin + if params.has('email') or params.has('mobile') then + x.tx(', '); + cp := result.telecomList.Append; + cp.system := ContactPointSystemPhone; + cp.value := params['phone']; + x.tx('phone: '); + x.ah('tel:'+params['phone']).tx(params['phone']); + end; + end; + + if (params.has('nok')) then + begin + x.br; + x.tx('Next of Kin: '+params['nok']); + nok := result.contactList.Append; + nok.name := TFhirHumanName.Create; + nok.name.text := params['nok']; + if params.has('nokemail') or params.has('nokmobile') or params.has('nokphone') then + begin + x.tx(', contacts: '); + if params.has('nokemail') then + begin + cp := nok.telecomList.Append; + cp.system := ContactPointSystemEmail; + cp.value := params['nokemail']; + x.tx('email: '); + x.ah('mailto:'+params['nokemail']).tx(params['nokemail']); + end; + if params.has('nokmobile') then + begin + if params.has('nokemail') then + x.tx(', '); + cp := nok.telecomList.Append; + cp.system := ContactPointSystemPhone; + cp.use := ContactPointUseMobile; + cp.value := params['nokmobile']; + x.tx('mobile: '); + x.ah('tel:'+params['nokmobile']).tx(params['nokmobile']); + end; + if params.has('nokphone') then + begin + if params.has('email') or params.has('mobile') then + x.tx(', '); + cp := nok.telecomList.Append; + cp.system := ContactPointSystemPhone; + cp.value := params['nokphone']; + x.tx('phone: '); + x.ah('tel:'+params['nokphone']).tx(params['nokphone']); + end; + end; + end; + if (params.has('language')) then + begin + s := params['language'].toLower; + l := result.communicationList.Append; + l.language := TFHIRCodeableConcept.create; + l.language.text := params['language']; + l.preferred := true; + if ((s = 'en') or (s = 'english')) then + if (params.has('english')) then + begin + l := result.communicationList.Append; + l.language := TFHIRCodeableConcept.create; + l.language.text := 'english'; + end; + end; + + result.link; + finally + result.free; + end; +end; + +function TIPSGenerator.makeFuncStatusCondition(sect: TFHIRCompositionSection; ul : TFhirXHtmlNode; paramName, text, systemUri, code, display: String): TFHIRCondition; +var + rx : TFhirXHtmlNode; +begin + if params[paramName] <> 'true' then + result := nil + else + begin + result := TFHIRCondition.Create; + try + result.id := nextId('cnd'); + result.text := makeDiv(false, rx); + result.clinicalStatus := makeCodeableConcept('http://terminology.hl7.org/CodeSystem/condition-clinical', 'active', 'Active', ''); + result.code := makeCodeableConcept(systemUri, code, display, ''); + result.code.text := text; + result.subject := TFHIRReference.Create('Patient/p1'); + sect.entryList.Append.reference := 'Condition/'+result.id; + ul.li.tx(text); + rx.p.tx('Condition for '+FPatDesc); + rx.p.tx(text); + result.link; + finally + result.free; + end; + end; +end; + +function organStatusCode(s : String) : String; +begin + if (s = 'ns') then + result := '' + else if (s = 'p') then + result := 'present' + else if (s = 'a') then + result := 'transplanted-in' + else if (s = 'i') then + result := 'implant' + else if (s = 'g') then + result := 'absent' + else if (s = 'np') then + result := 'congenitally-absent' + else if (s = 'pr') then + result := 'partially-excised' + else if (s = 'r') then + result := 'excised' + else + result := ''; +end; + + +function organStatusDisplay(s : String) : String; +begin + if (s = 'ns') then + result := '' + else if (s = 'present') then + result := 'present' + else if (s = 'transplanted-in') then + result := 'transplanted-in' + else if (s = 'implant') then + result := 'implant' + else if (s = 'absent') then + result := 'absent' + else if (s = 'congenitally-absent') then + result := 'congenitally-absent' + else if (s = 'partially-excised') then + result := 'partially-excised' + else if (s = 'excised') then + result := 'excised' + else + result := ''; +end; + + +function TIPSGenerator.makeOrganRegistryEntry(sect : TFHIRCompositionSection; ul : TFhirXHtmlNode; paramName, text, systemUri, code, display : String) : TFHIRObservation; +var + rx : TFhirXHtmlNode; + s : String; +begin + if params[paramName] = 'ns' then + result := nil + else + begin + result := TFHIRObservation.Create; + try + result.id := nextId('obs'); + result.text := makeDiv(false, rx); + result.categoryList.add(makeCodeableConcept('http://terminology.hl7.org/CodeSystem/observation-category', 'organ-inventory', 'Organ Inventory', '')); + result.code := makeCodeableConcept('http://loinc.org', 'XXXXX-Y', 'Organ status', ''); + result.code.text := text; + result.subject := TFHIRReference.Create('Patient/p1'); + result.effective := TFHIRDateTime.create(TFslDateTime.makeUTC); + result.bodySite := makeCodeableConcept(systemUri, code, display, ''); + s := organStatusCode(params[paramName]); + result.value := makeCodeableConcept('http://healthintersections.com.au/fhir/playground/CodeSystem/organ-inventory-status', s, organStatusDisplay(s), ''); + sect.entryList.Append.reference := 'Condition/'+result.id; + ul.li.tx(text); + rx.p.tx('Condition for '+FPatDesc); + rx.p.tx(text); + result.link; + finally + result.free; + end; + end; +end; + +function TIPSGenerator.makeFuncStatusTextCondition(sect: TFHIRCompositionSection; x: TFhirXHtmlNode; paramName: string): TFHIRCondition; +var + rx : TFhirXHtmlNode; +begin + if params[paramName] = '' then + result := nil + else + begin + result := TFHIRCondition.Create; + try + result.id := nextId('cnd'); + result.text := makeDiv(false, rx); + result.clinicalStatus := makeCodeableConcept('http://terminology.hl7.org/CodeSystem/condition-clinical', 'active', 'Active', ''); + result.code := TFhirCodeableConcept.Create; + result.code.text := params[paramName]; + result.subject := TFHIRReference.Create('Patient/p1'); + sect.entryList.Append.reference := 'Condition/'+result.id; + x.p.tx(params[paramName]); + rx.p.tx('Condition for '+FPatDesc); + rx.p.tx(params[paramName]); + result.link; + finally + result.free; + end; + end; +end; + +procedure TIPSGenerator.makeAvoidanceRelationship(sect: TFHIRCompositionSection; ul: TFhirXHtmlNode; s : String); +var + li: TFhirXHtmlNode; +var + ref : TFhirReference; +begin + li := ul.li; + li.tx(s); + ref := sect.entryList.Append; + ref.display := s; + ref.addExtension('http://www.healthintersections.com.au/fhir/StructureDefinition/do-not-contact', TFhirBoolean.create(true)); +end; + +function TIPSGenerator.makeCareAdvocate(sect: TFHIRCompositionSection; ul: TFhirXHtmlNode): TFHIRRelatedPerson; +var + li: TFhirXHtmlNode; +var + rx : TFhirXHtmlNode; + cp : TFHIRContactPoint; +begin + if params['ca'] = '' then + result := nil + else + begin + li := ul.li; + result := TFHIRRelatedPerson.Create; + try + result.id := nextId('rp'); + result.text := makeDiv(false, rx); + result.patient := TFHIRReference.Create('Patient/p1'); + li.tx('Care Advocate:'); + rx.p.tx('Care Advocate for '+FPatDesc+':'); + result.nameList.Append.text := params['caname']; + li.tx(params['caname']); + rx.tx(params['caname']); + if params.has('caemail') or params.has('camobile') or params.has('caphone') then + begin + li.tx('. Contacts: '); + rx.tx('. Contacts: '); + if params.has('caemail') then + begin + cp := result.telecomList.Append; + cp.system := ContactPointSystemEmail; + cp.value := params['caemail']; + li.tx('email: '); + li.ah('mailto:'+params['caemail']).tx(params['caemail']); + rx.tx('email: '); + rx.ah('mailto:'+params['caemail']).tx(params['caemail']); + end; + if params.has('camobile') then + begin + if params.has('caemail') then + begin + li.tx(', '); + rx.tx(', '); + end; + cp := result.telecomList.Append; + cp.system := ContactPointSystemPhone; + cp.use := ContactPointUseMobile; + cp.value := params['camobile']; + li.tx('mobile: '); + li.ah('tel:'+params['camobile']).tx(params['camobile']); + rx.tx('mobile: '); + rx.ah('tel:'+params['camobile']).tx(params['camobile']); + end; + if params.has('caphone') then + begin + if params.has('caemail') or params.has('camobile') then + begin + li.tx(', '); + rx.tx(', '); + end; + cp := result.telecomList.Append; + cp.system := ContactPointSystemPhone; + cp.value := params['caphone']; + li.tx('phone: '); + li.ah('tel:'+params['caphone']).tx(params['caphone']); + rx.tx('phone: '); + rx.ah('tel:'+params['caphone']).tx(params['caphone']); + end; + end; + if params['calegal'] = 'true' then + begin + result.relationshipList.Add(makeCodeableConcept('http://terminology.hl7.org/CodeSystem/v3-RoleCode', 'HPOWATT', 'healthcare power of attorney', '')); + rx.tx(' (legal power of attorney)'); + li.tx(' (legal power of attorney)'); + end + else + result.relationshipList.Add(makeCodeableConcept('http://terminology.hl7.org/CodeSystem/v3-RoleCode', 'NOK', 'next of kin', '')); + + sect.entryList.Append.reference := 'RelatedPerson/'+result.id; + result.link; + finally + result.free; + end; + end; +end; + +function TIPSGenerator.makeConsent(sect : TFHIRCompositionSection; ul : TFhirXHtmlNode; fwds : boolean; paramName, textYes, textNo, systemUri, code, display : String) : TFHIRConsent; +var + li: TFhirXHtmlNode; +var + rx : TFhirXHtmlNode; + cp : TFHIRContactPoint; +begin + if (params[paramName] = '') then + result := nil + else + begin + li := ul.li; + result := TFHIRConsent.Create; + try + result.id := nextId('cnst'); + result.text := makeDiv(false, rx); + li.tx('Consent: '); + rx.p.tx('Consent for '+FPatDesc+': '); + result.patient := TFHIRReference.Create('Patient/p1'); + result.status := ConsentStateCodesActive; + result.scope := makeCodeableConcept('http://terminology.hl7.org/CodeSystem/consentscope', 'adr', 'Advanced Care Directive', ''); + result.categoryList.Add(makeCodeableConcept('http://terminology.hl7.org/CodeSystem/consentcategorycodes', 'acd', 'Advance Directive', '')); + result.policyRule := TFhirCodeableConcept.Create; + result.policyRule.text := 'Unknown Policy'; + result.provision := TFHIRConsentProvision.Create; + if (params[paramName] = 'false') xor fwds then + begin + result.provision.type_ := ConsentProvisionTypePermit; + li.tx(textYes); + rx.tx(textYes); + end + else + begin + result.provision.type_ := ConsentProvisionTypeDeny; + li.tx(textNo); + rx.tx(textNo); + end; + result.provision.codeList.add(makeCodeableConcept(systemUri, code, display, '')); + + sect.entryList.Append.reference := 'Consent/'+result.id; + result.link; + finally + result.free; + end; + end; +end; + +function TIPSGenerator.makeDocRef(sect: TFHIRCompositionSection; ul: TFhirXHtmlNode): TFHIRDocumentReference; +var + li: TFhirXHtmlNode; +var + rx : TFhirXHtmlNode; + cp : TFHIRContactPoint; +begin + if attachment = nil then + result := nil + else + begin + li := ul.li; + result := TFHIRDocumentReference.Create; + try + result.id := nextId('dr'); + result.text := makeDiv(false, rx); + result.status := DocumentReferenceStatusCurrent; + result.subject := TFHIRReference.Create('Patient/p1'); + result.type_ := makeCodeableConcept('http://loinc.org', '75320-2', 'Advance directive', ''); + li.tx('Advance Care Directive:'); + rx.p.tx('Advance Care Directive '+FPatDesc+':'); + if FFormatChoice = 'z' then + result.contentList.Append.attachment := makeAttachment(attachment.Format, 'Advance directive', 'adr.pdf') + else + result.contentList.Append.attachment := makeAttachment(attachment.Format, 'Advance directive', attachment); + + sect.entryList.Append.reference := 'DocumentReference/'+result.id; + result.link; + finally + result.free; + end; + end; +end; + +function TIPSGenerator.generateBundle : TFhirBundle; +var + bnd : TFHIRBundle; + comp : TFHIRComposition; + sect : TFHIRCompositionSection; + cp : TFHIRCarePlan; + x, ul : TFhirXHtmlNode; + ts : TStringList; + s : String; +begin + FFormatChoice := params['format']; + + bnd := makeBundle; + try + comp := makeComposition; + addToBundle(bnd, comp); + addToBundle(bnd, makePatient); + + // functional concerns / needs + sect := addSection(comp, 'Functional Concerns', 'http://loinc.org', '47420-5', x); + ul := x.ul; + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-visual', 'Patient has concerns around Vision', 'http://snomed.info/sct', '397540003', 'Visual impairment')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-audio', 'Patient has concerns around Hearing / Listening', 'http://snomed.info/sct', '15188001', 'Hearing impaired')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-cognition', 'Patient has concerns around Cognition / thinking / understanding / information processing', 'http://snomed.info/sct', '386806002', 'Impaired cognition')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-speaking', 'Patient has concerns around Speaking / communicating / Conversation / Verbal interaction', 'http://snomed.info/sct', '29164008', 'Speech impairment')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-mobility', 'Patient has concerns around Mobility / moving myself around', 'http://snomed.info/sct', '82971005', 'Impaired mobility')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-gender', 'Patient has concerns around Use of gender specific areas', 'http://snomed.info/sct', '93461009', 'Gender dysphoria')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-memory', 'Patient has concerns around Memory', 'http://snomed.info/sct', '386807006', 'Memory impairment')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-trauma', 'Patient has concerns around dealing with Past Trauma', 'http://snomed.info/sct', '161472001', 'History of psychological trauma')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-focus', 'Patient has concerns around Staying focused / Concentration', 'http://snomed.info/sct', '1144748009', 'Impaired concentration')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-addiction', 'Patient has concerns around managing their addictions', 'http://snomed.info/sct', '32709003', 'Addiction')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'concern-city', 'Cities and/or crowds are unfamiliar for the patient', 'http://snomed.info/sct', '5794003', 'Country dweller')); + + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'eating', 'Patient may need help with Eating / Drinking', 'http://snomed.info/sct', '110292000', 'Difficulty eating')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'toileting', 'Patient may need help with Toileting', 'http://snomed.info/sct', '284911003', 'Difficulty using toilet')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'bed-exit', 'Patient may need help with Getting out of bed', 'http://snomed.info/sct', '301666002', 'Difficulty getting on and off a bed')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'bed-in', 'Patient may need help with Moving in bed', 'http://snomed.info/sct', '301685004', 'Difficulty moving in bed')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'orientation', 'Patient may need help with Getting orientated in a new environment', 'http://snomed.info/sct', '72440003', ' Disorientated in place')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'dressing', 'Patient may need help with Dressing', 'http://snomed.info/sct', '284977008', 'Difficulty dressing')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'bathing', 'Patient may need help with Bathing / Cleaning', 'http://snomed.info/sct', '284807005', 'Difficulty bathing self')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'meds', 'Patient may need help with Taking my medications', 'http://snomed.info/sct', '715037005', 'Difficulty taking medication')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'reading', 'Patient may need help with Reading Documentation', 'http://snomed.info/sct', '309253009', 'Difficulty reading')); + + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'dog', 'Patient has a Guide Dog', 'http://snomed.info/sct', '105506000', 'Dependence on seeing eye dog')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'wheelchair', 'Patient has a Wheelchair', 'http://snomed.info/sct', '105503008', 'Dependence on wheelchair')); + addToBundle(bnd, makeFuncStatusCondition(sect, ul, 'comm-device', 'Patient has a Communication Device', 'http://snomed.info/sct', '719369003', 'Uses communication device')); + + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Arm-l', 'Left Arm Status', 'http://snomed.info/sct', '368208006', 'Left upper arm structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Arm-r', 'Right Arm Status', 'http://snomed.info/sct', '368209003', 'Right upper arm structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Hand-l', 'Left Hand Status', 'http://snomed.info/sct', '85151006', 'Structure of left hand')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Hand-r', 'Right Hand Status', 'http://snomed.info/sct', '78791008', 'Structure of right hand')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Fingers-l', 'Left Fingers Status', 'http://snomed.info/sct', '786841006', 'Structure of all fingers of left hand')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Fingers-r', 'Right Fingers Status', 'http://snomed.info/sct', '786842004', 'Structure of all fingers of right hand')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Leg-l', 'Left Leg Status', 'http://snomed.info/sct', '48979004', 'Structure of left lower leg')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Leg-r', 'Right Leg Status', 'http://snomed.info/sct', '32696007', 'Structure of right lower leg')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Calf-l', 'Left Calf Status', 'http://snomed.info/sct', '48979004', 'Structure of left lower leg')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Calf-r', 'Right Calf Status', 'http://snomed.info/sct', '32696007', 'Structure of right lower leg')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Foot-l', 'Left Foot Status', 'http://snomed.info/sct', '22335008', 'Structure of left foot')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Foot-r', 'Right Foot Status', 'http://snomed.info/sct', '7769000', 'Structure of right foot')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Toe-l', 'Left Toe Status', 'http://snomed.info/sct', '785708006', 'Structure of all toes of left foot')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Toe-r', 'Right Toe Status', 'http://snomed.info/sct', '785709003', 'Structure of all toes of right foot')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Hip-l', 'Left Hip Status', 'http://snomed.info/sct', '287679003', 'Left hip region structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Hip-r', 'Right Hip Status', 'http://snomed.info/sct', '287579007', 'Right hip region structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Eye-l', 'Left Eye Status', 'http://snomed.info/sct', '1290041000', 'Entire left eye proper')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Eye-r', 'Right Eye Status', 'http://snomed.info/sct', '1290043002', 'Entire right eye proper')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Hypothalamus', 'Hypothalamus Status', 'http://snomed.info/sct', '67923007', 'Hypothalamic structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Pituitary', 'Pituitary Status', 'http://snomed.info/sct', '56329008', 'Pituitary structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Tongue', 'Tongue Status', 'http://snomed.info/sct', '21974007', 'Tongue structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Jaw', 'Jaw Status', 'http://snomed.info/sct', '661005', 'Jaw region structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Oesophagus', 'Oesophagus Status', 'http://snomed.info/sct', '32849002', 'Esophageal structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'LargeColon', 'Large Colon Status', 'http://snomed.info/sct', '71854001', 'Colon structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Stomach', 'Stomach Status', 'http://snomed.info/sct', '69695003', 'Stomach structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'GallBladder', 'Gall Bladder Status', 'http://snomed.info/sct', '28231008', 'Gallbladder structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Kidney-l', 'Left Kidney Status', 'http://snomed.info/sct', '18639004', 'Left kidney structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Kidney-r', 'Right Kidney Status', 'http://snomed.info/sct', '9846003', 'Right kidney structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Liver', 'Liver Status', 'http://snomed.info/sct', '10200004', '10200004')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Bladder', 'Bladder Status', 'http://snomed.info/sct', '89837001', 'Urinary bladder structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Lung-l', 'Left Lung Status', 'http://snomed.info/sct', '44029006', 'Left lung structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Lung-r', 'Right Lung Status', 'http://snomed.info/sct', '3341006', 'Right lung structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Breasts-l', 'Left Breast Status', 'http://snomed.info/sct', '80248007', 'Left breast structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Breasts-r', 'Right Breast Status', 'http://snomed.info/sct', '73056007', 'Right breast structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Ovary-l', 'Left Ovary Status', 'http://snomed.info/sct', '43981004', 'Structure of left ovary')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Ovary-r', 'Right Ovary Status', 'http://snomed.info/sct', '20837000', 'Structure of right ovary')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Uterus', 'Uterus Status', 'http://snomed.info/sct', '35039007', 'Uterine structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Cervix', 'Cervix Status', 'http://snomed.info/sct', '71252005', 'Cervix uteri structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Vagina', 'Vagina Status', 'http://snomed.info/sct', '76784001', 'Vaginal structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Penis', 'Penis Status', 'http://snomed.info/sct', '18911002', 'Penile structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Prostate', 'Prostate Status', 'http://snomed.info/sct', '41216001', 'Prostatic structure')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Testis-l', 'Left Testis Status', 'http://snomed.info/sct', '63239009', 'Structure of left testis')); + addToBundle(bnd, makeOrganRegistryEntry(sect, ul, 'Testis-r', 'Right Testis Status', 'http://snomed.info/sct', '15598003', 'Structure of right testis')); + + addToBundle(bnd, makeFuncStatusTextCondition(sect, x, 'text')); + + // advance directive things + sect := addSection(comp, 'Care Directives', 'http://loinc.org', '42348-3', x); + ul := x.ul; + addToBundle(bnd, makeCareAdvocate(sect, ul)); + addToBundle(bnd, makeConsent(sect, ul, false, 'dnr', 'Please resuscitate if necessary', + 'Patient wishes to not be resuscitated (DNR)', 'http://snomed.info/sct', '439569004', 'Resuscitation')); + addToBundle(bnd, makeConsent(sect, ul, true, 'donor', 'Patient agrees to be an organ donor', + 'Patient does not agree to be an organ donor', 'http://snomed.info/sct', '1148553005', 'Post-mortem organ donation')); + addToBundle(bnd, makeConsent(sect, ul, true, 'bld', 'Patient agrees to accept a blood tranfusion if necessary', + 'Patient does not accept a blood transfusion', 'http://snomed.info/sct', '116859006', 'Blood transfusion')); + addToBundle(bnd, makeDocRef(sect, ul)); + + if (params.has('avoidance')) then + begin + x.p.tx('Plase avoid contacting/communicating with these individuals:'); + ul := x.ul; + ts := TStringList.create; + try + ts.text := params['avoidance']; + for s in ts do + makeAvoidanceRelationship(sect, ul, s); + finally + ts.free; + end; + end; + result := bnd.Link; + finally + bnd.free; + end; +end; + +function TIPSGenerator.generateBinary: TFslBuffer; +var + bnd : TFhirBundle; + comp : TFHIRComposer; + wrap : TIPSWrapper; +begin + bnd := generateBundle; + try + result := TFslBuffer.Create; + try + if FFormatChoice = 'j' then + begin + comp := TFHIRJsonComposer.Create(nil, OutputStylePretty, nil); + try + result.AsText := comp.Compose(bnd); + finally + comp.free; + end; + result.Format := 'application/fhir+json'; + end + else if FFormatChoice = 'x' then + begin + comp := TFHIRXmlComposer.Create(nil, OutputStylePretty, nil); + try + result.AsText := comp.Compose(bnd); + finally + comp.free; + end; + result.Format := 'application/fhir+xml'; + end + else + begin + wrap := TIPSWrapper.Create; + try + wrap.startBuild('Patient Authored Passport (IPS)'); + wrap.addIPS(bnd, ivkOriginal, 'Health Intersections Website'); + if attachment <> nil then + wrap.addAttachment(attachment, 'adr.pdf', iakAttachment); + result.AsBytes := wrap.saveToBytes; + finally + wrap.free; + end; + result.Format := 'application/health-document'; + end; + result.link; + finally + result.free; + end; + finally + bnd.free; + end; +end; + + +{ TIPSWrapper } + +function TIPSWrapper.writeManifest: TBytes; +begin + result := TJsonWriter.writeObject(FManifest, true); +end; + +constructor TIPSWrapper.Create; +begin + inherited Create; + FContent := TFslMap.Create; +end; + +destructor TIPSWrapper.Destroy; +begin + FContent.free; + FManifest.free; + inherited Destroy; +end; + +procedure TIPSWrapper.startBuild(name : String); +begin + FManifest := TJsonObject.Create; + FManifest.str['format'] := 'ips-wrapper/1'; + FManifest.str['description'] := name; +end; + +procedure TIPSWrapper.addIPS(ips: TFhirBundle; kind : TIPSVersionKind; agent : String); +var + comp : TFHIRComposer; + id : String; + e : TJsonObject; + bin : TFslBuffer; +begin + id := 'ips-'+CODES_TIPSVersionKind[kind]+'.json'; + if (FContent.ContainsKey(id)) then + id := newGuidId+'.json'; + e := FManifest.forceArr['ips-versions'].addObject; + e.str['source'] := id; + e.str['kind'] := CODES_TIPSVersionKind[kind]; + e.str['mimetype'] := 'application/fhir+json'; + bin := TFslBuffer.Create; + try + comp := TFHIRJsonComposer.Create(nil, OutputStylePretty, nil); + try + bin.AsText := comp.Compose(ips); + finally + comp.free; + end; + FContent.Add(id, bin.link); + finally + bin.free; + end; +end; + +procedure TIPSWrapper.addAttachment(attachment : TFslBuffer; fn : String; kind : TIPSAttachmentKind); +var + e : TJsonObject; +begin + e := FManifest.forceArr['attachments'].addObject; + e.str['source'] := fn; + e.str['kind'] := CODES_TIPSAttachmentKind[kind]; + if attachment.format <> '' then + e.str['mimetype'] := attachment.format; + FContent.Add(fn, attachment.link); +end; + +class function TIPSWrapper.fromStream(stream: TStream): TIPSWrapper; +begin + raise EFslException.Create('Not done yet'); +end; + +class function TIPSWrapper.fromStream(stream: TFslStream): TIPSWrapper; +begin + raise EFslException.Create('Not done yet'); +end; + +procedure TIPSWrapper.saveToStream(stream: TStream); +begin + raise EFslException.Create('Not done yet'); +end; + +procedure TIPSWrapper.saveToStream(stream: TFslStream); +begin + raise EFslException.Create('Not done yet'); +end; + + +procedure Decode(const sSource: TBytes); +var + buffer : TFslBuffer; + zip : TFslZipPartList; + reader : TFslZipReader; + ss : TFslStringStream; + i : integer; +Begin + ss := TFslStringStream.Create; + try + ss.Bytes := sSource; + zip := TFslZipPartList.Create; + reader := TFslZipReader.Create; + try + reader.Stream := ss.Link; + reader.Parts := zip.Link; + reader.ReadZip; + for i := 0 to zip.Count - 1 do + Logging.log(zip[i].Name); + finally + reader.free; + end; + finally + ss.free; + end; +end; + +function TIPSWrapper.saveToBytes: TBytes; +var + ss : TFslStringStream; + zip : TFslZipPartList; + writer : TFslZipWriter; + name : String; +begin + zip := TFslZipPartList.Create; + try + zip.Add('manifest.json', WriteManifest); + for name in FContent.Keys do + zip.Add(name, FContent[name].AsBytes); + writer := TFslZipWriter.Create; + try + writer.Parts := zip.Link; + ss := TFslStringStream.Create; + try + writer.Stream := ss.Link; + writer.WriteZip; + result := ss.Bytes; + finally + ss.free; + end; + finally + writer.free; + end; + finally + zip.free; + end; + // decode(result); +end; + + +end. + + diff --git a/library/fhir4/fhir4_utilities.pas b/library/fhir4/fhir4_utilities.pas index 8e62f3ca2..f1d619051 100644 --- a/library/fhir4/fhir4_utilities.pas +++ b/library/fhir4/fhir4_utilities.pas @@ -5258,13 +5258,27 @@ function TFhirCodeSystemHelper.GetSystem: String; function TFhirCodeSystemHelper.isAbstract(concept: TFhirCodeSystemConcept): boolean; var p : TFhirCodeSystemConceptProperty; + pd : TFhirCodeSystemProperty; + c, s : String; begin result := false; for p in concept.property_List do + begin if (p.code = 'abstract') and (p.value is TFhirBoolean) and (TFHIRBoolean(p.value).value) then exit(true); + end; + s := csUriForProperty('notSelectable'); + c := 'notSelectable'; + if (s <> '') then + for pd in property_List do + if pd.uri = s then + begin + c := pd.code; + break; + end; + for p in concept.property_List do - if (p.code = 'notSelectable') and (p.value is TFhirBoolean) and (TFHIRBoolean(p.value).value) then + if (p.code = c) and (p.value is TFhirBoolean) and (TFHIRBoolean(p.value).value) then exit(true); end; diff --git a/library/fhir4b/fhir4b_utilities.pas b/library/fhir4b/fhir4b_utilities.pas index 7960d19c9..d6a512bf8 100644 --- a/library/fhir4b/fhir4b_utilities.pas +++ b/library/fhir4b/fhir4b_utilities.pas @@ -5228,13 +5228,27 @@ function TFhirCodeSystemHelper.GetSystem: String; function TFhirCodeSystemHelper.isAbstract(concept: TFhirCodeSystemConcept): boolean; var p : TFhirCodeSystemConceptProperty; + pd : TFhirCodeSystemProperty; + c, s : String; begin result := false; for p in concept.property_List do + begin if (p.code = 'abstract') and (p.value is TFhirBoolean) and (TFHIRBoolean(p.value).value) then - exit(true); + exit(true); + end; + s := csUriForProperty('notSelectable'); + c := 'notSelectable'; + if (s <> '') then + for pd in property_List do + if pd.uri = s then + begin + c := pd.code; + break; + end; + for p in concept.property_List do - if (p.code = 'notSelectable') and (p.value is TFhirBoolean) and (TFHIRBoolean(p.value).value) then + if (p.code = c) and (p.value is TFhirBoolean) and (TFHIRBoolean(p.value).value) then exit(true); end; diff --git a/library/fhir5/fhir5_context.pas b/library/fhir5/fhir5_context.pas index 2daef8ccc..31882edaa 100644 --- a/library/fhir5/fhir5_context.pas +++ b/library/fhir5/fhir5_context.pas @@ -201,6 +201,7 @@ implementation constructor TFHIRResourceProxy.Create(factory: TFHIRFactory; resource: TFHIRResource); begin + // inherited if resource is TFHIRCanonicalResource then inherited Create(resource, TFHIRCanonicalResource(resource).url, TFHIRCanonicalResource(resource).version) else diff --git a/library/fhir5/fhir5_narrative2.pas b/library/fhir5/fhir5_narrative2.pas index 54454aaf1..56be4cbdc 100644 --- a/library/fhir5/fhir5_narrative2.pas +++ b/library/fhir5/fhir5_narrative2.pas @@ -109,7 +109,7 @@ implementation function TNarrativeGenerator.capitalize(s : String):String; begin - if( s = '') then + if (s = '') then result := '' else result := UpperCase(s.substring(0, 1)) + s.substring(1); diff --git a/library/fhir5/fhir5_utilities.pas b/library/fhir5/fhir5_utilities.pas index d74032f1c..3d9d1c897 100644 --- a/library/fhir5/fhir5_utilities.pas +++ b/library/fhir5/fhir5_utilities.pas @@ -5195,13 +5195,27 @@ function TFhirCodeSystemHelper.GetSystem: String; function TFhirCodeSystemHelper.isAbstract(concept: TFhirCodeSystemConcept): boolean; var p : TFhirCodeSystemConceptProperty; + pd : TFhirCodeSystemProperty; + c, s : String; begin result := false; for p in concept.property_List do + begin if (p.code = 'abstract') and (p.value is TFhirBoolean) and (TFHIRBoolean(p.value).value) then - exit(true); + exit(true); + end; + s := csUriForProperty('notSelectable'); + c := 'notSelectable'; + if (s <> '') then + for pd in property_List do + if pd.uri = s then + begin + c := pd.code; + break; + end; + for p in concept.property_List do - if (p.code = 'notSelectable') and (p.value is TFhirBoolean) and (TFHIRBoolean(p.value).value) then + if (p.code = c) and (p.value is TFhirBoolean) and (TFHIRBoolean(p.value).value) then exit(true); end; diff --git a/library/fsl/fsl_base.pas b/library/fsl/fsl_base.pas index 1c5f1f6c3..fcec67fbe 100644 --- a/library/fsl/fsl_base.pas +++ b/library/fsl/fsl_base.pas @@ -1207,7 +1207,9 @@ procedure TFslObject.Free; clsName := 'n/a'; nmCls := 'n/a'; try + {$IFOPT D+} nmCls := FNamedClass; + {$ENDIF} except nmCls := '??'; end; @@ -1523,7 +1525,9 @@ function TFslObject.debugInfo: String; procedure TFslObject.updateDebugInfo; begin + {$IFOPT D+} FDebugInfo := debugInfo; + {$ENDIF} end; function TFslObject.ObjectCrossesThreads: boolean; @@ -1566,7 +1570,7 @@ function TFslObject.updatedDebugInfo: String; updateDebugInfo; except end; - result := FDebugInfo; + result := {$IFOPT D+}FDebugInfo{$ELSE}''{$ENDIF}; end; function TFslObject.CheckCondition(bCorrect: Boolean; const sMethod, sMessage: String): Boolean; diff --git a/library/fsl/fsl_cpu.pas b/library/fsl/fsl_cpu.pas index 6870327b2..2448d15b7 100644 --- a/library/fsl/fsl_cpu.pas +++ b/library/fsl/fsl_cpu.pas @@ -1,171 +1,171 @@ -unit fsl_cpu; - -{$i fhir.inc} - -{ -Copyright (c) 2011+, HL7 and Health Intersections Pty Ltd (http://www.healthintersections.com.au) -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, -are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of HL7 nor the names of its contributors may be used to - endorse or promote products derived from this software without specific - prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. -IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, -INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. -} -// adapted from https://w-shadow.com/blog/2006/08/27/how-to-get-the-cpu-usage-of-a-process/ and - -interface - -uses - Classes, SysUtils, - fsl_base, fsl_threads; - -const - wsMinMeasurementInterval=250; - {minimum amount of time that must have elapsed to calculate CPU usage, miliseconds. If time elapsed is less than this, previous result is returned, or zero, if there is no previous result.} - -type - - { TCPUUsageData } - - TCPUUsageData = class (TFslObject) - private - FLock : TFslLock; - FPID : cardinal; - {$IFDEF WINDOWS} - FHandle:cardinal; - {$ENDIF} - FOldUser, FOldKernel : Int64; - FLastUpdateTime : cardinal; - FLastUsage : single; //Last result of wsGetCpuUsage is saved here - public - constructor Create(PID : cardinal = 0); - destructor Destroy; override; - - function cpuUsage : Single; - function usage : String; - end; - -implementation - -uses -{$IFDEF WINDOWS} - Windows; -{$ELSE} - baseunix; -{$ENDIF} - -constructor TCPUUsageData.Create(PID : cardinal = 0); -{$IFDEF WINDOWS} -var - mCreationTime, mExitTime, mKernelTime, mUserTime:_FILETIME; - h : cardinal; -{$ENDIF} -begin - inherited create; - FLock := TFslLock.create('cpu.usage'); -{$IFDEF WINDOWS} - if FPID = 0 then - FPID := GetCurrentProcessId; - - //We need a handle with PROCESS_QUERY_INFORMATION privileges - FHandle := OpenProcess(PROCESS_QUERY_INFORMATION,false,FPID); - if FHandle <> 0 then - begin - FLastUpdateTime := GetTickCount64; - FLastUsage:=0; - if GetProcessTimes(FHandle, mCreationTime, mExitTime, mKernelTime, mUserTime) then - begin - //convert _FILETIME to Int64 - FOldKernel:=int64(mKernelTime.dwLowDateTime or (mKernelTime.dwHighDateTime shr 32)); - FOldUser:=int64(mUserTime.dwLowDateTime or (mUserTime.dwHighDateTime shr 32)); - end - end; -{$ELSE} -{$ENDIF}; -end; - -destructor TCPUUsageData.Destroy; -begin -{$IFDEF WINDOWS} - CloseHandle(FHandle); -{$ELSE} -{$ENDIF}; - FLock.Free; - inherited; -end; - -{$IFNDEF WINDOWS} -function getrusage(usage : integer; var data : rusage) : integer; -begin -// result := host_processor_info(); - // result := Getrusage(); -end; - -{$ENDIF} - -function TCPUUsageData.cpuUsage : Single; -{$IFDEF WINDOWS} -var - mCreationTime, mExitTime, mKernelTime, mUserTime:_FILETIME; - DeltaMs, ThisTime:cardinal; - mKernel, mUser, mDelta:int64; - {$ENDIF} -begin - result := 0; - {$IFDEF WINDOWS} - if (FHandle <> 0) then - begin - FLock.Lock; - try - result := FLastUsage; - ThisTime := GetTickCount; //Get the time elapsed since last query - DeltaMs := ThisTime - FLastUpdateTime; - if DeltaMs > wsMinMeasurementInterval then - begin - FLastUpdateTime := ThisTime; - GetProcessTimes(FHandle, mCreationTime, mExitTime, mKernelTime, mUserTime); - //convert _FILETIME to Int64. - mKernel := int64(mKernelTime.dwLowDateTime or (mKernelTime.dwHighDateTime shr 32)); - mUser := int64(mUserTime.dwLowDateTime or (mUserTime.dwHighDateTime shr 32)); - //get the delta - mDelta := mUser + mKernel - FOldUser - FOldKernel; - FOldUser := mUser; - FOldKernel := mKernel; - Result := (mDelta / DeltaMs) / 100; //mDelta is in units of 100 nanoseconds, so… - FLastUsage := Result; //just in case you want to use it later, too - end; - finally - FLock.Unlock; - end; - end; - {$ELSE} - // getrusage... - {$ENDIF}; -end; - -function TCPUUsageData.usage: String; -begin - result := inttostr(trunc(cpuUsage))+'%'; -end; - - -end. - +unit fsl_cpu; + +{$i fhir.inc} + +{ +Copyright (c) 2011+, HL7 and Health Intersections Pty Ltd (http://www.healthintersections.com.au) +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of HL7 nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +} +// adapted from https://w-shadow.com/blog/2006/08/27/how-to-get-the-cpu-usage-of-a-process/ and + +interface + +uses + Classes, SysUtils, + fsl_base, fsl_threads; + +const + wsMinMeasurementInterval=250; + {minimum amount of time that must have elapsed to calculate CPU usage, miliseconds. If time elapsed is less than this, previous result is returned, or zero, if there is no previous result.} + +type + + { TCPUUsageData } + + TCPUUsageData = class (TFslObject) + private + FLock : TFslLock; + FPID : cardinal; + {$IFDEF WINDOWS} + FHandle:cardinal; + {$ENDIF} + FOldUser, FOldKernel : Int64; + FLastUpdateTime : cardinal; + FLastUsage : single; //Last result of wsGetCpuUsage is saved here + public + constructor Create(PID : cardinal = 0); + destructor Destroy; override; + + function cpuUsage : Single; + function usage : String; + end; + +implementation + +uses +{$IFDEF WINDOWS} + Windows; +{$ELSE} + baseunix; +{$ENDIF} + +constructor TCPUUsageData.Create(PID : cardinal = 0); +{$IFDEF WINDOWS} +var + mCreationTime, mExitTime, mKernelTime, mUserTime:_FILETIME; + h : cardinal; +{$ENDIF} +begin + inherited create; + FLock := TFslLock.create('cpu.usage'); +{$IFDEF WINDOWS} + if FPID = 0 then + FPID := GetCurrentProcessId; + + //We need a handle with PROCESS_QUERY_INFORMATION privileges + FHandle := OpenProcess(PROCESS_QUERY_INFORMATION,false,FPID); + if FHandle <> 0 then + begin + FLastUpdateTime := GetTickCount64; + FLastUsage:=0; + if GetProcessTimes(FHandle, mCreationTime, mExitTime, mKernelTime, mUserTime) then + begin + //convert _FILETIME to Int64 + FOldKernel:=int64(mKernelTime.dwLowDateTime or (mKernelTime.dwHighDateTime shr 32)); + FOldUser:=int64(mUserTime.dwLowDateTime or (mUserTime.dwHighDateTime shr 32)); + end + end; +{$ELSE} +{$ENDIF}; +end; + +destructor TCPUUsageData.Destroy; +begin +{$IFDEF WINDOWS} + CloseHandle(FHandle); +{$ELSE} +{$ENDIF}; + FLock.Free; + inherited; +end; + +{$IFNDEF WINDOWS} +function getrusage(usage : integer; var data : rusage) : integer; +begin +// result := host_processor_info(); + // result := Getrusage(); +end; + +{$ENDIF} + +function TCPUUsageData.cpuUsage : Single; +{$IFDEF WINDOWS} +var + mCreationTime, mExitTime, mKernelTime, mUserTime:_FILETIME; + DeltaMs, ThisTime:cardinal; + mKernel, mUser, mDelta:int64; + {$ENDIF} +begin + result := 0; + {$IFDEF WINDOWS} + if (FHandle <> 0) then + begin + FLock.Lock; + try + result := FLastUsage; + ThisTime := GetTickCount; //Get the time elapsed since last query + DeltaMs := ThisTime - FLastUpdateTime; + if DeltaMs > wsMinMeasurementInterval then + begin + FLastUpdateTime := ThisTime; + GetProcessTimes(FHandle, mCreationTime, mExitTime, mKernelTime, mUserTime); + //convert _FILETIME to Int64. + mKernel := int64(mKernelTime.dwLowDateTime or (mKernelTime.dwHighDateTime shr 32)); + mUser := int64(mUserTime.dwLowDateTime or (mUserTime.dwHighDateTime shr 32)); + //get the delta + mDelta := mUser + mKernel - FOldUser - FOldKernel; + FOldUser := mUser; + FOldKernel := mKernel; + Result := (mDelta / DeltaMs) / 100; //mDelta is in units of 100 nanoseconds, so… + FLastUsage := Result; //just in case you want to use it later, too + end; + finally + FLock.Unlock; + end; + end; + {$ELSE} + // getrusage... + {$ENDIF}; +end; + +function TCPUUsageData.usage: String; +begin + result := inttostr(trunc(cpuUsage))+'%'; +end; + + +end. + diff --git a/library/fsl/fsl_gzip.pas b/library/fsl/fsl_gzip.pas index 723cf1a38..82468148c 100644 --- a/library/fsl/fsl_gzip.pas +++ b/library/fsl/fsl_gzip.pas @@ -1,81 +1,81 @@ -unit fsl_gzip; - -{ -Copyright (c) 2011+, HL7 and Health Intersections Pty Ltd (http://www.healthintersections.com.au) -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, -are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of HL7 nor the names of its contributors may be used to - endorse or promote products derived from this software without specific - prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. -IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, -INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. -} - -{$I fhir.inc} - -interface - -uses - Classes, SysUtils, - {$IFDEF FPC} - zflate, - {$ELSE} - ZLib, - {$ENDIF} - fsl_base; - -{ - for FPC, we use the zflate units by fibodevy (thanks). - for delphi, we use delphi's inbuilt ZLib support -} - -function gzip(bytes : TBytes; header : boolean; level: {$IFDEF FPC}dword=9{$ELSE}TZCompressionLevel=TZCompressionLevel.zcDefault{$ENDIF}) : TBytes; -function ungzip(bytes : TBytes; description : String) : TBytes; - -implementation - -function gzip(bytes : TBytes; header : boolean; level: {$IFDEF FPC}dword=9{$ELSE}TZCompressionLevel=TZCompressionLevel.zcDefault{$ENDIF}) : TBytes; -begin - {$IFDEF FPC} - result := zflate.gzcompress(bytes, level); - {$ELSE} - ZLib.ZCompress(bytes, result, level); - {$ENDIF} -end; - -function ungzip(bytes : TBytes; description : String) : TBytes; -begin - {$IFDEF FPC} - result := zflate.zdecompress(bytes); - if zlastError <> 0 then - raise EFslException.create('Failed to uncompress '+description+': '+zflatetranslatecode(zlasterror)); - {$ELSE} - try - ZLib.ZDecompress(bytes, result); - except - on ex: Exception do - raise EFslException.create('Failed to uncompress '+description+': '+ex.Message); - end; - {$ENDIF} -end; - - -end. - +unit fsl_gzip; + +{ +Copyright (c) 2011+, HL7 and Health Intersections Pty Ltd (http://www.healthintersections.com.au) +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of HL7 nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +} + +{$I fhir.inc} + +interface + +uses + Classes, SysUtils, + {$IFDEF FPC} + zflate, + {$ELSE} + ZLib, + {$ENDIF} + fsl_base; + +{ + for FPC, we use the zflate units by fibodevy (thanks). + for delphi, we use delphi's inbuilt ZLib support +} + +function gzip(bytes : TBytes; header : boolean; level: {$IFDEF FPC}dword=9{$ELSE}TZCompressionLevel=TZCompressionLevel.zcDefault{$ENDIF}) : TBytes; +function ungzip(bytes : TBytes; description : String) : TBytes; + +implementation + +function gzip(bytes : TBytes; header : boolean; level: {$IFDEF FPC}dword=9{$ELSE}TZCompressionLevel=TZCompressionLevel.zcDefault{$ENDIF}) : TBytes; +begin + {$IFDEF FPC} + result := zflate.gzcompress(bytes, level); + {$ELSE} + ZLib.ZCompress(bytes, result, level); + {$ENDIF} +end; + +function ungzip(bytes : TBytes; description : String) : TBytes; +begin + {$IFDEF FPC} + result := zflate.zdecompress(bytes); + if zlastError <> 0 then + raise EFslException.create('Failed to uncompress '+description+': '+zflatetranslatecode(zlasterror)); + {$ELSE} + try + ZLib.ZDecompress(bytes, result); + except + on ex: Exception do + raise EFslException.create('Failed to uncompress '+description+': '+ex.Message); + end; + {$ENDIF} +end; + + +end. + diff --git a/library/ftx/fhir_codesystem_service.pas b/library/ftx/fhir_codesystem_service.pas index d27261902..8caf8c9af 100644 --- a/library/ftx/fhir_codesystem_service.pas +++ b/library/ftx/fhir_codesystem_service.pas @@ -205,8 +205,10 @@ TFhirCodeSystemProvider = class (TCodeSystemProvider) function locateParent(ctxt: TFHIRCodeSystemConceptW; code: String): String; function locCode(list: TFhirCodeSystemConceptListW; code, synonym: String; altOpt : TAlternateCodeOptions): TFhirCodeSystemConceptW; function getProperty(code : String) : TFhirCodeSystemPropertyW; + function hasPropForCode(code : String) : boolean; function conceptHasProperty(concept : TFhirCodeSystemConceptW; url : String; value : string) : boolean; procedure iterateConceptsByProperty(src : TFhirCodeSystemConceptListW; pp : TFhirCodeSystemPropertyW; value : String; list: TFhirCodeSystemProviderFilterContext); + procedure iterateConceptsByKnownProperty(src : TFhirCodeSystemConceptListW; code : String; value : String; List: TFhirCodeSystemProviderFilterContext); procedure iterateConceptsByRegex(src : TFhirCodeSystemConceptListW; regex: string; list: TFhirCodeSystemProviderFilterContext); procedure listChildrenByProperty(code : String; list, children : TFhirCodeSystemConceptListW); protected @@ -1035,17 +1037,48 @@ function TFhirCodeSystemProvider.getProperty(code: String): TFhirCodeSystemPrope var p : TFhirCodeSystemPropertyW; cs : TFhirCodeSystemW; + uri : String; begin result := nil; + uri := csUriForProperty(code); + if (uri <> '') then + begin + for p in FCs.CodeSystem.properties.forEnum do + if (p.uri = uri) then + exit(p.link); + for cs in FCs.Supplements do + for p in cs.properties.forEnum do + if (p.uri = uri) then + exit(p.link); + end; + for p in FCs.CodeSystem.properties.forEnum do - if (p.code = code) then + if (p.code = code) and ((uri = '') or (p.uri = '')) then exit(p.link); + for cs in FCs.Supplements do for p in cs.properties.forEnum do - if (p.code = code) then + if (p.code = code) and ((uri = '') or (p.uri = '')) then exit(p.link); end; +function TFhirCodeSystemProvider.hasPropForCode(code: String): boolean; +var + p : TFhirCodeSystemPropertyW; + cs : TFhirCodeSystemW; + uri : String; +begin + result := false; + for p in FCs.CodeSystem.properties.forEnum do + if (p.code = code) then + exit(true); + + for cs in FCs.Supplements do + for p in cs.properties.forEnum do + if (p.code = code) then + exit(true); +end; + function TFhirCodeSystemProvider.hasSupplement(url: String): boolean; var @@ -1448,6 +1481,66 @@ procedure TFhirCodeSystemProvider.iterateConceptsByProperty(src : TFhirCodeSyste end; end; +procedure TFhirCodeSystemProvider.iterateConceptsByKnownProperty(src: TFhirCodeSystemConceptListW; code: String; value: String; list: TFhirCodeSystemProviderFilterContext); +var + c, cc : TFhirCodeSystemConceptW; + concepts : TFhirCodeSystemConceptListW; + css : TFhirCodeSystemW; + cp : TFhirCodeSystemConceptPropertyW; + ok, val : boolean; + coding : TFHIRCodingW; + s1, s2 : String; +begin + concepts := TFhirCodeSystemConceptListW.Create; + try + for c in src do + begin + concepts.Clear; + concepts.Add(c.Link); + for css in FCs.Supplements do + begin + cc := locCode(css.conceptList, c.code, css.propertyCode('http://hl7.org/fhir/concept-properties#alternateCode'), nil); + if (cc <> nil) then + concepts.Add(cc.Link); + end; + for cc in concepts do + begin + ok := false; + val := false; + for cp in cc.properties.forEnum do + begin + if not ok and (cp.code = code) then + begin + val := true; + if (cp.value.isPrimitive) then + begin + s1 := cp.value.primitiveValue; + s2 := value; + ok := s1 = s2; + end + else // Coding: + begin + coding := FFactory.wrapCoding(cp.value.Link); + try + ok := coding.code = value; + finally + coding.free; + end; + end; + end; + end; + //if (not ok) and (not val and (pp.type_ = cptBoolean) and (value = 'false')) then + // ok := true; + if ok then + list.Add(c.Link, 0); + end; + iterateConceptsByKnownProperty(c.conceptList, code, value, list); + end; + finally + concepts.free; + end; +end; + procedure TFhirCodeSystemProvider.iterateConceptsByRegex(src: TFhirCodeSystemConceptListW; regex: string; list: TFhirCodeSystemProviderFilterContext); var c : TFhirCodeSystemConceptW; @@ -1578,7 +1671,7 @@ function TFhirCodeSystemProvider.filter(forIteration : boolean; prop: String; op begin pp := getProperty(prop); try - if (pp <> nil) and (op = foEqual) then + if (pp <> nil) and (op = foEqual) then begin result := TFhirCodeSystemProviderFilterContext.Create; try @@ -1588,6 +1681,16 @@ function TFhirCodeSystemProvider.filter(forIteration : boolean; prop: String; op result.free; end; end + else if StringArrayExists(['notSelectable'], prop) then // special known properties + begin + result := TFhirCodeSystemProviderFilterContext.Create; + try + iterateConceptsByKnownProperty(FCs.CodeSystem.conceptList, prop, value, result as TFhirCodeSystemProviderFilterContext); + result.link; + finally + result.free; + end; + end else result := nil; finally diff --git a/library/ftx/ftx_lang.pas b/library/ftx/ftx_lang.pas index eb6af9a4a..ac5864497 100644 --- a/library/ftx/ftx_lang.pas +++ b/library/ftx/ftx_lang.pas @@ -301,32 +301,34 @@ function TIETFLanguageCodeServices.filterLocate(ctxt : TCodeSystemProviderFilter cc : TIETFLanguageCodeConcept; filter : TIETFLanguageCodeFilter; ok : boolean; + l : TIETFLang; begin result := nil; - cc := TIETFLanguageCodeConcept.Create(FLanguages.parse(code, message)); - try - filter := TIETFLanguageCodeFilter(ctxt); - ok := false; - if cc <> nil then - begin + l := FLanguages.parse(code, message); + if (l <> nil) then + begin + try + filter := TIETFLanguageCodeFilter(ctxt); case filter.component of - languageComponentLang: ok := filter.status = (cc.FInfo.language <> ''); - languageComponentExtLang: ok := filter.status = (length(cc.FInfo.extLang) > 0); - languageComponentScript: ok := filter.status = (cc.FInfo.script <> ''); - languageComponentRegion: ok := filter.status = (cc.FInfo.region <> ''); - languageComponentVariant: ok := filter.status = (cc.FInfo.variant <> ''); - languageComponentExtension: ok := filter.status = (cc.FInfo.extension <> ''); - languageComponentPrivateUse: ok := filter.status = (length(cc.FInfo.privateUse) > 0); + languageComponentLang: ok := filter.status = (l.language <> ''); + languageComponentExtLang: ok := filter.status = (length(l.extLang) > 0); + languageComponentScript: ok := filter.status = (l.script <> ''); + languageComponentRegion: ok := filter.status = (l.region <> ''); + languageComponentVariant: ok := filter.status = (l.variant <> ''); + languageComponentExtension: ok := filter.status = (l.extension <> ''); + languageComponentPrivateUse: ok := filter.status = (length(l.privateUse) > 0); + else + ok := false; end; + if ok then + result := TIETFLanguageCodeConcept.Create(l.link) + else if filter.status then + message := 'The language code '+code+' does not contain a '+CODES_TIETFLanguageComponent[filter.component]+', and it is required to' + else + message := 'The language code '+code+' contains a '+CODES_TIETFLanguageComponent[filter.component]+', and it is not allowed to'; + finally + l.free; end; - if ok then - result := cc.Link - else if filter.status then - message := 'The language code '+code+' does not contain a '+CODES_TIETFLanguageComponent[filter.component]+', and it is required to' - else - message := 'The language code '+code+' contains a '+CODES_TIETFLanguageComponent[filter.component]+', and it is not allowed to'; - finally - cc.free; end; end; diff --git a/packages/fhir.pas b/packages/fhir.pas index 0a6426912..4c77585cd 100644 --- a/packages/fhir.pas +++ b/packages/fhir.pas @@ -1,41 +1,41 @@ -{ This file was automatically created by Lazarus. Do not edit! - This source is only used to compile and install the package. - } - -unit fhir; - -{$warn 5023 off : no warning about unused units} -interface - -uses - fhir_cdshooks, fhir_client, fhir_client_async, fhir_client_debugger, - fhir_client_http, fhir_client_registry, fhir_client_threaded, fhir_codegen, - fhir_common, fhir_consentengine, fhir_diff, fhir_elementmodel, fhir_factory, - fhir_graphdefinition, fhir_graphql, fhir_indexing, fhir_narrative, - fhir_ndjson, fhir_oauth, fhir_objects, fhir_oids, fhir_parser, - fhir_pathengine, fhir_utilities, fhir_validator, fhir_xhtml, cda_base, - cda_documents, cda_javascript, cda_narrative, cda_objects, cda_parser, - cda_types, cda_writer, fhir_codesystem_service, fhir_valuesets, - ftx_loinc_importer, ftx_loinc_publisher, ftx_loinc_services, ftx_ndc, - ftx_sct_analysis, ftx_sct_combiner, ftx_sct_expressions, ftx_sct_importer, - ftx_sct_publisher, ftx_sct_services, ftx_service, ftx_ucum_base, - ftx_ucum_expressions, ftx_ucum_handlers, ftx_ucum_search, ftx_ucum_services, - ftx_ucum_validators, v2_base, v2_conformance, v2_dictionary, - v2_dictionary_compiled, v2_dictionary_database, v2_dictionary_v21, - v2_dictionary_v22, v2_dictionary_v23, v2_dictionary_v24, v2_dictionary_v25, - v2_dictionary_v26, v2_dictionary_v27, v2_dictionary_v231, - v2_dictionary_v251, v2_dictionary_versions, v2_message, v2_objects, - v2_protocol, dicom_dictionary, dicom_jpegls, dicom_objects, dicom_parser, - dicom_writer, ftx_lang, fhir_healthcard, fhir_context, fhir_icao, - fhir_qrcode, qrcodegen, fhir_colour_utils, fhir_package_upload, - fhir_tools_settings, fhir_extensions, LazarusPackageIntf; - -implementation - -procedure Register; -begin -end; - -initialization - RegisterPackage('fhir', @Register); -end. +{ This file was automatically created by Lazarus. Do not edit! + This source is only used to compile and install the package. + } + +unit fhir; + +{$warn 5023 off : no warning about unused units} +interface + +uses + fhir_cdshooks, fhir_client, fhir_client_async, fhir_client_debugger, + fhir_client_http, fhir_client_registry, fhir_client_threaded, fhir_codegen, + fhir_common, fhir_consentengine, fhir_diff, fhir_elementmodel, fhir_factory, + fhir_graphdefinition, fhir_graphql, fhir_indexing, fhir_narrative, + fhir_ndjson, fhir_oauth, fhir_objects, fhir_oids, fhir_parser, + fhir_pathengine, fhir_utilities, fhir_validator, fhir_xhtml, cda_base, + cda_documents, cda_javascript, cda_narrative, cda_objects, cda_parser, + cda_types, cda_writer, fhir_codesystem_service, fhir_valuesets, + ftx_loinc_importer, ftx_loinc_publisher, ftx_loinc_services, ftx_ndc, + ftx_sct_analysis, ftx_sct_combiner, ftx_sct_expressions, ftx_sct_importer, + ftx_sct_publisher, ftx_sct_services, ftx_service, ftx_ucum_base, + ftx_ucum_expressions, ftx_ucum_handlers, ftx_ucum_search, ftx_ucum_services, + ftx_ucum_validators, v2_base, v2_conformance, v2_dictionary, + v2_dictionary_compiled, v2_dictionary_database, v2_dictionary_v21, + v2_dictionary_v22, v2_dictionary_v23, v2_dictionary_v24, v2_dictionary_v25, + v2_dictionary_v26, v2_dictionary_v27, v2_dictionary_v231, + v2_dictionary_v251, v2_dictionary_versions, v2_message, v2_objects, + v2_protocol, dicom_dictionary, dicom_jpegls, dicom_objects, dicom_parser, + dicom_writer, ftx_lang, fhir_healthcard, fhir_context, fhir_icao, + fhir_qrcode, qrcodegen, fhir_colour_utils, fhir_package_upload, + fhir_tools_settings, fhir_extensions, LazarusPackageIntf; + +implementation + +procedure Register; +begin +end; + +initialization + RegisterPackage('fhir', @Register); +end. diff --git a/packages/fhir4.pas b/packages/fhir4.pas index 948c26cc6..365a66a04 100644 --- a/packages/fhir4.pas +++ b/packages/fhir4.pas @@ -1,31 +1,31 @@ -{ This file was automatically created by Lazarus. Do not edit! - This source is only used to compile and install the package. - } - -unit fhir4; - -{$warn 5023 off : no warning about unused units} -interface - -uses - fhir4_adaptor, fhir4_authmap, fhir4_base, fhir4_client, fhir4_common, - fhir4_constants, fhir4_context, fhir4_elementmodel, fhir4_factory, - fhir4_graphdefinition, fhir4_indexinfo, fhir4_json, fhir4_liquid, - fhir4_maputils, fhir4_opbase, fhir4_operations, fhir4_organiser, - fhir4_parser, fhir4_parserbase, fhir4_patch, fhir4_pathengine, - fhir4_pathnode, fhir4_profiles, fhir4_resources, fhir4_resources_admin, - fhir4_resources_base, fhir4_resources_canonical, fhir4_resources_clinical, - fhir4_resources_financial, fhir4_resources_medications, - fhir4_resources_other, fhir4_tags, fhir4_turtle, fhir4_types, - fhir4_utilities, fhir4_xml, fhir4_questionnaire, fhir4_ips, - LazarusPackageIntf; - -implementation - -procedure Register; -begin -end; - -initialization - RegisterPackage('fhir4', @Register); -end. +{ This file was automatically created by Lazarus. Do not edit! + This source is only used to compile and install the package. + } + +unit fhir4; + +{$warn 5023 off : no warning about unused units} +interface + +uses + fhir4_adaptor, fhir4_authmap, fhir4_base, fhir4_client, fhir4_common, + fhir4_constants, fhir4_context, fhir4_elementmodel, fhir4_factory, + fhir4_graphdefinition, fhir4_indexinfo, fhir4_json, fhir4_liquid, + fhir4_maputils, fhir4_opbase, fhir4_operations, fhir4_organiser, + fhir4_parser, fhir4_parserbase, fhir4_patch, fhir4_pathengine, + fhir4_pathnode, fhir4_profiles, fhir4_resources, fhir4_resources_admin, + fhir4_resources_base, fhir4_resources_canonical, fhir4_resources_clinical, + fhir4_resources_financial, fhir4_resources_medications, + fhir4_resources_other, fhir4_tags, fhir4_turtle, fhir4_types, + fhir4_utilities, fhir4_xml, fhir4_questionnaire, fhir4_ips, + LazarusPackageIntf; + +implementation + +procedure Register; +begin +end; + +initialization + RegisterPackage('fhir4', @Register); +end. diff --git a/packages/fhir_fdb.pas b/packages/fhir_fdb.pas index 76f30f7bb..4cd47a6e0 100644 --- a/packages/fhir_fdb.pas +++ b/packages/fhir_fdb.pas @@ -1,24 +1,24 @@ -{ This file was automatically created by Lazarus. Do not edit! - This source is only used to compile and install the package. - } - -unit fhir_fdb; - -{$warn 5023 off : no warning about unused units} -interface - -uses - fdb_dialects, fdb_fpc, fdb_logging, fdb_manager, fdb_odbc_headers, - fdb_odbc_objects, fdb_odbc, fdb_settings, fdb_sqlite3_objects, - fdb_sqlite3_utilities, fdb_sqlite3_wrapper, fdb_sqlite3, fdb_fts, - LazarusPackageIntf; - -implementation - -procedure Register; -begin -end; - -initialization - RegisterPackage('fhir_fdb', @Register); -end. +{ This file was automatically created by Lazarus. Do not edit! + This source is only used to compile and install the package. + } + +unit fhir_fdb; + +{$warn 5023 off : no warning about unused units} +interface + +uses + fdb_dialects, fdb_fpc, fdb_logging, fdb_manager, fdb_odbc_headers, + fdb_odbc_objects, fdb_odbc, fdb_settings, fdb_sqlite3_objects, + fdb_sqlite3_utilities, fdb_sqlite3_wrapper, fdb_sqlite3, fdb_fts, + LazarusPackageIntf; + +implementation + +procedure Register; +begin +end; + +initialization + RegisterPackage('fhir_fdb', @Register); +end. diff --git a/packages/fhir_fsl.pas b/packages/fhir_fsl.pas index d89c056cc..5b2594662 100644 --- a/packages/fhir_fsl.pas +++ b/packages/fhir_fsl.pas @@ -1,26 +1,26 @@ -{ This file was automatically created by Lazarus. Do not edit! - This source is only used to compile and install the package. - } - -unit fhir_fsl; - -{$warn 5023 off : no warning about unused units} -interface - -uses - fsl_base, fsl_collections, fsl_comparisons, fsl_fpc, fsl_graphql, fsl_html, - fsl_http, fsl_json, fsl_lang, fsl_logging, fsl_npm, fsl_rdf, fsl_scim, - fsl_scrypt, fsl_service, fsl_service_win, fsl_shell, fsl_stream, - fsl_threads, fsl_turtle, fsl_utilities, fsl_xml, fsl_ucum, fsl_htmlgen, - fsl_diff, fsl_unicode, fsl_versions, fsl_i18n, fsl_fpc_memory, fsl_regex, - fsl_gzip, fsl_cpu, LazarusPackageIntf; - -implementation - -procedure Register; -begin -end; - -initialization - RegisterPackage('fhir_fsl', @Register); -end. +{ This file was automatically created by Lazarus. Do not edit! + This source is only used to compile and install the package. + } + +unit fhir_fsl; + +{$warn 5023 off : no warning about unused units} +interface + +uses + fsl_base, fsl_collections, fsl_comparisons, fsl_fpc, fsl_graphql, fsl_html, + fsl_http, fsl_json, fsl_lang, fsl_logging, fsl_npm, fsl_rdf, fsl_scim, + fsl_scrypt, fsl_service, fsl_service_win, fsl_shell, fsl_stream, + fsl_threads, fsl_turtle, fsl_utilities, fsl_xml, fsl_ucum, fsl_htmlgen, + fsl_diff, fsl_unicode, fsl_versions, fsl_i18n, fsl_fpc_memory, fsl_regex, + fsl_gzip, fsl_cpu, LazarusPackageIntf; + +implementation + +procedure Register; +begin +end; + +initialization + RegisterPackage('fhir_fsl', @Register); +end. diff --git a/server/endpoint_xig.pas b/server/endpoint_xig.pas index 093557535..4d724a51f 100644 --- a/server/endpoint_xig.pas +++ b/server/endpoint_xig.pas @@ -1,1560 +1,1560 @@ -unit endpoint_xig; - -{ -Copyright (c) 2001-2021, Health Intersections Pty Ltd (http://www.healthintersections.com.au) -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, -are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of HL7 nor the names of its contributors may be used to - endorse or promote products derived from this software without specific - prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. -IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, -INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. -} - -{$i fhir.inc} - -interface - -uses - SysUtils, Classes, {$IFDEF FPC} ZStream, {$ENDIF} - IdContext, IdCustomHTTPServer, IdOpenSSLX509, - fsl_base, fsl_utilities, fsl_json, fsl_i18n, fsl_http, fsl_html, fsl_fetcher, fsl_logging, fsl_threads, - fhir_objects, fhir_xhtml, - fdb_manager, fdb_sqlite3, - utilities, server_config, tx_manager, time_tracker, kernel_thread, - web_base, endpoint, server_stats; - -type - TContentMode = (cmAll, cmCodeSystem, cmResProfile, cmDTProfile, cmLogical, cmExtensions, cmValueSet, cmConceptMap); - - - { TPackageInformation } - - TPackageInformation = class (TFslObject) - private - FCanonical: String; - FId: String; - Fkey: String; - FVid: String; - FWeb: String; - public - constructor create(key, id, vid, web, canonical : String); - - function link : TPackageInformation; overload; - - property key : String read Fkey write FKey; - property id : String read FId write FId; - property vid : String read FVid write FVid; - property web : String read FWeb write FWeb; - property canonical : String read FCanonical write FCanonical; - end; - - { TFHIRXIGWebContext } - - TFHIRXIGWebContext = class (TFslObject) - private - FMetadata : TFslStringDictionary; - FVersions : TStringList; - FRealms : TStringList; - FAuthorities : TStringList; - FTypes : TStringList; - FDatabase : TFDBManager; - FPackages : TFslMap; - FPackagesById : TFslMap; - FResourceTypes : TStringList; - FProfileResources : TStringList; - FProfileTypes : TStringList; - FExtensionContexts : TStringList; - FExtensionTypes : TStringList; - FTerminologySources : TStringList; - FDate : String; - - procedure loadFromDB; - - function authBar(url, realm, auth, ver, rtype, rt, text: String): String; - function realmBar(url, realm, auth, ver, rtype, rt, text: String): String; - function typeBar(url, realm, auth, ver, rtype, rt, text: String): String; - function versionBar(url, realm, auth, ver, rtype, rt, text: String): String; - function makeSelect(rt : String; list : TStringList) : String; - function hasTerminologySource(s : String): boolean; - public - constructor create(db : TFDBManager); - destructor Destroy; override; - function link : TFHIRXIGWebContext; overload; - end; - - { TFHIRXIGWebServer } - - TFHIRXIGWebServer = class (TFhirWebServerEndpoint) - private - FLock : TFslLock; - FContext : TFHIRXIGWebContext; - - function adjustLinks(x : TFhirXHtmlNode; base : String) : String; - function fixNarrative(src, base: String): String; - - procedure renderExtension(b : TFslStringBuilder; details : String); - function extLink(url : String) : String; - - function contentAll(context : TFHIRXIGWebContext; mode : TContentMode; secure: boolean; realm, auth, ver, rt, text, offset: String): String; - function contentRes(context : TFHIRXIGWebContext; pid, rtype, id : String; secure : boolean) : String; - - function getContext : TFHIRXIGWebContext; - procedure sendViewHtml(request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; secure : boolean; rtype, auth, realm, ver, rt, text, offset : String); - procedure sendResourceHtml(request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; secure : boolean; pid, rtype, id : String); - function doRequest(AContext: TIdContext; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; id: String; secure: boolean): String; - public - Constructor Create(code, path : String; common : TFHIRWebServerCommon); override; - destructor Destroy; override; - function link : TFHIRXIGWebServer; overload; - function description : String; override; - - function PlainRequest(AContext: TIdContext; ip : String; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; id : String; tt : TTimeTracker) : String; override; - function SecureRequest(AContext: TIdContext; ip : String; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; cert : TIdOpenSSLX509; id : String; tt : TTimeTracker) : String; override; - function logId : string; override; - end; - - { TXIGServerEndPoint } - - TXIGServerEndPoint = class (TFHIRServerEndPoint) - private - FXIGServer : TFHIRXIGWebServer; - FLastCheck : TDateTime; - FLastDownload : String; - procedure loadFromDB; - function downloadTimestampFile : String; - procedure downloadAndReload; - function dateBuilt : String; - public - constructor Create(config : TFHIRServerConfigSection; settings : TFHIRServerSettings; common : TCommonTerminologies; i18n : TI18nSupport); - destructor Destroy; override; - - function summary : String; override; - function makeWebEndPoint(common : TFHIRWebServerCommon) : TFhirWebServerEndpoint; override; - procedure InstallDatabase(params : TCommandLineParameters); override; - procedure UninstallDatabase; override; - procedure LoadPackages(installer : boolean; plist : String); override; - procedure updateAdminPassword(pw : String); override; - procedure Load; override; - Procedure Unload; override; - procedure internalThread(callback : TFhirServerMaintenanceThreadTaskCallBack); override; - function cacheSize(magic : integer) : UInt64; override; - procedure clearCache; override; - procedure SweepCaches; override; - procedure SetCacheStatus(status : boolean); override; - procedure getCacheInfo(ci: TCacheInformation); override; - procedure recordStats(rec : TStatusRecord); override; - end; - -implementation - -{ TFHIRXIGWebContext } - -constructor TFHIRXIGWebContext.create(db: TFDBManager); -begin - inherited create; - - FVersions := TStringList.create; - FRealms := TStringList.create; - FAuthorities := TStringList.create; - FTypes := TStringList.create; - FPackages := TFslMap.create; - FPackagesById := TFslMap.create; - FPackagesById.defaultValue := nil; - FProfileResources := TStringList.create; - FProfileTypes := TStringList.create; - FResourceTypes := TStringList.create; - FExtensionContexts := TStringList.create; - FExtensionTypes := TStringList.create; - FTerminologySources := TStringList.create; - FMetadata := TFslStringDictionary.create; - - FDatabase := db; - loadFromDB; -end; - -destructor TFHIRXIGWebContext.Destroy; -begin - FMetadata.free; - FPackagesById.free; - FExtensionContexts.free; - FExtensionTypes.free; - FTerminologySources.free; - FResourceTypes.free; - FProfileResources.Free; - FProfileTypes.Free; - FPackages.Free; - FDatabase.Free; - FVersions.Free; - FRealms.Free; - FAuthorities.Free; - FTypes.Free; - - inherited Destroy; -end; - - -procedure TFHIRXIGWebContext.loadFromDB; -var - conn : TFDBConnection; - pck : TPackageInformation; -begin - conn := FDatabase.GetConnection('Load'); - try - conn.SQL := 'select Name, Value from Metadata'; - conn.Prepare; - conn.Execute; - while conn.FetchNext do - FMetadata.addOrSetValue(conn.ColStringByName['Name'], conn.ColStringByName['Value']); - conn.terminate; - FDate := FMetadata['date']; - - conn.SQL := 'select Code from realms'; - conn.Prepare; - conn.Execute; - while conn.FetchNext do - FRealms.add(conn.ColStringByName['Code']); - conn.terminate; - FRealms.Sort; - - conn.SQL := 'select Code from Authorities'; - conn.Prepare; - conn.Execute; - while conn.FetchNext do - FAuthorities.add(conn.ColStringByName['Code']); - conn.terminate; - FAuthorities.sort; - - conn.SQL := 'select PackageKey, Id, PID, Web, Canonical from Packages'; - conn.Prepare; - conn.Execute; - while conn.FetchNext do - begin - pck := TPackageInformation.create(conn.ColStringByName['PackageKey'], conn.ColStringByName['Id'], conn.ColStringByName['PID'].replace('#', '|'), conn.ColStringByName['Web'], conn.ColStringByName['Canonical']); - try - FPackages.add(pck.key, pck.link); - FPackagesById.addOrSetValue(pck.vid, pck.link); - finally - pck.free; - end; - end; - conn.terminate; - FAuthorities.sort; - - conn.SQL := 'Select distinct type from Resources where ResourceType = ''StructureDefinition'' and Kind = ''resource'''; - conn.Prepare; - conn.Execute; - while conn.FetchNext do - if conn.ColStringByName['Type'] <> '' then - FProfileResources.add(conn.ColStringByName['Type']); - conn.terminate; - FProfileResources.Sort; - - conn.SQL := 'Select distinct type from Resources where ResourceType = ''StructureDefinition'' and (Kind = ''complex-type'' or Kind = ''primitive-type'')'; - conn.Prepare; - conn.Execute; - while conn.FetchNext do - if (conn.ColStringByName['Type'] <> 'Extension') and (conn.ColStringByName['Type'] <> '') then - FProfileTypes.add(conn.ColStringByName['Type']); - conn.terminate; - FProfileTypes.Sort; - - conn.SQL := 'Select distinct ResourceType from Resources'; - conn.Prepare; - conn.Execute; - while conn.FetchNext do - if (conn.ColStringByName['ResourceType'] <> '') and (conn.ColStringByName['ResourceType'] <> 'StructureDefinition') and (conn.ColStringByName['ResourceType'] <> 'CodeSystem') and - (conn.ColStringByName['ResourceType'] <> 'ValueSet') and (conn.ColStringByName['ResourceType'] <> 'ConceptMap') then - FResourceTypes.add(conn.ColStringByName['ResourceType']); - conn.terminate; - FResourceTypes.Sort; - - conn.SQL := 'Select distinct Code from Categories where mode = 2'; - conn.Prepare; - conn.Execute; - while conn.FetchNext do - if (conn.ColStringByName['Code'] <> '') then - FExtensionContexts.add(conn.ColStringByName['Code']); - conn.terminate; - FExtensionContexts.Sort; - - conn.SQL := 'Select distinct Code from Categories where mode = 3'; - conn.Prepare; - conn.Execute; - while conn.FetchNext do - if (conn.ColStringByName['Code'] <> '') then - FExtensionTypes.add(conn.ColStringByName['Code']); - conn.terminate; - FExtensionTypes.Sort; - - conn.SQL := 'Select Code, Display from TxSource'; - conn.Prepare; - conn.Execute; - while conn.FetchNext do - if (conn.ColStringByName['Code'] <> '') then - FTerminologySources.add(conn.ColStringByName['Code']+'='+conn.ColStringByName['Display']); - conn.terminate; - FTerminologySources.Sort; - - - FVersions.Add('R2'); - FVersions.Add('R2B'); - FVersions.Add('R3'); - FVersions.Add('R4'); - FVersions.Add('R4B'); - FVersions.Add('R5'); - FVersions.Add('R6'); - - FTypes.add('rp=Resource Profiles'); - FTypes.add('dp=Datatype Profiles'); - FTypes.add('ext=Extensions'); - FTypes.add('lm=Logical Models'); - FTypes.add('cs=CodeSystems'); - FTypes.add('vs=ValueSets'); - FTypes.add('cm=ConceptMaps'); - - conn.release; - except - on e : Exception do - conn.Error(e); - end; -end; - -function TFHIRXIGWebContext.link: TFHIRXIGWebContext; -begin - result := TFHIRXIGWebContext(inherited Link); -end; - -function TFHIRXIGWebContext.realmBar(url, realm, auth, ver, rtype, rt, text : String) : String; -var - p, s : String; -begin - p := url+'/?'; - if (rtype <> '') then - p := p+'&type='+rtype; - if (auth <> '') then - p := p+'&auth='+auth; - if (ver <> '') then - p := p+'&ver='+ver; - if (rt <> '') then - p := p + '&rt='+rt; - if (text <> '') then - p := p + '&text='+encodePercent(text); - if realm = '' then - result := 'All' - else - result := 'All'; - for s in FRealms do - if (s = realm) then - result := result + ' | '+s+'' - else - result := result + ' | '+s+''; -end; - -function TFHIRXIGWebContext.authBar(url, realm, auth, ver, rtype, rt, text : String) : String; -var - p, s : String; -begin - p := url+'/?'; - if (rtype <> '') then - p := p+'&type='+rtype; - if (realm <> '') then - p := p+'&realm='+realm; - if (ver <> '') then - p := p+'&ver='+ver; - if (rt <> '') then - p := p + '&rt='+rt; - if (text <> '') then - p := p + '&text='+encodePercent(text); - if auth = '' then - result := 'All' - else - result := 'All'; - for s in FAuthorities do - if (s = auth) then - result := result + ' | '+s+'' - else - result := result + ' | '+s+''; -end; - -function TFHIRXIGWebContext.versionBar(url, realm, auth, ver, rtype, rt, text : String) : String; -var - p, s : String; -begin - p := url+'/?'; - if (rtype <> '') then - p := p+'&type='+rtype; - if (realm <> '') then - p := p+'&realm='+realm; - if (auth <> '') then - p := p+'&auth='+auth; - if (rt <> '') then - p := p + '&rt='+rt; - if (text <> '') then - p := p + '&text='+encodePercent(text); - if ver = '' then - result := 'All' - else - result := 'All'; - for s in FVersions do - if (s = ver) then - result := result + ' | '+s+'' - else - result := result + ' | '+s+''; -end; - -function TFHIRXIGWebContext.typeBar(url, realm, auth, ver, rtype, rt, text : String) : String; -var - p, s, n, v : String; -begin - p := url+'/?'; - if (ver <> '') then - p := p+'&ver='+ver; - if (realm <> '') then - p := p+'&realm='+realm; - if (auth <> '') then - p := p+'&auth='+auth; - if (rt <> '') then - p := p + '&rt='+rt; - if (text <> '') then - p := p + '&text='+encodePercent(text); - if rtype = '' then - result := 'All' - else - result := 'All'; - for s in FTypes do - begin - StringSplit(s, '=', n, v); - if (n = rtype) then - result := result + ' | '+v+'' - else - result := result + ' | '+v+''; - end; -end; - -function showVersion(db : TFDBConnection) : String; -begin - result := ''; - if (db.ColIntegerByName['R2'] = 1) then - CommaAdd(result, 'R2'); - if (db.ColIntegerByName['R2B'] = 1) then - CommaAdd(result, 'R2B'); - if (db.ColIntegerByName['R3'] = 1) then - CommaAdd(result, 'R3'); - if (db.ColIntegerByName['R4'] = 1) then - CommaAdd(result, 'R4'); - if (db.ColIntegerByName['R4B'] = 1) then - CommaAdd(result, 'R4B'); - if (db.ColIntegerByName['R5'] = 1) then - CommaAdd(result, 'R5'); - if (db.ColIntegerByName['R6'] = 1) then - CommaAdd(result, 'R6'); -end; - -function TFHIRXIGWebContext.makeSelect(rt : String; list : TStringList) : String; -var - b : TFslStringBuilder; - s : String; - procedure add(t : String); - var - n, v :String; - begin - if t.contains('=') then - StringSplit(t, '=', n, v) - else - begin - n := t; - v := t; - end; - if (rt = n) then - b.append('') - else - b.append('') - end; -begin - b := TFslStringBuilder.create; - try - b.append(''); - result := b.asString; - finally - b.free; - end; -end; - -function TFHIRXIGWebContext.hasTerminologySource(s: String): boolean; -var - t : String; -begin - result := false; - for t in FTerminologySources do - if (t.startsWith(s+'=')) then - exit(true); -end; - - -{ TPackageInformation } - -constructor TPackageInformation.create(key, id, vid, web, canonical: String); -begin - inherited create; - FKey := key; - FId := id; - FVid := vid; - FWeb := web; - if canonical = '' then - FCanonical := '!!!' - else - FCanonical := canonical+'/'; -end; - -function TPackageInformation.link: TPackageInformation; -begin - result := TPackageInformation(inherited Link); -end; - -{ TXIGServerEndPoint } - -constructor TXIGServerEndPoint.Create(config : TFHIRServerConfigSection; settings : TFHIRServerSettings; common : TCommonTerminologies; i18n : TI18nSupport); -begin - inherited Create(config, settings, nil, common, nil, i18n); -end; - -destructor TXIGServerEndPoint.Destroy; -begin - FXIGServer.free; - - inherited; -end; - -function TXIGServerEndPoint.cacheSize(magic : integer): UInt64; -begin - result := inherited cacheSize(magic); -end; - -procedure TXIGServerEndPoint.clearCache; -begin - inherited; -end; - -procedure TXIGServerEndPoint.SweepCaches; -begin - inherited SweepCaches; -end; - -procedure TXIGServerEndPoint.getCacheInfo(ci: TCacheInformation); -begin - inherited; -end; - -procedure TXIGServerEndPoint.recordStats(rec: TStatusRecord); -begin - inherited recordStats(rec); -// rec. -end; - -procedure TXIGServerEndPoint.loadFromDB; -begin - FXIGServer.FContext := TFHIRXIGWebContext.create(Database); -end; - -function TXIGServerEndPoint.downloadTimestampFile: String; -var - url : String; -begin - url := Config.prop['db-source'].value.replace('xig.db', 'timestamp.txt'); - result := TInternetFetcher.fetchUrlString(url).trim(); -end; - -procedure TXIGServerEndPoint.downloadAndReload; -var - src, tgt : String; - fetcher : TInternetFetcher; - start : TDateTime; - xig, oxig : TFHIRXIGWebContext; -begin - src := Config.prop['db-source'].value; - tgt := Config.prop['db-file'].value.replace('.db', '-'+FLastDownload+'.db'); - - if (FileExists(tgt)) then - deleteFile(tgt); - Logging.log('Download new XIG from '+src); - try - start := now; - fetcher := TInternetFetcher.Create; - try - fetcher.URL := src; - fetcher.Fetch; - fetcher.Buffer.SaveToFileName(tgt); - Logging.Log('Finished Downloading ('+DescribeBytes(fetcher.buffer.size)+', '+DescribePeriod(now - start)+'). reload'); - finally - fetcher.free; - end; - except - on e : Exception do - begin - Logging.finish(' '+e.Message); - raise; - end; - end; - xig := TFHIRXIGWebContext.Create(TFDBSQLiteManager.create('xig-'+FLastDownload, tgt, true, false)); - try - FXIGServer.FLock.lock; - try - oxig := FXIGServer.FContext; - FXIGServer.FContext := xig.link; - finally - FXIGServer.FLock.unlock; - end; - finally - xig.free; - end; - Logging.Log('Reloaded XIG from '+tgt); - tgt := (oxig.FDatabase as TFDBSQLiteManager).FileName; - oxig.free; - DeleteFile(tgt); -end; - -function TXIGServerEndPoint.dateBuilt: String; -begin - if (FXIGServer = nil) or (FXIGServer.FContext = nil) then - result := '???xig' - else - result := FXIGServer.FContext.FDate; -end; - -procedure TXIGServerEndPoint.Unload; -begin -end; - -procedure TXIGServerEndPoint.InstallDatabase(params: TCommandLineParameters); -begin -end; - -procedure TXIGServerEndPoint.UninstallDatabase; -begin -end; - -procedure TXIGServerEndPoint.internalThread(callback: TFhirServerMaintenanceThreadTaskCallBack); -var - dt : TDateTime; - s : String; -begin - dt := trunc(now); - if (dt > FLastCheck) then - begin - s := downloadTimestampFile; - if (s <> FLastDownload) then - begin - FLastDownload := s; - downloadAndReload(); - end; - FLastCheck := dt; - end; -end; - -procedure TXIGServerEndPoint.LoadPackages(installer : boolean; plist: String); -begin - raise EFslException.Create('This is not applicable to this endpoint'); -end; - -function TXIGServerEndPoint.makeWebEndPoint(common: TFHIRWebServerCommon): TFhirWebServerEndpoint; -var - json : TJsonObject; -begin - inherited makeWebEndPoint(common); - FXIGServer := TFHIRXIGWebServer.Create(config.name, config['path'].value, common); - (FXIGServer as TFHIRXIGWebServer).FContext := TFHIRXIGWebContext.create(Database.link); - WebEndPoint := FXIGServer; - result := FXIGServer.link; -end; - -procedure TXIGServerEndPoint.SetCacheStatus(status: boolean); -begin - inherited; -end; - -function TXIGServerEndPoint.summary: String; -begin - result := 'XIG Server based on database built '+dateBuilt(); -end; - -procedure TXIGServerEndPoint.updateAdminPassword(pw: String); -begin - raise EFslException.Create('This is not applicable to this endpoint'); -end; - -procedure TXIGServerEndPoint.Load; -begin - inherited Load; -end; - -{ TFHIRXIGWebServer } - -constructor TFHIRXIGWebServer.Create(code, path: String; common: TFHIRWebServerCommon); -begin - inherited Create(code, path, common); - FLock := TFslLock.create('xig-server'); -end; - -destructor TFHIRXIGWebServer.Destroy; -begin - FContext.Free; - FLock.free; - inherited; -end; - -function TFHIRXIGWebServer.description: String; -begin - result := 'XIG Server based on database built '+FContext.FDate; -end; - -function TFHIRXIGWebServer.contentAll(context : TFHIRXIGWebContext; mode : TContentMode; secure: boolean; realm, auth, ver, rt, text, offset: String): String; -var - db : TFDBConnection; - b : TFslStringBuilder; - filter, s, p, tt, id : String; - count, c, offs : integer; - pck : TPackageInformation; -begin - p := AbsoluteURL(secure)+'/?'; - if (ver <> '') then - p := p+'&ver='+ver; - if (realm <> '') then - p := p+'&realm='+realm; - if (auth <> '') then - p := p+'&auth='+auth; - if (text <> '') then - p := p+'&text='+EncodePercent(text); - if (rt <> '') then - p := p+'&rt='+rt; - case mode of - cmCodeSystem: p := p+'&type=cs'; - cmResProfile: p := p+'&type=rp'; - cmDTProfile: p := p+'&type=dp'; - cmLogical: p := p+'&type=lm'; - cmExtensions : p := p + '&type=ext'; - cmValueSet : p := p + '&type=vs'; - cmConceptMap : p := p + '&type=cm'; - end; - - b := TFslStringBuilder.create; - try - case mode of - cmCodeSystem : b.append('

CodeSystems'); - cmResProfile : b.append('

Resource Profiles'); - cmDTProfile : b.append('

Datatype Profiles'); - cmLogical : b.append('

Logical models'); - cmExtensions : b.append('

Extensions'); - cmValueSet :b.append('

ValueSets'); - cmConceptMap :b.append('

ConceptMaps'); - else if rt <> '' then - b.append('

Resources - '+rt) - else - b.append('

Resources - All Kinds'); - end; - - if (realm <> '') then - b.append(', Realm '+realm.ToUpper); - if (auth <> '') then - b.append(', Authority '+capitalise(auth)); - if ver <> '' then - b.append(', Version '+ver); - b.append('

'); - filter := ''; - if (realm <> '') then - filter := filter + ' and realm = '''+sqlWrapString(realm)+''''; - if (auth <> '') then - filter := filter + ' and authority = '''+sqlWrapString(auth)+''''; - if ver = 'R2' then - filter := filter + ' and R2 = 1' - else if ver = 'R2B' then - filter := filter + ' and R2B = 1' - else if ver = 'R3' then - filter := filter + ' and R3 = 1' - else if ver = 'R4' then - filter := filter + ' and R4 = 1' - else if ver = 'R4B' then - filter := filter + ' and R4B = 1' - else if ver = 'R5' then - filter := filter + ' and R5 = 1' - else if ver = 'R6' then - filter := filter + ' and R6 = 1'; - case mode of - cmCodeSystem : filter := filter + ' and ResourceType = ''CodeSystem'''; - cmResProfile : - begin - filter := filter + ' and ResourceType = ''StructureDefinition'' and kind = ''resource'''; - if (rt <> '') and (context.FProfileResources.IndexOf(rt) > -1) then - filter := filter + ' and Type = '''+sqlWrapString(rt)+'''' - end; - cmDTProfile : - begin - filter := filter + ' and ResourceType = ''StructureDefinition'' and (kind = ''complex-type'' or kind = ''primitive-type'')'; - if (rt <> '') and (context.FProfileTypes.IndexOf(rt) > -1) then - filter := filter + ' and Type = '''+sqlWrapString(rt)+'''' - end; - cmLogical: filter := filter + ' and ResourceType = ''StructureDefinition'' and kind = ''logical'''; - cmExtensions : - begin - filter := filter + ' and ResourceType = ''StructureDefinition'' and (Type = ''Extension'')'; - if (rt <> '') and (context.FExtensionContexts.IndexOf(rt) > -1) then - filter := filter + ' and ResourceKey in (Select ResourceKey from Categories where Mode = 2 and Code = '''+sqlWrapString(rt)+''')' - end; - cmValueSet: - begin - filter := filter + ' and ResourceType = ''ValueSet'''; - if (rt <> '') and (context.hasTerminologySource(rt)) then - filter := filter + ' and ResourceKey in (Select ResourceKey from Categories where Mode = 1 and Code = '''+sqlWrapString(rt)+''')' - end; - cmConceptMap: - begin - filter := filter + ' and ResourceType = ''ConceptMap'''; - if (rt <> '') and (context.hasTerminologySource(rt)) then - filter := filter + ' and ResourceKey in (Select ResourceKey from Categories where Mode = 1 and Code = '''+sqlWrapString(rt)+''')' - end; - else - if (rt <> '') and (context.FResourceTypes.IndexOf(rt) > -1) then - filter := filter + ' and ResourceType = '''+sqlWrapString(rt)+'''' - else - ; // nothing - end; - - if text <> '' then - if mode = cmCodeSystem then - filter := filter + ' and (ResourceKey in (select ResourceKey from ResourceFTS where Description match '''+SQLWrapString(text)+''' or Narrative match '''+SQLWrapString(text)+''') '+ - 'or ResourceKey in (select ResourceKey from CodeSystemFTS where Display match '''+SQLWrapString(text)+''' or Definition match '''+SQLWrapString(text)+'''))' - else - filter := filter + ' and ResourceKey in (select ResourceKey from ResourceFTS where Description match '''+SQLWrapString(text)+''' or Narrative match '''+SQLWrapString(text)+''')'; - if filter <> '' then - filter := 'where '+filter.substring(4); - - db := context.FDatabase.GetConnection('content-all'); - try - b.append('

'); - count := db.CountSQL('select count(*) from Resources '+filter); - b.append(inttostr(count)); - b.append(' resources

'); - b.append('
'); - if (ver <> '') then - b.append(''); - if (realm <> '') then - b.append(''); - if (auth <> '') then - b.append(''); - case mode of - cmCodeSystem: b.append(''); - cmResProfile: - begin - b.append(''); - b.append('Type: '+context.makeSelect(rt, context.FProfileResources)+'
'); - end; - cmDTProfile: - begin - b.append(''); - b.append('Type: '+context.makeSelect(rt, context.FProfileTypes)+'
'); - end; - cmLogical: b.append(''); - cmExtensions: - begin - b.append(''); - b.append('Context: '+context.makeSelect(rt, context.FExtensionContexts)+'
'); - end; - cmValueSet: - begin - b.append(''); - b.append('Source: '+context.makeSelect(rt, context.FTerminologySources)+'
'); - end; - cmConceptMap: - begin - b.append(''); - b.append('Source: '+context.makeSelect(rt, context.FTerminologySources)+'
'); - end; - else - b.append('Type: '+context.makeSelect(rt, context.FResourceTypes)+'
'); - end; - b.append('Text: [%include xig-help.html%]
'); - b.append(''); - b.append('
'); - - //if (text = '') then - //begin - if ver = '' then - begin - b.append('

By Version

    '); - for s in context.FVersions do - begin - if filter = '' then - c := db.CountSQL('select count(*) from Resources where '+s+' = 1') - else - c := db.CountSQL('select count(*) from Resources '+filter+' and '+s+' = 1'); - b.append('
  • '); - b.append(''+s+': '+inttostr(c)); - b.append('
    • '); - end; - b.append('
'); - end; - - if auth = '' then - begin - db.sql := 'select Authority, count(*) from Resources '+filter+' group by Authority '; - db.prepare; - db.execute; - b.append('

By Authority

    '); - while db.FetchNext do - begin - b.append('
  • '); - if (db.ColString[1] = '') then - b.append('none: '+db.colString[2]) - else - b.append(''+db.ColString[1]+': '+db.colString[2]); - b.append('
    • '); - end; - db.terminate; - b.append('
'); - end; - - if realm = '' then - begin - db.sql := 'select realm, count(*) from Resources '+filter+' group by realm '; - db.prepare; - db.execute; - b.append('

By realm

    '); - while db.FetchNext do - begin - b.append('
  • '); - if (db.ColString[1] = '') then - b.append('none: '+db.colString[2]) - else - b.append(''+db.ColString[1]+': '+db.colString[2]); - b.append('
    • '); - end; - db.terminate; - b.append('
'); - end; - //end; - - offs := StrToIntDef(offset, 0); - if (count > 200) then - begin - b.append('

'); - if (offs > 200) then - b.append('Start '); - if (offs >= 200) then - b.append('Prev '); - b.append('Rows '+inttostr(offs)+' - '+inttostr(offs+200)+''); - b.append(' Next '); - end; - - if (count > 0) then - begin - b.append(''); - b.append(''); - - b.append(''); - if (ver = '') then - b.append(''); - b.append(''); - b.append(''); - b.append(''); - b.append(''); - if (realm = '') then - b.append(''); - if (auth = '') then - b.append(''); - case mode of - cmCodeSystem: b.append(''); - cmResProfile: if (rt = '') then b.append(''); - cmDTProfile: if (rt = '') then b.append(''); - cmExtensions: b.append(''); - cmValueSet : b.append(''); - cmConceptMap : b.append(''); - cmLogical: b.append(''); - end; - case mode of - cmCodeSystem: tt := 'CodeSystem/'; - cmResProfile: tt := 'StructureDefinition/'; - cmDTProfile: tt := 'StructureDefinition/'; - cmExtensions: tt := 'StructureDefinition/'; - cmValueSet : tt := 'ValueSet/'; - cmConceptMap : tt := 'ConceptMap/'; - cmLogical: tt := 'StructureDefinition/'; - else - tt := ''; - end; - - b.append(''); - if (text <> '') then - db.sql := 'Select PackageKey, ResourceType, Id, R2, R2B, R3, R4, R4B, R5, R6, Web, Url, Version, Status, Date, Name, Title, Realm, Authority, Content, Supplements, Type, Details from Resources '+filter+' LIMIT '+inttostr(offs)+', '+inttostr(offs+200)+'' - else - db.sql := 'Select PackageKey, ResourceType, Id, R2, R2B, R3, R4, R4B, R5, R6, Web, Url, Version, Status, Date, Name, Title, Realm, Authority, Content, Supplements, Type, Details from Resources '+filter+' LIMIT '+inttostr(offs)+', '+inttostr(offs+200)+''; - db.prepare; - db.execute; - while db.fetchnext do - begin - b.append(''); - pck := context.FPackages[db.ColStringByName['PackageKey']]; - if (pck.web <> '') then - b.append('') - else - b.append(''); - if (ver = '') then - b.append(''); - id := pck.vid+'/'+db.ColStringByName['ResourceType']+'/'+db.ColStringByName['Id']; - if db.ColStringByName['Url'] <> '' then - b.append('') - else - b.append(''); - if db.ColStringByName['Title'] <> '' then - b.append('') - else - b.append(''); - b.append(''); - b.append(''); - if (realm = '') then - b.append(''); - if (auth = '') then - b.append(''); - case mode of - cmCodeSystem: if db.ColStringByName['Supplements'] <> '' then - b.append('') - else - b.append(''); - cmResProfile : if (rt = '') then b.append(''); - cmDTProfile : if (rt = '') then b.append(''); - cmValueSet : b.append(''); - cmConceptMap : b.append(''); - cmLogical : b.append(''); - cmExtensions : renderExtension(b, db.ColStringByName['Details']); - end; - b.append(''); - end; - b.append('
PackageVersionIdentityName/TitleStatusDateRealmAuthContentResourceDataTypeContextModifierTypeSource(s)Source(s)Type
'+pck.id+''+pck.id+''+showVersion(db)+''+db.ColStringByName['Url'].replace(pck.canonical+tt, '')+extLink(db.ColStringByName['Web'])+''+(db.ColStringByName['ResourceType']+'/').replace(tt, '')+db.ColStringByName['Id']+extLink(db.ColStringByName['Web'])+''+db.ColStringByName['Title']+''+db.ColStringByName['Name']+''+db.ColStringByName['Status']+''+TFslDateTime.fromXML(db.ColStringByName['Date']).toString('yyyy-mm')+''+db.ColStringByName['Realm']+''+db.ColStringByName['Authority']+'Suppl: '+db.ColStringByName['Supplements']+''+db.ColStringByName['Content']+''+db.ColStringByName['Type']+''+db.ColStringByName['Type']+''+db.ColStringByName['Details'].replace(',', ' ')+''+db.ColStringByName['Details'].replace(',', ' ')+''+db.ColStringByName['Type'].replace(pck.canonical+'StructureDefinition/', '')+'
'); - end; - db.terminate; - db.release; - result := b.AsString; - except - on e : Exception do - begin - db.Error(e); - result := '

Error: '+FormatTextToHTML(e.message)+'

'; - end; - end; - finally - b.free; - end; -end; - -procedure TFHIRXIGWebServer.renderExtension(b : TFslStringBuilder; details : String); -var - p1, p2 : TArray; -begin - p1 := details.Split(['|']); - b.append(''+p1[0].subString(9).replace(',', ' ')+''); - if p1[2] = 'Mod:1' then - b.append('M') - else - b.append(''); - if (p1[1].Contains('Meta') and p1[1].Contains('uuid')) then - b.append('(all)') - else - b.append(''+p1[1].subString(5).replace(',', ' ')+''); -end; - -function TFHIRXIGWebServer.extLink(url: String): String; -begin - if (url = '') then - result := '' - else - result := ' '; -end; - -{$IFDEF FPC} -procedure DecompressStream(src, dst: TStream); -var - ds: TDecompressionStream; - d: dword; - buff: array[0..1023] of byte; -begin - ds := TDecompressionStream.Create(src, true); - try - repeat - d := ds.Read(buff, 1024); - dst.Write(buff, d); - until - d = 0; - finally - ds.Free; - end; -end; - -function inflate(source:TBytes):TBytes; -var - ss1, ss2: TStringStream; -begin - ss1 := TStringStream.Create; - try - ss1.write(source[0], length(source)); - ss1.Position := 10; //SKIP GZIP HEADER - - ss2 := TStringStream.Create; - try - DecompressStream(ss1, ss2); - ss2.Position := 0; - setLength(result, ss2.Size); - ss2.Read(result[0], length(result)); - finally - ss2.Free; - end; - finally - ss1.Free; - end; -end; -{$ENDIF} - -function fixLink(base, link : String) : String; -begin - if link.StartsWith('http:') or link.StartsWith('https:') or link.StartsWith('data:') then - result := link - else - result := URLPath([base, link]); -end; - -function fixStyleLink(base, style : String) : String; -var - i, j : integer; - s : String; -begin - result := ''; - i := 1; - while (i <= length(style)) do - if copy(style, i, 4) = 'url(' then - begin - j := i + 1; - while (j <= length(style)) and (style[j] <> ')') do - inc(j); - if j <= length(style) then - begin - s := copy(style, i+4, j-i-4); - if (s.StartsWith('http:') or s.StartsWith('https:') or s.StartsWith('data:')) then - result := result + 'url('+s+')' - else - result := result + 'url('+URLPath([base, s])+')' - end - else - result := result + copy(style, i, length(style)); - i := j + 1; - end - else - begin - result := result + style[i]; - inc(i); - end; -end; - -function TFHIRXIGWebServer.adjustLinks(x : TFhirXHtmlNode; base : String) : String; -var - c : TFhirXHtmlNode; - s : String; -begin - if (x.name = 'img') and x.HasAttribute('src') then - x.attribute('src', fixLink(base, x.attribute('src'))) - else if (x.name = 'a') and (x.HasAttribute('href')) then - x.attribute('href', fixLink(base, x.attribute('href'))); - - if (x.hasAttribute('style')) then - x.attribute('style', fixStyleLink(base, x.attribute('style'))); - for c in x.ChildNodes do - adjustLinks(c, base); -end; - -function TFHIRXIGWebServer.fixNarrative(src, base : String) : String; -var - x : TFhirXHtmlNode; -begin - x := TFHIRXhtmlParser.parse(nil, xppAllow, [xopTrimWhitspace], src); - try - adjustLinks(x, base); - result := TFHIRXhtmlParser.compose(x, false); - finally - x.free; - end; -end; - -function TFHIRXIGWebServer.contentRes(context : TFHIRXIGWebContext; pid, rtype, id: String; secure : boolean): String; -var - db : TFDBConnection; - b : TFslStringBuilder; - pck : TPackageInformation; - rk, s, dv, js, base, st: String; - j : TBytes; - json, txt : TJsonObject; -begin - b := TFslStringBuilder.create; - try - db := context.FDatabase.GetConnection('content-res'); - try - pck := context.FPackagesById[pid]; - if (pck = nil) then - raise EWebServerException.create(400, 'Unknown Package '+pid.replace('|', '#')); - db.sql := 'Select * from Resources where PackageKey = '+pck.key+' and ResourceType = '''+SqlWrapString(rtype)+''' and Id = '''+SqlWrapString(id)+''''; - db.prepare; - db.Execute; - if not db.FetchNext then - raise EWebServerException.create(400, 'Unknown Resource '+rtype+'/'+id+' in package '+pid); - rk := db.ColStringByName['ResourceKey']; - base := db.ColStringByName['Web']; - base := base.Substring(0, base.LastIndexOf('/')); - - b.append(''); - b.append(''); - b.append(''); - b.append(''); - s := showVersion(db); - if (s.Contains(',')) then - b.append('') - else - b.append(''); - - b.append(''); - if (db.ColStringByName['Url'] <> '') then - b.append(''); - if (db.ColStringByName['Version'] <> '') then - b.append(''); - if (db.ColStringByName['Status'] <> '') then - b.append(''); - if (db.ColStringByName['Date'] <> '') then - b.append(''); - if (db.ColStringByName['Name'] <> '') then - b.append(''); - if (db.ColStringByName['Title'] <> '') then - b.append(''); - if (db.ColStringByName['Experimental'] <> '') then - if (db.ColStringByName['Experimental'] = '1') then - b.append('') - else - b.append(''); - if (db.ColStringByName['Realm'] <> '') then - b.append(''); - if (db.ColStringByName['Authority'] <> '') then - b.append(''); - if (db.ColStringByName['Description'] <> '') then - b.append(''); - if (db.ColStringByName['Purpose'] <> '') then - b.append(''); - if (db.ColStringByName['Copyright'] <> '') then - b.append(''); - if (db.ColStringByName['CopyrightLabel'] <> '') then - b.append(''); - if (db.ColStringByName['Content'] <> '') then - b.append(''); - if (db.ColStringByName['Type'] <> '') then - b.append(''); - if (db.ColStringByName['Supplements'] <> '') then - b.append(''); - if (db.ColStringByName['valueSet'] <> '') then - b.append(''); - if (db.ColStringByName['Kind'] <> '') then - b.append(''); - //if (db.ColStringByName['Details'] <> '') then - // b.append(''); - b.append('
Package '+pck.id+'
Type '+rtype+'
Id Id
FHIR Versions '+s+'
FHIR Version '+s+'
Source '+db.ColStringByName['Web']+'
Url '+db.ColStringByName['Url']+'
Version '+db.ColStringByName['Version']+'
Status '+db.ColStringByName['Status']+'
Date '+db.ColStringByName['Date']+'
Name '+db.ColStringByName['Name']+'
Title '+db.ColStringByName['Title']+'
Experimental True
Experimental False
Realm '+db.ColStringByName['Realm']+'
Authority '+db.ColStringByName['Authority']+'
Description '+db.ColStringByName['Description']+'
Purpose '+db.ColStringByName['Purpose']+'
Copyright '+db.ColStringByName['Copyright']+'
Copyright Label '+db.ColStringByName['CopyrightLabel']+'
Content '+db.ColStringByName['Content']+'
Type '+db.ColStringByName['Type']+'
Supplements '+db.ColStringByName['Supplements']+'
valueSet '+db.ColStringByName['valueSet']+'
Kind '+db.ColStringByName['Kind']+'
Details '+db.ColStringByName['Details']+'
'); - db.terminate; - - b.append('
'); - b.append('

Resources that use this resource

'); - db.SQL := 'Select Packages.PID, Resources.ResourceType, Resources.Id, Resources.URL, Resources.Web, Resources.Name, Resources.Title from DependencyList, Resources, Packages where DependencyList.TargetKey = '+rk+' and DependencyList.SourceKey = Resources.ResourceKey and Resources.PackageKey = Packages.PackageKey order by ResourceType'; - st := ''; - db.Prepare; - db.execute; - while db.fetchNext do - begin - if st = '' then - begin - st := db.ColStringByName['ResourceType']; - b.append(''); - b.append(''); - end; - b.append(''); - id := AbsoluteURL(secure)+'/'+db.colStringByName['PID'].replace('#','|')+'/'+db.ColStringByName['ResourceType']+'/'+db.ColStringByName['Id']; - if db.ColStringByName['Url'] <> '' then - b.append('') - else - b.append(''); - if db.ColStringByName['Title'] <> '' then - b.append('') - else - b.append(''); - b.append(''); - end; - if (st <> '') then - begin - b.append('
'+st+'
'+db.ColStringByName['Url'].replace(pck.canonical+st+'/', '')+extLink(db.ColStringByName['Web'])+''+(db.ColStringByName['ResourceType']+'/').replace(st+'/', '')+db.ColStringByName['Id']+extLink(db.ColStringByName['Web'])+''+db.ColStringByName['Title']+''+db.ColStringByName['Name']+'
'); - end - else - b.append('

No resources found

'); - db.terminate; - - b.append('
'); - b.append('

Resources that this resource uses

'); - db.SQL := 'Select Packages.PID, Resources.ResourceType, Resources.Id, Resources.URL, Resources.Web, Resources.Name, Resources.Title from DependencyList, Resources, Packages where DependencyList.SourceKey = '+rk+' and DependencyList.TargetKey = Resources.ResourceKey and Resources.PackageKey = Packages.PackageKey order by ResourceType'; - st := ''; - db.Prepare; - db.execute; - while db.fetchNext do - begin - if st = '' then - begin - st := db.ColStringByName['ResourceType']; - b.append(''); - b.append(''); - end; - b.append(''); - id := AbsoluteURL(secure)+'/'+db.colStringByName['PID'].replace('#','|')+'/'+db.ColStringByName['ResourceType']+'/'+db.ColStringByName['Id']; - if db.ColStringByName['Url'] <> '' then - b.append('') - else - b.append(''); - if db.ColStringByName['Title'] <> '' then - b.append('') - else - b.append(''); - b.append(''); - end; - if (st <> '') then - begin - b.append('
'+st+'
'+db.ColStringByName['Url'].replace(pck.canonical+st+'/', '')+extLink(db.ColStringByName['Web'])+''+(db.ColStringByName['ResourceType']+'/').replace(st+'/', '')+db.ColStringByName['Id']+extLink(db.ColStringByName['Web'])+''+db.ColStringByName['Title']+''+db.ColStringByName['Name']+'
'); - end - else - b.append('

No resources found

'); - db.terminate; - - b.append('
'); - db.SQL := 'Select * from Contents where ResourceKey = '+rk; - db.prepare; - db.Execute; - db.fetchNext; - {$IFDEF FPC} - j := inflate(db.ColBlobByName['Json']); - {$ELSE} - raise EFslException.Create('Not Implemented Yet'); - {$ENDIF} - db.terminate; - db.release; - - json := TJsonParser.Parse(j); - try - txt := json.forceObj['text']; - dv := txt.str['div']; - if (dv <> '') then - begin - dv := fixNarrative(dv, base); - b.append('
'); - b.append('

Narrative

'); - b.append('

Note: links and images are rebased to the (stated) source

'); - b.append(dv); - end; - js := TJSONWriter.writeObjectStr(json, true); - finally - json.free; - end; - b.append('
'); - b.append('

Source

'); - b.append('
');
-       b.append(FormatTextToHtml(js));
-       b.append('
'); - - result := b.AsString; - except - on e : Exception do - begin - db.Error(e); - result := '

Error: '+FormatTextToHTML(e.message)+'

'; - end; - end; - finally - b.free; - end; -end; - -function TFHIRXIGWebServer.getContext: TFHIRXIGWebContext; -begin - FLock.Lock; - try - result := FContext.link; - finally - FLock.Unlock; - end; -end; - -procedure TFHIRXIGWebServer.sendViewHtml(request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; secure : boolean; rtype, auth, realm, ver, rt, text, offset : String); -var - vars : TFslMap; - ms : int64; - s : String; - ctxt : TFHIRXIGWebContext; -begin - ctxt := getContext; - try - vars := TFslMap.Create('vars'); - try - vars.add('realm-bar', TFHIRObjectText.Create(ctxt.realmBar(absoluteUrl(secure), realm, auth, ver, rtype, rt, text))); - vars.add('auth-bar', TFHIRObjectText.Create(ctxt.authBar(absoluteUrl(secure), realm, auth, ver, rtype, rt, text))); - vars.add('version-bar', TFHIRObjectText.Create(ctxt.versionBar(absoluteUrl(secure), realm, auth, ver, rtype, rt, text))); - vars.add('type-bar', TFHIRObjectText.Create(ctxt.typeBar(absoluteUrl(secure), realm, auth, ver, rtype, rt, text))); - for s in ctxt.FMetadata.keys do - vars.add('metadata-'+s, TFHIRObjectText.Create(ctxt.FMetadata[s])); - - ms := getTickCount64; - if (rtype = '') then - vars.add('content', TFHIRObjectText.Create(contentAll(ctxt, cmAll, secure, realm, auth, ver, rt, text, offset))) - else if (rtype = 'cs') then - vars.add('content', TFHIRObjectText.Create(contentAll(ctxt, cmCodeSystem, secure, realm, auth, ver, '', text, offset))) - else if (rtype = 'rp') then - vars.add('content', TFHIRObjectText.Create(contentAll(ctxt, cmResProfile, secure, realm, auth, ver, rt, text, offset))) - else if (rtype = 'dp') then - vars.add('content', TFHIRObjectText.Create(contentAll(ctxt, cmDTProfile, secure, realm, auth, ver, rt, text, offset))) - else if (rtype = 'lm') then - vars.add('content', TFHIRObjectText.Create(contentAll(ctxt, cmLogical, secure, realm, auth, ver, rt, text, offset))) - else if (rtype = 'ext') then - vars.add('content', TFHIRObjectText.Create(contentAll(ctxt, cmExtensions, secure, realm, auth, ver, rt, text, offset))) - else if (rtype = 'vs') then - vars.add('content', TFHIRObjectText.Create(contentAll(ctxt, cmValueset, secure, realm, auth, ver, rt, text, offset))) - else if (rtype = 'cm') then - vars.add('content', TFHIRObjectText.Create(contentAll(ctxt, cmConceptMap, secure, realm, auth, ver, rt, text, offset))) - else - vars.add('content', TFHIRObjectText.Create('

Not done yet

')); - vars.add('ms', TFHIRObjectText.Create(inttostr(getTickCount64 - ms))); - - //vars.add('matches', TFHIRObjectText.Create(renderJson(json, path, reg, srvr, ver))); - //vars.add('count', TFHIRObjectText.Create(json.forceArr['results'].Count)); - //vars.add('registry', TFHIRObjectText.Create(reg)); - //vars.add('server', TFHIRObjectText.Create(srvr)); - //vars.add('version', TFHIRObjectText.Create(ver)); - //vars.add('url', TFHIRObjectText.Create(tx)); - //vars.add('status', TFHIRObjectText.Create(status)); - returnFile(request, response, nil, request.Document, 'xig.html', false, vars); - finally - vars.free; - end; - finally - ctxt.free; - end; -end; - -procedure TFHIRXIGWebServer.sendResourceHtml(request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; secure : boolean; pid, rtype, id : String); -var - vars : TFslMap; - ms : int64; - ctxt : TFHIRXIGWebContext; -begin - ctxt := getContext; - try - vars := TFslMap.Create('vars'); - try - vars.add('pid', TFHIRObjectText.Create(pid.replace('|', '#'))); - vars.add('rtype', TFHIRObjectText.Create(rtype)); - vars.add('id', TFHIRObjectText.Create(id)); - - ms := getTickCount64; - vars.add('content', TFHIRObjectText.Create(contentRes(ctxt, pid, rtype, id, secure))); - vars.add('ms', TFHIRObjectText.Create(inttostr(getTickCount64 - ms))); - returnFile(request, response, nil, request.Document, 'xig-res.html', false, vars); - finally - vars.free; - end; - finally - ctxt.free; - end; -end; - -function TFHIRXIGWebServer.link: TFHIRXIGWebServer; -begin - result := TFHIRXIGWebServer(inherited link); -end; - -function TFHIRXIGWebServer.logId: string; -begin - result := 'xig'; -end; - -function TFHIRXIGWebServer.PlainRequest(AContext: TIdContext; ip : String; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; id : String; tt : TTimeTracker) : String; -begin - countRequest; - result := doRequest(AContext, request, response, id, false); -end; - - -function TFHIRXIGWebServer.doRequest(AContext: TIdContext; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; id : String; secure : boolean) : String; -var - pm : THTTPParameters; - rtype, auth, realm, ver, rt,text, offs, s : String; - //s : TArray; - //sId : string; - json : TJsonObject; - p : TArray; -begin - pm := THTTPParameters.Create(request.UnparsedParams); - try - if (request.CommandType <> hcGET) then - raise EFslException.Create('The operation '+request.Command+' '+request.Document+' is not supported'); - if request.document = PathWithSlash then - begin - rtype := pm.Value['type']; - auth := pm.Value['auth']; - realm := pm.Value['realm']; - ver := pm.Value['ver']; - offs := pm.Value['offset']; - text := pm.Value['text']; - rt := pm.Value['rt']; - result := 'XIG (type='+rtype+', auth='+auth+', realm='+realm+', ver='+ver+', offset='+offs+', rt='+rt+', text='+text+')'; - sendViewHtml(request, response, secure, rtype, auth, realm, ver, rt, text, offs); - end - else if request.Document.StartsWith(PathWithSlash) then - begin - p := request.Document.subString(PathWithSlash.length).split(['/']); - if (length(p) <> 3) then - raise EFslException.Create('The operation '+request.Command+' '+request.Document+' is not supported') - else - begin - result := 'XIG Resource '+p[0]+'/'+p[1]+'/'+p[2]; - sendResourceHtml(request, response, secure, p[0], p[1], p[2]); - end; - end - else - raise EFslException.Create('The operation '+request.Command+' '+request.Document+' is not supported'); - finally - pm.free; - end; -end; - -function TFHIRXIGWebServer.SecureRequest(AContext: TIdContext; ip : String; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; cert: TIdOpenSSLX509; id: String; tt : TTimeTracker): String; -begin - countRequest; - result := doRequest(AContext, request, response, id, true); -end; - -end. +unit endpoint_xig; + +{ +Copyright (c) 2001-2021, Health Intersections Pty Ltd (http://www.healthintersections.com.au) +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of HL7 nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +} + +{$i fhir.inc} + +interface + +uses + SysUtils, Classes, {$IFDEF FPC} ZStream, {$ENDIF} + IdContext, IdCustomHTTPServer, IdOpenSSLX509, + fsl_base, fsl_utilities, fsl_json, fsl_i18n, fsl_http, fsl_html, fsl_fetcher, fsl_logging, fsl_threads, + fhir_objects, fhir_xhtml, + fdb_manager, fdb_sqlite3, + utilities, server_config, tx_manager, time_tracker, kernel_thread, + web_base, endpoint, server_stats; + +type + TContentMode = (cmAll, cmCodeSystem, cmResProfile, cmDTProfile, cmLogical, cmExtensions, cmValueSet, cmConceptMap); + + + { TPackageInformation } + + TPackageInformation = class (TFslObject) + private + FCanonical: String; + FId: String; + Fkey: String; + FVid: String; + FWeb: String; + public + constructor create(key, id, vid, web, canonical : String); + + function link : TPackageInformation; overload; + + property key : String read Fkey write FKey; + property id : String read FId write FId; + property vid : String read FVid write FVid; + property web : String read FWeb write FWeb; + property canonical : String read FCanonical write FCanonical; + end; + + { TFHIRXIGWebContext } + + TFHIRXIGWebContext = class (TFslObject) + private + FMetadata : TFslStringDictionary; + FVersions : TStringList; + FRealms : TStringList; + FAuthorities : TStringList; + FTypes : TStringList; + FDatabase : TFDBManager; + FPackages : TFslMap; + FPackagesById : TFslMap; + FResourceTypes : TStringList; + FProfileResources : TStringList; + FProfileTypes : TStringList; + FExtensionContexts : TStringList; + FExtensionTypes : TStringList; + FTerminologySources : TStringList; + FDate : String; + + procedure loadFromDB; + + function authBar(url, realm, auth, ver, rtype, rt, text: String): String; + function realmBar(url, realm, auth, ver, rtype, rt, text: String): String; + function typeBar(url, realm, auth, ver, rtype, rt, text: String): String; + function versionBar(url, realm, auth, ver, rtype, rt, text: String): String; + function makeSelect(rt : String; list : TStringList) : String; + function hasTerminologySource(s : String): boolean; + public + constructor create(db : TFDBManager); + destructor Destroy; override; + function link : TFHIRXIGWebContext; overload; + end; + + { TFHIRXIGWebServer } + + TFHIRXIGWebServer = class (TFhirWebServerEndpoint) + private + FLock : TFslLock; + FContext : TFHIRXIGWebContext; + + function adjustLinks(x : TFhirXHtmlNode; base : String) : String; + function fixNarrative(src, base: String): String; + + procedure renderExtension(b : TFslStringBuilder; details : String); + function extLink(url : String) : String; + + function contentAll(context : TFHIRXIGWebContext; mode : TContentMode; secure: boolean; realm, auth, ver, rt, text, offset: String): String; + function contentRes(context : TFHIRXIGWebContext; pid, rtype, id : String; secure : boolean) : String; + + function getContext : TFHIRXIGWebContext; + procedure sendViewHtml(request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; secure : boolean; rtype, auth, realm, ver, rt, text, offset : String); + procedure sendResourceHtml(request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; secure : boolean; pid, rtype, id : String); + function doRequest(AContext: TIdContext; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; id: String; secure: boolean): String; + public + Constructor Create(code, path : String; common : TFHIRWebServerCommon); override; + destructor Destroy; override; + function link : TFHIRXIGWebServer; overload; + function description : String; override; + + function PlainRequest(AContext: TIdContext; ip : String; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; id : String; tt : TTimeTracker) : String; override; + function SecureRequest(AContext: TIdContext; ip : String; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; cert : TIdOpenSSLX509; id : String; tt : TTimeTracker) : String; override; + function logId : string; override; + end; + + { TXIGServerEndPoint } + + TXIGServerEndPoint = class (TFHIRServerEndPoint) + private + FXIGServer : TFHIRXIGWebServer; + FLastCheck : TDateTime; + FLastDownload : String; + procedure loadFromDB; + function downloadTimestampFile : String; + procedure downloadAndReload; + function dateBuilt : String; + public + constructor Create(config : TFHIRServerConfigSection; settings : TFHIRServerSettings; common : TCommonTerminologies; i18n : TI18nSupport); + destructor Destroy; override; + + function summary : String; override; + function makeWebEndPoint(common : TFHIRWebServerCommon) : TFhirWebServerEndpoint; override; + procedure InstallDatabase(params : TCommandLineParameters); override; + procedure UninstallDatabase; override; + procedure LoadPackages(installer : boolean; plist : String); override; + procedure updateAdminPassword(pw : String); override; + procedure Load; override; + Procedure Unload; override; + procedure internalThread(callback : TFhirServerMaintenanceThreadTaskCallBack); override; + function cacheSize(magic : integer) : UInt64; override; + procedure clearCache; override; + procedure SweepCaches; override; + procedure SetCacheStatus(status : boolean); override; + procedure getCacheInfo(ci: TCacheInformation); override; + procedure recordStats(rec : TStatusRecord); override; + end; + +implementation + +{ TFHIRXIGWebContext } + +constructor TFHIRXIGWebContext.create(db: TFDBManager); +begin + inherited create; + + FVersions := TStringList.create; + FRealms := TStringList.create; + FAuthorities := TStringList.create; + FTypes := TStringList.create; + FPackages := TFslMap.create; + FPackagesById := TFslMap.create; + FPackagesById.defaultValue := nil; + FProfileResources := TStringList.create; + FProfileTypes := TStringList.create; + FResourceTypes := TStringList.create; + FExtensionContexts := TStringList.create; + FExtensionTypes := TStringList.create; + FTerminologySources := TStringList.create; + FMetadata := TFslStringDictionary.create; + + FDatabase := db; + loadFromDB; +end; + +destructor TFHIRXIGWebContext.Destroy; +begin + FMetadata.free; + FPackagesById.free; + FExtensionContexts.free; + FExtensionTypes.free; + FTerminologySources.free; + FResourceTypes.free; + FProfileResources.Free; + FProfileTypes.Free; + FPackages.Free; + FDatabase.Free; + FVersions.Free; + FRealms.Free; + FAuthorities.Free; + FTypes.Free; + + inherited Destroy; +end; + + +procedure TFHIRXIGWebContext.loadFromDB; +var + conn : TFDBConnection; + pck : TPackageInformation; +begin + conn := FDatabase.GetConnection('Load'); + try + conn.SQL := 'select Name, Value from Metadata'; + conn.Prepare; + conn.Execute; + while conn.FetchNext do + FMetadata.addOrSetValue(conn.ColStringByName['Name'], conn.ColStringByName['Value']); + conn.terminate; + FDate := FMetadata['date']; + + conn.SQL := 'select Code from realms'; + conn.Prepare; + conn.Execute; + while conn.FetchNext do + FRealms.add(conn.ColStringByName['Code']); + conn.terminate; + FRealms.Sort; + + conn.SQL := 'select Code from Authorities'; + conn.Prepare; + conn.Execute; + while conn.FetchNext do + FAuthorities.add(conn.ColStringByName['Code']); + conn.terminate; + FAuthorities.sort; + + conn.SQL := 'select PackageKey, Id, PID, Web, Canonical from Packages'; + conn.Prepare; + conn.Execute; + while conn.FetchNext do + begin + pck := TPackageInformation.create(conn.ColStringByName['PackageKey'], conn.ColStringByName['Id'], conn.ColStringByName['PID'].replace('#', '|'), conn.ColStringByName['Web'], conn.ColStringByName['Canonical']); + try + FPackages.add(pck.key, pck.link); + FPackagesById.addOrSetValue(pck.vid, pck.link); + finally + pck.free; + end; + end; + conn.terminate; + FAuthorities.sort; + + conn.SQL := 'Select distinct type from Resources where ResourceType = ''StructureDefinition'' and Kind = ''resource'''; + conn.Prepare; + conn.Execute; + while conn.FetchNext do + if conn.ColStringByName['Type'] <> '' then + FProfileResources.add(conn.ColStringByName['Type']); + conn.terminate; + FProfileResources.Sort; + + conn.SQL := 'Select distinct type from Resources where ResourceType = ''StructureDefinition'' and (Kind = ''complex-type'' or Kind = ''primitive-type'')'; + conn.Prepare; + conn.Execute; + while conn.FetchNext do + if (conn.ColStringByName['Type'] <> 'Extension') and (conn.ColStringByName['Type'] <> '') then + FProfileTypes.add(conn.ColStringByName['Type']); + conn.terminate; + FProfileTypes.Sort; + + conn.SQL := 'Select distinct ResourceType from Resources'; + conn.Prepare; + conn.Execute; + while conn.FetchNext do + if (conn.ColStringByName['ResourceType'] <> '') and (conn.ColStringByName['ResourceType'] <> 'StructureDefinition') and (conn.ColStringByName['ResourceType'] <> 'CodeSystem') and + (conn.ColStringByName['ResourceType'] <> 'ValueSet') and (conn.ColStringByName['ResourceType'] <> 'ConceptMap') then + FResourceTypes.add(conn.ColStringByName['ResourceType']); + conn.terminate; + FResourceTypes.Sort; + + conn.SQL := 'Select distinct Code from Categories where mode = 2'; + conn.Prepare; + conn.Execute; + while conn.FetchNext do + if (conn.ColStringByName['Code'] <> '') then + FExtensionContexts.add(conn.ColStringByName['Code']); + conn.terminate; + FExtensionContexts.Sort; + + conn.SQL := 'Select distinct Code from Categories where mode = 3'; + conn.Prepare; + conn.Execute; + while conn.FetchNext do + if (conn.ColStringByName['Code'] <> '') then + FExtensionTypes.add(conn.ColStringByName['Code']); + conn.terminate; + FExtensionTypes.Sort; + + conn.SQL := 'Select Code, Display from TxSource'; + conn.Prepare; + conn.Execute; + while conn.FetchNext do + if (conn.ColStringByName['Code'] <> '') then + FTerminologySources.add(conn.ColStringByName['Code']+'='+conn.ColStringByName['Display']); + conn.terminate; + FTerminologySources.Sort; + + + FVersions.Add('R2'); + FVersions.Add('R2B'); + FVersions.Add('R3'); + FVersions.Add('R4'); + FVersions.Add('R4B'); + FVersions.Add('R5'); + FVersions.Add('R6'); + + FTypes.add('rp=Resource Profiles'); + FTypes.add('dp=Datatype Profiles'); + FTypes.add('ext=Extensions'); + FTypes.add('lm=Logical Models'); + FTypes.add('cs=CodeSystems'); + FTypes.add('vs=ValueSets'); + FTypes.add('cm=ConceptMaps'); + + conn.release; + except + on e : Exception do + conn.Error(e); + end; +end; + +function TFHIRXIGWebContext.link: TFHIRXIGWebContext; +begin + result := TFHIRXIGWebContext(inherited Link); +end; + +function TFHIRXIGWebContext.realmBar(url, realm, auth, ver, rtype, rt, text : String) : String; +var + p, s : String; +begin + p := url+'/?'; + if (rtype <> '') then + p := p+'&type='+rtype; + if (auth <> '') then + p := p+'&auth='+auth; + if (ver <> '') then + p := p+'&ver='+ver; + if (rt <> '') then + p := p + '&rt='+rt; + if (text <> '') then + p := p + '&text='+encodePercent(text); + if realm = '' then + result := 'All' + else + result := 'All'; + for s in FRealms do + if (s = realm) then + result := result + ' | '+s+'' + else + result := result + ' | '+s+''; +end; + +function TFHIRXIGWebContext.authBar(url, realm, auth, ver, rtype, rt, text : String) : String; +var + p, s : String; +begin + p := url+'/?'; + if (rtype <> '') then + p := p+'&type='+rtype; + if (realm <> '') then + p := p+'&realm='+realm; + if (ver <> '') then + p := p+'&ver='+ver; + if (rt <> '') then + p := p + '&rt='+rt; + if (text <> '') then + p := p + '&text='+encodePercent(text); + if auth = '' then + result := 'All' + else + result := 'All'; + for s in FAuthorities do + if (s = auth) then + result := result + ' | '+s+'' + else + result := result + ' | '+s+''; +end; + +function TFHIRXIGWebContext.versionBar(url, realm, auth, ver, rtype, rt, text : String) : String; +var + p, s : String; +begin + p := url+'/?'; + if (rtype <> '') then + p := p+'&type='+rtype; + if (realm <> '') then + p := p+'&realm='+realm; + if (auth <> '') then + p := p+'&auth='+auth; + if (rt <> '') then + p := p + '&rt='+rt; + if (text <> '') then + p := p + '&text='+encodePercent(text); + if ver = '' then + result := 'All' + else + result := 'All'; + for s in FVersions do + if (s = ver) then + result := result + ' | '+s+'' + else + result := result + ' | '+s+''; +end; + +function TFHIRXIGWebContext.typeBar(url, realm, auth, ver, rtype, rt, text : String) : String; +var + p, s, n, v : String; +begin + p := url+'/?'; + if (ver <> '') then + p := p+'&ver='+ver; + if (realm <> '') then + p := p+'&realm='+realm; + if (auth <> '') then + p := p+'&auth='+auth; + if (rt <> '') then + p := p + '&rt='+rt; + if (text <> '') then + p := p + '&text='+encodePercent(text); + if rtype = '' then + result := 'All' + else + result := 'All'; + for s in FTypes do + begin + StringSplit(s, '=', n, v); + if (n = rtype) then + result := result + ' | '+v+'' + else + result := result + ' | '+v+''; + end; +end; + +function showVersion(db : TFDBConnection) : String; +begin + result := ''; + if (db.ColIntegerByName['R2'] = 1) then + CommaAdd(result, 'R2'); + if (db.ColIntegerByName['R2B'] = 1) then + CommaAdd(result, 'R2B'); + if (db.ColIntegerByName['R3'] = 1) then + CommaAdd(result, 'R3'); + if (db.ColIntegerByName['R4'] = 1) then + CommaAdd(result, 'R4'); + if (db.ColIntegerByName['R4B'] = 1) then + CommaAdd(result, 'R4B'); + if (db.ColIntegerByName['R5'] = 1) then + CommaAdd(result, 'R5'); + if (db.ColIntegerByName['R6'] = 1) then + CommaAdd(result, 'R6'); +end; + +function TFHIRXIGWebContext.makeSelect(rt : String; list : TStringList) : String; +var + b : TFslStringBuilder; + s : String; + procedure add(t : String); + var + n, v :String; + begin + if t.contains('=') then + StringSplit(t, '=', n, v) + else + begin + n := t; + v := t; + end; + if (rt = n) then + b.append('') + else + b.append('') + end; +begin + b := TFslStringBuilder.create; + try + b.append(''); + result := b.asString; + finally + b.free; + end; +end; + +function TFHIRXIGWebContext.hasTerminologySource(s: String): boolean; +var + t : String; +begin + result := false; + for t in FTerminologySources do + if (t.startsWith(s+'=')) then + exit(true); +end; + + +{ TPackageInformation } + +constructor TPackageInformation.create(key, id, vid, web, canonical: String); +begin + inherited create; + FKey := key; + FId := id; + FVid := vid; + FWeb := web; + if canonical = '' then + FCanonical := '!!!' + else + FCanonical := canonical+'/'; +end; + +function TPackageInformation.link: TPackageInformation; +begin + result := TPackageInformation(inherited Link); +end; + +{ TXIGServerEndPoint } + +constructor TXIGServerEndPoint.Create(config : TFHIRServerConfigSection; settings : TFHIRServerSettings; common : TCommonTerminologies; i18n : TI18nSupport); +begin + inherited Create(config, settings, nil, common, nil, i18n); +end; + +destructor TXIGServerEndPoint.Destroy; +begin + FXIGServer.free; + + inherited; +end; + +function TXIGServerEndPoint.cacheSize(magic : integer): UInt64; +begin + result := inherited cacheSize(magic); +end; + +procedure TXIGServerEndPoint.clearCache; +begin + inherited; +end; + +procedure TXIGServerEndPoint.SweepCaches; +begin + inherited SweepCaches; +end; + +procedure TXIGServerEndPoint.getCacheInfo(ci: TCacheInformation); +begin + inherited; +end; + +procedure TXIGServerEndPoint.recordStats(rec: TStatusRecord); +begin + inherited recordStats(rec); +// rec. +end; + +procedure TXIGServerEndPoint.loadFromDB; +begin + FXIGServer.FContext := TFHIRXIGWebContext.create(Database); +end; + +function TXIGServerEndPoint.downloadTimestampFile: String; +var + url : String; +begin + url := Config.prop['db-source'].value.replace('xig.db', 'timestamp.txt'); + result := TInternetFetcher.fetchUrlString(url).trim(); +end; + +procedure TXIGServerEndPoint.downloadAndReload; +var + src, tgt : String; + fetcher : TInternetFetcher; + start : TDateTime; + xig, oxig : TFHIRXIGWebContext; +begin + src := Config.prop['db-source'].value; + tgt := Config.prop['db-file'].value.replace('.db', '-'+FLastDownload+'.db'); + + if (FileExists(tgt)) then + deleteFile(tgt); + Logging.log('Download new XIG from '+src); + try + start := now; + fetcher := TInternetFetcher.Create; + try + fetcher.URL := src; + fetcher.Fetch; + fetcher.Buffer.SaveToFileName(tgt); + Logging.Log('Finished Downloading ('+DescribeBytes(fetcher.buffer.size)+', '+DescribePeriod(now - start)+'). reload'); + finally + fetcher.free; + end; + except + on e : Exception do + begin + Logging.finish(' '+e.Message); + raise; + end; + end; + xig := TFHIRXIGWebContext.Create(TFDBSQLiteManager.create('xig-'+FLastDownload, tgt, true, false)); + try + FXIGServer.FLock.lock; + try + oxig := FXIGServer.FContext; + FXIGServer.FContext := xig.link; + finally + FXIGServer.FLock.unlock; + end; + finally + xig.free; + end; + Logging.Log('Reloaded XIG from '+tgt); + tgt := (oxig.FDatabase as TFDBSQLiteManager).FileName; + oxig.free; + DeleteFile(tgt); +end; + +function TXIGServerEndPoint.dateBuilt: String; +begin + if (FXIGServer = nil) or (FXIGServer.FContext = nil) then + result := '???xig' + else + result := FXIGServer.FContext.FDate; +end; + +procedure TXIGServerEndPoint.Unload; +begin +end; + +procedure TXIGServerEndPoint.InstallDatabase(params: TCommandLineParameters); +begin +end; + +procedure TXIGServerEndPoint.UninstallDatabase; +begin +end; + +procedure TXIGServerEndPoint.internalThread(callback: TFhirServerMaintenanceThreadTaskCallBack); +var + dt : TDateTime; + s : String; +begin + dt := trunc(now); + if (dt > FLastCheck) then + begin + s := downloadTimestampFile; + if (s <> FLastDownload) then + begin + FLastDownload := s; + downloadAndReload(); + end; + FLastCheck := dt; + end; +end; + +procedure TXIGServerEndPoint.LoadPackages(installer : boolean; plist: String); +begin + raise EFslException.Create('This is not applicable to this endpoint'); +end; + +function TXIGServerEndPoint.makeWebEndPoint(common: TFHIRWebServerCommon): TFhirWebServerEndpoint; +var + json : TJsonObject; +begin + inherited makeWebEndPoint(common); + FXIGServer := TFHIRXIGWebServer.Create(config.name, config['path'].value, common); + (FXIGServer as TFHIRXIGWebServer).FContext := TFHIRXIGWebContext.create(Database.link); + WebEndPoint := FXIGServer; + result := FXIGServer.link; +end; + +procedure TXIGServerEndPoint.SetCacheStatus(status: boolean); +begin + inherited; +end; + +function TXIGServerEndPoint.summary: String; +begin + result := 'XIG Server based on database built '+dateBuilt(); +end; + +procedure TXIGServerEndPoint.updateAdminPassword(pw: String); +begin + raise EFslException.Create('This is not applicable to this endpoint'); +end; + +procedure TXIGServerEndPoint.Load; +begin + inherited Load; +end; + +{ TFHIRXIGWebServer } + +constructor TFHIRXIGWebServer.Create(code, path: String; common: TFHIRWebServerCommon); +begin + inherited Create(code, path, common); + FLock := TFslLock.create('xig-server'); +end; + +destructor TFHIRXIGWebServer.Destroy; +begin + FContext.Free; + FLock.free; + inherited; +end; + +function TFHIRXIGWebServer.description: String; +begin + result := 'XIG Server based on database built '+FContext.FDate; +end; + +function TFHIRXIGWebServer.contentAll(context : TFHIRXIGWebContext; mode : TContentMode; secure: boolean; realm, auth, ver, rt, text, offset: String): String; +var + db : TFDBConnection; + b : TFslStringBuilder; + filter, s, p, tt, id : String; + count, c, offs : integer; + pck : TPackageInformation; +begin + p := AbsoluteURL(secure)+'/?'; + if (ver <> '') then + p := p+'&ver='+ver; + if (realm <> '') then + p := p+'&realm='+realm; + if (auth <> '') then + p := p+'&auth='+auth; + if (text <> '') then + p := p+'&text='+EncodePercent(text); + if (rt <> '') then + p := p+'&rt='+rt; + case mode of + cmCodeSystem: p := p+'&type=cs'; + cmResProfile: p := p+'&type=rp'; + cmDTProfile: p := p+'&type=dp'; + cmLogical: p := p+'&type=lm'; + cmExtensions : p := p + '&type=ext'; + cmValueSet : p := p + '&type=vs'; + cmConceptMap : p := p + '&type=cm'; + end; + + b := TFslStringBuilder.create; + try + case mode of + cmCodeSystem : b.append('

CodeSystems'); + cmResProfile : b.append('

Resource Profiles'); + cmDTProfile : b.append('

Datatype Profiles'); + cmLogical : b.append('

Logical models'); + cmExtensions : b.append('

Extensions'); + cmValueSet :b.append('

ValueSets'); + cmConceptMap :b.append('

ConceptMaps'); + else if rt <> '' then + b.append('

Resources - '+rt) + else + b.append('

Resources - All Kinds'); + end; + + if (realm <> '') then + b.append(', Realm '+realm.ToUpper); + if (auth <> '') then + b.append(', Authority '+capitalise(auth)); + if ver <> '' then + b.append(', Version '+ver); + b.append('

'); + filter := ''; + if (realm <> '') then + filter := filter + ' and realm = '''+sqlWrapString(realm)+''''; + if (auth <> '') then + filter := filter + ' and authority = '''+sqlWrapString(auth)+''''; + if ver = 'R2' then + filter := filter + ' and R2 = 1' + else if ver = 'R2B' then + filter := filter + ' and R2B = 1' + else if ver = 'R3' then + filter := filter + ' and R3 = 1' + else if ver = 'R4' then + filter := filter + ' and R4 = 1' + else if ver = 'R4B' then + filter := filter + ' and R4B = 1' + else if ver = 'R5' then + filter := filter + ' and R5 = 1' + else if ver = 'R6' then + filter := filter + ' and R6 = 1'; + case mode of + cmCodeSystem : filter := filter + ' and ResourceType = ''CodeSystem'''; + cmResProfile : + begin + filter := filter + ' and ResourceType = ''StructureDefinition'' and kind = ''resource'''; + if (rt <> '') and (context.FProfileResources.IndexOf(rt) > -1) then + filter := filter + ' and Type = '''+sqlWrapString(rt)+'''' + end; + cmDTProfile : + begin + filter := filter + ' and ResourceType = ''StructureDefinition'' and (kind = ''complex-type'' or kind = ''primitive-type'')'; + if (rt <> '') and (context.FProfileTypes.IndexOf(rt) > -1) then + filter := filter + ' and Type = '''+sqlWrapString(rt)+'''' + end; + cmLogical: filter := filter + ' and ResourceType = ''StructureDefinition'' and kind = ''logical'''; + cmExtensions : + begin + filter := filter + ' and ResourceType = ''StructureDefinition'' and (Type = ''Extension'')'; + if (rt <> '') and (context.FExtensionContexts.IndexOf(rt) > -1) then + filter := filter + ' and ResourceKey in (Select ResourceKey from Categories where Mode = 2 and Code = '''+sqlWrapString(rt)+''')' + end; + cmValueSet: + begin + filter := filter + ' and ResourceType = ''ValueSet'''; + if (rt <> '') and (context.hasTerminologySource(rt)) then + filter := filter + ' and ResourceKey in (Select ResourceKey from Categories where Mode = 1 and Code = '''+sqlWrapString(rt)+''')' + end; + cmConceptMap: + begin + filter := filter + ' and ResourceType = ''ConceptMap'''; + if (rt <> '') and (context.hasTerminologySource(rt)) then + filter := filter + ' and ResourceKey in (Select ResourceKey from Categories where Mode = 1 and Code = '''+sqlWrapString(rt)+''')' + end; + else + if (rt <> '') and (context.FResourceTypes.IndexOf(rt) > -1) then + filter := filter + ' and ResourceType = '''+sqlWrapString(rt)+'''' + else + ; // nothing + end; + + if text <> '' then + if mode = cmCodeSystem then + filter := filter + ' and (ResourceKey in (select ResourceKey from ResourceFTS where Description match '''+SQLWrapString(text)+''' or Narrative match '''+SQLWrapString(text)+''') '+ + 'or ResourceKey in (select ResourceKey from CodeSystemFTS where Display match '''+SQLWrapString(text)+''' or Definition match '''+SQLWrapString(text)+'''))' + else + filter := filter + ' and ResourceKey in (select ResourceKey from ResourceFTS where Description match '''+SQLWrapString(text)+''' or Narrative match '''+SQLWrapString(text)+''')'; + if filter <> '' then + filter := 'where '+filter.substring(4); + + db := context.FDatabase.GetConnection('content-all'); + try + b.append('

'); + count := db.CountSQL('select count(*) from Resources '+filter); + b.append(inttostr(count)); + b.append(' resources

'); + b.append('
'); + if (ver <> '') then + b.append(''); + if (realm <> '') then + b.append(''); + if (auth <> '') then + b.append(''); + case mode of + cmCodeSystem: b.append(''); + cmResProfile: + begin + b.append(''); + b.append('Type: '+context.makeSelect(rt, context.FProfileResources)+'
'); + end; + cmDTProfile: + begin + b.append(''); + b.append('Type: '+context.makeSelect(rt, context.FProfileTypes)+'
'); + end; + cmLogical: b.append(''); + cmExtensions: + begin + b.append(''); + b.append('Context: '+context.makeSelect(rt, context.FExtensionContexts)+'
'); + end; + cmValueSet: + begin + b.append(''); + b.append('Source: '+context.makeSelect(rt, context.FTerminologySources)+'
'); + end; + cmConceptMap: + begin + b.append(''); + b.append('Source: '+context.makeSelect(rt, context.FTerminologySources)+'
'); + end; + else + b.append('Type: '+context.makeSelect(rt, context.FResourceTypes)+'
'); + end; + b.append('Text: [%include xig-help.html%]
'); + b.append(''); + b.append('
'); + + //if (text = '') then + //begin + if ver = '' then + begin + b.append('

By Version

    '); + for s in context.FVersions do + begin + if filter = '' then + c := db.CountSQL('select count(*) from Resources where '+s+' = 1') + else + c := db.CountSQL('select count(*) from Resources '+filter+' and '+s+' = 1'); + b.append('
  • '); + b.append(''+s+': '+inttostr(c)); + b.append('
    • '); + end; + b.append('
'); + end; + + if auth = '' then + begin + db.sql := 'select Authority, count(*) from Resources '+filter+' group by Authority '; + db.prepare; + db.execute; + b.append('

By Authority

    '); + while db.FetchNext do + begin + b.append('
  • '); + if (db.ColString[1] = '') then + b.append('none: '+db.colString[2]) + else + b.append(''+db.ColString[1]+': '+db.colString[2]); + b.append('
    • '); + end; + db.terminate; + b.append('
'); + end; + + if realm = '' then + begin + db.sql := 'select realm, count(*) from Resources '+filter+' group by realm '; + db.prepare; + db.execute; + b.append('

By realm

    '); + while db.FetchNext do + begin + b.append('
  • '); + if (db.ColString[1] = '') then + b.append('none: '+db.colString[2]) + else + b.append(''+db.ColString[1]+': '+db.colString[2]); + b.append('
    • '); + end; + db.terminate; + b.append('
'); + end; + //end; + + offs := StrToIntDef(offset, 0); + if (count > 200) then + begin + b.append('

'); + if (offs > 200) then + b.append('Start '); + if (offs >= 200) then + b.append('Prev '); + b.append('Rows '+inttostr(offs)+' - '+inttostr(offs+200)+''); + b.append(' Next '); + end; + + if (count > 0) then + begin + b.append(''); + b.append(''); + + b.append(''); + if (ver = '') then + b.append(''); + b.append(''); + b.append(''); + b.append(''); + b.append(''); + if (realm = '') then + b.append(''); + if (auth = '') then + b.append(''); + case mode of + cmCodeSystem: b.append(''); + cmResProfile: if (rt = '') then b.append(''); + cmDTProfile: if (rt = '') then b.append(''); + cmExtensions: b.append(''); + cmValueSet : b.append(''); + cmConceptMap : b.append(''); + cmLogical: b.append(''); + end; + case mode of + cmCodeSystem: tt := 'CodeSystem/'; + cmResProfile: tt := 'StructureDefinition/'; + cmDTProfile: tt := 'StructureDefinition/'; + cmExtensions: tt := 'StructureDefinition/'; + cmValueSet : tt := 'ValueSet/'; + cmConceptMap : tt := 'ConceptMap/'; + cmLogical: tt := 'StructureDefinition/'; + else + tt := ''; + end; + + b.append(''); + if (text <> '') then + db.sql := 'Select PackageKey, ResourceType, Id, R2, R2B, R3, R4, R4B, R5, R6, Web, Url, Version, Status, Date, Name, Title, Realm, Authority, Content, Supplements, Type, Details from Resources '+filter+' LIMIT '+inttostr(offs)+', '+inttostr(offs+200)+'' + else + db.sql := 'Select PackageKey, ResourceType, Id, R2, R2B, R3, R4, R4B, R5, R6, Web, Url, Version, Status, Date, Name, Title, Realm, Authority, Content, Supplements, Type, Details from Resources '+filter+' LIMIT '+inttostr(offs)+', '+inttostr(offs+200)+''; + db.prepare; + db.execute; + while db.fetchnext do + begin + b.append(''); + pck := context.FPackages[db.ColStringByName['PackageKey']]; + if (pck.web <> '') then + b.append('') + else + b.append(''); + if (ver = '') then + b.append(''); + id := pck.vid+'/'+db.ColStringByName['ResourceType']+'/'+db.ColStringByName['Id']; + if db.ColStringByName['Url'] <> '' then + b.append('') + else + b.append(''); + if db.ColStringByName['Title'] <> '' then + b.append('') + else + b.append(''); + b.append(''); + b.append(''); + if (realm = '') then + b.append(''); + if (auth = '') then + b.append(''); + case mode of + cmCodeSystem: if db.ColStringByName['Supplements'] <> '' then + b.append('') + else + b.append(''); + cmResProfile : if (rt = '') then b.append(''); + cmDTProfile : if (rt = '') then b.append(''); + cmValueSet : b.append(''); + cmConceptMap : b.append(''); + cmLogical : b.append(''); + cmExtensions : renderExtension(b, db.ColStringByName['Details']); + end; + b.append(''); + end; + b.append('
PackageVersionIdentityName/TitleStatusDateRealmAuthContentResourceDataTypeContextModifierTypeSource(s)Source(s)Type
'+pck.id+''+pck.id+''+showVersion(db)+''+db.ColStringByName['Url'].replace(pck.canonical+tt, '')+extLink(db.ColStringByName['Web'])+''+(db.ColStringByName['ResourceType']+'/').replace(tt, '')+db.ColStringByName['Id']+extLink(db.ColStringByName['Web'])+''+db.ColStringByName['Title']+''+db.ColStringByName['Name']+''+db.ColStringByName['Status']+''+TFslDateTime.fromXML(db.ColStringByName['Date']).toString('yyyy-mm')+''+db.ColStringByName['Realm']+''+db.ColStringByName['Authority']+'Suppl: '+db.ColStringByName['Supplements']+''+db.ColStringByName['Content']+''+db.ColStringByName['Type']+''+db.ColStringByName['Type']+''+db.ColStringByName['Details'].replace(',', ' ')+''+db.ColStringByName['Details'].replace(',', ' ')+''+db.ColStringByName['Type'].replace(pck.canonical+'StructureDefinition/', '')+'
'); + end; + db.terminate; + db.release; + result := b.AsString; + except + on e : Exception do + begin + db.Error(e); + result := '

Error: '+FormatTextToHTML(e.message)+'

'; + end; + end; + finally + b.free; + end; +end; + +procedure TFHIRXIGWebServer.renderExtension(b : TFslStringBuilder; details : String); +var + p1, p2 : TArray; +begin + p1 := details.Split(['|']); + b.append(''+p1[0].subString(9).replace(',', ' ')+''); + if p1[2] = 'Mod:1' then + b.append('M') + else + b.append(''); + if (p1[1].Contains('Meta') and p1[1].Contains('uuid')) then + b.append('(all)') + else + b.append(''+p1[1].subString(5).replace(',', ' ')+''); +end; + +function TFHIRXIGWebServer.extLink(url: String): String; +begin + if (url = '') then + result := '' + else + result := ' '; +end; + +{$IFDEF FPC} +procedure DecompressStream(src, dst: TStream); +var + ds: TDecompressionStream; + d: dword; + buff: array[0..1023] of byte; +begin + ds := TDecompressionStream.Create(src, true); + try + repeat + d := ds.Read(buff, 1024); + dst.Write(buff, d); + until + d = 0; + finally + ds.Free; + end; +end; + +function inflate(source:TBytes):TBytes; +var + ss1, ss2: TStringStream; +begin + ss1 := TStringStream.Create; + try + ss1.write(source[0], length(source)); + ss1.Position := 10; //SKIP GZIP HEADER + + ss2 := TStringStream.Create; + try + DecompressStream(ss1, ss2); + ss2.Position := 0; + setLength(result, ss2.Size); + ss2.Read(result[0], length(result)); + finally + ss2.Free; + end; + finally + ss1.Free; + end; +end; +{$ENDIF} + +function fixLink(base, link : String) : String; +begin + if link.StartsWith('http:') or link.StartsWith('https:') or link.StartsWith('data:') then + result := link + else + result := URLPath([base, link]); +end; + +function fixStyleLink(base, style : String) : String; +var + i, j : integer; + s : String; +begin + result := ''; + i := 1; + while (i <= length(style)) do + if copy(style, i, 4) = 'url(' then + begin + j := i + 1; + while (j <= length(style)) and (style[j] <> ')') do + inc(j); + if j <= length(style) then + begin + s := copy(style, i+4, j-i-4); + if (s.StartsWith('http:') or s.StartsWith('https:') or s.StartsWith('data:')) then + result := result + 'url('+s+')' + else + result := result + 'url('+URLPath([base, s])+')' + end + else + result := result + copy(style, i, length(style)); + i := j + 1; + end + else + begin + result := result + style[i]; + inc(i); + end; +end; + +function TFHIRXIGWebServer.adjustLinks(x : TFhirXHtmlNode; base : String) : String; +var + c : TFhirXHtmlNode; + s : String; +begin + if (x.name = 'img') and x.HasAttribute('src') then + x.attribute('src', fixLink(base, x.attribute('src'))) + else if (x.name = 'a') and (x.HasAttribute('href')) then + x.attribute('href', fixLink(base, x.attribute('href'))); + + if (x.hasAttribute('style')) then + x.attribute('style', fixStyleLink(base, x.attribute('style'))); + for c in x.ChildNodes do + adjustLinks(c, base); +end; + +function TFHIRXIGWebServer.fixNarrative(src, base : String) : String; +var + x : TFhirXHtmlNode; +begin + x := TFHIRXhtmlParser.parse(nil, xppAllow, [xopTrimWhitspace], src); + try + adjustLinks(x, base); + result := TFHIRXhtmlParser.compose(x, false); + finally + x.free; + end; +end; + +function TFHIRXIGWebServer.contentRes(context : TFHIRXIGWebContext; pid, rtype, id: String; secure : boolean): String; +var + db : TFDBConnection; + b : TFslStringBuilder; + pck : TPackageInformation; + rk, s, dv, js, base, st: String; + j : TBytes; + json, txt : TJsonObject; +begin + b := TFslStringBuilder.create; + try + db := context.FDatabase.GetConnection('content-res'); + try + pck := context.FPackagesById[pid]; + if (pck = nil) then + raise EWebServerException.create(400, 'Unknown Package '+pid.replace('|', '#')); + db.sql := 'Select * from Resources where PackageKey = '+pck.key+' and ResourceType = '''+SqlWrapString(rtype)+''' and Id = '''+SqlWrapString(id)+''''; + db.prepare; + db.Execute; + if not db.FetchNext then + raise EWebServerException.create(400, 'Unknown Resource '+rtype+'/'+id+' in package '+pid); + rk := db.ColStringByName['ResourceKey']; + base := db.ColStringByName['Web']; + base := base.Substring(0, base.LastIndexOf('/')); + + b.append(''); + b.append(''); + b.append(''); + b.append(''); + s := showVersion(db); + if (s.Contains(',')) then + b.append('') + else + b.append(''); + + b.append(''); + if (db.ColStringByName['Url'] <> '') then + b.append(''); + if (db.ColStringByName['Version'] <> '') then + b.append(''); + if (db.ColStringByName['Status'] <> '') then + b.append(''); + if (db.ColStringByName['Date'] <> '') then + b.append(''); + if (db.ColStringByName['Name'] <> '') then + b.append(''); + if (db.ColStringByName['Title'] <> '') then + b.append(''); + if (db.ColStringByName['Experimental'] <> '') then + if (db.ColStringByName['Experimental'] = '1') then + b.append('') + else + b.append(''); + if (db.ColStringByName['Realm'] <> '') then + b.append(''); + if (db.ColStringByName['Authority'] <> '') then + b.append(''); + if (db.ColStringByName['Description'] <> '') then + b.append(''); + if (db.ColStringByName['Purpose'] <> '') then + b.append(''); + if (db.ColStringByName['Copyright'] <> '') then + b.append(''); + if (db.ColStringByName['CopyrightLabel'] <> '') then + b.append(''); + if (db.ColStringByName['Content'] <> '') then + b.append(''); + if (db.ColStringByName['Type'] <> '') then + b.append(''); + if (db.ColStringByName['Supplements'] <> '') then + b.append(''); + if (db.ColStringByName['valueSet'] <> '') then + b.append(''); + if (db.ColStringByName['Kind'] <> '') then + b.append(''); + //if (db.ColStringByName['Details'] <> '') then + // b.append(''); + b.append('
Package '+pck.id+'
Type '+rtype+'
Id Id
FHIR Versions '+s+'
FHIR Version '+s+'
Source '+db.ColStringByName['Web']+'
Url '+db.ColStringByName['Url']+'
Version '+db.ColStringByName['Version']+'
Status '+db.ColStringByName['Status']+'
Date '+db.ColStringByName['Date']+'
Name '+db.ColStringByName['Name']+'
Title '+db.ColStringByName['Title']+'
Experimental True
Experimental False
Realm '+db.ColStringByName['Realm']+'
Authority '+db.ColStringByName['Authority']+'
Description '+db.ColStringByName['Description']+'
Purpose '+db.ColStringByName['Purpose']+'
Copyright '+db.ColStringByName['Copyright']+'
Copyright Label '+db.ColStringByName['CopyrightLabel']+'
Content '+db.ColStringByName['Content']+'
Type '+db.ColStringByName['Type']+'
Supplements '+db.ColStringByName['Supplements']+'
valueSet '+db.ColStringByName['valueSet']+'
Kind '+db.ColStringByName['Kind']+'
Details '+db.ColStringByName['Details']+'
'); + db.terminate; + + b.append('
'); + b.append('

Resources that use this resource

'); + db.SQL := 'Select Packages.PID, Resources.ResourceType, Resources.Id, Resources.URL, Resources.Web, Resources.Name, Resources.Title from DependencyList, Resources, Packages where DependencyList.TargetKey = '+rk+' and DependencyList.SourceKey = Resources.ResourceKey and Resources.PackageKey = Packages.PackageKey order by ResourceType'; + st := ''; + db.Prepare; + db.execute; + while db.fetchNext do + begin + if st = '' then + begin + st := db.ColStringByName['ResourceType']; + b.append(''); + b.append(''); + end; + b.append(''); + id := AbsoluteURL(secure)+'/'+db.colStringByName['PID'].replace('#','|')+'/'+db.ColStringByName['ResourceType']+'/'+db.ColStringByName['Id']; + if db.ColStringByName['Url'] <> '' then + b.append('') + else + b.append(''); + if db.ColStringByName['Title'] <> '' then + b.append('') + else + b.append(''); + b.append(''); + end; + if (st <> '') then + begin + b.append('
'+st+'
'+db.ColStringByName['Url'].replace(pck.canonical+st+'/', '')+extLink(db.ColStringByName['Web'])+''+(db.ColStringByName['ResourceType']+'/').replace(st+'/', '')+db.ColStringByName['Id']+extLink(db.ColStringByName['Web'])+''+db.ColStringByName['Title']+''+db.ColStringByName['Name']+'
'); + end + else + b.append('

No resources found

'); + db.terminate; + + b.append('
'); + b.append('

Resources that this resource uses

'); + db.SQL := 'Select Packages.PID, Resources.ResourceType, Resources.Id, Resources.URL, Resources.Web, Resources.Name, Resources.Title from DependencyList, Resources, Packages where DependencyList.SourceKey = '+rk+' and DependencyList.TargetKey = Resources.ResourceKey and Resources.PackageKey = Packages.PackageKey order by ResourceType'; + st := ''; + db.Prepare; + db.execute; + while db.fetchNext do + begin + if st = '' then + begin + st := db.ColStringByName['ResourceType']; + b.append(''); + b.append(''); + end; + b.append(''); + id := AbsoluteURL(secure)+'/'+db.colStringByName['PID'].replace('#','|')+'/'+db.ColStringByName['ResourceType']+'/'+db.ColStringByName['Id']; + if db.ColStringByName['Url'] <> '' then + b.append('') + else + b.append(''); + if db.ColStringByName['Title'] <> '' then + b.append('') + else + b.append(''); + b.append(''); + end; + if (st <> '') then + begin + b.append('
'+st+'
'+db.ColStringByName['Url'].replace(pck.canonical+st+'/', '')+extLink(db.ColStringByName['Web'])+''+(db.ColStringByName['ResourceType']+'/').replace(st+'/', '')+db.ColStringByName['Id']+extLink(db.ColStringByName['Web'])+''+db.ColStringByName['Title']+''+db.ColStringByName['Name']+'
'); + end + else + b.append('

No resources found

'); + db.terminate; + + b.append('
'); + db.SQL := 'Select * from Contents where ResourceKey = '+rk; + db.prepare; + db.Execute; + db.fetchNext; + {$IFDEF FPC} + j := inflate(db.ColBlobByName['Json']); + {$ELSE} + raise EFslException.Create('Not Implemented Yet'); + {$ENDIF} + db.terminate; + db.release; + + json := TJsonParser.Parse(j); + try + txt := json.forceObj['text']; + dv := txt.str['div']; + if (dv <> '') then + begin + dv := fixNarrative(dv, base); + b.append('
'); + b.append('

Narrative

'); + b.append('

Note: links and images are rebased to the (stated) source

'); + b.append(dv); + end; + js := TJSONWriter.writeObjectStr(json, true); + finally + json.free; + end; + b.append('
'); + b.append('

Source

'); + b.append('
');
+       b.append(FormatTextToHtml(js));
+       b.append('
'); + + result := b.AsString; + except + on e : Exception do + begin + db.Error(e); + result := '

Error: '+FormatTextToHTML(e.message)+'

'; + end; + end; + finally + b.free; + end; +end; + +function TFHIRXIGWebServer.getContext: TFHIRXIGWebContext; +begin + FLock.Lock; + try + result := FContext.link; + finally + FLock.Unlock; + end; +end; + +procedure TFHIRXIGWebServer.sendViewHtml(request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; secure : boolean; rtype, auth, realm, ver, rt, text, offset : String); +var + vars : TFslMap; + ms : int64; + s : String; + ctxt : TFHIRXIGWebContext; +begin + ctxt := getContext; + try + vars := TFslMap.Create('vars'); + try + vars.add('realm-bar', TFHIRObjectText.Create(ctxt.realmBar(absoluteUrl(secure), realm, auth, ver, rtype, rt, text))); + vars.add('auth-bar', TFHIRObjectText.Create(ctxt.authBar(absoluteUrl(secure), realm, auth, ver, rtype, rt, text))); + vars.add('version-bar', TFHIRObjectText.Create(ctxt.versionBar(absoluteUrl(secure), realm, auth, ver, rtype, rt, text))); + vars.add('type-bar', TFHIRObjectText.Create(ctxt.typeBar(absoluteUrl(secure), realm, auth, ver, rtype, rt, text))); + for s in ctxt.FMetadata.keys do + vars.add('metadata-'+s, TFHIRObjectText.Create(ctxt.FMetadata[s])); + + ms := getTickCount64; + if (rtype = '') then + vars.add('content', TFHIRObjectText.Create(contentAll(ctxt, cmAll, secure, realm, auth, ver, rt, text, offset))) + else if (rtype = 'cs') then + vars.add('content', TFHIRObjectText.Create(contentAll(ctxt, cmCodeSystem, secure, realm, auth, ver, '', text, offset))) + else if (rtype = 'rp') then + vars.add('content', TFHIRObjectText.Create(contentAll(ctxt, cmResProfile, secure, realm, auth, ver, rt, text, offset))) + else if (rtype = 'dp') then + vars.add('content', TFHIRObjectText.Create(contentAll(ctxt, cmDTProfile, secure, realm, auth, ver, rt, text, offset))) + else if (rtype = 'lm') then + vars.add('content', TFHIRObjectText.Create(contentAll(ctxt, cmLogical, secure, realm, auth, ver, rt, text, offset))) + else if (rtype = 'ext') then + vars.add('content', TFHIRObjectText.Create(contentAll(ctxt, cmExtensions, secure, realm, auth, ver, rt, text, offset))) + else if (rtype = 'vs') then + vars.add('content', TFHIRObjectText.Create(contentAll(ctxt, cmValueset, secure, realm, auth, ver, rt, text, offset))) + else if (rtype = 'cm') then + vars.add('content', TFHIRObjectText.Create(contentAll(ctxt, cmConceptMap, secure, realm, auth, ver, rt, text, offset))) + else + vars.add('content', TFHIRObjectText.Create('

Not done yet

')); + vars.add('ms', TFHIRObjectText.Create(inttostr(getTickCount64 - ms))); + + //vars.add('matches', TFHIRObjectText.Create(renderJson(json, path, reg, srvr, ver))); + //vars.add('count', TFHIRObjectText.Create(json.forceArr['results'].Count)); + //vars.add('registry', TFHIRObjectText.Create(reg)); + //vars.add('server', TFHIRObjectText.Create(srvr)); + //vars.add('version', TFHIRObjectText.Create(ver)); + //vars.add('url', TFHIRObjectText.Create(tx)); + //vars.add('status', TFHIRObjectText.Create(status)); + returnFile(request, response, nil, request.Document, 'xig.html', false, vars); + finally + vars.free; + end; + finally + ctxt.free; + end; +end; + +procedure TFHIRXIGWebServer.sendResourceHtml(request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; secure : boolean; pid, rtype, id : String); +var + vars : TFslMap; + ms : int64; + ctxt : TFHIRXIGWebContext; +begin + ctxt := getContext; + try + vars := TFslMap.Create('vars'); + try + vars.add('pid', TFHIRObjectText.Create(pid.replace('|', '#'))); + vars.add('rtype', TFHIRObjectText.Create(rtype)); + vars.add('id', TFHIRObjectText.Create(id)); + + ms := getTickCount64; + vars.add('content', TFHIRObjectText.Create(contentRes(ctxt, pid, rtype, id, secure))); + vars.add('ms', TFHIRObjectText.Create(inttostr(getTickCount64 - ms))); + returnFile(request, response, nil, request.Document, 'xig-res.html', false, vars); + finally + vars.free; + end; + finally + ctxt.free; + end; +end; + +function TFHIRXIGWebServer.link: TFHIRXIGWebServer; +begin + result := TFHIRXIGWebServer(inherited link); +end; + +function TFHIRXIGWebServer.logId: string; +begin + result := 'xig'; +end; + +function TFHIRXIGWebServer.PlainRequest(AContext: TIdContext; ip : String; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; id : String; tt : TTimeTracker) : String; +begin + countRequest; + result := doRequest(AContext, request, response, id, false); +end; + + +function TFHIRXIGWebServer.doRequest(AContext: TIdContext; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; id : String; secure : boolean) : String; +var + pm : THTTPParameters; + rtype, auth, realm, ver, rt,text, offs, s : String; + //s : TArray; + //sId : string; + json : TJsonObject; + p : TArray; +begin + pm := THTTPParameters.Create(request.UnparsedParams); + try + if (request.CommandType <> hcGET) then + raise EFslException.Create('The operation '+request.Command+' '+request.Document+' is not supported'); + if request.document = PathWithSlash then + begin + rtype := pm.Value['type']; + auth := pm.Value['auth']; + realm := pm.Value['realm']; + ver := pm.Value['ver']; + offs := pm.Value['offset']; + text := pm.Value['text']; + rt := pm.Value['rt']; + result := 'XIG (type='+rtype+', auth='+auth+', realm='+realm+', ver='+ver+', offset='+offs+', rt='+rt+', text='+text+')'; + sendViewHtml(request, response, secure, rtype, auth, realm, ver, rt, text, offs); + end + else if request.Document.StartsWith(PathWithSlash) then + begin + p := request.Document.subString(PathWithSlash.length).split(['/']); + if (length(p) <> 3) then + raise EFslException.Create('The operation '+request.Command+' '+request.Document+' is not supported') + else + begin + result := 'XIG Resource '+p[0]+'/'+p[1]+'/'+p[2]; + sendResourceHtml(request, response, secure, p[0], p[1], p[2]); + end; + end + else + raise EFslException.Create('The operation '+request.Command+' '+request.Document+' is not supported'); + finally + pm.free; + end; +end; + +function TFHIRXIGWebServer.SecureRequest(AContext: TIdContext; ip : String; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; cert: TIdOpenSSLX509; id: String; tt : TTimeTracker): String; +begin + countRequest; + result := doRequest(AContext, request, response, id, true); +end; + +end. diff --git a/server/fhirserver.lpi b/server/fhirserver.lpi index 658616317..700e8fb19 100644 --- a/server/fhirserver.lpi +++ b/server/fhirserver.lpi @@ -1,3 +1,4 @@ + @@ -20,7 +21,6 @@ - @@ -189,6 +189,11 @@ + + + + + @@ -985,7 +990,7 @@ - + diff --git a/server/kernel.pas b/server/kernel.pas index 58cf8e10c..dd1728145 100644 --- a/server/kernel.pas +++ b/server/kernel.pas @@ -717,7 +717,7 @@ procedure ExecuteFhirServer(params : TCommandLineParameters; ini : TFHIRServerCo {$IFDEF DELPHI} if JclExceptionTrackingActive then - logMsg := !'Using Configuration file '+ini.FileName+' (+stack dumps)' + logMsg := 'Using Configuration file '+ini.FileName+' (+stack dumps)' else {$ENDIF} logMsg := 'Using Configuration file '+ini.FileName; diff --git a/server/tests/tests_cpt.pas b/server/tests/tests_cpt.pas index 43b9b2d7a..f7a7ef5ed 100644 --- a/server/tests/tests_cpt.pas +++ b/server/tests/tests_cpt.pas @@ -1,445 +1,445 @@ -unit tests_cpt; - -{ -Copyright (c) 2011+, HL7 and Health Intersections Pty Ltd (http://www.healthintersections.com.au) -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, -are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of HL7 nor the names of its contributors may be used to - endorse or promote products derived from this software without specific - prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. -IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, -INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. -} - -{$i fhir.inc} - -interface - -uses - SysUtils, Classes, - IdHash, IdHashSHA, - fsl_testing, - fsl_base, fsl_stream, fsl_utilities, fsl_http, - fhir_common, ftx_service, - fdb_sqlite3, - tx_cpt; - -type - - { TCPTTests } - - TCPTTests = Class (TFslTestCase) - private - FCPT : TCPTServices; - - public - Procedure SetUp; override; - procedure TearDown; override; - published - Procedure TestDB; - procedure TestCode; - procedure TestCodeX; - procedure TestCodeMod; - procedure TestCodeModX1; - procedure TestIterator; - - procedure TestModifierFilter; - procedure TestBaseFilter; - procedure TestUnModifiedFilter; - procedure TestModifiedFilter; - procedure TestKindFilter; - - procedure TestExpression1; - procedure TestExpression2; - end; - -procedure registerTests; - -implementation - -procedure registerTests; -// don't use initialization - give other code time to set up directories etc -begin - RegisterTest('Terminology.CPT', TCPTTests.Suite); -end; - -{ TCPTTests } - -procedure TCPTTests.SetUp; -var - fn : String; -begin - if GCPTDataFile <> '' then - fn := GCPTDataFile - else - fn := TestSettings.serverTestFile(['testcases', 'cpt', 'cpt-fragment.db']); - FCPT := TCPTServices.Create(nil, nil, TFDBSQLiteManager.Create('test', fn, true, false, 4)); -end; - -procedure TCPTTests.TearDown; -begin - FCPT.free; -end; - -procedure TCPTTests.TestDB; -begin - assertTrue(FCPT.TotalCount > 0); -end; - -procedure TCPTTests.TestCode; -var - ctxt : TCodeSystemProviderContext; - msg : String; -begin - ctxt := FCPT.locate('99202', nil, msg); - try - assertTrue(ctxt <> nil); - assertEqual('Office or other outpatient visit for the evaluation and management of a new patient, which '+'requires a medically appropriate history and/or examination and straightforward medical decision making. When using time for code selection, 15-29 minutes of total time is spent on the date of the encounter.', FCPT.Display(ctxt, nil)); - finally - ctxt.free; - end; -end; - - -procedure TCPTTests.TestCodeX; -var - ctxt : TCodeSystemProviderContext; - msg : String; -begin - ctxt := FCPT.locate('99201', nil, msg); - try - assertTrue(ctxt = nil); - assertTrue(msg <> ''); - finally - ctxt.free; - end; -end; - -procedure TCPTTests.TestCodeMod; -var - ctxt : TCodeSystemProviderContext; - msg : String; -begin - ctxt := FCPT.locate('99202:P1', nil, msg); - try - assertTrue(ctxt <> nil); - assertEqual('', FCPT.Display(ctxt, nil)); - finally - ctxt.free; - end; -end; - -procedure TCPTTests.TestCodeModX1; -var - ctxt : TCodeSystemProviderContext; - msg : String; -begin - ctxt := FCPT.locate('99202:P1-P1', nil, msg); - try - assertTrue(ctxt = nil); - assertTrue(msg <> ''); - finally - ctxt.free; - end; -end; - -procedure TCPTTests.TestIterator; -var - iter : TCodeSystemIteratorContext; - c : TCodeSystemProviderContext; - s : String; -begin - iter := FCPT.getIterator(nil); - try - while iter.more do - begin - c := FCPT.getNextContext(iter); - try - s := FCPT.code(c); - AssertTrue(StringArrayExists(['metadata-kinds', 'metadata-designations', '99202', '99203', '0001A', '99252', '25', '95', 'P1', '1P', 'F1'], s), 'Unexpected code '+s); - finally - c.free; - end; - end; - finally - iter.free; - end; -end; - -procedure TCPTTests.TestModifierFilter; -var - filter : TCodeSystemProviderFilterContext; - ctxt : TCodeSystemProviderContext; - c : integer; - s, msg : String; -begin - filter := FCPT.filter(true, 'modifier', foEqual, 'true', nil); - try - AssertTrue(filter <> nil); - AssertFalse(FCPT.isNotClosed(nil, filter)); - c := 0; - while FCPT.FilterMore(filter) do - begin - inc(c); - ctxt := FCPT.FilterConcept(filter); - try - s := FCPT.code(ctxt); - AssertTrue(StringArrayExists(['25', '95', 'P1', '1P', 'F1'], s), 'Unexpected code '+s); - finally - ctxt.free; - end; - end; - AssertEqual(5, c); - ctxt := FCPT.locate('99202', nil, msg); - try - AssertFalse(FCPT.inFilter(filter, ctxt)); - finally - ctxt.free; - end; - ctxt := FCPT.locate('P1', nil, msg); - try - AssertTrue(FCPT.inFilter(filter, ctxt)); - finally - ctxt.free; - end; - ctxt := FCPT.locate('99202:P1', nil, msg); - try - AssertFalse(FCPT.inFilter(filter, ctxt)); - finally - ctxt.free; - end; - finally - filter.free; - end; -end; - -procedure TCPTTests.TestBaseFilter; -var - filter : TCodeSystemProviderFilterContext; - ctxt : TCodeSystemProviderContext; - c : integer; - s, msg : String; -begin - filter := FCPT.filter(true, 'modifier', foEqual, 'false', nil); - try - AssertTrue(filter <> Nil); - AssertFalse(FCPT.isNotClosed(nil, filter)); - c := 0; - while FCPT.FilterMore(filter) do - begin - inc(c); - ctxt := FCPT.FilterConcept(filter); - try - s := FCPT.code(ctxt); - AssertTrue(StringArrayExists(['99202', '99203', '0001A', '99252'], s), 'Unexpected code '+s); - finally - ctxt.free; - end; - end; - AssertEqual(4, c); - ctxt := FCPT.locate('99202', nil, msg); - try - AssertTrue(FCPT.inFilter(filter, ctxt)); - finally - ctxt.free; - end; - ctxt := FCPT.locate('P1', nil, msg); - try - AssertFalse(FCPT.inFilter(filter, ctxt)); - finally - ctxt.free; - end; - ctxt := FCPT.locate('99202:P1', nil, msg); - try - AssertFalse(FCPT.inFilter(filter, ctxt)); - finally - ctxt.free; - end; - finally - filter.free; - end; -end; - -procedure TCPTTests.TestUnModifiedFilter; -var - filter : TCodeSystemProviderFilterContext; - ctxt : TCodeSystemProviderContext; - c : integer; - s, msg : String; -begin - filter := FCPT.filter(true, 'modified', foEqual, 'false', nil); - try - AssertTrue(filter <> nil); - AssertFalse(FCPT.isNotClosed(nil, filter)); - c := 0; - while FCPT.FilterMore(filter) do - begin - inc(c); - ctxt := FCPT.FilterConcept(filter); - try - s := FCPT.code(ctxt); - AssertTrue(StringArrayExists(['99202', '99203', '0001A', '99252', '25', 'P1', '1P', 'F1', '95'], s), 'Unexpected code '+s); - finally - ctxt.free; - end; - end; - AssertEqual(9, c); - ctxt := FCPT.locate('99202', nil, msg); - try - AssertTrue(FCPT.inFilter(filter, ctxt)); - finally - ctxt.free; - end; - ctxt := FCPT.locate('P1', nil, msg); - try - AssertTrue(FCPT.inFilter(filter, ctxt)); - finally - ctxt.free; - end; - ctxt := FCPT.locate('99202:P1', nil, msg); - try - AssertFalse(FCPT.inFilter(filter, ctxt)); - finally - ctxt.free; - end; - finally - filter.free; - end; -end; - -procedure TCPTTests.TestModifiedFilter; -var - filter : TCodeSystemProviderFilterContext; - ctxt : TCodeSystemProviderContext; - c : integer; - s, msg : String; -begin - filter := FCPT.filter(true, 'modified', foEqual, 'true', nil); - try - AssertTrue(filter <> nil); - AssertTrue(FCPT.isNotClosed(nil, filter)); - c := 0; - while FCPT.FilterMore(filter) do - inc(c); - AssertEqual(0, c); - ctxt := FCPT.locate('99202', nil, msg); - try - AssertFalse(FCPT.inFilter(filter, ctxt)); - finally - ctxt.free; - end; - ctxt := FCPT.locate('P1', nil, msg); - try - AssertFalse(FCPT.inFilter(filter, ctxt)); - finally - ctxt.free; - end; - ctxt := FCPT.locate('99202:P1', nil, msg); - try - AssertTrue(FCPT.inFilter(filter, ctxt)); - finally - ctxt.free; - end; - finally - filter.free; - end; -end; - -procedure TCPTTests.TestKindFilter; - -var - filter : TCodeSystemProviderFilterContext; - ctxt : TCodeSystemProviderContext; - c : integer; - s, msg : String; -begin - filter := FCPT.filter(true, 'kind', foEqual, 'code', nil); - try - AssertTrue(filter <> nil); - AssertFalse(FCPT.isNotClosed(nil, filter)); - c := 0; - while FCPT.FilterMore(filter) do - begin - inc(c); - ctxt := FCPT.FilterConcept(filter); - try - s := FCPT.code(ctxt); - AssertTrue(StringArrayExists(['99202', '99203', '99252'], s), 'Unexpected code '+s); - finally - ctxt.free; - end; - end; - AssertEqual(3, c); - ctxt := FCPT.locate('99202', nil, msg); - try - AssertTrue(FCPT.inFilter(filter, ctxt)); - finally - ctxt.free; - end; - ctxt := FCPT.locate('P1', nil, msg); - try - AssertFalse(FCPT.inFilter(filter, ctxt)); - finally - ctxt.free; - end; - ctxt := FCPT.locate('99202:P1', nil, msg); - try - AssertFalse(FCPT.inFilter(filter, ctxt)); - finally - ctxt.free; - end; - finally - filter.free; - end; -end; - -procedure TCPTTests.TestExpression1; -var - ctxt : TCodeSystemProviderContext; - msg : String; -begin - ctxt := FCPT.locate('99202:25', nil, msg); - try - assertTrue(ctxt <> nil); - assertTrue(msg = ''); - assertEqual('', FCPT.Display(ctxt, nil)); - finally - ctxt.free; - end; -end; - -procedure TCPTTests.TestExpression2; -var - ctxt : TCodeSystemProviderContext; - msg : String; -begin - ctxt := FCPT.locate('99252:95', nil, msg); - try - assertTrue(ctxt = nil); - assertEqual('The modifier 95 cannot be used with the code 99252 as it is not designated for telemedicine', msg); - assertEqual('', FCPT.Display(ctxt, nil)); - finally - ctxt.free; - end; -end; - -end. - - +unit tests_cpt; + +{ +Copyright (c) 2011+, HL7 and Health Intersections Pty Ltd (http://www.healthintersections.com.au) +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of HL7 nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +} + +{$i fhir.inc} + +interface + +uses + SysUtils, Classes, + IdHash, IdHashSHA, + fsl_testing, + fsl_base, fsl_stream, fsl_utilities, fsl_http, + fhir_common, ftx_service, + fdb_sqlite3, + tx_cpt; + +type + + { TCPTTests } + + TCPTTests = Class (TFslTestCase) + private + FCPT : TCPTServices; + + public + Procedure SetUp; override; + procedure TearDown; override; + published + Procedure TestDB; + procedure TestCode; + procedure TestCodeX; + procedure TestCodeMod; + procedure TestCodeModX1; + procedure TestIterator; + + procedure TestModifierFilter; + procedure TestBaseFilter; + procedure TestUnModifiedFilter; + procedure TestModifiedFilter; + procedure TestKindFilter; + + procedure TestExpression1; + procedure TestExpression2; + end; + +procedure registerTests; + +implementation + +procedure registerTests; +// don't use initialization - give other code time to set up directories etc +begin + RegisterTest('Terminology.CPT', TCPTTests.Suite); +end; + +{ TCPTTests } + +procedure TCPTTests.SetUp; +var + fn : String; +begin + if GCPTDataFile <> '' then + fn := GCPTDataFile + else + fn := TestSettings.serverTestFile(['testcases', 'cpt', 'cpt-fragment.db']); + FCPT := TCPTServices.Create(nil, nil, TFDBSQLiteManager.Create('test', fn, true, false, 4)); +end; + +procedure TCPTTests.TearDown; +begin + FCPT.free; +end; + +procedure TCPTTests.TestDB; +begin + assertTrue(FCPT.TotalCount > 0); +end; + +procedure TCPTTests.TestCode; +var + ctxt : TCodeSystemProviderContext; + msg : String; +begin + ctxt := FCPT.locate('99202', nil, msg); + try + assertTrue(ctxt <> nil); + assertEqual('Office or other outpatient visit for the evaluation and management of a new patient, which '+'requires a medically appropriate history and/or examination and straightforward medical decision making. When using time for code selection, 15-29 minutes of total time is spent on the date of the encounter.', FCPT.Display(ctxt, nil)); + finally + ctxt.free; + end; +end; + + +procedure TCPTTests.TestCodeX; +var + ctxt : TCodeSystemProviderContext; + msg : String; +begin + ctxt := FCPT.locate('99201', nil, msg); + try + assertTrue(ctxt = nil); + assertTrue(msg <> ''); + finally + ctxt.free; + end; +end; + +procedure TCPTTests.TestCodeMod; +var + ctxt : TCodeSystemProviderContext; + msg : String; +begin + ctxt := FCPT.locate('99202:P1', nil, msg); + try + assertTrue(ctxt <> nil); + assertEqual('', FCPT.Display(ctxt, nil)); + finally + ctxt.free; + end; +end; + +procedure TCPTTests.TestCodeModX1; +var + ctxt : TCodeSystemProviderContext; + msg : String; +begin + ctxt := FCPT.locate('99202:P1-P1', nil, msg); + try + assertTrue(ctxt = nil); + assertTrue(msg <> ''); + finally + ctxt.free; + end; +end; + +procedure TCPTTests.TestIterator; +var + iter : TCodeSystemIteratorContext; + c : TCodeSystemProviderContext; + s : String; +begin + iter := FCPT.getIterator(nil); + try + while iter.more do + begin + c := FCPT.getNextContext(iter); + try + s := FCPT.code(c); + AssertTrue(StringArrayExists(['metadata-kinds', 'metadata-designations', '99202', '99203', '0001A', '99252', '25', '95', 'P1', '1P', 'F1'], s), 'Unexpected code '+s); + finally + c.free; + end; + end; + finally + iter.free; + end; +end; + +procedure TCPTTests.TestModifierFilter; +var + filter : TCodeSystemProviderFilterContext; + ctxt : TCodeSystemProviderContext; + c : integer; + s, msg : String; +begin + filter := FCPT.filter(true, 'modifier', foEqual, 'true', nil); + try + AssertTrue(filter <> nil); + AssertFalse(FCPT.isNotClosed(nil, filter)); + c := 0; + while FCPT.FilterMore(filter) do + begin + inc(c); + ctxt := FCPT.FilterConcept(filter); + try + s := FCPT.code(ctxt); + AssertTrue(StringArrayExists(['25', '95', 'P1', '1P', 'F1'], s), 'Unexpected code '+s); + finally + ctxt.free; + end; + end; + AssertEqual(5, c); + ctxt := FCPT.locate('99202', nil, msg); + try + AssertFalse(FCPT.inFilter(filter, ctxt)); + finally + ctxt.free; + end; + ctxt := FCPT.locate('P1', nil, msg); + try + AssertTrue(FCPT.inFilter(filter, ctxt)); + finally + ctxt.free; + end; + ctxt := FCPT.locate('99202:P1', nil, msg); + try + AssertFalse(FCPT.inFilter(filter, ctxt)); + finally + ctxt.free; + end; + finally + filter.free; + end; +end; + +procedure TCPTTests.TestBaseFilter; +var + filter : TCodeSystemProviderFilterContext; + ctxt : TCodeSystemProviderContext; + c : integer; + s, msg : String; +begin + filter := FCPT.filter(true, 'modifier', foEqual, 'false', nil); + try + AssertTrue(filter <> Nil); + AssertFalse(FCPT.isNotClosed(nil, filter)); + c := 0; + while FCPT.FilterMore(filter) do + begin + inc(c); + ctxt := FCPT.FilterConcept(filter); + try + s := FCPT.code(ctxt); + AssertTrue(StringArrayExists(['99202', '99203', '0001A', '99252'], s), 'Unexpected code '+s); + finally + ctxt.free; + end; + end; + AssertEqual(4, c); + ctxt := FCPT.locate('99202', nil, msg); + try + AssertTrue(FCPT.inFilter(filter, ctxt)); + finally + ctxt.free; + end; + ctxt := FCPT.locate('P1', nil, msg); + try + AssertFalse(FCPT.inFilter(filter, ctxt)); + finally + ctxt.free; + end; + ctxt := FCPT.locate('99202:P1', nil, msg); + try + AssertFalse(FCPT.inFilter(filter, ctxt)); + finally + ctxt.free; + end; + finally + filter.free; + end; +end; + +procedure TCPTTests.TestUnModifiedFilter; +var + filter : TCodeSystemProviderFilterContext; + ctxt : TCodeSystemProviderContext; + c : integer; + s, msg : String; +begin + filter := FCPT.filter(true, 'modified', foEqual, 'false', nil); + try + AssertTrue(filter <> nil); + AssertFalse(FCPT.isNotClosed(nil, filter)); + c := 0; + while FCPT.FilterMore(filter) do + begin + inc(c); + ctxt := FCPT.FilterConcept(filter); + try + s := FCPT.code(ctxt); + AssertTrue(StringArrayExists(['99202', '99203', '0001A', '99252', '25', 'P1', '1P', 'F1', '95'], s), 'Unexpected code '+s); + finally + ctxt.free; + end; + end; + AssertEqual(9, c); + ctxt := FCPT.locate('99202', nil, msg); + try + AssertTrue(FCPT.inFilter(filter, ctxt)); + finally + ctxt.free; + end; + ctxt := FCPT.locate('P1', nil, msg); + try + AssertTrue(FCPT.inFilter(filter, ctxt)); + finally + ctxt.free; + end; + ctxt := FCPT.locate('99202:P1', nil, msg); + try + AssertFalse(FCPT.inFilter(filter, ctxt)); + finally + ctxt.free; + end; + finally + filter.free; + end; +end; + +procedure TCPTTests.TestModifiedFilter; +var + filter : TCodeSystemProviderFilterContext; + ctxt : TCodeSystemProviderContext; + c : integer; + s, msg : String; +begin + filter := FCPT.filter(true, 'modified', foEqual, 'true', nil); + try + AssertTrue(filter <> nil); + AssertTrue(FCPT.isNotClosed(nil, filter)); + c := 0; + while FCPT.FilterMore(filter) do + inc(c); + AssertEqual(0, c); + ctxt := FCPT.locate('99202', nil, msg); + try + AssertFalse(FCPT.inFilter(filter, ctxt)); + finally + ctxt.free; + end; + ctxt := FCPT.locate('P1', nil, msg); + try + AssertFalse(FCPT.inFilter(filter, ctxt)); + finally + ctxt.free; + end; + ctxt := FCPT.locate('99202:P1', nil, msg); + try + AssertTrue(FCPT.inFilter(filter, ctxt)); + finally + ctxt.free; + end; + finally + filter.free; + end; +end; + +procedure TCPTTests.TestKindFilter; + +var + filter : TCodeSystemProviderFilterContext; + ctxt : TCodeSystemProviderContext; + c : integer; + s, msg : String; +begin + filter := FCPT.filter(true, 'kind', foEqual, 'code', nil); + try + AssertTrue(filter <> nil); + AssertFalse(FCPT.isNotClosed(nil, filter)); + c := 0; + while FCPT.FilterMore(filter) do + begin + inc(c); + ctxt := FCPT.FilterConcept(filter); + try + s := FCPT.code(ctxt); + AssertTrue(StringArrayExists(['99202', '99203', '99252'], s), 'Unexpected code '+s); + finally + ctxt.free; + end; + end; + AssertEqual(3, c); + ctxt := FCPT.locate('99202', nil, msg); + try + AssertTrue(FCPT.inFilter(filter, ctxt)); + finally + ctxt.free; + end; + ctxt := FCPT.locate('P1', nil, msg); + try + AssertFalse(FCPT.inFilter(filter, ctxt)); + finally + ctxt.free; + end; + ctxt := FCPT.locate('99202:P1', nil, msg); + try + AssertFalse(FCPT.inFilter(filter, ctxt)); + finally + ctxt.free; + end; + finally + filter.free; + end; +end; + +procedure TCPTTests.TestExpression1; +var + ctxt : TCodeSystemProviderContext; + msg : String; +begin + ctxt := FCPT.locate('99202:25', nil, msg); + try + assertTrue(ctxt <> nil); + assertTrue(msg = ''); + assertEqual('', FCPT.Display(ctxt, nil)); + finally + ctxt.free; + end; +end; + +procedure TCPTTests.TestExpression2; +var + ctxt : TCodeSystemProviderContext; + msg : String; +begin + ctxt := FCPT.locate('99252:95', nil, msg); + try + assertTrue(ctxt = nil); + assertEqual('The modifier 95 cannot be used with the code 99252 as it is not designated for telemedicine', msg); + assertEqual('', FCPT.Display(ctxt, nil)); + finally + ctxt.free; + end; +end; + +end. + + diff --git a/server/tx/tx_cpt.pas b/server/tx/tx_cpt.pas index 526f61e26..953d63aa2 100644 --- a/server/tx/tx_cpt.pas +++ b/server/tx/tx_cpt.pas @@ -1,977 +1,977 @@ -unit tx_cpt; - -{ -Copyright (c) 2011+, HL7 and Health Intersections Pty Ltd (http://www.healthintersections.com.au) -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, -are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of HL7 nor the names of its contributors may be used to - endorse or promote products derived from this software without specific - prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. -IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, -INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. -} - -{$i fhir.inc} - -interface - -uses - SysUtils, Classes, Generics.Collections, - fsl_base, fsl_utilities, fsl_http, fsl_threads, fsl_lang, fsl_logging, fsl_i18n, - fdb_manager, fdb_dialects, - fhir_objects, fhir_common, fhir_factory, fhir_utilities, fhir_features, fhir_uris, - fhir_cdshooks, - ftx_service; - -type - { TCPTConceptDesignation } - - TCPTConceptDesignation = class (TFslObject) - private - FKind: String; - FValue: String; - public - Function Link : TCPTConceptDesignation; overload; - - property kind : String read FKind write FKind; - property value : String read FValue write FValue; - end; - - { TCPTConceptProperty } - - TCPTConceptProperty = class (TFslObject) - private - FName: String; - FValue: String; - public - Function Link : TCPTConceptProperty; overload; - - property name : String read FName write FName; - property value : String read FValue write FValue; - end; - - { TCPTConcept } - - TCPTConcept = class (TCodeSystemProviderContext) - private - FCode: String; - FModifier: boolean; - FDesignations: TFslList; - FProperties: TFslList; - public - constructor Create; override; - destructor Destroy; Override; - Function Link : TCPTConcept; overload; - - property code : String read FCode write FCode; - property modifier : boolean read FModifier write FModifier; - property designations : TFslList read FDesignations; - property properties : TFslList read FProperties; - - procedure addProperty(name, value: String); - function hasProperty(name, value: String) : boolean; - procedure addDesignation(kind, value: String); - function getDesignation(kind: String) : String; - end; - - { TCPTFilterContext } - - TCPTFilterContext = class (TCodeSystemProviderFilterContext) - private - FName : String; - FClosed : boolean; - FIndex : integer; - FList : TFslList; - public - constructor Create(name : String; list : TFslList; closed : boolean); - destructor Destroy; override; - - property closed : boolean read FClosed; - property index : integer read FIndex; - property list : TFslList read FList; - - procedure next; - end; - - { TCPTExpression } - - TCPTExpression = class (TCodeSystemProviderContext) - private - FFocus: TCPTConcept; - FModifiers: TFslList; - procedure SetFocus(AValue: TCPTConcept); - public - constructor Create; override; - destructor Destroy; Override; - Function Link : TCPTExpression; overload; - - property focus : TCPTConcept read FFocus write SetFocus; - property modifiers : TFslList read FModifiers; - - function expression : String; - function hasModifier(code : String) : boolean; - end; - - { TCPTIteratorContext } - - TCPTIteratorContext = class (TCodeSystemIteratorContext) - private - FList : TFslList; - public - constructor Create(list : TFslList); - destructor Destroy; Override; - end; - - { TCPTServices } - - TCPTServices = class (TCodeSystemProvider) - private - db : TFDBManager; - FVersion : String; - FMap : TFslMap; - FList : TFslList; - FBase : TFslList; - FModifier : TFslList; - - function validateExpression(exp : TCPTExpression) : String; - function parse(code : String; var msg : String) : TCPTExpression; - procedure load; - public - constructor Create(languages : TIETFLanguageDefinitions; i18n : TI18nSupport; db : TFDBManager); - destructor Destroy; Override; - Function Link : TCPTServices; overload; - - class function checkDB(conn : TFDBConnection) : String; - - function expandLimitation : Integer; override; - function systemUri : String; override; - function version : String; override; - function name(context : TCodeSystemProviderContext) : String; override; - function description : String; override; - function TotalCount : integer; override; - function getIterator(context : TCodeSystemProviderContext) : TCodeSystemIteratorContext; override; - function getNextContext(context : TCodeSystemIteratorContext) : TCodeSystemProviderContext; override; - function getDisplay(code : String; langList : THTTPLanguageList):String; override; - function getDefinition(code : String):String; override; - function locate(code : String; altOpt : TAlternateCodeOptions; var message : String) : TCodeSystemProviderContext; override; - function locateIsA(code, parent : String; disallowParent : boolean = false) : TCodeSystemProviderContext; override; - function sameContext(a, b : TCodeSystemProviderContext) : boolean; override; - function IsAbstract(context : TCodeSystemProviderContext) : boolean; override; - function Code(context : TCodeSystemProviderContext) : string; override; - function Display(context : TCodeSystemProviderContext; langList : THTTPLanguageList) : string; override; - procedure Designations(context : TCodeSystemProviderContext; list : TConceptDesignations); override; - function Definition(context : TCodeSystemProviderContext) : string; override; - - function searchFilter(filter : TSearchFilterText; prep : TCodeSystemProviderFilterPreparationContext; sort : boolean) : TCodeSystemProviderFilterContext; override; - function filter(forIteration : boolean; prop : String; op : TFhirFilterOperator; value : String; prep : TCodeSystemProviderFilterPreparationContext) : TCodeSystemProviderFilterContext; override; - function filterLocate(ctxt : TCodeSystemProviderFilterContext; code : String; var message : String) : TCodeSystemProviderContext; override; - function FilterMore(ctxt : TCodeSystemProviderFilterContext) : boolean; override; - function filterSize(ctxt : TCodeSystemProviderFilterContext) : integer; override; - function FilterConcept(ctxt : TCodeSystemProviderFilterContext): TCodeSystemProviderContext; override; - function InFilter(ctxt : TCodeSystemProviderFilterContext; concept : TCodeSystemProviderContext) : Boolean; override; - function isNotClosed(textFilter : TSearchFilterText; propFilter : TCodeSystemProviderFilterContext = nil) : boolean; override; - procedure getCDSInfo(card : TCDSHookCard; langList : THTTPLanguageList; baseURL, code, display : String); override; - procedure extendLookup(factory : TFHIRFactory; ctxt : TCodeSystemProviderContext; langList : THTTPLanguageList; props : TArray; resp : TFHIRLookupOpResponseW); override; - //function subsumes(codeA, codeB : String) : String; override; - - procedure defineFeatures(features : TFslList); override; - end; - -implementation - -{ TCPTFilterContext } - -constructor TCPTFilterContext.Create(name : String; list: TFslList; closed: boolean); -var - i : integer; - s : String; -begin - inherited Create; - FName := name; - FList := list; - FClosed := closed; - FIndex := -1; - s := ''; - for i := 0 to integerMin(list.count, 50) - 1 do - s := s+list[i].code+','; - for i := integerMax(0, list.count - 10) to list.count - 1 do - s := s+','+list[i].code; - Logging.log('CPT filter '+name+': '+inttostr(list.count)+' concepts in filter (closed = '+boolToStr(FClosed)+'): '+s); -end; - -destructor TCPTFilterContext.Destroy; -begin - FList.free; - inherited Destroy; -end; - -procedure TCPTFilterContext.next; -begin - inc(FIndex); -end; - -{ TCPTIteratorContext } - -constructor TCPTIteratorContext.Create(list: TFslList); -begin - if list = nil then - inherited Create(nil, 0) - else - inherited Create(nil, list.Count); - FList := list; -end; - -destructor TCPTIteratorContext.Destroy; -begin - FList.free; - inherited Destroy; -end; - -{ TCPTConceptProperty } - -function TCPTConceptProperty.Link: TCPTConceptProperty; -begin - result := TCPTConceptProperty(inherited Link); -end; - - -{ TCPTConceptDesignation } - -function TCPTConceptDesignation.Link: TCPTConceptDesignation; -begin - result := TCPTConceptDesignation(inherited link); -end; - -{ TCPTConcept } - -constructor TCPTConcept.Create; -begin - inherited Create; - FDesignations := TFslList.Create; - FProperties := TFslList.Create; -end; - -destructor TCPTConcept.Destroy; -begin - FProperties.free; - FDesignations.free; - inherited Destroy; -end; - -function TCPTConcept.Link: TCPTConcept; -begin - result := TCPTConcept(inherited link); -end; - -procedure TCPTConcept.addProperty(name, value: String); -var - p : TCPTConceptProperty; -begin - p := TCPTConceptProperty.Create; - try - p.name := name; - p.value := value; - FProperties.add(p.link); - finally - p.free; - end; -end; - -function TCPTConcept.hasProperty(name, value: String): boolean; -var - c : TCPTConceptProperty; -begin - result := false; - for c in Properties do - if (c.name = name) and (c.value = value) then - exit(true); -end; - -procedure TCPTConcept.addDesignation(kind, value: String); -var - d : TCPTConceptDesignation; -begin - d := TCPTConceptDesignation.Create; - try - d.kind := kind; - d.value := value; - FDesignations.add(d.link); - finally - d.free; - end; -end; - -function TCPTConcept.getDesignation(kind: String): String; -var - d : TCPTConceptDesignation; -begin - result := ''; - for d in FDesignations do - if (d.kind = kind) then - exit(d.value); -end; - -{ TCPTExpression } - -constructor TCPTExpression.Create; -begin - inherited Create; - FModifiers := TFslList.Create; -end; - -destructor TCPTExpression.Destroy; -begin - FModifiers.free; - FFocus.free; - inherited Destroy; -end; - -function TCPTExpression.Link: TCPTExpression; -begin - result := TCPTExpression(inherited link); -end; - -function TCPTExpression.expression: String; -var - m : TCPTConcept; -begin - result := focus.code; - for m in modifiers do - result := result + ':' + m.code; -end; - -function TCPTExpression.hasModifier(code: String): boolean; -var - modifier : TCPTConcept; -begin - result := false; - for modifier in modifiers do - if modifier.code = code then - exit(true); -end; - -procedure TCPTExpression.SetFocus(AValue: TCPTConcept); -begin - FFocus.free; - FFocus := AValue; -end; - -{ TCPTServices } - -constructor TCPTServices.Create(languages : TIETFLanguageDefinitions; i18n : TI18nSupport; db : TFDBManager); -begin - inherited Create(languages, i18n); - FMap := TFslMap.Create; - FMap.defaultValue := nil; - FList := TFslList.Create; - FBase := TFslList.Create; - FModifier := TFslList.Create; - self.db := db; - load; -end; - -destructor TCPTServices.Destroy; -begin - db.free; - FMap.free; - FBase.free; - FModifier.free; - FList.free; - inherited Destroy; -end; - -function TCPTServices.Link: TCPTServices; -begin - result := TCPTServices(inherited link); -end; - -class function TCPTServices.checkDB(conn : TFDBConnection) : String; -var - meta : TFDBMetaData; -begin - meta := conn.FetchMetaData; - try - if not meta.HasTable('Information') or not meta.HasTable('Concepts') or not meta.HasTable('Designations') or not meta.HasTable('Properties') then - result := 'Missing Tables - needs re-importing' - else - result := 'OK ('+inttostr(conn.countSql('Select count(*) from Concepts'))+' Concepts)'; - finally - meta.free; - end; -end; - -function TCPTServices.expandLimitation: Integer; -begin - Result := 1000; // agreement with AMA -end; - -procedure checkMutuallyExclusive(list : TStringList; exp : TCPTExpression; modifiers : Array of String); -var - modifier : TCPTConcept; - c : integer; -begin - c := 0; - for modifier in exp.modifiers do - if StringArrayExists(modifiers, modifier.code) then - inc(c); - if c > 1 then - list.add('There can only one modifier in the set '+StringArrayToString(modifiers)); -end; - -function codeInSet(code, min, max : String) : boolean; -begin - result := (code >= min) and (code <= max); -end; - -function TCPTServices.validateExpression(exp: TCPTExpression): String; -var - modifier : TCPTConcept; - prop : TCPTConceptProperty; - list : TStringList; - s : string; -begin - list := TStringList.Create; - try - for modifier in exp.modifiers do - begin - for prop in modifier.properties do - begin - if prop.name = 'kind' then - begin - if prop.value = 'cat-2' then - begin - if not exp.focus.hasProperty('kind', 'cat-2') then - list.add('The modifier '+modifier.code+' is a cat-2 modifier that can only be used with cat-2 codes'); - end; - if (prop.value = 'physical') then - begin - if (exp.focus.code < '00100') or (exp.focus.code > '01999') then - list.add('The modifier '+modifier.code+' is a physical status modifier that can only be used with codes in the range 00100 - 01999'); - end; - if (prop.value = 'hcpcs') then - begin - if (not exp.hasModifier('59')) then - list.add('The modifier '+modifier.code+' is an hcpcs code that can only be used if the modifier 59 is also used'); - end; - end; - end; - // specific rules: - if (modifier.code = '50') or (modifier.code = '51') then - begin - if exp.focus.hasProperty('kind', 'cat-2') then - list.add('The modifier '+modifier.code+' cannot be used with cat-2 codes'); - end; - if (modifier.code = '63') then - begin - if not codeInSet(exp.focus.code, '20100', '69990') and not StringArrayExists(['92920', '92928', '92953', '92960', '92986', '92987', '92990', '92997', '92998', '93312', '93313', '93314', '93315', '93316', '93317', '93318', '93452', '93505', '93563', '93564', '93568', '93569', '93573', '93574', '93575', '93580', '93581', '93582', '93590', '93591', '93592', '93593', '93594', '93595', '93596', '93597', '93598', '93615', '93616'], - exp.focus.code) then - list.add('The modifier '+modifier.code+' cannot be used with the code '+exp.focus.code); - end; - if (modifier.code = '92') then - begin - if not codeInSet(exp.focus.code, '86701' ,'86703') and (exp.focus.code <> '87389') then - list.add('The modifier '+modifier.code+' cannot be used with the code '+exp.focus.code); - end; - if (modifier.code = '95') then - begin - if not exp.focus.hasProperty('telemedicine', 'true') then - list.add('The modifier '+modifier.code+' cannot be used with the code '+exp.focus.code+' as it is not designated for telemedicine'); - end; - // 76 | 77: not to an E/M service - end; - checkMutuallyExclusive(list, exp, ['25', '57', '59']); - checkMutuallyExclusive(list, exp, ['52', '53', '73', '74']); - checkMutuallyExclusive(list, exp, ['76', '77', '78', '79']); - checkMutuallyExclusive(list, exp, ['93', '95']); - result := ''; - for s in list do - CommaAdd(result, s); - finally - list.free; - end; -end; - -function TCPTServices.parse(code: String; var msg: String): TCPTExpression; -var - parts : TArray; - i : integer; - c : TCPTConcept; - exp : TCPTExpression; -begin - result := nil; - if (code = '') then - msg := 'No Expression Found' - else - begin - msg := ''; - parts := code.split([':']); - c := FMap[parts[0]]; - if (c = nil) then - msg := 'Base CPT Code '''+parts[0]+''' not found' - else - begin - exp := TCPTExpression.Create; - try - exp.focus := c.link; - for i := 1 to length(parts) - 1 do - begin - c := FMap[parts[i]]; - if c = nil then - begin - msg := 'Modifier CPT code '''+parts[i]+''' not found'; - exit(nil); - end - else - exp.modifiers.add(c.link); - end; - msg := validateExpression(exp); - if (msg <> '') then - result := nil - else - result := exp.link; - finally - exp.free; - end; - end; - end; -end; - -procedure TCPTServices.load; -var - conn : TFDBConnection; - c : TCPTConcept; -begin - conn := db.GetConnection('load'); - try - conn.SQL := 'Select * from Information'; - conn.prepare; - conn.Execute; - while conn.FetchNext do - if conn.ColStringByName['name'] = 'version' then - FVersion := conn.ColStringByName['value']; - conn.terminate; - - conn.SQL := 'Select * from Concepts'; - conn.prepare; - conn.Execute; - while conn.FetchNext do - begin - c := TCPTConcept.Create; - try - c.code := conn.ColStringByName['code']; - c.modifier := conn.ColIntegerByName['modifier'] = 1; - FMap.Add(c.code, c.link); - if c.modifier then - FModifier.Add(c.link) - else - FBase.Add(c.link); - FList.add(c.Link); - finally - c.free; - end; - end; - conn.terminate; - - conn.SQL := 'Select * from Properties'; - conn.prepare; - conn.Execute; - while conn.FetchNext do - begin - c := FMap[conn.ColStringByName['code']]; - c.addProperty(conn.ColStringByName['name'], conn.ColStringByName['value']); - end; - conn.terminate; - - conn.SQL := 'Select * from Designations'; - conn.prepare; - conn.Execute; - while conn.FetchNext do - begin - c := FMap[conn.ColStringByName['code']]; - c.addDesignation(conn.ColStringByName['type'], conn.ColStringByName['value']); - end; - conn.terminate; - - conn.Release; - except - on e : Exception do - begin - conn.Error(e); - recordStack(e); - raise; - end; - end; -end; - -function TCPTServices.systemUri : String; -begin - result := 'http://www.ama-assn.org/go/cpt'; -end; - -function TCPTServices.version : String; -begin - result := FVersion; -end; - -function TCPTServices.name(context : TCodeSystemProviderContext) : String; -begin - result := 'AmaCPT'; -end; - -function TCPTServices.description : String; -begin - result := 'CPT © Copyright 2019 American Medical Association. All rights reserved. AMA and CPT are registered trademarks of the American Medical Association.'; -end; - -function TCPTServices.TotalCount : integer; -begin - result := FMap.Count; -end; - -function TCPTServices.locate(code : String; altOpt : TAlternateCodeOptions; var message : String) : TCodeSystemProviderContext; -begin - if code.Contains(':') then - begin - result := parse(code, message); - end - else - begin - result := FMap[code].link; - if result = nil then - message := 'Code '''+code+''' not found in CPT'; - end; -end; - -function TCPTServices.getDisplay(code : String; langList : THTTPLanguageList):String; -var - c : TCPTConcept; -begin - c := FMap[code]; - if (c = nil) or c.designations.Empty then - result := '' - else - result := c.designations[0].value; -end; - -function TCPTServices.getDefinition(code : String):String; -var - c : TCPTConcept; -begin - c := FMap[code]; - if (c = nil) or c.designations.Empty then - result := '' - else - result := c.designations[0].value; -end; - - -function TCPTServices.locateIsA(code, parent : String; disallowParent : boolean = false) : TCodeSystemProviderContext; -begin - result := nil; -end; - -function TCPTServices.sameContext(a, b : TCodeSystemProviderContext) : boolean; -begin - result := a = b; -end; - -function TCPTServices.IsAbstract(context : TCodeSystemProviderContext) : boolean; -var - e : TCPTExpression; - c : TCPTConcept; -begin - if (context is TCPTExpression) then - begin - e := (context as TCPTExpression); - result := false; - end - else - begin - c := (context as TCPTConcept); - result := c.hasProperty('kind', 'metadata'); - end; -end; - -function TCPTServices.Code(context : TCodeSystemProviderContext) : string; -var - e : TCPTExpression; - c : TCPTConcept; -begin - if (context is TCPTExpression) then - begin - e := (context as TCPTExpression); - result := e.expression; - end - else - begin - c := (context as TCPTConcept); - result := c.code; - end; -end; - -function TCPTServices.Display(context : TCodeSystemProviderContext; langList : THTTPLanguageList) : string; -var - e : TCPTExpression; - c : TCPTConcept; -begin - if (context = nil) then - result := '' - else if (context is TCPTExpression) then - begin - e := (context as TCPTExpression); - result := ''; - end - else - begin - c := (context as TCPTConcept); - if c.designations.Empty then - result := '' - else - result := c.designations[0].value; - end; -end; - -procedure TCPTServices.Designations(context : TCodeSystemProviderContext; list : TConceptDesignations); -var - c : TCPTConcept; - d : TCPTConceptDesignation; - e : TCPTExpression; -begin - if (context is TCPTExpression) then - begin - e := (context as TCPTExpression); - // no text for expressions - end - else - begin - c := (context as TCPTConcept); - c := (context as TCPTConcept); - for d in c.designations do - list.addDesignation(d.kind = 'display', d.kind = 'display', 'en', d.value); - end; -end; - -function TCPTServices.Definition(context : TCodeSystemProviderContext) : string; -begin - result := Display(context, nil); -end; - -procedure TCPTServices.getCDSInfo(card : TCDSHookCard; langList : THTTPLanguageList; baseURL, code, display : String); -begin -end; - -procedure TCPTServices.extendLookup(factory : TFHIRFactory; ctxt : TCodeSystemProviderContext; langList : THTTPLanguageList; props : TArray; resp : TFHIRLookupOpResponseW); - -var - c : TCPTConcept; - d : TCPTConceptDesignation; - p : TCPTConceptProperty; - pp: TFHIRLookupOpRespPropertyW; - pp1 : TFHIRLookupOpRespSubPropertyW; - e : TCPTExpression; -begin - if (ctxt is TCPTExpression) then - begin - e := (ctxt as TCPTExpression); - extendLookup(factory, e.focus, langList, props, resp); - for c in e.modifiers do - begin - pp := resp.addProp('modifier'); - pp1 := pp.addSubProp('code'); - pp1.value := c.code; - if (not c.designations.Empty) then - begin - pp1 := pp.addSubProp('definition'); - pp1.value := c.designations[0].value; - end; - end; - end - else - begin - pp := resp.addProp('copyright'); - pp.value := factory.makeString('This response content from SNOMED CT, which is copyright ) 2002+ International Health Terminology Standards Development Organisation (IHTSDO), and distributed '+'by agreement between IHTSDO and HL7. Implementer use of SNOMED CT is not covered by this agreement'); - - c := (ctxt as TCPTConcept); - if hasProp(props, 'designation', true) then - for d in c.designations do - resp.addDesignation('en', 'http://www.ama-assn.org/go/cpt', '', d.kind, d.value); - - for p in c.properties do - begin - if hasProp(props, p.name, true) then - begin - pp := resp.addProp(p.name); - pp.value := factory.makeString(p.value); - end; - end; - end; -end; - - -function TCPTServices.getIterator(context : TCodeSystemProviderContext) : TCodeSystemIteratorContext; -begin - if (context = nil) then - result := TCPTIteratorContext.Create(FList.link) - else - result := TCPTIteratorContext.Create(nil); -end; - -function TCPTServices.getNextContext(context : TCodeSystemIteratorContext) : TCodeSystemProviderContext; -var - c : TCPTIteratorContext; -begin - c := context as TCPTIteratorContext; - if (c.FList = nil) or (c.current >= c.FList.Count) then - result := nil - else - result := c.FList[c.current].link; - context.next; -end; - - -function TCPTServices.searchFilter(filter : TSearchFilterText; prep : TCodeSystemProviderFilterPreparationContext; sort : boolean) : TCodeSystemProviderFilterContext; -begin - raise ETerminologyError.Create('Not supported yet', itBusinessRule); -end; - -function TCPTServices.filter(forIteration : boolean; prop : String; op : TFhirFilterOperator; value : String; prep : TCodeSystemProviderFilterPreparationContext) : TCodeSystemProviderFilterContext; -var - list : TFslList; - item : TCPTConcept; - b : boolean; -begin - // filters supported - // * modified = false - // * modifier = true / false - // * kind = x - - // todo: - // code in 86701-86703;87389-87389 - - if (prop = 'modifier') then - begin - b := value = 'true'; - if b then - result := TCPTFilterContext.Create('modifier:true', FModifier.link, true) - else - result := TCPTFilterContext.Create('modifier:false', FBase.link, true) - end - else if (prop = 'modified') and (op = foEqual) then - begin - b := value = 'true'; - if (b) then - result := TCPTFilterContext.Create('modified:true', TFslList.create, false) - else - result := TCPTFilterContext.Create('modified:false', FList.link, true); - end - else if (prop = 'kind') and (op = foEqual) then - begin - list := TFslList.Create; - try - for item in Flist do - if item.hasProperty('kind', value) then - list.add(item.link); - result := TCPTFilterContext.Create('kind:'+value, list.link, true); - finally - list.free; - end; - end - else - result := nil; -end; - -function TCPTServices.filterLocate(ctxt : TCodeSystemProviderFilterContext; code : String; var message : String) : TCodeSystemProviderContext; -var - fc : TCPTFilterContext; - c : TCPTConcept; -begin - fc := ctxt as TCPTFilterContext; - result := nil; - for c in fc.FList do - if (c.code = code) then - exit(c.link); -end; - -function TCPTServices.FilterMore(ctxt : TCodeSystemProviderFilterContext) : boolean; -var - fc : TCPTFilterContext; -begin - fc := ctxt as TCPTFilterContext; - fc.next; - result := (fc.Index < fc.Flist.count); -end; - -function TCPTServices.filterSize(ctxt: TCodeSystemProviderFilterContext): integer; -var - fc : TCPTFilterContext; -begin - fc := ctxt as TCPTFilterContext; - result := fc.Flist.count; -end; - -function TCPTServices.FilterConcept(ctxt : TCodeSystemProviderFilterContext): TCodeSystemProviderContext; -var - fc : TCPTFilterContext; -begin - fc := ctxt as TCPTFilterContext; - result := fc.FList[fc.index].link; -end; - -function TCPTServices.InFilter(ctxt : TCodeSystemProviderFilterContext; concept : TCodeSystemProviderContext) : Boolean; -var - fc : TCPTFilterContext; - e : TCPTExpression; - c : TCPTConcept; -begin - fc := ctxt as TCPTFilterContext; - if (concept is TCPTExpression) then - begin - e := (concept as TCPTExpression); - result := not fc.closed; - end - else - begin - c := (concept as TCPTConcept); - result := fc.FList.contains(c); - //Logging.log(c.code +' in '+fc.FName+': '+boolToStr(result)); - end; -end; - -function TCPTServices.isNotClosed(textFilter : TSearchFilterText; propFilter : TCodeSystemProviderFilterContext = nil) : boolean; -var - fc : TCPTFilterContext; -begin - if propFilter = nil then - result := true - else - begin - fc := propFilter as TCPTFilterContext; - result := not fc.closed; - end; -end; - -procedure TCPTServices.defineFeatures(features : TFslList); -begin - // nothing -end; - - -end. - +unit tx_cpt; + +{ +Copyright (c) 2011+, HL7 and Health Intersections Pty Ltd (http://www.healthintersections.com.au) +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of HL7 nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +} + +{$i fhir.inc} + +interface + +uses + SysUtils, Classes, Generics.Collections, + fsl_base, fsl_utilities, fsl_http, fsl_threads, fsl_lang, fsl_logging, fsl_i18n, + fdb_manager, fdb_dialects, + fhir_objects, fhir_common, fhir_factory, fhir_utilities, fhir_features, fhir_uris, + fhir_cdshooks, + ftx_service; + +type + { TCPTConceptDesignation } + + TCPTConceptDesignation = class (TFslObject) + private + FKind: String; + FValue: String; + public + Function Link : TCPTConceptDesignation; overload; + + property kind : String read FKind write FKind; + property value : String read FValue write FValue; + end; + + { TCPTConceptProperty } + + TCPTConceptProperty = class (TFslObject) + private + FName: String; + FValue: String; + public + Function Link : TCPTConceptProperty; overload; + + property name : String read FName write FName; + property value : String read FValue write FValue; + end; + + { TCPTConcept } + + TCPTConcept = class (TCodeSystemProviderContext) + private + FCode: String; + FModifier: boolean; + FDesignations: TFslList; + FProperties: TFslList; + public + constructor Create; override; + destructor Destroy; Override; + Function Link : TCPTConcept; overload; + + property code : String read FCode write FCode; + property modifier : boolean read FModifier write FModifier; + property designations : TFslList read FDesignations; + property properties : TFslList read FProperties; + + procedure addProperty(name, value: String); + function hasProperty(name, value: String) : boolean; + procedure addDesignation(kind, value: String); + function getDesignation(kind: String) : String; + end; + + { TCPTFilterContext } + + TCPTFilterContext = class (TCodeSystemProviderFilterContext) + private + FName : String; + FClosed : boolean; + FIndex : integer; + FList : TFslList; + public + constructor Create(name : String; list : TFslList; closed : boolean); + destructor Destroy; override; + + property closed : boolean read FClosed; + property index : integer read FIndex; + property list : TFslList read FList; + + procedure next; + end; + + { TCPTExpression } + + TCPTExpression = class (TCodeSystemProviderContext) + private + FFocus: TCPTConcept; + FModifiers: TFslList; + procedure SetFocus(AValue: TCPTConcept); + public + constructor Create; override; + destructor Destroy; Override; + Function Link : TCPTExpression; overload; + + property focus : TCPTConcept read FFocus write SetFocus; + property modifiers : TFslList read FModifiers; + + function expression : String; + function hasModifier(code : String) : boolean; + end; + + { TCPTIteratorContext } + + TCPTIteratorContext = class (TCodeSystemIteratorContext) + private + FList : TFslList; + public + constructor Create(list : TFslList); + destructor Destroy; Override; + end; + + { TCPTServices } + + TCPTServices = class (TCodeSystemProvider) + private + db : TFDBManager; + FVersion : String; + FMap : TFslMap; + FList : TFslList; + FBase : TFslList; + FModifier : TFslList; + + function validateExpression(exp : TCPTExpression) : String; + function parse(code : String; var msg : String) : TCPTExpression; + procedure load; + public + constructor Create(languages : TIETFLanguageDefinitions; i18n : TI18nSupport; db : TFDBManager); + destructor Destroy; Override; + Function Link : TCPTServices; overload; + + class function checkDB(conn : TFDBConnection) : String; + + function expandLimitation : Integer; override; + function systemUri : String; override; + function version : String; override; + function name(context : TCodeSystemProviderContext) : String; override; + function description : String; override; + function TotalCount : integer; override; + function getIterator(context : TCodeSystemProviderContext) : TCodeSystemIteratorContext; override; + function getNextContext(context : TCodeSystemIteratorContext) : TCodeSystemProviderContext; override; + function getDisplay(code : String; langList : THTTPLanguageList):String; override; + function getDefinition(code : String):String; override; + function locate(code : String; altOpt : TAlternateCodeOptions; var message : String) : TCodeSystemProviderContext; override; + function locateIsA(code, parent : String; disallowParent : boolean = false) : TCodeSystemProviderContext; override; + function sameContext(a, b : TCodeSystemProviderContext) : boolean; override; + function IsAbstract(context : TCodeSystemProviderContext) : boolean; override; + function Code(context : TCodeSystemProviderContext) : string; override; + function Display(context : TCodeSystemProviderContext; langList : THTTPLanguageList) : string; override; + procedure Designations(context : TCodeSystemProviderContext; list : TConceptDesignations); override; + function Definition(context : TCodeSystemProviderContext) : string; override; + + function searchFilter(filter : TSearchFilterText; prep : TCodeSystemProviderFilterPreparationContext; sort : boolean) : TCodeSystemProviderFilterContext; override; + function filter(forIteration : boolean; prop : String; op : TFhirFilterOperator; value : String; prep : TCodeSystemProviderFilterPreparationContext) : TCodeSystemProviderFilterContext; override; + function filterLocate(ctxt : TCodeSystemProviderFilterContext; code : String; var message : String) : TCodeSystemProviderContext; override; + function FilterMore(ctxt : TCodeSystemProviderFilterContext) : boolean; override; + function filterSize(ctxt : TCodeSystemProviderFilterContext) : integer; override; + function FilterConcept(ctxt : TCodeSystemProviderFilterContext): TCodeSystemProviderContext; override; + function InFilter(ctxt : TCodeSystemProviderFilterContext; concept : TCodeSystemProviderContext) : Boolean; override; + function isNotClosed(textFilter : TSearchFilterText; propFilter : TCodeSystemProviderFilterContext = nil) : boolean; override; + procedure getCDSInfo(card : TCDSHookCard; langList : THTTPLanguageList; baseURL, code, display : String); override; + procedure extendLookup(factory : TFHIRFactory; ctxt : TCodeSystemProviderContext; langList : THTTPLanguageList; props : TArray; resp : TFHIRLookupOpResponseW); override; + //function subsumes(codeA, codeB : String) : String; override; + + procedure defineFeatures(features : TFslList); override; + end; + +implementation + +{ TCPTFilterContext } + +constructor TCPTFilterContext.Create(name : String; list: TFslList; closed: boolean); +var + i : integer; + s : String; +begin + inherited Create; + FName := name; + FList := list; + FClosed := closed; + FIndex := -1; + s := ''; + for i := 0 to integerMin(list.count, 50) - 1 do + s := s+list[i].code+','; + for i := integerMax(0, list.count - 10) to list.count - 1 do + s := s+','+list[i].code; + Logging.log('CPT filter '+name+': '+inttostr(list.count)+' concepts in filter (closed = '+boolToStr(FClosed)+'): '+s); +end; + +destructor TCPTFilterContext.Destroy; +begin + FList.free; + inherited Destroy; +end; + +procedure TCPTFilterContext.next; +begin + inc(FIndex); +end; + +{ TCPTIteratorContext } + +constructor TCPTIteratorContext.Create(list: TFslList); +begin + if list = nil then + inherited Create(nil, 0) + else + inherited Create(nil, list.Count); + FList := list; +end; + +destructor TCPTIteratorContext.Destroy; +begin + FList.free; + inherited Destroy; +end; + +{ TCPTConceptProperty } + +function TCPTConceptProperty.Link: TCPTConceptProperty; +begin + result := TCPTConceptProperty(inherited Link); +end; + + +{ TCPTConceptDesignation } + +function TCPTConceptDesignation.Link: TCPTConceptDesignation; +begin + result := TCPTConceptDesignation(inherited link); +end; + +{ TCPTConcept } + +constructor TCPTConcept.Create; +begin + inherited Create; + FDesignations := TFslList.Create; + FProperties := TFslList.Create; +end; + +destructor TCPTConcept.Destroy; +begin + FProperties.free; + FDesignations.free; + inherited Destroy; +end; + +function TCPTConcept.Link: TCPTConcept; +begin + result := TCPTConcept(inherited link); +end; + +procedure TCPTConcept.addProperty(name, value: String); +var + p : TCPTConceptProperty; +begin + p := TCPTConceptProperty.Create; + try + p.name := name; + p.value := value; + FProperties.add(p.link); + finally + p.free; + end; +end; + +function TCPTConcept.hasProperty(name, value: String): boolean; +var + c : TCPTConceptProperty; +begin + result := false; + for c in Properties do + if (c.name = name) and (c.value = value) then + exit(true); +end; + +procedure TCPTConcept.addDesignation(kind, value: String); +var + d : TCPTConceptDesignation; +begin + d := TCPTConceptDesignation.Create; + try + d.kind := kind; + d.value := value; + FDesignations.add(d.link); + finally + d.free; + end; +end; + +function TCPTConcept.getDesignation(kind: String): String; +var + d : TCPTConceptDesignation; +begin + result := ''; + for d in FDesignations do + if (d.kind = kind) then + exit(d.value); +end; + +{ TCPTExpression } + +constructor TCPTExpression.Create; +begin + inherited Create; + FModifiers := TFslList.Create; +end; + +destructor TCPTExpression.Destroy; +begin + FModifiers.free; + FFocus.free; + inherited Destroy; +end; + +function TCPTExpression.Link: TCPTExpression; +begin + result := TCPTExpression(inherited link); +end; + +function TCPTExpression.expression: String; +var + m : TCPTConcept; +begin + result := focus.code; + for m in modifiers do + result := result + ':' + m.code; +end; + +function TCPTExpression.hasModifier(code: String): boolean; +var + modifier : TCPTConcept; +begin + result := false; + for modifier in modifiers do + if modifier.code = code then + exit(true); +end; + +procedure TCPTExpression.SetFocus(AValue: TCPTConcept); +begin + FFocus.free; + FFocus := AValue; +end; + +{ TCPTServices } + +constructor TCPTServices.Create(languages : TIETFLanguageDefinitions; i18n : TI18nSupport; db : TFDBManager); +begin + inherited Create(languages, i18n); + FMap := TFslMap.Create; + FMap.defaultValue := nil; + FList := TFslList.Create; + FBase := TFslList.Create; + FModifier := TFslList.Create; + self.db := db; + load; +end; + +destructor TCPTServices.Destroy; +begin + db.free; + FMap.free; + FBase.free; + FModifier.free; + FList.free; + inherited Destroy; +end; + +function TCPTServices.Link: TCPTServices; +begin + result := TCPTServices(inherited link); +end; + +class function TCPTServices.checkDB(conn : TFDBConnection) : String; +var + meta : TFDBMetaData; +begin + meta := conn.FetchMetaData; + try + if not meta.HasTable('Information') or not meta.HasTable('Concepts') or not meta.HasTable('Designations') or not meta.HasTable('Properties') then + result := 'Missing Tables - needs re-importing' + else + result := 'OK ('+inttostr(conn.countSql('Select count(*) from Concepts'))+' Concepts)'; + finally + meta.free; + end; +end; + +function TCPTServices.expandLimitation: Integer; +begin + Result := 1000; // agreement with AMA +end; + +procedure checkMutuallyExclusive(list : TStringList; exp : TCPTExpression; modifiers : Array of String); +var + modifier : TCPTConcept; + c : integer; +begin + c := 0; + for modifier in exp.modifiers do + if StringArrayExists(modifiers, modifier.code) then + inc(c); + if c > 1 then + list.add('There can only one modifier in the set '+StringArrayToString(modifiers)); +end; + +function codeInSet(code, min, max : String) : boolean; +begin + result := (code >= min) and (code <= max); +end; + +function TCPTServices.validateExpression(exp: TCPTExpression): String; +var + modifier : TCPTConcept; + prop : TCPTConceptProperty; + list : TStringList; + s : string; +begin + list := TStringList.Create; + try + for modifier in exp.modifiers do + begin + for prop in modifier.properties do + begin + if prop.name = 'kind' then + begin + if prop.value = 'cat-2' then + begin + if not exp.focus.hasProperty('kind', 'cat-2') then + list.add('The modifier '+modifier.code+' is a cat-2 modifier that can only be used with cat-2 codes'); + end; + if (prop.value = 'physical') then + begin + if (exp.focus.code < '00100') or (exp.focus.code > '01999') then + list.add('The modifier '+modifier.code+' is a physical status modifier that can only be used with codes in the range 00100 - 01999'); + end; + if (prop.value = 'hcpcs') then + begin + if (not exp.hasModifier('59')) then + list.add('The modifier '+modifier.code+' is an hcpcs code that can only be used if the modifier 59 is also used'); + end; + end; + end; + // specific rules: + if (modifier.code = '50') or (modifier.code = '51') then + begin + if exp.focus.hasProperty('kind', 'cat-2') then + list.add('The modifier '+modifier.code+' cannot be used with cat-2 codes'); + end; + if (modifier.code = '63') then + begin + if not codeInSet(exp.focus.code, '20100', '69990') and not StringArrayExists(['92920', '92928', '92953', '92960', '92986', '92987', '92990', '92997', '92998', '93312', '93313', '93314', '93315', '93316', '93317', '93318', '93452', '93505', '93563', '93564', '93568', '93569', '93573', '93574', '93575', '93580', '93581', '93582', '93590', '93591', '93592', '93593', '93594', '93595', '93596', '93597', '93598', '93615', '93616'], + exp.focus.code) then + list.add('The modifier '+modifier.code+' cannot be used with the code '+exp.focus.code); + end; + if (modifier.code = '92') then + begin + if not codeInSet(exp.focus.code, '86701' ,'86703') and (exp.focus.code <> '87389') then + list.add('The modifier '+modifier.code+' cannot be used with the code '+exp.focus.code); + end; + if (modifier.code = '95') then + begin + if not exp.focus.hasProperty('telemedicine', 'true') then + list.add('The modifier '+modifier.code+' cannot be used with the code '+exp.focus.code+' as it is not designated for telemedicine'); + end; + // 76 | 77: not to an E/M service + end; + checkMutuallyExclusive(list, exp, ['25', '57', '59']); + checkMutuallyExclusive(list, exp, ['52', '53', '73', '74']); + checkMutuallyExclusive(list, exp, ['76', '77', '78', '79']); + checkMutuallyExclusive(list, exp, ['93', '95']); + result := ''; + for s in list do + CommaAdd(result, s); + finally + list.free; + end; +end; + +function TCPTServices.parse(code: String; var msg: String): TCPTExpression; +var + parts : TArray; + i : integer; + c : TCPTConcept; + exp : TCPTExpression; +begin + result := nil; + if (code = '') then + msg := 'No Expression Found' + else + begin + msg := ''; + parts := code.split([':']); + c := FMap[parts[0]]; + if (c = nil) then + msg := 'Base CPT Code '''+parts[0]+''' not found' + else + begin + exp := TCPTExpression.Create; + try + exp.focus := c.link; + for i := 1 to length(parts) - 1 do + begin + c := FMap[parts[i]]; + if c = nil then + begin + msg := 'Modifier CPT code '''+parts[i]+''' not found'; + exit(nil); + end + else + exp.modifiers.add(c.link); + end; + msg := validateExpression(exp); + if (msg <> '') then + result := nil + else + result := exp.link; + finally + exp.free; + end; + end; + end; +end; + +procedure TCPTServices.load; +var + conn : TFDBConnection; + c : TCPTConcept; +begin + conn := db.GetConnection('load'); + try + conn.SQL := 'Select * from Information'; + conn.prepare; + conn.Execute; + while conn.FetchNext do + if conn.ColStringByName['name'] = 'version' then + FVersion := conn.ColStringByName['value']; + conn.terminate; + + conn.SQL := 'Select * from Concepts'; + conn.prepare; + conn.Execute; + while conn.FetchNext do + begin + c := TCPTConcept.Create; + try + c.code := conn.ColStringByName['code']; + c.modifier := conn.ColIntegerByName['modifier'] = 1; + FMap.Add(c.code, c.link); + if c.modifier then + FModifier.Add(c.link) + else + FBase.Add(c.link); + FList.add(c.Link); + finally + c.free; + end; + end; + conn.terminate; + + conn.SQL := 'Select * from Properties'; + conn.prepare; + conn.Execute; + while conn.FetchNext do + begin + c := FMap[conn.ColStringByName['code']]; + c.addProperty(conn.ColStringByName['name'], conn.ColStringByName['value']); + end; + conn.terminate; + + conn.SQL := 'Select * from Designations'; + conn.prepare; + conn.Execute; + while conn.FetchNext do + begin + c := FMap[conn.ColStringByName['code']]; + c.addDesignation(conn.ColStringByName['type'], conn.ColStringByName['value']); + end; + conn.terminate; + + conn.Release; + except + on e : Exception do + begin + conn.Error(e); + recordStack(e); + raise; + end; + end; +end; + +function TCPTServices.systemUri : String; +begin + result := 'http://www.ama-assn.org/go/cpt'; +end; + +function TCPTServices.version : String; +begin + result := FVersion; +end; + +function TCPTServices.name(context : TCodeSystemProviderContext) : String; +begin + result := 'AmaCPT'; +end; + +function TCPTServices.description : String; +begin + result := 'CPT © Copyright 2019 American Medical Association. All rights reserved. AMA and CPT are registered trademarks of the American Medical Association.'; +end; + +function TCPTServices.TotalCount : integer; +begin + result := FMap.Count; +end; + +function TCPTServices.locate(code : String; altOpt : TAlternateCodeOptions; var message : String) : TCodeSystemProviderContext; +begin + if code.Contains(':') then + begin + result := parse(code, message); + end + else + begin + result := FMap[code].link; + if result = nil then + message := 'Code '''+code+''' not found in CPT'; + end; +end; + +function TCPTServices.getDisplay(code : String; langList : THTTPLanguageList):String; +var + c : TCPTConcept; +begin + c := FMap[code]; + if (c = nil) or c.designations.Empty then + result := '' + else + result := c.designations[0].value; +end; + +function TCPTServices.getDefinition(code : String):String; +var + c : TCPTConcept; +begin + c := FMap[code]; + if (c = nil) or c.designations.Empty then + result := '' + else + result := c.designations[0].value; +end; + + +function TCPTServices.locateIsA(code, parent : String; disallowParent : boolean = false) : TCodeSystemProviderContext; +begin + result := nil; +end; + +function TCPTServices.sameContext(a, b : TCodeSystemProviderContext) : boolean; +begin + result := a = b; +end; + +function TCPTServices.IsAbstract(context : TCodeSystemProviderContext) : boolean; +var + e : TCPTExpression; + c : TCPTConcept; +begin + if (context is TCPTExpression) then + begin + e := (context as TCPTExpression); + result := false; + end + else + begin + c := (context as TCPTConcept); + result := c.hasProperty('kind', 'metadata'); + end; +end; + +function TCPTServices.Code(context : TCodeSystemProviderContext) : string; +var + e : TCPTExpression; + c : TCPTConcept; +begin + if (context is TCPTExpression) then + begin + e := (context as TCPTExpression); + result := e.expression; + end + else + begin + c := (context as TCPTConcept); + result := c.code; + end; +end; + +function TCPTServices.Display(context : TCodeSystemProviderContext; langList : THTTPLanguageList) : string; +var + e : TCPTExpression; + c : TCPTConcept; +begin + if (context = nil) then + result := '' + else if (context is TCPTExpression) then + begin + e := (context as TCPTExpression); + result := ''; + end + else + begin + c := (context as TCPTConcept); + if c.designations.Empty then + result := '' + else + result := c.designations[0].value; + end; +end; + +procedure TCPTServices.Designations(context : TCodeSystemProviderContext; list : TConceptDesignations); +var + c : TCPTConcept; + d : TCPTConceptDesignation; + e : TCPTExpression; +begin + if (context is TCPTExpression) then + begin + e := (context as TCPTExpression); + // no text for expressions + end + else + begin + c := (context as TCPTConcept); + c := (context as TCPTConcept); + for d in c.designations do + list.addDesignation(d.kind = 'display', d.kind = 'display', 'en', d.value); + end; +end; + +function TCPTServices.Definition(context : TCodeSystemProviderContext) : string; +begin + result := Display(context, nil); +end; + +procedure TCPTServices.getCDSInfo(card : TCDSHookCard; langList : THTTPLanguageList; baseURL, code, display : String); +begin +end; + +procedure TCPTServices.extendLookup(factory : TFHIRFactory; ctxt : TCodeSystemProviderContext; langList : THTTPLanguageList; props : TArray; resp : TFHIRLookupOpResponseW); + +var + c : TCPTConcept; + d : TCPTConceptDesignation; + p : TCPTConceptProperty; + pp: TFHIRLookupOpRespPropertyW; + pp1 : TFHIRLookupOpRespSubPropertyW; + e : TCPTExpression; +begin + if (ctxt is TCPTExpression) then + begin + e := (ctxt as TCPTExpression); + extendLookup(factory, e.focus, langList, props, resp); + for c in e.modifiers do + begin + pp := resp.addProp('modifier'); + pp1 := pp.addSubProp('code'); + pp1.value := c.code; + if (not c.designations.Empty) then + begin + pp1 := pp.addSubProp('definition'); + pp1.value := c.designations[0].value; + end; + end; + end + else + begin + pp := resp.addProp('copyright'); + pp.value := factory.makeString('This response content from SNOMED CT, which is copyright ) 2002+ International Health Terminology Standards Development Organisation (IHTSDO), and distributed '+'by agreement between IHTSDO and HL7. Implementer use of SNOMED CT is not covered by this agreement'); + + c := (ctxt as TCPTConcept); + if hasProp(props, 'designation', true) then + for d in c.designations do + resp.addDesignation('en', 'http://www.ama-assn.org/go/cpt', '', d.kind, d.value); + + for p in c.properties do + begin + if hasProp(props, p.name, true) then + begin + pp := resp.addProp(p.name); + pp.value := factory.makeString(p.value); + end; + end; + end; +end; + + +function TCPTServices.getIterator(context : TCodeSystemProviderContext) : TCodeSystemIteratorContext; +begin + if (context = nil) then + result := TCPTIteratorContext.Create(FList.link) + else + result := TCPTIteratorContext.Create(nil); +end; + +function TCPTServices.getNextContext(context : TCodeSystemIteratorContext) : TCodeSystemProviderContext; +var + c : TCPTIteratorContext; +begin + c := context as TCPTIteratorContext; + if (c.FList = nil) or (c.current >= c.FList.Count) then + result := nil + else + result := c.FList[c.current].link; + context.next; +end; + + +function TCPTServices.searchFilter(filter : TSearchFilterText; prep : TCodeSystemProviderFilterPreparationContext; sort : boolean) : TCodeSystemProviderFilterContext; +begin + raise ETerminologyError.Create('Not supported yet', itBusinessRule); +end; + +function TCPTServices.filter(forIteration : boolean; prop : String; op : TFhirFilterOperator; value : String; prep : TCodeSystemProviderFilterPreparationContext) : TCodeSystemProviderFilterContext; +var + list : TFslList; + item : TCPTConcept; + b : boolean; +begin + // filters supported + // * modified = false + // * modifier = true / false + // * kind = x + + // todo: + // code in 86701-86703;87389-87389 + + if (prop = 'modifier') then + begin + b := value = 'true'; + if b then + result := TCPTFilterContext.Create('modifier:true', FModifier.link, true) + else + result := TCPTFilterContext.Create('modifier:false', FBase.link, true) + end + else if (prop = 'modified') and (op = foEqual) then + begin + b := value = 'true'; + if (b) then + result := TCPTFilterContext.Create('modified:true', TFslList.create, false) + else + result := TCPTFilterContext.Create('modified:false', FList.link, true); + end + else if (prop = 'kind') and (op = foEqual) then + begin + list := TFslList.Create; + try + for item in Flist do + if item.hasProperty('kind', value) then + list.add(item.link); + result := TCPTFilterContext.Create('kind:'+value, list.link, true); + finally + list.free; + end; + end + else + result := nil; +end; + +function TCPTServices.filterLocate(ctxt : TCodeSystemProviderFilterContext; code : String; var message : String) : TCodeSystemProviderContext; +var + fc : TCPTFilterContext; + c : TCPTConcept; +begin + fc := ctxt as TCPTFilterContext; + result := nil; + for c in fc.FList do + if (c.code = code) then + exit(c.link); +end; + +function TCPTServices.FilterMore(ctxt : TCodeSystemProviderFilterContext) : boolean; +var + fc : TCPTFilterContext; +begin + fc := ctxt as TCPTFilterContext; + fc.next; + result := (fc.Index < fc.Flist.count); +end; + +function TCPTServices.filterSize(ctxt: TCodeSystemProviderFilterContext): integer; +var + fc : TCPTFilterContext; +begin + fc := ctxt as TCPTFilterContext; + result := fc.Flist.count; +end; + +function TCPTServices.FilterConcept(ctxt : TCodeSystemProviderFilterContext): TCodeSystemProviderContext; +var + fc : TCPTFilterContext; +begin + fc := ctxt as TCPTFilterContext; + result := fc.FList[fc.index].link; +end; + +function TCPTServices.InFilter(ctxt : TCodeSystemProviderFilterContext; concept : TCodeSystemProviderContext) : Boolean; +var + fc : TCPTFilterContext; + e : TCPTExpression; + c : TCPTConcept; +begin + fc := ctxt as TCPTFilterContext; + if (concept is TCPTExpression) then + begin + e := (concept as TCPTExpression); + result := not fc.closed; + end + else + begin + c := (concept as TCPTConcept); + result := fc.FList.contains(c); + //Logging.log(c.code +' in '+fc.FName+': '+boolToStr(result)); + end; +end; + +function TCPTServices.isNotClosed(textFilter : TSearchFilterText; propFilter : TCodeSystemProviderFilterContext = nil) : boolean; +var + fc : TCPTFilterContext; +begin + if propFilter = nil then + result := true + else + begin + fc := propFilter as TCPTFilterContext; + result := not fc.closed; + end; +end; + +procedure TCPTServices.defineFeatures(features : TFslList); +begin + // nothing +end; + + +end. + diff --git a/server/tx/tx_omop.pas b/server/tx/tx_omop.pas index 05f2915b1..6aafcbeda 100644 --- a/server/tx/tx_omop.pas +++ b/server/tx/tx_omop.pas @@ -1,444 +1,472 @@ -unit tx_omop; - -{$i fhir.inc} - -interface - -uses - Classes, SysUtils, - fsl_base, fsl_utilities, fsl_http, fsl_threads, fsl_lang, fsl_i18n, - fdb_manager, fdb_dialects, - fhir_objects, fhir_common, fhir_factory, fhir_utilities, fhir_features, fhir_uris, - fhir_cdshooks, - ftx_service; - -type - - { TOMOPConcept } - - TOMOPConcept = class (TCodeSystemProviderContext) - private - FCode : String; - FDisplay : String; - FDomain: String; - public - property Code : String read FCode write FCode; - property Display : String read FDisplay write FDisplay; - property domain : String read FDomain write FDomain; - end; - - { TOMOPFilter } - - TOMOPFilter = class (TCodeSystemProviderFilterContext) - private - FConn : TFDBConnection; - procedure SetConn(AValue: TFDBConnection); - public - destructor Destroy; override; - - property conn : TFDBConnection read FConn write SetConn; - end; - - { TOMOPServices } - - TOMOPServices = class (TCodeSystemProvider) - private - db : TFDBManager; - FVersion : String; - procedure loadVersion; - public - constructor Create(languages : TIETFLanguageDefinitions; i18n : TI18nSupport; db : TFDBManager); - destructor Destroy; Override; - Function Link : TOMOPServices; overload; - - class function checkDB(conn : TFDBConnection) : String; - - function systemUri : String; override; - function version : String; override; - function name(context : TCodeSystemProviderContext) : String; override; - function description : String; override; - function TotalCount : integer; override; - function getIterator(context : TCodeSystemProviderContext) : TCodeSystemIteratorContext; override; - function getNextContext(context : TCodeSystemIteratorContext) : TCodeSystemProviderContext; override; - function getDisplay(code : String; langList : THTTPLanguageList):String; override; - function getDefinition(code : String):String; override; - function locate(code : String; altOpt : TAlternateCodeOptions; var message : String) : TCodeSystemProviderContext; override; - function locateIsA(code, parent : String; disallowParent : boolean = false) : TCodeSystemProviderContext; override; - function sameContext(a, b : TCodeSystemProviderContext) : boolean; override; - function IsAbstract(context : TCodeSystemProviderContext) : boolean; override; - function Code(context : TCodeSystemProviderContext) : string; override; - function Display(context : TCodeSystemProviderContext; langList : THTTPLanguageList) : string; override; - procedure Designations(context : TCodeSystemProviderContext; list : TConceptDesignations); override; - function Definition(context : TCodeSystemProviderContext) : string; override; - - function getPrepContext : TCodeSystemProviderFilterPreparationContext; override; - function prepare(prep : TCodeSystemProviderFilterPreparationContext) : boolean; override; - - function searchFilter(filter : TSearchFilterText; prep : TCodeSystemProviderFilterPreparationContext; sort : boolean) : TCodeSystemProviderFilterContext; override; - function filter(forIteration : boolean; prop : String; op : TFhirFilterOperator; value : String; prep : TCodeSystemProviderFilterPreparationContext) : TCodeSystemProviderFilterContext; override; - function filterLocate(ctxt : TCodeSystemProviderFilterContext; code : String; var message : String) : TCodeSystemProviderContext; override; - function FilterMore(ctxt : TCodeSystemProviderFilterContext) : boolean; override; - function filterSize(ctxt : TCodeSystemProviderFilterContext) : integer; override; - function FilterConcept(ctxt : TCodeSystemProviderFilterContext): TCodeSystemProviderContext; override; - function InFilter(ctxt : TCodeSystemProviderFilterContext; concept : TCodeSystemProviderContext) : Boolean; override; - function isNotClosed(textFilter : TSearchFilterText; propFilter : TCodeSystemProviderFilterContext = nil) : boolean; override; - procedure getCDSInfo(card : TCDSHookCard; langList : THTTPLanguageList; baseURL, code, display : String); override; - procedure extendLookup(factory : TFHIRFactory; ctxt : TCodeSystemProviderContext; langList : THTTPLanguageList; props : TArray; resp : TFHIRLookupOpResponseW); override; - //function subsumes(codeA, codeB : String) : String; override; - - procedure defineFeatures(features : TFslList); override; - end; - - -implementation - -{ TOMOPFilter } - -procedure TOMOPFilter.SetConn(AValue: TFDBConnection); -begin - FConn.free; - FConn:=AValue; -end; - -destructor TOMOPFilter.Destroy; -begin - FConn.terminate; - FConn.release; - inherited Destroy; -end; - -{ TOMOPServices } - -constructor TOMOPServices.Create(languages: TIETFLanguageDefinitions; i18n : TI18nSupport; db: TFDBManager); -begin - inherited Create(languages, i18n); - self.db := db; - loadVersion; -end; - -destructor TOMOPServices.Destroy; -begin - db.free; - inherited Destroy; -end; - -function TOMOPServices.Link: TOMOPServices; -begin - result := TOMOPServices(inherited link); -end; - -class function TOMOPServices.checkDB(conn: TFDBConnection): String; -var - meta : TFDBMetaData; -begin - meta := conn.FetchMetaData; - try - if not meta.HasTable('Relationships') or not meta.HasTable('Domains') or not meta.HasTable('ConceptClasses') or not meta.HasTable('Vocabularies') - or not meta.HasTable('Concepts') or not meta.HasTable('ConceptSynonyms') or not meta.HasTable('ConceptRelationships') then - result := 'Missing Tables - needs re-importing (by java)' - else - result := 'OK ('+inttostr(conn.countSql('Select count(*) from Concepts'))+' Concepts)'; - finally - meta.free; - end; -end; - -procedure TOMOPServices.loadVersion; -var - ver : String; - conn : TFDBConnection; -begin - conn := db.GetConnection('Version'); - try - ver := conn.Lookup('Vocabularies', 'vocabulary_id', 'OMOP Extension', 'vocabulary_version', ''); - FVersion := ver.Substring(ver.LastIndexOf(' ')+1); - conn.Release; - except - on e : Exception do - begin - conn.Error(e); - end; - end; - -end; - -function TOMOPServices.systemUri: String; -begin - result := 'http://fhir.ohdsi.org/CodeSystem/concepts'; -end; - -function TOMOPServices.version: String; -begin - Result := FVersion; -end; - -function TOMOPServices.name(context: TCodeSystemProviderContext): String; -begin - Result := 'OMOP Concepts'; -end; - -function TOMOPServices.description: String; -begin - Result := 'OMOP Concepts, release '+FVersion; -end; - -function TOMOPServices.TotalCount: integer; -begin - result := db.countSql('Select count(*) from Concepts', 'TotalCount'); -end; - -function TOMOPServices.getDisplay(code: String; langList : THTTPLanguageList): String; -var - c : TOMOPConcept; - msg : String; -begin - c := locate(code, nil, msg) as TOMOPConcept; - try - if c <> nil then - result := c.Display - else - result := ''; - finally - c.free; - end; -end; - -function TOMOPServices.getDefinition(code: String): String; -begin - result := ''; -end; - -function TOMOPServices.locate(code: String; altOpt : TAlternateCodeOptions; var message: String): TCodeSystemProviderContext; -var - conn : TFDBConnection; - c : TOMOPConcept; -begin - conn := db.GetConnection('locate'); - try - conn.sql := 'Select concept_name, domain_id from Concepts where concept_id = '''+SQLWrapString(code)+''''; - conn.Prepare; - conn.Execute; - if conn.FetchNext then - begin - c := TOMOPConcept.Create; - try - c.code := code; - c.display := conn.ColStringByName['concept_name']; - c.domain := conn.ColStringByName['domain_id']; - result := c.link; - finally - c.free; - end; - end - else - result := nil; - conn.terminate; - conn.Release; - except - on e : Exception do - begin - conn.Error(e); - raise - end; - end; -end; - -function TOMOPServices.locateIsA(code, parent: String; disallowParent: boolean): TCodeSystemProviderContext; -begin - result := nil; // none -end; - -function TOMOPServices.sameContext(a, b: TCodeSystemProviderContext): boolean; -begin - result := (a is TOMOPConcept) and (b is TOMOPConcept) and ((a as TOMOPConcept).code = (b as TOMOPConcept).code); -end; - -function TOMOPServices.getIterator(context: TCodeSystemProviderContext): TCodeSystemIteratorContext; -var - qry : TFDBConnection; -begin - qry := db.GetConnection('getIterator'); - try - result := TCodeSystemIteratorContext.Create(nil, qry.CountSQL('Select count(concept_id) from Concepts')); - qry.Release; - except - on e : Exception do - begin - qry.Error(e); - recordStack(e); - raise; - end; - end; -end; - -function TOMOPServices.getNextContext(context: TCodeSystemIteratorContext): TCodeSystemProviderContext; -begin - raise ETerminologyError.Create('getNextContext not supported by RXNorm', itException); // only used when iterating the entire code system. and RxNorm is too big -end; - -function TOMOPServices.IsAbstract(context: TCodeSystemProviderContext): boolean; -begin - result := false; -end; - -function TOMOPServices.Code(context: TCodeSystemProviderContext): string; -begin - if (context is TOMOPConcept) then - result := (context as TOMOPConcept).code - else - result := ''; -end; - -function TOMOPServices.Display(context: TCodeSystemProviderContext; langList : THTTPLanguageList): string; -begin - if (context is TOMOPConcept) then - result := (context as TOMOPConcept).display - else - result := ''; -end; - -procedure TOMOPServices.Designations(context: TCodeSystemProviderContext; list: TConceptDesignations); -var - conn : TFDBConnection; -begin - if (context is TOMOPConcept) then - begin - list.addDesignation(true, true, 'en', (context as TOMOPConcept).Display); - conn := db.GetConnection('display'); - try - conn.sql := 'Select concept_synonym_name from ConceptSynonyms where concept_id = '''+SQLWrapString((context as TOMOPConcept).code)+''''; - conn.Prepare; - conn.Execute; - while conn.FetchNext do - list.addDesignation(false, false, 'en', conn.ColStringByName['concept_synonym_name']); - conn.terminate; - conn.Release; - except - on e : Exception do - begin - conn.Error(e); - raise - end; - end; - end; -end; - -function TOMOPServices.Definition(context: TCodeSystemProviderContext): string; -begin - result := ''; -end; - -function TOMOPServices.getPrepContext: TCodeSystemProviderFilterPreparationContext; -begin - result := nil; -end; - -function TOMOPServices.prepare(prep: TCodeSystemProviderFilterPreparationContext): boolean; -begin - result := false; -end; - -function TOMOPServices.searchFilter(filter: TSearchFilterText; prep: TCodeSystemProviderFilterPreparationContext; sort: boolean): TCodeSystemProviderFilterContext; -begin - raise ETerminologyError.Create('not done yet: searchFilter', itBusinessRule); -end; - -function TOMOPServices.filter(forIteration: boolean; prop: String; op: TFhirFilterOperator; value: String; prep: TCodeSystemProviderFilterPreparationContext): TCodeSystemProviderFilterContext; -var - f : TOMOPFilter; -begin - if (prop = 'domain') and (op = foEqual) then - begin - f := TOMOPFilter.Create; - try - f.conn := db.GetConnection('filter'); - f.conn.sql := 'Select concept_id, concept_name, domain_id from Concepts where domain_id = '''+SQLWrapString(value)+''''; - f.conn.Prepare; - f.conn.Execute; - result := f.link; - finally - f.free; - end; - end - else - raise ETerminologyError.Create('filter "'+prop+' '+CODES_TFhirFilterOperator[op]+' '+value+'" not understood for OMOP', itBusinessRule); -end; - -function TOMOPServices.filterLocate(ctxt: TCodeSystemProviderFilterContext; code: String; var message: String): TCodeSystemProviderContext; -begin - raise ETerminologyError.Create('not done yet: filterLocate', itBusinessRule); -end; - -function TOMOPServices.FilterMore(ctxt: TCodeSystemProviderFilterContext): boolean; -begin - result := (ctxt as TOMOPFilter).Conn.FetchNext; -end; - -function TOMOPServices.filterSize(ctxt: TCodeSystemProviderFilterContext): integer; -begin - result := (ctxt as TOMOPFilter).Conn.RowsAffected; -end; - -function TOMOPServices.FilterConcept(ctxt: TCodeSystemProviderFilterContext): TCodeSystemProviderContext; -var - conn : TFDBConnection; - c : TOMOPConcept; -begin - conn := (ctxt as TOMOPFilter).Conn; - c := TOMOPConcept.Create; - try - c.code := conn.ColStringByName['concept_id']; - c.display := conn.ColStringByName['concept_name']; - c.domain := conn.ColStringByName['domain_id']; - result := c.link; - finally - c.free; - end; -end; - -function TOMOPServices.InFilter(ctxt: TCodeSystemProviderFilterContext; concept: TCodeSystemProviderContext): Boolean; -begin - raise ETerminologyError.Create('not done yet: InFilter', itBusinessRule); -end; - -function TOMOPServices.isNotClosed(textFilter: TSearchFilterText; propFilter: TCodeSystemProviderFilterContext): boolean; -begin - result := false; -end; - -procedure TOMOPServices.getCDSInfo(card: TCDSHookCard; langList : THTTPLanguageList; baseURL, code, display: String); -begin - raise ETerminologyError.Create('not done yet: getCDSInfo', itBusinessRule); -end; - -procedure TOMOPServices.extendLookup(factory: TFHIRFactory; ctxt: TCodeSystemProviderContext; langList : THTTPLanguageList; props: TArray; resp: TFHIRLookupOpResponseW); -var - conn : TFDBConnection; -begin - if hasProp(props, 'domain', true) then - resp.addProp('domain').value := factory.makeCode((ctxt as TOMOPConcept).domain); - conn := db.GetConnection('display'); - try - conn.sql := 'Select concept_synonym_name from ConceptSynonyms where concept_id = '''+SQLWrapString((ctxt as TOMOPConcept).code)+''''; - conn.Prepare; - conn.Execute; - while conn.FetchNext do - resp.addDesignation('en', '', '', '', conn.ColStringByName['concept_synonym_name']); - conn.terminate; - conn.Release; - except - on e : Exception do - begin - conn.Error(e); - raise - end; - end; -end; - -procedure TOMOPServices.defineFeatures(features: TFslList); -begin - raise ETerminologyError.Create('not done yet: defineFeatures', itBusinessRule); -end; - -end. - +unit tx_omop; + +{ +Copyright (c) 2011+, HL7 and Health Intersections Pty Ltd (http://www.healthintersections.com.au) +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of HL7 nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +} + +{$i fhir.inc} + +interface + +uses + Classes, SysUtils, + fsl_base, fsl_utilities, fsl_http, fsl_threads, fsl_lang, fsl_i18n, + fdb_manager, fdb_dialects, + fhir_objects, fhir_common, fhir_factory, fhir_utilities, fhir_features, fhir_uris, + fhir_cdshooks, + ftx_service; + +type + + { TOMOPConcept } + + TOMOPConcept = class (TCodeSystemProviderContext) + private + FCode : String; + FDisplay : String; + FDomain: String; + public + property Code : String read FCode write FCode; + property Display : String read FDisplay write FDisplay; + property domain : String read FDomain write FDomain; + end; + + { TOMOPFilter } + + TOMOPFilter = class (TCodeSystemProviderFilterContext) + private + FConn : TFDBConnection; + procedure SetConn(AValue: TFDBConnection); + public + destructor Destroy; override; + + property conn : TFDBConnection read FConn write SetConn; + end; + + { TOMOPServices } + + TOMOPServices = class (TCodeSystemProvider) + private + db : TFDBManager; + FVersion : String; + procedure loadVersion; + public + constructor Create(languages : TIETFLanguageDefinitions; i18n : TI18nSupport; db : TFDBManager); + destructor Destroy; Override; + Function Link : TOMOPServices; overload; + + class function checkDB(conn : TFDBConnection) : String; + + function systemUri : String; override; + function version : String; override; + function name(context : TCodeSystemProviderContext) : String; override; + function description : String; override; + function TotalCount : integer; override; + function getIterator(context : TCodeSystemProviderContext) : TCodeSystemIteratorContext; override; + function getNextContext(context : TCodeSystemIteratorContext) : TCodeSystemProviderContext; override; + function getDisplay(code : String; langList : THTTPLanguageList):String; override; + function getDefinition(code : String):String; override; + function locate(code : String; altOpt : TAlternateCodeOptions; var message : String) : TCodeSystemProviderContext; override; + function locateIsA(code, parent : String; disallowParent : boolean = false) : TCodeSystemProviderContext; override; + function sameContext(a, b : TCodeSystemProviderContext) : boolean; override; + function IsAbstract(context : TCodeSystemProviderContext) : boolean; override; + function Code(context : TCodeSystemProviderContext) : string; override; + function Display(context : TCodeSystemProviderContext; langList : THTTPLanguageList) : string; override; + procedure Designations(context : TCodeSystemProviderContext; list : TConceptDesignations); override; + function Definition(context : TCodeSystemProviderContext) : string; override; + + function getPrepContext : TCodeSystemProviderFilterPreparationContext; override; + function prepare(prep : TCodeSystemProviderFilterPreparationContext) : boolean; override; + + function searchFilter(filter : TSearchFilterText; prep : TCodeSystemProviderFilterPreparationContext; sort : boolean) : TCodeSystemProviderFilterContext; override; + function filter(forIteration : boolean; prop : String; op : TFhirFilterOperator; value : String; prep : TCodeSystemProviderFilterPreparationContext) : TCodeSystemProviderFilterContext; override; + function filterLocate(ctxt : TCodeSystemProviderFilterContext; code : String; var message : String) : TCodeSystemProviderContext; override; + function FilterMore(ctxt : TCodeSystemProviderFilterContext) : boolean; override; + function filterSize(ctxt : TCodeSystemProviderFilterContext) : integer; override; + function FilterConcept(ctxt : TCodeSystemProviderFilterContext): TCodeSystemProviderContext; override; + function InFilter(ctxt : TCodeSystemProviderFilterContext; concept : TCodeSystemProviderContext) : Boolean; override; + function isNotClosed(textFilter : TSearchFilterText; propFilter : TCodeSystemProviderFilterContext = nil) : boolean; override; + procedure getCDSInfo(card : TCDSHookCard; langList : THTTPLanguageList; baseURL, code, display : String); override; + procedure extendLookup(factory : TFHIRFactory; ctxt : TCodeSystemProviderContext; langList : THTTPLanguageList; props : TArray; resp : TFHIRLookupOpResponseW); override; + //function subsumes(codeA, codeB : String) : String; override; + + procedure defineFeatures(features : TFslList); override; + end; + + +implementation + +{ TOMOPFilter } + +procedure TOMOPFilter.SetConn(AValue: TFDBConnection); +begin + FConn.free; + FConn:=AValue; +end; + +destructor TOMOPFilter.Destroy; +begin + FConn.terminate; + FConn.release; + inherited Destroy; +end; + +{ TOMOPServices } + +constructor TOMOPServices.Create(languages: TIETFLanguageDefinitions; i18n : TI18nSupport; db: TFDBManager); +begin + inherited Create(languages, i18n); + self.db := db; + loadVersion; +end; + +destructor TOMOPServices.Destroy; +begin + db.free; + inherited Destroy; +end; + +function TOMOPServices.Link: TOMOPServices; +begin + result := TOMOPServices(inherited link); +end; + +class function TOMOPServices.checkDB(conn: TFDBConnection): String; +var + meta : TFDBMetaData; +begin + meta := conn.FetchMetaData; + try + if not meta.HasTable('Relationships') or not meta.HasTable('Domains') or not meta.HasTable('ConceptClasses') or not meta.HasTable('Vocabularies') + or not meta.HasTable('Concepts') or not meta.HasTable('ConceptSynonyms') or not meta.HasTable('ConceptRelationships') then + result := 'Missing Tables - needs re-importing (by java)' + else + result := 'OK ('+inttostr(conn.countSql('Select count(*) from Concepts'))+' Concepts)'; + finally + meta.free; + end; +end; + +procedure TOMOPServices.loadVersion; +var + ver : String; + conn : TFDBConnection; +begin + conn := db.GetConnection('Version'); + try + ver := conn.Lookup('Vocabularies', 'vocabulary_id', 'OMOP Extension', 'vocabulary_version', ''); + FVersion := ver.Substring(ver.LastIndexOf(' ')+1); + conn.Release; + except + on e : Exception do + begin + conn.Error(e); + end; + end; + +end; + +function TOMOPServices.systemUri: String; +begin + result := 'http://fhir.ohdsi.org/CodeSystem/concepts'; +end; + +function TOMOPServices.version: String; +begin + Result := FVersion; +end; + +function TOMOPServices.name(context: TCodeSystemProviderContext): String; +begin + Result := 'OMOP Concepts'; +end; + +function TOMOPServices.description: String; +begin + Result := 'OMOP Concepts, release '+FVersion; +end; + +function TOMOPServices.TotalCount: integer; +begin + result := db.countSql('Select count(*) from Concepts', 'TotalCount'); +end; + +function TOMOPServices.getDisplay(code: String; langList : THTTPLanguageList): String; +var + c : TOMOPConcept; + msg : String; +begin + c := locate(code, nil, msg) as TOMOPConcept; + try + if c <> nil then + result := c.Display + else + result := ''; + finally + c.free; + end; +end; + +function TOMOPServices.getDefinition(code: String): String; +begin + result := ''; +end; + +function TOMOPServices.locate(code: String; altOpt : TAlternateCodeOptions; var message: String): TCodeSystemProviderContext; +var + conn : TFDBConnection; + c : TOMOPConcept; +begin + conn := db.GetConnection('locate'); + try + conn.sql := 'Select concept_name, domain_id from Concepts where concept_id = '''+SQLWrapString(code)+''''; + conn.Prepare; + conn.Execute; + if conn.FetchNext then + begin + c := TOMOPConcept.Create; + try + c.code := code; + c.display := conn.ColStringByName['concept_name']; + c.domain := conn.ColStringByName['domain_id']; + result := c.link; + finally + c.free; + end; + end + else + result := nil; + conn.terminate; + conn.Release; + except + on e : Exception do + begin + conn.Error(e); + raise + end; + end; +end; + +function TOMOPServices.locateIsA(code, parent: String; disallowParent: boolean): TCodeSystemProviderContext; +begin + result := nil; // none +end; + +function TOMOPServices.sameContext(a, b: TCodeSystemProviderContext): boolean; +begin + result := (a is TOMOPConcept) and (b is TOMOPConcept) and ((a as TOMOPConcept).code = (b as TOMOPConcept).code); +end; + +function TOMOPServices.getIterator(context: TCodeSystemProviderContext): TCodeSystemIteratorContext; +var + qry : TFDBConnection; +begin + qry := db.GetConnection('getIterator'); + try + result := TCodeSystemIteratorContext.Create(nil, qry.CountSQL('Select count(concept_id) from Concepts')); + qry.Release; + except + on e : Exception do + begin + qry.Error(e); + recordStack(e); + raise; + end; + end; +end; + +function TOMOPServices.getNextContext(context: TCodeSystemIteratorContext): TCodeSystemProviderContext; +begin + raise ETerminologyError.Create('getNextContext not supported by RXNorm', itException); // only used when iterating the entire code system. and RxNorm is too big +end; + +function TOMOPServices.IsAbstract(context: TCodeSystemProviderContext): boolean; +begin + result := false; +end; + +function TOMOPServices.Code(context: TCodeSystemProviderContext): string; +begin + if (context is TOMOPConcept) then + result := (context as TOMOPConcept).code + else + result := ''; +end; + +function TOMOPServices.Display(context: TCodeSystemProviderContext; langList : THTTPLanguageList): string; +begin + if (context is TOMOPConcept) then + result := (context as TOMOPConcept).display + else + result := ''; +end; + +procedure TOMOPServices.Designations(context: TCodeSystemProviderContext; list: TConceptDesignations); +var + conn : TFDBConnection; +begin + if (context is TOMOPConcept) then + begin + list.addDesignation(true, true, 'en', (context as TOMOPConcept).Display); + conn := db.GetConnection('display'); + try + conn.sql := 'Select concept_synonym_name from ConceptSynonyms where concept_id = '''+SQLWrapString((context as TOMOPConcept).code)+''''; + conn.Prepare; + conn.Execute; + while conn.FetchNext do + list.addDesignation(false, false, 'en', conn.ColStringByName['concept_synonym_name']); + conn.terminate; + conn.Release; + except + on e : Exception do + begin + conn.Error(e); + raise + end; + end; + end; +end; + +function TOMOPServices.Definition(context: TCodeSystemProviderContext): string; +begin + result := ''; +end; + +function TOMOPServices.getPrepContext: TCodeSystemProviderFilterPreparationContext; +begin + result := nil; +end; + +function TOMOPServices.prepare(prep: TCodeSystemProviderFilterPreparationContext): boolean; +begin + result := false; +end; + +function TOMOPServices.searchFilter(filter: TSearchFilterText; prep: TCodeSystemProviderFilterPreparationContext; sort: boolean): TCodeSystemProviderFilterContext; +begin + raise ETerminologyError.Create('not done yet: searchFilter', itBusinessRule); +end; + +function TOMOPServices.filter(forIteration: boolean; prop: String; op: TFhirFilterOperator; value: String; prep: TCodeSystemProviderFilterPreparationContext): TCodeSystemProviderFilterContext; +var + f : TOMOPFilter; +begin + if (prop = 'domain') and (op = foEqual) then + begin + f := TOMOPFilter.Create; + try + f.conn := db.GetConnection('filter'); + f.conn.sql := 'Select concept_id, concept_name, domain_id from Concepts where domain_id = '''+SQLWrapString(value)+''''; + f.conn.Prepare; + f.conn.Execute; + result := f.link; + finally + f.free; + end; + end + else + raise ETerminologyError.Create('filter "'+prop+' '+CODES_TFhirFilterOperator[op]+' '+value+'" not understood for OMOP', itBusinessRule); +end; + +function TOMOPServices.filterLocate(ctxt: TCodeSystemProviderFilterContext; code: String; var message: String): TCodeSystemProviderContext; +begin + raise ETerminologyError.Create('not done yet: filterLocate', itBusinessRule); +end; + +function TOMOPServices.FilterMore(ctxt: TCodeSystemProviderFilterContext): boolean; +begin + result := (ctxt as TOMOPFilter).Conn.FetchNext; +end; + +function TOMOPServices.filterSize(ctxt: TCodeSystemProviderFilterContext): integer; +begin + result := (ctxt as TOMOPFilter).Conn.RowsAffected; +end; + +function TOMOPServices.FilterConcept(ctxt: TCodeSystemProviderFilterContext): TCodeSystemProviderContext; +var + conn : TFDBConnection; + c : TOMOPConcept; +begin + conn := (ctxt as TOMOPFilter).Conn; + c := TOMOPConcept.Create; + try + c.code := conn.ColStringByName['concept_id']; + c.display := conn.ColStringByName['concept_name']; + c.domain := conn.ColStringByName['domain_id']; + result := c.link; + finally + c.free; + end; +end; + +function TOMOPServices.InFilter(ctxt: TCodeSystemProviderFilterContext; concept: TCodeSystemProviderContext): Boolean; +begin + raise ETerminologyError.Create('not done yet: InFilter', itBusinessRule); +end; + +function TOMOPServices.isNotClosed(textFilter: TSearchFilterText; propFilter: TCodeSystemProviderFilterContext): boolean; +begin + result := false; +end; + +procedure TOMOPServices.getCDSInfo(card: TCDSHookCard; langList : THTTPLanguageList; baseURL, code, display: String); +begin + raise ETerminologyError.Create('not done yet: getCDSInfo', itBusinessRule); +end; + +procedure TOMOPServices.extendLookup(factory: TFHIRFactory; ctxt: TCodeSystemProviderContext; langList : THTTPLanguageList; props: TArray; resp: TFHIRLookupOpResponseW); +var + conn : TFDBConnection; +begin + if hasProp(props, 'domain', true) then + resp.addProp('domain').value := factory.makeCode((ctxt as TOMOPConcept).domain); + conn := db.GetConnection('display'); + try + conn.sql := 'Select concept_synonym_name from ConceptSynonyms where concept_id = '''+SQLWrapString((ctxt as TOMOPConcept).code)+''''; + conn.Prepare; + conn.Execute; + while conn.FetchNext do + resp.addDesignation('en', '', '', '', conn.ColStringByName['concept_synonym_name']); + conn.terminate; + conn.Release; + except + on e : Exception do + begin + conn.Error(e); + raise + end; + end; +end; + +procedure TOMOPServices.defineFeatures(features: TFslList); +begin + raise ETerminologyError.Create('not done yet: defineFeatures', itBusinessRule); +end; + +end. + diff --git a/server/tx_manager.pas b/server/tx_manager.pas index bc7ba1a2f..71d6e17fd 100644 --- a/server/tx_manager.pas +++ b/server/tx_manager.pas @@ -363,7 +363,7 @@ procedure TTerminologyServerStore.BuildStems(cs: TFhirCodeSystemW); var map : TFhirCodeSystemConceptMapW; begin - raise Exception.create('todo'); + raise EFslException.create('todo'); //map := TFhirCodeSystemConceptMapW.Create('stems'); //try // !cs.Tag := TCodeSystemAdornment.Create(map.link); @@ -933,7 +933,7 @@ procedure TTerminologyServerStore.loadCodeSystem(cs: TFHIRResourceProxyV); procedure TTerminologyServerStore.loadCodeSystem(cs: TFHIRCodeSystemW); begin - raise Exception.create('loadCodeSystem(TFHIRCodeSystemW) not done yet'); + raise EFslException.create('loadCodeSystem(TFHIRCodeSystemW) not done yet'); end; procedure TTerminologyServerStore.UpdateConceptMaps; diff --git a/server/tx_operations.pas b/server/tx_operations.pas index ba9223df7..639128fc7 100644 --- a/server/tx_operations.pas +++ b/server/tx_operations.pas @@ -1,1457 +1,1457 @@ -unit tx_operations; - -{ -Copyright (c) 2017+, Health Intersections Pty Ltd (http://www.healthintersections.com.au) -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, -are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of HL7 nor the names of its contributors may be used to - endorse or promote products derived from this software without specific - prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. -IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, -INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. -} - -{$I fhir.inc} - -interface - -uses - SysUtils, - fsl_base, fsl_utilities, fsl_logging, fsl_http, fsl_lang, - fdb_manager, - fhir_objects, fhir_utilities, fhir_common, fhir_factory, - fhir_valuesets, - session, storage, ftx_service, tx_manager, tx_server, closuremanager, time_tracker; - -type - - { TFhirTerminologyOperation } - - TFhirTerminologyOperation = class (TFhirOperation) - protected - FServer : TTerminologyServer; - - function isValidation : boolean; virtual; - procedure processExpansionParams(request: TFHIRRequest; manager: TFHIROperationEngine; params : TFhirParametersW; result : TFHIRExpansionParams); - function buildExpansionParams(request: TFHIRRequest; manager: TFHIROperationEngine; params : TFhirParametersW) : TFHIRExpansionParams; - function loadCoded(request : TFHIRRequest; isValueSet : boolean; var issuePath : string; var mode : TValidationCheckMode) : TFhirCodeableConceptW; - function processAdditionalResources(context : TOperationContext; manager: TFHIROperationEngine; mr : TFHIRMetadataResourceW; params : TFHIRParametersW) : TFslMetadataResourceList; - public - constructor Create(factory : TFHIRFactory; server : TTerminologyServer; languages : TIETFLanguageDefinitions); - destructor Destroy; override; - end; - - TFhirExpandValueSetOperation = class (TFhirTerminologyOperation) - protected - function isWrite : boolean; override; - function owningResource : String; override; - function readValueSetUri(manager: TFHIROperationEngine; url : String; op : String) : String; - public - function Name : String; override; - function Types : TArray; override; - function CreateDefinition(base : String) : TFHIROperationDefinitionW; override; - function Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response : TFHIRResponse; tt : TTimeTracker) : String; override; - function formalURL : String; override; - end; - - { TFhirValueSetValidationOperation } - - TFhirValueSetValidationOperation = class (TFhirTerminologyOperation) - protected - function isWrite : boolean; override; - function owningResource : String; override; - function isValidation : boolean; override; - public - function Name : String; override; - function Types : TArray; override; - function CreateDefinition(base : String) : TFHIROperationDefinitionW; override; - function Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response : TFHIRResponse; tt : TTimeTracker) : String; override; - function formalURL : String; override; - end; - -(** - TFhirCodeSystemComposeOperation = class (TFhirTerminologyOperation) - protected - function isWrite : boolean; override; - function owningResource : String; override; - public - function Name : String; override; - function Types : TArray; override; - function CreateDefinition(base : String) : TFHIROperationDefinitionW; override; - procedure Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response : TFHIRResponse); override; - function formalURL : String; override; - end; -*) - - TFhirSubsumesOperation = class (TFhirTerminologyOperation) - protected - function isWrite : boolean; override; - function owningResource : String; override; - public - function Name : String; override; - function Types : TArray; override; - function CreateDefinition(base : String) : TFHIROperationDefinitionW; override; - function Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response : TFHIRResponse; tt : TTimeTracker) : String; override; - function formalURL : String; override; - end; - - TFhirConceptMapTranslationOperation = class (TFhirTerminologyOperation) - protected - function isWrite : boolean; override; - function owningResource : String; override; - public - function Name : String; override; - function Types : TArray; override; - function CreateDefinition(base : String) : TFHIROperationDefinitionW; override; - function Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response : TFHIRResponse; tt : TTimeTracker) : String; override; - function formalURL : String; override; - end; - - - TFhirLookupCodeSystemOperation = class (TFhirTerminologyOperation) - protected - function isWrite : boolean; override; - function owningResource : String; override; - public - function Name : String; override; - function Types : TArray; override; - function CreateDefinition(base : String) : TFHIROperationDefinitionW; override; - function Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response : TFHIRResponse; tt : TTimeTracker) : String; override; - function formalURL : String; override; - end; - - - TFhirConceptMapClosureOperation = class (TFhirTerminologyOperation) - protected - function isWrite : boolean; override; - function owningResource : String; override; - function checkName(request: TFHIRRequest; response : TFHIRResponse; var name : String) : boolean; - public - constructor Create(factory : TFHIRFactory; server : TTerminologyServer; languages : TIETFLanguageDefinitions); - function Name : String; override; - function Types : TArray; override; - function CreateDefinition(base : String) : TFHIROperationDefinitionW; override; - function Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response : TFHIRResponse; tt : TTimeTracker) : String; override; - function formalURL : String; override; - end; - - -implementation - -{ TFhirExpandValueSetOperation } - -function TFhirExpandValueSetOperation.Name: String; -begin - result := 'expand'; -end; - -function TFhirExpandValueSetOperation.owningResource: String; -begin - result := 'ValueSet'; -end; - -function TFhirExpandValueSetOperation.readValueSetUri(manager: TFHIROperationEngine; url, op: String): String; -var - sd : TFhirStructureDefinitionW; - ed : TFHIRElementDefinitionW; - u, p, t : String; - needSecure : boolean; -begin - if url.Contains('#') then - StringSplit(url, '#', u, p) - else - begin - if not url.Contains('.') then - raise EFSLException.Create('Unable to understand url "'+url+'"'); - StringSplit(url,'.', u, t); - u := 'http://hl7.org/fhir/StructureDefinition/'+u; - p := url; - end; - sd := FFactory.wrapStructureDefinition(manager.GetResourceByUrl('StructureDefinition', u, '', false, needSecure)); - try - ed := sd.getDefinition(p, edsSNAPSHOT); - if ed = nil then - raise EFSLException.Create('Unable to resolve element "'+p+'" in "'+u+'"'); - try - if (ed.valueSet = '') then - raise EFSLException.Create('No value set for element "'+p+'" in "'+u+'"'); - result := ed.valueSet; - finally - ed.free; - end; - finally - sd.free; - end; -end; - -function TFhirExpandValueSetOperation.Types: TArray; -begin - result := ['ValueSet']; -end; - -function TFhirExpandValueSetOperation.CreateDefinition(base : String): TFHIROperationDefinitionW; -begin - result := nil; -end; - -function TFhirExpandValueSetOperation.Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response: TFHIRResponse; tt : TTimeTracker) : String; -var - vs, dst : TFHIRValueSetW; - resourceKey, versionKey : integer; - url, cacheId, filter, id, version : String; - profile : TFHIRExpansionParams; - limit, count, offset : integer; - params : TFhirParametersW; - needSecure : boolean; - txResources : TFslMetadataResourceList; - mr : TFHIRMetadataResourceW; -begin - result := 'Expand ValueSet'; - try - manager.NotFound(request, response); - if manager.check(response, manager.opAllowed(request.ResourceName, request.CommandType), 400, manager.langList, StringFormat(GetFhirMessage('MSG_OP_NOT_ALLOWED', manager.langList), [CODES_TFHIRCommandType[request.CommandType], request.ResourceName]), itForbidden) then - begin - if (request.id = '') or ((length(request.id) <= ID_LENGTH) and manager.FindResource(request.ResourceName, request.Id, [], resourceKey, versionKey, request, response, nil)) then - begin - cacheId := ''; - params := makeParams(request); - vs := nil; - txResources := nil; - try - // first, we have to identify the value set. - if request.Id <> '' then // and it must exist, because of the check above - begin - vs := FFactory.wrapValueSet(manager.GetResourceById(request, 'ValueSet', request.Id, request.baseUrl, needSecure)); - cacheId := vs.url; - if vs.version <> '' then - cacheId := cacheId + vs.version; - end - else if params.has('url') then - begin - url := params.str('url'); - version := request.Parameters['valueSetVersion']; - txResources := processAdditionalResources(context, manager, nil, params); - for mr in txResources do - if (mr.url = url) and (mr is TFHIRValueSetW) then - begin - vs := (mr as TFHIRValueSetW).link; - break; - end; - if (vs = nil) then - begin - if (url.startsWith('ValueSet/')) then - vs := FFactory.wrapValueSet(manager.GetResourceById(request, 'ValueSet', url.substring(9), request.baseUrl, needSecure)) - else if (url.startsWith(request.baseURL+'ValueSet/')) then - vs := FFactory.wrapValueSet(manager.GetResourceById(request, 'ValueSet', url.substring(9+request.baseURL.Length), request.baseUrl, needSecure)) - else - begin - vs := FServer.getValueSetByUrl(url, version); - if vs = nil then - vs := FFactory.wrapValueSet(manager.getResourceByUrl('ValueSet', url, '', true, needSecure)); - if vs = nil then - if not FServer.isKnownValueSet(url, vs) then - vs := FFactory.wrapValueSet(manager.GetResourceByUrl('ValueSet', url, version, false, needSecure)); - end; - end; - if vs = nil then - raise ETerminologyError.Create('Unable to find value set for URL "'+url+'"', itUnknown); - - cacheId := vs.url; - if vs.version <> '' then - cacheId := cacheId + vs.version; - end - else if params.has('valueSet') then - begin - vs := FFactory.wrapValueSet(params.obj('valueSet').Link as TFHIRResourceV); - vs.tagInt := 1; - txResources := processAdditionalResources(context, manager, vs, params); - end - else if (request.Resource <> nil) and (request.Resource.fhirType = 'ValueSet') then - begin - vs := FFactory.wrapValueSet(request.Resource.Link); - vs.tagInt := 1; - txResources := processAdditionalResources(context, manager, vs, params); - end - else if params.has('context') then - begin - id := params.str('context'); - id := readValueSetUri(manager, id, params.str('operation')); - vs := FFactory.wrapValueSet(manager.getResourceByUrl('ValueSet', id, '', false, needSecure)); - if vs = nil then - raise ETerminologyError.Create('The context '+id+' was not understood', itInvalid); - cacheId := vs.url; - if vs.version <> '' then - cacheId := cacheId + vs.version; - end - else - raise ETerminologyError.Create('Unable to find value set to expand (not provided by id, identifier, or directly)', itUnknown); - - if vs.getId <> '' then - result := 'Expand ValueSet '+vs.getId+' on '+vs.source - else if vs.url <> '' then - result := 'Expand ValueSet '+vs.url+' on '+vs.source - else - result := 'Expand inline ValueSet on '+vs.source; - vs.checkNoImplicitRules('ExpandValueSet', 'ValueSet'); - FFactory.checkNoModifiers(vs.Resource, 'ExpandValueSet', 'ValueSet'); - - profile := buildExpansionParams(request, manager, params); - try - filter := params.str('filter'); - count := StrToIntDef(params.str('count'), -1); - offset := StrToIntDef(params.str('offset'), -1); - limit := StrToIntDef(params.str('_limit'), -1); - if (limit < -1) then - limit := -1 - else if limit > UPPER_LIMIT_TEXT then - limit := UPPER_LIMIT_TEXT; // can't ask for more than this externally, though you can internally - - if (txResources = nil) then - txResources := processAdditionalResources(context, manager, nil, params); - dst := FServer.expandVS(vs, request.internalRequestId, cacheId, profile, filter, limit, count, offset, txResources, params.str('no-cache') = 'please'); - try - response.HTTPCode := 200; - response.Message := 'OK'; - response.Body := ''; - response.LastModifiedDate := now; - response.Resource := dst.Resource.Link; - // response.categories.... no tags to go on this resource - finally - dst.free; - end; - finally - profile.free; - end; - finally - txResources.free; - vs.free; - params.free; - end; - end; - end; - manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, response.httpCode, '', response.message, []); - except - on e: exception do - begin - manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, 500, '', e.message, []); - recordStack(e); - raise; - end; - end; -end; - -function TFhirExpandValueSetOperation.formalURL: String; -begin - result := 'http://hl7.org/fhir/OperationDefinition/ValueSet-expand'; -end; - -function TFhirExpandValueSetOperation.isWrite: boolean; -begin - result := false; -end; - -{ TFhirValueSetValidationOperation } - -function TFhirValueSetValidationOperation.Name: String; -begin - result := 'validate-code'; -end; - -function TFhirValueSetValidationOperation.owningResource: String; -begin - result := 'ValueSet'; -end; - -function TFhirValueSetValidationOperation.isValidation: boolean; -begin - Result := true; -end; - -function TFhirValueSetValidationOperation.Types: TArray; -begin - result := ['ValueSet', 'CodeSystem']; -end; - -function TFhirValueSetValidationOperation.isWrite: boolean; -begin - result := false; -end; - -function TFhirValueSetValidationOperation.CreateDefinition(base : String): TFHIROperationDefinitionW; -begin - result := nil; -end; - -function canonicalMatches(mr : TFHIRMetadataResourceW; canonical, version : String) : boolean; -var - l, r : String; -begin - if canonical.Contains('|') then - begin - StringSplit(canonical, '|', l, r); - if (version <> '') and (l <> version) then - exit(false); - end - else - begin - l := canonical; - r := version; - end; - - result := (mr.url = l) and ((r = '') or (r = mr.version)); -end; - -function TFhirValueSetValidationOperation.Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response: TFHIRResponse; tt : TTimeTracker) : String; -var - vs : TFHIRValueSetW; - resourceKey, versionKey : integer; - cacheId, url, summary, issuePath, version, msg : String; - coded : TFhirCodeableConceptW; -// coding : TFhirCodingW; - abstractOk, inferSystem : boolean; - params, pout : TFhirParametersW; - oOut : TFHIROperationOutcomeW; - needSecure, isValueSet : boolean; - mode : TValidationCheckMode; - profile : TFhirExpansionParams; - txResources : TFslMetadataResourceList; - mr : TFHIRMetadataResourceW; -begin - isValueSet := request.ResourceName = 'ValueSet'; - - result := 'Validate Code'; - try - manager.NotFound(request, response); - if manager.check(response, manager.opAllowed(request.ResourceName, request.CommandType), 400, manager.langList, StringFormat(GetFhirMessage('MSG_OP_NOT_ALLOWED', manager.langList), [CODES_TFHIRCommandType[request.CommandType], request.ResourceName]), itForbidden) then - begin - if (request.id = '') or ((length(request.id) <= ID_LENGTH) and manager.FindResource(request.ResourceName, request.Id, [], resourceKey, versionKey, request, response, nil)) then - begin - cacheId := ''; - params := makeParams(request); - try - vs := nil; - txResources := nil; - pout := nil; - oOut := nil; - profile := nil; - try - profile := buildExpansionParams(request, manager, params); - coded := loadCoded(request, isValueSet, issuePath, mode); - try - result := 'Validate Code '+coded.renderText; - try - if isValueSet then - begin - // first, we have to identify the value set. - if request.Id <> '' then // and it must exist, because of the check above - begin - vs := FFactory.wrapValueSet(manager.GetResourceById(request, 'ValueSet', request.Id, request.baseUrl, needSecure)); - cacheId := vs.url; - result := result+' in vs '+request.id; - end - else if params.has('url') then - begin - url := params.str('url'); - version := params.str('valueSetVersion'); - if (version = '') then - result := result+' in vs '+url+'|'+version+' (ref)' - else - result := result+' in vs '+url+' (ref)'; - txResources := processAdditionalResources(context, manager, nil, params); - for mr in txResources do - if (canonicalMatches(mr, url, version)) and (mr is TFHIRValueSetW) then - begin - vs := (mr as TFHIRValueSetW).link; - break; - end; - if vs = nil then - vs := FServer.getValueSetByUrl(url, version); - if vs = nil then - if not FServer.isKnownValueSet(url, vs) then - vs := FFactory.wrapValueSet(manager.GetResourceByUrl('ValueSet', url, version, false, needSecure)); - if vs = nil then - begin - msg := FServer.i18n.translate('Unable_to_resolve_value_Set_', profile.languages, [url]); - oOut := FFactory.wrapOperationOutcome(FFactory.makeResource('OperationOutcome')); - oOut.addIssue(isError, itNotFound, '', msg, oicNotFound); - end - else - cacheId := vs.vurl; - end - else if params.has('valueSet') then - begin - if not (params.obj('valueSet') is TFHIRResourceV) then - raise ETerminologyError.Create('Error with valueSet parameter - must be a value set', itInvalid); - vs := FFactory.wrapValueSet(params.obj('valueSet').Link as TFHIRResourceV); - result := result+' in vs '+vs.url+' (param)'; - txResources := processAdditionalResources(context, manager, vs, params); - end - else if (request.Resource <> nil) and (request.Resource.fhirType = 'ValueSet') then - begin - vs := FFactory.wrapValueSet(request.Resource.Link); - result := result+' in vs '+vs.url+' (res)'; - txResources := processAdditionalResources(context, manager, vs, params); - end - // else - // raise ETerminologyError.Create('Unable to find valueset to validate against (not provided by id, identifier, or directly)'); - end; - - abstractOk := params.str('abstract') = 'true'; - inferSystem := (params.str('inferSystem') = 'true') or (params.str('implySystem') = 'true'); - - if (oOut = nil) and (pout = nil) then - begin - if (coded = nil) then - raise ETerminologyError.Create('Unable to find code to validate (looked for coding | codeableConcept | code in parameters ='+params.names+')', itNotFound); - - if vs <> nil then - begin - vs.checkNoImplicitRules('ValueSetValidation', 'ValueSet'); - FFactory.checkNoModifiers(vs.Resource, 'ValueSetValidation', 'ValueSet'); - end; - if txResources = nil then - txResources := processAdditionalResources(context, manager, nil, params); - - pout := FServer.validate(request.id, issuePath, vs, coded, profile, abstractOk, inferSystem, mode, txResources, summary); - end; - if summary <> '' then - result := result + ': '+summary; - if (oOut <> nil) then - response.resource := oOut.Resource.link - else - response.resource := pout.Resource.link; - finally - pOut.free; - oOut.free; - end; - response.HTTPCode := 200; - response.Message := 'OK'; - response.Body := ''; - response.LastModifiedDate := now; - finally - coded.free; - end; - finally - profile.free; - vs.free; - txResources.free; - end; - finally - params.free; - end; - end; - end; - manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, response.httpCode, '', response.message, []); - except - on e: exception do - begin - manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, 500, '', e.message, []); - recordStack(e); - raise; - end; - end; -end; - -function TFhirValueSetValidationOperation.formalURL: String; -begin - result := 'http://hl7.org/fhir/OperationDefinition/Resource-validate'; -end; - -(* -{ TFhirCodeSystemComposeOperation } - -function TFhirCodeSystemComposeOperation.Name: String; -begin - result := 'compose'; -end; - -function TFhirCodeSystemComposeOperation.owningResource: String; -begin - result := 'CodeSystem'; -end; - -function TFhirCodeSystemComposeOperation.Types: TArray; -begin - result := ['CodeSystem']; -end; - -function TFhirCodeSystemComposeOperation.CreateDefinition(base : String): TFHIROperationDefinitionW; -begin - result := nil; -end; - -procedure TFhirCodeSystemComposeOperation.Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response: TFHIRResponse); -var - req : TFHIRComposeOpRequest; - resp : TFHIRComposeOpResponse; - resourceKey, versionKey : integer; -begin - try - manager.NotFound(request, response); - if manager.check(response, manager.opAllowed(request.ResourceName, request.CommandType), 400, manager.lang, StringFormat(GetFhirMessage('MSG_OP_NOT_ALLOWED', manager.langList), [CODES_TFHIRCommandType[request.CommandType], request.ResourceName]), itForbidden) then - begin - if (request.id = '') or ((length(request.id) <= ID_LENGTH) and manager.FindResource(request.ResourceName, request.Id, [], resourceKey, versionKey, request, response, nil)) then - begin - req := TFHIRComposeOpRequest.Create; - try - if (request.Resource <> nil) and (request.Resource is TFHIRParameters) then - req.load(request.Resource as TFHIRParameters) - else - req.load(request.Parameters); - - // first, we have to identify the Code System - if request.Id <> '' then // and it must exist, because of the check above - raise ETerminologyError.Create('Specifying a code system is not supported (only snomed-ct is supported)'); - if req.system <> URI_SNOMED then - raise ETerminologyError.Create('Only snomed-ct is supported)'); - // ok, it's snomed - resp := TFHIRComposeOpResponse.Create; - try - try - FServer.composeCode(req, resp); - response.Body := ''; - response.LastModifiedDate := now; - response.Resource := resp.asParams; - response.HTTPCode := 200; - response.Message := 'OK'; - except - on e : Exception do - begin - response.HTTPCode := 400; - response.Message := 'Error'; - response.Resource := BuildOperationOutcome(request.Lang, e, IssueTypeCodeInvalid); - end; - end; - finally - resp.free; - end; - finally - req.free; - end; - end; - end; - manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, response.httpCode, '', response.message); - except - on e: exception do - begin - manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, 500, '', e.message); - recordStack(e); - raise; - end; - end; -end; - -function TFhirCodeSystemComposeOperation.formalURL: String; -begin - result := 'http://hl7.org/fhir/OperationDefinition/CodeSystem-compose'; -end; - -function TFhirCodeSystemComposeOperation.isWrite: boolean; -begin - result := false; -end; -*) - -{ TFhirConceptMapTranslationOperation } - -function TFhirConceptMapTranslationOperation.Types: TArray; -begin - result := ['ConceptMap']; -end; - -function TFhirConceptMapTranslationOperation.CreateDefinition(base: String): TFHIROperationDefinitionW; -begin - result := nil; -end; - -function TFhirConceptMapTranslationOperation.Name: String; -begin - result := 'translate'; -end; - -function TFhirConceptMapTranslationOperation.isWrite: boolean; -begin - result := false; -end; - -function TFhirConceptMapTranslationOperation.owningResource: String; -begin - result := 'ConceptMap'; -end; - -function TFhirConceptMapTranslationOperation.Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response: TFHIRResponse; tt : TTimeTracker) : String; -var - cm : TLoadedConceptMap; -// op : TFhirOperationOutcome; -// resourceKey : integer; - coded : TFhirCodeableConceptW; - coding : TFslList; - dummy : TValidationCheckMode; - params, pOut : TFhirParametersW; - issuePath : String; -begin - result := 'Translate'; - try - manager.NotFound(request, response); - if manager.check(response, manager.opAllowed(request.ResourceName, request.CommandType), 400, manager.langList, StringFormat(GetFhirMessage('MSG_OP_NOT_ALLOWED', manager.langList), [CODES_TFHIRCommandType[request.CommandType], request.ResourceName]), itForbidden) then - begin - params := makeParams(request); - try - // we have to find the right concept map - // it doesn't matter whether the value sets are actually defined or not - if request.id <> '' then - cm := FServer.getConceptMapById(request.id) - else - cm := FServer.getConceptMapBySrcTgt(params.str('valueset'), params.str('target')); - if cm = nil then - raise ETerminologyError.Create('Unable to find concept map to use', itNotFound); - try - // ok, now we need to find the source code to validate - coded := loadCoded(request, true, issuePath, dummy); -(* if params.has('coding') then - begin - coded := TFhirCodeableConcept.Create; - coded.codingList.add(LoadDTFromParam(request.Context, params.str['coding'], request.lang, 'coding', TFhirCoding) as TFhirCoding) - end - else if params.has('codeableConcept') then - coded := LoadDTFromParam(request.Context, params.str['codeableConcept'], request.lang, 'codeableConcept', TFhirCodeableConcept) as TFhirCodeableConcept - else if params.has('code') and params.has('system') then - begin - coded := TFhirCodeableConcept.Create; - coding := coded.codingList.Append; - coding.system := params.str['system']; - coding.version := params.str['version']; - coding.code := params.str['code']; - coding.display := params.str['display']; - end - else - raise ETerminologyError.Create('Unable to find code to translate (looked for coding | codeableConcept | code in parameters ='+params.names+')'); - *) - try - coding := coded.codings; - try - pOut := FServer.translate(request.langList, cm, coding[0]); - try - response.resource := pOut.Resource.link; - response.HTTPCode := 200; - response.Message := 'OK'; - response.Body := ''; - response.LastModifiedDate := now; - finally - pOut.free; - end; - finally - coding.free; - end; - finally - coded.free; - end; - finally - cm.free; - end; - finally - params.free; - end; - end; - manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, response.httpCode, '', response.message, []); - except - on e: exception do - begin - manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, 500, '', e.message, []); - recordStack(e); - raise; - end; - end; -end; - -function TFhirConceptMapTranslationOperation.formalURL: String; -begin - result := 'http://hl7.org/fhir/OperationDefinition/ConceptMap-translate'; -end; - -{ TFhirLookupCodeSystemOperation } - -function TFhirLookupCodeSystemOperation.Name: String; -begin - result := 'lookup'; -end; - -function TFhirLookupCodeSystemOperation.owningResource: String; -begin - result := 'CodeSystem'; -end; - -function TFhirLookupCodeSystemOperation.Types: TArray; -begin - result := ['CodeSystem']; -end; - -function TFhirLookupCodeSystemOperation.CreateDefinition(base : String): TFHIROperationDefinitionW; -begin - result := nil; -end; - -function TFhirLookupCodeSystemOperation.Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response: TFHIRResponse; tt : TTimeTracker) : String; -var - req : TFHIRLookupOpRequestW; - resp : TFHIRLookupOpResponseW; - c : TFhirCodingW; - langList : THTTPLanguageList; -begin - result := 'lookup code'; - try - manager.NotFound(request, response); - if manager.check(response, manager.opAllowed(request.ResourceName, request.CommandType), 400, manager.langList, StringFormat(GetFhirMessage('MSG_OP_NOT_ALLOWED', manager.langList), [CODES_TFHIRCommandType[request.CommandType], request.ResourceName]), itForbidden) then - begin - if (request.id <> '') then - raise ETerminologyError.Create('Lookup does not take an identified resource', itInvalid); - req := ffactory.makeOpReqLookup; - try - if (request.Resource <> nil) and (request.Resource.fhirType = 'Parameters') then - req.load(request.Resource) - else - req.load(request.Parameters); - req.loadCoding; - if req.displayLanguage <> '' then - langList := THTTPLanguageList.Create(req.displayLanguage, false) - else - langList := request.langList.Link; - try - result := 'lookup code '+req.coding.renderText; - - response.Body := ''; - response.LastModifiedDate := now; - resp := ffactory.makeOpRespLookup; - try - try - FServer.lookupCode(req.coding, langList, req.propList, resp); // currently, we ignore the date - response.CacheControl := cacheNotAtAll; - response.Resource := resp.asParams; - response.HTTPCode := 200; - response.Message := 'OK'; - except - on e : Exception do - begin - response.HTTPCode := 400; - response.Message := 'Error'; - response.Resource := FFactory.BuildOperationOutcome(request.LangList, e, itInvalid); - end; - end; - finally - resp.free; - end; - finally - langList.free; - end; - finally - req.free; - end; - end; - manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, response.httpCode, '', response.message, []); - except - on e: exception do - begin - manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, 500, '', e.message, []); - recordStack(e); - raise; - end; - end; -end; - -function TFhirLookupCodeSystemOperation.formalURL: String; -begin - if FFactory.version = fhirVersionRelease2 then - result := 'http://hl7.org/fhir/OperationDefinition/CodeSystem-lookup' - else - result := 'http://hl7.org/fhir/OperationDefinition/ValueSet-lookup'; -end; - -function TFhirLookupCodeSystemOperation.isWrite: boolean; -begin - result := false; -end; - -{ TFhirConceptMapClosureOperation } - -function TFhirConceptMapClosureOperation.checkName(request: TFHIRRequest; response: TFHIRResponse; var name: String) : boolean; -begin - if request.Session.UserEvidence = userAnonymous then - result := IsGuid(name) - else - begin - result := IsId(name); - if result and not IsGUID(name) then - name := inttostr(request.Session.UserKey)+'|'+name; - end; - if not result then - begin - response.HTTPCode := 400; - response.Message := StringFormat('invalid closure name %s', [request.ResourceName+':'+request.Id]); - response.Body := response.Message; - response.Resource := FFactory.BuildOperationOutcome(request.langList, response.Message); - end; -end; - -constructor TFhirConceptMapClosureOperation.Create(factory : TFHIRFactory; server: TTerminologyServer; languages : TIETFLanguageDefinitions); -begin - inherited Create(factory, server, languages); -end; - -function TFhirConceptMapClosureOperation.CreateDefinition(base: String): TFHIROperationDefinitionW; -begin - result := nil; -end; - -function TFhirConceptMapClosureOperation.Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response: TFHIRResponse; tt : TTimeTracker) : String; -var - params : TFhirParametersW; - p : TFhirParametersParameterW; - n, v : String; - cm : TClosureManager; - map : TFhirConceptMapW; - concepts : TFslList; - procedure errorResp(code : integer; message : String); - begin - response.HTTPCode := code; - response.Message := message; - response.Body := response.Message; - response.Resource := FFactory.BuildOperationOutcome(request.langList, response.Message); - end; -begin - result := 'Closure'; - try - manager.NotFound(request, response); - if manager.check(response, manager.opAllowed(request.ResourceName, request.CommandType), 400, manager.langList, StringFormat(GetFhirMessage('MSG_OP_NOT_ALLOWED', manager.langList), [CODES_TFHIRCommandType[request.CommandType], request.ResourceName]), itForbidden) then - begin - params := makeParams(request); - cm := nil; - map := nil; - try - n := params.str('name'); - if checkName(request, response, n) then - begin - v := params.str('version'); - if (v = '') and not params.has('concept') then - begin - v := FServer.InitClosure(n); - map := FFactory.wrapConceptMap(FFactory.makeResource('ConceptMap')); - response.resource := map.Resource.Link; - map.id := NewGuidId; - map.version := v; - map.status := psActive; - map.date := TFslDateTime.makeUTC; - map.name := 'Closure Table '+n+' initialized'; - response.HTTPCode := 200; - response.Message := 'OK'; - response.Body := ''; - end - else - begin - if not FServer.UseClosure(n, cm) then - errorResp(404, StringFormat('closure name ''%s'' not known', [n])) - else if (v <> '') and params.has('concept') then - errorResp(404, StringFormat('closure ''%s'': cannot combine version and concept', [n])) - else if (v <> '') and not StringIsInteger32(v) then - errorResp(404, StringFormat('closure ''%s'': version %s is not valid', [n, v])) - else - begin - response.HTTPCode := 200; - response.Message := 'OK'; - response.Body := ''; - map := FFactory.wrapConceptMap(FFactory.makeResource('ConceptMap')); - response.resource := map.Resource.Link; - map.id := NewGuidId; - map.version := inttostr(cm.version); - map.status := psActive; - map.date := TFslDateTime.makeUTC; - map.name := 'Updates for Closure Table '+n; - if (v <> '') then - begin - map.name := 'Replay for Closure Table '+n+' from version '+v; - // cm.rerun(Fconnection, map, StrToInt(v)) - end - else - begin - map.name := 'Updates for Closure Table '+n; - concepts := TFslList.Create; - try - for p in params.parameterList do - if p.Name = 'concept' then - concepts.Add(FFactory.wrapCoding(p.value.Link)); - // cm.processConcepts(FConnection, concepts, map); - finally - concepts.free; - end; - end; - end; - end; - end; - finally - params.free; - cm.free; - map.free; - end; - end; - manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, response.httpCode, '', response.message, []); - except - on e: exception do - begin - manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, 500, '', e.message, []); - recordStack(e); - raise; - end; - end; -end; - -function TFhirConceptMapClosureOperation.formalURL: String; -begin - result := 'http://hl7.org/fhir/OperationDefinition/ConceptMap-closure'; -end; - -function TFhirConceptMapClosureOperation.isWrite: boolean; -begin - result := false; -end; - -function TFhirConceptMapClosureOperation.Name: String; -begin - result := 'closure'; -end; - -function TFhirConceptMapClosureOperation.owningResource: String; -begin - result := ''; -end; - -function TFhirConceptMapClosureOperation.Types: TArray; -begin - result := []; -end; - -{ TFhirSubsumesSystemOperation } - -function TFhirSubsumesOperation.Name: String; -begin - result := 'subsumes'; -end; - -function TFhirSubsumesOperation.owningResource: String; -begin - result := 'CodeSystem'; -end; - -function TFhirSubsumesOperation.Types: TArray; -begin - result := ['CodeSystem']; -end; - -function TFhirSubsumesOperation.CreateDefinition(base : String): TFHIROperationDefinitionW; -begin - result := nil; -end; - -function TFhirSubsumesOperation.Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response: TFHIRResponse; tt : TTimeTracker) : String; -var - req : TFHIRSubsumesOpRequestW; - resp : TFHIRSubsumesOpResponseW; - resourceKey, versionKey : integer; - cs : TFhirCodeSystemW; - ca, cb : TFhirCodingW; - cacheId : string; - needSecure : boolean; -begin - result := 'Subsumes'; - try - manager.NotFound(request, response); - if manager.check(response, manager.opAllowed(request.ResourceName, request.CommandType), 400, manager.langList, StringFormat(GetFhirMessage('MSG_OP_NOT_ALLOWED', manager.langList), [CODES_TFHIRCommandType[request.CommandType], request.ResourceName]), itForbidden) then - begin - if (request.id = '') or ((length(request.id) <= ID_LENGTH) and manager.FindResource(request.ResourceName, request.Id, [], resourceKey, versionKey, request, response, nil)) then - begin - req := FFactory.makeOpReqSubsumes; - try - if (request.Resource <> nil) and (request.Resource.fhirType = 'Parameters') then - req.load(request.Resource) - else - req.load(request.Parameters); - - response.Body := ''; - response.LastModifiedDate := now; - resp := FFactory.makeOpRespSubsumes; - try - try - if (request.Id = '') and (req.systemUri <> '') and (req.codeA <> '') and (req.codeB <> '') then - begin - if not FServer.isValidCode(req.systemUri, req.codeA) or not FServer.isValidCode(req.systemUri, req.codeB) then - raise ETerminologyError.Create('Invalid code', itNotFound) - else if (req.codeA = req.codeB) then - resp.outcome := 'equivalent' - else if FServer.subsumes(req.systemUri, req.codeA, req.systemUri, req.codeB) then - resp.outcome := 'subsumes' - else if FServer.subsumes(req.systemUri, req.codeB, req.systemUri, req.codeA) then - resp.outcome := 'subsumed-by' - else - resp.outcome := 'not-subsumed'; - end - else - begin - // first, we have to identify the Code System - if request.Id <> '' then // and it must exist, because of the check above - cs := FFactory.wrapCodeSystem(manager.GetResourceById(request, 'CodeSystem', request.Id, request.baseUrl, needSecure)) - else if req.systemUri <> '' then - cs := FFactory.wrapCodeSystem(manager.GetResourceByUrl('CodeSystem', req.systemUri, req.version, false, needSecure)) - else - raise ETerminologyError.Create('No CodeSystem Identified (need a system parameter, or execute the operation on a CodeSystem resource', itUnknown); - - cacheId := cs.url; - ca := req.codingA; - cb := req.codingB; - try - if (ca = nil) and (req.codeA <> '') then - ca := FFactory.wrapCoding(FFactory.makeCoding(cs.url, req.codeA)); - if (cb = nil) and (req.codeB <> '') then - cb := FFactory.wrapCoding(FFactory.makeCoding(cs.url, req.codeB)); - if ca = nil then - raise ETerminologyError.Create('No codeA or codingA parameter found', itNotFound); - if cb = nil then - raise ETerminologyError.Create('No codeB or codingB parameter found', itNotFound); - - resp.outcome := FServer.subsumes(cs, ca, cb); - finally - ca.free; - cb.free; - end; - end; - response.Resource := resp.asParams; - response.HTTPCode := 200; - response.Message := 'OK'; - except - on e : Exception do - begin - response.HTTPCode := 400; - response.Message := 'Error'; - response.Resource := FFactory.BuildOperationOutcome(request.langList, e, itInvalid); - end; - end; - finally - resp.free; - end; - finally - req.free; - end; - end; - end; - manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, response.httpCode, '', response.message, []); - except - on e: exception do - begin - manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, 500, '', e.message, []); - recordStack(e); - raise; - end; - end; -end; - -function TFhirSubsumesOperation.formalURL: String; -begin - result := 'http://hl7.org/fhir/OperationDefinition/CodeSystem-subsumes'; -end; - -function TFhirSubsumesOperation.isWrite: boolean; -begin - result := false; -end; - - -{ TFhirTerminologyOperation } - -function TFhirTerminologyOperation.processAdditionalResources(context : TOperationContext; manager: TFHIROperationEngine; mr : TFHIRMetadataResourceW; params: TFHIRParametersW): TFslMetadataResourceList; -var - p : TFhirParametersParameterW; - list : TFslMetadataResourceList; - cacheId : String; - vs : TFHIRValueSetW; - cs : TFHIRCodeSystemW; -begin - cacheId := ''; - list := TFslMetadataResourceList.Create; - try - if (mr <> nil) then - list.Add(mr.link); - for p in params.parameterList do - begin - if (p.name = 'cache-id') then - begin - cacheId := p.valueString; - end; - if (p.name = 'tx-resource') then - begin - if p.resource.fhirType = 'ValueSet' then - begin - vs := FFactory.wrapValueSet(p.resource.link); - list.Add(vs); - vs.TagInt := 1; // marks it as not stored - end - else if p.resource.fhirType = 'CodeSystem' then - begin - cs := FFactory.wrapCodeSystem(p.resource.link); - list.Add(cs); - cs.TagInt := 1; // marks it as not stored - end; - end; - end; - if cacheId = '' then - begin - result := list.link - end - else - begin - context.CacheResponse := false; // no point caching these, they'll never be seen again - result := manager.clientCacheManager.processResources(cacheId, list); - end; - finally - list.free; - end; -end; - -function TFhirTerminologyOperation.isValidation: boolean; -begin - result := false; -end; - -procedure TFhirTerminologyOperation.processExpansionParams(request: TFHIRRequest; manager: TFHIROperationEngine; params: TFhirParametersW; result : TFHIRExpansionParams); -var - p : TFhirParametersParameterW; - obj : TFHIRObject; - pp : TFHIRParametersW; -begin - result.generateNarrative := false; // todo...? - - if (params.str('no-cache') = 'true') then - result.uid := NewGuidId; - if (params.str('_incomplete') <> '') then - result.limitedExpansion := StrToBoolDef(params.str('_incomplete'), false); - if (params.str('limitedExpansion') <> '') then - result.limitedExpansion := StrToBoolDef(params.str('limitedExpansion'), false); - if (params.str('includeDesignations') <> '') then - result.includeDesignations := StrToBoolDef(params.str('includeDesignations'), false); - if (params.str('includeDefinition') <> '') then - result.includeDefinition := StrToBoolDef(params.str('includeDefinition'), false); - if (params.str('activeOnly') <> '') then - result.activeOnly := StrToBoolDef(params.str('activeOnly'), false); - if (params.str('excludeNested') <> '') then - result.excludeNested := StrToBoolDef(params.str('excludeNested'), false); - if (params.str('excludeNotForUI') <> '') then - result.excludeNotForUI := StrToBoolDef(params.str('excludeNotForUI'), false); - if (params.str('excludePostCoordinated') <> '') then - result.excludePostCoordinated := StrToBoolDef(params.str('excludePostCoordinated'), false); - if (params.str('default-to-latest-version') <> '') then - result.defaultToLatestVersion := StrToBoolDef(params.str('default-to-latest-version'), false); - if (params.str('incomplete-ok') <> '') then - result.incompleteOK := StrToBoolDef(params.str('incomplete-ok'), false); - for p in params.parameterList do - begin - if (p.name = 'system-version') then - result.seeVersionRule(p.valueString, fvmDefault) - else if (p.name = 'check-system-version') then - result.seeVersionRule(p.valueString, fvmCheck) - else if (p.name = 'force-system-version') then - result.seeVersionRule(p.valueString, fvmOverride) - else if (p.name = 'displayLanguage') then - result.languages := THTTPLanguageList.create(p.valueString, not isValidation) - else if (p.name = 'property') then - result.properties.add(p.valueString) - else if (p.name = 'lenient-display-validation') and (p.valueString = 'true') then - result.displayWarning := true - else if (p.name = 'valueset-membership-only') and (p.valueString = 'true') then - result.membershipOnly := true - else if (p.name = 'includeAlternateCodes') then - result.altCodeRules.seeParam(p.valueString) - else if (p.name = 'designation') then - result.designations.add(p.valueString); - end; - if params.has('profile') then - begin - obj := params.obj('profile'); - if (obj <> nil) and ((obj.fhirType = 'Parameters') or (obj.fhirType = 'ExpansionProfile')) then - begin - pp := FFactory.wrapParams(obj.link as TFHIRResourceV); - try - processExpansionParams(request, manager, pp, result); - finally - pp.free; - end; - end - end; - - if not result.hasLanguages and (request.ContentLanguage <> '') then - result.languages := THTTPLanguageList.create(request.ContentLanguage, not isValidation);; - if not result.hasLanguages and (request.LangList <> nil) and (request.LangList.source <> '') then - result.languages := THTTPLanguageList.create(request.LangList.source, not isValidation); -end; - -function TFhirTerminologyOperation.buildExpansionParams(request: TFHIRRequest; manager: TFHIROperationEngine; params: TFhirParametersW): TFHIRExpansionParams; -begin - result := TFHIRExpansionParams.Create; - try - processExpansionParams(request, manager, params, result); - result.link; - finally - result.free; - end; -end; - -constructor TFhirTerminologyOperation.Create(factory : TFHIRFactory; server: TTerminologyServer; languages : TIETFLanguageDefinitions); -begin - inherited Create(factory, languages); - FServer := server; -end; - -destructor TFhirTerminologyOperation.Destroy; -begin - FServer.free; - inherited; -end; - -function TFhirTerminologyOperation.loadCoded(request : TFHIRRequest; isValueSet : boolean; var issuePath : string; var mode : TValidationCheckMode): TFhirCodeableConceptW; -var - coding : TFhirCodingW; - params : TFhirParametersW; -begin - // ok, now we need to find the source code to validate - if (request.form <> nil) and request.form.hasParam('coding') then - begin - result := FFactory.wrapCodeableConcept(fFactory.makeByName('CodeableConcept')); - coding := FFactory.makeDtFromForm(request.form.getParam('coding'), request.langList, 'coding', 'Coding') as TFHIRCodingW; - try - result.addCoding(coding); - finally - coding.free; - end; - issuePath := 'Coding'; - mode := vcmCoding; - end - else if (request.form <> nil) and request.form.hasParam('codeableConcept') then - begin - mode := vcmCodeableConcept; - result := FFactory.makeDtFromForm(request.form.getParam('codeableConcept'), request.langList, 'codeableConcept', 'CodeableConcept') as TFhirCodeableConceptW; - issuePath := 'CodeableConcept'; - end - else if request.Parameters.has('code') and (request.Parameters.has('system') or request.Parameters.has('inferSystem') or request.Parameters.has('implySystem')) then - begin - issuePath := ''; - mode := vcmCode; - result := FFactory.wrapCodeableConcept(fFactory.makeByName('CodeableConcept')); - coding := result.addCoding; - try - coding.systemUri := request.Parameters['system']; - coding.version := request.Parameters['systemVersion']; - if (coding.version = '') then - coding.version := request.Parameters['version']; - coding.code := request.Parameters['code']; - coding.display := request.Parameters['display']; - finally - coding.free; - end; - end - else if not isValueSet and request.Parameters.has('code') and request.Parameters.has('url') then - begin - issuePath := ''; - mode := vcmCode; - result := FFactory.wrapCodeableConcept(fFactory.makeByName('CodeableConcept')); - coding := result.addCoding; - try - coding.systemUri := request.Parameters['url']; - coding.version := request.Parameters['version']; - coding.code := request.Parameters['code']; - coding.display := request.Parameters['display']; - finally - coding.free; - end; - end - else if ((request.resource <> nil) and (request.Resource.fhirType = 'Parameters')) then - begin - params := FFactory.wrapParams(request.Resource.link); - try - if params.obj('coding') <> nil then - begin - mode := vcmCoding; - result := FFactory.wrapCodeableConcept(fFactory.makeByName('CodeableConcept')); - issuePath := 'Coding'; - coding := FFactory.wrapCoding(params.obj('coding').Link); - try - result.addCoding(coding); - finally - coding.free; - end; - end - else if params.has('codeableConcept') then - begin - mode := vcmCodeableConcept; - result := FFactory.wrapCodeableConcept(params.obj('codeableConcept').Link); - issuePath := 'CodeableConcept'; - end - else if (params.has('code') and (params.has('system')) or (isValueSet and (params.has('code') and (params.bool('inferSystem') or params.bool('implySystem'))))) then - begin - issuePath := ''; - mode := vcmCode; - result := FFactory.wrapCodeableConcept(fFactory.makeByName('CodeableConcept')); - coding := result.addCoding; - try - if params.has('system') then - coding.systemUri := params.str('system'); - if params.has('systemVersion') then - coding.version := params.str('systemVersion'); - if (coding.version = '') and params.has('version') then - coding.version := params.str('version'); - coding.code := params.str('code'); - if params.has('display') then - coding.display := params.str('display'); - finally - coding.free; - end; - end - else if not isValueSet and (params.has('code') and params.has('url')) then - begin - issuePath := ''; - mode := vcmCode; - result := FFactory.wrapCodeableConcept(fFactory.makeByName('CodeableConcept')); - coding := result.addCoding; - try - coding.systemUri := params.str('url'); - if params.has('version') then - coding.version := params.str('version'); - coding.code := params.str('code'); - if params.has('display') then - coding.display := params.str('display'); - finally - coding.free; - end; - end - else - raise ETerminologyError.Create('Unable to find code to validate (looked for coding | codeableConcept | code in parameters ='+params.names+')', itNotFound); - finally - params.free; - end; - end - else - raise ETerminologyError.Create('Unable to find code to validate (looked for coding | codeableConcept | code+system in parameters ='+request.Parameters.Source+')', itNotFound); -end; - -end. +unit tx_operations; + +{ +Copyright (c) 2017+, Health Intersections Pty Ltd (http://www.healthintersections.com.au) +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of HL7 nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +} + +{$I fhir.inc} + +interface + +uses + SysUtils, + fsl_base, fsl_utilities, fsl_logging, fsl_http, fsl_lang, + fdb_manager, + fhir_objects, fhir_utilities, fhir_common, fhir_factory, + fhir_valuesets, + session, storage, ftx_service, tx_manager, tx_server, closuremanager, time_tracker; + +type + + { TFhirTerminologyOperation } + + TFhirTerminologyOperation = class (TFhirOperation) + protected + FServer : TTerminologyServer; + + function isValidation : boolean; virtual; + procedure processExpansionParams(request: TFHIRRequest; manager: TFHIROperationEngine; params : TFhirParametersW; result : TFHIRExpansionParams); + function buildExpansionParams(request: TFHIRRequest; manager: TFHIROperationEngine; params : TFhirParametersW) : TFHIRExpansionParams; + function loadCoded(request : TFHIRRequest; isValueSet : boolean; var issuePath : string; var mode : TValidationCheckMode) : TFhirCodeableConceptW; + function processAdditionalResources(context : TOperationContext; manager: TFHIROperationEngine; mr : TFHIRMetadataResourceW; params : TFHIRParametersW) : TFslMetadataResourceList; + public + constructor Create(factory : TFHIRFactory; server : TTerminologyServer; languages : TIETFLanguageDefinitions); + destructor Destroy; override; + end; + + TFhirExpandValueSetOperation = class (TFhirTerminologyOperation) + protected + function isWrite : boolean; override; + function owningResource : String; override; + function readValueSetUri(manager: TFHIROperationEngine; url : String; op : String) : String; + public + function Name : String; override; + function Types : TArray; override; + function CreateDefinition(base : String) : TFHIROperationDefinitionW; override; + function Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response : TFHIRResponse; tt : TTimeTracker) : String; override; + function formalURL : String; override; + end; + + { TFhirValueSetValidationOperation } + + TFhirValueSetValidationOperation = class (TFhirTerminologyOperation) + protected + function isWrite : boolean; override; + function owningResource : String; override; + function isValidation : boolean; override; + public + function Name : String; override; + function Types : TArray; override; + function CreateDefinition(base : String) : TFHIROperationDefinitionW; override; + function Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response : TFHIRResponse; tt : TTimeTracker) : String; override; + function formalURL : String; override; + end; + +(** + TFhirCodeSystemComposeOperation = class (TFhirTerminologyOperation) + protected + function isWrite : boolean; override; + function owningResource : String; override; + public + function Name : String; override; + function Types : TArray; override; + function CreateDefinition(base : String) : TFHIROperationDefinitionW; override; + procedure Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response : TFHIRResponse); override; + function formalURL : String; override; + end; +*) + + TFhirSubsumesOperation = class (TFhirTerminologyOperation) + protected + function isWrite : boolean; override; + function owningResource : String; override; + public + function Name : String; override; + function Types : TArray; override; + function CreateDefinition(base : String) : TFHIROperationDefinitionW; override; + function Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response : TFHIRResponse; tt : TTimeTracker) : String; override; + function formalURL : String; override; + end; + + TFhirConceptMapTranslationOperation = class (TFhirTerminologyOperation) + protected + function isWrite : boolean; override; + function owningResource : String; override; + public + function Name : String; override; + function Types : TArray; override; + function CreateDefinition(base : String) : TFHIROperationDefinitionW; override; + function Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response : TFHIRResponse; tt : TTimeTracker) : String; override; + function formalURL : String; override; + end; + + + TFhirLookupCodeSystemOperation = class (TFhirTerminologyOperation) + protected + function isWrite : boolean; override; + function owningResource : String; override; + public + function Name : String; override; + function Types : TArray; override; + function CreateDefinition(base : String) : TFHIROperationDefinitionW; override; + function Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response : TFHIRResponse; tt : TTimeTracker) : String; override; + function formalURL : String; override; + end; + + + TFhirConceptMapClosureOperation = class (TFhirTerminologyOperation) + protected + function isWrite : boolean; override; + function owningResource : String; override; + function checkName(request: TFHIRRequest; response : TFHIRResponse; var name : String) : boolean; + public + constructor Create(factory : TFHIRFactory; server : TTerminologyServer; languages : TIETFLanguageDefinitions); + function Name : String; override; + function Types : TArray; override; + function CreateDefinition(base : String) : TFHIROperationDefinitionW; override; + function Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response : TFHIRResponse; tt : TTimeTracker) : String; override; + function formalURL : String; override; + end; + + +implementation + +{ TFhirExpandValueSetOperation } + +function TFhirExpandValueSetOperation.Name: String; +begin + result := 'expand'; +end; + +function TFhirExpandValueSetOperation.owningResource: String; +begin + result := 'ValueSet'; +end; + +function TFhirExpandValueSetOperation.readValueSetUri(manager: TFHIROperationEngine; url, op: String): String; +var + sd : TFhirStructureDefinitionW; + ed : TFHIRElementDefinitionW; + u, p, t : String; + needSecure : boolean; +begin + if url.Contains('#') then + StringSplit(url, '#', u, p) + else + begin + if not url.Contains('.') then + raise EFSLException.Create('Unable to understand url "'+url+'"'); + StringSplit(url,'.', u, t); + u := 'http://hl7.org/fhir/StructureDefinition/'+u; + p := url; + end; + sd := FFactory.wrapStructureDefinition(manager.GetResourceByUrl('StructureDefinition', u, '', false, needSecure)); + try + ed := sd.getDefinition(p, edsSNAPSHOT); + if ed = nil then + raise EFSLException.Create('Unable to resolve element "'+p+'" in "'+u+'"'); + try + if (ed.valueSet = '') then + raise EFSLException.Create('No value set for element "'+p+'" in "'+u+'"'); + result := ed.valueSet; + finally + ed.free; + end; + finally + sd.free; + end; +end; + +function TFhirExpandValueSetOperation.Types: TArray; +begin + result := ['ValueSet']; +end; + +function TFhirExpandValueSetOperation.CreateDefinition(base : String): TFHIROperationDefinitionW; +begin + result := nil; +end; + +function TFhirExpandValueSetOperation.Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response: TFHIRResponse; tt : TTimeTracker) : String; +var + vs, dst : TFHIRValueSetW; + resourceKey, versionKey : integer; + url, cacheId, filter, id, version : String; + profile : TFHIRExpansionParams; + limit, count, offset : integer; + params : TFhirParametersW; + needSecure : boolean; + txResources : TFslMetadataResourceList; + mr : TFHIRMetadataResourceW; +begin + result := 'Expand ValueSet'; + try + manager.NotFound(request, response); + if manager.check(response, manager.opAllowed(request.ResourceName, request.CommandType), 400, manager.langList, StringFormat(GetFhirMessage('MSG_OP_NOT_ALLOWED', manager.langList), [CODES_TFHIRCommandType[request.CommandType], request.ResourceName]), itForbidden) then + begin + if (request.id = '') or ((length(request.id) <= ID_LENGTH) and manager.FindResource(request.ResourceName, request.Id, [], resourceKey, versionKey, request, response, nil)) then + begin + cacheId := ''; + params := makeParams(request); + vs := nil; + txResources := nil; + try + // first, we have to identify the value set. + if request.Id <> '' then // and it must exist, because of the check above + begin + vs := FFactory.wrapValueSet(manager.GetResourceById(request, 'ValueSet', request.Id, request.baseUrl, needSecure)); + cacheId := vs.url; + if vs.version <> '' then + cacheId := cacheId + vs.version; + end + else if params.has('url') then + begin + url := params.str('url'); + version := request.Parameters['valueSetVersion']; + txResources := processAdditionalResources(context, manager, nil, params); + for mr in txResources do + if (mr.url = url) and (mr is TFHIRValueSetW) then + begin + vs := (mr as TFHIRValueSetW).link; + break; + end; + if (vs = nil) then + begin + if (url.startsWith('ValueSet/')) then + vs := FFactory.wrapValueSet(manager.GetResourceById(request, 'ValueSet', url.substring(9), request.baseUrl, needSecure)) + else if (url.startsWith(request.baseURL+'ValueSet/')) then + vs := FFactory.wrapValueSet(manager.GetResourceById(request, 'ValueSet', url.substring(9+request.baseURL.Length), request.baseUrl, needSecure)) + else + begin + vs := FServer.getValueSetByUrl(url, version); + if vs = nil then + vs := FFactory.wrapValueSet(manager.getResourceByUrl('ValueSet', url, '', true, needSecure)); + if vs = nil then + if not FServer.isKnownValueSet(url, vs) then + vs := FFactory.wrapValueSet(manager.GetResourceByUrl('ValueSet', url, version, false, needSecure)); + end; + end; + if vs = nil then + raise ETerminologyError.Create('Unable to find value set for URL "'+url+'"', itUnknown); + + cacheId := vs.url; + if vs.version <> '' then + cacheId := cacheId + vs.version; + end + else if params.has('valueSet') then + begin + vs := FFactory.wrapValueSet(params.obj('valueSet').Link as TFHIRResourceV); + vs.tagInt := 1; + txResources := processAdditionalResources(context, manager, vs, params); + end + else if (request.Resource <> nil) and (request.Resource.fhirType = 'ValueSet') then + begin + vs := FFactory.wrapValueSet(request.Resource.Link); + vs.tagInt := 1; + txResources := processAdditionalResources(context, manager, vs, params); + end + else if params.has('context') then + begin + id := params.str('context'); + id := readValueSetUri(manager, id, params.str('operation')); + vs := FFactory.wrapValueSet(manager.getResourceByUrl('ValueSet', id, '', false, needSecure)); + if vs = nil then + raise ETerminologyError.Create('The context '+id+' was not understood', itInvalid); + cacheId := vs.url; + if vs.version <> '' then + cacheId := cacheId + vs.version; + end + else + raise ETerminologyError.Create('Unable to find value set to expand (not provided by id, identifier, or directly)', itUnknown); + + if vs.getId <> '' then + result := 'Expand ValueSet '+vs.getId+' on '+vs.source + else if vs.url <> '' then + result := 'Expand ValueSet '+vs.url+' on '+vs.source + else + result := 'Expand inline ValueSet on '+vs.source; + vs.checkNoImplicitRules('ExpandValueSet', 'ValueSet'); + FFactory.checkNoModifiers(vs.Resource, 'ExpandValueSet', 'ValueSet'); + + profile := buildExpansionParams(request, manager, params); + try + filter := params.str('filter'); + count := StrToIntDef(params.str('count'), -1); + offset := StrToIntDef(params.str('offset'), -1); + limit := StrToIntDef(params.str('_limit'), -1); + if (limit < -1) then + limit := -1 + else if limit > UPPER_LIMIT_TEXT then + limit := UPPER_LIMIT_TEXT; // can't ask for more than this externally, though you can internally + + if (txResources = nil) then + txResources := processAdditionalResources(context, manager, nil, params); + dst := FServer.expandVS(vs, request.internalRequestId, cacheId, profile, filter, limit, count, offset, txResources, params.str('no-cache') = 'please'); + try + response.HTTPCode := 200; + response.Message := 'OK'; + response.Body := ''; + response.LastModifiedDate := now; + response.Resource := dst.Resource.Link; + // response.categories.... no tags to go on this resource + finally + dst.free; + end; + finally + profile.free; + end; + finally + txResources.free; + vs.free; + params.free; + end; + end; + end; + manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, response.httpCode, '', response.message, []); + except + on e: exception do + begin + manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, 500, '', e.message, []); + recordStack(e); + raise; + end; + end; +end; + +function TFhirExpandValueSetOperation.formalURL: String; +begin + result := 'http://hl7.org/fhir/OperationDefinition/ValueSet-expand'; +end; + +function TFhirExpandValueSetOperation.isWrite: boolean; +begin + result := false; +end; + +{ TFhirValueSetValidationOperation } + +function TFhirValueSetValidationOperation.Name: String; +begin + result := 'validate-code'; +end; + +function TFhirValueSetValidationOperation.owningResource: String; +begin + result := 'ValueSet'; +end; + +function TFhirValueSetValidationOperation.isValidation: boolean; +begin + Result := true; +end; + +function TFhirValueSetValidationOperation.Types: TArray; +begin + result := ['ValueSet', 'CodeSystem']; +end; + +function TFhirValueSetValidationOperation.isWrite: boolean; +begin + result := false; +end; + +function TFhirValueSetValidationOperation.CreateDefinition(base : String): TFHIROperationDefinitionW; +begin + result := nil; +end; + +function canonicalMatches(mr : TFHIRMetadataResourceW; canonical, version : String) : boolean; +var + l, r : String; +begin + if canonical.Contains('|') then + begin + StringSplit(canonical, '|', l, r); + if (version <> '') and (l <> version) then + exit(false); + end + else + begin + l := canonical; + r := version; + end; + + result := (mr.url = l) and ((r = '') or (r = mr.version)); +end; + +function TFhirValueSetValidationOperation.Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response: TFHIRResponse; tt : TTimeTracker) : String; +var + vs : TFHIRValueSetW; + resourceKey, versionKey : integer; + cacheId, url, summary, issuePath, version, msg : String; + coded : TFhirCodeableConceptW; +// coding : TFhirCodingW; + abstractOk, inferSystem : boolean; + params, pout : TFhirParametersW; + oOut : TFHIROperationOutcomeW; + needSecure, isValueSet : boolean; + mode : TValidationCheckMode; + profile : TFhirExpansionParams; + txResources : TFslMetadataResourceList; + mr : TFHIRMetadataResourceW; +begin + isValueSet := request.ResourceName = 'ValueSet'; + + result := 'Validate Code'; + try + manager.NotFound(request, response); + if manager.check(response, manager.opAllowed(request.ResourceName, request.CommandType), 400, manager.langList, StringFormat(GetFhirMessage('MSG_OP_NOT_ALLOWED', manager.langList), [CODES_TFHIRCommandType[request.CommandType], request.ResourceName]), itForbidden) then + begin + if (request.id = '') or ((length(request.id) <= ID_LENGTH) and manager.FindResource(request.ResourceName, request.Id, [], resourceKey, versionKey, request, response, nil)) then + begin + cacheId := ''; + params := makeParams(request); + try + vs := nil; + txResources := nil; + pout := nil; + oOut := nil; + profile := nil; + try + profile := buildExpansionParams(request, manager, params); + coded := loadCoded(request, isValueSet, issuePath, mode); + try + result := 'Validate Code '+coded.renderText; + try + if isValueSet then + begin + // first, we have to identify the value set. + if request.Id <> '' then // and it must exist, because of the check above + begin + vs := FFactory.wrapValueSet(manager.GetResourceById(request, 'ValueSet', request.Id, request.baseUrl, needSecure)); + cacheId := vs.url; + result := result+' in vs '+request.id; + end + else if params.has('url') then + begin + url := params.str('url'); + version := params.str('valueSetVersion'); + if (version = '') then + result := result+' in vs '+url+'|'+version+' (ref)' + else + result := result+' in vs '+url+' (ref)'; + txResources := processAdditionalResources(context, manager, nil, params); + for mr in txResources do + if (canonicalMatches(mr, url, version)) and (mr is TFHIRValueSetW) then + begin + vs := (mr as TFHIRValueSetW).link; + break; + end; + if vs = nil then + vs := FServer.getValueSetByUrl(url, version); + if vs = nil then + if not FServer.isKnownValueSet(url, vs) then + vs := FFactory.wrapValueSet(manager.GetResourceByUrl('ValueSet', url, version, false, needSecure)); + if vs = nil then + begin + msg := FServer.i18n.translate('Unable_to_resolve_value_Set_', profile.languages, [url]); + oOut := FFactory.wrapOperationOutcome(FFactory.makeResource('OperationOutcome')); + oOut.addIssue(isError, itNotFound, '', msg, oicNotFound); + end + else + cacheId := vs.vurl; + end + else if params.has('valueSet') then + begin + if not (params.obj('valueSet') is TFHIRResourceV) then + raise ETerminologyError.Create('Error with valueSet parameter - must be a value set', itInvalid); + vs := FFactory.wrapValueSet(params.obj('valueSet').Link as TFHIRResourceV); + result := result+' in vs '+vs.url+' (param)'; + txResources := processAdditionalResources(context, manager, vs, params); + end + else if (request.Resource <> nil) and (request.Resource.fhirType = 'ValueSet') then + begin + vs := FFactory.wrapValueSet(request.Resource.Link); + result := result+' in vs '+vs.url+' (res)'; + txResources := processAdditionalResources(context, manager, vs, params); + end + // else + // raise ETerminologyError.Create('Unable to find valueset to validate against (not provided by id, identifier, or directly)'); + end; + + abstractOk := params.str('abstract') <> 'false'; + inferSystem := (params.str('inferSystem') = 'true') or (params.str('implySystem') = 'true'); + + if (oOut = nil) and (pout = nil) then + begin + if (coded = nil) then + raise ETerminologyError.Create('Unable to find code to validate (looked for coding | codeableConcept | code in parameters ='+params.names+')', itNotFound); + + if vs <> nil then + begin + vs.checkNoImplicitRules('ValueSetValidation', 'ValueSet'); + FFactory.checkNoModifiers(vs.Resource, 'ValueSetValidation', 'ValueSet'); + end; + if txResources = nil then + txResources := processAdditionalResources(context, manager, nil, params); + + pout := FServer.validate(request.id, issuePath, vs, coded, profile, abstractOk, inferSystem, mode, txResources, summary); + end; + if summary <> '' then + result := result + ': '+summary; + if (oOut <> nil) then + response.resource := oOut.Resource.link + else + response.resource := pout.Resource.link; + finally + pOut.free; + oOut.free; + end; + response.HTTPCode := 200; + response.Message := 'OK'; + response.Body := ''; + response.LastModifiedDate := now; + finally + coded.free; + end; + finally + profile.free; + vs.free; + txResources.free; + end; + finally + params.free; + end; + end; + end; + manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, response.httpCode, '', response.message, []); + except + on e: exception do + begin + manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, 500, '', e.message, []); + recordStack(e); + raise; + end; + end; +end; + +function TFhirValueSetValidationOperation.formalURL: String; +begin + result := 'http://hl7.org/fhir/OperationDefinition/Resource-validate'; +end; + +(* +{ TFhirCodeSystemComposeOperation } + +function TFhirCodeSystemComposeOperation.Name: String; +begin + result := 'compose'; +end; + +function TFhirCodeSystemComposeOperation.owningResource: String; +begin + result := 'CodeSystem'; +end; + +function TFhirCodeSystemComposeOperation.Types: TArray; +begin + result := ['CodeSystem']; +end; + +function TFhirCodeSystemComposeOperation.CreateDefinition(base : String): TFHIROperationDefinitionW; +begin + result := nil; +end; + +procedure TFhirCodeSystemComposeOperation.Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response: TFHIRResponse); +var + req : TFHIRComposeOpRequest; + resp : TFHIRComposeOpResponse; + resourceKey, versionKey : integer; +begin + try + manager.NotFound(request, response); + if manager.check(response, manager.opAllowed(request.ResourceName, request.CommandType), 400, manager.lang, StringFormat(GetFhirMessage('MSG_OP_NOT_ALLOWED', manager.langList), [CODES_TFHIRCommandType[request.CommandType], request.ResourceName]), itForbidden) then + begin + if (request.id = '') or ((length(request.id) <= ID_LENGTH) and manager.FindResource(request.ResourceName, request.Id, [], resourceKey, versionKey, request, response, nil)) then + begin + req := TFHIRComposeOpRequest.Create; + try + if (request.Resource <> nil) and (request.Resource is TFHIRParameters) then + req.load(request.Resource as TFHIRParameters) + else + req.load(request.Parameters); + + // first, we have to identify the Code System + if request.Id <> '' then // and it must exist, because of the check above + raise ETerminologyError.Create('Specifying a code system is not supported (only snomed-ct is supported)'); + if req.system <> URI_SNOMED then + raise ETerminologyError.Create('Only snomed-ct is supported)'); + // ok, it's snomed + resp := TFHIRComposeOpResponse.Create; + try + try + FServer.composeCode(req, resp); + response.Body := ''; + response.LastModifiedDate := now; + response.Resource := resp.asParams; + response.HTTPCode := 200; + response.Message := 'OK'; + except + on e : Exception do + begin + response.HTTPCode := 400; + response.Message := 'Error'; + response.Resource := BuildOperationOutcome(request.Lang, e, IssueTypeCodeInvalid); + end; + end; + finally + resp.free; + end; + finally + req.free; + end; + end; + end; + manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, response.httpCode, '', response.message); + except + on e: exception do + begin + manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, 500, '', e.message); + recordStack(e); + raise; + end; + end; +end; + +function TFhirCodeSystemComposeOperation.formalURL: String; +begin + result := 'http://hl7.org/fhir/OperationDefinition/CodeSystem-compose'; +end; + +function TFhirCodeSystemComposeOperation.isWrite: boolean; +begin + result := false; +end; +*) + +{ TFhirConceptMapTranslationOperation } + +function TFhirConceptMapTranslationOperation.Types: TArray; +begin + result := ['ConceptMap']; +end; + +function TFhirConceptMapTranslationOperation.CreateDefinition(base: String): TFHIROperationDefinitionW; +begin + result := nil; +end; + +function TFhirConceptMapTranslationOperation.Name: String; +begin + result := 'translate'; +end; + +function TFhirConceptMapTranslationOperation.isWrite: boolean; +begin + result := false; +end; + +function TFhirConceptMapTranslationOperation.owningResource: String; +begin + result := 'ConceptMap'; +end; + +function TFhirConceptMapTranslationOperation.Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response: TFHIRResponse; tt : TTimeTracker) : String; +var + cm : TLoadedConceptMap; +// op : TFhirOperationOutcome; +// resourceKey : integer; + coded : TFhirCodeableConceptW; + coding : TFslList; + dummy : TValidationCheckMode; + params, pOut : TFhirParametersW; + issuePath : String; +begin + result := 'Translate'; + try + manager.NotFound(request, response); + if manager.check(response, manager.opAllowed(request.ResourceName, request.CommandType), 400, manager.langList, StringFormat(GetFhirMessage('MSG_OP_NOT_ALLOWED', manager.langList), [CODES_TFHIRCommandType[request.CommandType], request.ResourceName]), itForbidden) then + begin + params := makeParams(request); + try + // we have to find the right concept map + // it doesn't matter whether the value sets are actually defined or not + if request.id <> '' then + cm := FServer.getConceptMapById(request.id) + else + cm := FServer.getConceptMapBySrcTgt(params.str('valueset'), params.str('target')); + if cm = nil then + raise ETerminologyError.Create('Unable to find concept map to use', itNotFound); + try + // ok, now we need to find the source code to validate + coded := loadCoded(request, true, issuePath, dummy); +(* if params.has('coding') then + begin + coded := TFhirCodeableConcept.Create; + coded.codingList.add(LoadDTFromParam(request.Context, params.str['coding'], request.lang, 'coding', TFhirCoding) as TFhirCoding) + end + else if params.has('codeableConcept') then + coded := LoadDTFromParam(request.Context, params.str['codeableConcept'], request.lang, 'codeableConcept', TFhirCodeableConcept) as TFhirCodeableConcept + else if params.has('code') and params.has('system') then + begin + coded := TFhirCodeableConcept.Create; + coding := coded.codingList.Append; + coding.system := params.str['system']; + coding.version := params.str['version']; + coding.code := params.str['code']; + coding.display := params.str['display']; + end + else + raise ETerminologyError.Create('Unable to find code to translate (looked for coding | codeableConcept | code in parameters ='+params.names+')'); + *) + try + coding := coded.codings; + try + pOut := FServer.translate(request.langList, cm, coding[0]); + try + response.resource := pOut.Resource.link; + response.HTTPCode := 200; + response.Message := 'OK'; + response.Body := ''; + response.LastModifiedDate := now; + finally + pOut.free; + end; + finally + coding.free; + end; + finally + coded.free; + end; + finally + cm.free; + end; + finally + params.free; + end; + end; + manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, response.httpCode, '', response.message, []); + except + on e: exception do + begin + manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, 500, '', e.message, []); + recordStack(e); + raise; + end; + end; +end; + +function TFhirConceptMapTranslationOperation.formalURL: String; +begin + result := 'http://hl7.org/fhir/OperationDefinition/ConceptMap-translate'; +end; + +{ TFhirLookupCodeSystemOperation } + +function TFhirLookupCodeSystemOperation.Name: String; +begin + result := 'lookup'; +end; + +function TFhirLookupCodeSystemOperation.owningResource: String; +begin + result := 'CodeSystem'; +end; + +function TFhirLookupCodeSystemOperation.Types: TArray; +begin + result := ['CodeSystem']; +end; + +function TFhirLookupCodeSystemOperation.CreateDefinition(base : String): TFHIROperationDefinitionW; +begin + result := nil; +end; + +function TFhirLookupCodeSystemOperation.Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response: TFHIRResponse; tt : TTimeTracker) : String; +var + req : TFHIRLookupOpRequestW; + resp : TFHIRLookupOpResponseW; + c : TFhirCodingW; + langList : THTTPLanguageList; +begin + result := 'lookup code'; + try + manager.NotFound(request, response); + if manager.check(response, manager.opAllowed(request.ResourceName, request.CommandType), 400, manager.langList, StringFormat(GetFhirMessage('MSG_OP_NOT_ALLOWED', manager.langList), [CODES_TFHIRCommandType[request.CommandType], request.ResourceName]), itForbidden) then + begin + if (request.id <> '') then + raise ETerminologyError.Create('Lookup does not take an identified resource', itInvalid); + req := ffactory.makeOpReqLookup; + try + if (request.Resource <> nil) and (request.Resource.fhirType = 'Parameters') then + req.load(request.Resource) + else + req.load(request.Parameters); + req.loadCoding; + if req.displayLanguage <> '' then + langList := THTTPLanguageList.Create(req.displayLanguage, false) + else + langList := request.langList.Link; + try + result := 'lookup code '+req.coding.renderText; + + response.Body := ''; + response.LastModifiedDate := now; + resp := ffactory.makeOpRespLookup; + try + try + FServer.lookupCode(req.coding, langList, req.propList, resp); // currently, we ignore the date + response.CacheControl := cacheNotAtAll; + response.Resource := resp.asParams; + response.HTTPCode := 200; + response.Message := 'OK'; + except + on e : Exception do + begin + response.HTTPCode := 400; + response.Message := 'Error'; + response.Resource := FFactory.BuildOperationOutcome(request.LangList, e, itInvalid); + end; + end; + finally + resp.free; + end; + finally + langList.free; + end; + finally + req.free; + end; + end; + manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, response.httpCode, '', response.message, []); + except + on e: exception do + begin + manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, 500, '', e.message, []); + recordStack(e); + raise; + end; + end; +end; + +function TFhirLookupCodeSystemOperation.formalURL: String; +begin + if FFactory.version = fhirVersionRelease2 then + result := 'http://hl7.org/fhir/OperationDefinition/CodeSystem-lookup' + else + result := 'http://hl7.org/fhir/OperationDefinition/ValueSet-lookup'; +end; + +function TFhirLookupCodeSystemOperation.isWrite: boolean; +begin + result := false; +end; + +{ TFhirConceptMapClosureOperation } + +function TFhirConceptMapClosureOperation.checkName(request: TFHIRRequest; response: TFHIRResponse; var name: String) : boolean; +begin + if request.Session.UserEvidence = userAnonymous then + result := IsGuid(name) + else + begin + result := IsId(name); + if result and not IsGUID(name) then + name := inttostr(request.Session.UserKey)+'|'+name; + end; + if not result then + begin + response.HTTPCode := 400; + response.Message := StringFormat('invalid closure name %s', [request.ResourceName+':'+request.Id]); + response.Body := response.Message; + response.Resource := FFactory.BuildOperationOutcome(request.langList, response.Message); + end; +end; + +constructor TFhirConceptMapClosureOperation.Create(factory : TFHIRFactory; server: TTerminologyServer; languages : TIETFLanguageDefinitions); +begin + inherited Create(factory, server, languages); +end; + +function TFhirConceptMapClosureOperation.CreateDefinition(base: String): TFHIROperationDefinitionW; +begin + result := nil; +end; + +function TFhirConceptMapClosureOperation.Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response: TFHIRResponse; tt : TTimeTracker) : String; +var + params : TFhirParametersW; + p : TFhirParametersParameterW; + n, v : String; + cm : TClosureManager; + map : TFhirConceptMapW; + concepts : TFslList; + procedure errorResp(code : integer; message : String); + begin + response.HTTPCode := code; + response.Message := message; + response.Body := response.Message; + response.Resource := FFactory.BuildOperationOutcome(request.langList, response.Message); + end; +begin + result := 'Closure'; + try + manager.NotFound(request, response); + if manager.check(response, manager.opAllowed(request.ResourceName, request.CommandType), 400, manager.langList, StringFormat(GetFhirMessage('MSG_OP_NOT_ALLOWED', manager.langList), [CODES_TFHIRCommandType[request.CommandType], request.ResourceName]), itForbidden) then + begin + params := makeParams(request); + cm := nil; + map := nil; + try + n := params.str('name'); + if checkName(request, response, n) then + begin + v := params.str('version'); + if (v = '') and not params.has('concept') then + begin + v := FServer.InitClosure(n); + map := FFactory.wrapConceptMap(FFactory.makeResource('ConceptMap')); + response.resource := map.Resource.Link; + map.id := NewGuidId; + map.version := v; + map.status := psActive; + map.date := TFslDateTime.makeUTC; + map.name := 'Closure Table '+n+' initialized'; + response.HTTPCode := 200; + response.Message := 'OK'; + response.Body := ''; + end + else + begin + if not FServer.UseClosure(n, cm) then + errorResp(404, StringFormat('closure name ''%s'' not known', [n])) + else if (v <> '') and params.has('concept') then + errorResp(404, StringFormat('closure ''%s'': cannot combine version and concept', [n])) + else if (v <> '') and not StringIsInteger32(v) then + errorResp(404, StringFormat('closure ''%s'': version %s is not valid', [n, v])) + else + begin + response.HTTPCode := 200; + response.Message := 'OK'; + response.Body := ''; + map := FFactory.wrapConceptMap(FFactory.makeResource('ConceptMap')); + response.resource := map.Resource.Link; + map.id := NewGuidId; + map.version := inttostr(cm.version); + map.status := psActive; + map.date := TFslDateTime.makeUTC; + map.name := 'Updates for Closure Table '+n; + if (v <> '') then + begin + map.name := 'Replay for Closure Table '+n+' from version '+v; + // cm.rerun(Fconnection, map, StrToInt(v)) + end + else + begin + map.name := 'Updates for Closure Table '+n; + concepts := TFslList.Create; + try + for p in params.parameterList do + if p.Name = 'concept' then + concepts.Add(FFactory.wrapCoding(p.value.Link)); + // cm.processConcepts(FConnection, concepts, map); + finally + concepts.free; + end; + end; + end; + end; + end; + finally + params.free; + cm.free; + map.free; + end; + end; + manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, response.httpCode, '', response.message, []); + except + on e: exception do + begin + manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, 500, '', e.message, []); + recordStack(e); + raise; + end; + end; +end; + +function TFhirConceptMapClosureOperation.formalURL: String; +begin + result := 'http://hl7.org/fhir/OperationDefinition/ConceptMap-closure'; +end; + +function TFhirConceptMapClosureOperation.isWrite: boolean; +begin + result := false; +end; + +function TFhirConceptMapClosureOperation.Name: String; +begin + result := 'closure'; +end; + +function TFhirConceptMapClosureOperation.owningResource: String; +begin + result := ''; +end; + +function TFhirConceptMapClosureOperation.Types: TArray; +begin + result := []; +end; + +{ TFhirSubsumesSystemOperation } + +function TFhirSubsumesOperation.Name: String; +begin + result := 'subsumes'; +end; + +function TFhirSubsumesOperation.owningResource: String; +begin + result := 'CodeSystem'; +end; + +function TFhirSubsumesOperation.Types: TArray; +begin + result := ['CodeSystem']; +end; + +function TFhirSubsumesOperation.CreateDefinition(base : String): TFHIROperationDefinitionW; +begin + result := nil; +end; + +function TFhirSubsumesOperation.Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response: TFHIRResponse; tt : TTimeTracker) : String; +var + req : TFHIRSubsumesOpRequestW; + resp : TFHIRSubsumesOpResponseW; + resourceKey, versionKey : integer; + cs : TFhirCodeSystemW; + ca, cb : TFhirCodingW; + cacheId : string; + needSecure : boolean; +begin + result := 'Subsumes'; + try + manager.NotFound(request, response); + if manager.check(response, manager.opAllowed(request.ResourceName, request.CommandType), 400, manager.langList, StringFormat(GetFhirMessage('MSG_OP_NOT_ALLOWED', manager.langList), [CODES_TFHIRCommandType[request.CommandType], request.ResourceName]), itForbidden) then + begin + if (request.id = '') or ((length(request.id) <= ID_LENGTH) and manager.FindResource(request.ResourceName, request.Id, [], resourceKey, versionKey, request, response, nil)) then + begin + req := FFactory.makeOpReqSubsumes; + try + if (request.Resource <> nil) and (request.Resource.fhirType = 'Parameters') then + req.load(request.Resource) + else + req.load(request.Parameters); + + response.Body := ''; + response.LastModifiedDate := now; + resp := FFactory.makeOpRespSubsumes; + try + try + if (request.Id = '') and (req.systemUri <> '') and (req.codeA <> '') and (req.codeB <> '') then + begin + if not FServer.isValidCode(req.systemUri, req.codeA) or not FServer.isValidCode(req.systemUri, req.codeB) then + raise ETerminologyError.Create('Invalid code', itNotFound) + else if (req.codeA = req.codeB) then + resp.outcome := 'equivalent' + else if FServer.subsumes(req.systemUri, req.codeA, req.systemUri, req.codeB) then + resp.outcome := 'subsumes' + else if FServer.subsumes(req.systemUri, req.codeB, req.systemUri, req.codeA) then + resp.outcome := 'subsumed-by' + else + resp.outcome := 'not-subsumed'; + end + else + begin + // first, we have to identify the Code System + if request.Id <> '' then // and it must exist, because of the check above + cs := FFactory.wrapCodeSystem(manager.GetResourceById(request, 'CodeSystem', request.Id, request.baseUrl, needSecure)) + else if req.systemUri <> '' then + cs := FFactory.wrapCodeSystem(manager.GetResourceByUrl('CodeSystem', req.systemUri, req.version, false, needSecure)) + else + raise ETerminologyError.Create('No CodeSystem Identified (need a system parameter, or execute the operation on a CodeSystem resource', itUnknown); + + cacheId := cs.url; + ca := req.codingA; + cb := req.codingB; + try + if (ca = nil) and (req.codeA <> '') then + ca := FFactory.wrapCoding(FFactory.makeCoding(cs.url, req.codeA)); + if (cb = nil) and (req.codeB <> '') then + cb := FFactory.wrapCoding(FFactory.makeCoding(cs.url, req.codeB)); + if ca = nil then + raise ETerminologyError.Create('No codeA or codingA parameter found', itNotFound); + if cb = nil then + raise ETerminologyError.Create('No codeB or codingB parameter found', itNotFound); + + resp.outcome := FServer.subsumes(cs, ca, cb); + finally + ca.free; + cb.free; + end; + end; + response.Resource := resp.asParams; + response.HTTPCode := 200; + response.Message := 'OK'; + except + on e : Exception do + begin + response.HTTPCode := 400; + response.Message := 'Error'; + response.Resource := FFactory.BuildOperationOutcome(request.langList, e, itInvalid); + end; + end; + finally + resp.free; + end; + finally + req.free; + end; + end; + end; + manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, response.httpCode, '', response.message, []); + except + on e: exception do + begin + manager.AuditRest(request.session, request.internalRequestId, request.externalRequestId, request.ip, request.ResourceName, request.id, response.versionId, 0, request.CommandType, request.Provenance, request.OperationName, 500, '', e.message, []); + recordStack(e); + raise; + end; + end; +end; + +function TFhirSubsumesOperation.formalURL: String; +begin + result := 'http://hl7.org/fhir/OperationDefinition/CodeSystem-subsumes'; +end; + +function TFhirSubsumesOperation.isWrite: boolean; +begin + result := false; +end; + + +{ TFhirTerminologyOperation } + +function TFhirTerminologyOperation.processAdditionalResources(context : TOperationContext; manager: TFHIROperationEngine; mr : TFHIRMetadataResourceW; params: TFHIRParametersW): TFslMetadataResourceList; +var + p : TFhirParametersParameterW; + list : TFslMetadataResourceList; + cacheId : String; + vs : TFHIRValueSetW; + cs : TFHIRCodeSystemW; +begin + cacheId := ''; + list := TFslMetadataResourceList.Create; + try + if (mr <> nil) then + list.Add(mr.link); + for p in params.parameterList do + begin + if (p.name = 'cache-id') then + begin + cacheId := p.valueString; + end; + if (p.name = 'tx-resource') then + begin + if p.resource.fhirType = 'ValueSet' then + begin + vs := FFactory.wrapValueSet(p.resource.link); + list.Add(vs); + vs.TagInt := 1; // marks it as not stored + end + else if p.resource.fhirType = 'CodeSystem' then + begin + cs := FFactory.wrapCodeSystem(p.resource.link); + list.Add(cs); + cs.TagInt := 1; // marks it as not stored + end; + end; + end; + if cacheId = '' then + begin + result := list.link + end + else + begin + context.CacheResponse := false; // no point caching these, they'll never be seen again + result := manager.clientCacheManager.processResources(cacheId, list); + end; + finally + list.free; + end; +end; + +function TFhirTerminologyOperation.isValidation: boolean; +begin + result := false; +end; + +procedure TFhirTerminologyOperation.processExpansionParams(request: TFHIRRequest; manager: TFHIROperationEngine; params: TFhirParametersW; result : TFHIRExpansionParams); +var + p : TFhirParametersParameterW; + obj : TFHIRObject; + pp : TFHIRParametersW; +begin + result.generateNarrative := false; // todo...? + + if (params.str('no-cache') = 'true') then + result.uid := NewGuidId; + if (params.str('_incomplete') <> '') then + result.limitedExpansion := StrToBoolDef(params.str('_incomplete'), false); + if (params.str('limitedExpansion') <> '') then + result.limitedExpansion := StrToBoolDef(params.str('limitedExpansion'), false); + if (params.str('includeDesignations') <> '') then + result.includeDesignations := StrToBoolDef(params.str('includeDesignations'), false); + if (params.str('includeDefinition') <> '') then + result.includeDefinition := StrToBoolDef(params.str('includeDefinition'), false); + if (params.str('activeOnly') <> '') then + result.activeOnly := StrToBoolDef(params.str('activeOnly'), false); + if (params.str('excludeNested') <> '') then + result.excludeNested := StrToBoolDef(params.str('excludeNested'), false); + if (params.str('excludeNotForUI') <> '') then + result.excludeNotForUI := StrToBoolDef(params.str('excludeNotForUI'), false); + if (params.str('excludePostCoordinated') <> '') then + result.excludePostCoordinated := StrToBoolDef(params.str('excludePostCoordinated'), false); + if (params.str('default-to-latest-version') <> '') then + result.defaultToLatestVersion := StrToBoolDef(params.str('default-to-latest-version'), false); + if (params.str('incomplete-ok') <> '') then + result.incompleteOK := StrToBoolDef(params.str('incomplete-ok'), false); + for p in params.parameterList do + begin + if (p.name = 'system-version') then + result.seeVersionRule(p.valueString, fvmDefault) + else if (p.name = 'check-system-version') then + result.seeVersionRule(p.valueString, fvmCheck) + else if (p.name = 'force-system-version') then + result.seeVersionRule(p.valueString, fvmOverride) + else if (p.name = 'displayLanguage') then + result.languages := THTTPLanguageList.create(p.valueString, not isValidation) + else if (p.name = 'property') then + result.properties.add(p.valueString) + else if (p.name = 'lenient-display-validation') and (p.valueString = 'true') then + result.displayWarning := true + else if (p.name = 'valueset-membership-only') and (p.valueString = 'true') then + result.membershipOnly := true + else if (p.name = 'includeAlternateCodes') then + result.altCodeRules.seeParam(p.valueString) + else if (p.name = 'designation') then + result.designations.add(p.valueString); + end; + if params.has('profile') then + begin + obj := params.obj('profile'); + if (obj <> nil) and ((obj.fhirType = 'Parameters') or (obj.fhirType = 'ExpansionProfile')) then + begin + pp := FFactory.wrapParams(obj.link as TFHIRResourceV); + try + processExpansionParams(request, manager, pp, result); + finally + pp.free; + end; + end + end; + + if not result.hasLanguages and (request.ContentLanguage <> '') then + result.languages := THTTPLanguageList.create(request.ContentLanguage, not isValidation);; + if not result.hasLanguages and (request.LangList <> nil) and (request.LangList.source <> '') then + result.languages := THTTPLanguageList.create(request.LangList.source, not isValidation); +end; + +function TFhirTerminologyOperation.buildExpansionParams(request: TFHIRRequest; manager: TFHIROperationEngine; params: TFhirParametersW): TFHIRExpansionParams; +begin + result := TFHIRExpansionParams.Create; + try + processExpansionParams(request, manager, params, result); + result.link; + finally + result.free; + end; +end; + +constructor TFhirTerminologyOperation.Create(factory : TFHIRFactory; server: TTerminologyServer; languages : TIETFLanguageDefinitions); +begin + inherited Create(factory, languages); + FServer := server; +end; + +destructor TFhirTerminologyOperation.Destroy; +begin + FServer.free; + inherited; +end; + +function TFhirTerminologyOperation.loadCoded(request : TFHIRRequest; isValueSet : boolean; var issuePath : string; var mode : TValidationCheckMode): TFhirCodeableConceptW; +var + coding : TFhirCodingW; + params : TFhirParametersW; +begin + // ok, now we need to find the source code to validate + if (request.form <> nil) and request.form.hasParam('coding') then + begin + result := FFactory.wrapCodeableConcept(fFactory.makeByName('CodeableConcept')); + coding := FFactory.makeDtFromForm(request.form.getParam('coding'), request.langList, 'coding', 'Coding') as TFHIRCodingW; + try + result.addCoding(coding); + finally + coding.free; + end; + issuePath := 'Coding'; + mode := vcmCoding; + end + else if (request.form <> nil) and request.form.hasParam('codeableConcept') then + begin + mode := vcmCodeableConcept; + result := FFactory.makeDtFromForm(request.form.getParam('codeableConcept'), request.langList, 'codeableConcept', 'CodeableConcept') as TFhirCodeableConceptW; + issuePath := 'CodeableConcept'; + end + else if request.Parameters.has('code') and (request.Parameters.has('system') or request.Parameters.has('inferSystem') or request.Parameters.has('implySystem')) then + begin + issuePath := ''; + mode := vcmCode; + result := FFactory.wrapCodeableConcept(fFactory.makeByName('CodeableConcept')); + coding := result.addCoding; + try + coding.systemUri := request.Parameters['system']; + coding.version := request.Parameters['systemVersion']; + if (coding.version = '') then + coding.version := request.Parameters['version']; + coding.code := request.Parameters['code']; + coding.display := request.Parameters['display']; + finally + coding.free; + end; + end + else if not isValueSet and request.Parameters.has('code') and request.Parameters.has('url') then + begin + issuePath := ''; + mode := vcmCode; + result := FFactory.wrapCodeableConcept(fFactory.makeByName('CodeableConcept')); + coding := result.addCoding; + try + coding.systemUri := request.Parameters['url']; + coding.version := request.Parameters['version']; + coding.code := request.Parameters['code']; + coding.display := request.Parameters['display']; + finally + coding.free; + end; + end + else if ((request.resource <> nil) and (request.Resource.fhirType = 'Parameters')) then + begin + params := FFactory.wrapParams(request.Resource.link); + try + if params.obj('coding') <> nil then + begin + mode := vcmCoding; + result := FFactory.wrapCodeableConcept(fFactory.makeByName('CodeableConcept')); + issuePath := 'Coding'; + coding := FFactory.wrapCoding(params.obj('coding').Link); + try + result.addCoding(coding); + finally + coding.free; + end; + end + else if params.has('codeableConcept') then + begin + mode := vcmCodeableConcept; + result := FFactory.wrapCodeableConcept(params.obj('codeableConcept').Link); + issuePath := 'CodeableConcept'; + end + else if (params.has('code') and (params.has('system')) or (isValueSet and (params.has('code') and (params.bool('inferSystem') or params.bool('implySystem'))))) then + begin + issuePath := ''; + mode := vcmCode; + result := FFactory.wrapCodeableConcept(fFactory.makeByName('CodeableConcept')); + coding := result.addCoding; + try + if params.has('system') then + coding.systemUri := params.str('system'); + if params.has('systemVersion') then + coding.version := params.str('systemVersion'); + if (coding.version = '') and params.has('version') then + coding.version := params.str('version'); + coding.code := params.str('code'); + if params.has('display') then + coding.display := params.str('display'); + finally + coding.free; + end; + end + else if not isValueSet and (params.has('code') and params.has('url')) then + begin + issuePath := ''; + mode := vcmCode; + result := FFactory.wrapCodeableConcept(fFactory.makeByName('CodeableConcept')); + coding := result.addCoding; + try + coding.systemUri := params.str('url'); + if params.has('version') then + coding.version := params.str('version'); + coding.code := params.str('code'); + if params.has('display') then + coding.display := params.str('display'); + finally + coding.free; + end; + end + else + raise ETerminologyError.Create('Unable to find code to validate (looked for coding | codeableConcept | code in parameters ='+params.names+')', itNotFound); + finally + params.free; + end; + end + else + raise ETerminologyError.Create('Unable to find code to validate (looked for coding | codeableConcept | code+system in parameters ='+request.Parameters.Source+')', itNotFound); +end; + +end. diff --git a/server/tx_registry_model.pas b/server/tx_registry_model.pas index e66370363..0570df8f2 100644 --- a/server/tx_registry_model.pas +++ b/server/tx_registry_model.pas @@ -1,855 +1,883 @@ -unit tx_registry_model; - -{$i fhir.inc} - -interface - -uses - Classes, SysUtils, - fsl_base, fsl_json, fsl_utilities, fsl_versions, fsl_threads; - -Type - TServerSecurity = (ssOpen, ssPassword, ssToken, ssOAuth, ssSmart, ssCert); - TServerSecuritySet = set of TServerSecurity; - -const - CODES_TServerSecurity : Array[TServerSecurity] of String = ('open', 'password', 'token', 'oauth', 'smart', 'cert'); - -type - { TServerVersionInformation } - - TServerVersionInformation = class (TFslObject) - private - FError: String; - FAddress : String; - FLastTat: String; - FVersion : String; - FCodeSystems : TStringList; - FValueSets : TStringList; - FLastSuccess : TFslDateTime; - FSecurity : TServerSecuritySet; - public - constructor Create; override; - destructor Destroy; override; - function Link : TServerVersionInformation; overload; - property Version : String read FVersion write FVersion; - property Address : String read FAddress write FAddress; - property Security : TServerSecuritySet read FSecurity write FSecurity; - property Error : String read FError write FError; - property LastSuccess : TFslDateTime read FLastSuccess write FLastSuccess; - property lastTat : String read FLastTat write FLastTat; - property CodeSystems : TStringList read FCodeSystems; - property ValueSets : TStringList read FValueSets; - procedure update(source : TServerVersionInformation); - - function Details : String; - function cslist : String; - function vslist : String; - end; - - { TServerInformation } - - TServerInformation = class (TFslObject) - private - FCode: String; - FName : string; - FAddress : String; - FAccessInfo : String; - FAuthCSlist : TStringList; - FAuthVSlist : TStringList; - FUsageList : TStringList; - FVersions : TFslList; - public - constructor Create; override; - destructor Destroy; override; - function Link : TServerInformation; overload; - property Code : String read FCode write FCode; - property Name : String read FName write FName; - property Address : String read FAddress write FAddress; - property AccessInfo : String read FAccessInfo write FAccessInfo; - property AuthCSList : TStringList read FAuthCSList; - property AuthVSList : TStringList read FAuthVSList; - property UsageList : TStringList read FUsageList; - property Versions : TFslList read FVersions; - function version(ver : String) : TServerVersionInformation; - procedure update(source : TServerInformation); - - function Details : String; - function isAuthCS(tx : String) : boolean; - function isAuthVS(vs : String) : boolean; - function Description : String; - end; - - { TServerRegistry } - - TServerRegistry = class (TFslObject) - private - FCode: String; - FName : string; - FAddress : String; - FAuthority : string; - FError : String; - FServers : TFslList; - public - constructor Create; override; - destructor Destroy; override; - function Link : TServerRegistry; overload; - property Code : String read FCode write FCode; - property Name : String read FName write FName; - property Address : String read FAddress write FAddress; - property Authority : String read FAuthority write FAuthority; - property Error : String read FError write FError; - property Servers : TFslList read FServers; - - function server(code : String) : TServerInformation; - procedure update(source : TServerRegistry); - end; - - { TServerRegistries } - - TServerRegistries = class (TFslObject) - private - FAddress : String; - FDoco: String; - FLastRun : TFslDateTime; - FOutcome : String; - FRegistries: TFslList; - FLock : TFslLock; - public - constructor Create; override; - destructor Destroy; override; - function Link : TServerRegistries; overload; - property Address : String read FAddress write FAddress; - property doco : String read FDoco write FDoco; - property LastRun : TFslDateTime read FLastRun write FLastRun; - property Outcome : String read FOutcome write FOutcome; - property Registries : TFslList read FRegistries; - procedure Lock(name : String); - procedure UnLock; - - function registry(code : String) : TServerRegistry; - procedure update(source : TServerRegistries); - end; - - { TServerRow } - - TServerRow = class (TFslObject) - private - FError: String; - FLastSuccess: cardinal; - FRegistryCode: String; - FRegistryName: String; - FRegistryUrl: String; - FSecurity: TServerSecuritySet; - FServerCode: String; - FServerName: String; - FSystems: integer; - FSets : integer; - FURL: String; - FVersion: String; - FAuthCSList : TStringList; - FAuthVSList : TStringList; - FAuthoritative : boolean; - public - constructor Create; override; - destructor Destroy; override; - function Link : TServerRow; overload; - property ServerName : String read FServerName write FServerName; - property ServerCode : String read FServerCode write FServerCode; - property RegistryName : String read FRegistryName write FRegistryName; - property RegistryCode : String read FRegistryCode write FRegistryCode; - property RegistryUrl : String read FRegistryUrl write FRegistryUrl; - property AuthCSList : TStringList read FAuthCSList; - property AuthVSList : TStringList read FAuthVSList; - - property Version : String read FVersion write FVersion; - property URL : String read FURL write FURL; - property Error : String read FError write FError; - property Security : TServerSecuritySet read FSecurity write FSecurity; - property LastSuccess : cardinal read FLastSuccess write FLastSuccess; // ms - property systems : integer read FSystems write FSystems; - property sets : integer read FSets write FSets; - property Authoritative : boolean read FAuthoritative write FAuthoritative; - end; - - { TServerRegistryUtilities } - - TServerRegistryUtilities = class (TFslObject) - private - class function securitySetToString(sset : TServerSecuritySet) : String; - class function toJson(v : TServerVersionInformation) : TJsonObject; overload; - class function toJson(s : TServerInformation) : TJsonObject; overload; - class function toJson(r : TServerRegistry) : TJsonObject; overload; - - class function stringToSecuritySet(s : String) : TServerSecuritySet; - class function readVersion(fv : String; json : TJsonObject): TServerVersionInformation; - class function readServer(fv : String; json : TJsonObject): TServerInformation; - class function readRegistry(fv : String; json : TJsonObject): TServerRegistry; - - class procedure addRow(rows : TFslList; reg: TServerRegistry; srvr : TServerInformation; version : TServerVersionInformation; auth : boolean); - class procedure buildRows(reg: TServerRegistry; srvr : TServerInformation; version, tx : String; rows : TFslList); overload; - class procedure buildRows(reg : TServerRegistry; srvrCode, version, tx : String; rows : TFslList); overload; - class procedure buildRows(info : TServerRegistries; regCode, srvrCode, version, tx : String; rows : TFslList); overload; - - public - class function fromJson(json : TJsonObject) : TServerRegistries; - class function toJson(reg : TServerRegistries) : TJsonObject; overload; - class function toJson(row : TServerRow) : TJsonObject; overload; - - class function buildRows(info : TServerRegistries; regCode, srvrCode, version, tx : String) : TFslList; overload; - class function hasMatchingCodeSystem(cs : String; list : TStringList; mask : boolean) : boolean; - class function hasMatchingValueSet(vs : String; list : TStringList; mask : boolean) : boolean; - end; - -implementation - -{ TServerRow } - -constructor TServerRow.Create; -begin - inherited Create; - FAuthCSList := TStringList.Create; - FAuthVSList := TStringList.Create; -end; - -destructor TServerRow.Destroy; -begin - FAuthCSList.free; - FAuthVSList.free; - inherited Destroy; -end; - -function TServerRow.Link: TServerRow; -begin - result := TServerRow(inherited Link); -end; - -{ TServerRegistryUtilities } - -class function TServerRegistryUtilities.securitySetToString(sset: TServerSecuritySet): String; -var - a : TServerSecurity; -begin - result := ''; - for a := low(TServerSecurity) to High(TServerSecurity) do - if a in sset then - CommaAdd(result, CODES_TServerSecurity[a]); -end; - - -class function TServerRegistryUtilities.stringToSecuritySet(s : String) : TServerSecuritySet; -var - a : TServerSecurity; -begin - result := []; - for a := low(TServerSecurity) to High(TServerSecurity) do - if s.Contains(CODES_TServerSecurity[a]) then - result := result + [a]; -end; - -class function TServerRegistryUtilities.toJson(v: TServerVersionInformation): TJsonObject; -var - s : String; -begin - result := TJsonObject.Create; - try - result.str['address'] := v.Address; - result.str['version'] := v.Version; - result.str['security'] := securitySetToString(v.Security); - result.str['error'] := v.Error; - result.str['last-success'] := v.LastSuccess.toXML; - for s in v.CodeSystems do - result.forceArr['terminologies'].add(s); - for s in v.ValueSets do - result.forceArr['valuesets'].add(s); - result.link; - finally - result.free; - end; -end; - -class function TServerRegistryUtilities.readVersion(fv : String; json: TJsonObject): TServerVersionInformation; -var - s : String; -begin - result := TServerVersionInformation.Create; - try - result.Address := json.str['address']; - result.Version := json.str['version']; - result.Security := stringToSecuritySet(json.str['security']); - result.Error := json.str['error']; - result.LastSuccess := TFslDateTime.fromXML(json.str['last-success']); - json.forceArr['terminologies'].readStrings(result.CodeSystems); - json.forceArr['valuesets'].readStrings(result.ValueSets); - result.link; - finally - result.free; - end; -end; - - -class function TServerRegistryUtilities.toJson(s: TServerInformation): TJsonObject; -var - v : TServerVersionInformation; -begin - result := TJsonObject.Create; - try - result.str['code'] := s.Code; - result.str['name'] := s.Name; - result.str['address'] := s.Address; - result.str['access-info'] := s.AccessInfo; - result.str['authoritative'] := s.AuthCSList.CommaText; - result.str['authoritative-valuesets'] := s.AuthVSList.CommaText; - for v in s.Versions do - result.forceArr['versions'].add(toJson(s)); - result.link; - finally - result.free; - end; -end; - - -class function TServerRegistryUtilities.readServer(fv : String; json: TJsonObject): TServerInformation; -var - obj : TJsonObject; -begin - result := TServerInformation.Create; - try - result.Code := json.str['code']; - result.Name := json.str['name']; - result.Address := json.str['address']; - result.AccessInfo := json.str['access-info']; - result.AuthCSList.CommaText := json.str['authoritative']; - result.AuthVSList.CommaText := json.str['authoritative-valuesets']; - for obj in json.forceArr['versions'].asObjects.forEnum do - result.versions.add(readVersion(fv, json)); - result.link; - finally - result.free; - end; -end; - - -class function TServerRegistryUtilities.toJson(r: TServerRegistry): TJsonObject; -var - s : TServerInformation; -begin - result := TJsonObject.Create; - try - result.str['code'] := s.Code; - result.str['name'] := r.Name; - result.str['address'] := r.Address; - result.str['authority'] := r.Authority; - result.str['error'] := r.Error; - for s in r.Servers do - result.forceArr['servers'].add(toJson(s)); - result.link; - finally - result.free; - end; -end; - -class function TServerRegistryUtilities.readRegistry(fv : String; json: TJsonObject): TServerRegistry; -var - obj : TJsonObject; -begin - result := TServerRegistry.Create; - try - result.Code := json.str['code']; - result.Name := json.str['name']; - result.Address := json.str['address']; - result.Authority := json.str['authority']; - result.Error := json.str['error']; - for obj in json.forceArr['servers'].asObjects.forEnum do - result.Servers.add(readServer(fv, json)); - result.link; - finally - result.free; - end; -end; - -class procedure TServerRegistryUtilities.addRow(rows: TFslList; reg: TServerRegistry; srvr: TServerInformation; version: TServerVersionInformation; auth : boolean); -var - row : TServerRow; -begin - row := TServerRow.Create; - try - row.Authoritative := auth; - row.ServerName := srvr.Name; - row.ServerCode := srvr.Code; - row.RegistryName := reg.Name; - row.RegistryCode := reg.Code; - row.RegistryUrl := reg.Address; - - row.URL := version.Address; - row.Error := version.Error; - if (version.LastSuccess.null) then - row.LastSuccess := 0 - else - row.LastSuccess := trunc(TFslDateTime.makeUTC.difference(version.LastSuccess) * DATETIME_DAY_MILLISECONDS); - row.security := version.security; - row.Version := version.Version; - row.systems := version.CodeSystems.Count; - row.sets := version.ValueSets.Count; - row.AuthCSList.assign(srvr.AuthCSList); - row.AuthVSList.assign(srvr.AuthVSList); - - rows.add(row.link); - finally - row.free; - end; -end; - -function passesMask(mask, tx : string) : Boolean; -begin - if mask.EndsWith('*') then - result := tx.StartsWith(mask.Substring(0, mask.length-1)) - else - result := tx = mask; -end; - - -class function TServerRegistryUtilities.hasMatchingCodeSystem(cs : String; list : TStringList; mask : boolean) : boolean; -var - s, r : String; -begin - r := cs; - if r.contains('|') then - r := r.subString(0, r.indexOf('|')); - result := false; - for s in list do - begin - if mask and passesMask(s, cs) then - exit(true); - if not mask and ((s = cs) or (r = s)) then - exit(true); - end; -end; - -class function TServerRegistryUtilities.hasMatchingValueSet(vs : String; list : TStringList; mask : boolean) : boolean; -var - s, r : String; -begin - r := vs; - if r.contains('|') then - r := r.subString(0, r.indexOf('|')); - result := false; - for s in list do - begin - if mask and passesMask(s, vs) then - exit(true); - if not mask and ((s = vs) or (r = s)) then - exit(true); - end; -end; - -class procedure TServerRegistryUtilities.buildRows(reg: TServerRegistry; srvr: TServerInformation; version, tx: String; rows: TFslList); -var - ver : TServerVersionInformation; - auth : boolean; -begin - auth := hasMatchingCodeSystem(tx, srvr.AuthCSList, true); - for ver in srvr.Versions do - if (version = '') or (TSemanticVersion.matches(version, ver.version, semverAuto)) then - begin - if auth or (tx = '') or hasMatchingCodeSystem(tx, ver.CodeSystems, false) then - addRow(rows, reg, srvr, ver, auth); - end; -end; - -class procedure TServerRegistryUtilities.buildRows(reg: TServerRegistry; srvrCode, version, tx: String; rows: TFslList); -var - srvr : TServerInformation; -begin - for srvr in reg.Servers do - if (srvrCode = '') or (srvr.Code = srvrCode) then - buildRows(reg, srvr, version, tx, rows); -end; - -class procedure TServerRegistryUtilities.buildRows(info: TServerRegistries; regCode, srvrCode, version, tx: String; rows: TFslList); -var - reg : TServerRegistry; -begin - for reg in info.Registries do - if (regCode = '') or (reg.Code = regCode) then - buildRows(reg, srvrCode, version, tx, rows); -end; - -class function TServerRegistryUtilities.toJson(reg: TServerRegistries): TJsonObject; -var - sr : TServerRegistry; -begin - result := TJsonObject.Create; - try - result.str['version'] := '1'; - result.str['address'] := reg.Address; - result.str['last-run'] := reg.LastRun.toXML; - result.str['outcome'] := reg.Outcome; - for sr in reg.Registries do - result.forceArr['registries'].add(toJson(sr)); - result.link; - finally - result.free; - end; -end; - -class function TServerRegistryUtilities.toJson(row: TServerRow): TJsonObject; -var - s : String; -begin - result := TJsonObject.Create; - try - if (row.Authoritative) then - result.bool['is-authoritative'] := true; - result.str['server-name'] := row.ServerName; - result.str['server-code'] := row.ServerCode; - - result.str['registry-name'] := row.RegistryName; - result.str['registry-code'] := row.RegistryCode; - result.str['registry-url'] := row.RegistryUrl; - - result.str['url'] := row.URL; - result.str['version'] := row.Version; - result.str['error'] := row.Error; - result.int['last-success'] := row.LastSuccess; - result.int['systems'] := row.systems; - for s in row.AuthCSList do - result.forceArr['authoritative'].add(s); - for s in row.AuthVSList do - result.forceArr['authoritative-valuesets'].add(s); - - if (ssOpen in row.Security) then result.bool[CODES_TServerSecurity[ssOpen]] := true; - if (ssPassword in row.Security) then result.bool[CODES_TServerSecurity[ssPassword]] := true; - if (ssToken in row.Security) then result.bool[CODES_TServerSecurity[ssToken]] := true; - if (ssOAuth in row.Security) then result.bool[CODES_TServerSecurity[ssOAuth]] := true; - if (ssSmart in row.Security) then result.bool[CODES_TServerSecurity[ssSmart]] := true; - if (ssCert in row.Security) then result.bool[CODES_TServerSecurity[ssCert]] := true; - - result.link; - finally - result.free; - end; -end; - -class function TServerRegistryUtilities.buildRows(info: TServerRegistries; regCode, srvrCode, version, tx: String): TFslList; -begin - info.Lock('build'); - try - result := TFslList.Create; - try - buildRows(info, regCode, srvrCode, version, tx, result); - result.link; - finally - result.free; - end; - finally - info.unlock; - end; -end; - -class function TServerRegistryUtilities.fromJson(json: TJsonObject): TServerRegistries; -var - fv : String; - obj : TJsonObject; -begin - fv := json.str['version']; - if (fv <> '1') then - raise EFslException.Create('Unsupported version '+fv); - - result := TServerRegistries.Create; - try - result.Address := json.str['address']; - result.LastRun := TFslDateTime.fromXML(json.str['last-run']); - result.Outcome := json.str['outcome']; - for obj in json.forceArr['registries'].asObjects.forEnum do - result.Registries.add(readRegistry(fv, json)); - result.link; - finally - result.free; - end; -end; - -{ TServerRegistries } - -constructor TServerRegistries.Create; -begin - inherited Create; - FRegistries := TFslList.Create; -end; - -destructor TServerRegistries.Destroy; -begin - FLock.Free; - FRegistries.free; - inherited Destroy; -end; - -function TServerRegistries.Link: TServerRegistries; -begin - result := TServerRegistries(inherited link); -end; - -procedure TServerRegistries.Lock(name: String); -begin - if (FLock = nil) then - FLock := TFslLock.create('ServerRegistries'); - FLock.Lock(name); -end; - -procedure TServerRegistries.UnLock; -begin - FLock.unlock; -end; - -function TServerRegistries.registry(code: String): TServerRegistry; -var - t : TServerRegistry; -begin - result := nil; - for t in FRegistries do - if (t.code = code) then - exit(t); -end; - -procedure TServerRegistries.update(source: TServerRegistries); -var - t, sr : TServerRegistry; -begin - FLastRun := source.FLastRun; - FOutcome := source.FOutcome; - FDoco := source.doco; - for t in source.Registries do - begin - sr := registry(t.Code); - if (sr = nil) then - FRegistries.add(t.link) - else - sr.update(t); - end; -end; - -{ TServerRegistry } - -constructor TServerRegistry.Create; -begin - inherited Create; - FServers := TFslList.Create; -end; - -destructor TServerRegistry.Destroy; -begin - FServers.free; - inherited Destroy; -end; - -function TServerRegistry.Link: TServerRegistry; -begin - result := TServerRegistry(inherited link); -end; - -function TServerRegistry.server(code: String): TServerInformation; -var - t : TServerInformation; -begin - result := nil; - for t in FServers do - if (t.code = code) then - exit(t); -end; - -procedure TServerRegistry.update(source: TServerRegistry); -var - t, s : TServerInformation; -begin - FName := source.FName; - FAddress := source.FAddress; - FAuthority := source.FAuthority; - FError := source.FError; - for t in source.Servers do - begin - s := server(t.Code); - if (s = nil) then - FServers.add(t.link) - else - s.update(t); - end; -end; - -{ TServerInformation } - -constructor TServerInformation.Create; -begin - inherited Create; - FVersions := TFslList.Create; - FAuthCSList := TStringList.Create; - FAuthVSList := TStringList.Create; - FUsageList := TStringList.create; -end; - -destructor TServerInformation.Destroy; -begin - FUsageList.free; - FAuthVSList.free; - FAuthCSList.free; - FVersions.free; - inherited Destroy; -end; - -function TServerInformation.Link: TServerInformation; -begin - result := TServerInformation(inherited link); -end; - -function TServerInformation.version(ver: String): TServerVersionInformation; -var - t : TServerVersionInformation; -begin - result := nil; - for t in FVersions do - if (t.version = ver) then - exit(t); -end; - -procedure TServerInformation.update(source: TServerInformation); -var - t, v : TServerVersionInformation; -begin - FName := source.FName; - FAddress := source.FAddress; - FAccessInfo := source.FAccessInfo; - FAuthCSList.Assign(source.FAuthCSList); - FAuthVSList.Assign(source.FAuthVSList); - FUsagelist.Assign(source.FUsagelist); - for t in source.Versions do - begin - v := version(t.Version); - if (v = nil) then - FVersions.add(t.link) - else - v.update(t); - end; -end; - -function TServerInformation.Details: String; -begin - result := FAccessInfo; -end; - -function TServerInformation.isAuthCS(tx: String): boolean; -var - mask : String; -begin - result := false; - for mask in AuthCSList do - if passesMask(mask, tx) then - exit(true); -end; - -function TServerInformation.isAuthVS(vs: String): boolean; -var - mask : String; -begin - result := false; - for mask in AuthVSList do - if passesMask(mask, vs) then - exit(true); -end; - -function TServerInformation.description: String; -var - s : String; -begin - result := ''; - if (FusageList.count > 0) then - result := 'Usage Tags: '+FUsageList.CommaText; - if (FAuthCSList.count > 0) then - begin - if (result <> '') then - result := result+'. '; - result := result + 'Authoritative for the following CodeSystems:
    '; - for s in FAuthCSlist do - result := result + '
  • '+FormatTextToHtml(s).replace('*', '*')+'
    • '; - result := result + '
'; - end; - if (FAuthVSList.count > 0) then - begin - if (result <> '') then - result := result+'. '; - result := result + 'Authoritative for the following ValueSets:
    '; - for s in FAuthVSlist do - result := result + '
  • '+FormatTextToHtml(s).replace('*', '*')+'
    • '; - result := result + '
'; - end; -end; - -{ TServerVersionInformation } - -constructor TServerVersionInformation.Create; -begin - inherited Create; - FCodeSystems := TStringList.Create; - FCodeSystems.Sorted := true; - FCodeSystems.Duplicates := dupIgnore; - - FValueSets := TStringList.Create; - FValueSets.Sorted := true; - FValueSets.Duplicates := dupIgnore; -end; - -destructor TServerVersionInformation.Destroy; -begin - FValueSets.free; - FCodeSystems.free; - inherited Destroy; -end; - -function TServerVersionInformation.Link: TServerVersionInformation; -begin - result := TServerVersionInformation(inherited link); -end; - -procedure TServerVersionInformation.update(source: TServerVersionInformation); -begin - FAddress := source.FAddress; - FError := source.FError; - if (source.Error = '') then - begin - FSecurity := source.FSecurity; - FLastSuccess := source.FLastSuccess; - FCodeSystems.assign(source.FCodeSystems); - FValueSets.assign(source.FValueSets); - end; -end; - -function TServerVersionInformation.Details: String; -begin - if FError = '' then - result := 'Server Processed Ok' - else - result := FError; - result := result + ' (last seen '+LastSuccess.toXML()+', last tat = '+FLastTat+')'; -end; - -function TServerVersionInformation.cslist: String; -var - s : String; -begin - result := '
    '; - for s in FCodeSystems do - result := result + '
  • '+FormatTextToHtml(s)+'
    • '; - result := result + '
'; -end; - -function TServerVersionInformation.vslist: String; -var - s : String; -begin - result := '
    '; - for s in FValueSets do - result := result + '
  • '+FormatTextToHtml(s)+'
    • '; - result := result + '
'; -end; - - -end. - +unit tx_registry_model; + +{ +Copyright (c) 2011+, HL7 and Health Intersections Pty Ltd (http://www.healthintersections.com.au) +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of HL7 nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +} + +{$i fhir.inc} + +interface + +uses + Classes, SysUtils, + fsl_base, fsl_json, fsl_utilities, fsl_versions, fsl_threads; + +Type + TServerSecurity = (ssOpen, ssPassword, ssToken, ssOAuth, ssSmart, ssCert); + TServerSecuritySet = set of TServerSecurity; + +const + CODES_TServerSecurity : Array[TServerSecurity] of String = ('open', 'password', 'token', 'oauth', 'smart', 'cert'); + +type + { TServerVersionInformation } + + TServerVersionInformation = class (TFslObject) + private + FError: String; + FAddress : String; + FLastTat: String; + FVersion : String; + FCodeSystems : TStringList; + FValueSets : TStringList; + FLastSuccess : TFslDateTime; + FSecurity : TServerSecuritySet; + public + constructor Create; override; + destructor Destroy; override; + function Link : TServerVersionInformation; overload; + property Version : String read FVersion write FVersion; + property Address : String read FAddress write FAddress; + property Security : TServerSecuritySet read FSecurity write FSecurity; + property Error : String read FError write FError; + property LastSuccess : TFslDateTime read FLastSuccess write FLastSuccess; + property lastTat : String read FLastTat write FLastTat; + property CodeSystems : TStringList read FCodeSystems; + property ValueSets : TStringList read FValueSets; + procedure update(source : TServerVersionInformation); + + function Details : String; + function cslist : String; + function vslist : String; + end; + + { TServerInformation } + + TServerInformation = class (TFslObject) + private + FCode: String; + FName : string; + FAddress : String; + FAccessInfo : String; + FAuthCSlist : TStringList; + FAuthVSlist : TStringList; + FUsageList : TStringList; + FVersions : TFslList; + public + constructor Create; override; + destructor Destroy; override; + function Link : TServerInformation; overload; + property Code : String read FCode write FCode; + property Name : String read FName write FName; + property Address : String read FAddress write FAddress; + property AccessInfo : String read FAccessInfo write FAccessInfo; + property AuthCSList : TStringList read FAuthCSList; + property AuthVSList : TStringList read FAuthVSList; + property UsageList : TStringList read FUsageList; + property Versions : TFslList read FVersions; + function version(ver : String) : TServerVersionInformation; + procedure update(source : TServerInformation); + + function Details : String; + function isAuthCS(tx : String) : boolean; + function isAuthVS(vs : String) : boolean; + function Description : String; + end; + + { TServerRegistry } + + TServerRegistry = class (TFslObject) + private + FCode: String; + FName : string; + FAddress : String; + FAuthority : string; + FError : String; + FServers : TFslList; + public + constructor Create; override; + destructor Destroy; override; + function Link : TServerRegistry; overload; + property Code : String read FCode write FCode; + property Name : String read FName write FName; + property Address : String read FAddress write FAddress; + property Authority : String read FAuthority write FAuthority; + property Error : String read FError write FError; + property Servers : TFslList read FServers; + + function server(code : String) : TServerInformation; + procedure update(source : TServerRegistry); + end; + + { TServerRegistries } + + TServerRegistries = class (TFslObject) + private + FAddress : String; + FDoco: String; + FLastRun : TFslDateTime; + FOutcome : String; + FRegistries: TFslList; + FLock : TFslLock; + public + constructor Create; override; + destructor Destroy; override; + function Link : TServerRegistries; overload; + property Address : String read FAddress write FAddress; + property doco : String read FDoco write FDoco; + property LastRun : TFslDateTime read FLastRun write FLastRun; + property Outcome : String read FOutcome write FOutcome; + property Registries : TFslList read FRegistries; + procedure Lock(name : String); + procedure UnLock; + + function registry(code : String) : TServerRegistry; + procedure update(source : TServerRegistries); + end; + + { TServerRow } + + TServerRow = class (TFslObject) + private + FError: String; + FLastSuccess: cardinal; + FRegistryCode: String; + FRegistryName: String; + FRegistryUrl: String; + FSecurity: TServerSecuritySet; + FServerCode: String; + FServerName: String; + FSystems: integer; + FSets : integer; + FURL: String; + FVersion: String; + FAuthCSList : TStringList; + FAuthVSList : TStringList; + FAuthoritative : boolean; + public + constructor Create; override; + destructor Destroy; override; + function Link : TServerRow; overload; + property ServerName : String read FServerName write FServerName; + property ServerCode : String read FServerCode write FServerCode; + property RegistryName : String read FRegistryName write FRegistryName; + property RegistryCode : String read FRegistryCode write FRegistryCode; + property RegistryUrl : String read FRegistryUrl write FRegistryUrl; + property AuthCSList : TStringList read FAuthCSList; + property AuthVSList : TStringList read FAuthVSList; + + property Version : String read FVersion write FVersion; + property URL : String read FURL write FURL; + property Error : String read FError write FError; + property Security : TServerSecuritySet read FSecurity write FSecurity; + property LastSuccess : cardinal read FLastSuccess write FLastSuccess; // ms + property systems : integer read FSystems write FSystems; + property sets : integer read FSets write FSets; + property Authoritative : boolean read FAuthoritative write FAuthoritative; + end; + + { TServerRegistryUtilities } + + TServerRegistryUtilities = class (TFslObject) + private + class function securitySetToString(sset : TServerSecuritySet) : String; + class function toJson(v : TServerVersionInformation) : TJsonObject; overload; + class function toJson(s : TServerInformation) : TJsonObject; overload; + class function toJson(r : TServerRegistry) : TJsonObject; overload; + + class function stringToSecuritySet(s : String) : TServerSecuritySet; + class function readVersion(fv : String; json : TJsonObject): TServerVersionInformation; + class function readServer(fv : String; json : TJsonObject): TServerInformation; + class function readRegistry(fv : String; json : TJsonObject): TServerRegistry; + + class procedure addRow(rows : TFslList; reg: TServerRegistry; srvr : TServerInformation; version : TServerVersionInformation; auth : boolean); + class procedure buildRows(reg: TServerRegistry; srvr : TServerInformation; version, tx : String; rows : TFslList); overload; + class procedure buildRows(reg : TServerRegistry; srvrCode, version, tx : String; rows : TFslList); overload; + class procedure buildRows(info : TServerRegistries; regCode, srvrCode, version, tx : String; rows : TFslList); overload; + + public + class function fromJson(json : TJsonObject) : TServerRegistries; + class function toJson(reg : TServerRegistries) : TJsonObject; overload; + class function toJson(row : TServerRow) : TJsonObject; overload; + + class function buildRows(info : TServerRegistries; regCode, srvrCode, version, tx : String) : TFslList; overload; + class function hasMatchingCodeSystem(cs : String; list : TStringList; mask : boolean) : boolean; + class function hasMatchingValueSet(vs : String; list : TStringList; mask : boolean) : boolean; + end; + +implementation + +{ TServerRow } + +constructor TServerRow.Create; +begin + inherited Create; + FAuthCSList := TStringList.Create; + FAuthVSList := TStringList.Create; +end; + +destructor TServerRow.Destroy; +begin + FAuthCSList.free; + FAuthVSList.free; + inherited Destroy; +end; + +function TServerRow.Link: TServerRow; +begin + result := TServerRow(inherited Link); +end; + +{ TServerRegistryUtilities } + +class function TServerRegistryUtilities.securitySetToString(sset: TServerSecuritySet): String; +var + a : TServerSecurity; +begin + result := ''; + for a := low(TServerSecurity) to High(TServerSecurity) do + if a in sset then + CommaAdd(result, CODES_TServerSecurity[a]); +end; + + +class function TServerRegistryUtilities.stringToSecuritySet(s : String) : TServerSecuritySet; +var + a : TServerSecurity; +begin + result := []; + for a := low(TServerSecurity) to High(TServerSecurity) do + if s.Contains(CODES_TServerSecurity[a]) then + result := result + [a]; +end; + +class function TServerRegistryUtilities.toJson(v: TServerVersionInformation): TJsonObject; +var + s : String; +begin + result := TJsonObject.Create; + try + result.str['address'] := v.Address; + result.str['version'] := v.Version; + result.str['security'] := securitySetToString(v.Security); + result.str['error'] := v.Error; + result.str['last-success'] := v.LastSuccess.toXML; + for s in v.CodeSystems do + result.forceArr['terminologies'].add(s); + for s in v.ValueSets do + result.forceArr['valuesets'].add(s); + result.link; + finally + result.free; + end; +end; + +class function TServerRegistryUtilities.readVersion(fv : String; json: TJsonObject): TServerVersionInformation; +var + s : String; +begin + result := TServerVersionInformation.Create; + try + result.Address := json.str['address']; + result.Version := json.str['version']; + result.Security := stringToSecuritySet(json.str['security']); + result.Error := json.str['error']; + result.LastSuccess := TFslDateTime.fromXML(json.str['last-success']); + json.forceArr['terminologies'].readStrings(result.CodeSystems); + json.forceArr['valuesets'].readStrings(result.ValueSets); + result.link; + finally + result.free; + end; +end; + + +class function TServerRegistryUtilities.toJson(s: TServerInformation): TJsonObject; +var + v : TServerVersionInformation; +begin + result := TJsonObject.Create; + try + result.str['code'] := s.Code; + result.str['name'] := s.Name; + result.str['address'] := s.Address; + result.str['access-info'] := s.AccessInfo; + result.str['authoritative'] := s.AuthCSList.CommaText; + result.str['authoritative-valuesets'] := s.AuthVSList.CommaText; + for v in s.Versions do + result.forceArr['versions'].add(toJson(s)); + result.link; + finally + result.free; + end; +end; + + +class function TServerRegistryUtilities.readServer(fv : String; json: TJsonObject): TServerInformation; +var + obj : TJsonObject; +begin + result := TServerInformation.Create; + try + result.Code := json.str['code']; + result.Name := json.str['name']; + result.Address := json.str['address']; + result.AccessInfo := json.str['access-info']; + result.AuthCSList.CommaText := json.str['authoritative']; + result.AuthVSList.CommaText := json.str['authoritative-valuesets']; + for obj in json.forceArr['versions'].asObjects.forEnum do + result.versions.add(readVersion(fv, json)); + result.link; + finally + result.free; + end; +end; + + +class function TServerRegistryUtilities.toJson(r: TServerRegistry): TJsonObject; +var + s : TServerInformation; +begin + result := TJsonObject.Create; + try + result.str['code'] := s.Code; + result.str['name'] := r.Name; + result.str['address'] := r.Address; + result.str['authority'] := r.Authority; + result.str['error'] := r.Error; + for s in r.Servers do + result.forceArr['servers'].add(toJson(s)); + result.link; + finally + result.free; + end; +end; + +class function TServerRegistryUtilities.readRegistry(fv : String; json: TJsonObject): TServerRegistry; +var + obj : TJsonObject; +begin + result := TServerRegistry.Create; + try + result.Code := json.str['code']; + result.Name := json.str['name']; + result.Address := json.str['address']; + result.Authority := json.str['authority']; + result.Error := json.str['error']; + for obj in json.forceArr['servers'].asObjects.forEnum do + result.Servers.add(readServer(fv, json)); + result.link; + finally + result.free; + end; +end; + +class procedure TServerRegistryUtilities.addRow(rows: TFslList; reg: TServerRegistry; srvr: TServerInformation; version: TServerVersionInformation; auth : boolean); +var + row : TServerRow; +begin + row := TServerRow.Create; + try + row.Authoritative := auth; + row.ServerName := srvr.Name; + row.ServerCode := srvr.Code; + row.RegistryName := reg.Name; + row.RegistryCode := reg.Code; + row.RegistryUrl := reg.Address; + + row.URL := version.Address; + row.Error := version.Error; + if (version.LastSuccess.null) then + row.LastSuccess := 0 + else + row.LastSuccess := trunc(TFslDateTime.makeUTC.difference(version.LastSuccess) * DATETIME_DAY_MILLISECONDS); + row.security := version.security; + row.Version := version.Version; + row.systems := version.CodeSystems.Count; + row.sets := version.ValueSets.Count; + row.AuthCSList.assign(srvr.AuthCSList); + row.AuthVSList.assign(srvr.AuthVSList); + + rows.add(row.link); + finally + row.free; + end; +end; + +function passesMask(mask, tx : string) : Boolean; +begin + if mask.EndsWith('*') then + result := tx.StartsWith(mask.Substring(0, mask.length-1)) + else + result := tx = mask; +end; + + +class function TServerRegistryUtilities.hasMatchingCodeSystem(cs : String; list : TStringList; mask : boolean) : boolean; +var + s, r : String; +begin + r := cs; + if r.contains('|') then + r := r.subString(0, r.indexOf('|')); + result := false; + for s in list do + begin + if mask and passesMask(s, cs) then + exit(true); + if not mask and ((s = cs) or (r = s)) then + exit(true); + end; +end; + +class function TServerRegistryUtilities.hasMatchingValueSet(vs : String; list : TStringList; mask : boolean) : boolean; +var + s, r : String; +begin + r := vs; + if r.contains('|') then + r := r.subString(0, r.indexOf('|')); + result := false; + for s in list do + begin + if mask and passesMask(s, vs) then + exit(true); + if not mask and ((s = vs) or (r = s)) then + exit(true); + end; +end; + +class procedure TServerRegistryUtilities.buildRows(reg: TServerRegistry; srvr: TServerInformation; version, tx: String; rows: TFslList); +var + ver : TServerVersionInformation; + auth : boolean; +begin + auth := hasMatchingCodeSystem(tx, srvr.AuthCSList, true); + for ver in srvr.Versions do + if (version = '') or (TSemanticVersion.matches(version, ver.version, semverAuto)) then + begin + if auth or (tx = '') or hasMatchingCodeSystem(tx, ver.CodeSystems, false) then + addRow(rows, reg, srvr, ver, auth); + end; +end; + +class procedure TServerRegistryUtilities.buildRows(reg: TServerRegistry; srvrCode, version, tx: String; rows: TFslList); +var + srvr : TServerInformation; +begin + for srvr in reg.Servers do + if (srvrCode = '') or (srvr.Code = srvrCode) then + buildRows(reg, srvr, version, tx, rows); +end; + +class procedure TServerRegistryUtilities.buildRows(info: TServerRegistries; regCode, srvrCode, version, tx: String; rows: TFslList); +var + reg : TServerRegistry; +begin + for reg in info.Registries do + if (regCode = '') or (reg.Code = regCode) then + buildRows(reg, srvrCode, version, tx, rows); +end; + +class function TServerRegistryUtilities.toJson(reg: TServerRegistries): TJsonObject; +var + sr : TServerRegistry; +begin + result := TJsonObject.Create; + try + result.str['version'] := '1'; + result.str['address'] := reg.Address; + result.str['last-run'] := reg.LastRun.toXML; + result.str['outcome'] := reg.Outcome; + for sr in reg.Registries do + result.forceArr['registries'].add(toJson(sr)); + result.link; + finally + result.free; + end; +end; + +class function TServerRegistryUtilities.toJson(row: TServerRow): TJsonObject; +var + s : String; +begin + result := TJsonObject.Create; + try + if (row.Authoritative) then + result.bool['is-authoritative'] := true; + result.str['server-name'] := row.ServerName; + result.str['server-code'] := row.ServerCode; + + result.str['registry-name'] := row.RegistryName; + result.str['registry-code'] := row.RegistryCode; + result.str['registry-url'] := row.RegistryUrl; + + result.str['url'] := row.URL; + result.str['version'] := row.Version; + result.str['error'] := row.Error; + result.int['last-success'] := row.LastSuccess; + result.int['systems'] := row.systems; + for s in row.AuthCSList do + result.forceArr['authoritative'].add(s); + for s in row.AuthVSList do + result.forceArr['authoritative-valuesets'].add(s); + + if (ssOpen in row.Security) then result.bool[CODES_TServerSecurity[ssOpen]] := true; + if (ssPassword in row.Security) then result.bool[CODES_TServerSecurity[ssPassword]] := true; + if (ssToken in row.Security) then result.bool[CODES_TServerSecurity[ssToken]] := true; + if (ssOAuth in row.Security) then result.bool[CODES_TServerSecurity[ssOAuth]] := true; + if (ssSmart in row.Security) then result.bool[CODES_TServerSecurity[ssSmart]] := true; + if (ssCert in row.Security) then result.bool[CODES_TServerSecurity[ssCert]] := true; + + result.link; + finally + result.free; + end; +end; + +class function TServerRegistryUtilities.buildRows(info: TServerRegistries; regCode, srvrCode, version, tx: String): TFslList; +begin + info.Lock('build'); + try + result := TFslList.Create; + try + buildRows(info, regCode, srvrCode, version, tx, result); + result.link; + finally + result.free; + end; + finally + info.unlock; + end; +end; + +class function TServerRegistryUtilities.fromJson(json: TJsonObject): TServerRegistries; +var + fv : String; + obj : TJsonObject; +begin + fv := json.str['version']; + if (fv <> '1') then + raise EFslException.Create('Unsupported version '+fv); + + result := TServerRegistries.Create; + try + result.Address := json.str['address']; + result.LastRun := TFslDateTime.fromXML(json.str['last-run']); + result.Outcome := json.str['outcome']; + for obj in json.forceArr['registries'].asObjects.forEnum do + result.Registries.add(readRegistry(fv, json)); + result.link; + finally + result.free; + end; +end; + +{ TServerRegistries } + +constructor TServerRegistries.Create; +begin + inherited Create; + FRegistries := TFslList.Create; +end; + +destructor TServerRegistries.Destroy; +begin + FLock.Free; + FRegistries.free; + inherited Destroy; +end; + +function TServerRegistries.Link: TServerRegistries; +begin + result := TServerRegistries(inherited link); +end; + +procedure TServerRegistries.Lock(name: String); +begin + if (FLock = nil) then + FLock := TFslLock.create('ServerRegistries'); + FLock.Lock(name); +end; + +procedure TServerRegistries.UnLock; +begin + FLock.unlock; +end; + +function TServerRegistries.registry(code: String): TServerRegistry; +var + t : TServerRegistry; +begin + result := nil; + for t in FRegistries do + if (t.code = code) then + exit(t); +end; + +procedure TServerRegistries.update(source: TServerRegistries); +var + t, sr : TServerRegistry; +begin + FLastRun := source.FLastRun; + FOutcome := source.FOutcome; + FDoco := source.doco; + for t in source.Registries do + begin + sr := registry(t.Code); + if (sr = nil) then + FRegistries.add(t.link) + else + sr.update(t); + end; +end; + +{ TServerRegistry } + +constructor TServerRegistry.Create; +begin + inherited Create; + FServers := TFslList.Create; +end; + +destructor TServerRegistry.Destroy; +begin + FServers.free; + inherited Destroy; +end; + +function TServerRegistry.Link: TServerRegistry; +begin + result := TServerRegistry(inherited link); +end; + +function TServerRegistry.server(code: String): TServerInformation; +var + t : TServerInformation; +begin + result := nil; + for t in FServers do + if (t.code = code) then + exit(t); +end; + +procedure TServerRegistry.update(source: TServerRegistry); +var + t, s : TServerInformation; +begin + FName := source.FName; + FAddress := source.FAddress; + FAuthority := source.FAuthority; + FError := source.FError; + for t in source.Servers do + begin + s := server(t.Code); + if (s = nil) then + FServers.add(t.link) + else + s.update(t); + end; +end; + +{ TServerInformation } + +constructor TServerInformation.Create; +begin + inherited Create; + FVersions := TFslList.Create; + FAuthCSList := TStringList.Create; + FAuthVSList := TStringList.Create; + FUsageList := TStringList.create; +end; + +destructor TServerInformation.Destroy; +begin + FUsageList.free; + FAuthVSList.free; + FAuthCSList.free; + FVersions.free; + inherited Destroy; +end; + +function TServerInformation.Link: TServerInformation; +begin + result := TServerInformation(inherited link); +end; + +function TServerInformation.version(ver: String): TServerVersionInformation; +var + t : TServerVersionInformation; +begin + result := nil; + for t in FVersions do + if (t.version = ver) then + exit(t); +end; + +procedure TServerInformation.update(source: TServerInformation); +var + t, v : TServerVersionInformation; +begin + FName := source.FName; + FAddress := source.FAddress; + FAccessInfo := source.FAccessInfo; + FAuthCSList.Assign(source.FAuthCSList); + FAuthVSList.Assign(source.FAuthVSList); + FUsagelist.Assign(source.FUsagelist); + for t in source.Versions do + begin + v := version(t.Version); + if (v = nil) then + FVersions.add(t.link) + else + v.update(t); + end; +end; + +function TServerInformation.Details: String; +begin + result := FAccessInfo; +end; + +function TServerInformation.isAuthCS(tx: String): boolean; +var + mask : String; +begin + result := false; + for mask in AuthCSList do + if passesMask(mask, tx) then + exit(true); +end; + +function TServerInformation.isAuthVS(vs: String): boolean; +var + mask : String; +begin + result := false; + for mask in AuthVSList do + if passesMask(mask, vs) then + exit(true); +end; + +function TServerInformation.description: String; +var + s : String; +begin + result := ''; + if (FusageList.count > 0) then + result := 'Usage Tags: '+FUsageList.CommaText; + if (FAuthCSList.count > 0) then + begin + if (result <> '') then + result := result+'. '; + result := result + 'Authoritative for the following CodeSystems:
    '; + for s in FAuthCSlist do + result := result + '
  • '+FormatTextToHtml(s).replace('*', '*')+'
    • '; + result := result + '
'; + end; + if (FAuthVSList.count > 0) then + begin + if (result <> '') then + result := result+'. '; + result := result + 'Authoritative for the following ValueSets:
    '; + for s in FAuthVSlist do + result := result + '
  • '+FormatTextToHtml(s).replace('*', '*')+'
    • '; + result := result + '
'; + end; +end; + +{ TServerVersionInformation } + +constructor TServerVersionInformation.Create; +begin + inherited Create; + FCodeSystems := TStringList.Create; + FCodeSystems.Sorted := true; + FCodeSystems.Duplicates := dupIgnore; + + FValueSets := TStringList.Create; + FValueSets.Sorted := true; + FValueSets.Duplicates := dupIgnore; +end; + +destructor TServerVersionInformation.Destroy; +begin + FValueSets.free; + FCodeSystems.free; + inherited Destroy; +end; + +function TServerVersionInformation.Link: TServerVersionInformation; +begin + result := TServerVersionInformation(inherited link); +end; + +procedure TServerVersionInformation.update(source: TServerVersionInformation); +begin + FAddress := source.FAddress; + FError := source.FError; + if (source.Error = '') then + begin + FSecurity := source.FSecurity; + FLastSuccess := source.FLastSuccess; + FCodeSystems.assign(source.FCodeSystems); + FValueSets.assign(source.FValueSets); + end; +end; + +function TServerVersionInformation.Details: String; +begin + if FError = '' then + result := 'Server Processed Ok' + else + result := FError; + result := result + ' (last seen '+LastSuccess.toXML()+', last tat = '+FLastTat+')'; +end; + +function TServerVersionInformation.cslist: String; +var + s : String; +begin + result := '
    '; + for s in FCodeSystems do + result := result + '
  • '+FormatTextToHtml(s)+'
    • '; + result := result + '
'; +end; + +function TServerVersionInformation.vslist: String; +var + s : String; +begin + result := '
    '; + for s in FValueSets do + result := result + '
  • '+FormatTextToHtml(s)+'
    • '; + result := result + '
'; +end; + + +end. + diff --git a/server/xig_provider.pas b/server/xig_provider.pas index 47c249d81..3cde2b198 100644 --- a/server/xig_provider.pas +++ b/server/xig_provider.pas @@ -1,242 +1,270 @@ -unit xig_provider; - -{$i fhir.inc} - -interface - -uses - Classes, SysUtils, - {$IFDEF FPC} ZStream, {ELSE} Zlib, {$ENDIF} - fsl_base, fsl_lang, fsl_utilities, fsl_logging, fsl_i18n, - fdb_manager, - fhir_objects, fhir_factory, fhir_common, fhir_parser, - fhir5_context; - -type - TXIGProvider = class; - - { TXIGResourceProxy } - - TXIGResourceProxy = class (TFHIRResourceProxy) - private - FKey: Integer; - FDB: TFDBManager; - - protected - procedure loadResource; override; - public - destructor Destroy; override; - - property key : Integer read FKey write FKey; - end; - - { TXigLoader } - - TXigLoader = class (TFslObject) - private - FConn : TFDBConnection; - FFactory: TFHIRFactory; - procedure SetFactory(AValue: TFHIRFactory); - public - destructor Destroy; override; - property Factory : TFHIRFactory read FFactory write SetFactory; - - function next : boolean; - function makeResource : TFHIRResourceProxyV; - end; - - { TXIGProvider } - - TXIGProvider = class (TFslObject) - private - FLanguages : TIETFLanguageDefinitions; - FDb : TFDBManager; - public - constructor Create(languages : TIETFLanguageDefinitions; i18n : TI18nSupport; db : TFDBManager); - destructor Destroy; override; - - function link : TXIGProvider; overload; - function startLoad(types : TStringArray) : TXigLoader; - end; - -implementation - -{ TXIGResourceProxy } - -destructor TXIGResourceProxy.Destroy; -begin - FDB.free; - inherited Destroy; -end; - -{$IFDEF FPC} -procedure DecompressStream(src, dst: TStream); -var - ds: TDecompressionStream; - d: dword; - buff: array[0..1023] of byte; -begin - ds := TDecompressionStream.Create(src, true); - try - repeat - d := ds.Read(buff, 1024); - dst.Write(buff, d); - until - d = 0; - finally - ds.Free; - end; -end; - -function inflate(source:TBytes):TBytes; -var - ss1, ss2: TStringStream; -begin - ss1 := TStringStream.Create; - try - ss1.write(source[0], length(source)); - ss1.Position := 10; //SKIP GZIP HEADER - - ss2 := TStringStream.Create; - try - DecompressStream(ss1, ss2); - - writeln('decompressed ', ss1.Size, ' bytes to ', ss2.Size, ' bytes'); - - ss2.Position := 0; - setLength(result, ss2.Size); - ss2.Read(result[0], length(result)); - finally - ss2.Free; - end; - finally - ss1.Free; - end; -end; -{$ENDIF} - -procedure TXIGResourceProxy.loadResource; -var - conn : TFDBConnection; - cnt : TBytes; - p : TFHIRParser; -begin - try - conn := FDB.GetConnection('Load Resource'); - try - conn.sql := 'select JsonR5 from Contents where ResourceKey = '+inttostr(FKey); - conn.Prepare; - conn.Execute; - if not conn.FetchNext then - raise Exception.create('Unable to find resource key '+inttostr(FKey)); - cnt := conn.ColBlob[1]; - conn.terminate; - conn.Release; - except - on e : Exception do - begin - conn.Error(e); - raise; - end; - end; - if (length(cnt) = 0) then - raise Exception.create('Unable to load content for resource key '+inttostr(FKey)); - - {$IFDEF FPC} - cnt := inflate(cnt); - {$ELSE} - raise EFslException.Create('Not Implemented Yet'); - {$ENDIF} - - p := Factory.makeParser(Worker, ffJson, nil); - try - FResourceV := p.parseResource(cnt); - finally - p.free; - end; - except - on e : Exception do - raise EFSLException.create('Unable to read XIG Resource '+inttostr(key)+': '+e.Message); - end; -end; - -{ TXigLoader } - -destructor TXigLoader.Destroy; -begin - FConn.Release; - FFactory.Free; - inherited Destroy; -end; - -function TXigLoader.next: boolean; -begin - result := FConn.FetchNext; -end; - -function TXigLoader.makeResource: TFHIRResourceProxyV; -var - p : TXIGResourceProxy; -begin - p := TXIGResourceProxy.create(factory.version, FConn.ColStringByName['ResourceTypeR5'], - FConn.ColStringByName['id'], FConn.ColStringByName['Url'], FConn.ColStringByName['Version'], - FConn.ColStringByName['Supplements'], FConn.ColStringByName['Content'], FConn.ColStringByName['ValueSet']); - try - p.factory := factory.link; - p.key := FConn.ColIntegerByName['ResourceKey']; - p.FDB := FConn.Owner.link; - result := p.link; - finally - p.free; - end; -end; - -procedure TXigLoader.SetFactory(AValue: TFHIRFactory); -begin - FFactory.Free; - FFactory := AValue; -end; - -{ TXIGProvider } - -constructor TXIGProvider.Create(languages : TIETFLanguageDefinitions; i18n : TI18nSupport; db : TFDBManager); -begin - inherited Create; - FLanguages := languages; - FDb := db; -end; - -destructor TXIGProvider.Destroy; -begin - FLanguages.free; - FDb.free; - inherited Destroy; -end; - -function TXIGProvider.link: TXIGProvider; -begin - result := TXIGProvider(inherited Link); -end; - -function TXIGProvider.startLoad(types: TStringArray): TXigLoader; -var - s, t : String; - conn : TFDBConnection; -begin - result := TXigLoader.create; - try - result.FConn := FDB.GetConnection('load resources'); - s := ''; - for t in types do - s := s + ', '''+sqlWrapString(t)+''''; - result.FConn.SQL := 'select ResourceKey, PID, ResourceTypeR5, Resources.id, Resources.Web, Url, Resources.Version, Content, Supplements, ValueSet from Resources, Packages where Resources.PackageKey = Packages.PackageKey and ResourceTypeR5 in ('+s.substring(2)+')'; - result.FConn.Prepare; - result.FConn.Execute; - result.link; - finally - result.free; - end; -end; - -end. - +unit xig_provider; + +{ +Copyright (c) 2011+, HL7 and Health Intersections Pty Ltd (http://www.healthintersections.com.au) +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of HL7 nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +} + +{$i fhir.inc} + +interface + +uses + Classes, SysUtils, + {$IFDEF FPC} ZStream, {ELSE} Zlib, {$ENDIF} + fsl_base, fsl_lang, fsl_utilities, fsl_logging, fsl_i18n, + fdb_manager, + fhir_objects, fhir_factory, fhir_common, fhir_parser, + fhir5_context; + +type + TXIGProvider = class; + + { TXIGResourceProxy } + + TXIGResourceProxy = class (TFHIRResourceProxy) + private + FKey: Integer; + FDB: TFDBManager; + + protected + procedure loadResource; override; + public + destructor Destroy; override; + + property key : Integer read FKey write FKey; + end; + + { TXigLoader } + + TXigLoader = class (TFslObject) + private + FConn : TFDBConnection; + FFactory: TFHIRFactory; + procedure SetFactory(AValue: TFHIRFactory); + public + destructor Destroy; override; + property Factory : TFHIRFactory read FFactory write SetFactory; + + function next : boolean; + function makeResource : TFHIRResourceProxyV; + end; + + { TXIGProvider } + + TXIGProvider = class (TFslObject) + private + FLanguages : TIETFLanguageDefinitions; + FDb : TFDBManager; + public + constructor Create(languages : TIETFLanguageDefinitions; i18n : TI18nSupport; db : TFDBManager); + destructor Destroy; override; + + function link : TXIGProvider; overload; + function startLoad(types : TStringArray) : TXigLoader; + end; + +implementation + +{ TXIGResourceProxy } + +destructor TXIGResourceProxy.Destroy; +begin + FDB.free; + inherited Destroy; +end; + +{$IFDEF FPC} +procedure DecompressStream(src, dst: TStream); +var + ds: TDecompressionStream; + d: dword; + buff: array[0..1023] of byte; +begin + ds := TDecompressionStream.Create(src, true); + try + repeat + d := ds.Read(buff, 1024); + dst.Write(buff, d); + until + d = 0; + finally + ds.Free; + end; +end; + +function inflate(source:TBytes):TBytes; +var + ss1, ss2: TStringStream; +begin + ss1 := TStringStream.Create; + try + ss1.write(source[0], length(source)); + ss1.Position := 10; //SKIP GZIP HEADER + + ss2 := TStringStream.Create; + try + DecompressStream(ss1, ss2); + + writeln('decompressed ', ss1.Size, ' bytes to ', ss2.Size, ' bytes'); + + ss2.Position := 0; + setLength(result, ss2.Size); + ss2.Read(result[0], length(result)); + finally + ss2.Free; + end; + finally + ss1.Free; + end; +end; +{$ENDIF} + +procedure TXIGResourceProxy.loadResource; +var + conn : TFDBConnection; + cnt : TBytes; + p : TFHIRParser; +begin + try + conn := FDB.GetConnection('Load Resource'); + try + conn.sql := 'select JsonR5 from Contents where ResourceKey = '+inttostr(FKey); + conn.Prepare; + conn.Execute; + if not conn.FetchNext then + raise EFslException.create('Unable to find resource key '+inttostr(FKey)); + cnt := conn.ColBlob[1]; + conn.terminate; + conn.Release; + except + on e : Exception do + begin + conn.Error(e); + raise; + end; + end; + if (length(cnt) = 0) then + raise EFslException.create('Unable to load content for resource key '+inttostr(FKey)); + + {$IFDEF FPC} + cnt := inflate(cnt); + {$ELSE} + raise EFslException.Create('Not Implemented Yet'); + {$ENDIF} + + p := Factory.makeParser(Worker, ffJson, nil); + try + FResourceV := p.parseResource(cnt); + finally + p.free; + end; + except + on e : Exception do + raise EFSLException.create('Unable to read XIG Resource '+inttostr(key)+': '+e.Message); + end; +end; + +{ TXigLoader } + +destructor TXigLoader.Destroy; +begin + FConn.Release; + FFactory.Free; + inherited Destroy; +end; + +function TXigLoader.next: boolean; +begin + result := FConn.FetchNext; +end; + +function TXigLoader.makeResource: TFHIRResourceProxyV; +var + p : TXIGResourceProxy; +begin + p := TXIGResourceProxy.create(factory.version, FConn.ColStringByName['ResourceTypeR5'], + FConn.ColStringByName['id'], FConn.ColStringByName['Url'], FConn.ColStringByName['Version'], + FConn.ColStringByName['Supplements'], FConn.ColStringByName['Content'], FConn.ColStringByName['ValueSet']); + try + p.factory := factory.link; + p.key := FConn.ColIntegerByName['ResourceKey']; + p.FDB := FConn.Owner.link; + result := p.link; + finally + p.free; + end; +end; + +procedure TXigLoader.SetFactory(AValue: TFHIRFactory); +begin + FFactory.Free; + FFactory := AValue; +end; + +{ TXIGProvider } + +constructor TXIGProvider.Create(languages : TIETFLanguageDefinitions; i18n : TI18nSupport; db : TFDBManager); +begin + inherited Create; + FLanguages := languages; + FDb := db; +end; + +destructor TXIGProvider.Destroy; +begin + FLanguages.free; + FDb.free; + inherited Destroy; +end; + +function TXIGProvider.link: TXIGProvider; +begin + result := TXIGProvider(inherited Link); +end; + +function TXIGProvider.startLoad(types: TStringArray): TXigLoader; +var + s, t : String; + conn : TFDBConnection; +begin + result := TXigLoader.create; + try + result.FConn := FDB.GetConnection('load resources'); + s := ''; + for t in types do + s := s + ', '''+sqlWrapString(t)+''''; + result.FConn.SQL := 'select ResourceKey, PID, ResourceTypeR5, Resources.id, Resources.Web, Url, Resources.Version, Content, Supplements, ValueSet from Resources, Packages where Resources.PackageKey = Packages.PackageKey and ResourceTypeR5 in ('+s.substring(2)+')'; + result.FConn.Prepare; + result.FConn.Execute; + result.link; + finally + result.free; + end; +end; + +end. + diff --git a/server/zero_config.pas b/server/zero_config.pas index d17f67cb0..fac680261 100644 --- a/server/zero_config.pas +++ b/server/zero_config.pas @@ -1,586 +1,586 @@ -unit zero_config; - -{ -Copyright (c) 2001-2021, Health Intersections Pty Ltd (http://www.healthintersections.com.au) -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, -are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of HL7 nor the names of its contributors may be used to - endorse or promote products derived from this software without specific - prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. -IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, -INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. -} - -{$i fhir.inc} - -interface - -uses - SysUtils, Classes, IniFiles, - fsl_base, fsl_utilities, fsl_fetcher, fsl_logging, fsl_json, fsl_threads, - fdb_manager, fdb_sqlite3, - fhir_objects, - server_config, database_installer, server_factory, server_constants, - endpoint_txsvr; - -function loadRemoteConfig(params : TCommandLineParameters; src : String; local : TIniFile) : String; - -implementation - -type - - { TEndPointInfo } - - TEndPointInfo = class (TFslObject) - private - FActive: boolean; - FMode: String; - FVersion: TFHIRVersion; - FFilename: String; - FPackages: TStringList; - FKind: String; - public - constructor Create(version : TFHIRVersion); overload; - destructor Destroy; override; - - property active : boolean read FActive write FActive; - property kind : String read FKind write FKind; - property mode : String read FMode write FMode; - property filename : String read FFilename write FFilename; - property version : TFHIRVersion read FVersion write FVersion; - property Packages : TStringList read FPackages; - - end; - - { TConfigurationBuilder } - - TConfigurationBuilder = class (TFslObject) - private - FParams : TCommandLineParameters; - FLastPct : Integer; - FJson : TJsonObject; - FFolder : String; - FUrl : String; - FFiles : TFslStringDictionary; - FEndPoints : TFslMap; - FMode : String; - procedure DownloadProgress(sender : TObject; progress : integer); - procedure downloadFile(fn : String); overload; - procedure downloadFile(src, tgt : String); overload; - procedure DownloadFiles; - function fixDBPath(fn: String): String; - procedure readConfig; - procedure buildEndPoint(ep : TEndPointInfo); - procedure setupEndPoints; - procedure CreateDatabase(v : TFHIRVersion; fn : String); - function doUpgrade(v : TFHIRVersion; fn : String) : boolean; - procedure buildConfig(fn : String; local : TCustomIniFile); - procedure DownloadFileList(files: TJsonObject); - procedure seePackages(realm : TJsonObject); - public - constructor Create(params : TCommandLineParameters); - destructor Destroy; override; - end; - -constructor TConfigurationBuilder.Create(params : TCommandLineParameters); -begin - inherited Create; - FParams := params; - FFiles := TFslStringDictionary.Create; - FEndPoints := TFslMap.Create; - FEndPoints.Add('r2', TEndPointInfo.Create(fhirVersionRelease2)); - FEndPoints.Add('r3', TEndPointInfo.Create(fhirVersionRelease3)); - FEndPoints.Add('r4', TEndPointInfo.Create(fhirVersionRelease4)); - FEndPoints.Add('r5', TEndPointInfo.Create(fhirVersionRelease5)); - FEndPoints.defaultValue := nil; -end; - -destructor TConfigurationBuilder.Destroy; -begin - FParams.free; - FEndPoints.free; - FFiles.free; - FJson.free; - inherited; -end; - -function TConfigurationBuilder.doUpgrade(v : TFHIRVersion; fn : String) : boolean; -var - sql : TFDBSQLiteManager; - conn : TFDBConnection; - installer : TFHIRDatabaseInstaller; -begin - result := false; - sql := TFDBSQLiteManager.Create('cfg', fn, false, true); - try - conn := sql.GetConnection('install'); - try - installer := TFHIRDatabaseInstaller.Create(conn, makeTxFactory(v), makeTxServerFactory(v)); - try - try - installer.Upgrade; - result := true; - except - on e : Exception do - Logging.log('Unable to upgrade existing database '+fn+': '+e.message); - end; - finally - installer.free; - end; - conn.Release; - except - on e : exception do - begin - conn.Error(e); - end; - end; - finally - sql.free; - end; -end; - -procedure TConfigurationBuilder.CreateDatabase(v : TFHIRVersion; fn : String); -var - sql : TFDBSQLiteManager; - conn : TFDBConnection; - installer : TFHIRDatabaseInstaller; -begin - sql := TFDBSQLiteManager.Create('cfg', fn, false, true); - try - conn := sql.GetConnection('install'); - try - installer := TFHIRDatabaseInstaller.Create(conn, makeTxFactory(v), makeTxServerFactory(v)); - try - installer.InstallTerminologyServer; - finally - installer.free; - end; - conn.Release; - except - on e : exception do - begin - conn.Error(e); - end; - end; - finally - sql.free; - end; -end; - -function TConfigurationBuilder.fixDBPath(fn : String) : String; -begin - if (fn.StartsWith('http:') or fn.StartsWith('https:')) then - begin - result := FilePath([FFolder, fn.Substring(fn.LastIndexOf('/')+1)]); - downloadFile(fn, result); - end - else if (ExtractFilePath(fn) = '') then - result := FilePath([FFolder, fn]) - else - result := fn; -end; - -function def(s1, s2, s3 : String) : String; -begin - if (s1 <> '') then - result := s1 - else if (s2 <> '') then - result := s2 - else - result := s3; -end; - -procedure TConfigurationBuilder.buildConfig(fn: String; local : TCustomIniFile); -var - cfg : TFHIRServerConfigFile; - n, v : String; - rn : integer; - sct : TFHIRServerConfigSection; - ep, o : TJsonObject; - lwi, mode : String; -begin - rn := 1; - if FileExists(fn) then - begin - cfg := TFHIRServerConfigFile.Create(fn); - try - rn := StrToIntDef(cfg.section['service']['runNumber'].value, 1); - finally - cfg.free; - end; - DeleteFile(fn); - end; - - cfg := TFHIRServerConfigFile.Create(fn); - try - cfg.section['service']['runNumber'].value := inttostr(rn); - - cfg.web['host'].value := def(local.ReadString('web', 'host', ''), cfg.web['host'].value, 'localhost'); - cfg.web['http'].value := def(local.ReadString('web', 'http', ''), cfg.web['http'].value, '80'); - cfg.web['https'].value := def(local.ReadString('web', 'https', ''), cfg.web['https'].value, ''); - cfg.web['rproxy-http'].value := def(local.ReadString('web', 'rproxy-http', ''), cfg.web['rproxy-http'].value, ''); - cfg.web['rproxy-https'].value := def(local.ReadString('web', 'rproxy-https', ''), cfg.web['rproxy-https'].value, ''); - cfg.web['rproxy-cert-header'].value := def(local.ReadString('web', 'rproxy-cert-header', ''), cfg.web['rproxy-cert-header'].value, ''); - cfg.web['rproxy-ssl-value'].value := def(local.ReadString('web', 'rproxy-ssl-value', ''), cfg.web['rproxy-ssl-value'].value, ''); - cfg.web['certname'].value := def(local.ReadString('web', 'certname', ''), cfg.web['certname'].value, ''); - cfg.web['cacertname'].value := def(local.ReadString('web', 'cacertname', ''), cfg.web['cacertname'].value, ''); - cfg.web['certkey'].value := def(local.ReadString('web', 'certkey', ''), cfg.web['certkey'].value, ''); - cfg.web['password'].value := def(local.ReadString('web', 'password', ''), cfg.web['password'].value, ''); - cfg.web['telnet-password'].value := def(local.ReadString('config', 'telnet-pword', NewGuidId), cfg.web['telnet-password'].value, ''); - cfg.web['robots.txt'].value := def(local.ReadString('web', 'robots.txt', ''), cfg.web['robots.txt'].value, ''); - cfg.admin['log-folder'].value := def(local.ReadString('web', 'logFolder', ''), cfg.admin['log-folder'].value, ''); - cfg.admin['email'].value := def(local.ReadString('config', 'email', ''), cfg.admin['email'].value, 'noone@fhir.org'); - cfg.admin['ownername'].value := def(local.ReadString('config', 'user', ''), cfg.admin['ownername'].value, 'Local User'); - cfg.service['max-memory'].value := def(local.ReadString('config', 'max-memory', ''), cfg.service['max-memory'].value, '0'); - cfg.service['cache-time'].value := def(local.ReadString('config', 'cache-time', ''), cfg.service['cache-time'].value, inttostr(DEFAULT_DWELL_TIME_MIN)); - - cfg.web['http-max-conn'].value := '50'; - cfg.web['http-cache-time'].value := '1000'; - cfg.web['plain-mode'].value := 'false'; - cfg.web['caching'].value := 'true'; - cfg.service['langfile'].value := partnerFile('lang.dat'); - cfg.service['package-cache'].value := ExtractFilePath(fn); - cfg.admin['scim-salt'].value := NewGuidId; - - for n in FFiles.Keys do - begin - sct := cfg.section['terminologies'].section[PathTitle(n)]; - sct['type'].value := FFiles[n]; - sct['active'].value := 'true'; - if StringArrayExists(['rxnorm', 'ndc', 'unii', 'cpt', 'omop', 'xig'], FFiles[n]) then - begin - sct['db-type'].value := 'sqlite'; - if (FFiles[n] = 'cpt') and (local.ValueExists('cpt', 'local-source')) then - sct['db-file'].value := local.ReadString('cpt', 'local-source', '') - else if (n.startsWith('file:')) then - sct['db-file'].value := FilePath([FFolder, extractFileName(n.subString(5))]) - else - sct['db-file'].value := FilePath([FFolder, n]); - sct['db-auto-create'].value := 'false'; - end - else - begin - sct['source'].value := FilePath([FFolder, n]); - if (FFiles[n] = 'snomed!') then - begin - sct['type'].value := 'snomed'; - sct['default'].value := 'true'; - end; - end; - end; - - for n in FEndPoints.Keys do - begin - if (FEndPoints[n].active) and (FEndPoints[n].Packages.Count > 0) then - begin - buildEndPoint(FEndPoints[n]); - sct := cfg.section['endpoints'].section[n]; - sct['type'].value := 'terminology'; - sct['path'].value := '/'+n; - sct['version'].value := n; - sct['active'].value := 'true'; - sct['security'].value := 'open'; - sct['db-type'].value := 'sqlite'; - sct['db-file'].value := FEndPoints[n].filename; - sct['db-auto-create'].value := 'false'; - sct['packages'].values.Assign(FEndPoints[n].Packages); - end; - end; - - ep := FJson.forceObj['endpoints']; - for n in ep.properties.keys do - begin - o := ep.obj[n]; - mode := o.str['mode']; - if (mode = '') or (mode = FMode) then - begin - sct := cfg.section['endpoints'].section[n]; - sct['type'].value := o.str['type']; - sct['path'].value := o.str['path']; - sct['active'].value := 'true'; - sct['db-type'].value := o.str['db-type']; - sct['db-source'].value := o.str['db-file']; - sct['db-file'].value := fixDbPath(o.str['db-file']); - sct['db-auto-create'].value := o.str['db-auto-create']; - if o.has('folder') then - sct['folder'].value := o.str['folder'].Replace('{local}', FFolder); - end; - end; - - cfg.Save; - finally - cfg.free; - end; -end; - -procedure TConfigurationBuilder.buildEndPoint(ep : TEndPointInfo); -var - fn : String; -begin - fn := FilePath([FFolder, 'endpoint-r'+CODES_FHIR_GENERATED_PUBLICATION[ep.version]+'.db']); - ep.filename := fn; - if not FileExists(fn) then - CreateDatabase(ep.version, fn) - else if not doUpgrade(ep.version, fn) then - begin - Logging.log('Rebuilding database. Closure tables will be lost'); - CreateDatabase(ep.version, fn); - end; -end; - -procedure TConfigurationBuilder.setupEndPoints; -var - v, vl : String; - ep : TEndPointInfo; -begin - if not FParams.get('version', vl) then - vl := '*'; - if (vl = '*') then - vl := '2,3,4,5'; - - for v in vl.Split([';', ',']) do - begin - ep := FEndPoints['r'+v]; - if (ep = nil) then - raise EFslException.Create('Version "'+v+'" is unknown') - else - ep.active := true; - end; -end; - -procedure TConfigurationBuilder.DownloadFileList(files : TJsonObject); -var - fn : String; -begin - for fn in files.properties.Keys do - begin - FFiles.Add(fn, (files.node[fn] as TJsonString).value); - downloadFile(fn); - end; -end; - -procedure TConfigurationBuilder.DownloadFiles; -var - content, realm, files : TJsonObject; - r, i : String; -begin -// Logging.log('Realm: uv'); - content := FJson.forceObj['content']; - realm := content.forceObj['uv']; - SeePackages(realm); - files := realm.forceObj['files']; - DownloadFileList(files); - - if not FParams.get('realm', r) then - r := '*'; - - if (r = '*') then - begin - for i in content.properties.Keys do - if i <> 'uv' then - begin -// Logging.log('Realm: '+i); - realm := content.forceObj[i]; - SeePackages(realm); - files := realm.forceObj['files']; - DownloadFileList(files); - end; - end - else - begin - for i in r.split([';', ',']) do - begin -// Logging.log('Realm: '+i); - realm := content.forceObj[i]; - SeePackages(realm); - files := realm.forceObj['files']; - DownloadFileList(files); - end; - end; -end; - -procedure TConfigurationBuilder.DownloadProgress(sender: TObject; progress: integer); -begin - if progress >= FLastPct + 2 then - begin - FLastPct := progress; - Logging.continue('.'); - end; -end; - -procedure TConfigurationBuilder.readConfig; -var - f : TFileStream; - src : String; -begin - src := URLPath([FUrl, 'config.json']); - Logging.log('Read Zero Config from '+src); - if (src.StartsWith('file:')) then - FJson := TJSONParser.ParseFile(src.Substring(5)) - else - FJson := TInternetFetcher.fetchJson(src+'?timestamp='+TFslDateTime.makeUTC.toHL7); - f := TFileStream.Create(FilePath([FFolder, 'config.json']), fmCreate); - try - TJSONWriter.writeObject(f, FJson, true); - finally - f.free; - end; -end; - -procedure TConfigurationBuilder.seePackages(realm: TJsonObject); -var - i : integer; - pck : TJsonObject; -begin - pck := realm.forceObj['packages']; - - for i := 0 to pck.forceArr['r5'].Count - 1 do - FEndPoints['r5'].Packages.Add(pck.arr['r5'].Value[i]); - - for i := 0 to pck.forceArr['r4'].Count - 1 do - FEndPoints['r4'].Packages.Add(pck.arr['r4'].Value[i]); - - for i := 0 to pck.forceArr['r3'].Count - 1 do - FEndPoints['r3'].Packages.Add(pck.arr['r3'].Value[i]); - - for i := 0 to pck.forceArr['r2'].Count - 1 do - FEndPoints['r2'].Packages.Add(pck.arr['r2'].Value[i]); -end; - -procedure TConfigurationBuilder.downloadFile(fn : String); -var - src, tgt : String; -begin - if (fn.StartsWith('file:')) then - begin - src := fn; - tgt := FilePath([FFolder, extractFileName(fn)]); - end - else - begin - src := UrlPath([FUrl, fn]); - tgt := FilePath([FFolder, fn]); - end; - downloadFile(src, tgt); -end; - -procedure TConfigurationBuilder.downloadFile(src, tgt : String); -var - fetcher : TInternetFetcher; - start : TDateTime; -begin - if (src.StartsWith('file:')) then - begin - if not (FileExists(tgt)) then - begin - Logging.start('Copy '+src); - BytesToFile(FileToBytes(src.Substring(5)), tgt); - Logging.finish(' Done'); - end; -// else -// Logging.log(fn+' already copied') - end - else - begin - FLastPct := 0; - if not FileExists(tgt) then - begin - Logging.start('Download '+src); - try - start := now; - fetcher := TInternetFetcher.Create; - try - fetcher.OnProgress := DownloadProgress; - fetcher.URL := src; - fetcher.Fetch; - fetcher.Buffer.SaveToFileName(tgt); - Logging.finish(' Done ('+DescribeBytes(fetcher.buffer.size)+', '+DescribePeriod(now - start)+')'); - finally - fetcher.free; - end; - except - on e : Exception do - begin - Logging.finish(' '+e.Message); - raise; - end; - end; - //else - // Logging.log(fn+' already downloaded') - end; - end; -end; - -function loadRemoteConfig(params : TCommandLineParameters; src : String; local : TIniFile) : String; -var - cb : TConfigurationBuilder; - dir : String; -begin - SetThreadStatus('loadRemoteConfig'); - dir := local.ReadString('config', 'local', UserFolder); - - result := FilePath([dir, 'fhir-server', 'fhir-server-config.cfg']); - try - cb := TConfigurationBuilder.Create(params.link); - try - cb.FMode := local.ReadString('config', 'mode', ''); - cb.FUrl := src; - cb.FFolder := ExtractFilePath(result); - if not FolderExists(cb.FFolder) then - ForceDirectories(cb.FFolder); - cb.readConfig; - Logging.log('Local Config in '+cb.FFolder); - cb.DownloadFiles; - cb.setupEndPoints; - cb.buildConfig(result, local); - finally - cb.free; - end; - except - on e : Exception do - begin - Logging.log('Zero Configuration Process failed: '+e.message); - if FileExists(result) then - Logging.log('Continuing on last successful configuration') - else - begin - Logging.log('First time, so can''t continue.'); - raise; - end; - end; - end; -end; - -{ TEndPointInfo } - -constructor TEndPointInfo.Create(version : TFHIRVersion); -begin - inherited Create; - FPackages := TStringList.Create; - FVersion := version; -end; - -destructor TEndPointInfo.Destroy; -begin - FPackages.free; - inherited; -end; - -end. +unit zero_config; + +{ +Copyright (c) 2001-2021, Health Intersections Pty Ltd (http://www.healthintersections.com.au) +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of HL7 nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +} + +{$i fhir.inc} + +interface + +uses + SysUtils, Classes, IniFiles, + fsl_base, fsl_utilities, fsl_fetcher, fsl_logging, fsl_json, fsl_threads, + fdb_manager, fdb_sqlite3, + fhir_objects, + server_config, database_installer, server_factory, server_constants, + endpoint_txsvr; + +function loadRemoteConfig(params : TCommandLineParameters; src : String; local : TIniFile) : String; + +implementation + +type + + { TEndPointInfo } + + TEndPointInfo = class (TFslObject) + private + FActive: boolean; + FMode: String; + FVersion: TFHIRVersion; + FFilename: String; + FPackages: TStringList; + FKind: String; + public + constructor Create(version : TFHIRVersion); overload; + destructor Destroy; override; + + property active : boolean read FActive write FActive; + property kind : String read FKind write FKind; + property mode : String read FMode write FMode; + property filename : String read FFilename write FFilename; + property version : TFHIRVersion read FVersion write FVersion; + property Packages : TStringList read FPackages; + + end; + + { TConfigurationBuilder } + + TConfigurationBuilder = class (TFslObject) + private + FParams : TCommandLineParameters; + FLastPct : Integer; + FJson : TJsonObject; + FFolder : String; + FUrl : String; + FFiles : TFslStringDictionary; + FEndPoints : TFslMap; + FMode : String; + procedure DownloadProgress(sender : TObject; progress : integer); + procedure downloadFile(fn : String); overload; + procedure downloadFile(src, tgt : String); overload; + procedure DownloadFiles; + function fixDBPath(fn: String): String; + procedure readConfig; + procedure buildEndPoint(ep : TEndPointInfo); + procedure setupEndPoints; + procedure CreateDatabase(v : TFHIRVersion; fn : String); + function doUpgrade(v : TFHIRVersion; fn : String) : boolean; + procedure buildConfig(fn : String; local : TCustomIniFile); + procedure DownloadFileList(files: TJsonObject); + procedure seePackages(realm : TJsonObject); + public + constructor Create(params : TCommandLineParameters); + destructor Destroy; override; + end; + +constructor TConfigurationBuilder.Create(params : TCommandLineParameters); +begin + inherited Create; + FParams := params; + FFiles := TFslStringDictionary.Create; + FEndPoints := TFslMap.Create; + FEndPoints.Add('r2', TEndPointInfo.Create(fhirVersionRelease2)); + FEndPoints.Add('r3', TEndPointInfo.Create(fhirVersionRelease3)); + FEndPoints.Add('r4', TEndPointInfo.Create(fhirVersionRelease4)); + FEndPoints.Add('r5', TEndPointInfo.Create(fhirVersionRelease5)); + FEndPoints.defaultValue := nil; +end; + +destructor TConfigurationBuilder.Destroy; +begin + FParams.free; + FEndPoints.free; + FFiles.free; + FJson.free; + inherited; +end; + +function TConfigurationBuilder.doUpgrade(v : TFHIRVersion; fn : String) : boolean; +var + sql : TFDBSQLiteManager; + conn : TFDBConnection; + installer : TFHIRDatabaseInstaller; +begin + result := false; + sql := TFDBSQLiteManager.Create('cfg', fn, false, true); + try + conn := sql.GetConnection('install'); + try + installer := TFHIRDatabaseInstaller.Create(conn, makeTxFactory(v), makeTxServerFactory(v)); + try + try + installer.Upgrade; + result := true; + except + on e : Exception do + Logging.log('Unable to upgrade existing database '+fn+': '+e.message); + end; + finally + installer.free; + end; + conn.Release; + except + on e : exception do + begin + conn.Error(e); + end; + end; + finally + sql.free; + end; +end; + +procedure TConfigurationBuilder.CreateDatabase(v : TFHIRVersion; fn : String); +var + sql : TFDBSQLiteManager; + conn : TFDBConnection; + installer : TFHIRDatabaseInstaller; +begin + sql := TFDBSQLiteManager.Create('cfg', fn, false, true); + try + conn := sql.GetConnection('install'); + try + installer := TFHIRDatabaseInstaller.Create(conn, makeTxFactory(v), makeTxServerFactory(v)); + try + installer.InstallTerminologyServer; + finally + installer.free; + end; + conn.Release; + except + on e : exception do + begin + conn.Error(e); + end; + end; + finally + sql.free; + end; +end; + +function TConfigurationBuilder.fixDBPath(fn : String) : String; +begin + if (fn.StartsWith('http:') or fn.StartsWith('https:')) then + begin + result := FilePath([FFolder, fn.Substring(fn.LastIndexOf('/')+1)]); + downloadFile(fn, result); + end + else if (ExtractFilePath(fn) = '') then + result := FilePath([FFolder, fn]) + else + result := fn; +end; + +function def(s1, s2, s3 : String) : String; +begin + if (s1 <> '') then + result := s1 + else if (s2 <> '') then + result := s2 + else + result := s3; +end; + +procedure TConfigurationBuilder.buildConfig(fn: String; local : TCustomIniFile); +var + cfg : TFHIRServerConfigFile; + n, v : String; + rn : integer; + sct : TFHIRServerConfigSection; + ep, o : TJsonObject; + lwi, mode : String; +begin + rn := 1; + if FileExists(fn) then + begin + cfg := TFHIRServerConfigFile.Create(fn); + try + rn := StrToIntDef(cfg.section['service']['runNumber'].value, 1); + finally + cfg.free; + end; + DeleteFile(fn); + end; + + cfg := TFHIRServerConfigFile.Create(fn); + try + cfg.section['service']['runNumber'].value := inttostr(rn); + + cfg.web['host'].value := def(local.ReadString('web', 'host', ''), cfg.web['host'].value, 'localhost'); + cfg.web['http'].value := def(local.ReadString('web', 'http', ''), cfg.web['http'].value, '80'); + cfg.web['https'].value := def(local.ReadString('web', 'https', ''), cfg.web['https'].value, ''); + cfg.web['rproxy-http'].value := def(local.ReadString('web', 'rproxy-http', ''), cfg.web['rproxy-http'].value, ''); + cfg.web['rproxy-https'].value := def(local.ReadString('web', 'rproxy-https', ''), cfg.web['rproxy-https'].value, ''); + cfg.web['rproxy-cert-header'].value := def(local.ReadString('web', 'rproxy-cert-header', ''), cfg.web['rproxy-cert-header'].value, ''); + cfg.web['rproxy-ssl-value'].value := def(local.ReadString('web', 'rproxy-ssl-value', ''), cfg.web['rproxy-ssl-value'].value, ''); + cfg.web['certname'].value := def(local.ReadString('web', 'certname', ''), cfg.web['certname'].value, ''); + cfg.web['cacertname'].value := def(local.ReadString('web', 'cacertname', ''), cfg.web['cacertname'].value, ''); + cfg.web['certkey'].value := def(local.ReadString('web', 'certkey', ''), cfg.web['certkey'].value, ''); + cfg.web['password'].value := def(local.ReadString('web', 'password', ''), cfg.web['password'].value, ''); + cfg.web['telnet-password'].value := def(local.ReadString('config', 'telnet-pword', NewGuidId), cfg.web['telnet-password'].value, ''); + cfg.web['robots.txt'].value := def(local.ReadString('web', 'robots.txt', ''), cfg.web['robots.txt'].value, ''); + cfg.admin['log-folder'].value := def(local.ReadString('web', 'logFolder', ''), cfg.admin['log-folder'].value, ''); + cfg.admin['email'].value := def(local.ReadString('config', 'email', ''), cfg.admin['email'].value, 'noone@fhir.org'); + cfg.admin['ownername'].value := def(local.ReadString('config', 'user', ''), cfg.admin['ownername'].value, 'Local User'); + cfg.service['max-memory'].value := def(local.ReadString('config', 'max-memory', ''), cfg.service['max-memory'].value, '0'); + cfg.service['cache-time'].value := def(local.ReadString('config', 'cache-time', ''), cfg.service['cache-time'].value, inttostr(DEFAULT_DWELL_TIME_MIN)); + + cfg.web['http-max-conn'].value := '50'; + cfg.web['http-cache-time'].value := '1000'; + cfg.web['plain-mode'].value := 'false'; + cfg.web['caching'].value := 'true'; + cfg.service['langfile'].value := partnerFile('lang.dat'); + cfg.service['package-cache'].value := ExtractFilePath(fn); + cfg.admin['scim-salt'].value := NewGuidId; + + for n in FFiles.Keys do + begin + sct := cfg.section['terminologies'].section[PathTitle(n)]; + sct['type'].value := FFiles[n]; + sct['active'].value := 'true'; + if StringArrayExists(['rxnorm', 'ndc', 'unii', 'cpt', 'omop', 'xig'], FFiles[n]) then + begin + sct['db-type'].value := 'sqlite'; + if (FFiles[n] = 'cpt') and (local.ValueExists('cpt', 'local-source')) then + sct['db-file'].value := local.ReadString('cpt', 'local-source', '') + else if (n.startsWith('file:')) then + sct['db-file'].value := FilePath([FFolder, extractFileName(n.subString(5))]) + else + sct['db-file'].value := FilePath([FFolder, n]); + sct['db-auto-create'].value := 'false'; + end + else + begin + sct['source'].value := FilePath([FFolder, n]); + if (FFiles[n] = 'snomed!') then + begin + sct['type'].value := 'snomed'; + sct['default'].value := 'true'; + end; + end; + end; + + for n in FEndPoints.Keys do + begin + if (FEndPoints[n].active) and (FEndPoints[n].Packages.Count > 0) then + begin + buildEndPoint(FEndPoints[n]); + sct := cfg.section['endpoints'].section[n]; + sct['type'].value := 'terminology'; + sct['path'].value := '/'+n; + sct['version'].value := n; + sct['active'].value := 'true'; + sct['security'].value := 'open'; + sct['db-type'].value := 'sqlite'; + sct['db-file'].value := FEndPoints[n].filename; + sct['db-auto-create'].value := 'false'; + sct['packages'].values.Assign(FEndPoints[n].Packages); + end; + end; + + ep := FJson.forceObj['endpoints']; + for n in ep.properties.keys do + begin + o := ep.obj[n]; + mode := o.str['mode']; + if (mode = '') or (mode = FMode) then + begin + sct := cfg.section['endpoints'].section[n]; + sct['type'].value := o.str['type']; + sct['path'].value := o.str['path']; + sct['active'].value := 'true'; + sct['db-type'].value := o.str['db-type']; + sct['db-source'].value := o.str['db-file']; + sct['db-file'].value := fixDbPath(o.str['db-file']); + sct['db-auto-create'].value := o.str['db-auto-create']; + if o.has('folder') then + sct['folder'].value := o.str['folder'].Replace('{local}', FFolder); + end; + end; + + cfg.Save; + finally + cfg.free; + end; +end; + +procedure TConfigurationBuilder.buildEndPoint(ep : TEndPointInfo); +var + fn : String; +begin + fn := FilePath([FFolder, 'endpoint-r'+CODES_FHIR_GENERATED_PUBLICATION[ep.version]+'.db']); + ep.filename := fn; + if not FileExists(fn) then + CreateDatabase(ep.version, fn) + else if not doUpgrade(ep.version, fn) then + begin + Logging.log('Rebuilding database. Closure tables will be lost'); + CreateDatabase(ep.version, fn); + end; +end; + +procedure TConfigurationBuilder.setupEndPoints; +var + v, vl : String; + ep : TEndPointInfo; +begin + if not FParams.get('version', vl) then + vl := '*'; + if (vl = '*') then + vl := '2,3,4,5'; + + for v in vl.Split([';', ',']) do + begin + ep := FEndPoints['r'+v]; + if (ep = nil) then + raise EFslException.Create('Version "'+v+'" is unknown') + else + ep.active := true; + end; +end; + +procedure TConfigurationBuilder.DownloadFileList(files : TJsonObject); +var + fn : String; +begin + for fn in files.properties.Keys do + begin + FFiles.Add(fn, (files.node[fn] as TJsonString).value); + downloadFile(fn); + end; +end; + +procedure TConfigurationBuilder.DownloadFiles; +var + content, realm, files : TJsonObject; + r, i : String; +begin +// Logging.log('Realm: uv'); + content := FJson.forceObj['content']; + realm := content.forceObj['uv']; + SeePackages(realm); + files := realm.forceObj['files']; + DownloadFileList(files); + + if not FParams.get('realm', r) then + r := '*'; + + if (r = '*') then + begin + for i in content.properties.Keys do + if i <> 'uv' then + begin +// Logging.log('Realm: '+i); + realm := content.forceObj[i]; + SeePackages(realm); + files := realm.forceObj['files']; + DownloadFileList(files); + end; + end + else + begin + for i in r.split([';', ',']) do + begin +// Logging.log('Realm: '+i); + realm := content.forceObj[i]; + SeePackages(realm); + files := realm.forceObj['files']; + DownloadFileList(files); + end; + end; +end; + +procedure TConfigurationBuilder.DownloadProgress(sender: TObject; progress: integer); +begin + if progress >= FLastPct + 2 then + begin + FLastPct := progress; + Logging.continue('.'); + end; +end; + +procedure TConfigurationBuilder.readConfig; +var + f : TFileStream; + src : String; +begin + src := URLPath([FUrl, 'config.json']); + Logging.log('Read Zero Config from '+src); + if (src.StartsWith('file:')) then + FJson := TJSONParser.ParseFile(src.Substring(5)) + else + FJson := TInternetFetcher.fetchJson(src+'?timestamp='+TFslDateTime.makeUTC.toHL7); + f := TFileStream.Create(FilePath([FFolder, 'config.json']), fmCreate); + try + TJSONWriter.writeObject(f, FJson, true); + finally + f.free; + end; +end; + +procedure TConfigurationBuilder.seePackages(realm: TJsonObject); +var + i : integer; + pck : TJsonObject; +begin + pck := realm.forceObj['packages']; + + for i := 0 to pck.forceArr['r5'].Count - 1 do + FEndPoints['r5'].Packages.Add(pck.arr['r5'].Value[i]); + + for i := 0 to pck.forceArr['r4'].Count - 1 do + FEndPoints['r4'].Packages.Add(pck.arr['r4'].Value[i]); + + for i := 0 to pck.forceArr['r3'].Count - 1 do + FEndPoints['r3'].Packages.Add(pck.arr['r3'].Value[i]); + + for i := 0 to pck.forceArr['r2'].Count - 1 do + FEndPoints['r2'].Packages.Add(pck.arr['r2'].Value[i]); +end; + +procedure TConfigurationBuilder.downloadFile(fn : String); +var + src, tgt : String; +begin + if (fn.StartsWith('file:')) then + begin + src := fn; + tgt := FilePath([FFolder, extractFileName(fn)]); + end + else + begin + src := UrlPath([FUrl, fn]); + tgt := FilePath([FFolder, fn]); + end; + downloadFile(src, tgt); +end; + +procedure TConfigurationBuilder.downloadFile(src, tgt : String); +var + fetcher : TInternetFetcher; + start : TDateTime; +begin + if (src.StartsWith('file:')) then + begin + if not (FileExists(tgt)) then + begin + Logging.start('Copy '+src); + BytesToFile(FileToBytes(src.Substring(5)), tgt); + Logging.finish(' Done'); + end; +// else +// Logging.log(fn+' already copied') + end + else + begin + FLastPct := 0; + if not FileExists(tgt) then + begin + Logging.start('Download '+src); + try + start := now; + fetcher := TInternetFetcher.Create; + try + fetcher.OnProgress := DownloadProgress; + fetcher.URL := src; + fetcher.Fetch; + fetcher.Buffer.SaveToFileName(tgt); + Logging.finish(' Done ('+DescribeBytes(fetcher.buffer.size)+', '+DescribePeriod(now - start)+')'); + finally + fetcher.free; + end; + except + on e : Exception do + begin + Logging.finish(' '+e.Message); + raise; + end; + end; + //else + // Logging.log(fn+' already downloaded') + end; + end; +end; + +function loadRemoteConfig(params : TCommandLineParameters; src : String; local : TIniFile) : String; +var + cb : TConfigurationBuilder; + dir : String; +begin + SetThreadStatus('loadRemoteConfig'); + dir := local.ReadString('config', 'local', UserFolder); + + result := FilePath([dir, 'fhir-server', 'fhir-server-config.cfg']); + try + cb := TConfigurationBuilder.Create(params.link); + try + cb.FMode := local.ReadString('config', 'mode', ''); + cb.FUrl := src; + cb.FFolder := ExtractFilePath(result); + if not FolderExists(cb.FFolder) then + ForceDirectories(cb.FFolder); + cb.readConfig; + Logging.log('Local Config in '+cb.FFolder); + cb.DownloadFiles; + cb.setupEndPoints; + cb.buildConfig(result, local); + finally + cb.free; + end; + except + on e : Exception do + begin + Logging.log('Zero Configuration Process failed: '+e.message); + if FileExists(result) then + Logging.log('Continuing on last successful configuration') + else + begin + Logging.log('First time, so can''t continue.'); + raise; + end; + end; + end; +end; + +{ TEndPointInfo } + +constructor TEndPointInfo.Create(version : TFHIRVersion); +begin + inherited Create; + FPackages := TStringList.Create; + FVersion := version; +end; + +destructor TEndPointInfo.Destroy; +begin + FPackages.free; + inherited; +end; + +end. diff --git a/utilities/codescan/codescan.lpi b/utilities/codescan/codescan.lpi index 05c607de9..bd1254e8f 100644 --- a/utilities/codescan/codescan.lpi +++ b/utilities/codescan/codescan.lpi @@ -116,7 +116,6 @@ - diff --git a/utilities/codescan/codescan.lpr b/utilities/codescan/codescan.lpr index 6db9f42a1..2f36293dd 100644 --- a/utilities/codescan/codescan.lpr +++ b/utilities/codescan/codescan.lpr @@ -87,7 +87,7 @@ TIncludeHandler = class(TInterfacedObject, IIncludeHandler) end; { TCodeScanner } - TSourceScanCheck = (sscUnicode, sscLicense, sscExceptionRaise, sscExceptionDefine, sscLineEndings, sscParse); + TSourceScanCheck = (sscUnicode, sscLicense, sscExceptionRaise, sscExceptionDefine, sscLineEndings, sscParse, sscConstructors); TSourceScanCheckSet = set of TSourceScanCheck; TCodeScanner = class(TObject) @@ -110,6 +110,7 @@ TCodeScanner = class(TObject) procedure checkFileForLicense(filename, src : String); procedure checkFileForExceptionRaise(filename, src : String; ts : TStringList); procedure checkFileForExceptionDefine(filename, src : String; ts : TStringList); + function checkConstructors(filename, src : String; ts : TStringList) : boolean; function checkFileForLineEndings(filename, src : String) : String; procedure scanFolder(folder: String; checks: TSourceScanCheckSet; incFolder : String); @@ -216,7 +217,7 @@ procedure TCodeScanner.checkFileForExceptionRaise(filename, src : String; ts : T begin srcns := ts[i].Replace(#9, '').Replace(' ', ' ').ToLower; if srcns.contains('raise exception.') then - reportError(filename, i, 'raises a unspecialised exception'); + reportError(filename, i, 'raises an unspecialised exception'); end; end; @@ -233,6 +234,36 @@ if srcns.contains('=class(exception)') and not srcns.contains('efslexception end; end; +function TCodeScanner.checkConstructors(filename, src: String; ts: TStringList) : boolean; +var + i : integer; + inConstructor : boolean; + srcns, s : String; +begin + inConstructor := false; + result := false; + for i := 0 to ts.count - 1 do + begin + srcns := ts[i].Replace(#9, ' ').Replace(' ', '').ToLower; + if inConstructor then + begin + if srcns.trim = 'begin' then + begin + inConstructor := false; + s := ts[i+1].toLower; + if not s.contains('create') and not s.contains('inherited') then + begin + reportError(filename, i, 'constructor does not call (inherited?) create'); + //ts[i+1] := '!'+ts[i+1]; + //result := true; + end; + end + end + else if srcns.startsWith('constructor T') then + inConstructor := true; + end; +end; + function TCodeScanner.checkFileForLineEndings(filename, src : String) : String; var b : TFslStringBuilder; @@ -373,7 +404,10 @@ procedure TCodeScanner.checkFile(filename: String; checks: TSourceScanCheckSet; var src : String; ts : TStringList; + save : boolean; begin + save := false; + if (sscUnicode in checks) and StringArrayExists(['.pas', '.inc', '.html', '.css', '.dpr', '.lpr', '.xml', '.json'], ExtractFileExt(filename)) then checkFileForUnicode(filename); @@ -413,6 +447,18 @@ procedure TCodeScanner.checkFile(filename: String; checks: TSourceScanCheckSet; end; checkFileForExceptionDefine(filename, src, ts); end; + + if (sscConstructors in checks) and StringArrayExists(['.pas'], ExtractFileExt(filename)) then + begin + if src = '' then + begin + src := FileToString(filename, nil); + ts.Text := src; + end; + save := checkConstructors(filename, src, ts); + end; + if save then + ts.SaveToFile(filename, TEncoding.UTF8); finally ts.free; end; @@ -630,7 +676,7 @@ procedure TCodeScanner.Run; scanFolder(FilePath([FSourceDir, 'lazarus-ide-tester']), [sscLicense, sscLineEndings, sscExceptionRaise, sscParse], FilePath([FSourceDir, 'lazarus-ide-tester'])); output(''); output(FProjectDir+' [license, eoln, exceptions, full-parse]'); - scanFolder(FProjectDir, [sscUnicode, sscLicense, sscExceptionRaise, sscExceptionDefine, sscLineEndings, sscParse], FilePath([FProjectDir, 'library'])); + scanFolder(FProjectDir, [sscUnicode, sscLicense, sscExceptionRaise, sscExceptionDefine, sscLineEndings, sscConstructors, sscParse], FilePath([FProjectDir, 'library'])); output(''); end; except