?? RIGHT := 110 ??
?? NEWTITLE := 'CREATE_ORDER_DEFINITION Subutility:  ADD_SUBPRODUCT Subcommand.' ??
MODULE ram$add_subproduct;

{ PURPOSE:
{   This module contains the procedures that will add a subproduct to the order.
{
{ DESIGN:
{   The subproduct is checked to determine if it is a valid subproduct.
{   If it is a valid subproduct, a copy of the subproduct's SIF is added
{   to the current end of the packing list sequence in memory, and a
{   record for the subproduct is added to the order contents list.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{   If the following scenario occurs:
{
{   1.  The packing list and order contents list both validate.
{   2.  The SIF is copied to the packing list.
{   3.  Something aborts the job before the order contents record
{       is copied to the order contents list.
{   THEN these procedures will not remove the SIF from the packing list.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$not_assigned
*copyc rac$pacs_processor_version
*copyc rac$sif_file_name
*copyc rac$subproduct_info_level
*copyc cld$path_description
*copyc rae$package_software_cc
*copyc rat$order_contents_list
*copyc rat$packing_list_types
*copyc rat$sequence_descriptor_types
*copyc rat$subproduct_info_types
*copyc rat$subproduct_info_pointers
?? POP ??
*copyc amp$get_segment_pointer
*copyc clp$get_value
*copyc clp$scan_command_file
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc pmp$get_date
*copyc pmp$get_time
*copyc pmp$get_user_identification
*copyc rap$add_name_to_path_ref
*copyc rap$get_file_path_and_ref
*copyc rap$get_sif_pointers
*copyc rap$open_file
*copyc rav$creod_scratch_segment
*copyc rav$order_contents_list_p
*copyc rav$order_contents_count
*copyc rav$packing_list_header_p
*copyc rav$packing_list_seq_p
*copyc rav$subproduct_type

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$add_subproduct', EJECT ??

{ PURPOSE:
{   This procedure adds information to the packing list and the order
{   data file for a subproduct.
{
{ DESIGN:
{   This procedure validates the SIF file, validates the order contents
{   array, writes the SIF file to the end of the packing list and
{   writes the order contents record to the end of the order contents list.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$add_subproduct
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt adds_pdt (
{   pacs_catalog, pc      : file = $required
{   licensed_product, lp  : name = $optional
{   subproduct, s         : name = $optional
{   level, l              : name = $optional
{   type, t               : key release, correction = $optional
{   correction_chosen, cc : boolean = $optional
{   status                : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      adds_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^adds_pdt_names, ^adds_pdt_params];

    VAR
      adds_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 13] of
            clt$parameter_name_descriptor := [['PACS_CATALOG', 1], ['PC', 1], ['LICENSED_PRODUCT', 2],
            ['LP', 2], ['SUBPRODUCT', 3], ['S', 3], ['LEVEL', 4], ['L', 4], ['TYPE', 5], ['T', 5],
            ['CORRECTION_CHOSEN', 6], ['CC', 6], ['STATUS', 7]];

    VAR
      adds_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 7] of clt$parameter_descriptor := [

{ PACS_CATALOG PC }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ LICENSED_PRODUCT LP }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ SUBPRODUCT S }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ LEVEL L }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ TYPE T }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [^adds_pdt_kv5, clc$keyword_value]],

{ CORRECTION_CHOSEN CC }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      adds_pdt_kv5: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := ['RELEASE',
            'CORRECTION'];

?? POP ??

    VAR
      attributes_p: ^rat$subproduct_attributes,
      auto_install: boolean,
      file_opened: boolean,
      ignore_status: ost$status,
      local_status: ost$status,
      message_status: ost$status,
      mmt_seg_p: mmt$segment_pointer,
      order_contents: rat$order_contents,
      pacs_path_p: ^pft$path,
      pacs_ref_p: ^fst$file_reference,
      seg_p: amt$segment_pointer,
      subproduct_info_pointers: rat$subproduct_info_pointers,
      sif_file_id: amt$file_identifier,
      sif_file_ref_p: ^fst$file_reference,
      sif_pacs_ref_p: ^string ( * ),
      subproduct_seq_length: amt$file_length,
      subproduct_seq_p: rat$subproduct_info_p,
      write_definition_needed_flag_p: ^boolean;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the file has been opened, it will be closed before the
{   the procedure returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF file_opened THEN
        fsp$close_file (sif_file_id, ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    file_opened := FALSE;

    clp$scan_parameter_list (parameter_list, adds_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF rav$packing_list_header_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$command_defo_required, '', message_status);
      osp$generate_error_message (message_status, ignore_status);
      RETURN;
    IFEND;

    RESET rav$creod_scratch_segment.sequence_p TO rav$creod_scratch_segment.reset_p;
    rap$get_file_path_and_ref ('PACS_CATALOG', rav$creod_scratch_segment.sequence_p, pacs_path_p,
          pacs_ref_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$add_name_to_path_ref (pacs_ref_p, rac$sif_file_name, rav$creod_scratch_segment.sequence_p,
          sif_file_ref_p);

    rap$open_file (sif_file_ref_p, amc$segment, fsc$read, FALSE, NIL, sif_file_id, file_opened, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      amp$get_segment_pointer (sif_file_id, amc$sequence_pointer, seg_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      mmt_seg_p.seq_pointer := NIL;
      rap$get_sif_pointers (seg_p, mmt_seg_p, sif_file_ref_p, subproduct_info_pointers, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      attributes_p := subproduct_info_pointers.attributes_p;
      PUSH sif_pacs_ref_p: [attributes_p^.pacs_catalog_path.size];
      sif_pacs_ref_p^ := attributes_p^.pacs_catalog_path.path (1, attributes_p^.pacs_catalog_path.size);

      IF pacs_ref_p^ <> sif_pacs_ref_p^ THEN

          osp$set_status_abnormal ('RA', rae$pacs_catalog_name_changed, sif_pacs_ref_p^, message_status);
          osp$append_status_file (osc$status_parameter_delimiter, pacs_ref_p^, message_status);
          osp$append_status_file (osc$status_parameter_delimiter, pacs_ref_p^, message_status);
          osp$generate_error_message (message_status, ignore_status);
          RETURN;

       IFEND;

      validate_licensd_prod_parameter (subproduct_info_pointers.attributes_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      validate_subproduct_parameter (subproduct_info_pointers.attributes_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      validate_level_parameter (subproduct_info_pointers.attributes_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      validate_type_parameter (subproduct_info_pointers.attributes_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      validate_order_contents (subproduct_info_pointers.attributes_p, rav$order_contents_list_p, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      process_correction_chosen (subproduct_info_pointers.attributes_p, auto_install, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      add_sif_to_packing_list (subproduct_info_pointers.subproduct_info_seq_p, rav$packing_list_seq_p,
            subproduct_seq_length, subproduct_seq_p, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      initialize_order_contents_recd (subproduct_info_pointers.attributes_p, auto_install, pacs_ref_p^,
           subproduct_seq_length, subproduct_seq_p, order_contents);

      add_to_order_contents_list (order_contents, rav$creod_scratch_segment, rav$order_contents_list_p,
            rav$order_contents_count, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

    END /main/;

    fsp$close_file (sif_file_id, local_status);
    IF status.normal THEN
      status := local_status;
    IFEND;

    osp$disestablish_cond_handler;

    RESET rav$creod_scratch_segment.sequence_p;
    NEXT write_definition_needed_flag_p IN rav$creod_scratch_segment.sequence_p;
    write_definition_needed_flag_p^ := TRUE;

  PROCEND rap$add_subproduct;

?? TITLE := 'add_sif_to_packing_list', EJECT ??

{ PURPOSE:
{   This procedure adds the SIF to the end of the packing list.
{
{ DESIGN:
{   The size of the SIF is determined and that size is added to the
{   end of the packing list.  The contents of the SIF is stored in the
{   part of the packing list that has been added.
{
{ NOTES:
{
{

  PROCEDURE add_sif_to_packing_list
    (VAR subproduct_info_seq_p: ^rat$subproduct_info_sequence;
     VAR rav$packing_list_seq_p: ^rat$packing_list_sequence;
     VAR subproduct_seq_length: amt$file_length;
     VAR subproduct_seq_p: rat$subproduct_info_p;
     VAR status: ost$status);


    VAR
      seq_p: ^SEQ ( * ),
      sif_seq_p: ^rat$subproduct_info_sequence;


    status.normal := TRUE;

    subproduct_seq_length := #SIZE (subproduct_info_seq_p^);
    RESET subproduct_info_seq_p;
    NEXT sif_seq_p: [[REP subproduct_seq_length OF cell]] IN subproduct_info_seq_p;
    IF sif_seq_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    NEXT seq_p: [[REP subproduct_seq_length OF cell]] IN rav$packing_list_seq_p;
    IF seq_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;
    seq_p^ := sif_seq_p^;

    subproduct_seq_p := #REL (seq_p, rav$packing_list_seq_p^);

  PROCEND add_sif_to_packing_list;

?? TITLE := 'add_to_order_contents_list', EJECT ??

{ PURPOSE:
{   This procedure adds the order contents record to the end of the order contents
{   list.
{
{ DESIGN:
{   The order contents list is reset and then it is created with a size
{   one larger than the previous size.  The last element in the new array
{   is set equal to the order contents.
{
{ NOTES:
{   The scratch segment reset pointer must be reset to just beyond the new end
{   of the contents list.

  PROCEDURE add_to_order_contents_list
    (    order_contents: rat$order_contents;
     VAR rav$creod_scratch_seqment: rat$scratch_segment;
     VAR rav$order_contents_list_p: ^rat$order_contents_list;
     VAR rav$order_contents_count: rat$subproduct_count;
     VAR status: ost$status);


    status.normal := TRUE;

    rav$order_contents_count := rav$order_contents_count + 1;
    RESET rav$creod_scratch_segment.sequence_p TO rav$order_contents_list_p;
    NEXT rav$order_contents_list_p: [1 .. rav$order_contents_count] IN rav$creod_scratch_segment.sequence_p;
    IF rav$order_contents_list_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    rav$order_contents_list_p^ [rav$order_contents_count] := order_contents;

    NEXT rav$creod_scratch_segment.reset_p IN rav$creod_scratch_segment.sequence_p;
    IF rav$creod_scratch_segment.reset_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

  PROCEND add_to_order_contents_list;

?? TITLE := 'initialize_order_contents_recd', EJECT ??

{ PURPOSE:
{   This procedure sets the values of the order contents record.
{
{ DESIGN:
{   The fields in the order contents record are set from the values
{   in the attributes record, the pacs path, auto install and other
{   input parameters.
{
{ NOTES:
{
{

  PROCEDURE initialize_order_contents_recd
    (    attributes_p: ^rat$subproduct_attributes;
         auto_install: boolean;
         pacs_path: fst$file_reference;
         subproduct_seq_length: amt$file_length;
         subproduct_seq_p: rat$subproduct_info_p;
     VAR order_contents: rat$order_contents);


    order_contents.contents_type := subproduct;

    order_contents.size := attributes_p^.size;
    order_contents.licensed_product := attributes_p^.licensed_product;
    order_contents.level := attributes_p^.level;
    order_contents.name := attributes_p^.name;
    order_contents.subproduct_type := attributes_p^.subproduct_type;
    order_contents.sif_identifier := attributes_p^.sif_identifier;

    order_contents.auto_install := auto_install;

    order_contents.pacs_catalog.path (1, * ) := ' ';
    order_contents.pacs_catalog.size := clp$trimmed_string_size (pacs_path);
    order_contents.pacs_catalog.path := pacs_path (1, order_contents.pacs_catalog.size);

    order_contents.subproduct_seq_length := subproduct_seq_length;
    order_contents.subproduct_seq_p := subproduct_seq_p;

    order_contents.assignment_priority := $INTEGER (attributes_p^.subproduct_priority);
    order_contents.position_assigned := rac$not_assigned;

  PROCEND initialize_order_contents_recd;

?? TITLE := 'process_correction_chosen', EJECT ??

{ PURPOSE:
{   This procedure validates the value of CORRECTION_CHOSEN
{   and sets the correct value of AUTO_INSTALL.
{
{ DESIGN:
{   1.  If the subproduct was defined as type release:
{       A) A CORRECTION_CHOSEN parameter cannot be specified.
{       B) The value of AUTO_INSTALL defaults to the value in the
{          subproduct attributes AUTO_INSTALL field.
{
{   2.  If the subproduct was defined as type correction:
{       A) AUTO_INSTALL is set to the boolean equal to the CORRECTION_CHOSEN
{          parameter.
{       B) When CORRECTION_CHOSEN is not specified, the value of AUTO_INSTALL
{          defaults to TRUE.
{
{ NOTES:
{
{

  PROCEDURE process_correction_chosen
    (    attributes_p: ^rat$subproduct_attributes;
     VAR auto_install: boolean;
     VAR status: ost$status);


    VAR
      specified: boolean,
      value: clt$value;

    status.normal := TRUE;

    clp$test_parameter ('CORRECTION_CHOSEN', specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF attributes_p^.subproduct_type = rac$release THEN

      IF specified THEN
        osp$set_status_abnormal ('RA', rae$incorrect_value_for_corr_ch, '', status);
        RETURN;
      IFEND;
      auto_install := attributes_p^.auto_install;

    ELSE {rac$correction}

      IF specified THEN
        clp$get_value ('CORRECTION_CHOSEN', 1, 1, clc$low, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        auto_install := value.bool.value;
      ELSE
        auto_install := TRUE;
      IFEND;

    IFEND;

  PROCEND process_correction_chosen;


?? TITLE := 'validate_level_parameter', EJECT ??

{ PURPOSE:
{   Validate that the LEVEL parameter equals the LEVEL
{   as set in the subproduct attributes record.
{
{ DESIGN:
{   If the parameter has been specified, it is compared with the
{   field in the attributes record.  If the two are not equal
{   a bad status is returned.
{
{ NOTES:
{
{

  PROCEDURE validate_level_parameter
    (    attributes_p: ^rat$subproduct_attributes;
     VAR status: ost$status);


    VAR
      specified: boolean,
      value: clt$value;

    status.normal := TRUE;

    clp$test_parameter ('LEVEL', specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF specified THEN

      clp$get_value ('LEVEL', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF attributes_p^.level <> value.name.value THEN
        osp$set_status_abnormal ('RA', rae$sif_mismatch, 'LEVEL', status);
        RETURN;
      IFEND;

    IFEND;

  PROCEND validate_level_parameter;

?? TITLE := 'validate_licensd_prod_parameter', EJECT ??

{ PURPOSE:
{   Validate that the LICENSED PRODUCT parameter equals the LICENSED PRODUCT
{   as set in the subproduct attributes record.
{
{ DESIGN:
{   If the parameter has been specified, it is compared with the
{   field in the attributes record.  If the two are not equal
{   a bad status is returned.
{
{ NOTES:
{
{

  PROCEDURE validate_licensd_prod_parameter
    (    attributes_p: ^rat$subproduct_attributes;
     VAR status: ost$status);


    VAR
      specified: boolean,
      value: clt$value;

    status.normal := TRUE;

    clp$test_parameter ('LICENSED_PRODUCT', specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF specified THEN

      clp$get_value ('LICENSED_PRODUCT', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF attributes_p^.licensed_product <> value.name.value THEN
        osp$set_status_abnormal ('RA', rae$sif_mismatch, 'LICENSED PRODUCT', status);
        RETURN;
      IFEND;

    IFEND;

  PROCEND validate_licensd_prod_parameter;

?? TITLE := 'validate_order_contents', EJECT ??

{ PURPOSE:
{   This procedure determines if this subproduct can be added to the
{   order contents list.
{
{ DESIGN:
{   This procedure validates an entry to the order contents list by
{   checking the following:
{   1. If the order type on the ADD SUBPRODUCT command is correction,
{      the subproduct type in the SUBPRODUCT INFORMATION FILE cannot be release.
{   2. If the subproduct has been specified on a previous ADD SUBPRODUCT command,
{      it cannot be specifed as the as the same order type.
{
{ NOTES:
{
{

  PROCEDURE validate_order_contents
    (    attributes_p: ^rat$subproduct_attributes;
         order_contents_list_p: ^rat$order_contents_list;
     VAR status: ost$status);


    VAR
      i: rat$subproduct_count;

    status.normal := TRUE;

    FOR i := rac$first_subproduct_entry TO UPPERBOUND (order_contents_list_p^) DO

      IF order_contents_list_p^ [i].name = attributes_p^.name THEN
        IF (order_contents_list_p^ [i].subproduct_type = attributes_p^.subproduct_type) THEN
          osp$set_status_abnormal ('RA', rae$type_already_specified, attributes_p^.name , status);
          osp$append_status_parameter (osc$status_parameter_delimiter, rav$subproduct_type
               [attributes_p^.subproduct_type], status);
          RETURN;
        IFEND;
      IFEND;

    FOREND;

  PROCEND validate_order_contents;

?? TITLE := 'validate_subproduct_parameter', EJECT ??

{ PURPOSE:
{   Validate that the SUBPRODUCT parameter equals the name
{   as set in the subproduct attributes record.
{
{ DESIGN:
{   If the parameter has been specified, it is compared with the
{   field in the attributes record.  If the two are not equal
{   a bad status is returned.
{
{ NOTES:
{
{

  PROCEDURE validate_subproduct_parameter
    (    attributes_p: ^rat$subproduct_attributes;
     VAR status: ost$status);


    VAR
      value: clt$value,
      specified: boolean;

    status.normal := TRUE;

    clp$test_parameter ('SUBPRODUCT', specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF specified THEN

      clp$get_value ('SUBPRODUCT', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF attributes_p^.name <> value.name.value THEN
        osp$set_status_abnormal ('RA', rae$sif_mismatch, 'SUBPRODUCT', status);
        RETURN;
      IFEND;

    IFEND;

  PROCEND validate_subproduct_parameter;

?? TITLE := 'validate_type_parameter', EJECT ??

{ PURPOSE:
{   Validate that the TYPE parameter equals the subproduct_type
{   as set in the subproduct attributes record.
{
{ DESIGN:
{   If the parameter has been specified, it is compared with the subproduct_type
{   field in the attributes record.  If the two are not equal
{   a bad status is returned.
{
{ NOTES:
{
{

  PROCEDURE validate_type_parameter
    (    attributes_p: ^rat$subproduct_attributes;
     VAR status: ost$status);


    VAR
      value: clt$value,
      specified: boolean;

    status.normal := TRUE;

    clp$test_parameter ('TYPE', specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF specified THEN
      clp$get_value ('TYPE', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF ((attributes_p^.subproduct_type = rac$release) AND (value.name.value =
            'CORRECTION')) OR ((attributes_p^.subproduct_type = rac$correction) AND
            (value.name.value = 'RELEASE')) THEN
        osp$set_status_abnormal ('RA', rae$sif_mismatch, 'TYPE', status);
        RETURN;
      IFEND;

    IFEND;

  PROCEND validate_type_parameter;


MODEND ram$add_subproduct;
