view release on metacpan or  search on metacpan

lib/Convert/Pheno/OpenEHR/ToBFF.pm  view on Meta::CPAN

    return unless defined $code;

    return {
        diseaseCode => $code,
        _info       => {
            openEHR => $node,
        },
    };
}

sub _map_procedure {
    my ($node) = @_;
    my $code = _find_first_element_value( $node, 'Procedure name' );
    return unless defined $code;

    my $procedure = {
        procedureCode => $code,
        _info         => {
            openEHR => $node,
        },
    };

    my $body_site = _find_first_element_value( $node, 'Body site' );
    $procedure->{bodySite} = $body_site if defined $body_site;

    my $date = _extract_date( $node->{time}{value} );
    $procedure->{dateOfProcedure} = $date if defined $date;

    return $procedure;
}

sub _map_treatment {
    my ($node) = @_;

    my $code =
         _find_first_element_value( $node, 'Name' )
      || _find_first_element_value( $node, 'Medication item', 'Immunisation item' );
    return unless defined $code;

    my $treatment = {
        treatmentCode => $code,
        _info         => {
            openEHR => $node,
        },
    };

    my $route = _find_first_element_value( $node, 'Route' );
    $treatment->{routeOfAdministration} = $route if defined $route;

    return $treatment;
}

sub _find_first_element_value {
    my ( $node, @names ) = @_;
    my %wanted = map { $_ => 1 } @names;
    my $found;

    _walk_nodes(
        $node,
        sub {
            my ($cursor) = @_;
            return if defined $found;
            return unless ref($cursor) eq 'HASH';
            return unless ( $cursor->{_type} || '' ) eq 'ELEMENT';

            my $name = _node_name($cursor);
            return unless defined $name && $wanted{$name};

            $found = _term_from_value( $cursor->{value}, $cursor );
        }
    );

    return $found;
}

sub _find_first_text_value {
    my ( $node, @names ) = @_;
    my %wanted = map { $_ => 1 } @names;
    my $found;

    _walk_nodes(
        $node,
        sub {
            my ($cursor) = @_;
            return if defined $found;
            return unless ref($cursor) eq 'HASH';
            return unless ( $cursor->{_type} || '' ) eq 'ELEMENT';

            my $name = _node_name($cursor);
            return unless defined $name && $wanted{$name};
            return unless ref( $cursor->{value} ) eq 'HASH';
            return unless defined $cursor->{value}{value};

            $found = $cursor->{value}{value};
        }
    );

    return $found;
}

sub _find_first_quantity_value {
    my ( $node, @names ) = @_;
    my %wanted = map { $_ => 1 } @names;
    my $found;

    _walk_nodes(
        $node,
        sub {
            my ($cursor) = @_;
            return if defined $found;
            return unless ref($cursor) eq 'HASH';
            return unless ( $cursor->{_type} || '' ) eq 'ELEMENT';

            my $name = _node_name($cursor);
            return unless defined $name && $wanted{$name};
            return unless ref( $cursor->{value} ) eq 'HASH';
            return unless ( $cursor->{value}{_type} || '' ) eq 'DV_QUANTITY';

            $found = _quantity_from_dv_quantity( $cursor->{value} );
        }
    );

    return $found;
}

sub _find_first_named_cluster_code {
    my ( $node, $cluster_name ) = @_;
    my $found;

    _walk_nodes(
        $node,
        sub {
            my ($cursor) = @_;
            return if defined $found;
            return unless ref($cursor) eq 'HASH';
            return unless ( $cursor->{_type} || '' ) eq 'CLUSTER';
            return unless defined _node_name($cursor) && _node_name($cursor) eq $cluster_name;

            if ( ref( $cursor->{items} ) eq 'ARRAY' ) {
                for my $item ( @{ $cursor->{items} } ) {
                    next unless ref($item) eq 'HASH';
                    my $name = $item->{name};
                    next unless ref($name) eq 'HASH';
                    next unless ( $name->{_type} || '' ) eq 'DV_CODED_TEXT';
                    $found = _term_from_value( $name, $item );
                    last if defined $found;
                }
            }
        }
    );

    return $found;
}

sub _find_first_datetime_value {
    my ($node) = @_;
    my $found;

    _walk_nodes(
        $node,
        sub {
            my ($cursor) = @_;
            return if defined $found;
            return unless ref($cursor) eq 'HASH';

            if ( exists $cursor->{time}
                && ref( $cursor->{time} ) eq 'HASH'
                && defined $cursor->{time}{value} )
            {
                $found = $cursor->{time}{value};
                return;
            }

            if ( exists $cursor->{origin}
                && ref( $cursor->{origin} ) eq 'HASH'
                && defined $cursor->{origin}{value} )
            {
                $found = $cursor->{origin}{value};
                return;
            }
        }
    );

    return $found;
}

sub _term_from_value {
    my ( $value, $source_node ) = @_;
    return unless defined $value;

    if ( ref($value) eq 'HASH' ) {
        if ( defined $value->{value} ) {
            my %term = ( label => $value->{value} );
            my $id = _term_id_from_defining_code( $value->{defining_code} );
            $id ||= _synthetic_term_id( $value->{value}, $source_node );
            $term{id} = $id if defined $id;
            return \%term;
        }
        return;
    }

    return {
        id    => _synthetic_term_id( $value, $source_node ),
        label => $value,
      }
      if !ref($value) && length $value;
    return;
}

sub _term_from_text {
    my ( $text, $source_node ) = @_;
    return unless defined $text && length $text;
    return {
        id    => _synthetic_term_id( $text, $source_node ),
        label => $text,
    };
}

sub _term_id_from_defining_code {
    my ($code) = @_;
    return unless ref($code) eq 'HASH';
    return unless defined $code->{code_string};
    return unless ref( $code->{terminology_id} ) eq 'HASH';
    return unless defined $code->{terminology_id}{value};

    my $terminology = $code->{terminology_id}{value};
    return if $terminology eq 'local' || $terminology eq 'openehr';

    return $terminology . ':' . $code->{code_string};
}

sub _quantity_from_dv_quantity {
    my ($value) = @_;
    return unless ref($value) eq 'HASH';
    return unless defined $value->{magnitude};

    my %quantity = ( value => $value->{magnitude} );
    $quantity{unit} = { label => $value->{units} }