
PROC qcp$establish_qcu_environment (
correction, c: name = $required
correction_file_path, cfp: file = $required
check:VAR of boolean
output, o: file = $output
status )

crev ignore k=status
crev count
crev level_ident k=string v='A'
crev running_system k=string
crev check k=boolean v=FALSE
crev work k=string
crev path_name k=string
crev ci k=string v=$string($value(correction))
crev qev$ccu k=boolean v=FALSE s=xdcl
crev qev$previous_base k=string s=xdcl
crev qev$correction_base k=string s=xref
path_name = $string(qev$correction_base)

$value(check) = TRUE


      IF $file($value(output) open_position) = '$BOI' THEN
        rewind_file $value(output) status=ignore
        ofile = $string($value(output))//'.$ASIS'
      ELSE
        ofile = $string($value(output))
      IFEND

crev cf_path k=string v=$string($value(correction_file_path))
crev cc_path k=string v=path_name
crev cn_path k=string v=path_name//'.'//$string($value(correction))
crev cb_path k=string v=path_name//'.'//$string($value(correction))
     cb_path = cb_path//'.LINK_INPUT_FILES'
crev na_path k=string v=path_name//'.'//$string($value(correction))
     na_path = na_path//'.NAMES'
crev pl_path k=string v=path_name//'.'//$string($value(correction))
     pl_path = pl_path//'.HEADER'
crev temp2 k=string v=$unique//'.$asis'
crev lb_path k=string v=path_name//'.LIBRARIES'
crev cp_path k=string v=path_name//'.PATHS'
crev ll_path k=string v=path_name//'.LINK_INPUT_FILES'


check = $file($fname(cf_path),permanent)

IF NOT check THEN
 putl '                      WARNING  ' o=$fname(ofile//'.$eoi')
 putl ' The Correction File Path provided does not describe a file' o=$fname(ofile//'.$eoi')
 putl ' path known to the system. Please correct the situation and' o=$fname(ofile//'.$eoi')
 putl ' reissue the request.'                                       o=$fname(ofile//'.$eoi')
 putl ''                                                            o=$fname(ofile//'.$eoi')
 $value(check) = FALSE
 EXIT_PROC
IFEND

crec  $fname(cc_path) status=ignore
delc  $fname(cb_path) do=cac status=ignore
delf  $fname(na_path) status=ignore
detf  $fname(pl_path) status=ignore
delf  $fname(pl_path) status=ignore
crec  $fname(cn_path) status=ignore
crec  $fname(ll_path) status=ignore

crev break k=string v='_'
crev temp k=string v=$unique//'.$asis'
crev link_path k=string
crev qcu_ident k=string
crev system_ident k=string

content = $file($fname(cf_path),fc)
IF content <> 'FILE_BACKUP' THEN
 putl '                     WARNING ' o=$fname(ofile//'.$eoi')
 putl ' The correction path provided describes a file with improper' o=$fname(ofile//'.$eoi')
 putl ' file attributes. The file_content attribute must be set to'  o=$fname(ofile//'.$eoi')
 putl ' FILE_BACKUP to describe a proper correction packet file. File' o=$fname(ofile//'.$eoi')
 putl ' path '//cf_path//' has a file_content attribute of '//content  o=$fname(ofile//'.$eoi')
 putl ''                                                               o=$fname(ofile//'.$eoi')

 $value(check) = FALSE
 EXIT_PROC
IFEND


RESPF l=$fname(temp)
DISBF BF=$fname(cf_path)
QUIT

crev cross
crev counter
rewf $fname(temp) status=ignore
WHILE counter < 2 DO
 accl v=work i=$fname(temp) lc=count
 IF $substr(work,2,1) = ':' THEN
  counter = counter + 1
   IFEND
  cross = cross + 1
   IF cross > 10 THEN
      putl '                     WARNING  '   o=$fname(ofile//'.$eoi')
      putl ''                                 o=$fname(ofile//'.$eoi')
      putl ' The contents of the correction file are not as expected.'  o=$fname(ofile//'.$eoi')
      putl ' Either the path provided does not describe a proper'       o=$fname(ofile//'.$eoi')
      putl ' correction packet file or the file attributes are improper.' o=$fname(ofile//'.$eoi')
      putl ''                                                             o=$fname(ofile//'.$eoi')
      putl ' The required file attributes are fc=FILE_BACKUP, fs=DATA,'   o=$fname(ofile//'.$eoi')
      putl ' fp=UNKNOWN and rt=VARIABLE.'                                 o=$fname(ofile//'.$eoi')
      putl ''                                                             o=$fname(ofile//'.$eoi')
      putl ' Please correct the situation and reissue the request.'       o=$fname(ofile//'.$eoi')
      putl ''   o=$fname(ofile//'.$eoi')
      $value(check) = FALSE
      EXIT_PROC
 IFEND
WHILEND

crev base_path k=string
crev name_path k=string
crev head_path k=string

link_path = work
count = $scan_string(break,work)
count = count -1
base_path = $substr(work,1,count)
name_path = base_path//'_names'
head_path = base_path//'_pl'

RESPF l=$fname(temp)
RESC c=$fname(link_path) ncn=$fname(cb_path) bf=$fname(cf_path)
RESF f=$fname(name_path) nfn=$fname(na_path) bf=$fname(cf_path)
RESF f=$fname(head_path) nfn=$fname(pl_path) bf=$fname(cf_path)
QUIT


crev previous_base k=string
crev msg k=string
crev msg1 k=string
count = 1
detf $fname(pl_path) status=ignore
attf $fname(pl_path) op=$asis
 putl '' o=$fname(temp2)
 msg =  '       FIELD CORRECTION DESCRIPTION FOR '//$string($value(correction))
 putl ' '//msg o=$fname(temp2//'.$eoi')
 putl ' ' o=$fname(temp2//'.$EOI')
accl v=work i=$fname(pl_path) lc=count
WHILE count <> 0 DO
 IF $substr(work,8,10) = 'Identifier' THEN
    msg ='             QCU Identifier:    '
    msg = msg//$substr(work,21,6)
    putl msg o=$fname(temp2//'.$eoi')
    qcu_ident = $trim($substr(work,20,7))
 ELSEIF $substr(work,6,6) = 'Answer' THEN
    msg1 ='             Answers:           '
    msg1 = msg//$substr(work,20,$strlen(work))
    putl msg  o=$fname(temp2//'.$eoi')
    IF $substr(work,21,7) = 'GENERIC' THEN
         msg1 ='             Type:              CCU '
         qev$ccu = TRUE
    IFEND
 ELSEIF $substr(work,8,4) = 'Type' THEN
         msg1 ='             Type:              SINGLE '
         msg1 = msg//$substr(work,21,10)

 ELSEIF $substr(work,8,5) = 'Creat' THEN
    msg ='             Creation:          '
    msg = msg//$substr(work,21,19)
    putl msg o=$fname(temp2//'.$eoi')
 ELSEIF $substr(work,8,6) = 'Medium' THEN
    msg ='             Medium:            ELECTRONIC/'
    msg = msg//$substr(work,21,4)
    putl msg o=$fname(temp2//'.$eoi')
 ELSEIF $substr(work,11,7) = 'Product' THEN
    msg ='             Product:           '
    msg = msg//$substr(work,19,$strlen(work))
    putl msg o=$fname(temp2//'.$eoi')
 ELSEIF $substr(work,4,10) = 'Subproduct' THEN

    msg ='             Subproduct:        '
    msg = msg//$substr(work,15,17)
    putl msg o=$fname(temp2//'.$eoi')
 ELSEIF $substr(work,6,6) = 'Correc' THEN
    msg ='             Based on:          '
    msg = msg//$substr(work,22,12)
    putl msg  o=$fname(temp2//'.$eoi')
    previous_base = $substr(work,22,12)
    putl msg1 o=$fname(temp2//'.$eoi')
 IFEND

accl v=work i=$fname(pl_path) lc=count
WHILEND
    msg = '             Correction Path:   '
    msg = msg//$string($value(correction_file_path))
    putl msg  o=$fname(temp2//'.$eoi')



  crev hi_path k=string v=path_name//'.HISTORY.$ASIS'
  crev ho_path k=string v=path_name//'.HISTORY_LINE'

  delf $fname(ho_path) status=ignore
  detf $fname(hi_path) status=ignore

"**************************************************************************
" Update the installed code history file and retrieve the last QCU or BCU
" installed. If the history file currently does not exist create it.
" Return the last base value in variable qev$correction_base
"**************************************************************************
   crev history k=boolean v=FALSE
   history = $file($fname(hi_path),permanent)


   crev libs k=string
   crev libt k=string
   crev last_base k=string v=''
      IF $translate(ltu,$substr(previous_base,10,1))= 'X' THEN
         last_base = $substr(previous_base,6,4)
      ELSE
         last_base = $substr(previous_base,6,6)
      IFEND
   count = 1

   crev rs_path k=string v='$system.nosve_maintenance.link_input_files.os_version'
   incf $fname(rs_path)

   running_system = $string(level_id)
 IF running_system <> last_base  THEN
    putl '-'                            o=$fname(ofile//'.$eoi')
    putl '                   WARNING  ' o=$fname(ofile//'.$eoi')
    putl '      The correction '//$strrep(ci)//' was not manufactured' o=$fname(ofile//'.$eoi')
    putl '      against the system base at which you are currently'    o=$fname(ofile//'.$eoi')
    putl '      running.     '                                         o=$fname(ofile//'.$eoi')
    putl ' '                                                           o=$fname(ofile//'.$eoi')
    putl '      Installed system is '//level_id//' based'             o=$fname(ofile//'.$eoi')
    putl ' '                                                           o=$fname(ofile//'.$eoi')
    putl '      '//$strrep(ci)//' is '//last_base//' system based.' o=$fname(ofile//'.$eoi')
    putl ' '                                                       o=$fname(ofile//'.$eoi')
    putl '      The correction cannot be applied.'                 o=$fname(ofile//'.$eoi')
    putl ' '                                                       o=$fname(ofile//'.$eoi')
    $value(check) = FALSE
    detf $fname(pl_path) status=ignore
    delc $fname(cn_path) do=cac status=ignore
    EXIT_PROC
 IFEND


IF history THEN
   attf $fname(hi_path) op=$asis
   accl work i=$fname(hi_path) lc=count

    WHILE count <> 0 DO
          IF $substr(work,3,7) = $strrep(ci)  THEN
            putl '            WARNING '  o=$fname(ofile//'.$eoi')
            putl ' The correction specified is already installed' o=$fname(ofile//'.$eoi')
            putl ' '                                              o=$fname(ofile//'.$eoi')
             detf $fname(hi_path) status=ignore
             $value(check) = FALSE
             EXIT_PROC
          IFEND
        accl work i=$fname(hi_path) lc=count
    WHILEND

    detf $fname(hi_path) status=ignore
   count = 1
   attf $fname(hi_path) op=$asis
   accl work i=$fname(hi_path) lc=count

    WHILE count <> 0 DO
          IF work <> '' THEN
             last_base = $substr(work,3,7)
"            level_ident = $substr(work,19,1)
 "           level_ident = $char($ord(level_ident)+1)
             work = ''
          IFEND
        accl work i=$fname(hi_path) lc=count
    WHILEND
IFEND
crev c1
crev work1 k=string
crev psr k=string
crev lib k=string
crev ck_path k=string
detf $fname(na_path) status=ignore
attf $fname(na_path) op=$asis
 accl work i=$fname(na_path) lc=count
  WHILE count > 0 DO
   IF work <> 'OSF$VERSION' THEN
     lib = '.OSF$BOUND_'//$substr(work,5,$strlen(work))
     ck_path = ll_path//lib
      IF $file($fname(ck_path),permanent) THEN
       $value(check) = FALSE
         detf $fname(cp_path) status=ignore
         attf $fname(cp_path) op=$asis
         accl work1 i=$fname(cp_path) lc=c1

          WHILE c1 > 0 DO
           IF $substr(work1,1,29) = $substr(lib,2,29) THEN
             psr = $substr(work1,30,8)
           IFEND
           accl work1 i=$fname(cp_path) lc=c1
          WHILEND
           detf $fname(cp_path) status=ignore

         putl ' '
         putl '                     WARNING' o=$fname(ofile//'.$eoi')
         putl '      Modifications associated with correction '//ci  o=$fname(ofile//'.$eoi')
         putl '      conflict with previously installed corrections. It' o=$fname(ofile//'.$eoi')
         putl '      is not possible to install these modifications over' o=$fname(ofile//'.$eoi')
         putl '      the existing base. In order to successfully install' o=$fname(ofile//'.$eoi')
         putl '      the correction it will be necessary to withdraw'     o=$fname(ofile//'.$eoi')
         putl '      correction '//psr                                    o=$fname(ofile//'.$eoi')
         putl ' '                                                         o=$fname(ofile//'.$eoi')
        detf $fname(na_path) status=ignore
        detf $fname(hi_path) status=ignore
       EXIT_PROC
      IFEND
     IFEND
       accl work i=$fname(na_path) lc=count
    WHILEND

   crev user_ident k=string

   detf $fname(hi_path) status=ignore
" Manufacture a new system level id for this correction
  IF NOT qev$ccu THEN

   putl '    The Identifier for this correction system is of the form'  o=$fname(ofile)
   putl '    '//$substr(qcu_ident,2,5)//'Cn where n is a user supplied sub-identifier. Please'  o=$fname(ofile)
   accl v=work i=input lc=count p='   Enter a character to be used as the system sub-identifier - '
   user_ident = $translate(ltu,($substr(work,1,1)))
   putl ' ' o=$fname(ofile)
   putl '    The new system identifier will be '//$substr(qcu_ident,2,5)//'C'//user_ident  o=$fname(ofile)
   putl ' '   o=$fname(ofile)
   qcul = $size(qcu_ident)
   system_ident = $substr(qcu_ident,2,qcul-1)//'_C'//user_ident
   main_ident = 'C'//user_ident
   ELSE
   putl ' '
   putl ' Identifiers are no longer user supplied for a CCU'
   putl ' '
   system_ident = qcu_ident
   IFEND



   msg = ''
   msg = '  '//$strrep(ci)
   msg = msg//$substr('',1,13-$strlen(msg))//system_ident
   msg = msg//$substr('',1,25-$strlen(msg))//last_base
   msg = msg//$substr('',1,37-$strlen(msg))//previous_base
   msg = msg//$substr('',1,51-$strlen(msg))//$date(mdy)
   msg = msg//$substr('',1,62-$strlen(msg))//$time(hms)
   msg = msg//$substr('',1,75-$strlen(msg))//'NO'
   putl msg o=$fname(ho_path)

   qev$previous_base  = previous_base

   detf $fname(ho_path) status=ignore

" Go save the header file
    msg = '             System Identifier: '
    msg = msg//system_ident
    putl msg  o=$fname(temp2//'.$eoi')
     rewf $fname(temp2)  status=ignore
     detf $fname(pl_path) status=ignore
     copf $fname(temp2) $fname(pl_path)


detf $fname(na_path) status=ignore
attf $fname(na_path) op=$asis

accl work i=$fname(na_path) lc=count
WHILE count > 0 DO
 IF work <> 'OSF$VERSION' THEN
   putl work o=$fname(lb_path//'.$eoi')
 IFEND
accl work i=$fname(na_path) lc=count
WHILEND
detf $fname(na_path) status=ignore


modify_version,$value(correction),qcu_ident,system_ident


PROCEND qcp$establish_qcu_environment

