?? RIGHT := 110 ??
?? NEWTITLE := 'CREATE_ORDER_DEFINITION Subutility: DEFINE_ORDER Subcommand.' ??
MODULE ram$define_order;

{ PURPOSE:
{   This module contains procedures to initiate a new order definition.
{
{ DESIGN:
{   The scratch sequence and packing list sequences are reset.
{   The sequence descriptor and packing list header are added to the
{   packing list sequence and their fields are initialized.
{   The order contents list is added to the scratch sequence and initialized
{   with one entry for the packing list.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$packing_list_level
*copyc rac$packing_list_name
*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
?? POP ??
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc pmp$get_compact_date_time
*copyc rav$creod_scratch_segment
*copyc rav$order_contents_count
*copyc rav$order_contents_list_p
*copyc rav$packing_list_header_p
*copyc rav$packing_list_seq_p

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


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

{ PURPOSE:
{   This procedure initiates a new order definition.
{
{ DESIGN:
{   The scratch sequence and packing list sequences are reset.
{   The sequence descriptor and packing list header are added to the
{   packing list sequence and their fields are initialized.
{   The order contents list is added to the scratch sequence and initialized
{   with one entry for the packing list.
{
{ NOTES:
{

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


{ pdt defo_pdt (
{   identifier, i     : name = $required
{   medium, m         : key tape, disk = tape
{   type, t           : key release, correction = release
{   status            : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    defo_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^defo_pdt_names, ^defo_pdt_params];

  VAR
    defo_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
      clt$parameter_name_descriptor := [['IDENTIFIER', 1], ['I', 1], ['MEDIUM', 2], ['M', 2], ['TYPE', 3], [
      'T', 3], ['STATUS', 4]];

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

{ IDENTIFIER I }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ MEDIUM M }
    [[clc$optional_with_default, ^defo_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [^defo_pdt_kv2,
      clc$keyword_value]],

{ TYPE T }
    [[clc$optional_with_default, ^defo_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [^defo_pdt_kv3,
      clc$keyword_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
    defo_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := ['TAPE','DISK'];

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

  VAR
    defo_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'tape';

  VAR
    defo_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := 'release';

?? POP ??

    VAR
      ignore_status: ost$status,
      message_status: ost$status,
      write_definition_needed_flag_p: ^boolean;


    status.normal := TRUE;

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

    RESET rav$creod_scratch_segment.sequence_p;
    NEXT write_definition_needed_flag_p IN rav$creod_scratch_segment.sequence_p;
    IF write_definition_needed_flag_p^ = TRUE THEN
      osp$set_status_abnormal ('RA', rae$command_wrid_required, '', message_status);
      osp$generate_error_message (message_status, ignore_status);
    ELSE
      write_definition_needed_flag_p^ := TRUE;
    IFEND;

    initialize_packing_list_seq (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    initialize_order_contents_list (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$define_order;

?? TITLE := 'initialize_order_contents_list', EJECT ??

{ PURPOSE:
{   This procedure sets the initial values for the order contents
{   list in the scratch sequence.
{
{ DESIGN:
{   The order contents list is added to the scratch sequence and
{   its fields are initialized.
{
{ NOTES:
{
{

  PROCEDURE initialize_order_contents_list
    (VAR status: ost$status);

    status.normal := TRUE;

    NEXT rav$order_contents_list_p: [1 .. 1] IN rav$creod_scratch_segment.sequence_p;
    rav$order_contents_count := 1;

    rav$order_contents_list_p^ [1].assignment_priority := $INTEGER (rac$packing_list);
    rav$order_contents_list_p^ [1].size := 0;
    rav$order_contents_list_p^ [1].position_assigned := 0;
    rav$order_contents_list_p^ [1].name := rac$packing_list_name;
    rav$order_contents_list_p^ [1].contents_type := packing_list;

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

  PROCEND initialize_order_contents_list;

?? TITLE := 'initialize_packing_list_seq', EJECT ??

{ PURPOSE:
{   This procedure sets the initial values for the sequence descriptor
{   and packing list header in the packing list sequence.
{
{ DESIGN:
{   The sequence descriptor and packing list header are added to the
{   packing list sequence and their fields are initialized.
{
{ NOTES:
{
{

  PROCEDURE initialize_packing_list_seq
    (VAR status: ost$status);


    VAR
      length: integer,
      order_type: ost$name,
      sequence_descriptor_p: ^rat$sequence_descriptor,
      specified: boolean,
      value: clt$value;

    status.normal := TRUE;
    RESET rav$packing_list_seq_p;

    NEXT sequence_descriptor_p IN rav$packing_list_seq_p;
    IF sequence_descriptor_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$packing_list_level;
    sequence_descriptor_p^.sequence_type := rac$packing_list_sequence;

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

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

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

    IF value.name.value (1, value.name.size) = 'TAPE' THEN
      rav$packing_list_header_p^.order_medium := rac$tape;
    ELSEIF value.name.value (1, value.name.size) = 'DISK' THEN
      rav$packing_list_header_p^.order_medium := rac$disk;
    IFEND;

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

    IF order_type = 'RELEASE' THEN
      rav$packing_list_header_p^.order_type := rac$release;
    ELSE { order_type = 'CORRECTION' }
      rav$packing_list_header_p^.order_type := rac$correction;
    IFEND;

  PROCEND initialize_packing_list_seq;

MODEND ram$define_order;
