Archive version of: dicomparser.r ... version: 1 ... willemm 7-Apr-2008

Amendment note: new script || Publicly available? Yes

REBOL [
	file: %dicomparser.r
	title: "Parser for Dicom Header"
    version: 1.0.0
    author: "Willem Michiels"
    purpose: "Parse dicom headers"
	date: 7-Apr-2008
	library: [
        level: 'intermediate
        platform: 'all
        type: [tool protocol]
        domain: [dialects parse]
        tested-under: none
        support: none
        license: mit
        see-also: none
	requirements: "rebdb from dobeash, dcmDict.ctl and dcmDict.dat"
    ]
]

do %db.r

vrNumber: ["AS" "FL" "FD" "SL" "SS" "UL" "US"]
vrString: ["AE" "AT" "CS" "DA" "DS" "DT" "IS" "LO" "LT" "OF" "PN" "SH" "ST" "TM" "UI" "UT"]
vrOther: ["OB" "OW" "SQ" "UN"]

Implicit_VR_Little_Endian: "1.2.840.10008.1.2"  
Explicit_VR_Little_Endian: "1.2.840.10008.1.2.1" 

checkVl: func [vr vl] [
	; if (find ["IS"] vr)	[ if not (vl <= 12) ["vl not correct"]]
	; if (find ["AE" "CS" "DS" "SH"	"TM"] vr) [ if not (vl <= 16) ["vl not correct"] ]
	if (find ["SS" "US"] vr)	[ if not (vl <= 2) [vl: 2] ]
	if (find ["AS" "AT" "FL" "SL" "UL"] vr)	[ if not (vl <= 4) [vl: 4] ]
	if (find ["DA" "FD"] vr) [ if not (vl <= 8) [vl: 8] ]
	; if (find ["DT"] vr) [ if not (vl <= 26) ["vl not correct"] ]
	; if (find ["LO" "UI"] vr) [ if not (vl <= 64) ["vl not correct"] ]
	; if (find ["PN"] vr) [ if not (vl <= (5 x 64)) ["vl not correct"] ]
	; if (find ["ST"] vr) [ if not (vl <= 1024) ["vl not correct"] ]
	; if (find ["LT"] vr) [ if not (vl <= 10240) ["vl not correct"] ]
	; if (find ["UT"] vr) [ if not (vl <= ((power 2 32) - 2)) ["vl not correct"] ]
	; if (find ["OF"] vr) [  if not (vl <= ((power 2 32) - 4)) ["vl not correct"] ]
	; "OB", "OW", "UN"		"SQ"
	return vl
]


parseDcmHeader: function [data] [][;[result group element transferSyntax vl vr value] [
    result: copy []
	take/part data 128
	take/part data 4
	
	transferSyntax: "1.2.840.10008.1.2.1" 
	
	; while [ not all [ group = #{7FE0} element = #{0010} ]] [
	while [not empty? data][
        ; determine data group
        group: reverse take/part data 2
        
        ;determine data element
        element:  reverse take/part data 2
        
		if all [ group = #{7FE0} element = #{0010} ] [
			return result
			break
		]
		
        ;determine  vr, not to be done for tags (FFFE,E000), (FFFE,E00D) and (FFFE,E0DD)
        either group = #{FFFE} [
			vr = "NA"
		][
			either any [ group = #{0002} transferSyntax = "1.2.840.10008.1.2.1" ][
				; print "vr is included in file, database not needed"
				vr: to-string take/part data 2
			][
				; print "looking for vr in database" 
				vr: to-string db-select/where vr dcmdict [all [dataGroup = :group dataElement = :element]]
			]
		]
        
        ;determine  value length
		either group = #{FFFE} [
			vl: to-integer reverse take/part data 4
		][
			either any [ group = #{0002} transferSyntax = "1.2.840.10008.1.2.1" ] [
				either  find union vrNumber vrString vr [
					vl: to-integer reverse take/part data 2
				][
					take/part data 2
					vl: to-integer reverse take/part data 4
				]
			][
				vl: to-integer reverse take/part data 4
			]
		]
		
		; vl: checkVl vr vl
	
        ; determine  value
		 
		either any [group = #{FFFE} vr = "SQ"] [	
			value: ""
		][
			value: take/part data vl
        
			if find vrString vr [value: trim to-string value]
			if find vrNumber vr [value: trim to-string to-integer reverse value]
			if find vrOther vr [value: trim to-string value]
			; if "SQ" = vr [value: parsedcmheader value]
			; if group = #{FFFE} [
				; if find [#{E000} #{E00D} #{E0DD}] element  [value: ""]
			; ]
        ]
		
		if all [ group = #{0002} element = #{0010} ] [ 
			transferSyntax: trim copy value
			; print [ "transfersyntax found in meta-header is -"transferSyntax"-"]
		]
		
		; print reduce [group element vr vl value]
		append/only result reduce [group element vr vl value]
    ]
    ; print result
    return result
]

ppHeader: function [data] [element] [
	foreach element data [
		prin element
		print ""
	]
]

dumpHeader: function [data destination] [] [
	write destination ""
	foreach line data [
		write/append destination reduce [mold line/1 "    " mold line/2 "    " line/3 "    " line/4 "    " line/5 newline]
	]
]