Michael S 2012-01-18 20:29

/*REXX ****************************************************************

  Takes a DICE BTS layout, and extracts the various variables
  (ie, performs the equivalent of a reverse DIALCOPY)

  Michael Simpson  Copyright   June 2004

  110830 Changed code to accomodate an 88-variable defined as
         88 :XX:-KORREKT-SVAR-J-N
                                  VALUE 'J'
                                  'N'.

 **********************************************************************/
PROCEDURE EXPOSE guiwindow sw_array

/* Entry handle is the handle to the multiline entry in the calling program */ 
ARG dial_data_handle, status_bar_handle, sw_mytrace

rname = 'DIALEXTR'

parms = ''
/* sw_mytrace = 0 */
rem_lead = 0
newlevel = ''

zuser = USERID()
zuser = TRANSLATE(zuser)

copydsn.1  = DIRECTORY()
copydsn.2  = "f:\a_ms_rexxcode\copybooks"
copydsn.3  = "f:\a_ms_rexxcode\tso_source_code"
copydsn.0 = 3

/* Get the entries from the entry control in the calling program's window */
/* The variable will automatically be placed in dial_data. (which is
   the name associated with the control in the calling program */
guigetctlvalue(dial_data_handle)

/* Check that they aren't trying to do a DIALEXTR when they SHOULD
   be doing a DIALCLN */
rc = find_string.rex('FIRST|./* COPY |1', dial_data., 0)
if rc <> 0 then
  rc = run_dialcln()

max_amount = 3000

cbl_comment = 1                         /*                       */
/* parse upper var ds proj '.' second '.' third '.' */
eof = 'NO'
bts_comment = './* '
dummy_bts_comment = '+/*' 
bts_commands = './O ./D ./T ./P ' /* Don't forget the trailing blank */
nr_copybooks = 0
v1 = 1
v2 = 99999
nr = 4      /* Maximum assumed number of occurs levels */
curr = 1

total_bytes = 0
ins_line = 0

field_names.0 = 0   /* 040623  misi01 */
field_types.0 = 0   /* 040623  misi01 */

eom = '$'           /* By default, use $ as end marker */
tran_langd = 0      /* By default, assume missing */
prefix = '' 
l_prefix = length(prefix)
syslrecl = 76
all_copybooks = ''

/* Set sw_status that will be used in dial_write_status_bar */
select
	when exists('status_bar_handle') = 0 then
		sw_status = 0
	when status_bar_handle = 0 then
		sw_status = 0	
	otherwise
		sw_status = 1
end		

temp ='Extracting BTS data'
rc = dial_write_status_bar.rex(temp, 2)
rc = get_btsin_cards()
/* Save the original BTS string */
temp_btsin = btsin

select
  when sw_m_found = 0 then
    rc = invalid_medd_header_anrop()
  when tran_langd = 0 then
    nop
  when tran_langd > length(temp_btsin) then
    rc = too_short_bts(tran_langd - length(temp_btsin))
  when tran_langd < length(temp_btsin) then
   rc =l too_long_bts(length(temp_btsin) - tran_langd)
  otherwise
    nop
end

sw_sep = '!'
nr_lines = 0
all_copybooks.0 = 0
data_lines.0 = 0

stop_after_copybook = 6
trace_nr_copybooks = 0
all_copybooks.0 = 1
/* Check valid IMS transaction */
rc = check_ims_trans()
ims_trans = substr(btsin,1,8)
btsin = substr(btsin,10) 
rc = check_shbgg014 
btsin = substr(btsin,rc+1)


/*
select
	when copybooks.1 = 'SHBGG514' then
		bts_i = 10			/* Point PAST the IMS transaction */
	otherwise		
		bts_i = 1
end		
*/
/* Loop round getting each copybook via count.rex.
	 The resulting copybook "layout" will be in 
	 ins_lines. Repalce the variables with the next
	 "part" of temp_btsin (throwing away leading data
	 from temp_btsin at the same time).
	 Insert all rows from ins_lines. into data_lines.
	 after which we drop ins_lines. and go round again.
*/   
do i4 = 1 to copybooks.0

  temp = "Copybook "i4" of "copybooks.0
  /*Temp*/
  say temp' 'copybooks.i4
	rc = dial_write_status_bar.rex(temp, 1)
	
	copybook = copybooks.i4
	rc = count.rex(ins_lines., "COPY "copybook)
	/* We now have the copybook layout in ins_lines.  Extract the first part of 
	   of BTS and put into place */
	rc = replace_ins_lines_with_btsin()   
	/* Insert ins_lines into data_lines. */
	rc = dial_insert_copybook_lines.rex('D', data_lines.0)
  drop ins_lines.
  
end

/* Okay - finished with all the copybooks. We shouldn't
   have anything left in BTSIN */
rc = exclude_unwanted_lines()
rc = align_separators.rex()

/* Create the 2 header data lines */
nr = 1
temp = bts_comment"SEP=!"
ins_lines.nr = temp ; nr=nr+1 
				
temp = bts_comment"HARDCODE=!" || substr(btsin,1,17) || '!' 
ins_lines.nr = temp ; nr=nr+1
ins_lines.0 = nr-1
rc = dial_insert_copybook_lines.rex('D', 0) 

    
rc = replace_lengthspecs() 
/* rc = replace_dummy_btsin_comments() */
rc = insert_hardcoded_values()

/* Write the contents of dial_data. to the entry control - clear out the control first ... */
drop dial_data.
/* .... copy the data_lines. to the contrl's stem variable .... */
rc = steminsert('dial_data.', 'data_lines.')
/* .... drop the data_lines. ...... */
drop data_lines.
/* .... and finally, write the data */
guisetctlvalue(dial_data_handle)

return 0
/*************************************************************

*************************************************************/
replace_ins_lines_with_btsin:


do i = 1 to ins_lines.0
	parse var ins_lines.i . '(' fld_length ')' . (sw_sep) fld_value (sw_sep)
	select
		when left(ins_lines.i,4) = bts_comment then
			nop
		when fld_length = 0 then
			nop				/* Group variable - ignore */
		otherwise
			do
				temp = substr(temp_btsin, bts_i ,fld_length)
				rc = dial_change_all.rex(ins_lines., fld_value, temp, i, i)
				bts_i = bts_i + fld_length
			end	
	end
end

/* Do it just the once.- should be cheaper/quicker */
temp_btsin = substr(temp_btsin, bts_i)
bts_i = 1			/* Now we need to point back at the START of the string */

return 0
/*************************************************************
 Check the IMS trans is valid. We check that:-

 - the first character isa 'P'
 - positions 3-8 are numeric

*************************************************************/
check_ims_trans:

select 
	when left(ims_trans,1) <> 'P' then
		rc = invalid_ims_trans(ims_trans, 1)
	when datatype(substr(ims_trans,3)) <> 'NUM' then
		rc = invalid_ims_trans(ims_trans, 2)
	otherwise
		nop
end
		
return 0
/*************************************************************
 Check that the first characters in BTSIN are NOW  X1002.00

 Returns the number of characters to throw away from the 
 start of the BTS string 
*************************************************************/
check_shbgg014:

normal_shbgg014 = ' X1002.00'
shbgg014 = left(btsin,length(temp))

select 
	when shbgg014 <> temp then
		rc = invalid_shbgg014(normal_shbgg014, shbgg014)
	otherwise
		nop
end			

return length(normal_shbgg014)
/***********************************************************
 Look for any SHBGG505 (could be lots of them) and count the
 number of bytes between each one. For example, the code
 could contain

   copy shbgg505
   copy fred
   copy bert
   copy shbgg505
   copy john

************************************************************/
check_shbgg505:

lgd_505 = 0
temp = 'SHBGG505-HDRIDFR'
x1 = length(temp)

curr = find_string.rex('FIRST|'temp, data_lines., 0)
if curr = 0 then
	/* No SHBGG505-HDRIDFR at all in file */
	return 0

line = data_lines.curr 
parse var line '(' x2 ')' .
lgd_505 = x2
curr = curr + 1

do while curr <> 0

  line = data_lines.curr 
  /* Loop round looking for the next line with SHBGG505-HDRIDFR */
  do while left(line,x1) <> temp & curr <= data_lines.0
    line = data_lines.curr 
    parse var line '(' x2 ')' .
    if length(x2) <> 0 then  /* In case it's a continuation line */
      lgd_505 = lgd_505 + x2
    curr = curr + 1  
  end

	if curr > data_lines.0 then
		curr = data_lines.0			/* If this was the last entry, then curr points one too far */
	
	/* Save where we were when we changed copybook */
  next_starting_point = curr
  
  curr = find_string.rex("PREV|SHBGG505-MSGLEN||"curr"/"1, data_lines., 0)
  line = data_lines.curr
  parse var line . (sw_sep) var_content (sw_sep) .
  x3 = length(var_content)
  x2 = '+'||right(lgd_505,x3 - 1,'0')
  rc = dial_change_all.rex(data_lines., var_content, x2, curr, curr)
  if sw_mytrace = 1 then
    do
      rc = var_content' to 'x2' for line 'curr
      rc = trace_current_line('C', rc)
    end
  /* Point back to where we were originally */
  curr = next_starting_point  
  curr = find_string.rex('NEXT|SHBGG505-HDRIDFR', data_lines., 1)
  if curr <> 0 then
    line = data_lines.curr
end

return 0
/***********************************************************
 Get rid of all lines containing a '*' in column 1
 **********************************************************/
exclude_unwanted_lines:

start_index = 1 + length(prefix)
test_field = 'SHBGG515-FILLER(277)'

/* Loop BACKWARDS (makes it easier) */
start = data_lines.0 
do i = start to 1 by -1

	parse var data_lines.i . '(' field_length ')' .

	if test_field = left(data_lines.i,length(test_field)) then
		nop
		
	select
		when length(data_lines.i) > syslrecl then
			do
				/* Needs splitting/wrapping */
				inserted_lines = split_text(syslrecl, i, data_lines.i)
				/* Now to delete the original LONG line */
				i2 = i + inserted_lines
			  rc = delete_lines(i2, 1)
			end
		otherwise
			nop
	end
end

drop all_copybooks.

return 0
/***********************************************************
 Replace various field contents with their hard-coded
 values - either the value we find in 'filename.DIAL'
 (or if that's missing) the value specified in this section
 (on the assumption that we find the various
 strings in the file)
************************************************************/
insert_hardcoded_values:

sw_finished = 0

guisay('length btsin 'length(btsin)' 'left(btsin,100))


/* Guarantee we're pointing at the first copybook variable */
curr = find_string.rex('FIRST|HARDCODE=', data_lines., 0)
curr = curr + 1
line = data_lines.curr
temp = line
btsin_temp = left(btsin,100)

do curr = 1 to data_lines.0 

	line = data_lines.curr 
	if left(line,1) = sw_sep then
		do
			/* Continuation line */
			parse var line (sw_sep) content (sw_sep)
			lgd = length(content)
		end	
	else
  	parse var line . '(' lgd ')' . (sw_sep) rest (sw_sep)

  select 
    when lgd = 0 then
    	lgd = ''				/* Group variable - ignore */ 
    when left(line,4) = bts_comment then
    	lgd = ''				/* BTS comment */	
/*    when substr(temp,1,8) <> ims_trans then
      nop   */
/*    when length(lgd) = 0 then
      /* We've arrived at the actual transaction. lgd contains
         nothing, which could well mean that we have a copybook
         WITHOUT the actual copybook name in the transaction
         data. Tell them
      */
      rc = copybook_name_missing() */
/*    when length(btsin) <> lgd then
      /* We should never come here. It probably means that the
         user adjusted an (invalid) length indicator WITHOUT
         adjusting the TOTAL length of the BTS string         */
      rc = bts_wrong_length(lgd - length(btsin)) */
    otherwise
      nop
  end
  y = 0
  y = y + pos('-MSGLEN',temp)
  y = y + pos('-HDRLEN',temp)
  y = y + pos('-LANGD-MEDDELANDE',temp)
  select
 		when bts_comment = left(line, length(bts_comment)) then
    	/* A line of the type ./ COPY xxxxxxx */
      lgd = ''
    when lgd = '' then
    	nop   
    when y > 0 then
      do
        /* Some sort of length indicator - check that the value
           is the same as that indicated in the BTSIN code */
        parse var line . (sw_sep) gen_l (sw_sep) .
        lgd = length(gen_l)
        y = substr(btsin,1,lgd)
        if gen_l <> y then
          do
            x = word(line,2)
            parse var x z '(' .
            bts_l = substr(btsin,1,lgd)
            rc = invalid_copybook_length(z, gen_l, bts_l)
          end
      end
    otherwise
      do
        /* Normal line - this is NOT a continuation line */
        start = pos(sw_sep,line) + 1
        parse var line . (sw_sep) content (sw_sep)
        old_string = sw_sep||substr(line,start,length(content))||sw_sep
        new_string = sw_sep||substr(btsin,1,length(content))||sw_sep
        if new_string <> old_string then
          do
            /* Don't change if nothing to change */
            rc = dial_change_all.rex(data_lines., old_string, new_string, curr, curr)
            if sw_mytrace = 1 then
              do
                rc = new_string
                rc = old_string' to 'rc' for line 'curr
                rc = trace_current_line('C', rc)
              end
          end
         /* Set lgd to the ACTUAL length of the string between separators.
            Otherwise, a line like
            SHBGG515-FILLER(277)!                                                      !
            will put everything out of wack */
         lgd = length(content)    
      end
      	
  end

  /* Get rid of the leading characters in btsin and point
     down a line */
  if length(lgd) <> 0 then
    btsin = substr(btsin,lgd + 1)

	btsin_temp = left(btsin,100)			/* For debugging purposes */ 

end
/*
if length(btsin) <> '' then
  /* We should never come here. It probably means that the
     user adjusted an (invalid) length indicator WITHOUT
     adjusting the TOTAL length of the BTS string         */
  rc = bts_wrong_length(lgd - length(btsin)) 
*/
return 0
/***********************************************************
 Replaces the various variables defining lengths
************************************************************/
replace_lengthspecs:

/* Now to replace all other variables ending in -LANGD-MEDDELANDE
   with the correct, generated length                           */
rc = replace_langd_meddelande('-MSGLEN')
rc = replace_langd_meddelande('-HDRLEN')
rc = replace_langd_meddelande('-LANGD-MEDDELANDE')

rc = check_shbgg505()

return 0
/***********************************************************
 Look for all occurrences of the length string, count
 the copybook length and insert the generated value
 Argument passed is the partial string that is used to
 contain the length indicator for the copybook
************************************************************/
replace_langd_meddelande:

/* Take the code from DIALCOPY and make separate script. DIALCOPY's
   version is more "flexible" */

arg lgd_name
lgd_name = strip(lgd_name)
lgd = 0   /* By default */

/*
  sw_cgpc is set to the following values:-
  0 - nothing to do with CGPCG010
  1 - we want the length of the current "group" variable
  2 - we want the length of ALL the CGPCG010 variables
  3 - we want the length of ALL the defined variables
      (this would be used for something like CGPCG016-LANGD-TRANSPORT)
*/
sw_cgpc = 0         /* By default */

select
  when lgd_name = 'CGPCG010-LANGD-HEADER-O-DATA' then
    do
      sw_cgpc = 1
      parse var lgd_name . '-' lgd_name
      lgd_name = '-'lgd_name
    end
  when lgd_name = 'CGPCG010-LANGD-TRANSAKTION' then
    do
      sw_cgpc = 2
      parse var lgd_name . '-' lgd_name
      lgd_name = '-'lgd_name
    end
  when lgd_name = 'CGPCG016-LANGD-TRANSPORT' then
    sw_cgpc = 3
  otherwise
    nop
end

curr = find_string.rex('FIRST|'lgd_name, data_lines., 1)
length_pos = curr

do while curr <> 0

  line = data_lines.curr 
  line2 = line
  lgdcsr = curr
  parse var line2 copybook_name (lgd_name) (sw_sep) var_length (sw_sep)
  var_sign = left(var_length,1)			/* Get the sign (it might NOT be signed) */
  copy_lgd = count_copy_length(strip(copybook_name), sw_cgpc)
  x1 = length(var_length)
	x2 = var_sign||right(copy_lgd,x1 - 1,'0')
	
  select
  	when copy_lgd = 0 then
  		nop
  	when left(line2,9) = 'SHBGG505-' then
  		nop				/* This has its own procedure */	
  	when var_length = x2 then
  		nop				/* Already has the correct value - leave alone */	
  	otherwise
  		do
      	length_field = copybook_name||lgd_name
      	status_bar = 'Automatically generating length value for 'length_field
				rc = dial_write_status_bar.rex(status_bar, 2)
      	curr = length_pos
 				rc = dial_change_all.rex(data_lines., var_length, x2, lgdcsr, lgdcsr)
    	end
  end  	
  lgdcsr = lgdcsr + 1
  curr = lgdcsr
  curr = find_string.rex('NEXT|'lgd_name, data_lines., 1)
  
end

return 0
/******************************************************************
 Count the total length for all items in the copybook
 specified in the argument. Note that this code has been changed
 so that it stops looking for the code once it finds a BTS
 commented line. The reason for this is that otherwise, if you had
 multiple copybooks with the SAME name, then this section would
 add up ALL fields starting with the same name. For example, if
 you had a line with "copy FRED" twice, and FRED contained (say)
 FRED-MSGLEN and the total length of the FRED copybook was 100
 bytes, the old code would look for ALL occurrences of FRED-
 and arrive at the grand total of 200 bytes (for the TWO copybooks)

 Okay, that logic wasn't enough (multiple duplicate copybooks).
 What we now do is to SAVE the first line of a copybook, and as
 soon as we find another line with the same variable name, we
 consider ourselves done with the current copybook
******************************************************************/
count_copy_length:

/* Can this become a separate script - used in DIALCOPY 
	 I've added the CGPC code from DIALCOPY
*/

arg copy_name, sw_cgpc
copy_lgd = 0

/* Loop backwards until we find the FIRST field belonging to
   this copybook                                            */
sw_finished = 0
x = copy_name||'-'
V1 = lgdcsr

/* Loop backwards until we find the FIRST field belonging to
   this copybook                                            */
sw_finished = 0
temp = '(0)'||sw_sep||sw_sep
x = copy_name||'-'

if sw_cgpc = 3 then
  do
    /* We want the total bytes for ALL fields */
    V1 = 1
    curr = v1
    sw_finished = 1
  end

do while sw_finished = 0

  V1 = V1 - 1
  curr = v1
  line = data_lines.curr
  /* Throw out possible BTS comment at start */
  line = substr(line, 1 + length(prefix))
  select
    when substr(line,1,length(x)) <> x then
      do
        sw_finished = 1
        v1 = v1 + 1
        curr = v1
      end
    when sw_cgpc = 1 & pos(temp,line) <> 0 then
      do
        /* We're looking at CGPCG010, and we've arrived at a
           group variable line (contains (0)!!)   */
        sw_finished = 1
        V1 = V1 + 1
        curr = v1
      end      
    when pos('-HDRIDFR',line) <> 0 then
      do
        /* Have to assume that if we reach a line containing
           the string '-HDRIDFR', then we're ALSO finished */
        sw_finished = 1
        curr = v1
      end
    otherwise
      nop
  end
end

sw_finished = 0
/* Get the first variable name */
line = data_lines.curr 
starting_variable = word(line,1)
/* Now loop forward calculating the total length of the copybook */
z = length(copy_name)

do while sw_finished = 0

  line = data_lines.curr  
  select
    when line = "" then
			sw_finished = 1       /* EOF */
    when substr(line,1,1) = sw_sep then
      do
        /* Continuation line for a looooooooong variable - ignore */
        V1 = V1 + 1
        curr = v1
        if curr > data_lines.0 then 
        	sw_finished = 1  /* EOF */
      end
    when (substr(line,1,z) <> copy_name) then
      do
        /* Code belonging to the NEXT copybook */
        sw_finished = 1
      end
    when (pos('-HDRIDFR',line) <> 0) & copy_lgd > 0 then
      do
        /* We "know" this is the first line of the current copybook */
        sw_finished = 1
      end
    when substr(line,1,4) = bts_comment then
      do
        sw_finished = 1
       end
    when substr(line,1,z) <> copy_name & sw_cgpc < 2 then
      /* Code belonging to the NEXT copybook AND we're not
         counting the WHOLE transaction length for
         CGPCG010-LANGD-TRANSAKTION */
      sw_finished = 1
    when sw_cgpc = 1 & pos('(0)',line) <> 0 then
      /* CGPC variable belonging to next group variable */
      sw_finished = 1       
    otherwise
      do
        parse var line '(' x1 ')' .
        copy_lgd = copy_lgd + x1
        V1 = V1 + 1
        curr = v1
        if curr > data_lines.0 then 
        	sw_finished = 1  /* EOF */
      end
  end
end

return copy_lgd
/*****************************************************************
 Couldn't insert the line 'cos it was too long. Split into
 multiple lines
 *************************************************************/
split_text:
procedure expose temp sw_sep rname sw_array curr sw_mytrace ,
				prefix data_lines. bts_comment

/* Can this be made a general script */				

parse arg lrecl, line_pointer, current_line

ins_lines = 0
temp2 = current_line
/* Remove the trailing separator, since we'll add it anyway */
x1 = length(temp2)
temp2 = substr(temp2,1,x1 - 1)
/* We're pointing BEYOND the current LONG line - back up a line */
x5 = line_pointer
x5 = x5 - 1

sw_start = 1
/* The actual area we can use is 4 bytes less than the record
   length - this because DIALBTS will insert BTS comment in front
   of each record. As a result of that, we will always be able
   to left shift all rows 4 bytes, change the values and then
   run DIALBTS again
*/

do while length(temp2) <> 0
  select
  	/* The remaining ecord must be <= the record length - 2
  	   bytes - one for the 1st separator, and one for the 2nd */
    when length(temp2) <= (lrecl - 2) /* (lrecl - 4)*/ then
      do                    /* All will fit on one line */
        temp3 = sw_sep||temp2||sw_sep
        temp2 = ''
      end
    when sw_start = 1 then
      do                    /* First time in            */
        temp3 = substr(temp2,1,lrecl - 1)||sw_sep
        temp2 = substr(temp2,lrecl)
      end
    otherwise
      do  /* Other lines              */
        temp3 = sw_sep||substr(temp2,1,lrecl - 2)||sw_sep
        temp2 = substr(temp2,lrecl - 1)
      end
  end

  ins_lines.0 = 1 ; ins_lines.1 = prefix||temp3
	rc = insert_copybook_lines('D',x5) 
	x5 = x5 + 1
  ins_lines = ins_lines + 1
  sw_start = 0
end

return ins_lines
/**********************************************************************
  Get the whole string into BTSIN
 **********************************************************************/
get_btsin_cards:

btsin = ''
sw_finished = 0
/* 'cursor = 1 1' */ curr = 1
curr = 1
/* A list of INLAPnnn copybooks which are "modern" and DON'T need
   SHBGG505 prefixed to them */
inla_modern = '/INLAP945/'
line = 'Dummy'

do while curr <= dial_data.0 & sw_finished = 0

  line = dial_data.curr
  bts? = substr(line,1,4)
  select
    when bts? = bts_comment then
      do
        /* BTS comment card. Check to see which it is */
        select
          when pos('EOM=',line) <> 0 then
            /* EOM= - get it */
            parse var line . 'EOM=' eom ' '.
          when pos('TRANLÄNGD=',line) <> 0 then
            /* TRANLÄNGD= - get it */
            parse var line . 'TRANLÄNGD=' tran_langd ' ' .
          otherwise
            nop
        end
      end
    when pos(bts?,bts_commands) <> 0 then
      nop
    when length(btsin) <> 0 & substr(line,72,1) <> '*' then
      do
        /* Last row of data */
        x = strip(line,'T')
        y = pos(eom,x)
        /* x = substr(x,1,length(x) - 1)  /* Remove trailing EOM */ */
        x = substr(x,1,y - 1)  /* Remove trailing EOM */
        btsin = btsin || x
        sw_finished = 1
      end
    when substr(line,72,1) = '*' then
      do
        /* Another line of data */
        btsin = btsin || substr(line,1,71)
      end
    otherwise
      sw_finished = 1
  end

  if sw_finished = 0 then
    /* Point to next row           */
    curr = curr + 1      

end

copybooks.0 = 0
/* See which copybook names we pulled */
/*
select 
	when substr(btsin,10,2) = 'X1' then
		do
			copybooks.0 = copybooks.0 + 1
			copybooks.[copybooks.0] = 'SHBGG514'
		end
	otherwise
		nop
end				
*/
copybooks.0 = copybooks.0 + 1
copybooks.[copybooks.0] = 'SHBGG511'   /* We assume this ALWAYS exists */

temp = btsin
sw_m_found = 0

temp = substr(temp,53)   
sw_finished = 0

do while sw_finished = 0

  /* First look for the characters 'M1' or 'M2' .... */
  y2 = pos('M2',temp)
  y1 = pos('M1',temp)
  y = 0                      /* By default */
  if (y1 <> 0) | (y2 <> 0) then
    do
      /* Found it - check that we have a + in pos 4 */
      if y1 = 0 then
        y1 = y2 + 1
      if y2 = 0 then
        y2 = y1 + 1
      if y2 < y1 then
        y = y2
      else
        y = y1
      sw_m_found = 1
      w = substr(temp,y)
      z = substr((w||'  '),4,1)
      if z <> '+' then
        /* No '+' - set y to pretend NOT found */
        y = 0
    end
  if y = 0 then
    sw_finished = 1
  else
    do
      copybook_length = substr(w,5,5)
      next_copybook = substr(temp,y + 9,8)
      /* 090119 Start */
      select
      	when strip(next_copybook) = '' then
      		rc = invalid_copybook_name(next_copybook, temp)
        when next_copybook = 'BOKAP413' then        
          do			/*Temp*/
          	copybooks.0 = copybooks.0 + 1
          	copybooks.[copybooks.0] = 'SHBGG505'
        	end      		
        when substr(next_copybook,1,5) <> 'INLAP' then
        	nop
        when pos('/'next_copybook'/',inla_modern) <> 0 then
          nop    /* Don't need to add SHBGG505 for this */
        otherwise
        do
          /* if next_copybook = 'BOKAP413' then
             nop */
          copybooks.0 = copybooks.0 + 1
          z = copybooks.0
          w = substr(next_copybook,5)
          copybooks.z = 'SHBGY505 REPLACING ==:XX:== BY =='w'=='
        end
      end
      copybooks.0 = copybooks.0 + 1
      z = copybooks.0
      copybooks.z = next_copybook
      /* temp = substr(temp,y + 17) 090119 */
      temp = substr(temp,copybook_length + 1)
    end
end

return 0
/**********************************************************************
 Trace changed code
**********************************************************************/
trace_current_line:
parse arg trace_type, string

if sw_mytrace = 0 then
  return 0

select
  when trace_type = '*' then
    temp = "Commenting "
  when trace_type = 'C' then
    temp = "Changing   "
  when trace_type = 'D' then
    temp = "Deleting   "
  when trace_type = 'I' then
    temp = "Inserting  "
  otherwise
    temp = "????????   "
end

say temp" "strip(string,"T")  /* " line "ms1 */
if pos('for line 0',string) <> 0 then
	nop

return 0
/*
/**********************************************************************

**********************************************************************/
HARDCODE_MISSING:

zedsmsg = "HARDCODE missing"
zedlmsg = "The HARDCODE= line is missing from your input",
          "- cannot continue"
rc = wdwsay.rex(zedlmsg, "STOP|")
RAISE FAILURE 2 DESCRIPTION ""
return 0
*/
/*
/**********************************************************************

**********************************************************************/
NO_SEP_LINE:

zedsmsg = "SEP= missing"
zedlmsg = "Can't find an uncommented line containing SEP=",
          "- check content and try again"
rc = wdwsay.rex(zedlmsg, "STOP|")
RAISE FAILURE 2 DESCRIPTION ""
return 0
*/
/**********************************************************************

**********************************************************************/
BTS_WRONG_LENGTH:

arg z
y = z * -1
zedsmsg = "Invalid input"
zedlmsg = 'Replacing variables with the BTS string, the variables',
          '"ran out". This probably means you adjusted a length',
          'indicator WITHOUT adjusting the length of the BTS string'

if z < 0 then
	zedlmsg = zedlmsg||' (your BTS string is 'y' byte(s) too long).'
else
  zedlmsg = zedlmsg||' (your BTS string is missing 'z' byte(s)).'

temp = " (DON'T forget to adjust the value in TRANLÄNGD as well)"
zedlmsg = zedlmsg || temp
rc = wdwsay.rex(zedlmsg, "STOP|")
RAISE FAILURE 2 DESCRIPTION ""
return 0
/**********************************************************************
 A copybook entry is empty - can't continue
**********************************************************************/
invalid_copybook_name:
parse arg copybook_name, temp
temp1 = "Invalid copybook name ("strip(copybook_name)") cannot continue"||'0D0A'x
temp1 = temp1"(current data being analyzed .....)"||'0D0A'x||'0D0A'x
temp1 = temp1 left(temp,100)
rc = wdwsay.rex(temp1, "STOP|")
RAISE FAILURE 2 DESCRIPTION ""
return 0
/**********************************************************************
 Couldn't find the string M1 in the btsin string - incorrectly defined
 MEDD-HEADER-ANROP ?
**********************************************************************/
INVALID_MEDD_HEADER_ANROP:
zedsmsg = "Invalid header ?"
zedlmsg = "Couldn't find the string 'M1' in your input data.",
					'0D0A'x,
          "Are you SURE you've defined your MEDD-HEADER-ANROP",
          "values correctly ?"
rc = wdwsay.rex(zedlmsg, "STOP|")
RAISE FAILURE 2 DESCRIPTION ""
return 0
/**********************************************************************

**********************************************************************/
INVALID_COPYBOOK_LENGTH:
arg variable, gen_l,bts_l
zedsmsg = "Invalid length"
zedlmsg = "Variable "variable" is defined as "gen_l" but the definition",
				  '0D0A'x,
          "in your BTS string is "bts_l" - investigate"
rc = wdwsay.rex(zedlmsg, "STOP|")
RAISE FAILURE 2 DESCRIPTION ""
return 0
/**********************************************************************

**********************************************************************/
invalid_ims_trans:

pargs arg ims_trans, error_type

select
	when error_type = 1 then
		temp = 'Invalid IMS trans ('ims_trans') - must start with the letter P'
	otherwise
		temp = 'Invalid IMS trans ('ims_trans') - positions 3-8 must be numeric'
	otherwise
		temp = 'Unexpected argument ('error_type') to INVALID_IMS_TRANS'
end	
rc = wdwsay.rex(temp, "STOP|")
RAISE FAILURE 2 DESCRIPTION ""
return 0
/**********************************************************************

**********************************************************************/
invalid_shbgg014:
parse arg normal_shbgg014, error_shbgg014

tepm = "Transaction MUST start with normal SHBGG014 content ("normal_shbgg014")"||'0D0A'x
temp = temp||"Your transaction contains ("shbgg014") instead - investigate"
rc = wdwsay.rex(zedlmsg, "STOP|")
RAISE FAILURE 2 DESCRIPTION ""
return 0
/*
/***************************************************************

***************************************************************/
run_dialcln:

zedsmsg = "Too short"
zedlmsg = "Cannot find the string './ * COPY ' in your source code",
          "- try running DIALCLN first"

rc = wdwsay.rex(zedlmsg, "STOP|")
RAISE FAILURE 2 DESCRIPTION ""
return 0
*/
/*************************************************************

*************************************************************/
insert_copybook_lines:
procedure expose all_copybooks. ins_lines. sw_array sw_mytrace,
			data_lines. bts_comment

/* Type can be 'A' - all_copybooks.
               'D' - data_lines.
*/                
arg type, position

if type = 'D' & pos(bts_comment' COPY BOKAP101',ins_lines.1) <> 0 then
	nop

select
	when sw_mytrace = 0 | ins_lines.0 > 2 then
		nop
	otherwise	
  	do
    	do i = 1 to ins_lines.0
      	rc = trace_current_line('I', ins_lines.i' before line 'position)
    	end
  	end
end  	  

select
	when sw_array = 0	& type = 'A' then
		rc = STEMINSERT("all_copybooks.", "ins_lines.", ,position)
	when sw_array = 0	& type = 'D' then
		do
			if pos('COPY ',ins_lines.1) <> 0 then
				nop
			rc = STEMINSERT("data_lines.", "ins_lines.", ,position + 1)		
		end	
	otherwise
		do
			do i = 1 to ins_lines.0
				rc = PUTS(ins_lines., i, left(ins_lines.i,80))
			end
			rc = insertglobal(ins_lines., all_copybooks., , , position)		
			if rc < 0 then
				do
					rc = array_failure.rex("INSERTGLOBAL")
					return 1
				end		
		end
end		

return rc	
/*************************************************************

*************************************************************/
delete_lines:
procedure expose sw_array data_lines. sw_mytrace

arg position, nr_lines

select
	when sw_mytrace = 0 then
		nop
	otherwise	
  	do
    	do i = position to position + (nr_lines - 1)
      	rc = trace_current_line('D', data_lines.i' at line 'position)
    	end
  	end
end  	 

if sw_array = 0 then
	rc = STEMDELETE("data_lines.", "E", position, nr_lines )
else
	do
		rc = EraseGlobal(data_lines., position, (position + nr_lines) - 1, 'F')   /* "F" is full compact */		
		if rc < 0 then
			do
				rc = array_failure.rex("ERASEGLOBAL")
				return 1
			end		
	end

return rc

Michael S 2012-01-18 20:29