?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: DEFINE_SUBPRODUCT Subutility Command.' ??
MODULE ram$define_subproduct;

{ PURPOSE:
{   This module invokes the DEFINE_SUBPRODUCT utility.
{
{ DESIGN:
{   This module creates a sequence in memory and sets pointers to
{   the sequence for the info header, subproduct attributes and the element list.
{   Then the info header, subproduct attributes and element list are initialized
{   to their default values.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*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 pft$array_index
*copyc rat$scratch_segment
*copyc rat$sequence_descriptor_types
*copyc rat$subproduct_info_pointers
*copyc rat$subproduct_info_types
?? POP ??
*copyc amp$get_file_attributes
*copyc clp$get_value
*copyc clp$include_line
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$scan_command_file
*copyc clp$scan_parameter_list
*copyc fsp$close_file
*copyc fsp$open_file
*copyc mmp$create_scratch_segment
*copyc mmp$create_segment
*copyc mmp$delete_scratch_segment
*copyc mmp$delete_segment
*copyc osp$append_status_parameter
*copyc osp$append_status_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pfp$purge
*copyc pmp$get_compact_date_time
*copyc rap$add_correction_format
*copyc rap$add_name_to_path_ref
*copyc rap$create_element_list
*copyc osp$generate_error_message
*copyc rap$get_file_path_and_ref

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

  VAR
    rav$defs_utility_name: [XDCL] ost$name := 'DEFINE_SUBPRODUCT';

  VAR
    rav$pacs_catalog_p: [XDCL] ^pft$path;

  VAR
    rav$pacs_catalog_ref_p: [XDCL] ^fst$file_reference;

  VAR
    rav$subproduct_info_pointers: [XDCL] rat$subproduct_info_pointers;

  VAR
    rav$defs_scratch_segment: [XDCL] rat$scratch_segment;

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

{ PURPOSE:
{   This procedure creates a sequence in memory and sets pointers to
{   the sequence for the info header, subproduct attributes and the element list.
{   Then the info header, subprodcut attributes and element list are initialized
{   to their default values.
{
{ DESIGN:
{   The PACS catalog is tested for the existence of a SIF file.  This procedure
{   will abort with an error message if one exists.
{   Then the SIF is initialized with values from the PACS catalog.
{
{ NOTES:
{
{

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


{ pdt defs_pdt (
{   name, n              : name = $required
{   pacs_catalog, pc     : file = $required
{   type, t              : key release, correction = $required
{   disable_checksums ..
{   disable_checksum, dc :boolean = false
{   status               : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    defs_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^defs_pdt_names, ^defs_pdt_params];

  VAR
    defs_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 10] of
      clt$parameter_name_descriptor := [['NAME', 1], ['N', 1], ['PACS_CATALOG', 2], ['PC', 2], ['TYPE', 3], [
      'T', 3], ['DISABLE_CHECKSUMS', 4], ['DISABLE_CHECKSUM', 4], ['DC', 4], ['STATUS', 5]];

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

{ NAME N }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

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

{ TYPE T }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^defs_pdt_kv3, clc$keyword_value]],

{ DISABLE_CHECKSUMS DISABLE_CHECKSUM DC }
    [[clc$optional_with_default, ^defs_pdt_dv4], 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
    defs_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := ['RELEASE',
      'CORRECTION'];

  VAR
    defs_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';

?? POP ??

{ table n=defs_command_table t=command s=xdcl
{ command n=(define_catalog_permit, define_catalog_permits, defcp) p=rap$define_catalog_permit cm=xref
{ command n=(define_correction_format, define_correction_formats, defcf) p=rap$define_correction_format    ..
{                               cm=xref
{ command n=(define_file_permit, define_file_permits, deffp) p=rap$define_file_permit cm=xref
{ command n=(define_library_merge, deflm) p=rap$define_library_merge cm=xref a=hidden
{ command n=(define_psrs_answered, define_psr_answered, defpa) p=rap$define_psrs_answered cm=xref
{ command n=(define_ring_attributes, define_ring_attribute, defra) p=rap$define_ring_attributes cm=xref
{ command n=(define_storage_class, define_storage_classes, defsc) p=rap$define_storage_class cm=xref
{ command n=(define_subproduct_attributes, defsa) p=rap$define_subproduct_attrib cm=xref
{ command n=(display_subproduct, diss) p=rap$display_subproduct cm=xref
{ command n=(quit, qui) p=rap$quit_defs cm=xref
{ tablend

?? PUSH (LISTEXT := ON) ??
VAR
  defs_command_table: [XDCL, READ] ^clt$command_table := ^defs_command_table_entries,

  defs_command_table_entries: [STATIC, READ] array [1 .. 26] of  clt$command_table_entry := [
  {} ['DEFCF                          ', clc$abbreviation_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rap$define_correction_format],
  {} ['DEFCP                          ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rap$define_catalog_permit],
  {} ['DEFFP                          ', clc$abbreviation_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$define_file_permit],
  {} ['DEFINE_CATALOG_PERMIT          ', clc$nominal_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rap$define_catalog_permit],
  {} ['DEFINE_CATALOG_PERMITS         ', clc$alias_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rap$define_catalog_permit],
  {} ['DEFINE_CORRECTION_FORMAT       ', clc$nominal_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rap$define_correction_format],
  {} ['DEFINE_CORRECTION_FORMATS      ', clc$alias_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rap$define_correction_format],
  {} ['DEFINE_FILE_PERMIT             ', clc$nominal_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$define_file_permit],
  {} ['DEFINE_FILE_PERMITS            ', clc$alias_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$define_file_permit],
  {} ['DEFINE_LIBRARY_MERGE           ', clc$nominal_entry, clc$hidden_entry, 4, clc$automatically_log,
         clc$linked_call, ^rap$define_library_merge],
  {} ['DEFINE_PSRS_ANSWERED           ', clc$nominal_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^rap$define_psrs_answered],
  {} ['DEFINE_PSR_ANSWERED            ', clc$alias_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^rap$define_psrs_answered],
  {} ['DEFINE_RING_ATTRIBUTE          ', clc$alias_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^rap$define_ring_attributes],
  {} ['DEFINE_RING_ATTRIBUTES         ', clc$nominal_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^rap$define_ring_attributes],
  {} ['DEFINE_STORAGE_CLASS           ', clc$nominal_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^rap$define_storage_class],
  {} ['DEFINE_STORAGE_CLASSES         ', clc$alias_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^rap$define_storage_class],
  {} ['DEFINE_SUBPRODUCT_ATTRIBUTES   ', clc$nominal_entry, clc$advertised_entry, 8,
        clc$automatically_log, clc$linked_call, ^rap$define_subproduct_attrib],
  {} ['DEFLM                          ', clc$abbreviation_entry, clc$hidden_entry, 4,
        clc$automatically_log, clc$linked_call, ^rap$define_library_merge],
  {} ['DEFPA                          ', clc$abbreviation_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^rap$define_psrs_answered],
  {} ['DEFRA                          ', clc$abbreviation_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^rap$define_ring_attributes],
  {} ['DEFSA                          ', clc$abbreviation_entry, clc$advertised_entry, 8,
        clc$automatically_log, clc$linked_call, ^rap$define_subproduct_attrib],
  {} ['DEFSC                          ', clc$abbreviation_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^rap$define_storage_class],
  {} ['DISPLAY_SUBPRODUCT             ', clc$nominal_entry, clc$advertised_entry, 9,
        clc$automatically_log, clc$linked_call, ^rap$display_subproduct],
  {} ['DISS                           ', clc$abbreviation_entry, clc$advertised_entry, 9,
        clc$automatically_log, clc$linked_call, ^rap$display_subproduct],
  {} ['QUI                            ', clc$abbreviation_entry, clc$advertised_entry, 10,
        clc$automatically_log, clc$linked_call, ^rap$quit_defs],
  {} ['QUIT                           ', clc$nominal_entry, clc$advertised_entry, 10,
        clc$automatically_log, clc$linked_call, ^rap$quit_defs]];

  PROCEDURE [XREF] rap$define_catalog_permit (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$define_correction_format (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$define_file_permit (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$define_library_merge (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$define_psrs_answered (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$define_ring_attributes (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$define_storage_class (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$define_subproduct_attrib (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$display_subproduct (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$quit_defs (parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? POP ??


    VAR
      info_segment_pointer: mmt$segment_pointer,
      first_element_p: ^rat$element,
      local_status: ost$status,
      scratch_segment_pointer: amt$segment_pointer,
      sif_present: boolean;

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

    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 info_segment_pointer.seq_pointer <> NIL THEN
        mmp$delete_segment (info_segment_pointer, 1, ignore_status);
        info_segment_pointer.seq_pointer := NIL;
      IFEND;

      IF scratch_segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (scratch_segment_pointer, ignore_status);
        scratch_segment_pointer.sequence_pointer := NIL;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;

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

    info_segment_pointer.kind := mmc$sequence_pointer;
    info_segment_pointer.seq_pointer := NIL;
    scratch_segment_pointer.kind := amc$sequence_pointer;
    scratch_segment_pointer.sequence_pointer := NIL;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      mmp$create_segment (NIL, mmc$sequence_pointer, 1, info_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, scratch_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      rav$defs_scratch_segment.sequence_p := scratch_segment_pointer.sequence_pointer;
      RESET rav$defs_scratch_segment.sequence_p;

      rap$get_file_path_and_ref ('PACS_CATALOG', rav$defs_scratch_segment.sequence_p, rav$pacs_catalog_p,
            rav$pacs_catalog_ref_p, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF rav$pacs_catalog_p^ [1] = '$LOCAL' THEN
        osp$set_status_abnormal ('RA', rae$cannot_use_local_catalog, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, 'PACS CATALOG', status);
        RETURN;
      IFEND;

      NEXT rav$defs_scratch_segment.reset_p IN rav$defs_scratch_segment.sequence_p;

      test_pacs_catalog_for_sif (rav$pacs_catalog_ref_p, rav$pacs_catalog_p, sif_present, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF sif_present THEN
        osp$set_status_abnormal ('RA', rae$pacs_catalog_contains_sif, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, rav$pacs_catalog_ref_p^, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, rac$sif_file_name, status);
        EXIT /main/;
      IFEND;

      initialize_info_sequence (rav$pacs_catalog_ref_p, rav$pacs_catalog_p, info_segment_pointer,
            rav$subproduct_info_pointers, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF rav$subproduct_info_pointers.attributes_p^.subproduct_type = rac$correction THEN
        first_element_p := rav$subproduct_info_pointers.element_list_p;
        rap$add_correction_format (rac$replacement, rav$subproduct_info_pointers.attributes_p^.
              first_level_element_count, first_element_p, rav$subproduct_info_pointers.subproduct_info_seq_p);
      IFEND;

      clp$push_utility (rav$defs_utility_name, clc$global_command_search, defs_command_table, NIL, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      clp$scan_command_file (clc$current_command_input, rav$defs_utility_name, 'DEFS', status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      clp$pop_utility (status);

    END /main/;

    IF info_segment_pointer.seq_pointer <> NIL THEN
      mmp$delete_segment (info_segment_pointer, 1, local_status);
      info_segment_pointer.seq_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF scratch_segment_pointer.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (scratch_segment_pointer, local_status);
      scratch_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$define_subproduct;

?? TITLE := 'initialize_info_sequence', EJECT ??

{ PURPOSE:
{   This procedure sets the initial values in the subproduct
{   attributes record and element list.
{
{ DESIGN:
{   This procedure sets the name and type fields in the
{   subproduct attributes record and calls a procedure to
{   create the element list.
{
{ NOTES:
{
{

  PROCEDURE initialize_info_sequence
    (    pacs_catalog_ref_p: ^fst$file_reference;
         pacs_catalog_path_p: ^pft$path;
     VAR info_segment_pointer: mmt$segment_pointer;
     VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      attributes_p: ^rat$subproduct_attributes,
      checksum_files: boolean,
      ignore_status: ost$status,
      message_status: ost$status,
      subproduct_type: ost$name,
      validation_errors: boolean,
      validation_selections: rat$validation_selections,
      value: clt$value;


    status.normal := TRUE;

    initialize_sequence_records (info_segment_pointer, subproduct_info_pointers, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    attributes_p := subproduct_info_pointers.attributes_p;

    clp$get_value ('NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    attributes_p^.name := value.name.value (1, value.name.size);

    clp$get_value ('TYPE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    subproduct_type := value.name.value (1, value.name.size);

    IF subproduct_type = 'RELEASE' THEN
      attributes_p^.subproduct_type := rac$release;
    ELSE { subproduct_type = 'CORRECTION' }
      attributes_p^.subproduct_type := rac$correction;
    IFEND;

    validation_selections := $rat$validation_selections [rac$loading_cycle_only, rac$no_rings_below_11,
          rac$no_permits];

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

    attributes_p^.calculate_contents_checksum := NOT value.bool.value;
    attributes_p^.pacs_catalog_path.path := '';
    attributes_p^.pacs_catalog_path.path := pacs_catalog_ref_p^;
    attributes_p^.pacs_catalog_path.size := #SIZE (pacs_catalog_ref_p^);

    rap$create_element_list (pacs_catalog_ref_p, pacs_catalog_path_p^, validation_selections,
           FALSE, validation_errors, subproduct_info_pointers, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF validation_errors THEN
      osp$set_status_abnormal ('RA', rae$invalid_pacs_catalog, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, pacs_catalog_ref_p^, status);
      RETURN;
    IFEND;

    IF subproduct_info_pointers.attributes_p^.first_level_element_count = 0 THEN
      osp$set_status_abnormal ('RA', rae$warn_pacs_catalog_empty, '', message_status);
      osp$generate_error_message (message_status, ignore_status);
      RETURN;
    IFEND;


  PROCEND initialize_info_sequence;

?? TITLE := 'test_pacs_catalog_for_sif', EJECT ??

{ PURPOSE:
{   This procedure determines if the SIF file already exists.
{
{ DESIGN:
{   AMP$GET_FILE_ATTRIBUTES is used to determine if the SIF file exists.
{
{ NOTES:
{
{

  PROCEDURE test_pacs_catalog_for_sif
    (    pacs_catalog_ref_p: ^fst$file_reference;
         pacs_catalog_p: ^pft$path;
     VAR sif_present: boolean;
     VAR status: ost$status);

    VAR
      cycle_selector: pft$cycle_selector,
      existing_file: boolean,
      i: pft$array_index,
      ignore_attributes: array [1 .. 1] of amt$get_item,
      ignore_contains_data: boolean,
      local_file: boolean,
      local_status: ost$status,
      password: pft$password,
      sif_fid: amt$file_identifier,
      sif_path_p: ^pft$path,
      sif_reference_p: ^fst$file_reference,
      write_attachment: array [1 .. 2] of fst$attachment_option;

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

    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,
        local_status: ost$status,
        sif_path_p: ^pft$path;

      fsp$close_file (sif_fid, local_status);
      IF local_status.normal THEN
        PUSH sif_path_p: [1 .. UPPERBOUND (pacs_catalog_p^) + 1];
        FOR i := 1 TO UPPERBOUND (pacs_catalog_p^) DO
          sif_path_p^ [i] := pacs_catalog_p^ [i];
        FOREND;
        sif_path_p^ [UPPERBOUND (sif_path_p^)] := rac$sif_file_name;
        pfp$purge (sif_path_p^, cycle_selector, password, ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    password := ' ';
    cycle_selector.cycle_option := pfc$lowest_cycle;

    rap$add_name_to_path_ref (pacs_catalog_ref_p, rac$sif_file_name, rav$defs_scratch_segment.sequence_p,
          sif_reference_p);

    ignore_attributes [1].key := amc$file_length;

    amp$get_file_attributes (sif_reference_p^, ignore_attributes, local_file, existing_file,
          ignore_contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sif_present := (local_file OR existing_file);

  IF NOT sif_present THEN

    write_attachment [1].selector := fsc$access_and_share_modes;
    write_attachment [1].access_modes.selector := fsc$specific_access_modes;
    write_attachment [1].access_modes.value := $fst$file_access_options
          [fsc$read, fsc$shorten, fsc$append, fsc$modify];
    write_attachment [1].share_modes.selector := fsc$determine_from_access_modes;
    write_attachment [2].selector := fsc$create_file;
    write_attachment [2].create_file := TRUE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /open_file/
    BEGIN
      fsp$open_file (sif_reference_p^, amc$segment, ^write_attachment, NIL, NIL, NIL, NIL, sif_fid, status);
      IF NOT status.normal THEN
        EXIT /open_file/;
      IFEND;
    END /open_file/;

    fsp$close_file (sif_fid, local_status);
    IF local_status.normal THEN
      PUSH sif_path_p: [1 .. UPPERBOUND (pacs_catalog_p^) + 1];
      FOR i := 1 TO UPPERBOUND (pacs_catalog_p^) DO
        sif_path_p^ [i] := pacs_catalog_p^ [i];
      FOREND;
      sif_path_p^ [UPPERBOUND (sif_path_p^)] := rac$sif_file_name;
      pfp$purge (sif_path_p^, cycle_selector, password, local_status);
    IFEND;

    osp$disestablish_cond_handler;

  IFEND;

  PROCEND test_pacs_catalog_for_sif;

?? TITLE := 'initialize_sequence_records', EJECT ??

{ PURPOSE:
{   This procedure creates the sequence_descriptor_p, the info_header_p,
{   subproduct_attributes_p and the element_list_p and sets all of their
{   initial values.
{
{ DESIGN:
{   The sequence_descriptor_p, info_header_p, subproduct_attributes_p and
{   element_list_p are NEXT'd on subproduct_info_seq_p.  The values of the
{   relative pointers to the attributes_p and the element_list_p are saved
{   in the info_header record.
{   The value of the subproduct_info_pointers is initialized.
{
{ NOTES:
{
{

  PROCEDURE initialize_sequence_records
    (VAR info_segment_pointer: mmt$segment_pointer;
     VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      element_list_p: ^rat$element,
      i: 1 .. rac$max_additional_products,
      info_header_p: ^rat$subproduct_info_header,
      length: integer,
      sequence_descriptor_p: ^rat$sequence_descriptor,
      subproduct_attributes_p: ^rat$subproduct_attributes,
      subproduct_info_seq_p: ^rat$subproduct_info_sequence;


    status.normal := TRUE;

    subproduct_info_seq_p := info_segment_pointer.seq_pointer;
    RESET subproduct_info_seq_p;

    NEXT sequence_descriptor_p IN subproduct_info_seq_p;
    IF sequence_descriptor_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    NEXT info_header_p IN subproduct_info_seq_p;
    IF info_header_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    NEXT subproduct_attributes_p IN subproduct_info_seq_p;
    IF subproduct_attributes_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    NEXT element_list_p IN subproduct_info_seq_p;
    IF element_list_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    pmp$get_compact_date_time (sequence_descriptor_p^.sequence_creation_date_time, status );
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sequence_descriptor_p^.processor_version := rac$pacs_processor_version;
    sequence_descriptor_p^.sequence_level := rac$subproduct_info_level;
    sequence_descriptor_p^.sequence_type := rac$subproduct_info_sequence;

    info_header_p^.attributes_p := #REL (subproduct_attributes_p, subproduct_info_seq_p^);
    info_header_p^.element_list_p := #REL (element_list_p, subproduct_info_seq_p^);
    info_header_p^.path_container_length := 0;
    info_header_p^.path_container_p := NIL;
    info_header_p^.psrs_answered_count := 0;
    info_header_p^.psrs_answered_p := NIL;

    subproduct_attributes_p^.licensed_product := '';

    subproduct_info_pointers.sequence_descriptor_p := sequence_descriptor_p;
    subproduct_info_pointers.subproduct_info_seq_p := subproduct_info_seq_p;
    subproduct_info_pointers.info_header_p := info_header_p;
    subproduct_info_pointers.attributes_p := subproduct_attributes_p;
    subproduct_info_pointers.element_list_p := element_list_p;
    subproduct_info_pointers.path_container_p := NIL;
    subproduct_info_pointers.psrs_answered_p := NIL;

  PROCEND initialize_sequence_records;

MODEND ram$define_subproduct;
