PROCEDURE rap$write_tape_order (
  order_catalog, oc: file = $required
  external_vsn, evsn: any of
      key
        all
      keyend
      list of string 1..6
      list of name 1..6
    anyend = $required
  list, l: file = $list
  tape_file, tf: (BY_NAME, HIDDEN) file = $optional
  request_tape_labeling, request_tape_labelling, rtl: (BY_NAME, HIDDEN) boolean = $optional
  unload_volume, uv: boolean = true
  verify_option, vo: (BY_NAME, HIDDEN) key
      (brief, b)
      (full, f)
      (manufacturing, m)
    keyend = brief
  volume_overflow_allowed, voa: (BY_NAME, HIDDEN) boolean = false
  tape_permit, rmg: (BY_NAME, HIDDEN) any of
      key
        public, private, (release_tapes, release), none
      keyend
      name 1..13
    anyend = release_tapes
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"
" PURPOSE:
"   This procedure writes an order to a list of tapes.
"
" DESIGN:
"   The information from the order data file and the input parameters
"   on this procedure are used to write the packing list and the
"   subproducts to a list of tapes.  When the order data file is included,
"   a set of SCL variables is created and initialized.
"
"   The volume overflow allowed optional parameter allows specification
"   as to whether it is desired to allow tape volumes to overflow onto
"   additional tapes when the previous tape was not long enough, or
"   abort on an overflow condition.
"
" NOTES:
"
"
*IFEND

"$FORMAT=OFF
  VAR
    ignore_status: status
    local_status: status
    order_data: name = raf$order_data
    backup_status: status
    selected_evsns: list of string 1..6
    unique_tape_file: file = $fname($unique)
    tape_selected: boolean
    upper_evsns: list of string 1..6
    operator_reply: string
  VAREND
"$FORMAT=ON

  include_file f=order_catalog//order_data status=local_status
  EXIT procedure WITH local_status WHEN NOT local_status.normal

  IF order_medium <> tape THEN
    local_status = $status(false, 'RA', rae$medium_and_param_mismatch, order_medium, 'VSNS')
    EXIT procedure WITH local_status
  IFEND

  IF $generic_type(evsn) = key THEN
    selected_evsns = primary_vsns
  ELSE
    upper_evsns = evsn
    FOR evsn_index = 1 TO $size(evsn) DO
      upper_evsns(evsn_index) = $translate(lower_to_upper, evsn(evsn_index))
    FOREND

    IF $subset(upper_evsns, primary_vsns) THEN
      selected_evsns = upper_evsns
    ELSE
      local_status = $status(false, 'RA', rae$invalid_vsn_list)
      EXIT procedure WITH local_status
    IFEND

  IFEND

  IF $specified(tape_file) THEN
    unique_tape_file = $fname(tape_file)
  IFEND

" The WHEN handler is started here since it will be executed whenever the
" the procedure exits, even if the exit is because of an EXIT statement.

  WHEN exit DO
    include_command 'detach_file f=unique_tape_file uv=unload_volume' status=ignore_status
    EXIT procedure WITH osv$status
  WHENEND

main: ..
  BLOCK

    FOR tape_index = 1 TO $upperbound(tapes) DO

      tape_selected = $subset($first(tapes(tape_index).evsn), selected_evsns)

      IF tape_selected THEN

        IF request_tape_labeling THEN

          send_operator_message message=('PLS blank label '//..
tapes(tape_index).evsn//': internal_vsn='//tapes(tape_index).rvsn//'; density='//tape_type) ..
             operator_class=removable_media_operator status=ignore_status

        IFEND

        request_magnetic_tape f=unique_tape_file evsn=tapes(tape_index).evsn rvsn=tapes(tape_index).rvsn ..
              t=tape_type r=true voa=volume_overflow_allowed status=local_status
        EXIT main WHEN NOT local_status.normal

        IF tape_permit = public THEN
          change_tape_label_attributes file=unique_tape_file volume_accessibility=none ..
                owner_identifier=none status=local_status
        ELSEIF tape_permit = private THEN
          change_tape_label_attributes file=unique_tape_file volume_accessibility=a ..
                owner_identifier=$substr($string($job(login_user)) 1 14) status=local_status
        ELSEIF tape_permit = none THEN
          change_tape_label_attributes file=unique_tape_file volume_accessibility=$unspecified ..
                owner_identifier=$unspecified status=local_status
        ELSEIF tape_permit = release_tapes THEN
          change_tape_label_attributes file=unique_tape_file volume_accessibility=a ..
                removable_media_group=release_tapes status=local_status
        ELSE
          change_tape_label_attributes file=unique_tape_file volume_accessibility=a ..
                removable_media_group=tape_permit status=local_status
        IFEND
        EXIT main WHEN NOT local_status.normal

        IF tape_index = 1 THEN
          change_tape_label_attributes f=unique_tape_file fi=$string(packing_list_name) status=local_status
          EXIT main WHEN NOT local_status.normal

          BACKUP_PERMANENT_FILE bf=unique_tape_file l=list.$eoi status=backup_status
            EXIT main WHEN NOT backup_status.normal

            " The following line prevents compatibility problems in the backup file.
            set_backup_options backup_file_version=1 include_data=(ud rd od) ..
                  include_archive_information=false status=local_status
            EXIT main WHEN NOT local_status.normal

            backup_file f=order_catalog//packing_list_name status=local_status
            EXIT main WHEN NOT local_status.normal

            rap$display_message mm=ram$pacs_messages mn=backup_complete t=$response mp=($string(..
                  packing_list_name), primary_vsns(tape_index)) status=ignore_status
          QUIT

        IFEND

        FOR subproduct_index = tapes(tape_index).subproducts_index_lowerbound TO ..
              tapes(tape_index).subproducts_index_upperbound DO

          change_tape_label_attributes f=unique_tape_file fsp=next_file ..
                fi=$substr($string(subproducts(subproduct_index).name), 1, 17) status=local_status
          EXIT main WHEN NOT local_status.normal

          verify_subproduct pc=subproducts(subproduct_index).pacs_catalog vo=verify_option ..
                sif_identifier=subproducts(subproduct_index).sif_identifier status=local_status
          EXIT main WHEN NOT local_status.normal

          BACKUP_PERMANENT_FILE bf=unique_tape_file l=list.$eoi status=backup_status
            EXIT main WHEN NOT backup_status.normal

            " The following line prevents compatibility problems in the backup file.
            set_backup_options backup_file_version=1 include_data=(ud rd od) ..
                  include_archive_information=false status=local_status
            EXIT main WHEN NOT local_status.normal

            exclude_file f=subproducts(subproduct_index).pacs_catalog//sif_file_name status=local_status
            EXIT main WHEN NOT local_status.normal

            backup_catalog c=subproducts(subproduct_index).pacs_catalog status=local_status
            EXIT main WHEN NOT local_status.normal

            rap$display_message mm=ram$pacs_messages mn=backup_complete t=$response mp=($string(..
                  subproducts(subproduct_index).name), primary_vsns(tape_index)) status=ignore_status
          QUIT

        FOREND

      IFEND

      detach_file f=unique_tape_file uv=unload_volume status=ignore_status

    FOREND

  BLOCKEND main

  detach_file f=unique_tape_file uv=unload_volume status=ignore_status

  CANCEL exit

  EXIT procedure WITH local_status WHEN NOT local_status.normal
  EXIT procedure WITH backup_status WHEN NOT backup_status.normal

PROCEND rap$write_tape_order
