diff --git a/.github/workflows/linux-docker-build.yml b/.github/workflows/linux-docker-build.yml index 9b336aad5..ebecf95ed 100644 --- a/.github/workflows/linux-docker-build.yml +++ b/.github/workflows/linux-docker-build.yml @@ -4,7 +4,6 @@ on: push: branches: - master - - lastbuilt # pull_request: jobs: Build-Docker-Image: @@ -40,10 +39,10 @@ jobs: docker build \ --tag fhirserver \ . - - name: Scan Code - run: | - export DISPLAY=0:0 - docker run --entrypoint /work/fhirserver/utilities/codescan/codescan fhirserver /work/bootstrap +# - name: Scan Code +# run: | +# export DISPLAY=0:0 +# docker run --entrypoint /work/fhirserver/utilities/codescan/codescan fhirserver /work/bootstrap - name: Prepare ini file env: FHIRSERVER_LOCATIONS_CLONE_PATH: /work/fhirserver @@ -74,15 +73,15 @@ jobs: -v ~/test-settings.ini:/work/fhirserver/exec/64/test-settings.ini \ fhirserver -tests - - name: Tag and push Docker image - run: | - # Extract the FHIR server version from the library/version.inc file - FHIR_VERSION=$(grep -oP "FHIR_CODE_FULL_VERSION = '\K[^']+" library/version.inc) - - # Tag the Docker image with the extracted version and "latest" - docker tag fhirserver ${{ secrets.DOCKERHUB_USERNAME }}/fhirserver:$FHIR_VERSION - docker tag fhirserver ${{ secrets.DOCKERHUB_USERNAME }}/fhirserver:latest - - # Push both tagged images to Docker Hub - docker push ${{ secrets.DOCKERHUB_USERNAME }}/fhirserver:$FHIR_VERSION - docker push ${{ secrets.DOCKERHUB_USERNAME }}/fhirserver:latest +# - name: Tag and push Docker image +# run: | +# # Extract the FHIR server version from the library/version.inc file +# FHIR_VERSION=$(grep -oP "FHIR_CODE_FULL_VERSION = '\K[^']+" library/version.inc) +# +# # Tag the Docker image with the extracted version and "latest" +# docker tag fhirserver ${{ secrets.DOCKERHUB_USERNAME }}/fhirserver:$FHIR_VERSION +# docker tag fhirserver ${{ secrets.DOCKERHUB_USERNAME }}/fhirserver:latest +# +# # Push both tagged images to Docker Hub +# docker push ${{ secrets.DOCKERHUB_USERNAME }}/fhirserver:$FHIR_VERSION +# docker push ${{ secrets.DOCKERHUB_USERNAME }}/fhirserver:latest diff --git a/build/linux-fhirserver.sh b/build/linux-fhirserver.sh old mode 100755 new mode 100644 index 2809a694e..ef61deaa0 --- a/build/linux-fhirserver.sh +++ b/build/linux-fhirserver.sh @@ -44,7 +44,7 @@ echo "## compile packages/fhir_fui.lpk" $BUILD/tools/lazarus/lazbuild packages/fhir_fui.lpk -q -q --build-all echo "## compile codescanner" -$BUILD/tools/lazarus/lazbuild utilities/codescan/codescan.lpi --build-mode=linux -q -q --build-all +echo $BUILD/tools/lazarus/lazbuild utilities/codescan/codescan.lpi --build-mode=linux -q -q --build-all echo "## compile console" $BUILD/tools/lazarus/lazbuild server/fhirconsole.lpi --build-mode=linux -q -q --build-all diff --git a/build/windows-fhirserver.bat b/build/windows-fhirserver.bat index db4ff9a46..9413953dc 100644 --- a/build/windows-fhirserver.bat +++ b/build/windows-fhirserver.bat @@ -12,6 +12,8 @@ copy ..\exec\pack\*.cfg ..\exec\64\ copy ..\exec\pack\*.dat ..\exec\64\ copy ..\exec\pack\w64\*.dll ..\exec\64\ +del ..\exec\64\*.exe + IF %1.==. GOTO No1 set "tmp=%1" @@ -19,49 +21,49 @@ set "tmp=%1" echo ## compile packages/fhir_indy.lpk -%tmp%\tools\lazarus\lazbuild.exe packages/fhir_indy.lpk -q -q +%tmp%\tools\lazarus\lazbuild.exe packages/fhir_indy.lpk -q -q --build-all echo ## compile packages/fhir_fsl.lpk -%tmp%\tools\lazarus\lazbuild.exe packages/fhir_fsl.lpk -q -q +%tmp%\tools\lazarus\lazbuild.exe packages/fhir_fsl.lpk -q -q --build-all echo ## compile packages/fcomp.lpk -%tmp%\tools\lazarus\lazbuild.exe packages/fcomp.lpk -q -q +%tmp%\tools\lazarus\lazbuild.exe packages/fcomp.lpk -q -q --build-all echo ## compile packages/fhir.lpk -%tmp%\tools\lazarus\lazbuild.exe packages/fhir.lpk -q -q +%tmp%\tools\lazarus\lazbuild.exe packages/fhir.lpk -q -q --build-all echo ## compile packages/fhir2.lpk -%tmp%\tools\lazarus\lazbuild.exe packages/fhir2.lpk -q -q +%tmp%\tools\lazarus\lazbuild.exe packages/fhir2.lpk -q -q --build-all echo ## compile packages/fhir3.lpk -%tmp%\tools\lazarus\lazbuild.exe packages/fhir3.lpk -q -q +%tmp%\tools\lazarus\lazbuild.exe packages/fhir3.lpk -q -q --build-all echo ## compile packages/fhir4.lpk -%tmp%\tools\lazarus\lazbuild.exe packages/fhir4.lpk -q -q +%tmp%\tools\lazarus\lazbuild.exe packages/fhir4.lpk -q -q --build-all echo ## compile packages/fhir4b.lpk -%tmp%\tools\lazarus\lazbuild.exe packages/fhir4b.lpk -q -q +%tmp%\tools\lazarus\lazbuild.exe packages/fhir4b.lpk -q -q --build-all echo ## compile packages/fhir5.lpk -%tmp%\tools\lazarus\lazbuild.exe packages/fhir5.lpk -q -q +%tmp%\tools\lazarus\lazbuild.exe packages/fhir5.lpk -q -q --build-all echo ## compile packages/fhir_xver.lpk -%tmp%\tools\lazarus\lazbuild.exe packages/fhir_xver.lpk -q -q +%tmp%\tools\lazarus\lazbuild.exe packages/fhir_xver.lpk -q -q --build-all echo ## compile packages/fhir_fui.lpk -%tmp%\tools\lazarus\lazbuild.exe packages/fhir_fui.lpk -q -q +%tmp%\tools\lazarus\lazbuild.exe packages/fhir_fui.lpk -q -q --build-all echo ## compile code tools -%tmp%\tools\lazarus\lazbuild.exe utilities/codescan/codescan.lpi --build-mode=win64 -q -q +%tmp%\tools\lazarus\lazbuild.exe utilities/codescan/codescan.lpi --build-mode=win64 -q -q --build-all echo ## compile console -%tmp%\tools\lazarus\lazbuild.exe server/fhirconsole.lpi --build-mode=win64 -q -q +%tmp%\tools\lazarus\lazbuild.exe server/fhirconsole.lpi --build-mode=win64 -q -q --build-all echo ## compile server -%tmp%\tools\lazarus\lazbuild.exe server/fhirserver.lpr --build-mode=win64 -q -q +%tmp%\tools\lazarus\lazbuild.exe server/fhirserver.lpr --build-mode=win64 -q -q --build-all echo ## compile toolkit -%tmp%\tools\lazarus\lazbuild.exe toolkit2/fhirtoolkit.lpr --build-mode=win64 -q -q +%tmp%\tools\lazarus\lazbuild.exe toolkit2/fhirtoolkit.lpr --build-mode=win64 -q -q --build-all copy exec\64\fhirserver.exe exec\64\FHIRServer.debug.exe del exec\64\fhirserver.exe @@ -71,12 +73,21 @@ copy exec\64\fhirtoolkit.exe exec\64\FHIRToolkit.debug.exe del exec\64\fhirtoolkit.exe echo ## compile console -%tmp%\tools\lazarus\lazbuild.exe server/fhirconsole.lpi --build-mode=win64-release -q -q +%tmp%\tools\lazarus\lazbuild.exe server/fhirconsole.lpi --build-mode=win64-release -q -q --build-all echo ## compile server -%tmp%\tools\lazarus\lazbuild.exe server/fhirserver.lpr --build-mode=win64-release -q -q +%tmp%\tools\lazarus\lazbuild.exe server/fhirserver.lpr --build-mode=win64-release -q -q --build-all echo ## compile toolkit -%tmp%\tools\lazarus\lazbuild.exe toolkit2/fhirtoolkit.lpr --build-mode=win64-release -q -q +%tmp%\tools\lazarus\lazbuild.exe toolkit2/fhirtoolkit.lpr --build-mode=win64-release -q -q --build-all +IF EXIST "C:\Users\graha\Health Intersections Dropbox\Health Intersections Team Folder\fhirserver\win64" ( + copy exec\64\*.exe "C:\Users\graha\Health Intersections Dropbox\Health Intersections Team Folder\fhirserver\win64" +} + +IF EXIST exec\64\fhirserver.exe ( + echo Sucess! +) ELSE ( + echo Failed (no server executable found) +) chdir /d %FSDIR% diff --git a/build/windows-libraries.bat b/build/windows-libraries.bat index 6b8cd3c74..19257d204 100644 --- a/build/windows-libraries.bat +++ b/build/windows-libraries.bat @@ -67,17 +67,17 @@ cd .. Rem -- now build -tools\lazarus\lazbuild.exe source\tzdb\dist\tzdb_fpc.lpk -q -q -tools\lazarus\lazbuild.exe source\extrasyn\extrahighlighters.lpk -q -q -tools\lazarus\lazbuild.exe source\extrasyn\extrahighlighters_dsgn.lpk -q -q -tools\lazarus\lazbuild.exe source\ZXing.Delphi\Lazarus\Package\zxing.lpk -q -q -tools\lazarus\lazbuild.exe source\lazarus-ide-tester\package\idetester.lpk -q -q -tools\lazarus\lazbuild.exe source\lazarus-ide-tester\ide\idetester_dsgn.lpk -q -q -tools\lazarus\lazbuild.exe source\HtmlViewer\package\FrameViewer09.lpk -q -q -tools\lazarus\lazbuild.exe source\delphi-markdown\packages\markdownengine.lpk -q -q -tools\lazarus\lazbuild.exe source\delphi-markdown\tests\markdowntests.lpk -q -q -tools\lazarus\lazbuild.exe source\PdfiumLib\Package\Pdfium.lpk -q -q -tools\lazarus\lazbuild.exe source\DelphiAST\Package\pascalast.lpk -q -q +tools\lazarus\lazbuild.exe source\tzdb\dist\tzdb_fpc.lpk -q -q --build-all +tools\lazarus\lazbuild.exe source\extrasyn\extrahighlighters.lpk -q -q --build-all +tools\lazarus\lazbuild.exe source\extrasyn\extrahighlighters_dsgn.lpk -q -q --build-all +tools\lazarus\lazbuild.exe source\ZXing.Delphi\Lazarus\Package\zxing.lpk -q -q --build-all +tools\lazarus\lazbuild.exe source\lazarus-ide-tester\package\idetester.lpk -q -q --build-all +tools\lazarus\lazbuild.exe source\lazarus-ide-tester\ide\idetester_dsgn.lpk -q -q --build-all +tools\lazarus\lazbuild.exe source\HtmlViewer\package\FrameViewer09.lpk -q -q --build-all +tools\lazarus\lazbuild.exe source\delphi-markdown\packages\markdownengine.lpk -q -q --build-all +tools\lazarus\lazbuild.exe source\delphi-markdown\tests\markdowntests.lpk -q -q --build-all +tools\lazarus\lazbuild.exe source\PdfiumLib\Package\Pdfium.lpk -q -q --build-all +tools\lazarus\lazbuild.exe source\DelphiAST\Package\pascalast.lpk -q -q --build-all chdir /d %FSDIR% &rem restore current directory diff --git a/build/windows-toolchain.bat b/build/windows-toolchain.bat index eac5e2cc0..790c350a9 100644 --- a/build/windows-toolchain.bat +++ b/build/windows-toolchain.bat @@ -25,13 +25,11 @@ curl -L https://github.com/LongDirtyAnimAlf/fpcupdeluxe/releases/download/wincro powershell -command "Expand-Archive -Force tools\CrossLibsLinuxx64.zip tools" powershell -command "Expand-Archive -Force tools\WinCrossBinsLinuxx64.zip tools" -pause - rem -- run the installer- will finish with a full install of Lazarus tools\fpclazup --fpcVersion="stable.gitlab" --lazVersion="stable.gitlab" --installdir=tools --noconfirm --include=anchordocking,lazprojectgroups,virtualtreeview,fpdebug rem tools\fpclazup --installdir=tools --noconfirm --include=anchordocking,lazprojectgroups,virtualtreeview,fpdebug -tools\fpclazup --ostarget="linux" --cputarget="x86_64" --only="FPCCleanOnly,FPCBuildOnly" --installdir=tools. --noconfirm +tools\fpclazup --ostarget="linux" --cputarget="x86_64" --only="FPCCleanOnly,FPCBuildOnly" --installdir=tools --noconfirm Rem ---- back to the fhirserver directory ---------- diff --git a/dependencies/zflate/zflate.pas b/dependencies/zflate/zflate.pas new file mode 100644 index 000000000..845cb5ed3 --- /dev/null +++ b/dependencies/zflate/zflate.pas @@ -0,0 +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*16; //16 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 978366d3e..6b8d41614 100644 --- a/exec/pack/Messages.properties +++ b/exec/pack/Messages.properties @@ -77,7 +77,7 @@ Profile_VAL_MissingElement = Missing element ''{0}'' - required by fixed value a Profile_VAL_NotAllowed = The element {0} is present in the instance but not allowed in the applicable {1} specified in profile Measure_MR_M_None = No Measure is identified, so no validation can be performed against the Measure Measure_MR_M_NotFound = The Measure ''{0}'' could not be resolved, so no validation can be performed against the Measure -Questionnaire_QR_Item_BadOption = The code provided {1} in the system {0}) is not in the options value set ({2}) in the questionnaire: {3} +Questionnaire_QR_Item_BadOption = The code ''{1}'' in the system ''{0}'' is not in the options value set ({2}) specified by the questionnaire. Terminology Error: {3} QUESTIONNAIRE_QR_ITEM_BADOPTION_CS = The code provided {1} cannot be validated in the options value set ({2}) in the questionnaire because the system {0} could not be found Questionnaire_QR_Item_Coding = Error {0} validating Coding against Questionnaire Options Questionnaire_QR_Item_CodingNoOptions = Cannot validate Coding option because no option list is provided @@ -140,7 +140,7 @@ Resource_RES_ID_Malformed_Length = Invalid Resource id: Too long ({0} chars) Resource_RES_ID_Malformed_Chars = Invalid Resource id: Invalid Characters (''{0}'') Resource_RES_ID_Missing = Resource requires an id, but none is present Resource_RES_ID_Prohibited = Resource has an id, but none is allowed -Terminology_PassThrough_TX_Message = {0} for ''{1}#{2}'' +Terminology_PassThrough_TX_Message = {0} (for ''{1}#{2}'') Terminology_TX_Binding_CantCheck = Binding by URI reference cannot be checked Terminology_TX_Binding_Missing = Binding for CodeableConcept {0} missing Terminology_TX_Binding_Missing2 = Binding for Coding {0} missing @@ -159,8 +159,8 @@ Terminology_TX_Confirm_2_CC = Could not confirm that the codings provided are in Terminology_TX_Confirm_3_CC = Could not confirm that the codings provided are in the value set {0} and a coding is recommended to come from this value set (class = {1}) Terminology_TX_Confirm_4a = The code provided ({2}) was not found in the value set {0}, and a code from this value set is required: {1} Terminology_TX_Confirm_4b = The codes provided ({2}) are not in the value set {0}, and a code from this value set is required: {1} -Terminology_TX_Confirm_5 = Could not confirm that the codes provided are in the value set {0}, and a code should come from this value set unless it has no suitable code (the validator cannot judge what is suitable) -Terminology_TX_Confirm_6 = Could not confirm that the codes provided are in the value set {0}, and a code is recommended to come from this value set +Terminology_TX_Confirm_5 = The code provided ({1}) is not in the value set in the value set {0}, and a code should come from this value set unless it has no suitable code (the validator cannot judge what is suitable) +Terminology_TX_Confirm_6 = The code provided ({1}) is not in the value set in the value set {0}, and a code is recommended to come from this value set Terminology_TX_Display_Wrong = Display should be ''{0}'' Terminology_TX_Error_CodeableConcept = Error {0} validating CodeableConcept Terminology_TX_Error_CodeableConcept_Max = Error {0} validating CodeableConcept using maxValueSet @@ -186,7 +186,7 @@ Terminology_TX_NoValid_7 = None of the codes provided could be validated against Terminology_TX_NoValid_8 = None of the codes provided are in the maximum value set {0}, and a code from this value set is required) (codes = {1}) Terminology_TX_NoValid_9 = The code provided ({2}) could not be validated against the maximum value set {0}, (error = {1}) Terminology_TX_System_Invalid = Invalid System URI: {0} -Terminology_TX_System_NotKnown = Code System URI ''{0}'' could not be found so the code cannot be validated +Terminology_TX_System_NotKnown = A definition for CodeSystem ''{0}'' could not be found, so the code cannot be validated TERMINOLOGY_TX_SYSTEM_NOT_USABLE = The definition for the Code System with URI ''{0}'' doesn't provide any codes so the code cannot be validated Terminology_TX_System_Relative = Coding.system must be an absolute reference, not a local reference Terminology_TX_System_Unknown = Unknown Code System ''{0}'' @@ -222,6 +222,7 @@ Type_Specific_Checks_DT_Primitive_NotEmpty = value cannot be empty Type_Specific_Checks_DT_Primitive_Regex = Element value ''{0}'' does not meet regex ''{1}'' TYPE_SPECIFIC_CHECKS_DT_PRIMITIVE_REGEX_EXCEPTION = Exception evaluating regex ''{0}'' on type {1}: {2} Type_Specific_Checks_DT_Primitive_Regex_Type = Element value ''{0}'' does not meet {1} regex ''{2}'' +TYPE_SPECIFIC_CHECKS_DT_PRIMITIVE_REGEX_TYPE_ALT = Neither the element value ''{0}'' or the formatted value ''{1}'' meet {2} regex ''{3}'' Type_Specific_Checks_DT_Primitive_ValueExt = Primitive types must have a value or must have child extensions Type_Specific_Checks_DT_Primitive_WS = Primitive types should not only be whitespace Type_Specific_Checks_DT_String_Length = value is longer than permitted maximum length of 1 MB (1048576 bytes) @@ -243,6 +244,7 @@ Validation_VAL_Profile_Maximum_one = {3}: max allowed = {7}, but found {0} (from Validation_VAL_Profile_Maximum_other = {3}: max allowed = {7}, but found {0} (from {1}) Validation_VAL_Profile_Minimum_one = {3}: minimum required = {7}, but only found {0} (from {1}) Validation_VAL_Profile_Minimum_other = {3}: minimum required = {7}, but only found {0} (from {1}) +VALIDATION_VAL_PROFILE_MINIMUM_MAGIC = {0}: magic LOINC code {1} required, but not found (from {2}). Note that other Observation codes are allowed in addition to this required magic code Validation_VAL_Profile_NoCheckMax_one = {3}: Found {0} match, but unable to check max allowed ({2}) due to lack of slicing validation (from {1}) Validation_VAL_Profile_NoCheckMax_other = {3}: Found {0} matches, but unable to check max allowed ({2}) due to lack of slicing validation (from {1}) Validation_VAL_Profile_NoCheckMin_one = {3}: Found {0} match, but unable to check minimum required ({2}) due to lack of slicing validation (from {1}) @@ -473,12 +475,13 @@ Display_Name_for__should_be_one_of__instead_of_one = Wrong Display Name ''{4}'' Display_Name_for__should_be_one_of__instead_of_other = Wrong Display Name ''{4}'' for {1}#{2} - should be one of {0} choices: {3} (for the language(s) ''{5}'') Display_Name_WS_for__should_be_one_of__instead_of_one = Wrong whitespace in Display Name ''{4}'' for {1}#{2} - should be {3} (for the language(s) ''{5}'') Display_Name_WS_for__should_be_one_of__instead_of_other = Wrong whitespace in Display Name ''{4}'' for {1}#{2} - should be one of {0} choices: {3} (for the language(s) ''{5}'') -Unknown_Code__in_ = Unknown Code ''{0}'' in the system ''{1}'' -UNKNOWN_CODE__IN_FRAGMENT = Unknown Code ''{0}'' in the system ''{1}'' - note that the code system is labeled as a fragment, so the code may be valid in some other fragment +Unknown_Code_in = Unknown code ''{0}'' in the CodeSystem ''{1}'' +Unknown_Code_in_Version = Unknown code ''{0}'' in the CodeSystem ''{1}'' version ''{2}'' +UNKNOWN_CODE_IN_FRAGMENT = Unknown Code ''{0}'' in the system ''{1}'' version ''{2}'' - note that the code system is labeled as a fragment, so the code may be valid in some other fragment Code_found_in_expansion_however_ = Code found in expansion, however: {0} None_of_the_provided_codes_are_in_the_value_set_one = The provided code {2} was not found in the value set ''{1}'' None_of_the_provided_codes_are_in_the_value_set_other = None of the provided codes [{2}] are in the value set ''{1}'' -Coding_has_no_system__cannot_validate = Coding has no system - cannot validate +Coding_has_no_system__cannot_validate = Coding has no system. A code with no system has no defined meaning, and it cannot be validated. A system should be provided Unable_to_handle_system__concept_filter_with_op__ = Unable to handle system {0} concept filter with op = {1} UNABLE_TO_HANDLE_SYSTEM__PROPERTY_FILTER_WITH_OP__ = Unable to handle system {0} property filter with op = {1} Unable_to_handle_system__filter_with_property__ = Unable to handle system {0} filter with property = {1}, op = {2} @@ -491,6 +494,7 @@ Unable_to_resolve_system__value_set_has_multiple_matches = Unable to resolve sys Unable_to_resolve_system__value_set_expansion_has_multiple_systems = Unable to resolve system - value set expansion has multiple systems Unable_to_resolve_system__value_set_has_no_includes_or_expansion = Unable to resolve system - value set {0} has no includes or expansion Unable_to_resolve_system__no_value_set = Unable to resolve system - no value set +Unable_to_resolve_system__value_set_has_no_matches = Unable to determine system - value set has no matches for code ''{0}'' This_base_property_must_be_an_Array_not_ = This base property must be an Array, not {0} documentmsg = (document) xml_attr_value_invalid = The XML Attribute {0} has an invalid character @@ -568,6 +572,7 @@ SEARCHPARAMETER_NOTFOUND = Unable to find the base Search Parameter {0} so can'' SEARCHPARAMETER_BASE_WRONG = The resource type {1} is not listed as a base in the SearchParameter this is derived from ({0}) SEARCHPARAMETER_TYPE_WRONG = The type {1} is different to the type {0} in the derivedFrom SearchParameter SEARCHPARAMETER_EXP_WRONG = The expression ''{2}'' is not compatible with the expression ''{1}'' in the derivedFrom SearchParameter {0}, and this likely indicates that the derivation relationship is not valid +SEARCHPARAMETER_MISSING_COMPONENTS = When the SearchParameter has a type of 'composite', then the SearchParameter must define two or more components VALUESET_NO_SYSTEM_WARNING = No System specified, so Concepts and Filters can't be checked VALUESET_INCLUDE_INVALID_CONCEPT_CODE = The code ''{1}'' is not valid in the system {0} VALUESET_INCLUDE_INVALID_CONCEPT_CODE_VER = The code ''{2}'' is not valid in the system {0} version {1} @@ -679,7 +684,7 @@ RENDER_BUNDLE_DOCUMENT_CONTENT = Additional Document Content RENDER_BUNDLE_HEADER_DOC_ENTRY_URD = {0}. {1} ({2}/{3}) RENDER_BUNDLE_HEADER_DOC_ENTRY_U = {0}. {1} RENDER_BUNDLE_HEADER_DOC_ENTRY_RD = {0}. {2}/{3} -UNABLE_TO_CHECK_IF_THE_PROVIDED_CODES_ARE_IN_THE_VALUE_SET_ = Unable to check whether the code is in the value set {0} +UNABLE_TO_CHECK_IF_THE_PROVIDED_CODES_ARE_IN_THE_VALUE_SET_ = Unable to check whether the code is in the value set {0} because the code system {1} was not found TERMINOLOGY_TX_SYSTEM_WRONG_HTML = The code system reference {0} is wrong - the code system reference cannot be to an HTML page. This may be the correct reference: {1} TERMINOLOGY_TX_SYSTEM_WRONG_BUILD = The code system reference {0} is wrong - the code system reference cannot be a reference to build.fhir.org. This may be the correct reference: {1} FHIRPATH_BAD_DATE = Unable to parse Date {0} @@ -690,7 +695,7 @@ FHIRPATH_CONTINUOUS_ONLY= Error evaluating FHIRPath expression: The function {0} FHIRPATH_FOCUS_one = FHIRPATH_FOCUS_other = Error evaluating FHIRPath expression: focus for {0} can only have one value, but has {0} values REFERENCE_REF_SUSPICIOUS = The syntax of the reference ''{0}'' looks incorrect, and it should be checked -XHTML_XHTML_ELEMENT_ILLEGAL_IN_PARA = Invalid element name inside in a paragraph in the XHTML (''{0}'') +XHTML_XHTML_ELEMENT_ILLEGAL_IN_PARA = Invalid element name inside a paragraph in the XHTML (''{0}'') UNSUPPORTED_IDENTIFIER_PATTERN_PROPERTY_NOT_SUPPORTED_FOR_DISCRIMINATOR_FOR_SLICE = Unsupported property {3} on type {2} for pattern for discriminator ({0}) for slice {1} UNSUPPORTED_IDENTIFIER_PATTERN_NO_PROPERTY_NOT_SUPPORTED_FOR_DISCRIMINATOR_FOR_SLICE = Unsupported: no properties with values found on type {2} for pattern for discriminator ({0}) for slice {1} SD_NESTED_MUST_SUPPORT_DIFF = The element {0} has types/profiles/targets that are marked as must support, but the element itself is not marked as must-support. The inner must-supports will be ignored unless the element inherits must-support = true @@ -922,8 +927,8 @@ SM_DEPENDENT_PARAM_TYPE_MISMATCH_DUPLICATE = The group {0} has already been used CONCEPTMAP_GROUP_SOURCE_INCOMPLETE = Source Code System {0} doesn''t have all content (content = {1}), so the source codes cannot be checked CONCEPTMAP_GROUP_TARGET_INCOMPLETE = Target Code System {0} doesn''t have all content (content = {1}), so the target codes cannot be checked SD_NO_TYPE_CODE_ON_CODE = Snapshot for {1} element {0} has type.code without a value -UNKNOWN_CODESYSTEM = The code system {0} could not be found -UNKNOWN_CODESYSTEM_VERSION = The code system {0} version {1} could not be found. Valid versions: {2} +UNKNOWN_CODESYSTEM = A definition for CodeSystem ''{0}'' could not be found, so the code cannot be validated +UNKNOWN_CODESYSTEM_VERSION = A definition for CodeSystem ''{0}'' version ''{1}'' could not be found, so the code cannot be validated. Valid versions: {2} UNABLE_TO_INFER_CODESYSTEM = The System URI could not be determined for the code {0} in the ValueSet {1} VALUESET_TOO_COSTLY = The value set {0} has too many codes to display ({1}) VALUESET_TOO_COSTLY_TIME = The value set {0} took too long to process (>{1}sec) @@ -932,6 +937,7 @@ NO_VALID_DISPLAY_FOUND_other = No valid Display Names found for {1}#{2} in the l SD_NO_CONTEXT_WHEN_NOT_EXTENSION = The type is {0} so an extension context should not be specified SD_NO_CONTEXT_INV_WHEN_NOT_EXTENSION = The type is {0} so an extension context invariants should not be specified SD_CONTEXT_SHOULD_NOT_BE_ELEMENT = Review the extension type for {1}: extensions should not have a context of {0} unless it''s really intended that they can be used anywhere +SD_CONTEXT_SHOULD_NOT_BE_FHIRPATH = Review the extension type for {1}: the context of {0} appears to be a simple element, so the context type should be 'element' not 'fhirpath' ED_PATH_WRONG_TYPE_MATCH = The path must be ''{0}'' not ''{1}'' when the type list is not constrained ATTEMPT_TO_CHANGE_SLICING = The element at {0} defines the slicing {1} but then an element in the slicing {2} tries to redefine the slicing to {3} REPEAT_SLICING_IGNORED = The element at {0} defines the slicing but then an element in the slicing {2} repeats it, which is ignored @@ -1012,16 +1018,16 @@ FHIRPATH_AS_IMPOSSIBLE = The type specified in as() is {1} which is not a possib ED_SEARCH_EXPRESSION_ERROR = Error in search expression ''{0}'': {1} SD_EXTENSION_URL_MISMATCH = The fixed value for the extension URL is {1} which doesn''t match the canonical URL {0} SD_EXTENSION_URL_MISSING = The value of Extension.url is not fixed to the extension URL {0} -MSG_DEPRECATED = Reference to deprecated item {0} -MSG_WITHDRAWN = Reference to withdrawn item {0} -MSG_RETIRED = Reference to retired item {0} -MSG_EXPERIMENTAL = Reference to experimental item {0} -MSG_DRAFT = Reference to draft item {0} -MSG_DEPRECATED_SRC = Reference to deprecated item {0} from {1} -MSG_WITHDRAWN_SRC = Reference to withdrawn item {0} from {1} -MSG_RETIRED_SRC = Reference to retired item {0} from {1} -MSG_EXPERIMENTAL_SRC = Reference to experimental item {0} from {1} -MSG_DRAFT_SRC = Reference to draft item {0} from {1} +MSG_DEPRECATED = Reference to deprecated {2} {0} +MSG_WITHDRAWN = Reference to withdrawn {2} {0} +MSG_RETIRED = Reference to retired {2} {0} +MSG_EXPERIMENTAL = Reference to experimental {2} {0} +MSG_DRAFT = Reference to draft {2} {0} +MSG_DEPRECATED_SRC = Reference to deprecated {2} {0} from {1} +MSG_WITHDRAWN_SRC = Reference to withdrawn {2} {0} from {1} +MSG_RETIRED_SRC = Reference to retired {2} {0} from {1} +MSG_EXPERIMENTAL_SRC = Reference to experimental {2} {0} from {1} +MSG_DRAFT_SRC = Reference to draft {2} {0} from {1} STATUS_CODE_WARNING = The code is valid but is {0} STATUS_CODE_HINT = The code is {0} STATUS_CODE_WARNING_CODE = The code ''{1}'' is valid but is {0} @@ -1056,6 +1062,7 @@ BUNDLE_BUNDLE_ENTRY_MULTIPLE_PROFILES_NO_MATCH_REASON = The {1} resource did no VALIDATION_HL7_WG_NEEDED = When HL7 is publishing a resource, the owning committee must be stated using the {0} extension VALIDATION_HL7_WG_UNKNOWN = The nominated WG ''{0}'' is unknown VALIDATION_HL7_PUBLISHER_MISMATCH = The nominated WG ''{0}'' means that the publisher should be ''{1}'' but ''{2}'' was found +VALIDATION_HL7_PUBLISHER_MISMATCH2 = The nominated WG ''{0}'' means that the publisher should be either ''{1}''or ''{2}'' but ''{3}'' was found VALIDATION_HL7_WG_URL = The nominated WG ''{0}'' means that the contact url should be ''{1}'' but it was not found VALIDATION_HL7_PUBLISHER_MISSING = When HL7 is publishing a resource, the publisher must be provided, and for WG ''{0}'' it should be ''{1}'' TYPE_SPECIFIC_CHECKS_DT_QTY_UCUM_ANNOTATIONS_NO_UNIT = UCUM Codes that contain human readable annotations like {0} can be misleading (e.g. they are ignored when comparing units). Best Practice is not to depend on annotations in the UCUM code, so this usage should be checked, and the Quantity.unit SHOULD contain the annotation @@ -1075,7 +1082,7 @@ CDA_UNKNOWN_TEMPLATE = The CDA Template {0} is not known CDA_UNKNOWN_TEMPLATE_EXT = The CDA Template {0} / {1} is not known UNABLE_TO_DETERMINE_TYPE_CONTEXT_INV = The types could not be determined from the extension context, so the invariant can't be validated (types = {0}) ED_CONTEXT_INVARIANT_EXPRESSION_ERROR = Error in constraint ''{0}'': {1} -VALIDATION_VAL_PROFILE_SIGNPOST_OBS = Validate Observation against {1} profile because the {2} code {3} was found +VALIDATION_VAL_PROFILE_SIGNPOST_OBS = Validate Observation against the {1} profile ({0}) which is required by the FHIR specification because the {2} code {3} was found FHIRPATH_INVALID_TYPE = The type {0} is not valid FHIRPATH_AS_COLLECTION = Attempt to use ''as()'' on more than one item (''{0}'', ''{1}'') FHIRPATH_ARITHMETIC_QTY = Error in date arithmetic: attempt to add a definite quantity duration time unit {0} @@ -1087,3 +1094,8 @@ BUNDLE_ENTRY_URL_MATCHES_TYPE_ID = The fullUrl ''{0}'' looks like a RESTful serv BUNDLE_ENTRY_URL_ABSOLUTE = The fullUrl must be an absolute URL (not ''{0}'') FHIRPATH_COLLECTION_STATUS_PARAMETER = Parameter {1} is inherently a collection, and so the expression ''{0}'' may fail, create an error, or return false if there is more than one item in the parameter value ({2}) FHIRPATH_COLLECTION_STATUS_CONTEXT = The context is inherently a collection, and so the expression ''{0}'' may fail, create an error, or return false if there is more than one item in the context ({2}) +BUNDLE_BUNDLE_ENTRY_NOTFOUND_FRAGMENT = Can''t find ''{0}'' in the bundle ({1}) +BUNDLE_BUNDLE_ENTRY_FOUND_MULTIPLE_FRAGMENT = Found {0} matches for fragment {2} in resource ''{1}'' in the bundle ({3}) +XHTML_IDREF_NOT_FOUND = The target of the HTML idref attribute ''{0}'' was not found in the resource +XHTML_IDREF_NOT_MULTIPLE_MATCHES = Multiple matching targets for the HTML idref attribute ''{0}'' were found in the resource +TX_GENERAL_CC_ERROR_MESSAGE = No valid coding was found for the value set ''{0}'' \ No newline at end of file diff --git a/exec/pack/Messages_de.properties b/exec/pack/Messages_de.properties index b3d975922..8e07ca70b 100644 --- a/exec/pack/Messages_de.properties +++ b/exec/pack/Messages_de.properties @@ -419,7 +419,8 @@ Error_parsing_=Fehler beim Parsen {0}:{1} Unable_to_connect_to_terminology_server_Use_parameter_tx_na_tun_run_without_using_terminology_services_to_validate_LOINC_SNOMED_ICDX_etc_Error__=Keine Verbindung zum Terminologieserver m\u00f6glich. Verwenden Sie den Parameter ''-tx n/a'' um ohne Verwendung von Terminologiediensten zu laufen welche LOINC, SNOMED, ICD-X usw. zu validieren. Fehler = {0} Display_Name_for__should_be_one_of__instead_of_one=Der Displayname f\u00fcr {1}#{2} sollte einer von ''{3}'' anstelle von ''{4}'' sein. Display_Name_for__should_be_one_of__instead_of_other=Der Displayname f\u00fcr {1}#{2} sollte einer von ''{3}'' anstelle von ''{4}'' sein. -Unknown_Code__in_=Unbekannter Code {0} in {1} +Unknown_Code_in=Unbekannter Code {0} in {1} +Unknown_Code_in_Version=Unbekannter Code {0} in {1} Version {2} Code_found_in_expansion_however_=Code in der Erweiterung gefunden, jedoch: {0} None_of_the_provided_codes_are_in_the_value_set_=Keiner der bereitgestellten Codes ist im ValueSet {0} Coding_has_no_system__cannot_validate=Kodierung hat kein System - kann nicht validiert werden diff --git a/exec/pack/Messages_es.properties b/exec/pack/Messages_es.properties index b5f32cff0..0468a4e2f 100644 --- a/exec/pack/Messages_es.properties +++ b/exec/pack/Messages_es.properties @@ -469,8 +469,9 @@ Unable_to_connect_to_terminology_server_Use_parameter_tx_na_tun_run_without_usin Display_Name_for__should_be_one_of__instead_of_one = El nombre de display para {1}#{2} debe ser ''{3}'', no ''{4}'' Display_Name_for__should_be_one_of__instead_of_many = El nombre de display para {1}#{2} debe ser uno de estas opciones {0} de ''{3}'', no ''{4}'' Display_Name_for__should_be_one_of__instead_of_other = El nombre de display para {1}#{2} debe ser uno de estas opciones {0} de ''{3}'', no ''{4}'' -Unknown_Code__in_ = Código desconocido {0} en {1} -UNKNOWN_CODE__IN_FRAGMENT = Código desconocido {0} en {1} - note que el sistema de codificación está etiquetado como fragmento, así que el código puede ser válido mas allá del fragmento +Unknown_Code_in = Código desconocido {0} en {1} +Unknown_Code_in_Version = Código desconocido {0} en {1} versión {2} +UNKNOWN_CODE_IN_FRAGMENT = Código desconocido {0} en {1} - note que el sistema de codificación está etiquetado como fragmento, así que el código puede ser válido mas allá del fragmento Code_found_in_expansion_however_ = El código se encontró en la expansión, sin embargo: {0} None_of_the_provided_codes_are_in_the_value_set_one = None_of_the_provided_codes_are_in_the_value_set_many = Ninguno de los códigos provistos está en el conjunto de valores {0} diff --git a/exec/pack/Messages_ja.properties b/exec/pack/Messages_ja.properties index 3dc20f546..d728c5483 100644 --- a/exec/pack/Messages_ja.properties +++ b/exec/pack/Messages_ja.properties @@ -464,8 +464,9 @@ Error_parsing_ = {0} の解析エラー: {1} Unable_to_connect_to_terminology_server_Use_parameter_tx_na_tun_run_without_using_terminology_services_to_validate_LOINC_SNOMED_ICDX_etc_Error__ = 用語サーバー ({1}) に接続できません。LOINC、SNOMED、ICD-Xなどを検証するための用語サービスを使用せずに実行するには、パラメータ ''-tx n/a'' を使用してください。エラー = {0} Display_Name_for__should_be_one_of__instead_of_one = {1}#{2} の誤ったdisplay ''{4}'' - {3} であるべきです (言語 ''{5}'' のため) Display_Name_for__should_be_one_of__instead_of_other = {1}#{2} の誤ったdisplay ''{4}'' - {0} の選択肢のうちの一つであるべきです: {3} (言語 ''{5}'' のため) -Unknown_Code__in_ = system''{1}''で未知のコード''{0}'' -UNKNOWN_CODE__IN_FRAGMENT = system''{1}''で未知のコード''{0}'' - CodeSystemは断片としてラベル付けされているため、そのコードは他の断片では有効である可能性があります +Unknown_Code_in = system''{1}''で未知のコード''{0}'' +Unknown_Code_in_Version = system''{1}''で未知のコード''{0}'' +UNKNOWN_CODE_IN_FRAGMENT = system''{1}''で未知のコード''{0}'' - CodeSystemは断片としてラベル付けされているため、そのコードは他の断片では有効である可能性があります Code_found_in_expansion_however_ = 拡張中にコードが見つかりました。しかしながら: {0} None_of_the_provided_codes_are_in_the_value_set_one = 提供されたcode {2} は、ValueSet ''{1}''にありません None_of_the_provided_codes_are_in_the_value_set_other = 提供されたcode [{2}] のうちどれも、ValueSet ''{1}''に含まれていません diff --git a/exec/pack/Messages_nl.properties b/exec/pack/Messages_nl.properties index ea1faaa65..ec0c21b30 100644 --- a/exec/pack/Messages_nl.properties +++ b/exec/pack/Messages_nl.properties @@ -464,8 +464,9 @@ Error_parsing_ = Fout bij verwerken {0}:{1} Unable_to_connect_to_terminology_server_Use_parameter_tx_na_tun_run_without_using_terminology_services_to_validate_LOINC_SNOMED_ICDX_etc_Error__ = Kan niet verbinden met terminologieserver. Gebruik parameter ''-tx n/a'' om te starten zonder terminologieservices voor validatie van LOINC, SNOMED, ICD-X etc. Fout = {0} Display_Name_for__should_be_one_of__instead_of_one = Verkeerde weergavenaam ''{4}'' voor {1}#{2} - moet zijn ''{3}'' (voor taal/talen ''{5}'') Display_Name_for__should_be_one_of__instead_of_other = Verkeerde weergavenaam ''{4}'' voor {1}#{2} - moet een zijn van {0} keuzes: ''{3}'' voor de taal/talen ''{5}'' -Unknown_Code__in_ = Onbekende code {0} in {1} -UNKNOWN_CODE__IN_FRAGMENT = Onbekende code {0} in {1} - merk op dat het codesysteem is gemarkeerd als fragment, waardoor mogelijk geldig is in een ander fragment +Unknown_Code_in = Onbekende code {0} in {1} +Unknown_Code_in_Version = Onbekende code {0} in {1} versie {2} +UNKNOWN_CODE_IN_FRAGMENT = Onbekende code {0} in {1} - merk op dat het codesysteem is gemarkeerd als fragment, waardoor mogelijk geldig is in een ander fragment Code_found_in_expansion_however_ = Code gevonden in expansion, echter: {0} None_of_the_provided_codes_are_in_the_value_set_one = De opgegeven code {2} staat niet in de waardelijst ''{1}'' None_of_the_provided_codes_are_in_the_value_set_other = Geen van de opgegeven codes {2} staan niet in de waardelijst ''{1}'' diff --git a/ipsmanager/ipsmanager.lpr b/ipsmanager/ipsmanager.lpr index 53450f9d4..1ea0e4c41 100644 --- a/ipsmanager/ipsmanager.lpr +++ b/ipsmanager/ipsmanager.lpr @@ -30,4 +30,3 @@ Application.CreateForm(TIPSManagerForm, IPSManagerForm); Application.Run; end. - diff --git a/ipsmanager/views/mvbase.pas b/ipsmanager/views/mvbase.pas index e86270101..ac99535a2 100644 --- a/ipsmanager/views/mvbase.pas +++ b/ipsmanager/views/mvbase.pas @@ -1,4 +1,4 @@ -unit mvBase; +unit mvbase; {$i fhir.inc} @@ -53,4 +53,3 @@ procedure TViewManager.initialize; end; end. - diff --git a/ipsmanager/views/mvdatasources.pas b/ipsmanager/views/mvdatasources.pas index 7abc90df5..13b1bd332 100644 --- a/ipsmanager/views/mvdatasources.pas +++ b/ipsmanager/views/mvdatasources.pas @@ -1,4 +1,4 @@ -unit mvDataSources; +unit mvdatasources; {$i fhir.inc} @@ -7,7 +7,7 @@ interface uses Classes, SysUtils, mvBase; - + type { TDataSourceViewManager } @@ -27,4 +27,3 @@ procedure TDataSourceViewManager.initialize; end; end. - diff --git a/library/dicom/dicom_parser.pas b/library/dicom/dicom_parser.pas index 43af0001a..514e37e90 100644 --- a/library/dicom/dicom_parser.pas +++ b/library/dicom/dicom_parser.pas @@ -32,7 +32,7 @@ Uses SysUtils, - fsl_base, fsl_utilities, fsl_stream, fsl_fpc, + fsl_base, fsl_utilities, fsl_stream, fsl_fpc, fsl_gzip, dicom_dictionary, dicom_objects, dicom_writer; @@ -1569,7 +1569,7 @@ function TDicomInstanceDecoder.Execute: TDicomInstance; SetLength(sComp, oInput.Size); oInput.Position := 0; oInput.Read(sComp[1], oInput.Size); - sDecomp := ZcompressBytes(sComp); + sDecomp := ungzip(sComp); oInput.Position := 0; oPDU := TDicomPDUDecoder.Create(oInput.Size); diff --git a/library/fdb/fdb_fts.pas b/library/fdb/fdb_fts.pas index ea5f7d062..0b2b2f3cf 100644 --- a/library/fdb/fdb_fts.pas +++ b/library/fdb/fdb_fts.pas @@ -161,5 +161,4 @@ function TFDBFullTextSearch.link: TFDBFullTextSearch; result := TFDBFullTextSearch(inherited link); end; -end. - +end. \ No newline at end of file diff --git a/library/fdb/fdb_odbc.pas b/library/fdb/fdb_odbc.pas index ec525718f..5556219ba 100644 --- a/library/fdb/fdb_odbc.pas +++ b/library/fdb/fdb_odbc.pas @@ -989,7 +989,7 @@ function StandardODBCDriverName(APlatform: TFDBPlatform): String; kdbInterbase: Result := 'Intersolv Interbase ODBC Driver (*.gdb)'; // not that we would actually ever use this kdbDB2: Result := 'IBM DB2 ODBC DRIVER'; kdbOracle8: Result := 'Oracle ODBC Driver'; - kdbMySQL : result := 'MySQL ODBC 8.0 Unicode Driver'; + kdbMySQL : result := 'MySQL ODBC 8.2 Unicode Driver'; else Result := 'Unknown Platform ' + inttostr(ord(APlatform)); end; diff --git a/library/fhir/fhir_common.pas b/library/fhir/fhir_common.pas index 7c490087c..456febfc2 100644 --- a/library/fhir/fhir_common.pas +++ b/library/fhir/fhir_common.pas @@ -61,11 +61,13 @@ interface TObservationStatus = (obssNull, obssRegistered, obssPreliminary, obssFinal, obssAmended, obssCorrected, obssCancelled, obssEnteredInError, obssUnknown); TTokenCategory = (tcClinical, tcData, tcMeds, tcSchedule, tcAudit, tcDocuments, tcFinancial, tcMedicationDefinition, tcOther); TIdentifierUse = (iuNull, iuUsual, iuOfficial, iuTemp, iuSecondary, iuOld); + TOpIssueCode = (oicVoid, oicNotInVS, oicThisNotInVS, oicInvalidCode, oicDisplay, oicNotFound, oicCodeRule, oicVSProcessing, oicInferFailed, oicStatusCheck, oicInvalidData); const CODES_TFhirFilterOperator: Array[TFilterOperator] of String = ('', '=', 'is-a', 'descendent-of', 'is-not-a', 'regex', 'in', 'not-in', 'generalizes', 'exists', 'child-of', 'descendent-leaf'); CODES_TPublicationStatus: Array[TPublicationStatus] of String = ('', 'draft', 'active', 'retired'); CODES_TTokenCategory : array [TTokenCategory] of String = ('Clinical', 'Data', 'Meds', 'Schedule', 'Audit', 'Documents', 'Financial', 'MedicationDefinitions', 'Other'); + CODES_TOpIssueCode : array [TOpIssueCode] of String = ('', 'not-in-vs', 'this-code-not-in-vs', 'invalid-code', 'invalid-display', 'not-found', 'code-rule', 'vs-invalid', 'cannot-infer', 'status-check', 'invalid-data'); type @@ -383,7 +385,7 @@ TFhirOperationOutcomeW = class (TFHIRXVersionResourceWrapper) function code : TFhirIssueType; virtual; abstract; procedure addIssue(issue : TFhirOperationOutcomeIssueW; free : boolean); overload; virtual; abstract; - procedure addIssue(level : TIssueSeverity; cause : TFhirIssueType; path, message : String; addIfDuplicate : boolean = false); overload; virtual; abstract; + procedure addIssue(level : TIssueSeverity; cause : TFhirIssueType; path, message : String; issueCode : TOpIssueCode; addIfDuplicate : boolean = false); overload; virtual; abstract; function hasIssues : boolean; virtual; abstract; function issues : TFslList; virtual; abstract; function rule(level : TIssueSeverity; source : String; typeCode : TFhirIssueType; path : string; test : boolean; msg : string) : boolean; virtual; abstract; @@ -889,7 +891,12 @@ TFhirValueSetExpansionW = class (TFHIRXVersionElementWrapper) function getTotal : integer; virtual; abstract; procedure setTotal(value : integer) ; virtual; abstract; + function getOffset : integer; virtual; abstract; + procedure setOffset(value : integer) ; virtual; abstract; + property total : integer read getTotal write setTotal; + property offset : integer read getOffset write setOffset; + procedure defineProperty(focus : TFhirValueSetExpansionContainsW; url, code : String; value : TFHIRObject {link if needed}); virtual; abstract; end; diff --git a/library/fhir/fhir_factory.pas b/library/fhir/fhir_factory.pas index 4e64e66cc..c73407fb0 100644 --- a/library/fhir/fhir_factory.pas +++ b/library/fhir/fhir_factory.pas @@ -404,6 +404,90 @@ TFHIRFactoryX = class (TFHIRFactory) implementation +type + + { TFhirSystemCoding } + + TFhirSystemCoding = class (TFHIRCodingW) + private + function tuple : TFHIRSystemTuple; + protected + function getCode: String; override; + function getDisplay: String; override; + function getSystem: String; override; + function getVersion: String; override; + procedure setCode(Value: String); override; + procedure setDisplay(Value: String); override; + procedure setSystem(Value: String); override; + procedure setVersion(Value: String); override; + public + destructor Destroy; override; + end; + +{ TFhirSystemCoding } + +function TFhirSystemCoding.tuple: TFHIRSystemTuple; +begin + result := Element as TFhirSystemTuple; +end; + +function TFhirSystemCoding.getCode: String; +begin + if tuple.Fields['code'] = nil then + result := '' + else + result := (tuple.Fields['code'] as TFHIRObject).ToString; +end; + +function TFhirSystemCoding.getDisplay: String; +begin + if tuple.Fields['display'] = nil then + result := '' + else + result := (tuple.Fields['display'] as TFHIRObject).ToString; +end; + +function TFhirSystemCoding.getSystem: String; +begin + if tuple.Fields['system'] = nil then + result := '' + else + result := (tuple.Fields['system'] as TFHIRObject).ToString; +end; + +function TFhirSystemCoding.getVersion: String; +begin + if tuple.Fields['version'] = nil then + result := '' + else + result := (tuple.Fields['version'] as TFHIRObject).ToString; +end; + +procedure TFhirSystemCoding.setCode(Value: String); +begin + raise EFSLException.create('TFhirSystemCoding.setCode is Not supported'); +end; + +procedure TFhirSystemCoding.setDisplay(Value: String); +begin + raise EFSLException.create('TFhirSystemCoding.setDisplay is Not supported'); +end; + +procedure TFhirSystemCoding.setSystem(Value: String); +begin + raise EFSLException.create('TFhirSystemCoding.setSystem is Not supported'); +end; + +procedure TFhirSystemCoding.setVersion(Value: String); +begin + raise EFSLException.create('TFhirSystemCoding.setVersion is Not supported'); +end; + +destructor TFhirSystemCoding.Destroy; +begin + inherited Destroy; +end; + { TFHIRFactoryX } function TFHIRFactoryX.versionName: String; @@ -597,8 +681,31 @@ function TFHIRFactoryX.makeCodeableConcept(coding: TFHIRCodingW): TFHIRObject; end; function TFHIRFactoryX.makeCoding(systemUri, version, code, display: String): TFHIRObject; +var + t : TFHIRSystemTuple; begin - raise EFslException.Create('makeCoding is not implemented in the non-versioned FHIRFactory'); + t := TFHIRSystemTuple.create; + try + if (systemUri <> '') then + t.Fields.add('system', TFHIRSystemString.Create(systemUri)) + else + t.Fields.add('system', nil); + if (version <> '') then + t.Fields.add('version', TFHIRSystemString.Create(version)) + else + t.Fields.add('version', nil); + if (code <> '') then + t.Fields.add('code', TFHIRSystemString.Create(code)) + else + t.Fields.add('code', nil); + if (display <> '') then + t.Fields.add('display', TFHIRSystemString.Create(display)) + else + t.Fields.add('display', nil); + result := t.link; + finally + t.free; + end; end; function TFHIRFactoryX.makeString(s: string): TFHIRObject; @@ -721,7 +828,10 @@ function TFHIRFactoryX.wrapExtension(o: TFHIRObject): TFhirExtensionW; function TFHIRFactoryX.wrapCoding(o: TFHIRObject): TFhirCodingW; begin - raise EFslException.Create('wrapCoding is not implemented in the non-versioned FHIRFactory'); + if o = nil then + result := nil + else + result := TFhirSystemCoding.create(o); end; function TFHIRFactoryX.wrapCodeableConcept(o: TFHIRObject): TFhirCodeableConceptW; diff --git a/library/fhir/fhir_healthcard.pas b/library/fhir/fhir_healthcard.pas index a237de067..d906ff7a7 100644 --- a/library/fhir/fhir_healthcard.pas +++ b/library/fhir/fhir_healthcard.pas @@ -35,7 +35,7 @@ interface uses SysUtils, Classes, DateUtils, Graphics, {$IFDEF FPC} FPImage, FPWritePNG, {$ELSE} Vcl.Imaging.pngimage, {$ENDIF} IdGlobal, IdHash, IdHashSHA, - fsl_base, fsl_utilities, fsl_http, fsl_crypto, fsl_json, fsl_fetcher, fsl_openssl, + fsl_base, fsl_utilities, fsl_http, fsl_crypto, fsl_json, fsl_fetcher, fsl_openssl, fsl_gzip, fhir_objects, fhir_factory, fhir_parser, fhir_utilities; type @@ -231,7 +231,7 @@ procedure THealthcareCardUtilities.sign(card: THealthcareCard; jwk : TJWK); finally j.free; end; - bytes := DeflateRfc1951(TEncoding.UTF8.GetBytes(payload)); + bytes := gzip(TEncoding.UTF8.GetBytes(payload), false); card.jws := TJWTUtils.encodeJWT('{"alg":"ES256","zip":"DEF","kid":"'+jwk.id+'"}', bytes, jwt_es256, jwk); end; diff --git a/library/fhir/fhir_objects.pas b/library/fhir/fhir_objects.pas index 5462aa868..0c8d9ef54 100644 --- a/library/fhir/fhir_objects.pas +++ b/library/fhir/fhir_objects.pas @@ -758,6 +758,7 @@ TFHIRSystemString = class (TFHIRObject) function ToString : String; override; end; + TFHIRSystemTuple = class (TFHIRObject) private FFields : TFslMap; diff --git a/library/fhir/tests/fhir_tests_icao.pas b/library/fhir/tests/fhir_tests_icao.pas index ead711056..6b90d74e9 100644 --- a/library/fhir/tests/fhir_tests_icao.pas +++ b/library/fhir/tests/fhir_tests_icao.pas @@ -44,11 +44,11 @@ interface TFHIRICAOTests = Class (TFslTestCase) public - published {$IFDEF WINDOWS} // this is labelled as windows only in order to prevent the ci-build failing because the certificate - a real one - isn't in git (todo: sort this out) Procedure TestIcaoCertAu; {$ENDIF} + published Procedure TestIcaoCertAuBroken; Procedure TestIcaoCertNoStore; end; diff --git a/library/fhir2/fhir2_common.pas b/library/fhir2/fhir2_common.pas index 0851b47ff..30f9e4e42 100644 --- a/library/fhir2/fhir2_common.pas +++ b/library/fhir2/fhir2_common.pas @@ -178,7 +178,7 @@ TFhirOperationOutcome2 = class (TFhirOperationOutcomeW) function text : String; override; function code : TFhirIssueType; override; procedure addIssue(issue : TFhirOperationOutcomeIssueW; owns : boolean); override; - procedure addIssue(level : TIssueSeverity; cause : TFHIRIssueType; path, message : String; addIfDuplicate : boolean); override; + procedure addIssue(level : TIssueSeverity; cause : TFHIRIssueType; path, message : String; code : TOpIssueCode; addIfDuplicate : boolean); override; function hasIssues : boolean; override; function issues : TFslList; override; function rule(level : TIssueSeverity; source : String; typeCode : TFhirIssueType; path : string; test : boolean; msg : string) : boolean; override; @@ -496,6 +496,8 @@ TFhirValueSetExpansion2 = class (TFhirValueSetExpansionW) function contains : TFslList; override; function getTotal : integer; override; procedure setTotal(value : integer) ; override; + function getOffset : integer; override; + procedure setOffset(value : integer) ; override; procedure defineProperty(focus : TFhirValueSetExpansionContainsW; url, code : String; value : TFHIRObject); override; end; @@ -1250,7 +1252,7 @@ procedure TFhirOperationOutcome2.addIssue(issue: TFhirOperationOutcomeIssueW; ow issue.free; end; -procedure TFhirOperationOutcome2.addIssue(level: TIssueSeverity; cause: TFHIRIssueType; path, message: String; addIfDuplicate : boolean); +procedure TFhirOperationOutcome2.addIssue(level: TIssueSeverity; cause: TFHIRIssueType; path, message : String; code : TOpIssueCode; addIfDuplicate : boolean); var iss : TFhirOperationOutcomeIssue; begin @@ -1265,6 +1267,8 @@ procedure TFhirOperationOutcome2.addIssue(level: TIssueSeverity; cause: TFHIRIss iss.code:= ExceptionTypeTranslations[cause]; iss.severity := ISSUE_SEVERITY_MAP2[level]; iss.details := TFHIRCodeableConcept.Create; + if (code <> oicVoid) then + iss.details.addCoding('http://hl7.org/fhir/tools/CodeSystem/tx-issue-type', '', CODES_TOpIssueCode[code], ''); iss.details.text := message; iss.locationList.Add(path); end; @@ -3955,6 +3959,16 @@ procedure TFhirValueSetExpansion2.setTotal(value: integer); exp.total := inttostr(value); end; +function TFhirValueSetExpansion2.getOffset: integer; +begin + result := StrToIntDef(exp.offset, 0); +end; + +procedure TFhirValueSetExpansion2.setOffset(value: integer); +begin + exp.offset := inttostr(value); +end; + procedure TFhirValueSetExpansion2.defineProperty(focus: TFhirValueSetExpansionContainsW; url, code: String; value: TFHIRObject); begin // nothing diff --git a/library/fhir3/fhir3_common.pas b/library/fhir3/fhir3_common.pas index 5f9cb8d7a..32ff37765 100644 --- a/library/fhir3/fhir3_common.pas +++ b/library/fhir3/fhir3_common.pas @@ -178,7 +178,7 @@ TFhirOperationOutcome3 = class (TFhirOperationOutcomeW) function text : String; override; function code : TFhirIssueType; override; procedure addIssue(issue : TFhirOperationOutcomeIssueW; free : boolean); override; - procedure addIssue(level : TIssueSeverity; cause : TFHIRIssueType; path, message : String; addIfDuplicate : boolean); override; + procedure addIssue(level : TIssueSeverity; cause : TFHIRIssueType; path, message : String; code : TOpIssueCode; addIfDuplicate : boolean); override; function hasIssues : boolean; override; function issues : TFslList; override; function rule(level : TIssueSeverity; source : String; typeCode : TFhirIssueType; path : string; test : boolean; msg : string) : boolean; override; @@ -558,6 +558,8 @@ TFhirValueSetExpansion3 = class (TFhirValueSetExpansionW) function makeContains : TFhirValueSetExpansionContainsW; override; function contains : TFslList; override; function getTotal : integer; override; + function getOffset : integer; override; + procedure setOffset(value : integer) ; override; procedure setTotal(value : integer) ; override; procedure defineProperty(focus : TFhirValueSetExpansionContainsW; url, code : String; value : TFHIRObject); override; end; @@ -1392,7 +1394,7 @@ procedure TFhirOperationOutcome3.addIssue(issue: TFhirOperationOutcomeIssueW; fr issue.free; end; -procedure TFhirOperationOutcome3.addIssue(level: TIssueSeverity; cause: TFHIRIssueType; path, message: String; addIfDuplicate : boolean); +procedure TFhirOperationOutcome3.addIssue(level: TIssueSeverity; cause: TFHIRIssueType; path, message : String; code : TOpIssueCode; addIfDuplicate : boolean); var iss : TFhirOperationOutcomeIssue; begin @@ -1406,9 +1408,12 @@ procedure TFhirOperationOutcome3.addIssue(level: TIssueSeverity; cause: TFHIRIss iss := (Fres as TFhirOperationOutcome).issueList.Append; iss.code:= ExceptionTypeTranslations[cause]; iss.severity := ISSUE_SEVERITY_MAP2[level]; - iss.details := TFHIRCodeableConcept.Create; + iss.details := TFHIRCodeableConcept.Create; + if (code <> oicVoid) then + iss.details.addCoding('http://hl7.org/fhir/tools/CodeSystem/tx-issue-type', '', CODES_TOpIssueCode[code], ''); iss.details.text := message; iss.locationList.Add(path); + iss.expressionList.Add(path); end; function TFhirOperationOutcome3.code: TFhirIssueType; @@ -4485,6 +4490,16 @@ procedure TFhirValueSetExpansion3.setTotal(value: integer); exp.total := inttostr(value); end; +function TFhirValueSetExpansion3.getOffset: integer; +begin + result := StrToIntDef(exp.offset, 0); +end; + +procedure TFhirValueSetExpansion3.setOffset(value: integer); +begin + exp.offset := inttostr(value); +end; + procedure TFhirValueSetExpansion3.defineProperty(focus: TFhirValueSetExpansionContainsW; url, code: String; value: TFHIRObject); var pd, ext : TFhirExtension; diff --git a/library/fhir4/fhir4_common.pas b/library/fhir4/fhir4_common.pas index 694472b71..714e42d28 100644 --- a/library/fhir4/fhir4_common.pas +++ b/library/fhir4/fhir4_common.pas @@ -176,7 +176,7 @@ TFhirOperationOutcome4 = class (TFhirOperationOutcomeW) function text : String; override; function code : TFhirIssueType; override; procedure addIssue(issue : TFhirOperationOutcomeIssueW; free : boolean); override; - procedure addIssue(level : TIssueSeverity; cause : TFHIRIssueType; path, message : String; addIfDuplicate : boolean); override; + procedure addIssue(level : TIssueSeverity; cause : TFHIRIssueType; path, message : String; code : TOpIssueCode; addIfDuplicate : boolean); override; function hasIssues : boolean; override; function issues : TFslList; override; function rule(level : TIssueSeverity; source : String; typeCode : TFhirIssueType; path : string; test : boolean; msg : string) : boolean; override; @@ -504,6 +504,8 @@ TFhirValueSetExpansion4 = class (TFhirValueSetExpansionW) function contains : TFslList; override; function getTotal : integer; override; procedure setTotal(value : integer) ; override; + function getOffset : integer; override; + procedure setOffset(value : integer) ; override; procedure defineProperty(focus : TFhirValueSetExpansionContainsW; url, code : String; value : TFHIRObject); override; end; @@ -1364,7 +1366,7 @@ procedure TFhirOperationOutcome4.addIssue(issue: TFhirOperationOutcomeIssueW; fr issue.free; end; -procedure TFhirOperationOutcome4.addIssue(level: TIssueSeverity; cause: TFHIRIssueType; path, message: String; addIfDuplicate : boolean); +procedure TFhirOperationOutcome4.addIssue(level: TIssueSeverity; cause: TFHIRIssueType; path, message : String; code : TOpIssueCode; addIfDuplicate : boolean); var iss : TFhirOperationOutcomeIssue; begin @@ -1384,8 +1386,11 @@ procedure TFhirOperationOutcome4.addIssue(level: TIssueSeverity; cause: TFHIRIss iss.code:= ExceptionTypeTranslations[cause]; iss.severity := ISSUE_SEVERITY_MAP2[level]; iss.details := TFHIRCodeableConcept.Create; + if (code <> oicVoid) then + iss.details.addCoding('http://hl7.org/fhir/tools/CodeSystem/tx-issue-type', '', CODES_TOpIssueCode[code], ''); iss.details.text := message; iss.locationList.Add(path); + iss.expressionList.Add(path); end; function TFhirOperationOutcome4.code: TFhirIssueType; @@ -4174,6 +4179,16 @@ procedure TFhirValueSetExpansion4.setTotal(value: integer); exp.total := inttostr(value); end; +function TFhirValueSetExpansion4.getOffset: integer; +begin + result := StrToIntDef(exp.offset, 0); +end; + +procedure TFhirValueSetExpansion4.setOffset(value: integer); +begin + exp.offset := inttostr(value); +end; + procedure TFhirValueSetExpansion4.defineProperty(focus: TFhirValueSetExpansionContainsW; url, code: String; value: TFHIRObject); var pd, ext : TFhirExtension; diff --git a/library/fhir4/fhir4_ips.pas b/library/fhir4/fhir4_ips.pas index b0285778b..f2d4637da 100644 --- a/library/fhir4/fhir4_ips.pas +++ b/library/fhir4/fhir4_ips.pas @@ -1137,8 +1137,4 @@ function TIPSWrapper.saveToBytes: TBytes; end; // decode(result); end; - - end. - - diff --git a/library/fhir4/fhir4_pathengine.pas b/library/fhir4/fhir4_pathengine.pas index 1569f4c3e..1df622154 100644 --- a/library/fhir4/fhir4_pathengine.pas +++ b/library/fhir4/fhir4_pathengine.pas @@ -282,6 +282,7 @@ TFHIRPathEngine = class (TFHIRPathEngineV) function funcLowBoundary(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function funcHighBoundary(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function funcPrecision(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; + function funcComparable(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function qtyToCanonical(q : TFHIRQuantity) : TUcumPair; function pairToQty(p: TUcumPair): TFHIRQuantity; @@ -696,6 +697,7 @@ procedure TFHIRPathParser.checkParameters(lexer: TFHIRPathLexer; location : TSou pfLowBoundary: checkParamCount(lexer, location, exp, 0, 1); pfHighBoundary: checkParamCount(lexer, location, exp, 0, 1); pfPrecision: checkParamCount(lexer, location, exp, 0); + pfComparable : checkParamCount(lexer, location, exp, 1); pfEncode, pfDecode, pfEscape, pfUnescape : checkParamCount(lexer, location, exp, 1); pfCustom: ; // nothing end; @@ -2183,19 +2185,28 @@ function TFHIRPathEngine.funcIif(context: TFHIRPathExecutionContext; focus: TFHI var n1 : TFHIRSelectionList; v : TEqualityTriState; + cn : TFHIRPathExecutionContext; begin - n1 := execute(context, focus, exp.Parameters[0], true); + if (focus.Empty) then + cn := context.Link + else + cn := context.changeThis(focus[0].value, 0); try - v := asBool(n1); + n1 := execute(cn, focus, exp.Parameters[0], true); + try + v := asBool(n1); - if (v = equalTrue) then - result := execute(context, focus, exp.parameters[1], true) - else if (exp.parameters.count < 3) then - result := TFHIRSelectionList.Create - else - result := execute(context, focus, exp.parameters[2], true); + if (v = equalTrue) then + result := execute(context, focus, exp.parameters[1], true) + else if (exp.parameters.count < 3) then + result := TFHIRSelectionList.Create + else + result := execute(context, focus, exp.parameters[2], true); + finally + n1.free; + end; finally - n1.free; + cn.free; end; end; @@ -2342,15 +2353,17 @@ function TFHIRPathEngine.funcJoin(context: TFHIRPathExecutionContext; focus: TFH param : String; b : TFslStringBuilder; o : TFHIRSelection; + first : boolean; begin nl := execute(context, focus, exp.Parameters[0], true); try b := TFslStringBuilder.Create; try param := nl[0].value.primitiveValue; + first := true; for o in focus do begin - b.seperator(param); + if (first) then first := false else b.Append(param); b.append(o.value.primitiveValue); end; result := TFHIRSelectionList.Create(TFhirString.Create(b.ToString)); @@ -3535,17 +3548,24 @@ function TFHIRPathEngine.funcCombine(context : TFHIRPathExecutionContext; focus: var item : TFHIRSelection; res : TFHIRSelectionList; + fl : TFHIRSelectionList; begin result := TFHIRSelectionList.Create; try for item in focus do result.add(item.link); - res := execute(context, focus, exp.Parameters[0], true); + fl := TFHIRSelectionList.create; try - for item in res do - result.add(item.link); + fl.add(context.this.link); + res := execute(context, fl, exp.Parameters[0], true); + try + for item in res do + result.add(item.link); + finally + res.free; + end; finally - res.free; + fl.free; end; result.Link; finally @@ -3629,6 +3649,7 @@ function TFHIRPathEngine.funcSplit(context: TFHIRPathExecutionContext; focus: TF var nl : TFHIRSelectionList; param, s : String; + p : TStringArray; begin nl := execute(context, focus, exp.Parameters[0], true); try @@ -3636,8 +3657,11 @@ function TFHIRPathEngine.funcSplit(context: TFHIRPathExecutionContext; focus: TF result := TFHIRSelectionList.Create(); try if focus.Count = 1 then - for s in focus[0].value.primitiveValue.Split([param]) do + begin + p := focus[0].value.primitiveValue.Split([param]); + for s in p do result.add(TFhirString.Create(s)); + end; result.Link; finally result.free; @@ -3802,6 +3826,55 @@ function TFHIRPathEngine.funcHighBoundary(context : TFHIRPathExecutionContext; f end; end; +function TFHIRPathEngine.funcComparable(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; +var + n1 : TFHIRSelectionList; + s1, u1, s2, u2 : String; +begin + result := TFHIRSelectionList.Create; + try + if (focus.Count <> 1) or (focus[0].value.fhirType <> 'Quantity') then + result.add(TFHIRBoolean.Create(false)) + else + begin + n1 := execute(context, focus, exp.Parameters[0], true); + try + if (n1.Count <> 1) or (n1[0].value.fhirType <> 'Quantity') then + result.add(TFHIRBoolean.Create(false)) + else + begin + s1 := focus[0].value.getPrimitiveValue('system'); + u1 := focus[0].value.getPrimitiveValue('code'); + s2 := n1[0].value.getPrimitiveValue('system'); + u2 := n1[0].value.getPrimitiveValue('code'); + + if (s1 = '') or (s2 = '') or (s1 <> s2) then + result.add(TFHIRBoolean.Create(false)) + else if (u1 = '') or (u2 = '') then + result.add(TFHIRBoolean.Create(false)) + else if (u1 = u2) then + result.add(TFHIRBoolean.Create(true)) + else if (s1 = 'http://unitsofmeasure.org') and (FUcum <> nil) then + begin + try + result.add(TFHIRBoolean.Create(FUcum.isComparable(u1, u2))); + except + result.add(TFHIRBoolean.Create(false)); + end; + end + else + result.add(TFHIRBoolean.Create(false)) + end; + finally + n1.free; + end; + end; + result.Link; + finally + result.free; + end; +end; + function TFHIRPathEngine.funcPrecision(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; var base : TFhirObject; @@ -6091,6 +6164,7 @@ function TFHIRPathEngine.evaluateFunction(context : TFHIRPathExecutionContext; f pfLowBoundary : result := funcLowBoundary(context, focus, exp); pfHighBoundary : result := funcHighBoundary(context, focus, exp); pfPrecision : result := funcPrecision(context, focus, exp); + pfComparable : result := funcComparable(context, focus, exp); pfCustom : result := funcCustom(context, focus, exp); else raise EFHIRPath.Create('Unknown Function '+exp.name); @@ -6745,6 +6819,8 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on decima;, date, datetime, instant, time and Quantity, not '+focus.describe); result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Integer]); end; + pfComparable : + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Boolean]); pfCustom : result := evaluateCustomFunctionType(context, focus, exp); else diff --git a/library/fhir4/fhir4_pathnode.pas b/library/fhir4/fhir4_pathnode.pas index 8613c3c52..ffb83aa88 100644 --- a/library/fhir4/fhir4_pathnode.pas +++ b/library/fhir4/fhir4_pathnode.pas @@ -56,7 +56,7 @@ interface pfToBoolean, pfToInteger, pfToString, pfToDecimal, pfToQuantity, pfToDateTime, pfToTime, pfAbs, pfCeiling, pfExp, pfFloor, pfLn, pfLog, pfPower, pfTruncate, pfRound, pfSqrt, pfForHtml, pfEncode, pfDecode, pfEscape, pfUnescape, pfTrim, pfSplit, pfJoin, pfIndexOf, - pfLowBoundary, pfHighBoundary, pfPrecision, + pfLowBoundary, pfHighBoundary, pfPrecision, pfComparable, pfCustom); TFHIRPathExpressionNodeKind = (enkName, enkFunction, enkConstant, enkGroup, enkStructure, enkUnary); // structure is not used in fhir4_pathengine, but is in CQL @@ -78,7 +78,7 @@ interface 'toBoolean', 'toInteger', 'toString', 'toDecimal', 'toQuantity', 'toDateTime', 'toTime', 'abs', 'ceiling', 'exp', 'floor', 'ln', 'log', 'power', 'truncate', 'round', 'sqrt', 'forHtml', 'encode', 'decode', 'escape', 'unescape', 'trim', 'split', 'join', 'indexOf', - 'lowBoundary', 'highBoundary', 'precision', + 'lowBoundary', 'highBoundary', 'precision', 'comparable', 'xx-custom-xx'); FHIR_SD_NS = 'http://hl7.org/fhir/StructureDefinition/'; diff --git a/library/fhir4b/fhir4b_common.pas b/library/fhir4b/fhir4b_common.pas index 06cd71908..0112d9471 100644 --- a/library/fhir4b/fhir4b_common.pas +++ b/library/fhir4b/fhir4b_common.pas @@ -177,7 +177,7 @@ TFhirOperationOutcome4B = class (TFhirOperationOutcomeW) function text : String; override; function code : TFhirIssueType; override; procedure addIssue(issue : TFhirOperationOutcomeIssueW; free : boolean); override; - procedure addIssue(level : TIssueSeverity; cause : TFHIRIssueType; path, message : String; addIfDuplicate : boolean); override; + procedure addIssue(level : TIssueSeverity; cause : TFHIRIssueType; path, message : String; code : TOpIssueCode; addIfDuplicate : boolean); override; function hasIssues : boolean; override; function issues : TFslList; override; function rule(level : TIssueSeverity; source : String; typeCode : TFhirIssueType; path : string; test : boolean; msg : string) : boolean; override; @@ -505,6 +505,8 @@ TFhirValueSetExpansion4B = class (TFhirValueSetExpansionW) function contains : TFslList; override; function getTotal : integer; override; procedure setTotal(value : integer) ; override; + function getOffset : integer; override; + procedure setOffset(value : integer) ; override; procedure defineProperty(focus : TFhirValueSetExpansionContainsW; url, code : String; value : TFHIRObject); override; end; @@ -1363,7 +1365,7 @@ procedure TFhirOperationOutcome4B.addIssue(issue: TFhirOperationOutcomeIssueW; f issue.free; end; -procedure TFhirOperationOutcome4B.addIssue(level: TIssueSeverity; cause: TFHIRIssueType; path, message: String; addIfDuplicate : boolean); +procedure TFhirOperationOutcome4B.addIssue(level: TIssueSeverity; cause: TFHIRIssueType; path, message : String; code : TOpIssueCode; addIfDuplicate : boolean); var iss : TFhirOperationOutcomeIssue; begin @@ -1377,9 +1379,12 @@ procedure TFhirOperationOutcome4B.addIssue(level: TIssueSeverity; cause: TFHIRIs iss := (Fres as TFhirOperationOutcome).issueList.Append; iss.code:= ExceptionTypeTranslations[cause]; iss.severity := ISSUE_SEVERITY_MAP2[level]; - iss.details := TFHIRCodeableConcept.Create; + iss.details := TFHIRCodeableConcept.Create; + if (code <> oicVoid) then + iss.details.addCoding('http://hl7.org/fhir/tools/CodeSystem/tx-issue-type', '', CODES_TOpIssueCode[code], ''); iss.details.text := message; iss.locationList.Add(path); + iss.expressionList.Add(path); end; function TFhirOperationOutcome4B.code: TFhirIssueType; @@ -4152,6 +4157,16 @@ procedure TFhirValueSetExpansion4B.setTotal(value: integer); exp.total := inttostr(value); end; +function TFhirValueSetExpansion4B.getOffset: integer; +begin + result := StrToIntDef(exp.offset, 0); +end; + +procedure TFhirValueSetExpansion4B.setOffset(value: integer); +begin + exp.offset := inttostr(value); +end; + procedure TFhirValueSetExpansion4B.defineProperty(focus: TFhirValueSetExpansionContainsW; url, code: String; value: TFHIRObject); var pd, ext : TFhirExtension; diff --git a/library/fhir4b/fhir4b_pathengine.pas b/library/fhir4b/fhir4b_pathengine.pas index f54921e1b..405ceffa3 100644 --- a/library/fhir4b/fhir4b_pathengine.pas +++ b/library/fhir4b/fhir4b_pathengine.pas @@ -280,6 +280,7 @@ TFHIRPathEngine = class (TFHIRPathEngineV) function funcLowBoundary(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function funcHighBoundary(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function funcPrecision(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; + function funcComparable(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function qtyToCanonical(q : TFHIRQuantity) : TUcumPair; function pairToQty(p: TUcumPair): TFHIRQuantity; @@ -604,7 +605,7 @@ procedure TFHIRPathParser.checkParameters(lexer: TFHIRPathLexer; location : TSou case exp.FunctionId of pfEmpty: checkParamCount(lexer, location, exp, 0); pfNot: checkParamCount(lexer, location, exp, 0); - pfExists: checkParamCount(lexer, location, exp, 0, 1); // 1 is allowed in cql, and should be allowed in fhir4b_pathengine as well + pfExists: checkParamCount(lexer, location, exp, 0, 1); // 1 is allowed in cql, and should be allowed in fhir4_pathengine as well pfSubsetOf: checkParamCount(lexer, location, exp, 1); pfSupersetOf: checkParamCount(lexer, location, exp, 1); pfIsDistinct: checkParamCount(lexer, location, exp, 0); @@ -694,6 +695,7 @@ procedure TFHIRPathParser.checkParameters(lexer: TFHIRPathLexer; location : TSou pfLowBoundary: checkParamCount(lexer, location, exp, 0, 1); pfHighBoundary: checkParamCount(lexer, location, exp, 0, 1); pfPrecision: checkParamCount(lexer, location, exp, 0); + pfComparable : checkParamCount(lexer, location, exp, 1); pfEncode, pfDecode, pfEscape, pfUnescape : checkParamCount(lexer, location, exp, 1); pfCustom: ; // nothing end; @@ -2181,19 +2183,28 @@ function TFHIRPathEngine.funcIif(context: TFHIRPathExecutionContext; focus: TFHI var n1 : TFHIRSelectionList; v : TEqualityTriState; + cn : TFHIRPathExecutionContext; begin - n1 := execute(context, focus, exp.Parameters[0], true); + if (focus.Empty) then + cn := context.Link + else + cn := context.changeThis(focus[0].value, 0); try - v := asBool(n1); + n1 := execute(cn, focus, exp.Parameters[0], true); + try + v := asBool(n1); - if (v = equalTrue) then - result := execute(context, focus, exp.parameters[1], true) - else if (exp.parameters.count < 3) then - result := TFHIRSelectionList.Create - else - result := execute(context, focus, exp.parameters[2], true); + if (v = equalTrue) then + result := execute(context, focus, exp.parameters[1], true) + else if (exp.parameters.count < 3) then + result := TFHIRSelectionList.Create + else + result := execute(context, focus, exp.parameters[2], true); + finally + n1.free; + end; finally - n1.free; + cn.free; end; end; @@ -2340,15 +2351,17 @@ function TFHIRPathEngine.funcJoin(context: TFHIRPathExecutionContext; focus: TFH param : String; b : TFslStringBuilder; o : TFHIRSelection; + first : boolean; begin nl := execute(context, focus, exp.Parameters[0], true); try b := TFslStringBuilder.Create; try param := nl[0].value.primitiveValue; + first := true; for o in focus do begin - b.seperator(param); + if (first) then first := false else b.Append(param); b.append(o.value.primitiveValue); end; result := TFHIRSelectionList.Create(TFhirString.Create(b.ToString)); @@ -2559,7 +2572,7 @@ function TFHIRPathEngine.funcMatchesFull(context : TFHIRPathExecutionContext; fo var res : TFHIRSelectionList; s, p : String; - reg : TRegularExpression; + reg : TREgularExpression; begin result := TFHIRSelectionList.Create; try @@ -2574,7 +2587,7 @@ function TFHIRPathEngine.funcMatchesFull(context : TFHIRPathExecutionContext; fo result.add(TFHIRBoolean.Create(false)) else begin - reg := TRegularExpression.Create('(?s)' + p, [roCompiled]); + reg := TREgularExpression.Create('(?s)' + p, [roCompiled]); try s := convertToString(focus[0].value); result.add(TFHIRBoolean.Create(reg.isFullMatch(s))); @@ -3533,17 +3546,24 @@ function TFHIRPathEngine.funcCombine(context : TFHIRPathExecutionContext; focus: var item : TFHIRSelection; res : TFHIRSelectionList; + fl : TFHIRSelectionList; begin result := TFHIRSelectionList.Create; try for item in focus do result.add(item.link); - res := execute(context, focus, exp.Parameters[0], true); + fl := TFHIRSelectionList.create; try - for item in res do - result.add(item.link); + fl.add(context.this.link); + res := execute(context, fl, exp.Parameters[0], true); + try + for item in res do + result.add(item.link); + finally + res.free; + end; finally - res.free; + fl.free; end; result.Link; finally @@ -3627,6 +3647,7 @@ function TFHIRPathEngine.funcSplit(context: TFHIRPathExecutionContext; focus: TF var nl : TFHIRSelectionList; param, s : String; + p : TStringArray; begin nl := execute(context, focus, exp.Parameters[0], true); try @@ -3634,8 +3655,11 @@ function TFHIRPathEngine.funcSplit(context: TFHIRPathExecutionContext; focus: TF result := TFHIRSelectionList.Create(); try if focus.Count = 1 then - for s in focus[0].value.primitiveValue.Split([param]) do + begin + p := focus[0].value.primitiveValue.Split([param]); + for s in p do result.add(TFhirString.Create(s)); + end; result.Link; finally result.free; @@ -3800,6 +3824,55 @@ function TFHIRPathEngine.funcHighBoundary(context : TFHIRPathExecutionContext; f end; end; +function TFHIRPathEngine.funcComparable(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; +var + n1 : TFHIRSelectionList; + s1, u1, s2, u2 : String; +begin + result := TFHIRSelectionList.Create; + try + if (focus.Count <> 1) or (focus[0].value.fhirType <> 'Quantity') then + result.add(TFHIRBoolean.Create(false)) + else + begin + n1 := execute(context, focus, exp.Parameters[0], true); + try + if (n1.Count <> 1) or (n1[0].value.fhirType <> 'Quantity') then + result.add(TFHIRBoolean.Create(false)) + else + begin + s1 := focus[0].value.getPrimitiveValue('system'); + u1 := focus[0].value.getPrimitiveValue('code'); + s2 := n1[0].value.getPrimitiveValue('system'); + u2 := n1[0].value.getPrimitiveValue('code'); + + if (s1 = '') or (s2 = '') or (s1 <> s2) then + result.add(TFHIRBoolean.Create(false)) + else if (u1 = '') or (u2 = '') then + result.add(TFHIRBoolean.Create(false)) + else if (u1 = u2) then + result.add(TFHIRBoolean.Create(true)) + else if (s1 = 'http://unitsofmeasure.org') and (FUcum <> nil) then + begin + try + result.add(TFHIRBoolean.Create(FUcum.isComparable(u1, u2))); + except + result.add(TFHIRBoolean.Create(false)); + end; + end + else + result.add(TFHIRBoolean.Create(false)) + end; + finally + n1.free; + end; + end; + result.Link; + finally + result.free; + end; +end; + function TFHIRPathEngine.funcPrecision(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; var base : TFhirObject; @@ -3831,7 +3904,7 @@ function TFHIRPathEngine.funcCeiling(context: TFHIRPathExecutionContext; focus: var base : TFHIRObject; qty : TFHIRQuantity; - d : TFslDecimal; + v : TFslDecimal; begin if (focus.count <> 1) then raise EFHIRPath.Create('Error evaluating FHIRPath expression: focus for floor has more than one value'); @@ -3845,10 +3918,10 @@ function TFHIRPathEngine.funcCeiling(context: TFHIRPathExecutionContext; focus: begin qty := (base as TFhirQuantity).Clone; try - d := TFslDecimal.Create(qty.value); - d := d.Trunc; - d := d.AddInt(1); - qty.value := d.AsString; + v := TFslDecimal.Create(qty.value); + v := v.trunc; + v := v.addInt(1); + qty.value := v.AsString; result.add(qty.Link); finally qty.free; @@ -6089,6 +6162,7 @@ function TFHIRPathEngine.evaluateFunction(context : TFHIRPathExecutionContext; f pfLowBoundary : result := funcLowBoundary(context, focus, exp); pfHighBoundary : result := funcHighBoundary(context, focus, exp); pfPrecision : result := funcPrecision(context, focus, exp); + pfComparable : result := funcComparable(context, focus, exp); pfCustom : result := funcCustom(context, focus, exp); else raise EFHIRPath.Create('Unknown Function '+exp.name); @@ -6743,6 +6817,8 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on decima;, date, datetime, instant, time and Quantity, not '+focus.describe); result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Integer]); end; + pfComparable : + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Boolean]); pfCustom : result := evaluateCustomFunctionType(context, focus, exp); else diff --git a/library/fhir4b/fhir4b_pathnode.pas b/library/fhir4b/fhir4b_pathnode.pas index 75f34c8f1..868d9a6fb 100644 --- a/library/fhir4b/fhir4b_pathnode.pas +++ b/library/fhir4b/fhir4b_pathnode.pas @@ -56,7 +56,7 @@ interface pfToBoolean, pfToInteger, pfToString, pfToDecimal, pfToQuantity, pfToDateTime, pfToTime, pfAbs, pfCeiling, pfExp, pfFloor, pfLn, pfLog, pfPower, pfTruncate, pfRound, pfSqrt, pfForHtml, pfEncode, pfDecode, pfEscape, pfUnescape, pfTrim, pfSplit, pfJoin, pfIndexOf, - pfLowBoundary, pfHighBoundary, pfPrecision, + pfLowBoundary, pfHighBoundary, pfPrecision, pfComparable, pfCustom); TFHIRPathExpressionNodeKind = (enkName, enkFunction, enkConstant, enkGroup, enkStructure, enkUnary); // structure is not used in fhir4b_pathengine, but is in CQL @@ -78,7 +78,7 @@ interface 'toBoolean', 'toInteger', 'toString', 'toDecimal', 'toQuantity', 'toDateTime', 'toTime', 'abs', 'ceiling', 'exp', 'floor', 'ln', 'log', 'power', 'truncate', 'round', 'sqrt', 'forHtml', 'encode', 'decode', 'escape', 'unescape', 'trim', 'split', 'join', 'indexOf', - 'lowBoundary', 'highBoundary', 'precision', + 'lowBoundary', 'highBoundary', 'precision', 'comparable', 'xx-custom-xx'); FHIR_SD_NS = 'http://hl7.org/fhir/StructureDefinition/'; diff --git a/library/fhir5/fhir5_common.pas b/library/fhir5/fhir5_common.pas index b563321d8..acd663688 100644 --- a/library/fhir5/fhir5_common.pas +++ b/library/fhir5/fhir5_common.pas @@ -175,7 +175,7 @@ TFhirOperationOutcome5 = class (TFhirOperationOutcomeW) function text : String; override; function code : TFhirIssueType; override; procedure addIssue(issue : TFhirOperationOutcomeIssueW; free : boolean); override; - procedure addIssue(level : TIssueSeverity; cause : TFHIRIssueType; path, message : String; addIfDuplicate : boolean); override; + procedure addIssue(level : TIssueSeverity; cause : TFHIRIssueType; path, message : String; code : TOpIssueCode; addIfDuplicate : boolean); override; function hasIssues : boolean; override; function issues : TFslList; override; function rule(level : TIssueSeverity; source : String; typeCode : TFhirIssueType; path : string; test : boolean; msg : string) : boolean; override; @@ -503,6 +503,8 @@ TFhirValueSetExpansion5 = class (TFhirValueSetExpansionW) function contains : TFslList; override; function getTotal : integer; override; procedure setTotal(value : integer) ; override; + function getOffset : integer; override; + procedure setOffset(value : integer) ; override; procedure defineProperty(focus : TFhirValueSetExpansionContainsW; url, code : String; value : TFHIRObject); override; end; @@ -1373,7 +1375,7 @@ procedure TFhirOperationOutcome5.addIssue(issue: TFhirOperationOutcomeIssueW; fr issue.free; end; -procedure TFhirOperationOutcome5.addIssue(level: TIssueSeverity; cause: TFHIRIssueType; path, message: String; addIfDuplicate : boolean); +procedure TFhirOperationOutcome5.addIssue(level: TIssueSeverity; cause: TFHIRIssueType; path, message: String; code : TOpIssueCode; addIfDuplicate : boolean); var iss : TFhirOperationOutcomeIssue; begin @@ -1393,8 +1395,11 @@ procedure TFhirOperationOutcome5.addIssue(level: TIssueSeverity; cause: TFHIRIss iss.code:= ExceptionTypeTranslations[cause]; iss.severity := ISSUE_SEVERITY_MAP2[level]; iss.details := TFHIRCodeableConcept.Create; + if (code <> oicVoid) then + iss.details.addCoding('http://hl7.org/fhir/tools/CodeSystem/tx-issue-type', '', CODES_TOpIssueCode[code], ''); iss.details.text := message; iss.locationList.Add(path); + iss.expressionList.Add(path); end; function TFhirOperationOutcome5.code: TFhirIssueType; @@ -4172,6 +4177,16 @@ procedure TFhirValueSetExpansion5.setTotal(value: integer); exp.total := inttostr(value); end; +function TFhirValueSetExpansion5.getOffset: integer; +begin + result := StrToIntDef(exp.offset, 0); +end; + +procedure TFhirValueSetExpansion5.setOffset(value: integer); +begin + exp.offset := inttostr(value); +end; + procedure TFhirValueSetExpansion5.defineProperty(focus: TFhirValueSetExpansionContainsW; url, code: String; value: TFHIRObject); var pdef, t1 : TFhirValueSetExpansionProperty; diff --git a/library/fhir5/fhir5_pathengine.pas b/library/fhir5/fhir5_pathengine.pas index fa5198d7f..8c31cbc4d 100644 --- a/library/fhir5/fhir5_pathengine.pas +++ b/library/fhir5/fhir5_pathengine.pas @@ -34,8 +34,8 @@ interface uses - SysUtils, Classes, Math, Generics.Collections, Character, - fsl_base, fsl_utilities, fsl_stream, fsl_fpc, fsl_json, fsl_xml, fsl_regex, + SysUtils, Classes, Math, Generics.Collections, Character, + fsl_base, fsl_utilities, fsl_stream, fsl_fpc, fsl_xml, fsl_json, fsl_regex, fsl_ucum, fhir_objects, fhir_factory, fhir_pathengine, fhir_uris, fhir5_pathnode, fhir5_enums, fhir5_types, fhir5_resources, fhir5_utilities, fhir5_context, fhir5_constants; @@ -280,6 +280,7 @@ TFHIRPathEngine = class (TFHIRPathEngineV) function funcLowBoundary(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function funcHighBoundary(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function funcPrecision(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; + function funcComparable(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function qtyToCanonical(q : TFHIRQuantity) : TUcumPair; function pairToQty(p: TUcumPair): TFHIRQuantity; @@ -382,7 +383,7 @@ implementation { TFHIRConstant } -constructor TFHIRConstant.create(value: String); +constructor TFHIRConstant.Create(value: String); begin inherited Create; FValue := value; @@ -390,7 +391,7 @@ constructor TFHIRConstant.create(value: String); function TFHIRConstant.createPropertyValue(propName: string): TFHIRObject; begin - raise EFHIRTodo.create('TFHIRConstant.createPropertyValue'); + raise EFHIRTodo.Create('TFHIRConstant.createPropertyValue'); end; function TFHIRConstant.fhirType: string; @@ -400,12 +401,12 @@ function TFHIRConstant.fhirType: string; function TFHIRConstant.getId: String; begin - raise EFHIRTodo.create('TFHIRConstant.getId:'); + raise EFHIRTodo.Create('TFHIRConstant.getId:'); end; function TFHIRConstant.getTypesForProperty(propName : string): String; begin - raise EFHIRTodo.create('TFHIRConstant.getTypesForProperty'); + raise EFHIRTodo.Create('TFHIRConstant.getTypesForProperty'); end; function TFHIRConstant.hasExtensions: boolean; @@ -430,12 +431,12 @@ function TFHIRConstant.makeStringValue(v: String): TFHIRObject; procedure TFHIRConstant.setIdValue(id: String); begin - raise EFHIRTodo.create('TFHIRConstant.setIdValue'); + raise EFHIRTodo.Create('TFHIRConstant.setIdValue'); end; function TFHIRConstant.setProperty(propName: string; propValue: TFHIRObject) : TFHIRObject; begin - raise EFHIRTodo.create('TFHIRConstant.setProperty'); + raise EFHIRTodo.Create('TFHIRConstant.setProperty'); end; function TFHIRConstant.sizeInBytesV(magic : integer) : cardinal; @@ -446,7 +447,7 @@ function TFHIRConstant.sizeInBytesV(magic : integer) : cardinal; { TFHIRClassTypeInfo } -constructor TFHIRClassTypeInfo.create(instance: TFHIRObject); +constructor TFHIRClassTypeInfo.Create(instance: TFHIRObject); begin inherited Create; FInstance := instance; @@ -454,7 +455,7 @@ constructor TFHIRClassTypeInfo.create(instance: TFHIRObject); function TFHIRClassTypeInfo.createPropertyValue(propName: string): TFHIRObject; begin - raise EFHIRTodo.create('TFHIRClassTypeInfo.createPropertyValue'); + raise EFHIRTodo.Create('TFHIRClassTypeInfo.createPropertyValue'); end; destructor TFHIRClassTypeInfo.Destroy; @@ -471,9 +472,9 @@ function TFHIRClassTypeInfo.fhirType: string; procedure TFHIRClassTypeInfo.GetChildrenByName(name: string; list: TFHIRSelectionList); begin if (name = 'name') then - list.add(TFHIRString.create(getName).noExtensions) + list.add(TFHIRString.Create(getName).noExtensions) else if (name = 'namespace') then - list.add(TFHIRString.create(getNamespace).noExtensions) + list.add(TFHIRString.Create(getNamespace).noExtensions) else inherited GetChildrenByName(name, list); end; @@ -490,7 +491,7 @@ function TFHIRClassTypeInfo.getNamespace: String; function TFHIRClassTypeInfo.getTypesForProperty(propName : string): String; begin - raise EFHIRTodo.create('TFHIRClassTypeInfo.getTypesForProperty'); + raise EFHIRTodo.Create('TFHIRClassTypeInfo.getTypesForProperty'); end; function TFHIRClassTypeInfo.hasExtensions: boolean; @@ -500,7 +501,7 @@ function TFHIRClassTypeInfo.hasExtensions: boolean; function TFHIRClassTypeInfo.getId: String; begin - raise EFHIRTodo.create('TFHIRClassTypeInfo.getId:'); + raise EFHIRTodo.Create('TFHIRClassTypeInfo.getId:'); end; function TFHIRClassTypeInfo.makeCodeValue(v: String): TFHIRObject; @@ -520,12 +521,12 @@ function TFHIRClassTypeInfo.makeStringValue(v: String): TFHIRObject; procedure TFHIRClassTypeInfo.setIdValue(id: String); begin - raise EFHIRTodo.create('TFHIRClassTypeInfo.setIdValue'); + raise EFHIRTodo.Create('TFHIRClassTypeInfo.setIdValue'); end; function TFHIRClassTypeInfo.setProperty(propName: string; propValue: TFHIRObject) : TFHIRObject; begin - raise EFHIRTodo.create('TFHIRClassTypeInfo.setProperty'); + raise EFHIRTodo.Create('TFHIRClassTypeInfo.setProperty'); end; function TFHIRClassTypeInfo.getName: String; @@ -555,7 +556,7 @@ function TFHIRPathParser.parse(lexer: TFHIRPathLexer): TFHIRPathExpressionNode; result := parseExpression(lexer, true); try if not result.check(msg, 0) then - raise EFHIRPath.create('Error "'+msg+'" parsing "'+lexer.Path); + raise EFHIRPath.Create('Error "'+msg+'" parsing "'+lexer.Path); result.Link; finally result.free; @@ -576,7 +577,7 @@ function TFHIRPathParser.parse(path: String): TFHIRPathExpressionNode; if not lexer.done then raise lexer.error('Premature expression termination at unexpected token "'+lexer.current+'"'); if not result.check(msg, 0) then - raise EFHIRPath.create('Error parsing "'+path+'": '+msg); + raise EFHIRPath.Create('Error parsing "'+path+'": '+msg); result.Link; finally @@ -604,7 +605,7 @@ procedure TFHIRPathParser.checkParameters(lexer: TFHIRPathLexer; location : TSou case exp.FunctionId of pfEmpty: checkParamCount(lexer, location, exp, 0); pfNot: checkParamCount(lexer, location, exp, 0); - pfExists: checkParamCount(lexer, location, exp, 0, 1); // 1 is allowed in cql, and should be allowed in fhir5_pathengine as well + pfExists: checkParamCount(lexer, location, exp, 0, 1); // 1 is allowed in cql, and should be allowed in fhir4_pathengine as well pfSubsetOf: checkParamCount(lexer, location, exp, 1); pfSupersetOf: checkParamCount(lexer, location, exp, 1); pfIsDistinct: checkParamCount(lexer, location, exp, 0); @@ -694,6 +695,7 @@ procedure TFHIRPathParser.checkParameters(lexer: TFHIRPathLexer; location : TSou pfLowBoundary: checkParamCount(lexer, location, exp, 0, 1); pfHighBoundary: checkParamCount(lexer, location, exp, 0, 1); pfPrecision: checkParamCount(lexer, location, exp, 0); + pfComparable : checkParamCount(lexer, location, exp, 1); pfEncode, pfDecode, pfEscape, pfUnescape : checkParamCount(lexer, location, exp, 1); pfCustom: ; // nothing end; @@ -718,7 +720,7 @@ function TFHIRPathParser.parse(path: String; var i: integer): TFHIRPathExpressio result := parseExpression(lexer, true); try if not result.check(msg, 0) then - raise EFHIRPath.create('Error parsing "'+path+'": '+msg); + raise EFHIRPath.Create('Error parsing "'+path+'": '+msg); result.Link; finally result.free; @@ -1065,7 +1067,7 @@ function TFHIRPathEngine.check(appInfo : TFslObject; resourceType, context, path end; try - ctxt := TFHIRPathExecutionTypeContext.create(appInfo, resourceType, types.Link, types.Link); + ctxt := TFHIRPathExecutionTypeContext.Create(appInfo, resourceType, types.Link, types.Link); try result := executeType(ctxt, types, expr, true); finally @@ -1114,7 +1116,7 @@ function TFHIRPathEngine.convertToString(item: TFHIRObject): String; end; -constructor TFHIRPathEngine.create(context: TFHIRWorkerContext; ucum : TUcumServiceInterface); +constructor TFHIRPathEngine.Create(context: TFHIRWorkerContext; ucum : TUcumServiceInterface); var sd : TFhirStructureDefinition; list : TFslList; @@ -1140,7 +1142,7 @@ constructor TFHIRPathEngine.create(context: TFHIRWorkerContext; ucum : TUcumServ if (sd.derivation = TypeDerivationRuleSPECIALIZATION) and (sd.kind = StructureDefinitionKindPrimitiveType) then primitiveTypes.add(sd.id); {$ELSE} - raise EFHIRException.create('Debug this'); + raise EFHIRException.Create('Debug this'); if (sd.constrainedType = DefinedTypesNull) then allTypes.add(sd.id); if (sd.constrainedType = DefinedTypesNull) and isPrimitive(sd) then @@ -1170,11 +1172,11 @@ function TFHIRPathEngine.dateAdd(d: TFhirObject; qty: TFhirQuantity; negate: boo if (c = 'years') or (c = 'year') then result.dateValue := d.dateValue.add(v, dtuYear) else if (c = 'a') then - raise EFHIRPath.create(format('Error in date arithmetic: attempt to add a definite quantity duration time unit %s', [c])) + raise EFHIRPath.Create(format('Error in date arithmetic: attempt to add a definite quantity duration time unit %s', [c])) else if (c = 'months') or (c = 'month') then result.dateValue := d.dateValue.add(v, dtuMonth) else if (c = 'mo') then - raise EFHIRPath.create(format('Error in date arithmetic: attempt to add a definite quantity duration time unit %s', [c])) + raise EFHIRPath.Create(format('Error in date arithmetic: attempt to add a definite quantity duration time unit %s', [c])) else if (c = 'weeks') or (c = 'week') or (c = 'wk') then result.dateValue := d.dateValue.add(v * 7, dtuDay) else if (c = 'days') or (c = 'day') or (c = 'd') then @@ -1188,7 +1190,7 @@ function TFHIRPathEngine.dateAdd(d: TFhirObject; qty: TFhirQuantity; negate: boo else if (c = 'millisecond') or (c = 'millisecond') or (c = 'ms') then result.dateValue := d.dateValue.add(v, dtuMillisecond) else - raise EFHIRPath.create(format('Error in date arithmetic: unrecognized time unit %s', [c])); + raise EFHIRPath.Create(format('Error in date arithmetic: unrecognized time unit %s', [c])); result.Link; finally result.free; @@ -1470,7 +1472,7 @@ function TFHIRPathEngine.evaluate(appInfo : TFslObject; resource : TFHIRObject; function TFHIRPathEngine.evaluateCustomFunctionType(context: TFHIRPathExecutionTypeContext; focus: TFHIRTypeDetails; exp: TFHIRPathExpressionNode): TFHIRTypeDetails; begin - raise EFHIRPath.create('Unknown Function '+exp.name); + raise EFHIRPath.Create('Unknown Function '+exp.name); end; function TFHIRPathEngine.executeV(context: TFHIRPathExecutionContext; item: TFHIRObject; exp: TFHIRPathExpressionNodeV; atEntry: boolean): TFHIRSelectionList; @@ -1603,51 +1605,51 @@ procedure TFHIRPathEngine.ListAllChildren(item : TFHIRObject; results : TFHIRSel function TFHIRPathEngine.resolveConstantType(ctxt: TFHIRPathExecutionTypeContext; constant : TFHIRObject) : TFHIRTypeDetails; begin if (constant is TFHIRBoolean) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Boolean]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Boolean]) else if (constant is TFHIRInteger) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Integer]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Integer]) else if (constant is TFHIRDecimal) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Decimal]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Decimal]) else if (constant is TFHIRQuantity) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Quantity]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Quantity]) else if (constant is TFHIRConstant) then result := resolveConstantType(ctxt, (constant as TFHIRConstant).FValue) else - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]); end; function TFHIRPathEngine.resolveConstantType(ctxt: TFHIRPathExecutionTypeContext; s : String) : TFHIRTypeDetails; begin if (s.startsWith('@')) then if (s.startsWith('@T')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Time]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Time]) else - result := TFHIRTypeDetails.create(csSINGLETON, [FP_DateTime]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_DateTime]) else if (s.equals('%sct')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]) else if (s.equals('%loinc')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]) else if (s.equals('%ucum')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]) else if (s.equals('%resource')) then begin if (ctxt.resourceType = '') then - raise EFHIRPath.create('%resource cannot be used in this context'); - result := TFHIRTypeDetails.create(csSINGLETON, [ctxt.resourceType]); + raise EFHIRPath.Create('%resource cannot be used in this context'); + result := TFHIRTypeDetails.Create(csSINGLETON, [ctxt.resourceType]); end else if (s.equals('%context')) then result := ctxt.context.link else if (s.equals('%map-codes')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]) else if (s.equals('%us-zip')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]) else if (s.startsWith('%`vs-')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]) else if (s.startsWith('%`cs-')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]) else if (s.startsWith('%`ext-')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]) else - raise EFHIRPath.create('Unknown fixed constant type for "'+s+'"'); + raise EFHIRPath.Create('Unknown fixed constant type for "'+s+'"'); end; function TFHIRPathEngine.executeType(ctxt: TFHIRPathExecutionTypeContext; focus: TFHIRTypeDetails; exp: TFHIRPathExpressionNode; atEntry : boolean): TFHIRTypeDetails; @@ -1678,7 +1680,7 @@ function TFHIRPathEngine.executeType(ctxt: TFHIRPathExecutionTypeContext; focus: end; end; if (result.hasNoTypes) then - raise EFHIRPath.create('The name '+exp.Name+' was not valid for any of the possible types: '+focus.describe()); + raise EFHIRPath.Create('The name '+exp.Name+' was not valid for any of the possible types: '+focus.describe()); end; enkUnary : begin @@ -1731,7 +1733,7 @@ function TFHIRPathEngine.executeType(ctxt: TFHIRPathExecutionTypeContext; focus: while (next <> nil) do begin if (last.Operation in [popIs, popAs]) then - work := TFHIRTypeDetails.create(csSINGLETON, next.name) + work := TFHIRTypeDetails.Create(csSINGLETON, next.name) else work := executeType(ctxt, focus, next, atEntry); try @@ -1863,11 +1865,11 @@ function TFHIRPathEngine.funcContains(context : TFHIRPathExecutionContext; focus end; if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions) + result.add(TFHIRBoolean.Create(false).noExtensions) else if sw = '' then - result.add(TFHIRBoolean.create(true).noExtensions) + result.add(TFHIRBoolean.Create(true).noExtensions) else - result.add(TFHIRBoolean.create(convertToString(focus[0].value).contains(sw)).noExtensions); + result.add(TFHIRBoolean.Create(convertToString(focus[0].value).contains(sw)).noExtensions); end; result.Link; finally @@ -2009,11 +2011,11 @@ function TFHIRPathEngine.funcEndsWith(context: TFHIRPathExecutionContext; focus: end; if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions) + result.add(TFHIRBoolean.Create(false).noExtensions) else if (sw = '') then - result.add(TFHIRBoolean.create(true).noExtensions) + result.add(TFHIRBoolean.Create(true).noExtensions) else - result.add(TFHIRBoolean.create(convertToString(focus[0].value).endsWith(sw)).noExtensions); + result.add(TFHIRBoolean.Create(convertToString(focus[0].value).endsWith(sw)).noExtensions); end; result.Link; finally @@ -2157,9 +2159,9 @@ function TFHIRPathEngine.funcHasValue(context: TFHIRPathExecutionContext; focus: result := TFHIRSelectionList.Create; try if (focus.count = 1) then - result.add(TFHIRBoolean.create(focus[0].value.hasPrimitiveValue).noExtensions) + result.add(TFHIRBoolean.Create(focus[0].value.hasPrimitiveValue).noExtensions) else - result.add(TFHIRBoolean.create(false).noExtensions); + result.add(TFHIRBoolean.Create(false).noExtensions); result.Link; finally result.free; @@ -2170,7 +2172,7 @@ function TFHIRPathEngine.funcHtmlChecks(context: TFHIRPathExecutionContext; focu begin result := TFHIRSelectionList.Create; try - result.add(TFHIRBoolean.create(true).noExtensions); + result.add(TFHIRBoolean.Create(true).noExtensions); result.Link; finally result.free; @@ -2181,19 +2183,28 @@ function TFHIRPathEngine.funcIif(context: TFHIRPathExecutionContext; focus: TFHI var n1 : TFHIRSelectionList; v : TEqualityTriState; + cn : TFHIRPathExecutionContext; begin - n1 := execute(context, focus, exp.Parameters[0], true); + if (focus.Empty) then + cn := context.Link + else + cn := context.changeThis(focus[0].value, 0); try - v := asBool(n1); + n1 := execute(cn, focus, exp.Parameters[0], true); + try + v := asBool(n1); - if (v = equalTrue) then - result := execute(context, focus, exp.parameters[1], true) - else if (exp.parameters.count < 3) then - result := TFHIRSelectionList.Create - else - result := execute(context, focus, exp.parameters[2], true); + if (v = equalTrue) then + result := execute(context, focus, exp.parameters[1], true) + else if (exp.parameters.count < 3) then + result := TFHIRSelectionList.Create + else + result := execute(context, focus, exp.parameters[2], true); + finally + n1.free; + end; finally - n1.free; + cn.free; end; end; @@ -2227,18 +2238,18 @@ function TFHIRPathEngine.funcIs(context: TFHIRPathExecutionContext; focus: TFHIR result := TFHIRSelectionList.Create; try if (focus.count = 0) or (focus.count > 1) then - result.add(TFHIRBoolean.create(false).noExtensions) + result.add(TFHIRBoolean.Create(false).noExtensions) else begin ns := ''; n := ''; texp := exp.Parameters[0]; if (texp.Kind <> enkName) then - raise EFHIRPath.create('Unsupported Expression type for Parameter on Is'); + raise EFHIRPath.Create('Unsupported Expression type for Parameter on Is'); if (texp.inner <> nil) then begin if (texp.Kind <> enkName) then - raise EFHIRPath.create('Unsupported Expression type for Parameter on Is'); + raise EFHIRPath.Create('Unsupported Expression type for Parameter on Is'); ns := texp.Name; n := texp.inner.Name; end @@ -2255,19 +2266,19 @@ function TFHIRPathEngine.funcIs(context: TFHIRPathExecutionContext; focus: TFHIR if (ns = 'System') then begin if (focus[0].value is TFHIRResource) then - result.add(TFHIRBoolean.create(false).noExtensions) + result.add(TFHIRBoolean.Create(false).noExtensions) else if (not (focus[0].value is TFHIRElement) or (focus[0].value as TFHIRElement).DisallowExtensions) then if (focus[0].value.fhirType = 'date') and (n = 'DateTime') then - result.add(TFHIRBoolean.create(true).noExtensions) + result.add(TFHIRBoolean.Create(true).noExtensions) else - result.add(TFHIRBoolean.create(n = capitalise(focus[0].value.fhirType)).noExtensions) + result.add(TFHIRBoolean.Create(n = capitalise(focus[0].value.fhirType)).noExtensions) else - result.add(TFHIRBoolean.create(false).noExtensions); + result.add(TFHIRBoolean.Create(false).noExtensions); end else if (ns = 'FHIR') then - result.add(TFHIRBoolean.create(typeMatches(n, focus[0].value.fhirType, true)).noExtensions) + result.add(TFHIRBoolean.Create(typeMatches(n, focus[0].value.fhirType, true)).noExtensions) else - result.add(TFHIRBoolean.create(false).noExtensions); + result.add(TFHIRBoolean.Create(false).noExtensions); end; result.link; finally @@ -2284,7 +2295,7 @@ function TFHIRPathEngine.funcIsDistinct( context: TFHIRPathExecutionContext; foc result := TFHIRSelectionList.Create; try if (focus.count = 1) then - result.add(TFHIRBoolean.create(true).noExtensions) + result.add(TFHIRBoolean.Create(true).noExtensions) else if (focus.count > 1) then begin distinct := true; @@ -2303,7 +2314,7 @@ function TFHIRPathEngine.funcIsDistinct( context: TFHIRPathExecutionContext; foc break; end; end; - result.add(TFHIRBoolean.create(distinct).noExtensions); + result.add(TFHIRBoolean.Create(distinct).noExtensions); end; result.link; finally @@ -2340,15 +2351,17 @@ function TFHIRPathEngine.funcJoin(context: TFHIRPathExecutionContext; focus: TFH param : String; b : TFslStringBuilder; o : TFHIRSelection; + first : boolean; begin nl := execute(context, focus, exp.Parameters[0], true); try b := TFslStringBuilder.Create; try param := nl[0].value.primitiveValue; + first := true; for o in focus do begin - b.seperator(param); + if (first) then first := false else b.Append(param); b.append(o.value.primitiveValue); end; result := TFHIRSelectionList.Create(TFhirString.Create(b.ToString)); @@ -2378,14 +2391,14 @@ function TFHIRPathEngine.funcIndexOf(context: TFHIRPathExecutionContext; focus: begin sw := convertToString(nl); if (sw = '') then - result.add(TFHIRInteger.create(0)) + result.add(TFHIRInteger.Create(0)) else // if (focus[0].hasType(FHIR_TYPES_STRING)) then begin s := convertToString(focus[0].value); if (s = '') then - result.add(TFHIRInteger.create(0)) + result.add(TFHIRInteger.Create(0)) else - result.add(TFHIRInteger.create(s.indexOf(sw))); + result.add(TFHIRInteger.Create(s.indexOf(sw))); end; end; finally @@ -2414,7 +2427,7 @@ function TFHIRPathEngine.funcLength(context : TFHIRPathExecutionContext; focus: if (focus.count = 1) then begin s := convertToString(focus[0].value); - result.add(TFHIRInteger.create(inttostr(s.length)).noExtensions); + result.add(TFHIRInteger.Create(inttostr(s.length)).noExtensions); end; result.Link; finally @@ -2533,13 +2546,13 @@ function TFHIRPathEngine.funcMatches(context : TFHIRPathExecutionContext; focus: begin p := convertToString(res); if (p = '') then - result.add(TFHIRBoolean.create(false)) + result.add(TFHIRBoolean.Create(false)) else begin reg := TRegularExpression.Create('(?s)' + p, [roCompiled]); try s := convertToString(focus[0].value); - result.add(TFHIRBoolean.create(reg.isMatch(s))); + result.add(TFHIRBoolean.Create(reg.isMatch(s))); finally reg.free; end; @@ -2559,7 +2572,7 @@ function TFHIRPathEngine.funcMatchesFull(context : TFHIRPathExecutionContext; fo var res : TFHIRSelectionList; s, p : String; - reg : TRegularExpression; + reg : TREgularExpression; begin result := TFHIRSelectionList.Create; try @@ -2571,13 +2584,13 @@ function TFHIRPathEngine.funcMatchesFull(context : TFHIRPathExecutionContext; fo begin p := convertToString(res); if (p = '') then - result.add(TFHIRBoolean.create(false)) + result.add(TFHIRBoolean.Create(false)) else begin - reg := TRegularExpression.Create('(?s)' + p, [roCompiled]); + reg := TREgularExpression.Create('(?s)' + p, [roCompiled]); try s := convertToString(focus[0].value); - result.add(TFHIRBoolean.create(reg.isFullMatch(s))); + result.add(TFHIRBoolean.Create(reg.isFullMatch(s))); finally reg.free; end; @@ -2595,7 +2608,7 @@ function TFHIRPathEngine.funcMatchesFull(context : TFHIRPathExecutionContext; fo function TFHIRPathEngine.funcMemberOf(context: TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp: TFHIRPathExpressionNode): TFHIRSelectionList; begin - raise EFHIRPathTodo.create('TFHIRPathEngine.funcMemberOf'); + raise EFHIRPathTodo.Create('TFHIRPathEngine.funcMemberOf'); end; function TFHIRPathEngine.funcNot(context : TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp: TFHIRPathExpressionNode): TFHIRSelectionList; @@ -2704,7 +2717,7 @@ function TFHIRPathEngine.funcReplace(context: TFHIRPathExecutionContext; focus: begin f := convertToString(focus[0].value); if (f = '') then - result.add(TFHIRString.create('')) + result.add(TFHIRString.Create('')) else if (t = '') then begin b := TFslStringBuilder.Create; @@ -2715,7 +2728,7 @@ function TFHIRPathEngine.funcReplace(context: TFHIRPathExecutionContext; focus: b.append(f[i]); b.append(r); end; - result.add(TFHIRString.create(b.toString)) + result.add(TFHIRString.Create(b.toString)) finally b.free; end; @@ -2723,7 +2736,7 @@ function TFHIRPathEngine.funcReplace(context: TFHIRPathExecutionContext; focus: else begin n := f.replace(t, r); - result.add(TFHIRString.create(n)); + result.add(TFHIRString.Create(n)); end end else @@ -2762,13 +2775,13 @@ function TFHIRPathEngine.funcReplaceMatches( context: TFHIRPathExecutionContext; begin f := convertToString(focus[0].value); if (f = '') then - result.add(TFHIRString.create('')) + result.add(TFHIRString.Create('')) else if (t = '') then - result.add(TFHIRString.create(f)) + result.add(TFHIRString.Create(f)) else begin n := f.replace(t, r); - result.add(TFHIRString.create(TRegularExpression.replace(n, t, r))); + result.add(TFHIRString.Create(TRegularExpression.replace(n, t, r))); end end else @@ -2833,7 +2846,7 @@ function TFHIRPathEngine.funcResolve(context : TFHIRPathExecutionContext; focus: else begin if not assigned(FOnResolveReference) then - raise EFHIRPath.create('resolve() - resolution services for '+exp.name+' not implemented yet'); + raise EFHIRPath.Create('resolve() - resolution services for '+exp.name+' not implemented yet'); res := FOnResolveReference(self, context.appInfo, s); end; if (res <> nil) then @@ -2934,7 +2947,7 @@ function TFHIRPathEngine.funcSelect(context: TFHIRPathExecutionContext; focus: T function TFHIRPathEngine.funcSingle(context: TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp: TFHIRPathExpressionNode): TFHIRSelectionList; begin if (focus.count <> 1) then - raise EFHIRPath.create(StringFormat('Single() : checking for 1 item but found %d items', [focus.count])); + raise EFHIRPath.Create(StringFormat('Single() : checking for 1 item but found %d items', [focus.count])); result := focus.link; end; @@ -2967,9 +2980,9 @@ function TFHIRPathEngine.funcStartsWith(context : TFHIRPathExecutionContext; foc begin sw := convertToString(swb); if (sw = '') then - result.add(TFHIRBoolean.create(true).noExtensions) + result.add(TFHIRBoolean.Create(true).noExtensions) else - result.add(TFHIRBoolean.create(convertToString(focus[0].value).startsWith(sw)).noExtensions); + result.add(TFHIRBoolean.Create(convertToString(focus[0].value).startsWith(sw)).noExtensions); end; finally swb.free; @@ -3010,7 +3023,7 @@ function TFHIRPathEngine.funcSubsetOf(context: TFHIRPathExecutionContext; focus: break; end; end; - result := TFHIRSelectionList.Create(TFHIRBoolean.create(valid).noExtensions); + result := TFHIRSelectionList.Create(TFHIRBoolean.Create(valid).noExtensions); finally target.free; end; @@ -3098,7 +3111,7 @@ function TFHIRPathEngine.funcExists(context: TFHIRPathExecutionContext; focus: T pc.free; end; - result.add(TFHIRBoolean.create(not empty).noExtensions); + result.add(TFHIRBoolean.Create(not empty).noExtensions); result.link; finally result.free; @@ -3168,7 +3181,7 @@ function TFHIRPathEngine.funcSupersetOf( context: TFHIRPathExecutionContext; foc break; end; end; - result := TFHIRSelectionList.Create(TFHIRBoolean.create(valid).noExtensions); + result := TFHIRSelectionList.Create(TFHIRBoolean.Create(valid).noExtensions); finally target.free; end; @@ -3533,17 +3546,24 @@ function TFHIRPathEngine.funcCombine(context : TFHIRPathExecutionContext; focus: var item : TFHIRSelection; res : TFHIRSelectionList; + fl : TFHIRSelectionList; begin result := TFHIRSelectionList.Create; try for item in focus do result.add(item.link); - res := execute(context, focus, exp.Parameters[0], true); + fl := TFHIRSelectionList.create; try - for item in res do - result.add(item.link); + fl.add(context.this.link); + res := execute(context, fl, exp.Parameters[0], true); + try + for item in res do + result.add(item.link); + finally + res.free; + end; finally - res.free; + fl.free; end; result.Link; finally @@ -3557,7 +3577,7 @@ function TFHIRPathEngine.funcType(context : TFHIRPathExecutionContext; focus: TF begin result := TFHIRSelectionList.Create; for item in focus do - result.add(TFHIRClassTypeInfo.create(item.value.Link)); + result.add(TFHIRClassTypeInfo.Create(item.value.Link)); end; function TFHIRPathEngine.funcOfType(context : TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; @@ -3615,18 +3635,19 @@ function TFHIRPathEngine.funcPower(context: TFHIRPathExecutionContext; focus: TF function TFHIRPathEngine.funcElementDefinition(context : TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; begin - raise EFHIRTodo.create('TFHIRPathEngine.funcElementDefinition'); + raise EFHIRTodo.Create('TFHIRPathEngine.funcElementDefinition'); end; function TFHIRPathEngine.funcSlice(context : TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; begin - raise EFHIRTodo.create('TFHIRPathEngine.funcSlice'); + raise EFHIRTodo.Create('TFHIRPathEngine.funcSlice'); end; function TFHIRPathEngine.funcSplit(context: TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp: TFHIRPathExpressionNode): TFHIRSelectionList; var nl : TFHIRSelectionList; param, s : String; + p : TStringArray; begin nl := execute(context, focus, exp.Parameters[0], true); try @@ -3634,8 +3655,11 @@ function TFHIRPathEngine.funcSplit(context: TFHIRPathExecutionContext; focus: TF result := TFHIRSelectionList.Create(); try if focus.Count = 1 then - for s in focus[0].value.primitiveValue.Split([param]) do + begin + p := focus[0].value.primitiveValue.Split([param]); + for s in p do result.add(TFhirString.Create(s)); + end; result.Link; finally result.free; @@ -3718,19 +3742,19 @@ function TFHIRPathEngine.funcLowBoundary(context : TFHIRPathExecutionContext; fo base := focus[0].value; if (base.hasType('decimal')) then - result.add(TFhirDecimal.create(lowBoundaryForDecimal(base.primitiveValue(), dp(8)))) + result.add(TFhirDecimal.Create(lowBoundaryForDecimal(base.primitiveValue(), dp(8)))) else if (base.hasType('date')) then - result.add(TFHIRDateTime.create(lowBoundaryForDate(base.primitiveValue(), dp(8)))) + result.add(TFHIRDateTime.Create(lowBoundaryForDate(base.primitiveValue(), dp(8)))) else if (base.hasType('dateTime')) then - result.add(TFHIRDateTime.create(lowBoundaryForDate(base.primitiveValue(), dp(17)))) + result.add(TFHIRDateTime.Create(lowBoundaryForDate(base.primitiveValue(), dp(17)))) else if (base.hasType('time')) then - result.add(TFHIRTime.create(lowBoundaryForTime(base.primitiveValue(), dp(9)))) + result.add(TFHIRTime.Create(lowBoundaryForTime(base.primitiveValue(), dp(9)))) else if (base.hasType('Quantity')) then begin value := base.getPrimitiveValue('value'); v := base.Clone; result.add(v); - v.setProperty('value', TFHIRDecimal.create(lowBoundaryForDecimal(value, dp(8)))); + v.setProperty('value', TFHIRDecimal.Create(lowBoundaryForDecimal(value, dp(8)))); end else raise EFHIRPath.Create('Unable to generate low boundary for '+base.fhirType); @@ -3777,19 +3801,19 @@ function TFHIRPathEngine.funcHighBoundary(context : TFHIRPathExecutionContext; f base := focus[0].value; if (base.hasType('decimal')) then - result.add(TFhirDecimal.create(highBoundaryForDecimal(base.primitiveValue(), dp(8)))) + result.add(TFhirDecimal.Create(highBoundaryForDecimal(base.primitiveValue(), dp(8)))) else if (base.hasType('date')) then - result.add(TFHIRDateTime.create(highBoundaryForDate(base.primitiveValue(), dp(8)))) + result.add(TFHIRDateTime.Create(highBoundaryForDate(base.primitiveValue(), dp(8)))) else if (base.hasType('dateTime')) then - result.add(TFHIRDateTime.create(highBoundaryForDate(base.primitiveValue(), dp(17)))) + result.add(TFHIRDateTime.Create(highBoundaryForDate(base.primitiveValue(), dp(17)))) else if (base.hasType('time')) then - result.add(TFHIRTime.create(highBoundaryForTime(base.primitiveValue(), dp(9)))) + result.add(TFHIRTime.Create(highBoundaryForTime(base.primitiveValue(), dp(9)))) else if (base.hasType('Quantity')) then begin value := base.getPrimitiveValue('value'); v := base.Clone; result.add(v); - v.setProperty('value', TFHIRDecimal.create(highBoundaryForDecimal(value, dp(8)))); + v.setProperty('value', TFHIRDecimal.Create(highBoundaryForDecimal(value, dp(8)))); end else raise EFHIRPath.Create('Unable to generate low boundary for '+base.fhirType); @@ -3800,6 +3824,55 @@ function TFHIRPathEngine.funcHighBoundary(context : TFHIRPathExecutionContext; f end; end; +function TFHIRPathEngine.funcComparable(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; +var + n1 : TFHIRSelectionList; + s1, u1, s2, u2 : String; +begin + result := TFHIRSelectionList.Create; + try + if (focus.Count <> 1) or (focus[0].value.fhirType <> 'Quantity') then + result.add(TFHIRBoolean.Create(false)) + else + begin + n1 := execute(context, focus, exp.Parameters[0], true); + try + if (n1.Count <> 1) or (n1[0].value.fhirType <> 'Quantity') then + result.add(TFHIRBoolean.Create(false)) + else + begin + s1 := focus[0].value.getPrimitiveValue('system'); + u1 := focus[0].value.getPrimitiveValue('code'); + s2 := n1[0].value.getPrimitiveValue('system'); + u2 := n1[0].value.getPrimitiveValue('code'); + + if (s1 = '') or (s2 = '') or (s1 <> s2) then + result.add(TFHIRBoolean.Create(false)) + else if (u1 = '') or (u2 = '') then + result.add(TFHIRBoolean.Create(false)) + else if (u1 = u2) then + result.add(TFHIRBoolean.Create(true)) + else if (s1 = 'http://unitsofmeasure.org') and (FUcum <> nil) then + begin + try + result.add(TFHIRBoolean.Create(FUcum.isComparable(u1, u2))); + except + result.add(TFHIRBoolean.Create(false)); + end; + end + else + result.add(TFHIRBoolean.Create(false)) + end; + finally + n1.free; + end; + end; + result.Link; + finally + result.free; + end; +end; + function TFHIRPathEngine.funcPrecision(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; var base : TFhirObject; @@ -3813,11 +3886,11 @@ function TFHIRPathEngine.funcPrecision(context : TFHIRPathExecutionContext; focu base := focus[0].value; if (base.hasType('decimal')) then - result.add(TFHIRInteger.create(getDecimalPrecision(base.primitiveValue()))) + result.add(TFHIRInteger.Create(getDecimalPrecision(base.primitiveValue()))) else if (base.hasType('date') or base.hasType('dateTime')) then - result.add(TFHIRInteger.create(getDatePrecision(base.primitiveValue()))) + result.add(TFHIRInteger.Create(getDatePrecision(base.primitiveValue()))) else if (base.hasType('time')) then - result.add(TFHIRInteger.create(getTimePrecision(base.primitiveValue()))) + result.add(TFHIRInteger.Create(getTimePrecision(base.primitiveValue()))) else raise EFHIRPath.Create('Unable to get precision for '+base.fhirType); end; @@ -3831,7 +3904,7 @@ function TFHIRPathEngine.funcCeiling(context: TFHIRPathExecutionContext; focus: var base : TFHIRObject; qty : TFHIRQuantity; - d : TFslDecimal; + v : TFslDecimal; begin if (focus.count <> 1) then raise EFHIRPath.Create('Error evaluating FHIRPath expression: focus for floor has more than one value'); @@ -3845,10 +3918,10 @@ function TFHIRPathEngine.funcCeiling(context: TFHIRPathExecutionContext; focus: begin qty := (base as TFhirQuantity).Clone; try - d := TFslDecimal.Create(qty.value); - d := d.Trunc; - d := d.AddInt(1); - qty.value := d.AsString; + v := TFslDecimal.Create(qty.value); + v := v.trunc; + v := v.addInt(1); + qty.value := v.AsString; result.add(qty.Link); finally qty.free; @@ -3909,7 +3982,7 @@ function TFHIRPathEngine.funcCheckModifiers(context : TFHIRPathExecutionContext; function TFHIRPathEngine.funcConformsTo(context : TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; begin - raise EFHIRTodo.create('TFHIRPathEngine.funcConformsTo'); + raise EFHIRTodo.Create('TFHIRPathEngine.funcConformsTo'); end; function TFHIRPathEngine.funcAbs(context: TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp: TFHIRPathExpressionNode): TFHIRSelectionList; @@ -4145,7 +4218,7 @@ function TFHIRPathEngine.funcLower(context : TFHIRPathExecutionContext; focus : begin sw := convertToString(focus[0].value); if sw <> '' then - result.add(TFHIRString.create(sw.ToLower).noExtensions); + result.add(TFHIRString.Create(sw.ToLower).noExtensions); end; result.Link; finally @@ -4163,7 +4236,7 @@ function TFHIRPathEngine.funcUpper(context : TFHIRPathExecutionContext; focus : begin sw := convertToString(focus[0].value); if sw <> '' then - result.add(TFHIRString.create(sw.ToUpper).noExtensions); + result.add(TFHIRString.Create(sw.ToUpper).noExtensions); end; result.Link; finally @@ -4182,7 +4255,7 @@ function TFHIRPathEngine.funcToChars(context : TFHIRPathExecutionContext; focus begin sw := convertToString(focus[0].value); for c in sw do - result.add(TFHIRString.create(c).noExtensions); + result.add(TFHIRString.Create(c).noExtensions); end; result.Link; finally @@ -4203,8 +4276,8 @@ function TFHIRPathEngine.funcToBoolean(context : TFHIRPathExecutionContext; focu else if (focus[0].value is TFHIRInteger) then begin case StrToInt((focus[0].value as TFHIRInteger).value) of - 0: result.add(TFHIRBoolean.create(false).noExtensions()); - 1: result.add(TFHIRBoolean.create(true).noExtensions()); + 0: result.add(TFHIRBoolean.Create(false).noExtensions()); + 1: result.add(TFHIRBoolean.Create(true).noExtensions()); else end; end @@ -4212,15 +4285,15 @@ function TFHIRPathEngine.funcToBoolean(context : TFHIRPathExecutionContext; focu begin s := removeTrailingZeros(TFHIRDecimal(focus[0].value).value); if (s = '0') then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if (s = '1') then - result.add(TFHIRBoolean.create(true).noExtensions()); + result.add(TFHIRBoolean.Create(true).noExtensions()); end else if (focus[0].value is TFHIRString) then if SameText('true', focus[0].value.primitiveValue) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if SameText('false', focus[0].value.primitiveValue) then - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); end; result.Link; finally @@ -4258,12 +4331,12 @@ function TFHIRPathEngine.funcToQuantity(context : TFHIRPathExecutionContext; foc function TFHIRPathEngine.funcToDateTime(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; begin - raise EFHIRTodo.create('TFHIRPathEngine.funcToDateTime'); + raise EFHIRTodo.Create('TFHIRPathEngine.funcToDateTime'); end; function TFHIRPathEngine.funcToTime(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; begin - raise EFHIRTodo.create('TFHIRPathEngine.funcToTime'); + raise EFHIRTodo.Create('TFHIRPathEngine.funcToTime'); end; function TFHIRPathEngine.funcIsInteger(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; @@ -4271,15 +4344,15 @@ function TFHIRPathEngine.funcIsInteger(context : TFHIRPathExecutionContext; focu result := TFHIRSelectionList.Create; try if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if (focus[0].value is TFHIRInteger) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRBoolean) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRString) then - result.add(TFHIRBoolean.create(StringIsInteger32(convertToString(focus[0].value))).noExtensions()) + result.add(TFHIRBoolean.Create(StringIsInteger32(convertToString(focus[0].value))).noExtensions()) else - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); result.Link; finally result.free; @@ -4291,17 +4364,17 @@ function TFHIRPathEngine.funcIsDecimal(context : TFHIRPathExecutionContext; focu result := TFHIRSelectionList.Create; try if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if (focus[0].value is TFHIRInteger) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRBoolean) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRDecimal) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRString) then - result.add(TFHIRBoolean.create(StringIsDecimal(convertToString(focus[0].value))).noExtensions()) + result.add(TFHIRBoolean.Create(StringIsDecimal(convertToString(focus[0].value))).noExtensions()) else - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); result.Link; finally result.free; @@ -4313,11 +4386,11 @@ function TFHIRPathEngine.funcIsString(context : TFHIRPathExecutionContext; focus result := TFHIRSelectionList.Create; try if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if not (focus[0].value is TFHIRDateTime) and not (focus[0].value is TFHIRTime) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); result.Link; finally result.free; @@ -4329,17 +4402,17 @@ function TFHIRPathEngine.funcIsBoolean(context : TFHIRPathExecutionContext; focu result := TFHIRSelectionList.Create; try if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if (focus[0].value is TFHIRInteger) and (StrToIntDef((focus[0].value as TFHIRInteger).value, -1) >= 0) and (StrToIntDef((focus[0].value as TFHIRInteger).value, -1) <= 1) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRBoolean) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRDecimal) then - result.add(TFHIRBoolean.create(StringArrayExistsSensitive(['0', '1'], removeTrailingZeros(focus[0].value.primitiveValue))).noExtensions()) + result.add(TFHIRBoolean.Create(StringArrayExistsSensitive(['0', '1'], removeTrailingZeros(focus[0].value.primitiveValue))).noExtensions()) else if (focus[0].value is TFHIRString) then - result.add(TFHIRBoolean.create(StringArrayExistsInSensitive(['true', 'false'], convertToString(focus[0].value))).noExtensions()) + result.add(TFHIRBoolean.Create(StringArrayExistsInSensitive(['true', 'false'], convertToString(focus[0].value))).noExtensions()) else - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); result.Link; finally result.free; @@ -4412,22 +4485,22 @@ function TFHIRPathEngine.funcIsQuantity(context : TFHIRPathExecutionContext; foc result := TFHIRSelectionList.Create; try if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if (focus[0].value is TFHIRInteger) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRDecimal) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRQuantity) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRBoolean) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRString) then begin q := parseQuantityString(focus[0].value.primitiveValue()); - result.add(TFHIRBoolean.create(q <> nil).noExtensions()); + result.add(TFHIRBoolean.Create(q <> nil).noExtensions()); end else - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); result.Link; finally result.free; @@ -4440,15 +4513,15 @@ function TFHIRPathEngine.funcIsDate(context: TFHIRPathExecutionContext; focus: T result := TFHIRSelectionList.Create; try if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if (focus[0].value is TFHIRDateTime) or (focus[0].value is TFHIRDate) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRString) then - result.add(TFHIRBoolean.create(TRegularExpression.isMatch(convertToString(focus[0].value), + result.add(TFHIRBoolean.Create(TRegularExpression.isMatch(convertToString(focus[0].value), '([0-9]([0-9]([0-9][1-9]|[1-9]0)|[1-9]00)|[1-9]000)(-(0[1-9]|1[0-2])(-(0[1-9]|[1-2][0-9]|3[0-1]))?)?' )).noExtensions()) else - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); result.Link; finally result.free; @@ -4460,15 +4533,15 @@ function TFHIRPathEngine.funcIsDateTime(context : TFHIRPathExecutionContext; foc result := TFHIRSelectionList.Create; try if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if (focus[0].value is TFHIRDateTime) or (focus[0].value is TFHIRDate) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRString) then - result.add(TFHIRBoolean.create(TRegularExpression.isMatch(convertToString(focus[0].value), + result.add(TFHIRBoolean.Create(TRegularExpression.isMatch(convertToString(focus[0].value), '([0-9]([0-9]([0-9][1-9]|[1-9]0)|[1-9]00)|[1-9]000)(-(0[1-9]|1[0-2])(-(0[1-9]|[1-2][0-9]|3[0-1])(T([01][0-9]|2[0-3]):[0-5][0-9]:([0-5][0-9]|60)(\.[0-9]+)?(Z|(\+|-)((0[0-9]|1[0-3]):[0-5][0-9]|14:00))?)?)?)?' )).noExtensions()) else - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); result.Link; finally result.free; @@ -4480,14 +4553,14 @@ function TFHIRPathEngine.funcIsTime(context : TFHIRPathExecutionContext; focus : result := TFHIRSelectionList.Create; try if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if (focus[0].value is TFHIRTime) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRString) then - result.add(TFHIRBoolean.create(TRegularExpression.IsMatch(convertToString(focus[0].value), + result.add(TFHIRBoolean.Create(TRegularExpression.IsMatch(convertToString(focus[0].value), '(T)?([01][0-9]|2[0-3])(:[0-5][0-9](:([0-5][0-9]|60))?)?(\\.[0-9]+)?(Z|(\\+|-)((0[0-9]|1[0-3]):[0-5][0-9]|14:00))?')).noExtensions()) else - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); result.Link; finally result.free; @@ -4519,7 +4592,7 @@ function TFHIRPathEngine.preOperate(left: TFHIRSelectionList; op: TFHIRPathOpera function TFHIRPathEngine.operate(left: TFHIRSelectionList; op: TFHIRPathOperation; right: TFHIRSelectionList): TFHIRSelectionList; begin case op of - popNull: raise EFHIRPath.create('An internal error has occurred'); + popNull: raise EFHIRPath.Create('An internal error has occurred'); popEquals: result := opequal(left, right); popEquivalent: result := opEquivalent(left, right); popNotEquals: result := opNotequal(left, right); @@ -4544,9 +4617,9 @@ function TFHIRPathEngine.operate(left: TFHIRSelectionList; op: TFHIRPathOperatio popMod: result := opMod(left, right); popIs: result := opIs(left, right); popAs: result := opAs(left, right); - popCustom : raise EFHIRPath.create('An internal error has occurred (custom operation not implemented)'); + popCustom : raise EFHIRPath.Create('An internal error has occurred (custom operation not implemented)'); else - raise EFHIRPath.create('An internal error has occurred (operation not implemented)'); + raise EFHIRPath.Create('An internal error has occurred (operation not implemented)'); end; end; @@ -4554,37 +4627,37 @@ function TFHIRPathEngine.operate(left: TFHIRSelectionList; op: TFHIRPathOperatio function TFHIRPathEngine.operateTypes(left: TFHIRTypeDetails; op: TFHIRPathOperation; right: TFHIRTypeDetails): TFHIRTypeDetails; begin case op of - popEquals: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popEquivalent: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popNotEquals: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popNotEquivalent: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popLessThan: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popGreater: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popLessOrEqual: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popGreaterOrEqual: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popIs: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + popEquals: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popEquivalent: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popNotEquals: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popNotEquivalent: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popLessThan: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popGreater: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popLessOrEqual: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popGreaterOrEqual: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popIs: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); popAs: result := TFHIRTypeDetails.createList(csSINGLETON, right.Types); popUnion: result := left.union(right); - popOr: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popAnd: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popXor: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popImplies : result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + popOr: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popAnd: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popXor: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popImplies : result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); popTimes: begin - result := TFHIRTypeDetails.create(csSINGLETON, []); + result := TFHIRTypeDetails.Create(csSINGLETON, []); if (left.hasType(context, 'integer')) and (right.hasType(context, 'integer')) then result.addType(FP_integer) else if (left.hasType(context, ['integer', 'decimal'])) and (right.hasType(context, ['integer', 'decimal'])) then result.addType(FP_decimal); end; popDivideBy: begin - result := TFHIRTypeDetails.create(csSINGLETON, []); + result := TFHIRTypeDetails.Create(csSINGLETON, []); if (left.hasType(context, 'integer')) and (right.hasType(context, 'integer')) then result.addType(FP_decimal) else if (left.hasType(context, ['integer', 'decimal'])) and (right.hasType(context, ['integer', 'decimal'])) then result.addType(FP_decimal) end; popPlus: begin - result := TFHIRTypeDetails.create(csSINGLETON, []); + result := TFHIRTypeDetails.Create(csSINGLETON, []); if (left.hasType(context, 'integer')) and (right.hasType(context, 'integer')) then result.addType(FP_integer) else if (left.hasType(context, ['integer', 'decimal'])) and (right.hasType(context, ['integer', 'decimal'])) then @@ -4592,9 +4665,9 @@ function TFHIRPathEngine.operateTypes(left: TFHIRTypeDetails; op: TFHIRPathOpera else if (left.hasType(context, ['string', 'id', 'code', 'uri'])) and (right.hasType(context, ['string', 'id', 'code', 'uri'])) then result.addType(FP_string); end; - popConcatenate : result := TFHIRTypeDetails.create(csSINGLETON, ['string']); + popConcatenate : result := TFHIRTypeDetails.Create(csSINGLETON, ['string']); popMinus: begin - result := TFHIRTypeDetails.create(csSINGLETON, []); + result := TFHIRTypeDetails.Create(csSINGLETON, []); if (left.hasType(context, 'integer')) and (right.hasType(context, 'integer')) then result.addType(FP_integer) else if (left.hasType(context, ['integer', 'decimal'])) and (right.hasType(context, ['integer', 'decimal'])) then @@ -4606,22 +4679,22 @@ function TFHIRPathEngine.operateTypes(left: TFHIRTypeDetails; op: TFHIRPathOpera if (right.hasType(context, ['Quantity'])) then result.addType(left.type_) else - raise EFHIRPath.create(format('Error in date arithmetic: Unable to subtract type {0} from {1}', [right.type_, left.type_])); + raise EFHIRPath.Create(format('Error in date arithmetic: Unable to subtract type {0} from {1}', [right.type_, left.type_])); end; end; popDiv, popMod: begin - result := TFHIRTypeDetails.create(csSINGLETON, []); + result := TFHIRTypeDetails.Create(csSINGLETON, []); if (left.hasType(context, 'integer')) and (right.hasType(context, 'integer')) then result.addType(FP_integer) else if (left.hasType(context, ['integer', 'decimal'])) and (right.hasType(context, ['integer', 'decimal'])) then result.addType(FP_Decimal); end; - popIn: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popContains: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + popIn: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popContains: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); // todo: add memberOf - popCustom : raise EFHIRPath.create('An internal error has occurred (operation not implemented)'); + popCustom : raise EFHIRPath.Create('An internal error has occurred (operation not implemented)'); else - raise EFHIRPathTodo.create('TFHIRPathEngine.operateTypes'); + raise EFHIRPathTodo.Create('TFHIRPathEngine.operateTypes'); end; end; @@ -4705,17 +4778,17 @@ function TFHIRPathEngine.opDiv(left, right: TFHIRSelectionList): TFHIRSelectionL pl, pr : TUcumPair; begin if (left.count = 0) then - raise EFHIRPath.create('Error performing div: left operand has no value'); + raise EFHIRPath.Create('Error performing div: left operand has no value'); if (left.count > 1) then - raise EFHIRPath.create('Error performing div: left operand has more than one value'); + raise EFHIRPath.Create('Error performing div: left operand has more than one value'); if (not left[0].value.isPrimitive()) and not left[0].value.hasType('Quantity') then - raise EFHIRPath.create(StringFormat('Error performing div: left operand has the wrong type (%s)', [left[0].value.fhirType])); + raise EFHIRPath.Create(StringFormat('Error performing div: left operand has the wrong type (%s)', [left[0].value.fhirType])); if (right.count = 0) then - raise EFHIRPath.create('Error performing div: right operand has no value'); + raise EFHIRPath.Create('Error performing div: right operand has no value'); if (right.count > 1) then - raise EFHIRPath.create('Error performing div: right operand has more than one value'); + raise EFHIRPath.Create('Error performing div: right operand has more than one value'); if (not right[0].value.isPrimitive()) and not right[0].value.hasType('Quantity') then - raise EFHIRPath.create(StringFormat('Error performing div: right operand has the wrong type (%s)', [right[0].value.fhirType])); + raise EFHIRPath.Create(StringFormat('Error performing div: right operand has the wrong type (%s)', [right[0].value.fhirType])); result := TFHIRSelectionList.Create(); try @@ -4725,7 +4798,7 @@ function TFHIRPathEngine.opDiv(left, right: TFHIRSelectionList): TFHIRSelectionL if (l.hasType('integer')) and (r.hasType('integer')) then begin if r.primitiveValue() <> '0' then - result.add(TFHIRInteger.create(inttostr(strtoInt(l.primitiveValue()) div strtoInt(r.primitiveValue()))).noExtensions) + result.add(TFHIRInteger.Create(inttostr(strtoInt(l.primitiveValue()) div strtoInt(r.primitiveValue()))).noExtensions) end else if (l.hasType(['quantity'])) and (r.hasType(['quantity'])) and (FUcum <> nil) and FUcum.isConfigured then begin @@ -4755,10 +4828,10 @@ function TFHIRPathEngine.opDiv(left, right: TFHIRSelectionList): TFHIRSelectionL d1 := TFslDecimal.valueOf(l.primitiveValue()); d2 := TFslDecimal.valueOf(r.primitiveValue()); d3 := d1.divInt(d2); - result.add(TFHIRDecimal.create(d3.asDecimal).noExtensions); + result.add(TFHIRDecimal.Create(d3.asDecimal).noExtensions); end else - raise EFHIRPath.create(StringFormat('Error performing div: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing div: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); result.Link; finally result.free; @@ -4772,17 +4845,17 @@ function TFHIRPathEngine.opDivideBy(left, right: TFHIRSelectionList): TFHIRSelec pl, pr, p : TUcumPair; begin if (left.count = 0) then - raise EFHIRPath.create('Error performing /: left operand has no value'); + raise EFHIRPath.Create('Error performing /: left operand has no value'); if (left.count > 1) then - raise EFHIRPath.create('Error performing /: left operand has more than one value'); + raise EFHIRPath.Create('Error performing /: left operand has more than one value'); if (not left[0].value.isPrimitive()) and not left[0].value.hasType('Quantity') then - raise EFHIRPath.create(StringFormat('Error performing -: left operand has the wrong type (%s)', [left[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing -: left operand has the wrong type (%s)', [left[0].value.fhirType()])); if (right.count = 0) then - raise EFHIRPath.create('Error performing /: right operand has no value'); + raise EFHIRPath.Create('Error performing /: right operand has no value'); if (right.count > 1) then - raise EFHIRPath.create('Error performing /: right operand has more than one value'); + raise EFHIRPath.Create('Error performing /: right operand has more than one value'); if (not right[0].value.isPrimitive()) and not right[0].value.hasType('Quantity') then - raise EFHIRPath.create(StringFormat('Error performing /: right operand has the wrong type (%s)', [right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing /: right operand has the wrong type (%s)', [right[0].value.fhirType()])); result := TFHIRSelectionList.Create(); try @@ -4795,7 +4868,7 @@ function TFHIRPathEngine.opDivideBy(left, right: TFHIRSelectionList): TFHIRSelec d2 := TFslDecimal.valueOf(r.primitiveValue()); d3 := d1.divide(d2); if not d3.IsUndefined then - result.add(TFHIRDecimal.create(d3.asDecimal).noExtensions); + result.add(TFHIRDecimal.Create(d3.asDecimal).noExtensions); end else if (l.hasType(['Quantity'])) and (r.hasType(['Quantity'])) and (FUcum <> nil) and FUcum.isConfigured then begin @@ -4820,7 +4893,7 @@ function TFHIRPathEngine.opDivideBy(left, right: TFHIRSelectionList): TFHIRSelec end; end else - raise EFHIRPath.create(StringFormat('Error performing /: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing /: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); result.link; finally result.free; @@ -4946,8 +5019,8 @@ function TFHIRPathEngine.opGreater(left, right: TFHIRSelectionList): TFHIRSelect dl := TFHIRSelectionList.Create; dr := TFHIRSelectionList.Create; try - dl.add(TFhirDecimal.create(qtyToCanonical(left[0].value as TFhirQuantity).Value)); - dr.add(TFhirDecimal.create(qtyToCanonical(right[0].value as TFhirQuantity).Value)); + dl.add(TFhirDecimal.Create(qtyToCanonical(left[0].value as TFhirQuantity).Value)); + dr.add(TFhirDecimal.Create(qtyToCanonical(right[0].value as TFhirQuantity).Value)); result := opGreater(dl, dr); finally dl.free; @@ -4955,7 +5028,7 @@ function TFHIRPathEngine.opGreater(left, right: TFHIRSelectionList): TFHIRSelect end; end else - raise EFHIRPath.create('Canonical Comparison isn''t available'); + raise EFHIRPath.Create('Canonical Comparison isn''t available'); finally lUnit.free; rUnit.free; @@ -5023,8 +5096,8 @@ function TFHIRPathEngine.opGreaterOrEqual(left, right: TFHIRSelectionList): TFHI dl := TFHIRSelectionList.Create; dr := TFHIRSelectionList.Create; try - dl.add(TFhirDecimal.create(qtyToCanonical(left[0].value as TFhirQuantity).Value)); - dr.add(TFhirDecimal.create(qtyToCanonical(right[0].value as TFhirQuantity).Value)); + dl.add(TFhirDecimal.Create(qtyToCanonical(left[0].value as TFhirQuantity).Value)); + dr.add(TFhirDecimal.Create(qtyToCanonical(right[0].value as TFhirQuantity).Value)); result := opGreaterOrEqual(dl, dr); finally dl.free; @@ -5032,7 +5105,7 @@ function TFHIRPathEngine.opGreaterOrEqual(left, right: TFHIRSelectionList): TFHI end; end else - raise EFHIRPath.create('Canonical Comparison isn''t available'); + raise EFHIRPath.Create('Canonical Comparison isn''t available'); finally lUnit.free; rUnit.free; @@ -5053,7 +5126,7 @@ function TFHIRPathEngine.opIn(left, right: TFHIRSelectionList): TFHIRSelectionLi if (left.count = 0) then exit(TFHIRSelectionList.Create); if (right.count = 0) then - exit(TFHIRSelectionList.Create(TFHIRBoolean.create(false))); + exit(TFHIRSelectionList.Create(TFHIRBoolean.Create(false))); ans := true; for l in left do begin @@ -5089,9 +5162,9 @@ function TFHIRPathEngine.opIs(left, right: TFHIRSelectionList): TFHIRSelectionLi begin tn := convertToString(right); if not (left[0].value is TFHIRElement) or (left[0].value as TFHIRElement).DisallowExtensions then - result.add(TFHIRBoolean.create((capitalise(left[0].value.fhirType) = tn) or ('System.'+capitalise(left[0].value.fhirType) = tn)).noExtensions) + result.add(TFHIRBoolean.Create((capitalise(left[0].value.fhirType) = tn) or ('System.'+capitalise(left[0].value.fhirType) = tn)).noExtensions) else - result.add(TFHIRBoolean.create(typeMatches(tn, left[0].value.fhirType, true)).noExtensions); + result.add(TFHIRBoolean.Create(typeMatches(tn, left[0].value.fhirType, true)).noExtensions); end; result.link; finally @@ -5154,8 +5227,8 @@ function TFHIRPathEngine.opLessOrEqual(left, right: TFHIRSelectionList): TFHIRSe dl := TFHIRSelectionList.Create; dr := TFHIRSelectionList.Create; try - dl.add(TFhirDecimal.create(qtyToCanonical(left[0].value as TFhirQuantity).value)); - dr.add(TFhirDecimal.create(qtyToCanonical(right[0].value as TFhirQuantity).Value)); + dl.add(TFhirDecimal.Create(qtyToCanonical(left[0].value as TFhirQuantity).value)); + dr.add(TFhirDecimal.Create(qtyToCanonical(right[0].value as TFhirQuantity).Value)); result := opLessOrEqual(dl, dr); finally dl.free; @@ -5163,7 +5236,7 @@ function TFHIRPathEngine.opLessOrEqual(left, right: TFHIRSelectionList): TFHIRSe end; end else - raise EFHIRPath.create('Canonical Comparison isn''t available'); + raise EFHIRPath.Create('Canonical Comparison isn''t available'); finally lUnit.free; rUnit.free; @@ -5232,8 +5305,8 @@ function TFHIRPathEngine.opLessThan(left, right: TFHIRSelectionList): TFHIRSelec dl := TFHIRSelectionList.Create; dr := TFHIRSelectionList.Create; try - dl.add(TFhirDecimal.create(qtyToCanonical(left[0].value as TFhirQuantity).Value)); - dr.add(TFhirDecimal.create(qtyToCanonical(right[0].value as TFhirQuantity).Value)); + dl.add(TFhirDecimal.Create(qtyToCanonical(left[0].value as TFhirQuantity).Value)); + dr.add(TFhirDecimal.Create(qtyToCanonical(right[0].value as TFhirQuantity).Value)); result := opLessThan(dl, dr); finally dl.free; @@ -5241,7 +5314,7 @@ function TFHIRPathEngine.opLessThan(left, right: TFHIRSelectionList): TFHIRSelec end; end else - raise EFHIRPath.create('Canonical Comparison isn''t available'); + raise EFHIRPath.Create('Canonical Comparison isn''t available'); finally lUnit.free; rUnit.free; @@ -5263,13 +5336,13 @@ function TFHIRPathEngine.opMinus(left, right: TFHIRSelectionList): TFHIRSelectio if (left.count = 0) or (right.count = 0) then exit(TFHIRSelectionList.Create); if (left.count > 1) then - raise EFHIRPath.create('Error performing -: left operand has more than one value'); + raise EFHIRPath.Create('Error performing -: left operand has more than one value'); if (not left[0].value.isPrimitive() and not left[0].hasType('Quantity')) then - raise EFHIRPath.create(StringFormat('Error performing -: left operand has the wrong type (%s)', [left[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing -: left operand has the wrong type (%s)', [left[0].value.fhirType()])); if (right.count > 1) then - raise EFHIRPath.create('Error performing -: right operand has more than one value'); + raise EFHIRPath.Create('Error performing -: right operand has more than one value'); if (not right[0].value.isPrimitive() and not ((left[0].value.isDateTime() or ('0' = left[0].value.primitiveValue) or left[0].value.hasType('Quantity')) and right[0].value.hasType('Quantity'))) then - raise EFHIRPath.create(StringFormat('Error performing -: right operand has the wrong type (%s)', [right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing -: right operand has the wrong type (%s)', [right[0].value.fhirType()])); result := TFHIRSelectionList.Create(); try @@ -5277,13 +5350,13 @@ function TFHIRPathEngine.opMinus(left, right: TFHIRSelectionList): TFHIRSelectio r := right[0].value; if (l.hasType('integer')) and (r.hasType('integer')) then - result.add(TFHIRInteger.create(inttostr(strToInt(l.primitiveValue()) - strToInt(r.primitiveValue()))).noExtensions) + result.add(TFHIRInteger.Create(inttostr(strToInt(l.primitiveValue()) - strToInt(r.primitiveValue()))).noExtensions) else if (l.hasType('decimal') or l.hasType('integer')) and (r.hasType('decimal') or r.hasType('integer')) then begin d1 := TFslDecimal.valueOf(l.primitiveValue()); d2 := TFslDecimal.valueOf(r.primitiveValue()); d3 := d1.Subtract(d2); - result.add(TFHIRDecimal.create(d3.asDecimal).noExtensions); + result.add(TFHIRDecimal.Create(d3.asDecimal).noExtensions); end else if (l.hasType(['decimal', 'integer', 'Quantity']) and r.hasType('Quantity')) then begin @@ -5303,7 +5376,7 @@ function TFHIRPathEngine.opMinus(left, right: TFHIRSelectionList): TFHIRSelectio else if (l.isDateTime() and r.hasType('Quantity')) then result.add(dateAdd(l, r as TFHIRQuantity, true)) else - raise EFHIRPath.create(StringFormat('Error performing -: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing -: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); result.Link; finally result.free; @@ -5316,17 +5389,17 @@ function TFHIRPathEngine.opMod(left, right: TFHIRSelectionList): TFHIRSelectionL d1, d2, d3 : TFslDecimal; begin if (left.count = 0) then - raise EFHIRPath.create('Error performing mod: left operand has no value'); + raise EFHIRPath.Create('Error performing mod: left operand has no value'); if (left.count > 1) then - raise EFHIRPath.create('Error performing mod: left operand has more than one value'); + raise EFHIRPath.Create('Error performing mod: left operand has more than one value'); if (not left[0].value.isPrimitive()) then - raise EFHIRPath.create(StringFormat('Error performing mod: left operand has the wrong type (%s)', [left[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing mod: left operand has the wrong type (%s)', [left[0].value.fhirType()])); if (right.count = 0) then - raise EFHIRPath.create('Error performing mod: right operand has no value'); + raise EFHIRPath.Create('Error performing mod: right operand has no value'); if (right.count > 1) then - raise EFHIRPath.create('Error performing mod: right operand has more than one value'); + raise EFHIRPath.Create('Error performing mod: right operand has more than one value'); if (not right[0].value.isPrimitive()) then - raise EFHIRPath.create(StringFormat('Error performing mod: right operand has the wrong type (%s)', [right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing mod: right operand has the wrong type (%s)', [right[0].value.fhirType()])); result := TFHIRSelectionList.Create(); try @@ -5336,17 +5409,17 @@ function TFHIRPathEngine.opMod(left, right: TFHIRSelectionList): TFHIRSelectionL if (l.hasType('integer')) and (r.hasType('integer')) then begin if r.primitiveValue() <> '0' then - result.add(TFHIRInteger.create(inttostr(strToInt(l.primitiveValue()) mod strToInt(r.primitiveValue()))).noExtensions) + result.add(TFHIRInteger.Create(inttostr(strToInt(l.primitiveValue()) mod strToInt(r.primitiveValue()))).noExtensions) end else if (l.hasType(['integer', 'decimal'])) and (r.hasType(['integer', 'decimal'])) then begin d1 := TFslDecimal.valueOf(l.primitiveValue()); d2 := TFslDecimal.valueOf(r.primitiveValue()); d3 := d1.Modulo(d2); - result.add(TFHIRDecimal.create(d3.asDecimal).noExtensions); + result.add(TFHIRDecimal.Create(d3.asDecimal).noExtensions); end else - raise EFHIRPath.create(StringFormat('Error performing mod: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing mod: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); result.Link; finally @@ -5443,13 +5516,13 @@ function TFHIRPathEngine.opConcatenate(left, right: TFHIRSelectionList): TFHIRSe l, r : String; begin if (left.count > 1) then - raise EFHIRPath.create('Error performing &: left operand has more than one value'); + raise EFHIRPath.Create('Error performing &: left operand has more than one value'); if (left.Count = 1) and (not left[0].value.hasType(FHIR_TYPES_STRING)) then - raise EFHIRPath.create(StringFormat('Error performing &: left operand has the wrong type (%s)', [left[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing &: left operand has the wrong type (%s)', [left[0].value.fhirType()])); if (right.count > 1) then - raise EFHIRPath.create('Error performing &: right operand has more than one value'); + raise EFHIRPath.Create('Error performing &: right operand has more than one value'); if (right.Count = 1) and (not right[0].value.hasType(FHIR_TYPES_STRING)) then - raise EFHIRPath.create(StringFormat('Error performing &: right operand has the wrong type (%s)', [right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing &: right operand has the wrong type (%s)', [right[0].value.fhirType()])); result := TFHIRSelectionList.Create(); try @@ -5461,7 +5534,7 @@ function TFHIRPathEngine.opConcatenate(left, right: TFHIRSelectionList): TFHIRSe r := '' else r := right[0].value.primitiveValue(); - result.add(TFHIRString.create(l + r).noExtensions); + result.add(TFHIRString.Create(l + r).noExtensions); result.Link; finally result.free; @@ -5476,13 +5549,13 @@ function TFHIRPathEngine.opPlus(left, right: TFHIRSelectionList): TFHIRSelection if (left.count = 0) or (right.count = 0) then exit(TFHIRSelectionList.Create); if (left.count > 1) then - raise EFHIRPath.create('Error performing +: left operand has more than one value'); + raise EFHIRPath.Create('Error performing +: left operand has more than one value'); if (not left[0].value.isPrimitive()) then - raise EFHIRPath.create(StringFormat('Error performing +: left operand has the wrong type (%s)', [left[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing +: left operand has the wrong type (%s)', [left[0].value.fhirType()])); if (right.count > 1) then - raise EFHIRPath.create('Error performing +: right operand has more than one value'); + raise EFHIRPath.Create('Error performing +: right operand has more than one value'); if (not right[0].value.isPrimitive() and not ((left[0].value.isDateTime() or ('0' = left[0].value.primitiveValue) or left[0].value.hasType('Quantity')) and right[0].value.hasType('Quantity'))) then - raise EFHIRPath.create(StringFormat('Error performing +: right operand has the wrong type (%s)', [right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing +: right operand has the wrong type (%s)', [right[0].value.fhirType()])); result := TFHIRSelectionList.Create(); try @@ -5490,20 +5563,20 @@ function TFHIRPathEngine.opPlus(left, right: TFHIRSelectionList): TFHIRSelection r := right[0].value; if (l.hasType(['string', 'id', 'code', 'uri'])) and (r.hasType(['string', 'id', 'code', 'uri'])) then - result.add(TFHIRString.create(l.primitiveValue() + r.primitiveValue()).noExtensions) + result.add(TFHIRString.Create(l.primitiveValue() + r.primitiveValue()).noExtensions) else if (l.hasType('integer')) and (r.hasType('integer')) then - result.add(TFHIRInteger.create(inttostr(strToInt(l.primitiveValue()) + strToInt(r.primitiveValue()))).noExtensions) + result.add(TFHIRInteger.Create(inttostr(strToInt(l.primitiveValue()) + strToInt(r.primitiveValue()))).noExtensions) else if (l.hasType(['integer', 'decimal'])) and (r.hasType(['integer', 'decimal'])) then begin d1 := TFslDecimal.valueOf(l.primitiveValue()); d2 := TFslDecimal.valueOf(r.primitiveValue()); d3 := d1.Add(d2); - result.add(TFHIRDecimal.create(d3.asDecimal).noExtensions); + result.add(TFHIRDecimal.Create(d3.asDecimal).noExtensions); end else if (l.isDateTime) and (r.hasType('Quantity')) then result.add(dateAdd(l, r as TFHIRQuantity, false)) else - raise EFHIRPath.create(StringFormat('Error performing +: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing +: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); result.Link; finally result.free; @@ -5517,17 +5590,17 @@ function TFHIRPathEngine.opTimes(left, right: TFHIRSelectionList): TFHIRSelectio p, pl, pr : TUcumPair; begin if (left.count = 0) then - raise EFHIRPath.create('Error performing *: left operand has no value'); + raise EFHIRPath.Create('Error performing *: left operand has no value'); if (left.count > 1) then - raise EFHIRPath.create('Error performing *: left operand has more than one value'); + raise EFHIRPath.Create('Error performing *: left operand has more than one value'); if (not left[0].value.isPrimitive()) and not left[0].value.hasType('Quantity') then - raise EFHIRPath.create(StringFormat('Error performing +: left operand has the wrong type (%s)', [left[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing +: left operand has the wrong type (%s)', [left[0].value.fhirType()])); if (right.count = 0) then - raise EFHIRPath.create('Error performing *: right operand has no value'); + raise EFHIRPath.Create('Error performing *: right operand has no value'); if (right.count > 1) then - raise EFHIRPath.create('Error performing *: right operand has more than one value'); + raise EFHIRPath.Create('Error performing *: right operand has more than one value'); if (not right[0].value.isPrimitive()) and not right[0].value.hasType('Quantity') then - raise EFHIRPath.create(StringFormat('Error performing *: right operand has the wrong type (%s)', [right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing *: right operand has the wrong type (%s)', [right[0].value.fhirType()])); result := TFHIRSelectionList.Create(); try @@ -5535,7 +5608,7 @@ function TFHIRPathEngine.opTimes(left, right: TFHIRSelectionList): TFHIRSelectio r := right[0].value; if (l.hasType('integer')) and (r.hasType('integer')) then - result.add(TFHIRInteger.create(inttostr(strToInt(l.primitiveValue()) * strToInt(r.primitiveValue()))).noExtensions) + result.add(TFHIRInteger.Create(inttostr(strToInt(l.primitiveValue()) * strToInt(r.primitiveValue()))).noExtensions) else if (l.hasType(['Quantity'])) and (r.hasType(['Quantity'])) and (FUcum <> nil) and FUcum.isConfigured then begin pl := qtyToPair(l as TFHIRQuantity); @@ -5563,10 +5636,10 @@ function TFHIRPathEngine.opTimes(left, right: TFHIRSelectionList): TFHIRSelectio d1 := TFslDecimal.valueOf(l.primitiveValue()); d2 := TFslDecimal.valueOf(r.primitiveValue()); d3 := d1.Multiply(d2); - result.add(TFHIRDecimal.create(d3.asDecimal).noExtensions); + result.add(TFHIRDecimal.Create(d3.asDecimal).noExtensions); end else - raise EFHIRPath.create(StringFormat('Error performing /: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing /: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); result.link; finally result.free; @@ -5662,7 +5735,7 @@ function TFHIRPathEngine.resolveConstant(context : TFHIRPathExecutionContext; co else if (c.FValue.startsWith('@')) then result := processDateConstant(context.appInfo, c.FValue.substring(1)) else - raise EFHIRPath.create('Invaild FHIR Constant '+c.FValue); + raise EFHIRPath.Create('Invaild FHIR Constant '+c.FValue); end; function TFHIRPathEngine.processDateConstant(appinfo : TFslObject; value : String) : TFHIRObject; @@ -5671,7 +5744,7 @@ function TFHIRPathEngine.processDateConstant(appinfo : TFslObject; value : Strin v : string; begin if (value.startsWith('T')) then - exit(TFHIRTime.create(value.substring(1)).noExtensions()); + exit(TFHIRTime.Create(value.substring(1)).noExtensions()); v := value; if (v.length > 10) then @@ -5685,9 +5758,9 @@ function TFHIRPathEngine.processDateConstant(appinfo : TFslObject; value : Strin v := v.substring(0, 10+i); end; if (v.length > 10) then - result := TFHIRDateTime.create(TFslDateTime.fromXML(value)).noExtensions() + result := TFHIRDateTime.Create(TFslDateTime.fromXML(value)).noExtensions() else - result := TFHIRDate.create(TFslDateTime.fromXML(value)).noExtensions(); + result := TFHIRDate.Create(TFslDateTime.fromXML(value)).noExtensions(); end; function TFHIRPathEngine.qtyEqual(left, right: TFHIRQuantity): TEqualityTriState; @@ -5818,27 +5891,27 @@ function TFHIRPathEngine.resolveConstant(context : TFHIRPathExecutionContext; s ext : TFHIRPathEngineExtension; begin if (s = '%sct') then - result := TFHIRString.create(URI_SNOMED).noExtensions() + result := TFHIRString.Create(URI_SNOMED).noExtensions() else if (s = '%loinc') then - result := TFHIRString.create(URI_LOINC).noExtensions() + result := TFHIRString.Create(URI_LOINC).noExtensions() else if (s = '%ucum') then - result := TFHIRString.create(URI_UCUM).noExtensions() + result := TFHIRString.Create(URI_UCUM).noExtensions() else if (s = '%resource') then begin if (context.resource = nil) then - raise EFHIRPath.create('Cannot use %resource in this context'); + raise EFHIRPath.Create('Cannot use %resource in this context'); result := context.resource.Link; end else if (s = '%context') then result := context.context.link else if (s = '%us-zip') then - result := TFHIRString.create('[0-9]{5}(-[0-9]{4}){0,1}').noExtensions() + result := TFHIRString.Create('[0-9]{5}(-[0-9]{4}){0,1}').noExtensions() else if (s.startsWith('%`vs-')) then - result := TFHIRString.create('http://hl7.org/fhir/ValueSet/'+s.substring(5, s.length-6)).noExtensions() + result := TFHIRString.Create('http://hl7.org/fhir/ValueSet/'+s.substring(5, s.length-6)).noExtensions() else if (s.startsWith('%`cs-')) then - result := TFHIRString.create('http://hl7.org/fhir/'+s.substring(5, s.length-1)).noExtensions() + result := TFHIRString.Create('http://hl7.org/fhir/'+s.substring(5, s.length-1)).noExtensions() else if (s.startsWith('%`ext-')) then - result := TFHIRString.create('http://hl7.org/fhir/StructureDefinition/'+s.substring(6, s.length-7)).noExtensions() + result := TFHIRString.Create('http://hl7.org/fhir/StructureDefinition/'+s.substring(6, s.length-7)).noExtensions() else begin for ext in FExtensions do @@ -5846,7 +5919,7 @@ function TFHIRPathEngine.resolveConstant(context : TFHIRPathExecutionContext; s if ext.resolveConstant(context, s, result) then exit; end; - raise EFHIRPath.create('Unknown fixed constant "'+s+'"') + raise EFHIRPath.Create('Unknown fixed constant "'+s+'"') end; end; @@ -5869,7 +5942,7 @@ function TFHIRPathEngine.execute(context : TFHIRPathExecutionContext; focus: TFH else if atEntry and (exp.name = '$total') then work.addAll(context.total) else if atEntry and (exp.name = '$index') then - work.add(TFHIRInteger.create(context.index)) + work.add(TFHIRInteger.Create(context.index)) else for item in focus do begin @@ -5976,10 +6049,10 @@ function TFHIRPathEngine.execute(context : TFHIRPathExecutionContext; focus: TFH function TFHIRPathEngine.executeType(focus: String; exp: TFHIRPathExpressionNode; atEntry : boolean): TFHIRTypeDetails; begin if (atEntry and exp.Name[1].IsUpper) and (focus = TFHIRProfiledType.ns(exp.Name)) then - result := TFHIRTypeDetails.create(csSINGLETON, [focus]) + result := TFHIRTypeDetails.Create(csSINGLETON, [focus]) else begin - result := TFHIRTypeDetails.create(csNULL, []); + result := TFHIRTypeDetails.Create(csNULL, []); try ListChildTypesByName(focus, exp.name, result); result.Link; @@ -6089,9 +6162,10 @@ function TFHIRPathEngine.evaluateFunction(context : TFHIRPathExecutionContext; f pfLowBoundary : result := funcLowBoundary(context, focus, exp); pfHighBoundary : result := funcHighBoundary(context, focus, exp); pfPrecision : result := funcPrecision(context, focus, exp); + pfComparable : result := funcComparable(context, focus, exp); pfCustom : result := funcCustom(context, focus, exp); else - raise EFHIRPath.create('Unknown Function '+exp.name); + raise EFHIRPath.Create('Unknown Function '+exp.name); end; end; @@ -6134,7 +6208,7 @@ function TFHIRPathEngine.funcCustom(context : TFHIRPathExecutionContext; focus: end; end; if not done and (not couldHaveBeen or (focus.Count > 0)) then - raise EFHIRPath.create('Unknown Function '+exp.name); + raise EFHIRPath.Create('Unknown Function '+exp.name); result.Link; finally result.free; @@ -6236,7 +6310,7 @@ procedure TFHIRPathEngine.checkParamTypes(funcId : TFHIRPathFunction; paramTypes sd := context.fetchStructureDefinition(sd.baseDefinition); end; if (not ok) then - raise EFHIRPath.create('The parameter type "'+a.uri+'" is not legal for '+CODES_TFHIRPathFunctions[funcId]+' parameter '+Integer.toString(i)+', expecting '+pt.describe()); + raise EFHIRPath.Create('The parameter type "'+a.uri+'" is not legal for '+CODES_TFHIRPathFunctions[funcId]+' parameter '+Integer.toString(i)+', expecting '+pt.describe()); end; end; end; @@ -6250,7 +6324,7 @@ function TFHIRPathEngine.childTypes(focus : TFHIRTypeDetails; mask : string) : T var f : TFHIRProfiledType; begin - result := TFHIRTypeDetails.create(csUNORDERED, []); + result := TFHIRTypeDetails.Create(csUNORDERED, []); try for f in focus.types do ListChildTypesByName(f.uri, mask, result); @@ -6287,7 +6361,7 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon paramTypes := TFslList.Create; try if (exp.FunctionId in [pfIs, pfAs, pfOfType]) then - paramTypes.add(TFHIRTypeDetails.create(csSINGLETON, [FP_string])) + paramTypes.add(TFHIRTypeDetails.Create(csSINGLETON, [FP_string])) else begin i := 0; @@ -6310,27 +6384,27 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon case exp.FunctionId of pfEmpty : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfNot : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfExists : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfSubsetOf : begin checkParamTypes(exp.FunctionId, paramTypes, [focus.link]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfSupersetOf : begin checkParamTypes(exp.FunctionId, paramTypes, [focus.link]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfIsDistinct : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfDistinct : result := focus.Link; pfCount : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_integer]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_integer]); pfWhere : if (focus.hasType(self.context, 'Reference')) then begin @@ -6363,7 +6437,7 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon pfSelect : result := paramTypes[0].link; pfAll : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfRepeat : result := TFHIRTypeDetails.createList(focus.CollectionStatus, allTypes); pfAggregate : @@ -6371,14 +6445,14 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon pfItem : begin if (focus.CollectionStatus = csUNORDERED) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_integer])]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_integer])]); result := focus.Link; end; pfOfType : begin - checkParamTypes(exp.FunctionId, paramTypes, TFHIRTypeDetails.create(csSINGLETON, [FP_String])); - result := TFHIRTypeDetails.create(csSINGLETON, [exp.Parameters[0].name]); + checkParamTypes(exp.FunctionId, paramTypes, TFHIRTypeDetails.Create(csSINGLETON, [FP_String])); + result := TFHIRTypeDetails.Create(csSINGLETON, [exp.Parameters[0].name]); end; pfType : begin @@ -6390,54 +6464,54 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon c := c or not pt.isSystemType(); end; if (s and c) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_SimpleTypeInfo, FP_ClassInfo]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_SimpleTypeInfo, FP_ClassInfo]) else if (s) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_SimpleTypeInfo]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_SimpleTypeInfo]) else - result := TFHIRTypeDetails.create(csSINGLETON, [FP_ClassInfo]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_ClassInfo]); end; pfAs : begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, exp.Parameters[0].Name); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, exp.Parameters[0].Name); end; pfIs : begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfSingle : result := focus.toSingleton(); pfFirst : begin if (focus.CollectionStatus = csUNORDERED) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); result := focus.toSingleton(); end; pfLast : begin if (focus.CollectionStatus = csUNORDERED) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); result := focus.toSingleton(); end; pfTail : begin if (focus.CollectionStatus = csUNORDERED) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); result := focus.Link; end; pfSkip : begin if (focus.CollectionStatus = csUNORDERED) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_integer])]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_integer])]); result := focus.Link; end; pfTake : begin if (focus.CollectionStatus = csUNORDERED) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_integer])]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_integer])]); result := focus.Link; end; pfUnion : @@ -6450,7 +6524,7 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon result := focus.link; pfIif : begin - result := TFHIRTypeDetails.create(csNull, []); + result := TFHIRTypeDetails.Create(csNull, []); result.update(paramTypes[0]); if (paramTypes.count > 1) then result.update(paramTypes[1]); @@ -6458,75 +6532,75 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon pfLower : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_string]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_string]); end; pfUpper : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_string]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_string]); end; pfToChars : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_string]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_string]); end; pfSubstring : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_Integer]), TFHIRTypeDetails.create(csSINGLETON, [FP_integer])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_string]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_Integer]), TFHIRTypeDetails.Create(csSINGLETON, [FP_integer])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_string]); end; pfStartsWith : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfEndsWith : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfMatches, pfMatchesFull : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfReplaceMatches : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string]), TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_string]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string]), TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_string]); end; pfContains : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfReplace : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string]), TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_string]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string]), TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_string]); end; pfLength : begin if (not focus.hasType(self.context, primitiveTypes)) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_integer]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_integer]); end; pfChildren : result := childTypes(focus, '*'); @@ -6535,218 +6609,220 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon pfMemberOf : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'Coding', 'CodeableConcept'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, Coding, CodeableConcept not '+focus.describe); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, Coding, CodeableConcept not '+focus.describe); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfTrace : begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); result := focus.Link; end; pfToday : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_DateTime]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_DateTime]); pfNow : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_dateTime]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_dateTime]); pfResolve : begin if (not focus.hasType(self.context, ['uri', 'Reference'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on uri, Reference not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, ['DomainResource']); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on uri, Reference not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, ['DomainResource']); end; pfExtension : begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, ['Extension']); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, ['Extension']); end; pfHasExtension : begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfAllFalse: - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfAnyFalse: - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfAllTrue: - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfAnyTrue: - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfElementDefinition: begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, ['ElementDefinition']); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, ['ElementDefinition']); end; pfSlice: begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string, FP_string])]); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string, FP_string])]); result := focus.Link; end; pfCheckModifiers: begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csUNORDERED, [FP_string])]); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csUNORDERED, [FP_string])]); result := focus.Link; end; pfConformsTo: begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfHasValue: - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfHtmlChecks: - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfToInteger : begin if (not focus.hasType(self.context, primitiveTypes)) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_integer]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_integer]); end; pfToDecimal : begin if (not focus.hasType(self.context, primitiveTypes)) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_decimal]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_decimal]); end; pfToString : begin if (not focus.hasType(self.context, primitiveTypes) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_string]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_string]); end; pfToQuantity : begin if (not focus.hasType(self.context, primitiveTypes) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Quantity]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Quantity]); end; pfToBoolean : begin if (not focus.hasType(self.context, primitiveTypes)) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Boolean]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Boolean]); end; pfToDateTime : begin if (not focus.hasType(self.context, primitiveTypes)) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_DateTime]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_DateTime]); end; pfToTime : begin if (not focus.hasType(self.context, primitiveTypes)) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Time]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Time]); end; pfAbs : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfCeiling : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfExp : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfFloor : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfLn : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfLog : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfPower : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfTruncate : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfRound : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfSqrt : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfConvertsToString, pfConvertsToQuantity : begin if (not focus.hasType(self.context, primitiveTypes) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Boolean]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Boolean]); end; pfConvertsToInteger, pfConvertsToDecimal, pfConvertsToDateTime, pfConvertsToDate, pfConvertsToTime, pfConvertsToBoolean : begin if (not focus.hasType(self.context, primitiveTypes)) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Boolean]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Boolean]); end; pfForHtml, pfEncode, pfDecode, pfEscape, pfUnescape, pfTrim : begin - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]); end; pfSplit : - result := TFHIRTypeDetails.create(csORDERED, [FP_String]); + result := TFHIRTypeDetails.Create(csORDERED, [FP_String]); pfJoin : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]); pfIndexOf : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Integer]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Integer]); pfLowBoundary, pfHighBoundary : begin if (not focus.hasNoTypes() and not focus.hasType(self.context, 'decimal') and not focus.hasType(self.context, 'date') and not focus.hasType(self.context, 'dateTime') and not focus.hasType(self.context, 'time') and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on decimal, date, datetime, instant, time and Quantity, not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on decimal, date, datetime, instant, time and Quantity, not '+focus.describe); if (paramTypes.count > 0) then - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_Integer])]); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_Integer])]); if (focus.hasType(self.context, 'date') or focus.hasType(self.context, 'dateTime') or focus.hasType(self.context, 'instant')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_DateTime]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_DateTime]) else if (focus.hasType(self.context, 'decimal')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Decimal]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Decimal]) else if (focus.hasType(self.context, 'time')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Time]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Time]) else - result := TFHIRTypeDetails.create(csSINGLETON, []) + result := TFHIRTypeDetails.Create(csSINGLETON, []) end; pfPrecision : begin if (not focus.hasNoTypes() and not focus.hasType(self.context, 'decimal') and not focus.hasType(self.context, 'date') and not focus.hasType(self.context, 'dateTime') and not focus.hasType(self.context, 'time') and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on decima;, date, datetime, instant, time and Quantity, not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Integer]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on decima;, date, datetime, instant, time and Quantity, not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Integer]); end; + pfComparable : + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Boolean]); pfCustom : result := evaluateCustomFunctionType(context, focus, exp); else - raise EFHIRPath.create('not Implemented yet?'); + raise EFHIRPath.Create('not Implemented yet?'); end; finally paramTypes.free; @@ -6814,7 +6890,7 @@ function processDateConstant(s : String) : TFHIRDataType; // else if s = '%resource' then // begin // if (context.resource = nil) then -// raise EFHIRPath.create('%resource cannot be used in this context'); +// raise EFHIRPath.Create('%resource cannot be used in this context'); // result := context.resource.link; // end // else if s = '%us-zip' then @@ -6826,7 +6902,7 @@ function processDateConstant(s : String) : TFHIRDataType; // else if s.StartsWith('%"ext-') then // result := TFhirString.Create('http://hl7.org/fhir/StructureDefinition/'+s.Substring(6, s.length-7)).noExtensions // else -// raise EFHIRPath.create('Unknown fixed constant '+s); +// raise EFHIRPath.Create('Unknown fixed constant '+s); //end; // @@ -6886,7 +6962,7 @@ procedure TFHIRPathEngine.ListChildTypesByName(type_, name : String; result : TF rt : TFslStringSet; begin if (type_ = '') then - raise EFHIRPath.create('No type provided in BuildToolPathEvaluator.ListChildTypesByName'); + raise EFHIRPath.Create('No type provided in BuildToolPathEvaluator.ListChildTypesByName'); if (type_ = 'http://hl7.org/fhir/StructureDefinition/xhtml') then exit; if (type_ = 'Custom') or (type_ = 'http://hl7.org/fhir/StructureDefinition/Custom') then @@ -6919,7 +6995,7 @@ procedure TFHIRPathEngine.ListChildTypesByName(type_, name : String; result : TF sd := worker.fetchStructureDefinition(url); if (sd = nil) then - raise EFHIRPath.create('Unknown type '+type_); // this really is an error, because we can only get to here if the internal infrastrucgture is wrong + raise EFHIRPath.Create('Unknown type '+type_); // this really is an error, because we can only get to here if the internal infrastrucgture is wrong m := nil; sdl := TFslList.Create; try @@ -6931,7 +7007,7 @@ procedure TFHIRPathEngine.ListChildTypesByName(type_, name : String; result : TF begin dt := worker.fetchStructureDefinition('http://hl7.org/fhir/StructureDefinition/'+specifiedType); if (dt = nil) then - raise EFHIRPath.create('unknown data type '+specifiedType); + raise EFHIRPath.Create('unknown data type '+specifiedType); sdl.add(dt); end else @@ -6939,7 +7015,7 @@ procedure TFHIRPathEngine.ListChildTypesByName(type_, name : String; result : TF begin dt := worker.fetchStructureDefinition('http://hl7.org/fhir/StructureDefinition/'+t.Code) as TFhirStructureDefinition; if (dt = nil) then - raise EFHIRPath.create('unknown data type '+t.code); + raise EFHIRPath.Create('unknown data type '+t.code); sdl.add(dt); end; end @@ -7028,7 +7104,7 @@ procedure TFHIRPathEngine.ListChildTypesByName(type_, name : String; result : TF for t in ed.type_list do begin if (t.code = '') then - break; // raise EFHIRPath.create('Illegal reference to primitive value attribute @ '+path); + break; // raise EFHIRPath.Create('Illegal reference to primitive value attribute @ '+path); if (t.code = 'Element') or (t.code = 'BackboneElement') then result.addType(path) @@ -7124,11 +7200,11 @@ function TFHIRPathEngine.getElementDefinition(sd : TFHIRStructureDefinition; pat // now we walk into the type. if (ed.type_list.count > 1) then // if there's more than one type, the test above would fail this - raise EFHIRException.create('Internal typing issue....'); + raise EFHIRException.Create('Internal typing issue....'); sd := worker.getStructure('http://hl7.org/fhir/StructureDefinition/'+ed.type_List[0].code); try if (sd = nil) then - raise EDefinitionException.create('Unknown type '+ed.type_List[0].code); + raise EDefinitionException.Create('Unknown type '+ed.type_List[0].code); result := getElementDefinition(sd, sd.id+path.Substring(ed.path.Length), true, specifiedType); finally sd.free; @@ -7166,7 +7242,7 @@ function TFHIRPathEngine.sizeInBytesV(magic : integer) : cardinal; result := inherited sizeInBytesV(magic); inc(result, worker.sizeInBytes(magic)); inc(result, allTypes.sizeInBytes(magic)); - inc(result, primitiveTypes.sizeInBytes(magic)); + inc(result, primitiveTypes.sizeInBytes(magic)); inc(result, FUcum.sizeInBytes(magic)); end; @@ -7212,7 +7288,7 @@ function TFHIRPathExecutionTypeContext.sizeInBytesV(magic : integer) : cardinal; inc(result, FContext.sizeInBytes(magic)); end; -{ TFHIRPathLexer5 } +{ TFHIRPathLexer4 } function TFHIRPathLexer5.opCodes: TArray; @@ -7232,20 +7308,20 @@ function TFHIRPathLexer5.opCodes: TArray; function TFHIRPathLexer5.processConstant : TFHIRObject; begin if (isStringConstant()) then - result := TFHIRString.create(TFHIRPathLexer.processConstant(take())).noExtensions() + result := TFHIRString.Create(TFHIRPathLexer.processConstant(take())).noExtensions() else if (StringIsInteger32(current)) then - result := TFHIRInteger.create(take).noExtensions() + result := TFHIRInteger.Create(take).noExtensions() else if (StringIsDecimal(current)) then - result := TFHIRDecimal.create(take).noExtensions() + result := TFHIRDecimal.Create(take).noExtensions() else if (StringArrayExistsSensitive(['true', 'false'], current)) then - result := TFHIRBoolean.create(take = 'true').noExtensions() + result := TFHIRBoolean.Create(take = 'true').noExtensions() else if (current = '{}') then begin take; result := nil; end else if (current.startsWith('%') or current.startsWith('@')) then - result := TFHIRConstant.create(take) + result := TFHIRConstant.Create(take) else raise error('Invalid Constant '+current); end; diff --git a/library/fhir5/fhir5_pathnode.pas b/library/fhir5/fhir5_pathnode.pas index 14c6c4849..f022508c3 100644 --- a/library/fhir5/fhir5_pathnode.pas +++ b/library/fhir5/fhir5_pathnode.pas @@ -56,7 +56,7 @@ interface pfToBoolean, pfToInteger, pfToString, pfToDecimal, pfToQuantity, pfToDateTime, pfToTime, pfAbs, pfCeiling, pfExp, pfFloor, pfLn, pfLog, pfPower, pfTruncate, pfRound, pfSqrt, pfForHtml, pfEncode, pfDecode, pfEscape, pfUnescape, pfTrim, pfSplit, pfJoin, pfIndexOf, - pfLowBoundary, pfHighBoundary, pfPrecision, + pfLowBoundary, pfHighBoundary, pfPrecision, pfComparable, pfCustom); TFHIRPathExpressionNodeKind = (enkName, enkFunction, enkConstant, enkGroup, enkStructure, enkUnary); // structure is not used in fhir4_pathengine, but is in CQL @@ -78,7 +78,7 @@ interface 'toBoolean', 'toInteger', 'toString', 'toDecimal', 'toQuantity', 'toDateTime', 'toTime', 'abs', 'ceiling', 'exp', 'floor', 'ln', 'log', 'power', 'truncate', 'round', 'sqrt', 'forHtml', 'encode', 'decode', 'escape', 'unescape', 'trim', 'split', 'join', 'indexOf', - 'lowBoundary', 'highBoundary', 'precision', + 'lowBoundary', 'highBoundary', 'precision', 'comparable', 'xx-custom-xx'); FHIR_SD_NS = 'http://hl7.org/fhir/StructureDefinition/'; diff --git a/library/fsl/fsl_fpc.pas b/library/fsl/fsl_fpc.pas index e70a0685c..e8a6f0d13 100644 --- a/library/fsl/fsl_fpc.pas +++ b/library/fsl/fsl_fpc.pas @@ -39,7 +39,7 @@ interface {$IFDEF LINUX} baseunix, unix, {$ENDIF} - Classes, SysUtils, SyncObjs, Contnrs, Character, Generics.Collections, ZLib, ZStream, Types + Classes, SysUtils, SyncObjs, Contnrs, Character, Generics.Collections, Types {$IFDEF FPC}, {$IFDEF OSX} MacOSAll, CFBase, CFString, @@ -124,98 +124,6 @@ procedure FileSetModified(const FileName : String; dateTime : TDateTime); //function ColorToString(Color: TColor): AnsiString; - -type - TZDecompressionStream = TDecompressionStream; - TZCompressionStream = TCompressionStream; - -//type -// TZCompressionLevel = (zcNone, zcFastest, zcDefault, zcMax); -// -// // CG: Define old enum for compression level -// TCompressionLevel = (clNone = Integer(zcNone), clFastest, clDefault, clMax); -// -// TZStreamRec = z_stream; -// -// {** TCustomZStream ********************************************************} -// -// TCustomZStream = class(TStream) -// private -// FStream: TStream; -// FStreamStartPos: Int64; -// FStreamPos: Int64; -// FOnProgress: TNotifyEvent; -// FZStream: TZStreamRec; -// FBuffer: TBytes; -// public -// constructor Create(stream: TStream); -// procedure DoProgress; dynamic; -// property OnProgress: TNotifyEvent read FOnProgress write FOnProgress; -// end; -// // CG: Add alias of classname to old Zlib classname -// TCustomZLibStream = TCustomZStream; -// -// {** TZCompressionStream ***************************************************} -// -// TZCompressionStream = class(TCustomZStream) -// private -// function GetCompressionRate: Single; -// public -// constructor Create(dest: TStream); overload; -// constructor Create(dest: TStream; compressionLevel: TZCompressionLevel; windowBits: Integer); overload; -// // CG: Add overloaded constructor for old parameter type and order -// constructor Create(compressionLevel: TCompressionLevel; dest: TStream); overload; -// destructor Destroy; override; -// function Read(var buffer; count: Longint): Longint; override; -// function Write(const buffer; count: Longint): Longint; override; -// -// function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; -// property CompressionRate: Single read GetCompressionRate; -// property OnProgress; -// end; -// -// // CG: Add alias of classname to old Zlib classname -// TCompressionStream = TZCompressionStream; -// -// {** TZDecompressionStream *************************************************} -// -// TZDecompressionStream = class(TCustomZStream) -// private -// FOwnsStream: Boolean; -// public -// constructor Create(source: TStream); overload; -// constructor Create(source: TStream; WindowBits: Integer); overload; -// constructor Create(source: TStream; WindowBits: Integer; OwnsStream: Boolean); overload; -// destructor Destroy; override; -// function Read(var buffer; count: Longint): Longint; override; -// function Write(const buffer; count: Longint): Longint; override; -// function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; -// property OnProgress; -// end; -// // CG: Add alias of classname to old Zlib classname -// TDecompressionStream = TZDecompressionStream; -// -//const -// ZLevels: array[TZCompressionLevel] of Shortint = ( -// Z_NO_COMPRESSION, -// Z_BEST_SPEED, -// Z_DEFAULT_COMPRESSION, -// Z_BEST_COMPRESSION -// ); -// -// _z_errmsg: array [0..9] of String = ( -// 'need dictionary', // Z_NEED_DICT (2) -// 'stream end', // Z_STREAM_END (1) -// '', // Z_OK (0) -// 'file error', // Z_ERRNO (-1) -// 'stream error', // Z_STREAM_ERROR (-2) -// 'data error', // Z_DATA_ERROR (-3) -// 'insufficient memory', // Z_MEM_ERROR (-4) -// 'buffer error', // Z_BUF_ERROR (-5) -// 'incompatible version', // Z_VERSION_ERROR (-6) -// '' -// ); - {$ENDIF} {$IFDEF FPC} @@ -280,18 +188,21 @@ procedure setCurrentDirectory(dir : String); function unicodeChars(s : String) : TUCharArray; var i, c, l, cl : integer; - ch : UnicodeChar; + ch : LongWord; p: PChar; + ss : String; begin l := length(s); SetLength(result, l); // maximum possible length i := 0; c := 1; p := @s[1]; + ss := ''; while l > 0 do begin - ch := UnicodeChar(UTF8CodepointToUnicode(p, cl)); - result[i] := ch; + ch := UTF8CodepointToUnicode(p, cl); + result[i] := UnicodeChar(ch); + ss := ss + IntToHex(ch, 4)+'.'; inc(i); dec(l, cl); inc(p, cl); @@ -500,281 +411,6 @@ function TryEnterCriticalSection(var cs : TRTLCriticalSection) : boolean; begin result := System.TryEnterCriticalSection(cs) > 0; end; -// -//function ZCompressCheck(code: Integer): Integer; overload; -//begin -// Result := code; -// -// if code < 0 then -// raise EIOException.Create(string(_z_errmsg[2 - code])); -//end; -// -//function ZCompressCheckWithoutBufferError(code: Integer): Integer; overload; -// begin -// Result := code; -// -// if code < 0 then -// if (code <> Z_BUF_ERROR) then -// raise EIOException.Create(string(_z_errmsg[2 - code])); -// end; -// -//function ZDecompressCheck(code: Integer): Integer; overload; -//begin -// Result := code; -// -// if code < 0 then -// raise EIOException.Create(string(_z_errmsg[2 - code])); -//end; -// -//function ZDecompressCheckWithoutBufferError(code: Integer): Integer; overload; -//begin -// Result := code; -// -// if code < 0 then -// if (code <> Z_BUF_ERROR) then -// raise EIOException.Create(string(_z_errmsg[2 - code])); -// end; -// -// -// -//{ TCustomZStream } -// -//constructor TCustomZStream.Create(stream: TStream); -//begin -// inherited Create; -// FStream := stream; -// FStreamStartPos := Stream.Position; -// FStreamPos := FStreamStartPos; -// SetLength(FBuffer, $10000); -// end; -// -//procedure TCustomZStream.DoProgress; -//begin -// if Assigned(FOnProgress) then FOnProgress(Self); -//end; -// -// -//{ TZCompressionStream } -// -//constructor TZCompressionStream.Create(dest: TStream); -//begin -// Create(dest, zcDefault, 15); -//end; -// -//constructor TZCompressionStream.Create(dest: TStream; -// compressionLevel: TZCompressionLevel; windowBits: Integer); -//begin -// inherited Create(dest); -// -// FZStream.next_out := @FBuffer[0]; -// FZStream.avail_out := Length(FBuffer); -// -// ZCompressCheck(DeflateInit2(FZStream, ZLevels[compressionLevel], Z_DEFLATED, windowBits, 8, Z_DEFAULT_STRATEGY)); -//end; -// -//constructor TZCompressionStream.Create(compressionLevel: TCompressionLevel; dest: TStream); -//begin -// Create(dest, TZCompressionLevel(Byte(compressionLevel)), 15); -//end; -// -//destructor TZCompressionStream.Destroy; -//begin -// FZStream.next_in := nil; -// FZStream.avail_in := 0; -// -// try -// if FStream.Position <> FStreamPos then FStream.Position := FStreamPos; -// -// while ZCompressCheckWithoutBufferError(deflate(FZStream, Z_FINISH)) <> Z_STREAM_END do -// begin -// FStream.WriteBuffer(FBuffer, Length(FBuffer) - Integer(FZStream.avail_out)); -// -// FZStream.next_out := @FBuffer[0]; -// FZStream.avail_out := Length(FBuffer); -// end; -// -// if Integer(FZStream.avail_out) < Length(FBuffer) then -// begin -// FStream.WriteBuffer(FBuffer, Length(FBuffer) - Integer(FZStream.avail_out)); -// end; -// finally -// deflateEnd(FZStream); -// end; -// -// inherited Destroy; -//end; -// -//function TZCompressionStream.Read(var buffer; count: Longint): Longint; -//begin -// result := 0; -// raise EIOException.Create('Cannot read from a compression stream'); -//end; -// -//function TZCompressionStream.Write(const buffer; count: Longint): Longint; -//begin -// FZStream.next_in := @buffer; -// FZStream.avail_in := count; -// -// if FStream.Position <> FStreamPos then FStream.Position := FStreamPos; -// -// while FZStream.avail_in > 0 do -// begin -// ZCompressCheckWithoutBufferError(deflate(FZStream, Z_NO_FLUSH)); -// -// if FZStream.avail_out = 0 then -// begin -// FStream.WriteBuffer(FBuffer, Length(FBuffer)); -// -// FZStream.next_out := @FBuffer[0]; -// FZStream.avail_out := Length(FBuffer); -// -// FStreamPos := FStream.Position; -// -// DoProgress; -// end; -//end; -// -// result := Count; -//end; -// -//function TZCompressionStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; -//begin -// if (offset = 0) and (origin = soCurrent) then -// begin -// result := FZStream.total_in; -// end -// else -// raise EIOException.Create('Invalid Operation'); -//end; -// -//function TZCompressionStream.GetCompressionRate: Single; -//begin -// if FZStream.total_in = 0 then result := 0 -// else result := (1.0 - (FZStream.total_out / FZStream.total_in)) * 100.0; -//end; -// -//{ TZDecompressionStream } -// -//constructor TZDecompressionStream.Create(source: TStream); -//begin -// Create(source, 15, False); -//end; -// -//constructor TZDecompressionStream.Create(source: TStream; WindowBits: Integer); -//begin -// Create(source, WindowBits, False); -//end; -// -//constructor TZDecompressionStream.Create(source: TStream; WindowBits: Integer; OwnsStream: Boolean); -//begin -// inherited Create(source); -// FZStream.next_in := @FBuffer[0]; -// FZStream.avail_in := 0; -// ZDecompressCheckWithoutBufferError(InflateInit2(FZStream, WindowBits)); -// FOwnsStream := OwnsStream; -//end; -// -//destructor TZDecompressionStream.Destroy; -//begin -// inflateEnd(FZStream); -// if FOwnsStream then -// FStream.free; -// inherited Destroy; -//end; -// -//function TZDecompressionStream.Read(var buffer; count: Longint): Longint; -//var -// zresult: Integer; -//begin -// FZStream.next_out := @buffer; -// FZStream.avail_out := count; -// -// if FStream.Position <> FStreamPos then FStream.Position := FStreamPos; -// -// zresult := Z_OK; -// -// while (FZStream.avail_out > 0) and (zresult <> Z_STREAM_END) do -// begin -// if FZStream.avail_in = 0 then -// begin -// FZStream.avail_in := FStream.Read(FBuffer[0], Length(FBuffer)); -// -// if FZStream.avail_in = 0 then -// begin -// result := NativeUInt(count) - FZStream.avail_out; -// -// Exit; -// end; -// if (length(FBuffer) = 0) then -// raise EFslException.Create('read File returned an empty buffer but claimed it wasn''t'); -// -// FZStream.next_in := @FBuffer[0]; -// FStreamPos := FStream.Position; -// -// DoProgress; -// end; -// -// zresult := ZDecompressCheckWithoutBufferError(inflate(FZStream, Z_NO_FLUSH)); -// end; -// -// if (zresult = Z_STREAM_END) and (FZStream.avail_in > 0) then -// begin -// FStream.Position := FStream.Position - FZStream.avail_in; -// FStreamPos := FStream.Position; -// -// FZStream.avail_in := 0; -// end; -// -// result := NativeUInt(count) - FZStream.avail_out; -//end; -// -//function TZDecompressionStream.Write(const buffer; count: Longint): Longint; -//begin -// result := 0; -// raise EIOException.Create('Invalid Operation'); -//end; -// -//function TZDecompressionStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; -//const -// BufSize = 8192; -//var -// buf: TBytes; -// i: Integer; -// localOffset: Int64; -//begin -// if (Offset = 0) and (Origin = soBeginning) then -// begin -// ZDecompressCheck(inflateReset(FZStream)); -// -// FZStream.next_in := @FBuffer; -// FZStream.avail_in := 0; -// -// FStream.Position := FStreamStartPos; -// FStreamPos := FStreamStartPos; -// end -// else if ((Offset >= 0) and (Origin = soCurrent)) or -// (((NativeUInt(offset) - FZStream.total_out) > 0) and (Origin = soBeginning)) then -// begin -// localOffset := Offset; -// if (Origin = soBeginning) then Dec(localOffset, FZStream.total_out); -// -// if localOffset > 0 then -// begin -// SetLength(buf, BufSize); -// for i := 1 to localOffset div BufSize do ReadBuffer(buf[0], BufSize); -// ReadBuffer(buf[0], localOffset mod BufSize); -// end; -// end -// else if (Offset = 0) and (Origin = soEnd) then -// begin -// SetLength(buf, BufSize); -// while Read(buf[0], BufSize) > 0 do ; -// end -// else -// raise EIOException.Create('Invalid Operation'); -// -// result := FZStream.total_out; -//end; {$ENDIF} diff --git a/library/fsl/fsl_gzip.pas b/library/fsl/fsl_gzip.pas new file mode 100644 index 000000000..4c8dcf0bb --- /dev/null +++ b/library/fsl/fsl_gzip.pas @@ -0,0 +1,65 @@ +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, zflate, + fsl_base; + +{ + for FPC, we use the zflate units by fibonacci. + for delphi, we use delphi's inbuilt ZLib support + + this unit is to handle the $IFDEF between the two (tbd) +} + +function gzip(bytes : TBytes; header : boolean; level: dword=9) : TBytes; +function ungzip(bytes : TBytes) : TBytes; + +implementation + +function gzip(bytes : TBytes; header : boolean; level: dword=9) : TBytes; +begin + result := zflate.gzcompress(bytes, level); +end; + +function ungzip(bytes : TBytes) : TBytes; +begin + result := zflate.zdecompress(bytes); + if zlastError <> 0 then + raise EFslException.create('Failed to read compressed content: '+zflatetranslatecode(zlasterror)); +end; + + +end. + diff --git a/library/fsl/fsl_npm.pas b/library/fsl/fsl_npm.pas index 205590b71..312e69edf 100644 --- a/library/fsl/fsl_npm.pas +++ b/library/fsl/fsl_npm.pas @@ -34,7 +34,7 @@ interface uses SysUtils, Classes, Types, {$IFDEF DELPHI}IOUtils, {$ENDIF} zlib, - fsl_base, fsl_utilities, fsl_stream, fsl_json, fsl_fpc, fsl_threads, fsl_versions; + fsl_base, fsl_utilities, fsl_stream, fsl_json, fsl_fpc, fsl_threads, fsl_versions, fsl_gzip; Type TFHIRPackageKind = (fpkNull, fpkCore, fpkIG, fpkIGTemplate, fpkTool, fpkToolGen, fpkGroup, fpkExamples); @@ -225,6 +225,7 @@ TNpmPackage = class (TNpmPackageObject) function isValidPackageId(id : String) : boolean; function isMoreRecentVersion(test, base : String) : boolean; + implementation function isValidPackagePart(part : String) : boolean; @@ -1076,70 +1077,38 @@ function TNpmPackage.presentation: String; end; end; -function readZLibHeader(stream : TStream) : TBytes; -var - b : TBytes; - p : int64; - i : integer; -begin - b := StreamToBytes(stream); - if (length(b) < 10) or (b[0] <> $1F) or (b[1] <> $8B) then - result := b - else - begin - i := 10; - if ((b[3] and $08) > 0) then - begin - repeat - inc(i); - until (i = length(b)) or (b[i] = 0); - inc(i); - end; - if i >= length(b) then - result := b - else - result := copy(b, i, length(b)-i-8); - end; -end; - procedure TNpmPackage.readStream(tgz: TStream; desc: String; progress: TWorkProgressEvent); var bs : TBytesStream; - z : TZDecompressionStream; tar : TTarArchive; entry : TTarDirRec; n : String; b : TBytes; bi : TBytesStream; begin - bs := TBytesStream.create(readZLibHeader(tgz)); + bs := TBytesStream.create(ungzip(streamToBytes(tgz))); try - z := TZDecompressionStream.Create(bs, true); // 15+16); + tar := TTarArchive.Create(bs); try - tar := TTarArchive.Create(z); - try - tar.Reset; - while tar.FindNext(entry) do - begin - n := String(entry.Name); - if (n.contains('..')) then - raise EFSLException.create('The package "'+desc+'" contains the file "'+n+'". Packages are not allowed to contain files with ".." in the name'); - bi := TBytesStream.Create; - try - tar.ReadFile(bi); - b := copy(bi.Bytes, 0, bi.size); - finally - bi.free; - end; - loadFile(n, b); - if assigned(progress) then - progress(self, -1, false, 'Loading '+n); + tar.Reset; + while tar.FindNext(entry) do + begin + n := String(entry.Name); + if (n.contains('..')) then + raise EFSLException.create('The package "'+desc+'" contains the file "'+n+'". Packages are not allowed to contain files with ".." in the name'); + bi := TBytesStream.Create; + try + tar.ReadFile(bi); + b := copy(bi.Bytes, 0, bi.size); + finally + bi.free; end; - finally - tar.free; + loadFile(n, b); + if assigned(progress) then + progress(self, -1, false, 'Loading '+n); end; finally - z.free; + tar.free; end; finally bs.free; diff --git a/library/fsl/fsl_stream.pas b/library/fsl/fsl_stream.pas index d93bfda41..23f4650e2 100644 --- a/library/fsl/fsl_stream.pas +++ b/library/fsl/fsl_stream.pas @@ -37,7 +37,7 @@ {$IFDEF LINUX} unixtype, baseunix, unix, {$ENDIF} {$IFDEF FPC} ZStream, {$ELSE} AnsiStrings, {$ENDIF} SysUtils,Classes, RTLConsts, ZLib, - fsl_fpc, fsl_base, fsl_collections, fsl_utilities, fsl_logging; + fsl_fpc, fsl_base, fsl_collections, fsl_utilities, fsl_logging, fsl_gzip; type EParserException = class; @@ -5302,34 +5302,16 @@ procedure TFslZipPartList.add(name: String; bytes: TBytes); Procedure TFslZipReader.ReadKnownDeflate(pIn : Pointer; partName : string; iSizeComp, iSizeDecomp : LongWord; oBuffer : TFslBuffer); Var - oSrc : TStream; - oDecompressor : TZDecompressionStream; - + src : TBytes; {$IFOPT C+} iRead : Integer; {$ENDIF} Begin If iSizeDecomp > 0 Then Begin - oSrc := TPointerMemoryStream.Create(pIn, iSizeComp); - Try - oDecompressor := TZDecompressionStream.Create(oSrc); - Try - oBuffer.Capacity := iSizeDecomp; - - {$IFOPT C+} - iRead := oDecompressor.Read(oBuffer.Data^, iSizeDecomp); - Assert(CheckCondition(iRead = iSizeDecomp, 'ReadKnownDeflate', partName+': Expected to read '+IntegerToString(iSizeDecomp)+ - ' bytes, but actually found '+IntegerToString(iRead)+' bytes')); - {$ELSE} - oDecompressor.Read(oBuffer.Data^, iSizeDecomp); - {$ENDIF} - Finally - oDecompressor.free; - End; - Finally - oSrc.free; - End; + setLength(src, iSizeComp); + move(pIn^, src[0], iSizeComp); + oBuffer.AsBytes := ungzip(src); End; End; @@ -6113,7 +6095,7 @@ function TTarArchive.FindNext (var DirRec : TTarDirRec) : boolean; else FBytesToGo := DirRec.Size; // zipslip prevention: .. in file names are *never* allowed anywhere path := DirRec.name; - If path.contains('..') then + If path.contains('../') or path.contains('/..') then raise EIOException.create('Illegal Filename in compressed archive: '+path); end; diff --git a/library/fsl/fsl_ucum.pas b/library/fsl/fsl_ucum.pas index 1717794e0..dcb7c16e4 100644 --- a/library/fsl/fsl_ucum.pas +++ b/library/fsl/fsl_ucum.pas @@ -57,6 +57,8 @@ TUcumServiceInterface = class (TFslObject) function multiply(o1, o2 : TUcumPair) : TUcumPair; virtual; abstract; function divideBy(o1, o2 : TUcumPair) : TUcumPair; virtual; abstract; function getCanonicalForm(value : TUcumPair) : TUcumPair; virtual; abstract; + function getCanonicalUnits(units : string) : string; virtual; abstract; + function isComparable(u1, u2 : String) : boolean; virtual; abstract; function isConfigured : boolean; virtual; abstract; end; diff --git a/library/fsl/fsl_utilities.pas b/library/fsl/fsl_utilities.pas index bf69b59f1..42b771da3 100644 --- a/library/fsl/fsl_utilities.pas +++ b/library/fsl/fsl_utilities.pas @@ -46,7 +46,7 @@ {$ENDIF} {$IFDEF FPC} - base64, + base64, LazUTF8, {$ELSE} System.TimeSpan, System.NetEncoding, EncdDecd, UIConsts, ZLib, {$ENDIF} @@ -1848,10 +1848,6 @@ TStringListHelper = class helper for TStringList function sizeInBytes(magic : integer) : cardinal; end; -function ZCompressBytes(const s: TBytes): TBytes; -function ZDecompressBytes(const s: TBytes): TBytes; -function TryZDecompressBytes(const s: TBytes): TBytes; - type TCacheInformation = class (TFslObject) private @@ -15872,7 +15868,10 @@ function TFslWordStemmer.stem(word: String): String; end; function removeAccentFromChar(ch : UnicodeChar) : String; +var + v : Cardinal; begin + v := ord(ch); case ch of //' ' #$00A0 : result := ' '; @@ -16917,9 +16916,11 @@ function removeAccentFromChar(ch : UnicodeChar) : String; #$2C6C : result := 'z'; #$A763 : result := 'z'; - #$0439 : result := #$0438; + #$0439 : result := UnicodeToUTF8($0438); + else if ch < #$FE then + result := ch else - result := ch; + result := UnicodeToUTF8(v); end; end; @@ -17140,70 +17141,6 @@ function AllContentHex(s: String): Boolean; Result := Result and ((Upcase(s[i]) >= '0') and (Upcase(s[i]) <= '9')) or ((s[i] >= 'A') and (s[i] <= 'F')); end; -function ZCompressBytes(const s: TBytes): TBytes; -begin - {$IFDEF FPC} - result := nil; - raise ETodo.create('Not done yet'); - {$ELSE} - ZCompress(s, result); - {$ENDIF} -end; - -function TryZDecompressBytes(const s: TBytes): TBytes; -begin - try - result := ZDecompressBytes(s); - except - result := s; - end; -end; - -function ZDecompressBytes(const s: TBytes): TBytes; -{$IFDEF FPC} -var - b1, b2 : TBytesStream; - z : TZDecompressionStream; -begin - b1 := TBytesStream.create(s); - try - z := TZDecompressionStream.create(b1); - try - b2 := TBytesStream.Create; - try - b2.CopyFrom(z, z.Size); - result := b2.Bytes; - setLength(result, b2.size); - finally - b2.free; - end; - finally - z.free; - end; - finally - b1.free; - end; -end; - -{$ELSE} -{$IFNDEF WIN64} -var - buffer: Pointer; - size : Integer; -{$ENDIF} -begin - {$IFDEF WIN64} - ZDecompress(s, result); - {$ELSE} - ZDecompress(@s[0],Length(s),buffer,size); - SetLength(result,size); - Move(buffer^,result[0],size); - FreeMem(buffer); - {$ENDIF} -end; -{$ENDIF} - - { TStringListHelper } function TStringListHelper.sizeInBytes(magic : integer): cardinal; @@ -17470,6 +17407,8 @@ function lowBoundaryForDate(value : String; precision : integer) : String; b.append(':00'); if (b.length = 19) then b.append('.000'); + if (tz = '') and (precision >= 10) then + tz := '+14:00'; result := applyDatePrecision(b.toString(), precision)+tz; finally b.free; @@ -17515,6 +17454,8 @@ function highBoundaryForDate(value : String; precision : integer) : String; b.append(':59'); if (b.length = 19) then b.append('.999'); + if (tz = '') and (precision >= 10) then + tz := '-12:00'; result := applyDatePrecision(b.toString(), precision)+tz; finally b.free; diff --git a/library/fsl/tests/fsl_testing.pas b/library/fsl/tests/fsl_testing.pas index 2e1e2617b..7a6a09663 100644 --- a/library/fsl/tests/fsl_testing.pas +++ b/library/fsl/tests/fsl_testing.pas @@ -64,6 +64,8 @@ TFslTestCase = class (TTestCase) procedure assertEqual(left, right : String); overload; procedure assertEqual(left, right : integer; message : String); overload; procedure assertEqual(left, right : integer); overload; + procedure assertEqual(const left, right : TBytes; message : String); overload; + procedure assertEqual(const left, right : TBytes); overload; procedure assertWillRaise(AMethod: TTestMethodWithContext; context : TObject; AExceptionClass: ExceptClass; AExceptionMessage : String); procedure thread(proc : TTestMethodWithContext; context : TObject); public @@ -280,6 +282,36 @@ procedure TFslTestCase.assertEqual(left, right: integer); {$ENDIF} end; +procedure TFslTestCase.assertEqual(const left, right: TBytes; message: String); +var + i : integer; +begin + {$IFDEF FPC} + for i := 0 to IntegerMin(length(left), length(right)) - 1 do + if (left[i] <> right[i]) then + raise EFslException.create('Byte Arrays differ at position '+inttostr(i)+': '+inttostr(ord(left[i]))+'/'+inttostr(ord(right[i]))); + if length(left) <> length(right) then + raise EFslException.create('Byte Arrays differ in length: '+inttostr(length(left))+'/'+inttostr(length(right))); + {$ELSE} + todo + {$ENDIF} +end; + +procedure TFslTestCase.assertEqual(const left, right: TBytes); +var + i : integer; +begin + {$IFDEF FPC} + for i := 0 to IntegerMin(length(left), length(right)) - 1 do + if (left[i] <> right[i]) then + raise EFslException.create('Byte Arrays differ at position '+inttostr(i)+': '+inttostr(ord(left[i]))+'/'+inttostr(ord(right[i]))); + if length(left) <> length(right) then + raise EFslException.create('Byte Arrays differ in length: '+inttostr(length(left))+'/'+inttostr(length(right))); + {$ELSE} + todo + {$ENDIF} +end; + procedure TFslTestCase.assertWillRaise(AMethod: TTestMethodWithContext; context : TObject; AExceptionClass: ExceptClass; AExceptionMessage : String); begin try diff --git a/library/fsl/tests/fsl_tests.pas b/library/fsl/tests/fsl_tests.pas index 1e5bc198f..730932188 100644 --- a/library/fsl/tests/fsl_tests.pas +++ b/library/fsl/tests/fsl_tests.pas @@ -33,15 +33,16 @@ interface Uses - {$IFDEF WINDOWS} Windows, {$ENDIF} SysUtils, Classes, {$IFNDEF FPC}Soap.EncdDecd, System.NetEncoding, {$ENDIF} SyncObjs, zlib, + {$IFDEF WINDOWS} Windows, {$ENDIF} SysUtils, Classes, {$IFNDEF FPC}Soap.EncdDecd, System.NetEncoding, {$ENDIF} SyncObjs, + zlib, zstream, {$IFDEF FPC} FPCUnit, TestRegistry, RegExpr, {$ELSE} TestFramework, {$ENDIF} fsl_testing, IdGlobalProtocols, - fsl_base, fsl_utilities, fsl_stream, fsl_threads, fsl_collections, fsl_fpc, fsl_versions, + fsl_base, fsl_utilities, fsl_stream, fsl_threads, fsl_collections, fsl_fpc, fsl_versions, fsl_gzip, fsl_xml, {$IFNDEF FPC} fsl_msxml, {$ENDIF} - fsl_json, fsl_turtle, fsl_comparisons; + fsl_json, fsl_turtle, fsl_comparisons, fsl_npm; Type TFslTestString = class (TFslObject) @@ -1104,11 +1105,14 @@ procedure TFslUtilitiesTestCases.testSemVer; procedure TFslUtilitiesTestCases.testUnicode; var - s : String; + s, sc : String; b : TBytes; begin - s := TEncoding.UTF8.GetString(bu2); - AssertTrue(s = 'EKG PB R'''' 波持续时间（持续时长、时长、时间长度、时间、时间长短、为时、为期、历时、延续时间、持久时间、持续期） AVR 导联'); + sc := 'EKG PB R'''' 波持续时间（持续时长、时长、时间长度、时间、时间长短、为时、为期、历时、延续时间、持久时间、持续期） AVR 导联'; + b := TEncoding.UTF8.GetBytes(sc); + s := TEncoding.UTF8.GetString(bu2); + AssertEqual(b, bu2); + AssertEqual(s, sc); s := '背景 发现是一个原子型临床观察指标'; b := TEncoding.UTF8.GetBytes(s); @@ -5264,49 +5268,48 @@ procedure TXmlUtilsTest.TestUnPretty; function TTarGZParserTests.load(filename : String) : TFslList; var - z : TZDecompressionStream; + bs : TBytesStream; tar : TTarArchive; entry : TTarDirRec; - mem : TMemoryStream; + n : String; + b : TBytes; + bi : TBytesStream; item : TFslNameBuffer; - stream : TFileStream; -begin +begin result := TFslList.Create; try - stream := TFileStream.Create(filename, fmOpenRead); + bs := TBytesStream.create(ungzip(fileToBytes(filename))); try - z := TZDecompressionStream.Create(stream, false); // 15+16); + tar := TTarArchive.Create(bs); try - tar := TTarArchive.Create(z); - try - while tar.FindNext(entry) do - begin - item := TFslNameBuffer.Create; - try - item.Name := String(entry.Name); - mem := TMemoryStream.Create; - try - tar.ReadFile(mem); - mem.position := 0; - item.loadFromStream(mem); - finally - mem.free; - end; - result.Add(item.link) - finally - item.free; - end; - //break; + tar.Reset; + while tar.FindNext(entry) do + begin + n := String(entry.Name); + if (n.contains('..')) then + raise EFSLException.create('The package contains the file "'+n+'". Packages are not allowed to contain files with ".." in the name'); + bi := TBytesStream.Create; + try + tar.ReadFile(bi); + b := copy(bi.Bytes, 0, bi.size); + finally + bi.free; + end; + item := TFslNameBuffer.Create; + try + item.Name := n; + item.AsBytes := b; + result.Add(item.link) + finally + item.free; end; - finally - tar.free; end; finally - z.free; + tar.free; end; finally - stream.free; - end; + bs.free; + end; result.link; finally result.free; diff --git a/library/fsl/tests/fsl_tests_npm.pas b/library/fsl/tests/fsl_tests_npm.pas index 74fff6418..39b017b5e 100644 --- a/library/fsl/tests/fsl_tests_npm.pas +++ b/library/fsl/tests/fsl_tests_npm.pas @@ -62,6 +62,7 @@ procedure TNpmPackageTests.LoadUSCore; var npm : TNpmPackage; begin + exit; npm := FCache.loadPackage('hl7.fhir.us.core'); try assertTrue(npm <> nil); diff --git a/library/fsl/tests/fsl_tests_web.pas b/library/fsl/tests/fsl_tests_web.pas index 51775b188..cbede0859 100644 --- a/library/fsl/tests/fsl_tests_web.pas +++ b/library/fsl/tests/fsl_tests_web.pas @@ -284,8 +284,6 @@ procedure TJWTTests.TestPacking; s : String; jwt : TJWT; begin - raise EFslException.create('fix me'); - jwk := TJWK.create(TJSONParser.Parse('{"kty": "oct", "k": "AyM1SysPpbyDfgZld3umj1qzKObwVMkoqQ-EstJQLr_T-1qS0gZH75aKtMN3Yj0iPS4hcgUuTwjAzZr1Z9CAow"}')); try // this test is from the spec @@ -605,7 +603,6 @@ procedure TOpenSSLTests.testWebServer_110; begin assertTrue(TestSettings.SSLCertFile <> '', 'Must provide public key file for SSL test in '+TestSettings.filename+' ([ssl] cert=)'); assertTrue(TestSettings.SSLKeyFile <> '', 'Must provide private key file for SSL test in '+TestSettings.filename+' ([ssl] key=)'); - assertTrue(TestSettings.SSLPassword <> '', 'Must provide password for private key for SSL test in '+TestSettings.filename+' ([ssl] password=)'); assertTrue(TestSettings.SSLCAFile <> '', 'Must provide ca cert file for SSL test in '+TestSettings.filename+' ([ssl] cacert=)'); assertTrue(FileExists(TestSettings.SSLCertFile), 'SSL Certificate not found at '+TestSettings.SSLCertFile); diff --git a/library/ftx/fhir_codesystem_service.pas b/library/ftx/fhir_codesystem_service.pas index bd19bcb3d..2b1b8d088 100644 --- a/library/ftx/fhir_codesystem_service.pas +++ b/library/ftx/fhir_codesystem_service.pas @@ -214,6 +214,7 @@ TFhirCodeSystemProvider = class (TCodeSystemProvider) function name(context: TCodeSystemProviderContext): String; override; function version(context: TCodeSystemProviderContext): String; override; function TotalCount : integer; override; + function getPropertyDefinitions : TFslList; override; function getIterator(context : TCodeSystemProviderContext) : TCodeSystemIteratorContext; override; function getNextContext(context : TCodeSystemIteratorContext) : TCodeSystemProviderContext; override; function systemUri(context : TCodeSystemProviderContext) : String; override; @@ -1227,6 +1228,11 @@ function count(item : TFhirCodeSystemConceptW) : integer; inc(result, count(FCs.CodeSystem.conceptList[i])); end; +function TFhirCodeSystemProvider.getPropertyDefinitions: TFslList; +begin + Result := FCs.CodeSystem.properties; +end; + function TFhirCodeSystemProvider.version(context: TCodeSystemProviderContext): String; begin result := FCs.CodeSystem.version; diff --git a/library/ftx/fhir_valuesets.pas b/library/ftx/fhir_valuesets.pas index 450cd9def..f1e8726e5 100644 --- a/library/ftx/fhir_valuesets.pas +++ b/library/ftx/fhir_valuesets.pas @@ -58,7 +58,6 @@ interface TTrueFalseUnknown = (bTrue, bFalse, bUnknown); TFhirExpansionParamsVersionRuleMode = (fvmDefault, fvmCheck, fvmOverride); - TValueSetValidationMode = (vsvmAllChecks, vsvmMembershipOnly, vsvmNoMembership); { TFhirExpansionParamsVersionRule } @@ -94,7 +93,7 @@ TFHIRExpansionParams = class (TFslObject) FincludeDesignations: boolean; FincludeDefinition: boolean; FUid: String; - FValueSetMode: TValueSetValidationMode; + FMembershipOnly : boolean; FDefaultToLatestVersion : boolean; FIncompleteOK: boolean; FProperties : TStringList; @@ -114,7 +113,7 @@ TFHIRExpansionParams = class (TFslObject) FHasDefaultToLatestVersion : boolean; FHasIncompleteOK : boolean; FHasexcludeNotForUI : boolean; - FHasValueSetMode : boolean; + FHasMembershipOnly : boolean; FHasDisplayWarning : boolean; FAltCodeRules : TAlternateCodeOptions; @@ -132,7 +131,7 @@ TFHIRExpansionParams = class (TFslObject) procedure SetDefaultToLatestVersion(value : boolean); procedure SetIncompleteOK(value : boolean); procedure SetDisplayWarning(value : boolean); - procedure SetValueSetMode(value : TValueSetValidationMode); + procedure SetMembershipOnly(value : boolean); protected function sizeInBytesV(magic : integer) : cardinal; override; public @@ -159,7 +158,7 @@ TFHIRExpansionParams = class (TFslObject) property excludeNested : boolean read FexcludeNested write SetexcludeNested; property excludeNotForUI : boolean read FexcludeNotForUI write SetexcludeNotForUI; property excludePostCoordinated : boolean read FexcludePostCoordinated write SetexcludePostCoordinated; - property valueSetMode : TValueSetValidationMode read FValueSetMode write SetValueSetMode; + property membershipOnly : boolean read FMembershipOnly write SetMembershipOnly; property uid : String read FUid write FUid; property defaultToLatestVersion : boolean read FDefaultToLatestVersion write SetDefaultToLatestVersion; property incompleteOK : boolean read FIncompleteOK write SetIncompleteOK; @@ -177,7 +176,7 @@ TFHIRExpansionParams = class (TFslObject) property hasExcludeNested : boolean read FHasexcludeNested; property hasExcludeNotForUI : boolean read FHasexcludeNotForUI; property hasExcludePostCoordinated : boolean read FHasexcludePostCoordinated; - property hasValueSetMode : boolean read FHasValueSetMode; + property hasMembershipOnly : boolean read FHasMembershipOnly; property hasDefaultToLatestVersion : boolean read FHasDefaultToLatestVersion; property hasIncompleteOK : boolean read FHasIncompleteOK; property hasDisplayWarning : boolean read FHasDisplayWarning; @@ -259,7 +258,7 @@ TValueSetWorker = class (TFslObject) FValueSet : TFHIRValueSetW; FLangList : THTTPLanguageList; - function findInAdditionalResources(url, version, resourceType : String) : TFHIRMetadataResourceW; + function findInAdditionalResources(url, version, resourceType : String; error : boolean) : TFHIRMetadataResourceW; function findValueSet(url, version : String) : TFHIRValueSetW; function findCodeSystem(url, version : String; params : TFHIRExpansionParams; nullOk : boolean) : TCodeSystemProvider; function listVersions(url : String) : String; @@ -283,22 +282,24 @@ TValueSetWorker = class (TFslObject) end; { TValueSetChecker } + TValidationCheckMode = (vcmCode, vcmCoding, vcmCodeableConcept); TValueSetChecker = class (TValueSetWorker) private FOthers : TFslStringObjectMatch; // checkers or code system providers FId: String; FLog : String; + FAllValueSet : boolean; procedure checkCanonicalStatus(path : string; op : TFhirOperationOutcomeW; resource, source : TFHIRMetadataResourceW); overload; procedure checkCanonicalStatus(path : string; op : TFhirOperationOutcomeW; cs : TCodeSystemProvider; source : TFHIRMetadataResourceW); overload; - procedure checkCanonicalStatus(path : string; op : TFhirOperationOutcomeW; vurl : String; status: TPublicationStatus; standardsStatus: String; experimental : boolean; source : TFHIRMetadataResourceW); overload; + procedure checkCanonicalStatus(path : string; op : TFhirOperationOutcomeW; rtype, vurl : String; status: TPublicationStatus; standardsStatus: String; experimental : boolean; source : TFHIRMetadataResourceW); overload; function dispWarning : TIssueSeverity; function determineSystemFromExpansion(code: String): String; function determineSystem(code : String) : String; function determineVersion(path, systemURI, versionVS, versionCoding : String; op : TFhirOperationOutcomeW; var message : String) : string; - function check(path, system, version, code : String; abstractOk, inferSystem : boolean; displays : TConceptDesignations; unknownSystems : TStringList; var message, ver : String; var inactive : boolean; var vstatus : String; var cause : TFhirIssueType; op : TFhirOperationOutcomeW; vcc : TFHIRCodeableConceptW; params: TFHIRParametersW; var contentMode : TFhirCodeSystemContentMode; var impliedSystem : string) : TTrueFalseUnknown; overload; + function check(path, system, version, code : String; abstractOk, inferSystem : boolean; displays : TConceptDesignations; unknownSystems : TStringList; var message, ver : String; var inactive : boolean; var vstatus : String; var cause : TFhirIssueType; op : TFhirOperationOutcomeW; vcc : TFHIRCodeableConceptW; params: TFHIRParametersW; var contentMode : TFhirCodeSystemContentMode; var impliedSystem : string; unkCodes, messages : TStringList) : TTrueFalseUnknown; overload; function findCode(cs : TFhirCodeSystemW; code: String; list : TFhirCodeSystemConceptListW; displays : TConceptDesignations; out isabstract : boolean): boolean; function checkConceptSet(path : String; cs: TCodeSystemProvider; cset : TFhirValueSetComposeIncludeW; code : String; abstractOk : boolean; displays : TConceptDesignations; vs : TFHIRValueSetW; var message : String; var inactive : boolean; var vstatus : String; op : TFHIROperationOutcomeW; vcc : TFHIRCodeableConceptW) : boolean; function checkExpansion(path : String; cs: TCodeSystemProvider; cset : TFhirValueSetExpansionContainsW; code : String; abstractOk : boolean; displays : TConceptDesignations; vs : TFHIRValueSetW; var message : String; var inactive : boolean; var vstatus : String; op : TFHIROperationOutcomeW) : boolean; @@ -321,7 +322,7 @@ TValueSetChecker = class (TValueSetWorker) function check(issuePath, system, version, code : String; abstractOk, inferSystem : boolean; op : TFhirOperationOutcomeW) : TTrueFalseUnknown; overload; function check(issuePath, system, version, code : String; inferSystem : boolean) : TFhirParametersW; overload; function check(issuePath : String; coding : TFhirCodingW; abstractOk, inferSystem : boolean): TFhirParametersW; overload; - function check(issuePath : String; code: TFhirCodeableConceptW; abstractOk, inferSystem, addCodeable : boolean) : TFhirParametersW; overload; + function check(issuePath : String; code: TFhirCodeableConceptW; abstractOk, inferSystem : boolean; mode : TValidationCheckMode) : TFhirParametersW; overload; property log : String read FLog; end; @@ -340,7 +341,9 @@ TValueSetCounter = class (TFslObject) TFHIRValueSetExpander = class (TValueSetWorker) private + FHasCount : boolean; FCount : integer; + FHasOffset : boolean; FOffset : integer; FLimitCount : integer; FCanBeHierarchy : boolean; @@ -555,7 +558,7 @@ function isLaterVersion(test, base : String) : boolean; result := StringCompare(test, base) > 0; end; -function TValueSetWorker.findInAdditionalResources(url, version, resourceType : String) : TFHIRMetadataResourceW; +function TValueSetWorker.findInAdditionalResources(url, version, resourceType : String; error : boolean) : TFHIRMetadataResourceW; var r : TFHIRMetadataResourceW; matches : TFslMetadataResourceList; @@ -571,7 +574,10 @@ function TValueSetWorker.findInAdditionalResources(url, version, resourceType : if (url <> '') and ((r.url = url) or (r.vurl = url)) and ((version = '') or (version = r.version)) then begin if r.fhirType <> resourceType then - raise EFHIRException.Create('Attempt to reference '+url+' as a '+resourceType+' when it''s a '+r.fhirType); + if error then + raise EFHIRException.Create('Attempt to reference '+url+' as a '+resourceType+' when it''s a '+r.fhirType) + else + exit(nil); matches.add(r.link); end; end; @@ -604,7 +610,7 @@ function TValueSetWorker.findCodeSystem(url, version: String; params: TFHIRExpan result := nil; end; - cs := findInAdditionalResources(url, version, 'CodeSystem') as TFhirCodeSystemW; + cs := findInAdditionalResources(url, version, 'CodeSystem', not nullOk) as TFhirCodeSystemW; if (cs <> nil) and (cs.content = cscmComplete) then begin cse := TFHIRCodeSystemEntry.Create(cs.link); @@ -658,7 +664,7 @@ function TValueSetWorker.findValueSet(url, version: String): TFHIRValueSetW; if (url = '') then exit(nil); - r := findInAdditionalResources(url, '', 'ValueSet'); + r := findInAdditionalResources(url, '', 'ValueSet', false); if (r <> nil) then exit(r.link as TFHIRValueSetW); @@ -698,7 +704,7 @@ destructor TValueSetChecker.Destroy; procedure TValueSetChecker.checkCanonicalStatus(path: string; op: TFhirOperationOutcomeW; resource, source: TFHIRMetadataResourceW); begin - checkCanonicalStatus(path, op, resource.vurl, resource.status, resource.getExtensionString('http://hl7.org/fhir/StructureDefinition/structuredefinition-standards-status'), resource.experimental, source); + checkCanonicalStatus(path, op, resource.fhirType, resource.vurl, resource.status, resource.getExtensionString('http://hl7.org/fhir/StructureDefinition/structuredefinition-standards-status'), resource.experimental, source); end; procedure TValueSetChecker.checkCanonicalStatus(path : string; op : TFhirOperationOutcomeW; cs: TCodeSystemProvider; source : TFHIRMetadataResourceW); @@ -709,28 +715,28 @@ procedure TValueSetChecker.checkCanonicalStatus(path : string; op : TFhirOperati begin cs.getStatus(status, standardsStatus, experimental); if (cs.version(nil) <> '') then - checkCanonicalStatus(path, op, cs.systemUri(nil)+'|'+cs.version(nil), status, standardsStatus, experimental, source) + checkCanonicalStatus(path, op, 'CodeSystem', cs.systemUri(nil)+'|'+cs.version(nil), status, standardsStatus, experimental, source) else - checkCanonicalStatus(path, op, cs.systemUri(nil), status, standardsStatus, experimental, source); + checkCanonicalStatus(path, op, 'CodeSystem', cs.systemUri(nil), status, standardsStatus, experimental, source); end; -procedure TValueSetChecker.checkCanonicalStatus(path : string; op : TFhirOperationOutcomeW; vurl: String; status: TPublicationStatus; standardsStatus: String; experimental : boolean; source : TFHIRMetadataResourceW); +procedure TValueSetChecker.checkCanonicalStatus(path : string; op : TFhirOperationOutcomeW; rtype, vurl: String; status: TPublicationStatus; standardsStatus: String; experimental : boolean; source : TFHIRMetadataResourceW); begin if op <> nil then begin if standardsStatus = 'deprecated' then - op.addIssue(isInformation, itBusinessRule, path, FI18n.translate('MSG_DEPRECATED', FParams.languages, [vurl]), false) + op.addIssue(isInformation, itBusinessRule, '', FI18n.translate('MSG_DEPRECATED', FParams.languages, [vurl, '', rtype]), oicStatusCheck, false) else if standardsStatus = 'withdrawn' then - op.addIssue(isInformation, itBusinessRule, path, FI18n.translate('MSG_WITHDRAWN', FParams.languages, [vurl]), false) + op.addIssue(isInformation, itBusinessRule, '', FI18n.translate('MSG_WITHDRAWN', FParams.languages, [vurl, '', rtype]), oicStatusCheck, false) else if status = psRetired then - op.addIssue(isInformation, itBusinessRule, path, FI18n.translate('MSG_RETIRED', FParams.languages, [vurl]), false) + op.addIssue(isInformation, itBusinessRule, '', FI18n.translate('MSG_RETIRED', FParams.languages, [vurl, '', rtype]), oicStatusCheck, false) else if (source <> nil) then begin if experimental and not source.experimental then - op.addIssue(isInformation, itBusinessRule, path, FI18n.translate('MSG_EXPERIMENTAL', FParams.languages, [vurl]), false) + op.addIssue(isInformation, itBusinessRule, '', FI18n.translate('MSG_EXPERIMENTAL', FParams.languages, [vurl, '', rtype]), oicStatusCheck, false) else if ((status = psDraft) or (standardsStatus = 'draft')) and not ((source.status = psDraft) or (source.getExtensionString('http://hl7.org/fhir/StructureDefinition/structuredefinition-standards-status') = 'draft')) then - op.addIssue(isInformation, itBusinessRule, path, FI18n.translate('MSG_DRAFT', FParams.languages, [vurl]), false) + op.addIssue(isInformation, itBusinessRule, '', FI18n.translate('MSG_DRAFT', FParams.languages, [vurl, '', rtype]), oicStatusCheck, false) end; end; end; @@ -899,7 +905,7 @@ function TValueSetChecker.determineVersion(path, systemURI, versionVS, versionCo else begin message := 'The code system "'+systemUri+'" version "'+versionVS+'" in the ValueSet include is different to the one in the value ("'+versionCoding+'")'; - op.addIssue(isError, itNotFound, addToPath(path, 'version'), message); + op.addIssue(isError, itInvalid, addToPath(path, 'version'), message, oicVSProcessing); exit(''); end; if result = '' then @@ -919,18 +925,20 @@ function TValueSetChecker.prepare(vs: TFHIRValueSetW; params : TFHIRExpansionPar begin result := nil; FParams := params.Link; - seeValueSet(vs); - FRequiredSupplements.clear; - for ext in vs.getExtensionsW(EXT_VSSUPPLEMENT).forEnum do - FRequiredSupplements.add(ext.valueAsString); - - vs.checkNoImplicitRules('ValueSetChecker.prepare', 'ValueSet'); - FFactory.checkNoModifiers(vs, 'ValueSetChecker.prepare', 'ValueSet'); if (vs = nil) then raise EFslException.Create('Error Error: vs = nil') else begin + seeValueSet(vs); + FRequiredSupplements.clear; + for ext in vs.getExtensionsW(EXT_VSSUPPLEMENT).forEnum do + FRequiredSupplements.add(ext.valueAsString); + + vs.checkNoImplicitRules('ValueSetChecker.prepare', 'ValueSet'); + FFactory.checkNoModifiers(vs, 'ValueSetChecker.prepare', 'ValueSet'); + FValueSet := vs.link; + FAllValueSet := FValueSet.url = 'http://hl7.org/fhir/ValueSet/@all'; // r2: ics := FValueSet.inlineCS; @@ -941,7 +949,7 @@ function TValueSetChecker.prepare(vs: TFHIRValueSetW; params : TFHIRExpansionPar cs := TFhirCodeSystemProvider.create(FLanguages.link, ffactory.link, TFHIRCodeSystemEntry.Create(FFactory.wrapCodeSystem(FValueSet.Resource.Link))); FOthers.Add(ics.systemUri, cs); if (FValueSet.version <> '') then - FOthers.Add(ics.systemUri+'|'+FValueSet.version, cs); + FOthers.Add(ics.systemUri+'|'+FValueSet.version, cs.link); finally ics.free; end; @@ -1070,16 +1078,20 @@ function TValueSetChecker.check(issuePath, system, version, code: String; abstra msg, ver, impliedSystem, vstatus : string; it : TFhirIssueType; contentMode : TFhirCodeSystemContentMode; - unknownSystems : TStringList; + unknownSystems, ts, msgs : TStringList; inactive : boolean; begin unknownSystems := TStringList.create; + ts := TStringList.create; + msgs := TStringList.create; try unknownSystems.duplicates := dupIgnore; unknownSystems.sorted := true; - result := check(issuePath, system, version, code, abstractOk, inferSystem, nil, unknownSystems, msg, ver, inactive, vstatus, it, op, nil, nil, contentMode, impliedSystem); + result := check(issuePath, system, version, code, abstractOk, inferSystem, nil, unknownSystems, msg, ver, inactive, vstatus, it, op, nil, nil, contentMode, impliedSystem, ts, msgs); finally unknownSystems.free; + ts.free; + msgs.free; end; end; @@ -1094,389 +1106,469 @@ function vurl(system, version : String) : String; function TValueSetChecker.check(path, system, version, code: String; abstractOk, inferSystem: boolean; displays: TConceptDesignations; unknownSystems : TStringList; var message, ver: String; var inactive : boolean; var vstatus : String; var cause: TFhirIssueType; op: TFhirOperationOutcomeW; - vcc : TFHIRCodeableConceptW; params: TFHIRParametersW; var contentMode: TFhirCodeSystemContentMode; var impliedSystem: string): TTrueFalseUnknown; + vcc : TFHIRCodeableConceptW; params: TFHIRParametersW; var contentMode: TFhirCodeSystemContentMode; var impliedSystem: string; unkCodes, messages : TStringList): TTrueFalseUnknown; var cs : TCodeSystemProvider; ctxt : TCodeSystemProviderContext; cc : TFhirValueSetComposeIncludeW; - excluded, ok : boolean; + excluded, ok, bAdd : boolean; isabstract : boolean; checker : TValueSetChecker; - s, v : String; + s, v, msg : String; ics : TFHIRValueSetCodeSystemW; ccl : TFhirCodeSystemConceptListW; ccc : TFhirValueSetExpansionContainsW; + ts : TStringList; + vss : TFHIRValueSetW; begin - FLog := ''; - {special case:} - contentMode := cscmNull; - s := FValueSet.url; - if (s = ANY_CODE_VS) then + if (system = '') and not inferSystem then begin - cs := findCodeSystem(system, version, FParams, true); - try - if cs = nil then - begin - result := bUnknown; - cause := itNotFound; - FLog := 'Unknown code system'; - if (version <> '') then - begin - op.addIssue(isError, itNotFound, addToPath(path, 'system'), FI18n.translate('UNKNOWN_CODESYSTEM_VERSION', FParams.languages, [system, version])); - unknownSystems.add(system+'|'+version); - end - else - begin - op.addIssue(isError, itNotFound, addToPath(path, 'system'), FI18n.translate('UNKNOWN_CODESYSTEM', FParams.languages, [system])); - unknownSystems.add(system); - end; - end - else - begin - checkCanonicalStatus(path, op, cs, FValueSet); - ver := cs.version(nil); - contentMode := cs.contentMode; - ctxt := cs.locate(code, nil, message); - if (ctxt = nil) then + msg := FI18n.translate('Coding_has_no_system__cannot_validate', FParams.languages, []); + messages.add(msg); + op.addIssue(isWarning, itInvalid, path, msg, oicInvalidData); + exit(bFalse); + end; + + ts := TStringList.create; + try + FLog := ''; + {special case:} + contentMode := cscmNull; + s := FValueSet.url; + if (s = ANY_CODE_VS) then + begin + cs := findCodeSystem(system, version, FParams, true); + try + if cs = nil then begin - if cs.contentMode <> cscmComplete then + result := bUnknown; + cause := itNotFound; + FLog := 'Unknown code system'; + vss := findValueSet(system, ''); + if (vss <> nil) then + begin + vss.free; + msg := FI18n.translate('Terminology_TX_System_ValueSet2', FParams.languages, [system]); + messages.add(msg); + op.addIssue(isError, itInvalid, addToPath(path, 'system'), msg, oicInvalidData); + end + else if (version <> '') then begin - result := bTrue; // we can't say it isn't valid. Need a third status? - cause := itNotFound; - FLog := 'Not found in Incomplete Code System'; - op.addIssue(isWarning, itNotFound, addToPath(path, 'code'), FI18n.translate('UNKNOWN_CODE__IN_FRAGMENT', FParams.languages, [code, vurl(system, version)])); + msg := FI18n.translate('UNKNOWN_CODESYSTEM_VERSION', FParams.languages, [system, version, '['+listVersions(system)+']']); + messages.add(msg); + if (unknownSystems.IndexOf(system+'|'+version) = -1) then + begin + op.addIssue(isError, itNotFound, addToPath(path, 'system'), msg, oicNotFound); + unknownSystems.add(system+'|'+version); + end; end else begin - result := bFalse; - cause := itCodeInvalid; - FLog := 'Unknown code'; - op.addIssue(isWarning, itNotFound, addToPath(path, 'code'), FI18n.translate('Unknown_Code__in_', FParams.languages, [code, vurl(system, version)])); + msg := FI18n.translate('UNKNOWN_CODESYSTEM', FParams.languages, [system]); + messages.add(msg); + op.addIssue(isError, itNotFound, addToPath(path, 'system'), msg, oicNotFound); + unknownSystems.add(system); end; end else begin - try - if vcc <> nil then - vcc.addCoding(cs.systemUri(ctxt), cs.version(ctxt), cs.code(ctxt), cs.display(ctxt, FParams.languages)); - cause := itNull; - if not (abstractOk or not cs.IsAbstract(ctxt)) then - begin - result := bFalse; - FLog := 'Abstract code when not allowed'; - cause := itBusinessRule; - op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('ABSTRACT_CODE_NOT_ALLOWED', FParams.languages, [system, code])); - end - else if ((FParams <> nil) and FParams.activeOnly and cs.isInactive(ctxt)) then + checkCanonicalStatus(path, op, cs, FValueSet); + ver := cs.version(nil); + contentMode := cs.contentMode; + ctxt := cs.locate(code, nil, msg); + if (ctxt = nil) then + begin + msg := ''; + unkCodes.add(cs.systemUri(nil)+'|'+cs.version(nil)+'#'+code); + if cs.contentMode <> cscmComplete then begin - result := bFalse; - FLog := 'Inactive code when not allowed'; - cause := itBusinessRule; - op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('INACTIVE_CODE_NOT_ALLOWED', FParams.languages, [system, code])); + result := bTrue; // we can't say it isn't valid. Need a third status? + cause := itCodeInvalid; + FLog := 'Not found in Incomplete Code System'; + msg := FI18n.translate('UNKNOWN_CODE_IN_FRAGMENT', FParams.languages, [code, cs.systemUri(nil), cs.version(nil)]); + messages.add(msg); + op.addIssue(isWarning, itCodeInvalid, addToPath(path, 'code'), msg, oicInvalidCode); end else begin - FLog := 'found OK'; - result := bTrue; - inactive := cs.IsInactive(ctxt); - if (inactive) then - vstatus := cs.getCodeStatus(ctxt); + result := bFalse; + cause := itCodeInvalid; + FLog := 'Unknown code'; + msg := FI18n.translate('Unknown_Code_in_Version', FParams.languages, [code, cs.systemUri(nil), cs.version(nil)]); + messages.add(msg); + op.addIssue(isError, itCodeInvalid, addToPath(path, 'code'), msg, oicInvalidCode); + end; + end + else + begin + try + if vcc <> nil then + vcc.addCoding(cs.systemUri(ctxt), cs.version(ctxt), cs.code(ctxt), cs.display(ctxt, FParams.languages)); + cause := itNull; + if not (abstractOk or not cs.IsAbstract(ctxt)) then + begin + result := bFalse; + FLog := 'Abstract code when not allowed'; + cause := itBusinessRule; + msg := FI18n.translate('ABSTRACT_CODE_NOT_ALLOWED', FParams.languages, [system, code]); + messages.add(msg); + op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), msg, oicCodeRule); + end + else if ((FParams <> nil) and FParams.activeOnly and cs.isInactive(ctxt)) then + begin + result := bFalse; + FLog := 'Inactive code when not allowed'; + cause := itBusinessRule; + msg := FI18n.translate('STATUS_CODE_WARNING_CODE', FParams.languages, ['not active', code]); + messages.add(msg); + op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), msg, oicCodeRule); + end + else + begin + FLog := 'found OK'; + result := bTrue; + inactive := cs.IsInactive(ctxt); + if (inactive) then + vstatus := cs.getCodeStatus(ctxt); + end; + if (displays <> nil) then + listDisplays(displays, cs, ctxt); + finally + ctxt.free; end; - if (displays <> nil) then - listDisplays(displays, cs, ctxt); - finally - ctxt.free; end; end; + finally + cs.free; end; - finally - cs.free; - end; - end - else if (FParams.valueSetMode = vsvmNoMembership) then - begin - // anyhow, we ignore the value set (at least for now) - cs := findCodeSystem(system, version, FParams, true); - try - if cs = nil then - begin - result := bUnknown; - cause := itNotFound; - FLog := 'Unknown code system'; - if (version <> '') then - begin - op.addIssue(isError, itNotFound, addToPath(path, 'system'), FI18n.translate('UNKNOWN_CODESYSTEM_VERSION', FParams.languages, [system, version])); - unknownSystems.add(system+'|'+version); - end - else - begin - op.addIssue(isError, itNotFound, addToPath(path, 'system'), FI18n.translate('UNKNOWN_CODESYSTEM', FParams.languages, [system])); - unknownSystems.add(system); - end; - end - else - begin - checkCanonicalStatus(path, op, cs, FValueSet); - ver := cs.version(nil); - contentMode := cs.contentMode; - ctxt := cs.locate(code); - if (ctxt = nil) then + end + else if (false) then + begin + // anyhow, we ignore the value set (at least for now) + cs := findCodeSystem(system, version, FParams, true); + try + if cs = nil then begin - if cs.contentMode <> cscmComplete then + result := bUnknown; + cause := itNotFound; + FLog := 'Unknown code system'; + if (version <> '') then begin - result := bTrue; // we can't say it isn't valid. Need a third status? - cause := itNotFound; - FLog := 'Not found in Incomplete Code System'; - op.addIssue(isWarning, itNotFound, addToPath(path, 'code'), FI18n.translate('UNKNOWN_CODE__IN_FRAGMENT', FParams.languages, [code, vurl(system, version)])); + msg := FI18n.translate('UNKNOWN_CODESYSTEM_VERSION', FParams.languages, [system, version, '['+listVersions(system)+']']); + messages.add(msg); + if (unknownSystems.IndexOf(system+'|'+version) = -1) then + begin + op.addIssue(isError, itNotFound, addToPath(path, 'system'), msg, oicNotFound); + unknownSystems.add(system+'|'+version); + end; end else begin - result := bFalse; - cause := itCodeInvalid; - FLog := 'Unknown code'; - op.addIssue(isWarning, itNotFound, addToPath(path, 'code'), FI18n.translate('Unknown_Code__in_', FParams.languages, [code, vurl(system, version)])); + msg := FI18n.translate('UNKNOWN_CODESYSTEM', FParams.languages, [system]); + messages.add(msg); + op.addIssue(isError, itNotFound, addToPath(path, 'system'), msg, oicNotFound); + unknownSystems.add(system); end; end else begin - try - cause := itNull; - if not (abstractOk or not cs.IsAbstract(ctxt)) then - begin - result := bFalse; - FLog := 'Abstract code when not allowed'; - cause := itBusinessRule; - op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('ABSTRACT_CODE_NOT_ALLOWED', FParams.languages, [system, code])); - end - else if ((FParams <> nil) and FParams.activeOnly and cs.isInactive(ctxt)) then + checkCanonicalStatus(path, op, cs, FValueSet); + ver := cs.version(nil); + contentMode := cs.contentMode; + ctxt := cs.locate(code); + if (ctxt = nil) then + begin + unkCodes.add(system+'|'+version+'#'+code); + if cs.contentMode <> cscmComplete then begin - result := bFalse; - FLog := 'Inactive code when not allowed'; - cause := itBusinessRule; - op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('INACTIVE_CODE_NOT_ALLOWED', FParams.languages, [system, code])); + result := bTrue; // we can't say it isn't valid. Need a third status? + cause := itCodeInvalid; + FLog := 'Not found in Incomplete Code System'; + msg := FI18n.translate('UNKNOWN_CODE_IN_FRAGMENT', FParams.languages, [code, system, version]); + messages.add(msg); + op.addIssue(isWarning, itCodeInvalid, addToPath(path, 'code'), msg, oicInvalidCode); end else begin - FLog := 'found'; - result := bTrue; + result := bFalse; + cause := itCodeInvalid; + FLog := 'Unknown code'; + msg := FI18n.translate('Unknown_Code_in_Version', FParams.languages, [code, system, version]); + messages.add(msg); + op.addIssue(isWarning, itCodeInvalid, addToPath(path, 'code'), msg, oicInvalidCode); + end; + end + else + begin + try + cause := itNull; + if not (abstractOk or not cs.IsAbstract(ctxt)) then + begin + result := bFalse; + FLog := 'Abstract code when not allowed'; + cause := itBusinessRule; + msg := FI18n.translate('STATUS_CODE_WARNING_CODE', FParams.languages, ['not active', code]); + messages.add(msg); + op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), msg, oicCodeRule); + end + else if ((FParams <> nil) and FParams.activeOnly and cs.isInactive(ctxt)) then + begin + result := bFalse; + FLog := 'Inactive code when not allowed'; + cause := itBusinessRule; + msg := FI18n.translate('STATUS_CODE_WARNING_CODE', FParams.languages, ['not active', code]); + messages.add(msg); + op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), msg, oicCodeRule); + end + else + begin + FLog := 'found'; + result := bTrue; + end; + listDisplays(displays, cs, ctxt); + finally + ctxt.free; end; - listDisplays(displays, cs, ctxt); - finally - ctxt.free; end; end; + finally + cs.free; end; - finally - cs.free; - end; - end - else - begin - if (system = '') and inferSystem then + end + else begin - system := determineSystem(code); - if (system = '') then + // todo: we can never get here? + if (system = '') and inferSystem then begin - message := FI18n.translate('UNABLE_TO_INFER_CODESYSTEM', FParams.languages, [code, FValueSet.url]); - op.addIssue(isError, itNotFound, path, message); - exit(bFalse); - end - else - impliedSystem := system; - end; - - ics := FValueSet.inlineCS; // r2 - if ics <> nil then - begin - try - contentMode := cscmComplete; - ver := FValueSet.version; - if (system = ics.systemUri) or (system = SYSTEM_NOT_APPLICABLE) then + system := determineSystem(code); + if (system = '') then begin - ccl := ics.concepts; - try - ok := FindCode(nil, code, ccl, displays, isabstract); - if ok and (abstractOk or not isabstract) then - exit(bTrue) - else - exit(bFalse); - finally - ccl.free; + message := FI18n.translate('UNABLE_TO_INFER_CODESYSTEM', FParams.languages, [code, FValueSet.url]); + messages.add(message); + op.addIssue(isError, itNotFound, path, message, oicInferFailed); + exit(bFalse); + end + else + impliedSystem := system; + end; + + ics := FValueSet.inlineCS; // r2 + if ics <> nil then + begin + try + contentMode := cscmComplete; + ver := FValueSet.version; + if (system = ics.systemUri) or (system = SYSTEM_NOT_APPLICABLE) then + begin + ccl := ics.concepts; + try + ok := FindCode(nil, code, ccl, displays, isabstract); + if ok and (abstractOk or not isabstract) then + exit(bTrue) + else + exit(bFalse); + finally + ccl.free; + end; end; + finally + ics.free; end; - finally - ics.free; end; - end; - if (FRequiredSupplements.count > 0) then - raise ETerminologyError.create('Required supplements not found: ['+FRequiredSupplements.commaText+']', itBusinessRule); + if (FRequiredSupplements.count > 0) then + raise ETerminologyError.create('Required supplements not found: ['+FRequiredSupplements.commaText+']', itBusinessRule); - if (FValueSet.checkCompose('ValueSetChecker.prepare', 'ValueSet.compose')) then - begin - result := bFalse; - for s in FValueSet.imports do + if (FValueSet.checkCompose('ValueSetChecker.prepare', 'ValueSet.compose')) then begin - if result = bFalse then + result := bFalse; + for s in FValueSet.imports do begin - checker := TValueSetChecker(FOthers.matches[s]); - checkCanonicalStatus(path, op, checker.FValueSet, FValueSet); - result := checker.check(path, system, version, code, abstractOk, inferSystem, displays, unknownSystems, message, ver, inactive, vstatus, cause, op, nil, params, contentMode, impliedSystem); + if result = bFalse then + begin + checker := TValueSetChecker(FOthers.matches[s]); + if (checker = nil) then + raise ETerminologyError.Create('No Match for '+s+' in '+FOthers.AsText, itUnknown); + checkCanonicalStatus(path, op, checker.FValueSet, FValueSet); + result := checker.check(path, system, version, code, abstractOk, inferSystem, displays, unknownSystems, message, ver, inactive, vstatus, cause, op, nil, params, contentMode, impliedSystem, unkCodes, messages); + end; end; - end; - for cc in FValueSet.includes.forEnum do - begin - if cc.systemUri = '' then - result := bTrue // why? - else if (cc.systemUri = system) or (system = SYSTEM_NOT_APPLICABLE) then + for cc in FValueSet.includes.forEnum do begin - v := determineVersion(path, cc.systemUri, cc.version, version, op, message); - if (v = '') then - cs := TCodeSystemProvider(FOthers.matches[cc.systemUri]).link - else - cs := TCodeSystemProvider(FOthers.matches[cc.systemUri+'|'+v]).link; - if (cs = nil) then - cs := findCodeSystem(system, v, FParams, true); - if (cs = nil) then + if cc.systemUri = '' then + result := bTrue // why? + else if (cc.systemUri = system) or (system = SYSTEM_NOT_APPLICABLE) then begin - if (FParams.valueSetMode <> vsvmMembershipOnly) then + v := determineVersion(path, cc.systemUri, cc.version, version, op, message); + if (v = '') then + cs := TCodeSystemProvider(FOthers.matches[cc.systemUri]).link + else + cs := TCodeSystemProvider(FOthers.matches[cc.systemUri+'|'+v]).link; + if (cs = nil) then + cs := findCodeSystem(system, v, FParams, true); + if (cs = nil) then begin - if (v = '') then + if (not FParams.membershipOnly) then begin - message := FI18n.translate('UNKNOWN_CODESYSTEM', FParams.languages, [system]); - unknownSystems.add(system); + bAdd := true; + if (v = '') then + begin + message := FI18n.translate('UNKNOWN_CODESYSTEM', FParams.languages, [system]); + unknownSystems.add(system); + end + else + begin + message := FI18n.translate('UNKNOWN_CODESYSTEM_VERSION', FParams.languages, [system, v, '['+listVersions(system)+']']); + badd := unknownSystems.IndexOf(system+'|'+version) = -1; + if (bAdd) then + unknownSystems.add(system+'|'+v); + end; + messages.add(message); + if (bAdd) then + op.addIssue(isError, itNotFound, addToPath(path, 'system'), message, oicNotFound); + exit(bUnknown); end else - begin - message := FI18n.translate('UNKNOWN_CODESYSTEM_VERSION', FParams.languages, [system, v, '['+listVersions(system)+']']); - unknownSystems.add(system+'|'+v); - end; - op.addIssue(isError, itNotFound, addToPath(path, 'system'), message); - exit(bUnknown); - end - else - exit(bFalse); - end; - try - checkCanonicalStatus(path, op, cs, FValueSet); - ver := cs.version(nil); - checkSupplements(cs, cc); - contentMode := cs.contentMode; + exit(bFalse); + end; + try + checkCanonicalStatus(path, op, cs, FValueSet); + ver := cs.version(nil); + checkSupplements(cs, cc); + contentMode := cs.contentMode; - if ((system = SYSTEM_NOT_APPLICABLE) or (cs.systemUri(nil) = system)) and checkConceptSet(path, cs, cc, code, abstractOk, displays, FValueSet, message, inactive, vstatus, op, vcc) then - result := bTrue - else - result := bFalse; - finally - cs.free; - end; - end - else - result := bFalse; - for s in cc.valueSets do - begin - checker := TValueSetChecker(FOthers.matches[s]); - if checker = nil then - raise ETerminologyError.Create('No Match for '+s, itUnknown); - checkCanonicalStatus(path, op, checker.FValueSet, FValueSet); - if (result = bTrue) then - result := checker.check(path, system, version, code, abstractOk, inferSystem, displays, unknownSystems, message, ver, inactive, vstatus, cause, op, nil, params, contentMode, impliedSystem); - end; - if result = bTrue then - break; - end; - if result = bTrue then - for cc in FValueSet.excludes.forEnum do - begin - if cc.systemUri = '' then - excluded := true + if ((system = SYSTEM_NOT_APPLICABLE) or (cs.systemUri(nil) = system)) and checkConceptSet(path, cs, cc, code, abstractOk, displays, FValueSet, message, inactive, vstatus, op, vcc) then + result := bTrue + else + result := bFalse; + finally + cs.free; + end; + end else - begin - if (cc.version = '') then - cs := TCodeSystemProvider(FOthers.matches[cc.systemUri]) - else - cs := TCodeSystemProvider(FOthers.matches[cc.systemUri+'|'+cc.version]); - checkCanonicalStatus(path, op, cs, FValueSet); - checkSupplements(cs, cc); - ver := cs.version(nil); - contentMode := cs.contentMode; - excluded := ((system = SYSTEM_NOT_APPLICABLE) or (cs.systemUri(nil) = system)) and checkConceptSet(path, cs, cc, code, abstractOk, displays, FValueSet, message, inactive, vstatus, op, vcc); - end; + result := bFalse; for s in cc.valueSets do begin checker := TValueSetChecker(FOthers.matches[s]); + if checker = nil then + raise ETerminologyError.Create('No Match for '+s+' in '+FOthers.AsText, itUnknown); checkCanonicalStatus(path, op, checker.FValueSet, FValueSet); - excluded := excluded and (checker.check(path, system, version, code, abstractOk, inferSystem, displays, unknownSystems, message, ver, inactive, vstatus, cause, op, nil, params, contentMode, impliedSystem) = bTrue); + if (result = bTrue) then + result := checker.check(path, system, version, code, abstractOk, inferSystem, displays, unknownSystems, message, ver, inactive, vstatus, cause, op, nil, params, contentMode, impliedSystem, unkCodes, messages); end; - if excluded then - exit(bFalse); + if result = bTrue then + break; end; - end - else if FValueSet.checkExpansion('ValueSetChecker.prepare', 'ValueSet.expansion') then - begin - ccc := FValueSet.findContains(system, version, code); - try - if (ccc = nil) then - result := bFalse - else - begin - if (ccc.version = '') and (version = '') then - v := '' - else if (ccc.version = '') then - v := version - else if (version = '') or (version = ccc.version) then - v := ccc.version - else + if result = bTrue then + for cc in FValueSet.excludes.forEnum do begin - message := 'The code system "'+ccc.systemUri+'" version "'+ccc.version+'" in the ValueSet expansion is different to the one in the value ("'+version+'")'; - op.addIssue(isError, itNotFound, addToPath(path, 'version'), message); - exit(bFalse); + if cc.systemUri = '' then + excluded := true + else + begin + if (cc.version = '') then + cs := TCodeSystemProvider(FOthers.matches[cc.systemUri]) + else + begin + cs := TCodeSystemProvider(FOthers.matches[cc.systemUri+'|'+cc.version]); + if (cs = nil) then + cs := TCodeSystemProvider(FOthers.matches[cc.systemUri]) + end; + if (cs = nil) then + raise ETerminologyError.Create('No Match for '+cc.systemUri+'|'+cc.version+' in '+FOthers.AsText, itUnknown); + checkCanonicalStatus(path, op, cs, FValueSet); + checkSupplements(cs, cc); + ver := cs.version(nil); + contentMode := cs.contentMode; + excluded := ((system = SYSTEM_NOT_APPLICABLE) or (cs.systemUri(nil) = system)) and checkConceptSet(path, cs, cc, code, abstractOk, displays, FValueSet, message, inactive, vstatus, op, vcc); + end; + for s in cc.valueSets do + begin + checker := TValueSetChecker(FOthers.matches[s]); + if (cs = nil) then + raise ETerminologyError.Create('No Match for '+cc.systemUri+'|'+cc.version+' in '+FOthers.AsText, itUnknown); + checkCanonicalStatus(path, op, checker.FValueSet, FValueSet); + excluded := excluded and (checker.check(path, system, version, code, abstractOk, inferSystem, displays, unknownSystems, message, ver, inactive, vstatus, cause, op, nil, params, contentMode, impliedSystem, unkCodes, messages) = bTrue); + end; + if excluded then + exit(bFalse); end; - if (v = '') then - cs := TCodeSystemProvider(FOthers.matches[ccc.systemUri]).link + end + else if FValueSet.checkExpansion('ValueSetChecker.prepare', 'ValueSet.expansion') then + begin + ccc := FValueSet.findContains(system, version, code); + try + if (ccc = nil) then + result := bFalse else - cs := TCodeSystemProvider(FOthers.matches[ccc.systemUri+'|'+v]).link; - if (cs = nil) then - cs := findCodeSystem(system, v, FParams, true); - if (cs = nil) then begin - if (FParams.valueSetMode <> vsvmMembershipOnly) then + if (ccc.version = '') and (version = '') then + v := '' + else if (ccc.version = '') then + v := version + else if (version = '') or (version = ccc.version) then + v := ccc.version + else + begin + message := 'The code system "'+ccc.systemUri+'" version "'+ccc.version+'" in the ValueSet expansion is different to the one in the value ("'+version+'")'; + messages.add(message); + op.addIssue(isError, itNotFound, addToPath(path, 'version'), message, oicVSProcessing); + exit(bFalse); + end; + if (v = '') then + cs := TCodeSystemProvider(FOthers.matches[ccc.systemUri]).link + else + cs := TCodeSystemProvider(FOthers.matches[ccc.systemUri+'|'+v]).link; + if (cs = nil) then + cs := findCodeSystem(system, v, FParams, true); + if (cs = nil) then begin - if (v = '') then + if (not FParams.membershipOnly) then begin - message := FI18n.translate('UNKNOWN_CODESYSTEM', FParams.languages, [system]) ; - unknownSystems.add(system); + bAdd := true; + if (v = '') then + begin + message := FI18n.translate('UNKNOWN_CODESYSTEM', FParams.languages, [system]) ; + unknownSystems.add(system); + end + else + begin + badd := unknownSystems.IndexOf(system+'|'+version) = -1; + if (bAdd) then + begin + message := FI18n.translate('UNKNOWN_CODESYSTEM_VERSION', FParams.languages, [system, v, '['+listVersions(system)+']']); + unknownSystems.add(system+'|'+v); + end; + end; + messages.add(message); + if bAdd then + op.addIssue(isError, itNotFound, addToPath(path, 'system'), message, oicNotFound); + exit(bUnknown); end else - begin - message := FI18n.translate('UNKNOWN_CODESYSTEM_VERSION', FParams.languages, [system, v, '['+listVersions(system)+']']); - unknownSystems.add(system+'|'+v); - end; - - op.addIssue(isError, itNotFound, addToPath(path, 'system'), message); - exit(bUnknown); - end - else - exit(bfalse); - end; - try - checkCanonicalStatus(path, op, cs, FValueSet); - ver := cs.version(nil); - contentMode := cs.contentMode; - if ((system = SYSTEM_NOT_APPLICABLE) or (cs.systemUri(nil) = system)) and checkExpansion(path, cs, ccc, code, abstractOk, displays, FValueSet, message, inactive, vstatus, op) then - result := bTrue - else - result := bFalse; - finally - cs.free; + exit(bfalse); + end; + try + checkCanonicalStatus(path, op, cs, FValueSet); + ver := cs.version(nil); + contentMode := cs.contentMode; + if ((system = SYSTEM_NOT_APPLICABLE) or (cs.systemUri(nil) = system)) and checkExpansion(path, cs, ccc, code, abstractOk, displays, FValueSet, message, inactive, vstatus, op) then + result := bTrue + else + result := bFalse; + finally + cs.free; + end; end; + finally + ccc.free; end; - finally - ccc.free; - end; - end - else - result := bFalse; + end + else + result := bFalse; + end; + finally + ts.free; end; end; @@ -1490,7 +1582,7 @@ function TValueSetChecker.check(issuePath : String; coding: TFhirCodingW; abstra contentMode : TFhirCodeSystemContentMode; dc : integer; ok : TTrueFalseUnknown; - unknownSystems : TStringList; + unknownSystems, unkCodes, messages : TStringList; diff : TDisplayDifference; inactive : boolean; vstatus : String; @@ -1498,6 +1590,8 @@ function TValueSetChecker.check(issuePath : String; coding: TFhirCodingW; abstra inactive := false; path := issuePath; unknownSystems := TStringList.create; + unkCodes := TStringList.create; + messages := TStringList.create; result := FFactory.makeParameters; try unknownSystems.sorted := true; @@ -1507,7 +1601,7 @@ function TValueSetChecker.check(issuePath : String; coding: TFhirCodingW; abstra checkCanonicalStatus(path, op, FValueSet, FValueSet); list := TConceptDesignations.Create(FFactory.link, FLanguages.link); try - ok := check(path, coding.systemUri, coding.version, coding.code, abstractOk, inferSystem, list, unknownSystems, message, ver, inactive, vstatus, cause, op, nil, result, contentMode, impliedSystem); + ok := check(path, coding.systemUri, coding.version, coding.code, abstractOk, inferSystem, list, unknownSystems, message, ver, inactive, vstatus, cause, op, nil, result, contentMode, impliedSystem, unkCodes, messages); if ok = bTrue then begin result.AddParamBool('result', true); @@ -1574,6 +1668,8 @@ function TValueSetChecker.check(issuePath : String; coding: TFhirCodingW; abstra finally result.free; unknownSystems.free; + unkCodes.free; + messages.free; end; end; @@ -1600,7 +1696,21 @@ function hasMessage(params : TFhirParametersW; msg : String) : boolean; exit(true); end; -function TValueSetChecker.check(issuePath : String; code: TFhirCodeableConceptW; abstractOk, inferSystem, addCodeable : boolean) : TFhirParametersW; +function toText(st : TStringList; sep : String) : String; +var + i : integer; +begin + if (st = nil) or (st.count = 0) then + result := '' + else + begin + result := st[0]; + for i := 1 to st.count - 1 do + result := result + sep + st[i]; + end; +end; + +function TValueSetChecker.check(issuePath : String; code: TFhirCodeableConceptW; abstractOk, inferSystem : boolean; mode : TValidationCheckMode) : TFhirParametersW; function Summary(code: TFhirCodeableConceptW) : String; begin if (code.codingCount = 1) then @@ -1613,7 +1723,7 @@ function TValueSetChecker.check(issuePath : String; code: TFhirCodeableConceptW; ok, v : TTrueFalseUnknown; first : boolean; contentMode : TFhirCodeSystemContentMode; - cc, codelist, message, mt, ver, pd, ws, impliedSystem, path, m: String; + cc, codelist, message, ver, pd, ws, impliedSystem, path, m, tsys, tcode, tver,vs, tdisp: String; prov, prov2 : TCodeSystemProvider; ctxt : TCodeSystemProviderContext; c : TFhirCodingW; @@ -1628,256 +1738,346 @@ function TValueSetChecker.check(issuePath : String; code: TFhirCodeableConceptW; vcc : TFHIRCodeableConceptW; severity : TIssueSeverity; diff : TDisplayDifference; - inactive : boolean; + inactive, bAdd : boolean; vstatus : String; + mt, ts : TStringList; + vss : TFHIRValueSetW; procedure msg(s : String; clear : boolean = false); begin if (s = '') then exit(); - if (mt = '') or (clear) then - mt := s - else if not mt.Contains(s) then - mt := mt+'; '+s; + if (clear) then + mt.clear; + if mt.indexOf(s) = -1 then + mt.add(s); end; begin inactive := false; cause := itNull; if FValueSet = nil then raise ETerminologyError.create('Error: cannot validate a CodeableConcept without a nominated valueset', itInvalid); - - vcc := FFactory.wrapCodeableConcept(FFactory.makeCodeableConcept); - vcc.text := code.text; - unknownSystems := TStringList.create; - result := FFactory.makeParameters; + mt := TStringList.create; + ts := TStringList.create; try - unknownSystems.sorted := true; - unknownSystems.duplicates := dupIgnore; - op := FFactory.wrapOperationOutcome(FFactory.makeResource('OperationOutcome')); + tsys := ''; + tcode := ''; + tver := ''; + tdisp := ''; + vcc := FFactory.wrapCodeableConcept(FFactory.makeCodeableConcept); + vcc.text := code.text; + unknownSystems := TStringList.create; + result := FFactory.makeParameters; try - checkCanonicalStatus(issuePath, op, FValueSet, FValueSet); - list := TConceptDesignations.Create(FFactory.link, FLanguages.link); + unknownSystems.sorted := true; + unknownSystems.duplicates := dupIgnore; + op := FFactory.wrapOperationOutcome(FFactory.makeResource('OperationOutcome')); try - ok := bFalse; - codelist := ''; - mt := ''; - i := 0; - for c in code.codings.forEnum do - begin - if (issuePath = 'CodeableConcept') then - path := addToPath(issuePath, 'coding['+inttostr(i)+']') - else - path := issuePath; - list.clear; - v := check(path, c.systemUri, c.version, c.code, abstractOk, inferSystem, list, unknownSystems, message, ver, inactive, vstatus, cause, op, vcc, result, contentMode, impliedSystem); - if (v <> bTrue) and (message <> '') then - msg(message); - if (v = bFalse) then - cause := itCodeInvalid; - if (impliedSystem <> '') then - ws := impliedSystem - else - ws := c.systemUri; - if (c.version = '') then - cc := ws+'#'+c.code - else - cc := ws+'|'+c.version+'#'+c.code; - CommaAdd(codelist, ''''+cc+''''); - - if (ok <> bTrue) and (v <> bFalse) then - ok := v; - message := ''; - - if (v = bTrue) then + checkCanonicalStatus(issuePath, op, FValueSet, FValueSet); + list := TConceptDesignations.Create(FFactory.link, FLanguages.link); + try + ok := bFalse; + codelist := ''; + mt.clear; + i := 0; + for c in code.codings.forEnum do begin - if ((cause = itNotFound) and (contentMode <> cscmComplete)) or (contentMode = cscmExample) then + if (issuePath = 'CodeableConcept') then + path := addToPath(issuePath, 'coding['+inttostr(i)+']') + else + path := issuePath; + list.clear; + v := check(path, c.systemUri, c.version, c.code, abstractOk, inferSystem, list, unknownSystems, message, ver, inactive, vstatus, cause, op, vcc, result, contentMode, impliedSystem, ts, mt); + if (v <> bTrue) and (message <> '') then + msg(message); + if (v = bFalse) then + cause := itCodeInvalid; + if (impliedSystem <> '') then + ws := impliedSystem + else + ws := c.systemUri; + if (tcode = '') or (v = bTrue) then begin - m := 'The system '+c.systemUri+' was found but did not contain enough information to properly validate the code "'+c.code+'" ("'+c.display+'") (mode = '+CODES_TFhirCodeSystemContentMode[contentMode]+')'; - msg(m); - op.addIssue(isWarning, itNotFound, path, m); - end + tsys := c.systemUri; + tcode := c.code; + tver := c.version; + tdisp := c.display; + end; + if (c.version = '') then + cc := ws+'#'+c.code else - if (c.display <> '') and (not list.hasDisplay(FParams.languages, c.display, dcsCaseInsensitive, diff)) then + cc := ws+'|'+c.version+'#'+c.code; + if (c.display <> '') then + cc := cc + ' ('''+c.display+''')'; + CommaAdd(codelist, ''''+cc+''''); + + if (v = bFalse) and not FAllValueSet and (mode = vcmCodeableConcept) then begin - if (diff = ddNormalised) then - baseMsg := 'Display_Name_WS_for__should_be_one_of__instead_of' - else - baseMsg := 'Display_Name_for__should_be_one_of__instead_of'; - dc := list.displayCount(FParams.languages, true); - severity := dispWarning; - if dc = 0 then + m := FI18n.translate('None_of_the_provided_codes_are_in_the_value_set_one', FParams.languages, ['', FValueSet.vurl, ''''+cc+'''']); + msg(m); + p := issuePath + '.coding['+inttostr(i)+'].code'; + op.addIssue(isInformation, itCodeInvalid, p, m, oicThisNotInVS); + if cause = itNull then + cause := itUnknown; + end; + + if (ok <> bTrue) and (v <> bFalse) then + ok := v; + message := ''; + + if (v = bTrue) then + begin + if ((cause = itNotFound) and (contentMode <> cscmComplete)) or (contentMode = cscmExample) then begin - severity := isWarning; - m := FI18n.translate(baseMsg+'_one', FParams.languages, - ['', c.systemUri, c.code, list.present(FParams.languages, true), c.display, FParams.langSummary]) + m := 'The system '+c.systemUri+' was found but did not contain enough information to properly validate the code "'+c.code+'" ("'+c.display+'") (mode = '+CODES_TFhirCodeSystemContentMode[contentMode]+')'; + msg(m); + op.addIssue(isWarning, itNotFound, path, m, oicVSProcessing); end - else if dc = 1 then - m := FI18n.translate(baseMsg+'_one', FParams.languages, - ['', c.systemUri, c.code, list.present(FParams.languages, true), c.display, FParams.langSummary]) else - m := FI18n.translate(baseMsg+'_other', FParams.languages, - [inttostr(dc), c.systemUri, c.code, list.present(FParams.languages, true), c.display, FParams.langSummary]); - msg(m); - op.addIssue(severity, itInvalid, addToPath(path, 'display'), m); - end; - psys := c.systemUri; - pcode := c.code; - if (ver <> '') then - pver := ver; - pd := list.preferredDisplay(FParams.languages); - if pd <> '' then - pdisp := pd; - if (pdisp = '') then - pdisp := list.preferredDisplay; - end - else if (FParams.valueSetMode <> vsvmMembershipOnly) then - begin - prov := findCodeSystem(ws, c.version, FParams, true); - try - if (prov = nil) then - begin - prov2 := findCodeSystem(ws, '', FParams, true); - try - if (prov2 = nil) then - begin - m := FI18n.translate('UNKNOWN_CODESYSTEM', FParams.languages, [ws]); - //if (valueSetDependsOnCodeSystem(ws, '')) then - unknownSystems.add(ws); - end - else - begin - m := FI18n.translate('UNKNOWN_CODESYSTEM_VERSION', FParams.languages, [ws, c.version, '['+listVersions(c.systemUri)+']']); - //if (valueSetDependsOnCodeSystem(ws, c.version)) then - unknownSystems.add(ws+'|'+c.version); - end; - op.addIssue(isError, itNotFound, addToPath(path, 'system'), m); - if (valueSetDependsOnCodeSystem(ws, c.version)) then - begin - m := 'Unable to check whether the code is in the value set '+FValueSet.vurl; - msg(m); - op.addIssue(isWarning, itNotFound, issuepath, m); - end - else - msg(m); - finally - prov2.free; - end; - cause := itNotFound; - end - else - begin - checkCanonicalStatus(path, op, prov, FValueSet); - ctxt := prov.locate(c.code, FAllAltCodes, message); - try - if ctxt = nil then + if (c.display <> '') and (not list.hasDisplay(FParams.languages, c.display, dcsCaseInsensitive, diff)) then + begin + if (diff = ddNormalised) then + baseMsg := 'Display_Name_WS_for__should_be_one_of__instead_of' + else + baseMsg := 'Display_Name_for__should_be_one_of__instead_of'; + dc := list.displayCount(FParams.languages, true); + severity := dispWarning; + if dc = 0 then + begin + severity := isWarning; + m := FI18n.translate(baseMsg+'_one', FParams.languages, + ['', c.systemUri, c.code, list.present(FParams.languages, true), c.display, FParams.langSummary]) + end + else if dc = 1 then + m := FI18n.translate(baseMsg+'_one', FParams.languages, + ['', c.systemUri, c.code, list.present(FParams.languages, true), c.display, FParams.langSummary]) + else + m := FI18n.translate(baseMsg+'_other', FParams.languages, + [inttostr(dc), c.systemUri, c.code, list.present(FParams.languages, true), c.display, FParams.langSummary]); + msg(m); + op.addIssue(severity, itInvalid, addToPath(path, 'display'), m, oicDisplay); + end; + psys := c.systemUri; + pcode := c.code; + if (ver <> '') then + pver := ver; + pd := list.preferredDisplay(FParams.languages); + if pd <> '' then + pdisp := pd; + if (pdisp = '') then + pdisp := list.preferredDisplay; + end + else if (not FParams.membershipOnly and (ws <> '')) then + begin + if not isAbsoluteUrl(ws) then + begin + m := FI18n.translate('Terminology_TX_System_Relative', FParams.languages, []); + if mode = vcmCoding then + p := issuePath + '.system' + else if mode = vcmCodeableConcept then + p := issuePath + '.coding['+inttostr(i)+'].system' + else + p := issuePath; + op.addIssue(isError, itInvalid, p, m, oicInvalidData); + end; + prov := findCodeSystem(ws, c.version, FParams, true); + try + if (prov = nil) then + begin + vss := findValueSet(ws, ''); + if (vss <> nil) then begin - if (message <> '') then - begin - msg(message); - op.addIssue(isInformation, cause, path, message); - end; - m := FI18N.translate('Unknown_Code__in_', FParams.languages, [c.code, vurl(ws, prov.version(nil))]); - cause := itCodeInvalid; + vss.free; + m := FI18n.translate('Terminology_TX_System_ValueSet2', FParams.languages, [ws]); msg(m); - vcc.removeCoding(prov.systemUri(nil), prov.version(nil), c.code); - op.addIssue(isError, itCodeInvalid, addToPath(path, 'code'), m); + op.addIssue(isError, itInvalid, addToPath(path, 'system'), m, oicInvalidData); + cause := itNotFound; end else begin - listDisplays(list, prov, ctxt); - severity := dispWarning(); - if (c.display <> '') and (not list.hasDisplay(FParams.languages, c.display, dcsCaseInsensitive, diff)) then - begin - if (diff = ddNormalised) then - baseMsg := 'Display_Name_WS_for__should_be_one_of__instead_of' + prov2 := findCodeSystem(ws, '', FParams, true); + try + bAdd := true; + if (prov2 = nil) then + begin + m := FI18n.translate('UNKNOWN_CODESYSTEM', FParams.languages, [ws]); + //if (valueSetDependsOnCodeSystem(ws, '')) then + unknownSystems.add(ws); + end else - baseMsg := 'Display_Name_for__should_be_one_of__instead_of'; - - dc := list.displayCount(FParams.languages, true); - if dc = 0 then begin - severity := isWarning; - m := FI18n.translate(baseMsg+'_other', FParams.languages, - ['', prov.systemUri(ctxt), c.code, list.present(FParams.languages, true), c.display, FParams.langSummary]) + m := FI18n.translate('UNKNOWN_CODESYSTEM_VERSION', FParams.languages, [ws, c.version, '['+listVersions(c.systemUri)+']']); + badd := unknownSystems.IndexOf(ws+'|'+c.version) = -1; + if (bAdd) then + unknownSystems.add(ws+'|'+c.version); + end; + if (bAdd) then + op.addIssue(isError, itNotFound, addToPath(path, 'system'), m, oicNotFound); + if (valueSetDependsOnCodeSystem(ws, c.version)) then + begin + m := 'Unable to check whether the code is in the value set '+FValueSet.vurl+' because the code system '+ws+'|'+c.version+' was not found'; + msg(m); + op.addIssue(isWarning, itNotFound, issuepath, m, oicVSProcessing); end - else if dc = 1 then - m := FI18n.translate(baseMsg+'_one', FParams.languages, - ['', prov.systemUri(ctxt), c.code, list.present(FParams.languages, true), c.display, FParams.langSummary]) else - m := FI18n.translate(baseMsg+'_other', FParams.languages, - [inttostr(dc), prov.systemUri(ctxt), c.code, list.present(FParams.languages, true), c.display, FParams.langSummary]); - msg(m); - op.addIssue(severity, itInvalid, addToPath(path, 'display'), m); + msg(m); + finally + prov2.free; + end; + cause := itNotFound; + end; + end + else + begin + checkCanonicalStatus(path, op, prov, FValueSet); + ctxt := prov.locate(c.code, FAllAltCodes, message); + try + if ctxt = nil then + begin + if (message <> '') then + begin + // msg(message); we just add this as an issue, but don't put it in the base message + if mode <> vcmCode then + p := path + '.code'; + op.addIssue(isInformation, cause, p, message, oicInvalidCode); + message := ''; + end; + vcc.removeCoding(prov.systemUri(nil), prov.version(nil), c.code); + vs := ws+'|'+prov.version(nil)+'#'+c.code; + if ts.indexOf(vs) = -1 then + begin + ts.add(vs); + m := FI18N.translate('Unknown_Code_in_Version', FParams.languages, [c.code, ws, prov.version(nil)]); + cause := itCodeInvalid; + msg(m); + op.addIssue(isError, itCodeInvalid, addToPath(path, 'code'), m, oicInvalidCode); + end; + end + else + begin + listDisplays(list, prov, ctxt); + pd := list.preferredDisplay(FParams.languages); + if pd <> '' then + pdisp := pd; + if (pdisp = '') then + pdisp := list.preferredDisplay; + severity := dispWarning(); + if (c.display <> '') and (not list.hasDisplay(FParams.languages, c.display, dcsCaseInsensitive, diff)) then + begin + if (diff = ddNormalised) then + baseMsg := 'Display_Name_WS_for__should_be_one_of__instead_of' + else + baseMsg := 'Display_Name_for__should_be_one_of__instead_of'; + + dc := list.displayCount(FParams.languages, true); + if dc = 0 then + begin + severity := isWarning; + m := FI18n.translate(baseMsg+'_other', FParams.languages, + ['', prov.systemUri(ctxt), c.code, list.present(FParams.languages, true), c.display, FParams.langSummary]) + end + else if dc = 1 then + m := FI18n.translate(baseMsg+'_one', FParams.languages, + ['', prov.systemUri(ctxt), c.code, list.present(FParams.languages, true), c.display, FParams.langSummary]) + else + m := FI18n.translate(baseMsg+'_other', FParams.languages, + [inttostr(dc), prov.systemUri(ctxt), c.code, list.present(FParams.languages, true), c.display, FParams.langSummary]); + msg(m); + op.addIssue(severity, itInvalid, addToPath(path, 'display'), m, oicDisplay); + end; + if (prov.version(nil) <> '') then + result.addParamStr('version', prov.version(nil)); end; - if (prov.version(nil) <> '') then - result.addParamStr('version', prov.version(nil)); + finally + ctxt.free; end; - finally - ctxt.free; end; - end; - finally - prov.free; + finally + prov.free; + end; end; + inc(i); end; - inc(i); + if (ok = bFalse) and not FAllValueSet then + begin + if mode = vcmCodeableConcept then + m := FI18n.translate('TX_GENERAL_CC_ERROR_MESSAGE', FParams.languages, [FValueSet.vurl]) + else // true... if code.codingCount = 1 then + m := FI18n.translate('None_of_the_provided_codes_are_in_the_value_set_one', FParams.languages, ['', FValueSet.vurl, codelist]); + //else + // m := FI18n.translate('None_of_the_provided_codes_are_in_the_value_set_other', FParams.languages, ['', FValueSet.vurl, codelist]); + msg(m); + + if mode = vcmCodeableConcept then + p := '' + else if (issuePath <> 'CodeableConcept') then + p := issuePath + '.code' + else if code.codingCount = 1 then + p := issuePath + '.coding[0].code' + else + p := issuePath; + + op.addIssue(isError, itCodeInvalid, p, m, oicNotInVS); + if cause = itNull then + cause := itUnknown; + end; + finally + list.free; end; - if (ok = bFalse) then - begin - if code.codingCount = 1 then - m := FI18n.translate('None_of_the_provided_codes_are_in_the_value_set_one', FParams.languages, ['', FValueSet.vurl, codelist]) - else - m := FI18n.translate('None_of_the_provided_codes_are_in_the_value_set_other', FParams.languages, ['', FValueSet.vurl, codelist]); - msg(m); - if (issuePath <> 'CodeableConcept') then - p := issuePath + '.code' - else if code.codingCount = 1 then - p := issuePath + '.coding[0].code' - else - p := issuePath; + result.AddParamBool('result', (ok = bTrue) and not op.hasErrors); + if (psys <> '') then + result.addParamUri('system', psys) + else if (ok = bTrue) and (impliedSystem <> '') then + result.addParamUri('system', impliedSystem) + else if (tsys <> '') and (mode <> vcmCodeableConcept) then + result.addParamUri('system', tsys); - op.addIssue(isError, itCodeInvalid, p, m); - if cause = itNull then - cause := itUnknown; + if (ok <> bTrue) and (unknownSystems.count > 0) then + for us in unknownSystems do + result.addParamCanonical('x-caused-by-unknown-system', us); + if (pcode <>'') then + result.addParamCode('code', pcode) + else if (tcode <> '') and (mode <> vcmCodeableConcept) then + result.addParamCode('code', tcode); + if (pver <> '') then + result.addParamStr('version', pver) + else if (tver <> '') and (mode <> vcmCodeableConcept) then + result.addParamStr('version', tver); + + if pdisp <> '' then + result.AddParamStr('display', pdisp); + //else if tdisp <> '' then + // result.AddParamStr('display', tdisp); + + if inactive then + begin + result.addParamBool('inactive',inactive); + if (vstatus <> '') and (vstatus <> 'inactive') then + result.addParamStr('status', vstatus); + end; + if mt.count > 0 then + begin + mt.sort; + result.AddParamStr('message', toText(mt, '; ')); + end; + if (mode = vcmCodeableConcept) then + begin + result.addParam('codeableConcept', code.Element.link); end; + if (op.hasIssues) then + result.addParam('issues').resource := op.Resource.link; finally - list.free; - end; - - result.AddParamBool('result', (ok = bTrue) and not op.hasErrors); - if (psys <> '') then - result.addParamUri('system', psys) - else if (ok = bTrue) and (impliedSystem <> '') then - result.addParamUri('system', impliedSystem); - if (ok <> bTrue) and (unknownSystems.count > 0) then - for us in unknownSystems do - result.addParamCanonical('x-caused-by-unknown-system', us); - if (pcode <>'') then - result.addParamCode('code', pcode); - if (pver <> '') then - result.addParamStr('version', pver); - if pdisp <> '' then - result.AddParamStr('display', pdisp); - if inactive then - begin - result.addParamBool('inactive',inactive); - if (vstatus <> '') and (vstatus <> 'inactive') then - result.addParamStr('status', vstatus); + op.free; end; - if mt <> '' then - result.AddParamStr('message', mt); - if (addCodeable and (vcc.codingCount > 0)) then - result.addParam('codeableConcept', vcc.Element.link); - if (op.hasIssues) then - result.addParam('issues').resource := op.Resource.link; + result.Link; finally - op.free; + result.free; + vcc.free; + unknownSystems.free; end; - result.Link; finally - result.free; - vcc.free; - unknownSystems.free; + mt.free; + ts.free; end; end; @@ -1889,11 +2089,13 @@ function TValueSetChecker.check(issuePath, system, version, code: String; inferS op : TFhirOperationOutcomeW; contentMode : TFhirCodeSystemContentMode; ok : TTrueFalseUnknown; - unknownSystems : TStringList; + unknownSystems, unkCodes, messages : TStringList; inactive : boolean; vstatus : String; begin unknownSystems := TStringList.create; + unkCodes := TStringList.create; + messages := TStringList.create; try unknownSystems.sorted := true; unknownSystems.duplicates := dupIgnore; @@ -1904,7 +2106,7 @@ function TValueSetChecker.check(issuePath, system, version, code: String; inferS checkCanonicalStatus(issuePath, op, FValueSet, FValueSet); list := TConceptDesignations.Create(FFactory.link, FLanguages.link); try - ok := check(issuePath, system, version, code, true, inferSystem, list, unknownSystems, message, ver, inactive, vstatus, cause, op, nil, result, contentMode, impliedSystem); + ok := check(issuePath, system, version, code, true, inferSystem, list, unknownSystems, message, ver, inactive, vstatus, cause, op, nil, result, contentMode, impliedSystem, unkCodes, messages); if ok = bTrue then begin result.AddParamBool('result', true); @@ -1927,7 +2129,7 @@ function TValueSetChecker.check(issuePath, system, version, code: String; inferS begin result.AddParamBool('result', false); result.AddParamStr('message', 'The system "'+system+'" is unknown so the /"'+code+'" cannot be confirmed to be in the value set '+FValueSet.name); - op.addIssue(isError, cause, 'code', 'The system "'+system+'" is unknown so the /"'+code+'" cannot be confirmed to be in the value set '+FValueSet.name); + op.addIssue(isError, cause, 'code', 'The system "'+system+'" is unknown so the /"'+code+'" cannot be confirmed to be in the value set '+FValueSet.name, oicNotFound); //result.AddParamCode('cause', CODES_TFhirIssueType[itNotFound]); for us in unknownSystems do result.addParamCanonical('x-caused-by-unknown-system', us); @@ -1936,7 +2138,7 @@ function TValueSetChecker.check(issuePath, system, version, code: String; inferS begin result.AddParamBool('result', false); result.AddParamStr('message', 'The system/code "'+system+'"/"'+code+'" is not in the value set '+FValueSet.name); - op.addIssue(isError, cause, 'code', 'The system/code "'+system+'"/"'+code+'" is not in the value set '+FValueSet.name); + op.addIssue(isError, cause, 'code', 'The system/code "'+system+'"/"'+code+'" is not in the value set '+FValueSet.name, oicNotInVS); if (message <> '') then result.AddParamStr('message', message); if cause <> itNull then @@ -1956,6 +2158,8 @@ function TValueSetChecker.check(issuePath, system, version, code: String; inferS end; finally unknownSystems.free; + unkCodes.free; + messages.free; end; end; @@ -1994,29 +2198,39 @@ function TValueSetChecker.checkConceptSet(path : String; cs: TCodeSystemProvider result := false; if loc = nil then begin - if (FParams.valueSetMode <> vsvmMembershipOnly) then - op.addIssue(isError, itCodeInvalid, addToPath(path, 'code'), FI18n.translate('Unknown_Code__in_', FParams.languages, [code, vurl(cs.systemUri(nil), cs.version(nil))])) + if (not FParams.membershipOnly) then + op.addIssue(isError, itCodeInvalid, addToPath(path, 'code'), FI18n.translate('Unknown_Code_in_Version', FParams.languages, [code, cs.systemUri(nil), cs.version(nil)]), oicInvalidCode) end else if not (abstractOk or not cs.IsAbstract(loc)) then begin - if (FParams.valueSetMode <> vsvmMembershipOnly) then - op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('ABSTRACT_CODE_NOT_ALLOWED', FParams.languages, [cs.systemUri(nil), code])) + if (not FParams.membershipOnly) then + op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('ABSTRACT_CODE_NOT_ALLOWED', FParams.languages, [cs.systemUri(nil), code]), oicCodeRule) end else if FValueSet.excludeInactives and cs.IsInactive(loc) then begin + op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('STATUS_CODE_WARNING_CODE', FParams.languages, ['not active', code]), oicCodeRule); result := false; - if (FParams.valueSetMode <> vsvmMembershipOnly) then + if (not FParams.membershipOnly) then begin inactive := true; if (inactive) then vstatus := cs.getCodeStatus(loc); end; end + else if FParams.activeOnly and cs.IsInactive(loc) then + begin + result := false; + inactive := true; + vstatus := cs.getCodeStatus(loc); + op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('STATUS_CODE_WARNING_CODE', FParams.languages, ['not active', code]), oicCodeRule); + end else begin result := true; listDisplays(displays, cs, loc); inactive := cs.IsInactive(loc); + + if (inactive) then vstatus := cs.getCodeStatus(loc); @@ -2042,13 +2256,13 @@ function TValueSetChecker.checkConceptSet(path : String; cs: TCodeSystemProvider listDisplays(displays, cc, vs); if not (abstractOk or not cs.IsAbstract(loc)) then begin - if (FParams.valueSetMode <> vsvmMembershipOnly) then - op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('ABSTRACT_CODE_NOT_ALLOWED', FParams.languages, [cs.systemUri(nil), code])) + if (not FParams.membershipOnly) then + op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('ABSTRACT_CODE_NOT_ALLOWED', FParams.languages, [cs.systemUri(nil), code]), oicCodeRule) end else if FValueSet.excludeInactives and cs.IsInactive(loc) then begin result := false; - if (FParams.valueSetMode <> vsvmMembershipOnly) then + if (not FParams.membershipOnly) then begin inactive := true; vstatus := cs.getCodeStatus(loc); @@ -2095,13 +2309,13 @@ function TValueSetChecker.checkConceptSet(path : String; cs: TCodeSystemProvider listDisplays(displays, cs, loc); if not (abstractOk or not cs.IsAbstract(loc)) then begin - if (FParams.valueSetMode <> vsvmMembershipOnly) then - op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('ABSTRACT_CODE_NOT_ALLOWED', FParams.languages, [cs.systemUri(nil), code])) + if (not FParams.membershipOnly) then + op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('ABSTRACT_CODE_NOT_ALLOWED', FParams.languages, [cs.systemUri(nil), code]), oicCodeRule) end else if FValueSet.excludeInactives and cs.IsInactive(loc) then begin result := false; - if (FParams.valueSetMode <> vsvmMembershipOnly) then + if (not FParams.membershipOnly) then begin inactive := true; vstatus := cs.getCodeStatus(loc); @@ -2134,8 +2348,8 @@ function TValueSetChecker.checkConceptSet(path : String; cs: TCodeSystemProvider listDisplays(displays, cs, loc); if not (abstractOk or not cs.IsAbstract(loc)) then begin - if (FParams.valueSetMode <> vsvmMembershipOnly) then - op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('ABSTRACT_CODE_NOT_ALLOWED', FParams.languages, [cs.systemUri(nil), code])) + if (not FParams.membershipOnly) then + op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('ABSTRACT_CODE_NOT_ALLOWED', FParams.languages, [cs.systemUri(nil), code]), oicCodeRule) end else begin @@ -2164,13 +2378,13 @@ function TValueSetChecker.checkConceptSet(path : String; cs: TCodeSystemProvider listDisplays(displays, cs, loc); if not (abstractOk or not cs.IsAbstract(loc)) then begin - if (FParams.valueSetMode <> vsvmMembershipOnly) then - op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('ABSTRACT_CODE_NOT_ALLOWED', FParams.languages, [cs.systemUri(nil), code])) + if (not FParams.membershipOnly) then + op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('ABSTRACT_CODE_NOT_ALLOWED', FParams.languages, [cs.systemUri(nil), code]), oicCodeRule) end else if FValueSet.excludeInactives and cs.IsInactive(loc) then begin result := false; - if (FParams.valueSetMode <> vsvmMembershipOnly) then + if (not FParams.membershipOnly) then begin inactive := true; vstatus := cs.getCodeStatus(loc); @@ -2202,13 +2416,13 @@ function TValueSetChecker.checkConceptSet(path : String; cs: TCodeSystemProvider listDisplays(displays, cs, loc); if not (abstractOk or not cs.IsAbstract(loc)) then begin - if (FParams.valueSetMode <> vsvmMembershipOnly) then - op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('ABSTRACT_CODE_NOT_ALLOWED', FParams.languages, [cs.systemUri(nil), code])) + if (not FParams.membershipOnly) then + op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('ABSTRACT_CODE_NOT_ALLOWED', FParams.languages, [cs.systemUri(nil), code]), oicCodeRule) end else if FValueSet.excludeInactives and cs.IsInactive(loc) then begin result := false; - if (FParams.valueSetMode <> vsvmMembershipOnly) then + if (not FParams.membershipOnly) then begin inactive := true; vstatus := cs.getCodeStatus(loc); @@ -2253,13 +2467,13 @@ function TValueSetChecker.checkExpansion(path: String; cs: TCodeSystemProvider; result := false; if loc = nil then begin - if (FParams.valueSetMode <> vsvmMembershipOnly) then - op.addIssue(isError, itCodeInvalid, addToPath(path, 'code'), FI18n.translate('Unknown_Code__in_', FParams.languages, [code, vurl(cs.systemUri(nil), cs.version(nil))])) + if (not FParams.membershipOnly) then + op.addIssue(isError, itCodeInvalid, addToPath(path, 'code'), FI18n.translate('Unknown_Code_in_Version', FParams.languages, [code, cs.systemUri(nil), cs.version(nil)]), oicInvalidCode) end else if not (abstractOk or not cs.IsAbstract(loc)) then begin - if (FParams.valueSetMode <> vsvmMembershipOnly) then - op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('ABSTRACT_CODE_NOT_ALLOWED', FParams.languages, [cs.systemUri(nil), code])) + if (not FParams.membershipOnly) then + op.addIssue(isError, itBusinessRule, addToPath(path, 'code'), FI18n.translate('ABSTRACT_CODE_NOT_ALLOWED', FParams.languages, [cs.systemUri(nil), code]), oicCodeRule) end else begin @@ -2398,11 +2612,13 @@ function TFHIRValueSetExpander.expand(source: TFHIRValueSetW; if FParams.hasExcludePostCoordinated then exp.addParamBool('excludePostCoordinated', FParams.excludePostCoordinated); checkCanonicalStatus(exp, source, source); - if FOffset + Fcount > 0 then + if FOffset > -1 then begin exp.addParamInt('offset', FOffset); - exp.addParamInt('count', FCount); + exp.offset := FOffset; end; + if FCount > -1 then + exp.addParamInt('count', FCount); DeadCheck('expand'); try @@ -2490,7 +2706,7 @@ function TFHIRValueSetExpander.expand(source: TFHIRValueSetW; if FMap.containsKey(key(c)) then begin inc(o); - if FCanBeHierarchy or (o > offset) and ((count = 0) or (t < count)) then + if FCanBeHierarchy or (o > offset) and ((count <= 0) or (t < count)) then begin inc(t); exp.addContains(c); @@ -2848,6 +3064,23 @@ function TFHIRValueSetExpander.isValidating: boolean; result := false; end; +function getPropUrl(cs : TCodeSystemProvider; pcode : String) : String; +var + pl : TFslList; + p : TFhirCodeSystemPropertyW; +begin + result := ''; + pl := cs.getPropertyDefinitions; + try + if pl <> nil then + for p in pl do + if p.code = pcode then + exit(p.uri); + finally + pl.free; + end; +end; + function TFHIRValueSetExpander.processCode(cs : TCodeSystemProvider; parent : TFhirValueSetExpansionContainsW; doDelete : boolean; system, version, code : String; isAbstract, isInactive, deprecated : boolean; displays : TConceptDesignations; definition, itemWeight: string; expansion : TFhirValueSetExpansionW; imports : TFslList; csExtList, vsExtList : TFslList; csProps : TFslList; expProps : TFslList; excludeInactive : boolean; srcURL : string) : TFhirValueSetExpansionContainsW; @@ -2881,7 +3114,7 @@ function TFHIRValueSetExpander.processCode(cs : TCodeSystemProvider; parent : TF if (FLimitCount > 0) and (FFullList.Count >= FLimitCount) and not doDelete then begin - if (FCount + FOffset > 0) and (FFullList.count > FCount + FOffset) then + if (FCount > -1) and (FOffset > -1) and (FCount + FOffset > 0) and (FFullList.count > FCount + FOffset) then raise EFinished.create('.') else raise ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY', FParams.languages, [srcUrl, '>'+inttostr(FLimitCount)])); @@ -2933,9 +3166,9 @@ function TFHIRValueSetExpander.processCode(cs : TCodeSystemProvider; parent : TF expansion.defineProperty(n, 'http://hl7.org/fhir/concept-properties#label', 'label', FFactory.makeString(getExtensionString(vsExtList, 'http://hl7.org/fhir/StructureDefinition/valueset-label'))); if (hasExtension(csExtList, 'http://hl7.org/fhir/StructureDefinition/codesystem-conceptOrder')) then - expansion.defineProperty(n, 'http://hl7.org/fhir/concept-properties#order', 'order', FFactory.makeInteger(getExtensionString(csExtList, 'http://hl7.org/fhir/StructureDefinition/codesystem-conceptOrder'))); + expansion.defineProperty(n, 'http://hl7.org/fhir/concept-properties#order', 'order', FFactory.makeDecimal(getExtensionString(csExtList, 'http://hl7.org/fhir/StructureDefinition/codesystem-conceptOrder'))); if (hasExtension(vsExtList, 'http://hl7.org/fhir/StructureDefinition/valueset-conceptOrder')) then - expansion.defineProperty(n, 'http://hl7.org/fhir/concept-properties#order', 'order', FFactory.makeInteger(getExtensionString(vsExtList, 'http://hl7.org/fhir/StructureDefinition/valueset-conceptOrder'))); + expansion.defineProperty(n, 'http://hl7.org/fhir/concept-properties#order', 'order', FFactory.makeDecimal(getExtensionString(vsExtList, 'http://hl7.org/fhir/StructureDefinition/valueset-conceptOrder'))); if (hasExtension(csExtList, 'http://hl7.org/fhir/StructureDefinition/itemWeight')) then expansion.defineProperty(n, 'http://hl7.org/fhir/concept-properties#itemWeight', 'weight', FFactory.makeDecimal(getExtensionString(csExtList, 'http://hl7.org/fhir/StructureDefinition/itemWeight'))); @@ -2975,7 +3208,7 @@ function TFHIRValueSetExpander.processCode(cs : TCodeSystemProvider; parent : TF begin vstr := FFactory.makeString(definition); try - n.addProperty(pn, vstr); + expansion.defineProperty(n, 'http://hl7.org/fhir/concept-properties#definition', pn, vstr.link); finally vstr.free; end; @@ -2986,7 +3219,10 @@ function TFHIRValueSetExpander.processCode(cs : TCodeSystemProvider; parent : TF for cp in csprops do begin if cp.code = pn then - n.addProperty(pn, cp); + begin + expansion.defineProperty(n, getPropUrl(cs, pn), pn, cp.value.link); + // n.addProperty(pn, cp); + end; end; end; end; @@ -3197,7 +3433,7 @@ procedure TFHIRValueSetExpander.checkSource(cset: TFhirValueSetComposeIncludeW; else raise ETooCostly.create('The code System "'+cs.systemUri(nil)+'" has a grammar, and cannot be enumerated directly'); - if not imp and (FLimitCount > 0) and (cs.TotalCount > FLimitCount) and not (FParams.limitedExpansion) and (FOffset+FCount = 0) then + if not imp and (FLimitCount > 0) and (cs.TotalCount > FLimitCount) and not (FParams.limitedExpansion) and (FOffset+FCount <= 0) then raise ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY', FParams.languages, [srcUrl, '>'+inttostr(FLimitCount)])); end end; @@ -3347,7 +3583,7 @@ procedure TFHIRValueSetExpander.processCodes(doDelete : boolean; cset: TFhirValu iter := cs.getIterator(nil); try - if valueSets.Empty and (FLimitCount > 0) and (iter.count > FLimitCount) and not (FParams.limitedExpansion) and not doDelete and (FOffset + Fcount = 0) then + if valueSets.Empty and (FLimitCount > 0) and (iter.count > FLimitCount) and not (FParams.limitedExpansion) and not doDelete and (FOffset + Fcount < 0) then raise ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY', FParams.languages, [vsSrc.url, '>'+inttostr(FLimitCount)])); while iter.more do begin @@ -3464,7 +3700,7 @@ procedure TFHIRValueSetExpander.processCodes(doDelete : boolean; cset: TFhirValu inner := cs.prepare(prep); count := 0; - While cs.FilterMore(filters[0]) and ((FOffset + FCount = 0) or (count < FOffset + FCount)) do + While cs.FilterMore(filters[0]) and (((FOffset <= 0) and (FCount <= 0)) or (count < FOffset + FCount)) do begin deadCheck('processCodes#5'); c := cs.FilterConcept(filters[0]); @@ -3683,10 +3919,10 @@ procedure TFHIRExpansionParams.SetDisplayWarning(value : boolean); FHasDisplayWarning := true; end; -procedure TFHIRExpansionParams.SetValueSetMode(value : TValueSetValidationMode); +procedure TFHIRExpansionParams.SetMembershipOnly(value : boolean); begin - FValueSetMode := value; - FHasValueSetMode := true; + FMembershipOnly := value; + FHasMembershipOnly := true; end; function TFHIRExpansionParams.sizeInBytesV(magic : integer) : cardinal; @@ -3768,11 +4004,11 @@ function TFHIRExpansionParams.hash: String; result := '0|'; end; begin - s := FUid+'|'+ inttostr(ord(FValueSetMode)) + '|' + FProperties.CommaText+'|'+ + s := FUid+'|'+ b(FMembershipOnly) + '|' + FProperties.CommaText+'|'+ b(FactiveOnly)+b(FIncompleteOK)+b(FDisplayWarning)+b(FexcludeNested)+b(FGenerateNarrative)+b(FlimitedExpansion)+b(FexcludeNotForUI)+b(FexcludePostCoordinated)+ b(FincludeDesignations)+b(FincludeDefinition)+b(FHasactiveOnly)+b(FHasExcludeNested)+b(FHasGenerateNarrative)+ b(FHasLimitedExpansion)+b(FHesExcludeNotForUI)+b(FHasExcludePostCoordinated)+b(FHasIncludeDesignations)+ - b(FHasIncludeDefinition)+b(FHasDefaultToLatestVersion)+b(FHasIncompleteOK)+b(FHasDisplayWarning)+b(FHasexcludeNotForUI)+b(FHasValueSetMode)+b(FDefaultToLatestVersion); + b(FHasIncludeDefinition)+b(FHasDefaultToLatestVersion)+b(FHasIncompleteOK)+b(FHasDisplayWarning)+b(FHasexcludeNotForUI)+b(FHasMembershipOnly)+b(FDefaultToLatestVersion); if hasLanguages then s := s + FLanguages.AsString(true)+'|'; diff --git a/library/ftx/ftx_lang.pas b/library/ftx/ftx_lang.pas index 79ff8a3f2..75aa7fca9 100644 --- a/library/ftx/ftx_lang.pas +++ b/library/ftx/ftx_lang.pas @@ -180,7 +180,10 @@ procedure TIETFLanguageCodeServices.Designations(context: TCodeSystemProviderCon begin list.addDesignation(true, true, '', FLanguages.present(c.FInfo).Trim); if (c.FInfo.isLangRegion) then + begin list.addDesignation(false, true, '', FLanguages.present(c.FInfo, '{{lang}} ({{region}})').Trim); + list.addDesignation(false, true, '', FLanguages.present(c.FInfo, '{{lang}} (Region={{region}})').Trim); + end; end; end; end; diff --git a/library/ftx/ftx_sct_services.pas b/library/ftx/ftx_sct_services.pas index 308b0a1e2..8dcc034e5 100644 --- a/library/ftx/ftx_sct_services.pas +++ b/library/ftx/ftx_sct_services.pas @@ -5420,15 +5420,18 @@ function TSnomedProvider.locate(code: String; altOpt : TAlternateCodeOptions; va try result := TSnomedExpressionContext.Create(code, FSct.parseExpression(code)) except - Message := 'Unable to find code '+code+' in '+systemUri(nil)+' (version '+version(nil)+')'; - result := nil; + on e : Exception do + begin + Message := 'Code '+code+' is not a valid SNOMED CT Term, and neither could it be parsed as an expression ('+e.message+')'; + result := nil; + end; end end else if FSct.Concept.FindConcept(iId, index) Then result := TSnomedExpressionContext.create(code, index) else begin - Message := 'Unable to find code '+code+' in '+systemUri(nil)+' (version '+version(nil)+')'; + Message := ''; // 'Unable to find code '+code+' in '+systemUri(nil)+' (version '+version(nil)+')'; it's not useful to say anything more result := nil; end; end; diff --git a/library/ftx/ftx_service.pas b/library/ftx/ftx_service.pas index ab7de776a..744f28ca9 100644 --- a/library/ftx/ftx_service.pas +++ b/library/ftx/ftx_service.pas @@ -226,6 +226,7 @@ TCodeSystemProvider = class abstract (TFslObject) function expandLimitation : Integer; virtual; function description : String; virtual; abstract; function TotalCount : integer; virtual; abstract; + function getPropertyDefinitions : TFslList; virtual; function getIterator(context : TCodeSystemProviderContext) : TCodeSystemIteratorContext; virtual; abstract; function getNextContext(context : TCodeSystemIteratorContext) : TCodeSystemProviderContext; virtual; abstract; function systemUri(context : TCodeSystemProviderContext) : String; virtual; abstract; @@ -835,6 +836,11 @@ function TCodeSystemProvider.expandLimitation: Integer; result := 0; // no limit end; +function TCodeSystemProvider.getPropertyDefinitions: TFslList; +begin + result := nil; +end; + function TCodeSystemProvider.IsInactive(context: TCodeSystemProviderContext): boolean; begin result := false; diff --git a/library/ftx/ftx_ucum_services.pas b/library/ftx/ftx_ucum_services.pas index 432d66396..1db602a5a 100644 --- a/library/ftx/ftx_ucum_services.pas +++ b/library/ftx/ftx_ucum_services.pas @@ -282,6 +282,8 @@ TUcumServiceList = class (TFslObjectList) Property Definition[iIndex : Integer] : TUcumServices read GetDefinition; Default; End; + { TUcumServiceImplementation } + TUcumServiceImplementation = class (TUcumServiceInterface) private FSvc : TUcumServices; @@ -293,6 +295,8 @@ TUcumServiceImplementation = class (TUcumServiceInterface) Function multiply(o1, o2 : TUcumPair) : TUcumPair; override; Function divideBy(o1, o2 : TUcumPair) : TUcumPair; override; function getCanonicalForm(value : TUcumPair) : TUcumPair; override; + function getCanonicalUnits(units : string) : string; override; + function isComparable(u1, u2 : String) : boolean; override; Function isConfigured : boolean; override; end; @@ -1267,6 +1271,37 @@ function TUcumServiceImplementation.getCanonicalForm(value: TUcumPair): TUcumPai result := FSvc.getCanonicalForm(value); end; +function TUcumServiceImplementation.getCanonicalUnits(units: string): string; +var + p1, p2 : TUcumPair; +begin + if units = '' then + result := '' + else + begin + p1 := TUcumPair.create(TFslDecimal.makeOne, units); + try + p2 := getCanonicalForm(p1); + try + result := p2.UnitCode; + finally + p2.free; + end; + finally + p1.free; + end; + end; + +end; + +function TUcumServiceImplementation.isComparable(u1, u2: String): boolean; +begin + if (u1 = '') or (u2 = '') then + result := false + else + result := getCanonicalUnits(u1) = getCanonicalUnits(u2); +end; + function TUcumServiceImplementation.isConfigured: boolean; begin result := FSvc <> nil; diff --git a/library/web/fsl_crypto.pas b/library/web/fsl_crypto.pas index 8db6b1101..a01c827cf 100644 --- a/library/web/fsl_crypto.pas +++ b/library/web/fsl_crypto.pas @@ -80,7 +80,7 @@ interface IdOpenSSLHeaders_pem, IdOpenSSLHeaders_err, IdOpenSSLHeaders_evp, IdOpenSSLHeaders_ec, IdOpenSSLHeaders_obj_mac, IdOpenSSLHeaders_x509, IdOpenSSLHeaders_x509v3, IdOpenSSLHeaders_x509_vfy, IdOpenSSLX509, - fsl_base, fsl_utilities, fsl_stream, fsl_collections, fsl_json, fsl_xml, fsl_fpc, + fsl_base, fsl_utilities, fsl_stream, fsl_collections, fsl_json, fsl_xml, fsl_fpc, fsl_npm, fsl_gzip, fsl_openssl, fsl_fetcher; Type @@ -431,9 +431,6 @@ TDigitalSigner = class (TFslObject) function verifySignature(xml : TBytes) : boolean; end; -function InflateRfc1951(b : TBytes) : TBytes; -function DeflateRfc1951(b : TBytes) : TBytes; - function Base64URL(s : TBytes) : String; function unBase64URL(s : String) : TBytes; @@ -1133,7 +1130,7 @@ class function TJWTUtils.encodeJWT(jwt: TJWT; method: TJWTAlgorithm; key: TJWK; input := JWTBase64URL(TJSONWriter.writeObject(jwt.header)); input := BytesAdd(input, Byte('.')); if zip = 'DEF' then - input := BytesAdd(input, JWTBase64URL(DeflateRfc1951(TJSONWriter.writeObject(jwt.payload)))) + input := BytesAdd(input, JWTBase64URL(gzip(TJSONWriter.writeObject(jwt.payload), false))) else input := BytesAdd(input, JWTBase64URL(TJSONWriter.writeObject(jwt.payload))); case method of @@ -1391,51 +1388,6 @@ class function TJWTUtils.encodeJWT(jwt: TJWT; method: TJWTAlgorithm; pem_file, p result := BytesAsString(input)+'.'+BytesAsString(JWTBase64URL(sig)); end; -function InflateRfc1951(b : TBytes) : TBytes; -var - b1, b2 : TBytesStream; - z : TZDecompressionStream; -begin - b1 := TBytesStream.create(b); - try - z := TZDecompressionStream.create(b1, false); // -15); - try - b2 := TBytesStream.Create; - try - b2.CopyFrom(z, z.Size); - result := b2.Bytes; - setLength(result, b2.size); - finally - b2.free; - end; - finally - z.free; - end; - finally - b1.free; - end; -end; - -function DeflateRfc1951(b : TBytes) : TBytes; -var - s : TBytesStream; - z : TZCompressionStream; -begin - s := TBytesStream.create(); - try - z := TZCompressionStream.create(clMax, s); // , -15); - try - z.Write(b, length(b)); - finally - z.free; - end; - result := s.Bytes; - setLength(result, s.size); - finally - s.free; - end; -end; - class function TJWTUtils.decodeJWT(token: string): TJWT; var header, payload, sig : String; @@ -1458,7 +1410,7 @@ class function TJWTUtils.decodeJWT(token: string): TJWT; result.payloadBytes := JWTDeBase64URL(payload); if result.header['zip'] = 'DEF' then - result.payloadBytes := InflateRfc1951(result.payloadBytes); + result.payloadBytes := ungzip(result.payloadBytes); result.payload := TJSONParser.Parse(result.payloadBytes); result.link; @@ -1569,7 +1521,7 @@ class function TJWTUtils.Sign_ES256(input: TBytes; key: TJWK): TBytes; var ctx : PEVP_MD_CTX; keysize : integer; - len, l : Cardinal; + len, l : QWord; p : System.PByte; pkey: PEVP_PKEY; PkeyCtx: PEVP_PKEY_CTX; @@ -1598,6 +1550,7 @@ class function TJWTUtils.Sign_ES256(input: TBytes; key: TJWK): TBytes; // 2. do the signing keysize := EVP_PKEY_size(pkey); + len := keysize; SetLength(result, keysize); ctx := EVP_MD_CTX_new; try @@ -1672,7 +1625,7 @@ class function TJWTUtils.Sign_Hmac_RSA256(input: TBytes; key: TJWK): TBytes; var ctx : PEVP_MD_CTX; keysize : integer; - len : Cardinal; + len : QWord; pkey: PEVP_PKEY; rkey: PRSA; keys : TJWKList; @@ -1689,6 +1642,7 @@ class function TJWTUtils.Sign_Hmac_RSA256(input: TBytes; key: TJWK): TBytes; // 2. do the signing keysize := EVP_PKEY_size(pkey); SetLength(result, keysize); + len := keysize; ctx := EVP_MD_CTX_new; try check(EVP_DigestSignInit(ctx, nil, EVP_sha256, nil, pKey) = 1, 'openSSL EVP_DigestInit_ex failed'); diff --git a/library/web/fsl_fetcher.pas b/library/web/fsl_fetcher.pas index 939f05d84..4cbf4e3e4 100644 --- a/library/web/fsl_fetcher.pas +++ b/library/web/fsl_fetcher.pas @@ -226,7 +226,7 @@ procedure TInternetFetcher.Fetch; End; End Else - raise EWebException.create('Protocol '+oUri.Protocol+' not supported'); + raise EWebException.create('Protocol '+oUri.Protocol+' not supported for URL '+url); Finally oUri.free; End; diff --git a/library/web/fsl_npm_cache.pas b/library/web/fsl_npm_cache.pas index a4486751c..d33fc0f80 100644 --- a/library/web/fsl_npm_cache.pas +++ b/library/web/fsl_npm_cache.pas @@ -34,9 +34,9 @@ interface uses {$IFDEF WINDOWS} Windows, {$ELSE} LazFileUtils, {$ENDIF} - SysUtils, Classes, IniFiles, zlib, Generics.Collections, Types, {$IFDEF DELPHI} IOUtils, {$ENDIF} + SysUtils, Classes, IniFiles, Generics.Collections, Types, {$IFDEF DELPHI} IOUtils, {$ENDIF} fsl_base, fsl_utilities, fsl_json, fsl_fpc, fsl_threads, fsl_logging, fsl_stream, fsl_fetcher, fsl_versions, - fsl_npm, fsl_npm_client; + fsl_npm, fsl_npm_client, fsl_gzip; type TCheckEvent = function(sender : TObject; msg : String):boolean of object; @@ -729,7 +729,6 @@ function TFHIRPackageManager.loadArchive(content: TBytes): TDictionary.Create; - bo := TBytesStream.Create(content); + bo := TBytesStream.create(ungzip(content)); try - z := TZDecompressionStream.Create(bo, false); // 15+16); + work(trunc(bo.Position / bo.Size * 100), false, 'Loading Package'); + tar := TTarArchive.Create(bo); try - work(trunc(bo.Position / bo.Size * 100), false, 'Loading Package'); - tar := TTarArchive.Create(z); - try - tar.Reset; - while tar.FindNext(DirRec) do + tar.Reset; + while tar.FindNext(DirRec) do + begin + fn := String(DirRec.Name); + fn := fn.replace('/', '\'); + if not fn.contains('@') then begin - fn := String(DirRec.Name); - fn := fn.replace('/', '\'); - if not fn.contains('@') then - begin - bi := TBytesStream.Create; - try - tar.ReadFile(bi); - b := bi.Bytes; - if not result.ContainsKey(fn) then - result.Add(fn, copy(b, 0, bi.Size)); + bi := TBytesStream.Create; + try + tar.ReadFile(bi); + b := bi.Bytes; + if not result.ContainsKey(fn) then + result.Add(fn, copy(b, 0, bi.Size)); // else // raise EFSLException.Create('Duplicate Entry: '+fn); - finally - bi.free; - end; + finally + bi.free; end; end; - finally - tar.free; end; finally - z.free; + tar.free; end; finally bo.free; end; finally work(100, true, ''); - end; + end; + Logging.log('Loaded Package ('+inttostr(result.Count)+' files)'); end; procedure TFHIRPackageManager.loadPackage(id, ver: String; diff --git a/packages/fhir.pas b/packages/fhir.pas index 0a6426912..e8d0a812f 100644 --- a/packages/fhir.pas +++ b/packages/fhir.pas @@ -38,4 +38,4 @@ procedure Register; initialization RegisterPackage('fhir', @Register); -end. + end. \ No newline at end of file diff --git a/packages/fhir4.pas b/packages/fhir4.pas index 948c26cc6..228313275 100644 --- a/packages/fhir4.pas +++ b/packages/fhir4.pas @@ -28,4 +28,4 @@ procedure Register; initialization RegisterPackage('fhir4', @Register); -end. +end. \ No newline at end of file diff --git a/packages/fhir_fdb.pas b/packages/fhir_fdb.pas index c2897c675..d9665e95a 100644 --- a/packages/fhir_fdb.pas +++ b/packages/fhir_fdb.pas @@ -20,5 +20,5 @@ procedure Register; end; initialization - RegisterPackage('fhir_fdb', @Register); -end. + RegisterPackage('fhir_fdb', @Register); +end. \ No newline at end of file diff --git a/packages/fhir_fsl.lpk b/packages/fhir_fsl.lpk index e19149926..589fb8c84 100644 --- a/packages/fhir_fsl.lpk +++ b/packages/fhir_fsl.lpk @@ -9,7 +9,7 @@ - + @@ -144,6 +144,10 @@ + + + + diff --git a/packages/fhir_fsl.pas b/packages/fhir_fsl.pas index 3bf2b03c8..db0e3be27 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, - 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, + LazarusPackageIntf; + +implementation + +procedure Register; +begin +end; + +initialization + RegisterPackage('fhir_fsl', @Register); +end. diff --git a/server/admin/console_managers.pas b/server/admin/console_managers.pas index cc5e45978..0d7c5213c 100644 --- a/server/admin/console_managers.pas +++ b/server/admin/console_managers.pas @@ -33,7 +33,7 @@ interface uses - SysUtils, Classes, Graphics, UITypes, + SysUtils, Classes, Graphics, System.UITypes, Dialogs, fsl_base, fsl_threads, fsl_utilities, fdb_manager, diff --git a/server/endpoint_storage.pas b/server/endpoint_storage.pas index 97fdea052..634061561 100644 --- a/server/endpoint_storage.pas +++ b/server/endpoint_storage.pas @@ -1296,6 +1296,7 @@ function TStorageWebEndpoint.HandleRequest(AContext: TIdContext; request: TIdHTT oRequest.IfNoneExist := request.RawHeaders.Values['If-None-Exist']; oRequest.IfModifiedSince := processIfModifiedSince(request.RawHeaders.Values['If-Modified-Since']); oRequest.strictSearch := request.RawHeaders.Values['Prefer'] = 'handling=strict'; + oRequest.ContentLanguage := request.ContentLanguage; noErrCode := StringArrayExistsInsensitive(['yes', 'true', '1'], oRequest.Parameters['nohttperr']) or StringArrayExistsInsensitive(['yes', 'true', '1'], oRequest.Parameters['_nohttperr']); diff --git a/server/endpoint_txsvr.pas b/server/endpoint_txsvr.pas index c591f5379..1eaa1d9d1 100644 --- a/server/endpoint_txsvr.pas +++ b/server/endpoint_txsvr.pas @@ -1569,8 +1569,11 @@ procedure TTerminologyServerEndPoint.Load; procedure TTerminologyServerEndPoint.Unload; begin - FServerContext.Unload; - FServerContext.free; + if FServerContext <> nil then + begin + FServerContext.Unload; + FServerContext.free; + end; FServerContext := nil; FStore.free; FStore := nil; diff --git a/server/endpoint_xig.pas b/server/endpoint_xig.pas index 82628db2f..1197128df 100644 --- a/server/endpoint_xig.pas +++ b/server/endpoint_xig.pas @@ -1551,5 +1551,4 @@ function TFHIRXIGWebServer.SecureRequest(AContext: TIdContext; ip : String; requ countRequest; result := doRequest(AContext, request, response, id, true); end; - -end. +end. \ No newline at end of file diff --git a/server/fhirserver.lpi b/server/fhirserver.lpi index ee5a533eb..241aabb9c 100644 --- a/server/fhirserver.lpi +++ b/server/fhirserver.lpi @@ -86,10 +86,10 @@ - - - - + + + + @@ -269,13 +269,12 @@ - - + @@ -780,7 +779,7 @@ - + @@ -814,7 +813,7 @@ - + @@ -975,6 +974,7 @@ + @@ -985,6 +985,15 @@ + + + + + + + + + diff --git a/server/kernel.pas b/server/kernel.pas index e4be8f4b5..a3cbd023c 100644 --- a/server/kernel.pas +++ b/server/kernel.pas @@ -768,6 +768,8 @@ procedure initLogging(params : TCommandLineParameters; cfg : TCustomIniFile); begin if cfg.valueExists('config', 'log') then logFilename := cfg.readString('config', 'log', '') + else if params.has('-tests') then + logFilename := filePath(['[tmp]', 'fhirserver-tests.log']) else logFilename := filePath(['[tmp]', 'fhirserver.log']); Logging.logToFile(logFilename); diff --git a/server/server_context.pas b/server/server_context.pas index fa923c327..b21481f3e 100644 --- a/server/server_context.pas +++ b/server/server_context.pas @@ -469,7 +469,8 @@ procedure TFHIRServerContext.getCacheInfo(ci: TCacheInformation); procedure TFHIRServerContext.UnLoad; begin - FStorage.UnLoad; + if FStorage <> nil then + FStorage.UnLoad; FQuestionnaireCache.clearCache; FValidatorContext.UnLoad; FValidator.Unload; diff --git a/server/session.pas b/server/session.pas index 9754100e1..dc451d27d 100644 --- a/server/session.pas +++ b/server/session.pas @@ -311,6 +311,7 @@ TFHIRRequest = class (TFslObject) FVersion: TFHIRVersion; FTransactionResource: TFhirResourceV; FSecureURL: String; + FContentLanguage : String; procedure SetResource(const Value: TFhirResourceV); procedure SetSource(const Value: TFslBuffer); procedure SetSession(const Value: TFhirSession); @@ -490,6 +491,7 @@ TFHIRRequest = class (TFslObject) Property IfNoneMatch : String read FIfNoneMatch write FIfNoneMatch; Property IfModifiedSince : TDateTime read FIfModifiedSince write FIfModifiedSince; Property IfNoneExist : String read FIfNoneExist write FIfNoneExist; + Property ContentLanguage : String read FContentLanguage write FContentLanguage; Property Provenance : TFhirProvenanceW read FProvenance write SetProvenance; Property Origin : TFHIRRequestOrigin read FOrigin; diff --git a/server/test_registry.pas b/server/test_registry.pas index 355b81e04..e07c7e108 100644 --- a/server/test_registry.pas +++ b/server/test_registry.pas @@ -81,15 +81,15 @@ implementation const {$IFDEF WINDOWS} DefaultMSSQLDriver = 'SQL Server'; - DefaultMySQLDriver = 'MySQL ODBC 8.0 Unicode Driver'; + DefaultMySQLDriver = 'MySQL ODBC 8.2 Unicode Driver'; {$ENDIF} {$IFDEF LINUX} DefaultMSSQLDriver = 'ODBC Driver 17 for SQL Server'; - DefaultMySQLDriver = 'MySQL ODBC 8.0 Unicode Driver'; + DefaultMySQLDriver = 'MySQL ODBC 8.2 Unicode Driver'; {$ENDIF} {$IFDEF OSX} DefaultMSSQLDriver = 'ODBC Driver 17 for SQL Server'; - DefaultMySQLDriver = 'MySQL ODBC 8.0 Unicode Driver'; + DefaultMySQLDriver = 'MySQL ODBC 8.2 Unicode Driver'; {$ENDIF} Procedure SetUpDefaultTestSettings(filename : String); diff --git a/server/tests/tests_cpt.pas b/server/tests/tests_cpt.pas index 17017c141..a59a972ba 100644 --- a/server/tests/tests_cpt.pas +++ b/server/tests/tests_cpt.pas @@ -439,7 +439,4 @@ procedure TCPTTests.TestExpression2; ctxt.free; end; end; - -end. - - +end. \ No newline at end of file diff --git a/server/tx/tx_cpt.pas b/server/tx/tx_cpt.pas index f12180d61..70cac0094 100644 --- a/server/tx/tx_cpt.pas +++ b/server/tx/tx_cpt.pas @@ -964,5 +964,4 @@ procedure TCPTServices.defineFeatures(features : TFslList); end; -end. - +end. \ No newline at end of file diff --git a/server/tx/tx_omop.pas b/server/tx/tx_omop.pas index 8295cb523..b971dc128 100644 --- a/server/tx/tx_omop.pas +++ b/server/tx/tx_omop.pas @@ -433,6 +433,4 @@ procedure TOMOPServices.defineFeatures(features: TFslList); begin raise ETerminologyError.Create('not done yet: defineFeatures'); end; - -end. - +end. \ No newline at end of file diff --git a/server/tx_operations.pas b/server/tx_operations.pas index f41b9a84e..2a5d46d3f 100644 --- a/server/tx_operations.pas +++ b/server/tx_operations.pas @@ -51,7 +51,7 @@ TFhirTerminologyOperation = class (TFhirOperation) 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 addCodeable : boolean) : TFhirCodeableConceptW; + 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); @@ -315,13 +315,15 @@ function TFhirExpandValueSetOperation.Execute(context : TOperationContext; manag profile := buildExpansionParams(request, manager, params); try filter := params.str('filter'); - count := StrToIntDef(params.str('count'), 0); - offset := StrToIntDef(params.str('offset'), 0); - limit := StrToIntDef(params.str('_limit'), 0); - if (limit < 0) then - limit := 0 + 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 (count > 0) and (offset = -1) then + offset := 0; if (txResources = nil) then txResources := processAdditionalResources(context, manager, nil, params); @@ -427,7 +429,8 @@ function TFhirValueSetValidationOperation.Execute(context : TOperationContext; m // coding : TFhirCodingW; abstractOk, inferSystem : boolean; params, pout : TFhirParametersW; - needSecure, isValueSet, addCodeable : boolean; + needSecure, isValueSet : boolean; + mode : TValidationCheckMode; profile : TFhirExpansionParams; txResources : TFslMetadataResourceList; mr : TFHIRMetadataResourceW; @@ -448,7 +451,7 @@ function TFhirValueSetValidationOperation.Execute(context : TOperationContext; m txResources := nil; profile := nil; try - coded := loadCoded(request, isValueSet, issuePath, addCodeable); + coded := loadCoded(request, isValueSet, issuePath, mode); try result := 'Validate Code '+coded.renderText; if isValueSet then @@ -517,7 +520,7 @@ function TFhirValueSetValidationOperation.Execute(context : TOperationContext; m txResources := processAdditionalResources(context, manager, nil, params); profile := buildExpansionParams(request, manager, params); - pout := FServer.validate(issuePath, vs, coded, profile, abstractOk, inferSystem, addCodeable, txResources, summary); + pout := FServer.validate(issuePath, vs, coded, profile, abstractOk, inferSystem, mode, txResources, summary); try if summary <> '' then result := result + ': '+summary; @@ -687,7 +690,7 @@ function TFhirConceptMapTranslationOperation.Execute(context : TOperationContext // resourceKey : integer; coded : TFhirCodeableConceptW; coding : TFslList; - dummy : boolean; + dummy : TValidationCheckMode; params, pOut : TFhirParametersW; issuePath : String; begin @@ -1261,8 +1264,10 @@ procedure TFhirTerminologyOperation.processExpansionParams(request: TFHIRRequest result.languages := THTTPLanguageList.create(p.valueString, not isValidation) else if (p.name = 'property') then result.properties.add(p.valueString) - else if (p.name = 'mode') and (p.valueString = 'lenient-display-validation') then - result.displayWarning := true + 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 @@ -1281,14 +1286,9 @@ procedure TFhirTerminologyOperation.processExpansionParams(request: TFHIRRequest end; end end; - result.valueSetMode := vsvmAllChecks; - if (params.has('valueSetMode')) then - begin - if (params.str('valueSetMode') = 'CHECK_MEMBERSHIP_ONLY') then - result.valueSetMode := vsvmMembershipOnly - else if (params.str('valueSetMode') = 'NO_MEMBERSHIP_CHECK') then - result.valueSetMode := vsvmNoMembership - 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; @@ -1316,13 +1316,11 @@ destructor TFhirTerminologyOperation.Destroy; inherited; end; -function TFhirTerminologyOperation.loadCoded(request : TFHIRRequest; isValueSet : boolean; var issuePath : string; var addCodeable : boolean): TFhirCodeableConceptW; +function TFhirTerminologyOperation.loadCoded(request : TFHIRRequest; isValueSet : boolean; var issuePath : string; var mode : TValidationCheckMode): TFhirCodeableConceptW; var coding : TFhirCodingW; params : TFhirParametersW; begin - addCodeable := false; - // ok, now we need to find the source code to validate if (request.form <> nil) and request.form.hasParam('coding') then begin @@ -1334,16 +1332,18 @@ function TFhirTerminologyOperation.loadCoded(request : TFHIRRequest; isValueSet coding.free; end; issuePath := 'Coding'; + mode := vcmCoding; end else if (request.form <> nil) and request.form.hasParam('codeableConcept') then begin - addCodeable := true; + 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 @@ -1360,6 +1360,7 @@ function TFhirTerminologyOperation.loadCoded(request : TFHIRRequest; isValueSet 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 @@ -1377,6 +1378,7 @@ function TFhirTerminologyOperation.loadCoded(request : TFHIRRequest; isValueSet 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); @@ -1388,13 +1390,14 @@ function TFhirTerminologyOperation.loadCoded(request : TFHIRRequest; isValueSet end else if params.has('codeableConcept') then begin - addCodeable := true; + mode := vcmCodeableConcept; result := FFactory.wrapCodeableConcept(params.obj('codeableConcept').Link); issuePath := 'CodeableConcept'; end - else if isValueSet and (params.has('code') and (params.has('system') or params.bool('inferSystem') or params.bool('implySystem'))) then + 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 @@ -1414,6 +1417,7 @@ function TFhirTerminologyOperation.loadCoded(request : TFHIRRequest; isValueSet 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 diff --git a/server/tx_registry_model.pas b/server/tx_registry_model.pas index 1569a01e7..2779c99da 100644 --- a/server/tx_registry_model.pas +++ b/server/tx_registry_model.pas @@ -663,7 +663,4 @@ procedure TServerVersionInformation.update(source: TServerVersionInformation); FTerminologies.assign(source.Terminologies); end; end; - - -end. - +end. \ No newline at end of file diff --git a/server/tx_server.pas b/server/tx_server.pas index c6ab79025..d26d19ebe 100644 --- a/server/tx_server.pas +++ b/server/tx_server.pas @@ -138,7 +138,7 @@ TTerminologyServer = class (TTerminologyServerStore) procedure lookupCode(coding : TFHIRCodingW; langList : THTTPLanguageList; props : TArray; resp : TFHIRLookupOpResponseW); function validate(vs : TFhirValueSetW; coding : TFHIRCodingW; profile : TFHIRExpansionParams; abstractOk, inferSystem : boolean; txResources : TFslMetadataResourceList; var summary : string) : TFhirParametersW; overload; - function validate(issuePath : String; vs : TFhirValueSetW; coded : TFhirCodeableConceptW; profile : TFHIRExpansionParams; abstractOk, inferSystem, addCodeable: boolean; txResources : TFslMetadataResourceList; var summary : string) : TFhirParametersW; overload; + function validate(issuePath : String; vs : TFhirValueSetW; coded : TFhirCodeableConceptW; profile : TFHIRExpansionParams; abstractOk, inferSystem: boolean; mode : TValidationCheckMode; txResources : TFslMetadataResourceList; var summary : string) : TFhirParametersW; overload; function codeInValueSet(c : TFHIRCodingW; valueSet : String) : boolean; function translate(langList : THTTPLanguageList; cm : TLoadedConceptMap; coding : TFHIRCodingW) : TFhirParametersW; overload; function translate(langList : THTTPLanguageList; source : TFhirValueSetW; coding : TFHIRCodingW; target : TFhirValueSetW) : TFhirParametersW; overload; @@ -672,7 +672,7 @@ function TTerminologyServer.validate(vs : TFhirValueSetW; coding : TFHIRCodingW; end; -function TTerminologyServer.validate(issuePath : String; vs : TFhirValueSetW; coded : TFhirCodeableConceptW; profile : TFHIRExpansionParams; abstractOk, inferSystem, addCodeable : boolean; txResources : TFslMetadataResourceList; var summary : string) : TFhirParametersW; +function TTerminologyServer.validate(issuePath : String; vs : TFhirValueSetW; coded : TFhirCodeableConceptW; profile : TFHIRExpansionParams; abstractOk, inferSystem : boolean; mode : TValidationCheckMode; txResources : TFslMetadataResourceList; var summary : string) : TFhirParametersW; var check : TValueSetChecker; begin @@ -686,7 +686,7 @@ function TTerminologyServer.validate(issuePath : String; vs : TFhirValueSetW; co try result := check.prepare(vs, profile); if result = nil then - result := check.check(issuePath, coded, abstractOk, inferSystem, addCodeable); + result := check.check(issuePath, coded, abstractOk, inferSystem, mode); summary := check.log; finally check.free; @@ -703,7 +703,7 @@ function TTerminologyServer.workerGetDefinition(sender: TObject; url, version: S function TTerminologyServer.workerGetExpansion(sender: TObject; opContext : TTerminologyOperationContext; url, version, filter: String; params: TFHIRExpansionParams; dependencies: TStringList; additionalResources : TFslMetadataResourceList; limit: integer): TFHIRValueSetW; begin - result := expandVS(url, version, params, opContext, filter, dependencies, limit, 0, 0, additionalResources); + result := expandVS(url, version, params, opContext, filter, dependencies, limit, -1, -1, additionalResources); end; function TTerminologyServer.workerGetProvider(sender: TObject; url, version: String; params: TFHIRExpansionParams; nullOk : boolean): TCodeSystemProvider; @@ -849,7 +849,7 @@ function TTerminologyServer.codeInValueSet(c : TFHIRCodingW; valueSet: String): exit(false); profile := TFHIRExpansionParams.Create; try - profile.valueSetMode := vsvmMembershipOnly; + profile.membershipOnly := true; p := validate(vs, c, profile, true, false, nil, summary); try result := p.bool('result'); diff --git a/server/validator_r2.pas b/server/validator_r2.pas index b91f381c0..1212fc3e1 100644 --- a/server/validator_r2.pas +++ b/server/validator_r2.pas @@ -335,7 +335,7 @@ function TFHIRServerWorkerContextR2.validateCode(code: TFHIRCodeableConcept; vs: try c := factory.wrapCodeableConcept(code.Link); try - p := FTerminologyServer.validate('CodeableConcept', vsw, c, FProfile, false, true, false, nil, summary); + p := FTerminologyServer.validate('CodeableConcept', vsw, c, FProfile, false, true, vcmCodeableConcept, nil, summary); try result.Message := p.str('message'); if p.bool('result') then diff --git a/server/validator_r3.pas b/server/validator_r3.pas index 11c56b638..021bc515c 100644 --- a/server/validator_r3.pas +++ b/server/validator_r3.pas @@ -419,7 +419,7 @@ function TFHIRServerWorkerContextR3.validateCode(code: TFHIRCodeableConcept; vs: try c := factory.wrapCodeableConcept(code.Link); try - p := FTerminologyServer.validate('CodeableConcept', vsw, c, FProfile, false, true, false, nil, summary); + p := FTerminologyServer.validate('CodeableConcept', vsw, c, FProfile, false, true, vcmCodeableConcept, nil, summary); try result.Message := p.str('message'); if p.bool('result') then diff --git a/server/validator_r4.pas b/server/validator_r4.pas index 9b7945e66..58193588a 100644 --- a/server/validator_r4.pas +++ b/server/validator_r4.pas @@ -418,7 +418,7 @@ function TFHIRServerWorkerContextR4.validateCode(code: TFHIRCodeableConcept; vs: try c := factory.wrapCodeableConcept(code.Link); try - p := FTerminologyServer.validate('CodeableConcept', vsw, c, FProfile, false, true, false, nil, summary); + p := FTerminologyServer.validate('CodeableConcept', vsw, c, FProfile, false, true, vcmCodeableConcept, nil, summary); try result.Message := p.str('message'); if p.bool('result') then diff --git a/server/validator_r4b.pas b/server/validator_r4b.pas index 30dc8173e..3cbf354e9 100644 --- a/server/validator_r4b.pas +++ b/server/validator_r4b.pas @@ -418,7 +418,7 @@ function TFHIRServerWorkerContextR4B.validateCode(code: TFHIRCodeableConcept; vs try c := factory.wrapCodeableConcept(code.Link); try - p := FTerminologyServer.validate('CodeableConcept', vsw, c, FProfile, false, true, false, nil, summary); + p := FTerminologyServer.validate('CodeableConcept', vsw, c, FProfile, false, true, vcmCodeableConcept, nil, summary); try result.Message := p.str('message'); if p.bool('result') then diff --git a/server/validator_r5.pas b/server/validator_r5.pas index 88ddc6ff5..02a193279 100644 --- a/server/validator_r5.pas +++ b/server/validator_r5.pas @@ -418,7 +418,7 @@ function TFHIRServerWorkerContextR5.validateCode(code: TFHIRCodeableConcept; vs: try c := factory.wrapCodeableConcept(code.Link); try - p := FTerminologyServer.validate('CodeableConcept', vsw, c, FProfile, false, true, false, nil, summary); + p := FTerminologyServer.validate('CodeableConcept', vsw, c, FProfile, false, true, vcmCodeableConcept, nil, summary); try result.Message := p.str('message'); if p.bool('result') then diff --git a/server/xig_provider.pas b/server/xig_provider.pas index 6d2bedb85..bf213dd51 100644 --- a/server/xig_provider.pas +++ b/server/xig_provider.pas @@ -230,5 +230,4 @@ function TXIGProvider.startLoad(types: TStringArray): TXigLoader; end; end; -end. - +end. \ No newline at end of file diff --git a/toolkit2/views/ftk_project_tree.pas b/toolkit2/views/ftk_project_tree.pas index 994d36e8f..85e614cf0 100644 --- a/toolkit2/views/ftk_project_tree.pas +++ b/toolkit2/views/ftk_project_tree.pas @@ -34,7 +34,7 @@ interface uses Classes, SysUtils, Graphics, IniFiles, - Controls, ComCtrls, Dialogs, UITypes, Menus, + Controls, ComCtrls, Dialogs, System.UITypes, Menus, fsl_base, fsl_utilities, fsl_json, fsl_fpc, fsl_stream, fui_lcl_managers, fhir_client, diff --git a/utilities/codescan/codescan.lpr b/utilities/codescan/codescan.lpr index 3be6d0768..1ebaf5fa9 100644 --- a/utilities/codescan/codescan.lpr +++ b/utilities/codescan/codescan.lpr @@ -229,7 +229,7 @@ procedure TCodeScanner.checkFileForExceptionDefine(filename, src : String; ts : begin srcns := ts[i].Replace(#9, '').Replace(' ', '').ToLower; if srcns.contains('=class(exception)') and not srcns.contains('efslexception=class(exception)') then - reportError(filename, i, 'subclasses Exception (should be (EFslException)'); + reportError(filename, i, 'subclasses Exception (should be (EFslException))'); end; end; @@ -245,20 +245,29 @@ function TCodeScanner.checkFileForLineEndings(filename, src : String) : String; i := 1; l := 0; fl := -1; + changed := False; // Initialize 'changed' to false while (i <= length(src)) do begin ch := src[i]; if (ch = #13) then begin inc(l); - b.Append(#13#10); - if (i = length(src)) or (src[i+1] <> #10) then + if (i = length(src)) then // Check if it's the end of the file + begin + b.Append(ch); // Just append the carriage return without adding a line feed + // Do not set 'changed' to true as we are keeping the original ending + end + else if (src[i+1] <> #10) then begin + b.Append(#13#10); // Append Windows-style line ending changed := true; if fl = -1 then fl := l; end else - inc(i); + begin + b.Append(ch); // Append the original character + inc(i); // Skip the next character as it's a line feed + end; end else if (ch = #10) then begin