Code challenge! :-)

[wahlers]

PROGRAM CHALLENGE:

Can somebody shorten the following algorithm?
(source program included)

Note: with the emphasis on 'shorten' or 'shorter' or 'less complex'.
I already know you can do this in 10,000 different ways.
I just want a smarter algorithm (in COBOL-85 of course!).

Restriction:
Only COBOL-85 allowed.
No tricky vendor supplied extensions allowed.

Following is the source code:
(algorithm is explained within this source code)

###############################################

IDENTIFICATION DIVISION.
PROGRAM-ID. getProductCode.
*/**
* ---> Interface contract:
*
* getProductCode will return a valid product code
* when and only when a valid product string is
* passed to this routine.
* Also, the validityIndicator is set to 'codeValid'
* when and only when a valid product code is returned.
* (n.b. a valid returned product code is padded with
* leading zeros).
*
* In all other events the validityIndicator is set to
* 'codeInvalid' and the contents of the returned product
* code field is undetermined.
*
* ---> Call structure:
*
* CALL getProductCode USING
* , passProductString X(50) INPUT (free format)
* , returnProductCode 9(18) OUTPUT
* , validityIndicator X(01) OUTPUT (valid = '0')
* END-CALL
*
* ---> valid product codes are (by example):
*
* '1-23-4505-4-321' <--- any number separated
* ' 123-450543-21 ' by 1 or more single(!)
* '12345-0-54321 ' hyphens,
* ' 12345-0-54321' with or without leading
* or trailing spaces. Or:
* ' 12345054321 ' <--- numeric digits only
* '12345054321 ' with or without leading
* ' 12345054321' or trailing spaces
*
* N.B. leading zeros are allowed but leading spaces
* are not allowed after leading zeros (by example):
*
* ' 00012345054321' <--- valid!
* '0012345-0-54321' <--- valid!
* '1 ' <--- valid! single digit number!
* ' 2 ' <--- valid! single digit number!
* ' 3' <--- valid! single digit number!
* ' 004 ' <--- valid! single digit number (=4)!
*
* ---> invalid product codes are (by example):
*
* '00 12345054321' <--- invalid! Spaces after leading zeros!
* ' 12345—-054321 ' <--- invalid! Consecutive hyphens!
* ' 12345054321- ' <--- invalid! Trailing hyphen!
* ' –12345054321 ' <--- invalid! Leading hyphen!
* ' 12345X54321 ' <--- invalid! Invalid character!
*
* N.B. all production codes are greater than zero
* therefore: productCode = ZERO is invalid!
*
**/

DATA DIVISION.
WORKING-STORAGE SECTION.
01 workFields.
05 firstPosition PIC 9(03) BINARY.
05 lastPosition PIC 9(03) BINARY.
05 sourcePosition PIC 9(03) BINARY.
05 targetPosition PIC 9(03) BINARY.

LINKAGE SECTION.

*// IN: User supplied product string
01 passProductString.
05 productString PIC X(50).

*// OUT: product code number
01 returnProductCode.
05 productCode PIC 9(18).

*// OUT: validityIndicator
01 validityIndicator PIC X(01).
88 codeValid VALUE 0.
88 codeInvalid VALUE 1.

PROCEDURE DIVISION USING passProductString
returnProductCode
validityIndicator
.
PERFORM getProductCode
GOBACK
.

getProductCode.
*-----------------------------------------------------
*
* Extract the product code as numeric value
* with mandatory test on validity!
*
*-----------------------------------------------------

*// Position at first non space position
*// (could be done with inspect statement but loop used here!)
PERFORM WITH TEST BEFORE
, VARYING firstPosition
, FROM 1
, BY 1
, UNTIL (NOT productString(firstPosition:1) IS SPACE)
, OR firstPosition = LENGTH OF productString
END-PERFORM

*// Position at first non leading zero position
PERFORM WITH TEST BEFORE
, VARYING firstPosition
, FROM firstPosition
, BY 1
, UNTIL (NOT productString(firstPosition:1) IS ZERO)
, OR firstPosition = LENGTH OF productString
END-PERFORM

*// Determine the last valid productString position.
*// only trailing spaces are allowed!
PERFORM WITH TEST BEFORE
, VARYING lastPosition
, FROM LENGTH OF productString
, BY -1
, UNTIL (NOT productString(lastPosition:1) IS SPACE)
, OR lastPosition = 1
END-PERFORM

IF productString(firstPosition:1) IS NUMERIC AND
, productString(lastPosition :1) IS NUMERIC AND
, productString(firstPosition:1) > ZERO
,
*// initially assume the code to be extracted is valid
*// and initialise target field (=productCode) and
*// position the pointer at the end of the target field
, SET codeValid TO TRUE
, MOVE LENGTH OF productCode TO targetPosition
, MOVE ZEROS TO productCode
,
ELSE
*// Invalid product code because product code must
*// at least begin with a digit greater zero (1 thru 9)
*// and at least end with a digit (0 thru 9).
, SET codeInvalid TO TRUE
,
END-IF

PERFORM WITH TEST BEFORE
, VARYING sourcePosition
, FROM lastPosition
, BY -1
, UNTIL sourcePosition < firstPosition
, OR codeInvalid
,
, EVALUATE TRUE
, ,
*// copy the digit when the source character is a digit
, , WHEN productString(sourcePosition:1) IS NUMERIC
, , IF targetPosition > ZERO
, , , MOVE productString(sourcePosition:1)
, , , TO productCode (targetPosition:1)
, , , SUBTRACT 1 FROM targetPosition
, , ELSE
*// numeric code in source (productString) exceeds
*// maximum value possible in target (productCode)
*// result: not all digits copied, therefore invalid!
*// (Option: code invalid or define a larger target field)
, , , SET codeInvalid TO TRUE
, , END-IF
, ,
*// ignore hyphen between two digits.
, , WHEN productString(sourcePosition :1) IS '-'
, , AND productString(sourcePosition - 1:1) IS NUMERIC
, , AND productString(sourcePosition + 1:1) IS NUMERIC
, , CONTINUE
, ,
*// Invalid character in input, therefore:
*// the whole product code is invalid!
, , WHEN OTHER
, , SET codeInvalid TO TRUE
, ,
, END-EVALUATE
END-PERFORM
.

END PROGRAM. getProductCode.

 

[wahlers]

To: k5tm
Went through it. Very creative!

About complexity:

Hard to judge...
It depends on the readers knowledge of all possibilities of the inspect statement.

I very rarely use them myself and I have never used them like you did (n.b. creating some kind of template field with all '-' and test for that).
Though I do use the redefinition quite a lot (between numeric and alphanumeric fields) I don't think I ever used in the way you did in this program (see: PIC z(18)b(32)).

All considering...I think you need less mental jumps in the original program.

But I have the feeling that you coded this more as a challenge to avoid the loop all together than with the complexity factor in your mind. In that you succeeded perfectly!
I never considered this solution myself, well done!

Regards, Wim.

 

[wahlers]

Based on comments given I slightly modified the original source program as follows:

 IDENTIFICATION DIVISION.
 PROGRAM-ID. getProductCode.
*/**
* ---> Interface contract:
*
* The getProductCode routine copies the productCode
* from the passProductString input field and returns
* it into the returnProductCode output field.
* In the process it is strips the productCode from
* hyphens.
*
* Also, the validityIndicator is set to 'codeValid'
* when and only when a valid product code is
*  returned.
* (n.b. a valid returned productCode is padded with
* leading zeros).
*
* In all other events the validityIndicator is set
* to 'codeInvalid' and the contents of the returned
* product code field is undetermined.
*
* ---> Call structure:
*
* CALL getProductCode USING
* , passProductString X(50) INPUT
* ,                   (unedited productCode)
* , returnProductCode 9(18) OUTPUT
* ,                   (edited productCode)
* , validityIndicator X(01) OUTPUT
* ,                   (valid   = '0') or,
* ,                   (invalid = '1')
* END-CALL
*
* The passProductString field contains
* a productCode.
* A productCode is valid only when:
*
* 1. It must start with a digit.
* 2. It must end with a digit.
* 3. Consecutive digits may be separated
*    by one hyphen and one hyphen only.
* 4. A hyphen character is not allowed when
*    all preceding digits are zeros only.
* 5. A productCode may have one or more leading
*    zeros.
* 6. A productCode only contains hyphens and digits,
*    space or other characters are not allowed.
* 7. productCode zero does not exists and is not
*    allowed.
*
* The productCode may start on any position within
* the productString field.
*
* Some examples of valid product codes are:
*
* in: ' 1-234-56-7 ' -> out: '00000000001234567'
* in: ' 00001234-5 ' -> out: '00000000000012345'
* in: '     008    ' -> out: '00000000000000008'
* in: '     800    ' -> out: '00000000000000800'
*
* Some examples of invalid productCodes are:
*
* 00000000000 <- productCode zero
* -1-234-45-7 <- leading hyphen
* 1-234-45-7- <- trailing hyphen
* 1-234--45-7 <- contiguous hyphens
* 00-00124345 <- hyphen within leading zeros
* 1-234 45-78 <- illegal including space
* 1-234@45-78 <- other illegal character
*
**/

 DATA DIVISION.
 WORKING-STORAGE SECTION.
 01  workFields.
   05  firstPosition     PIC  9(03) BINARY.
   05  lastPosition      PIC  9(03) BINARY.
   05  sourcePosition    PIC  9(03) BINARY.
   05  targetPosition    PIC  9(03) BINARY.
 
 LINKAGE SECTION.

*// IN: User supplied product string
 01  passProductString.
   05  productString     PIC  X(50).

*// OUT: product code number
 01  returnProductCode.
   05  productCode       PIC  9(18).

*// OUT: validityIndicator
 01  validityIndicator   PIC  X(01).
     88  codeValid       VALUE  '0'.
     88  codeInvalid     VALUE  '1'.

 PROCEDURE DIVISION USING  passProductString
                           returnProductCode
                           validityIndicator
                           .
 topProcedureDivision.

     PERFORM  getProductCode
     GOBACK
     .

  getProductCode.
*---------------------------------------------
*
* Extract the product code as numeric value
* with mandatory test on validity!
*
*---------------------------------------------

*// Position at first non space position 
*// (could be done with inspect statement
*// but loop used here!)
     PERFORM  WITH TEST BEFORE
     , VARYING  firstPosition
     ,    FROM  1
     ,      BY  1
     ,   UNTIL (NOT productString(firstPosition:1) =
     ,          SPACE)
     ,      OR  firstPosition =
     ,          LENGTH OF  productString
     , CONTINUE
     END-PERFORM

*// Position at first non leading zero position 
     PERFORM  WITH TEST BEFORE
     , VARYING  firstPosition
     ,    FROM  firstPosition
     ,      BY  1
     ,   UNTIL (NOT productString(firstPosition:1) =
     ,          ZERO)
     ,      OR  firstPosition  =
     ,          LENGTH OF  productString
     , CONTINUE
     END-PERFORM

*// Determine the last valid productString position.
*// only consecutive trailing spaces are allowed!
     PERFORM  WITH TEST BEFORE
     , VARYING  lastPosition
     ,    FROM  LENGTH OF  productString
     ,      BY  -1
     ,   UNTIL (NOT productString(lastPosition:1) =
                SPACE)
     ,      OR  lastPosition  =  1
     , CONTINUE
     END-PERFORM

     IF  productString(firstPosition:1) IS NUMERIC
     ,   AND
     ,   productString(lastPosition :1) IS NUMERIC
     ,   AND
     ,   productString(firstPosition:1) >  ZERO
     ,
*// initially assume the code to be extracted is
*// valid and initialise target field (=productCode)
*// and position the pointer at the end of the
*// target field
     , SET  codeValid  TO  TRUE
     , MOVE  LENGTH OF  productCode
     ,   TO  targetPosition
     , MOVE  ZEROS  TO  productCode
     ,
     ELSE
*// product code because product code must at least
*// begin with a digit greater zero (1 thru 9) and
*// at least end with a digit (0 thru 9).
     , SET  codeInvalid  TO  TRUE
     ,
     END-IF

      PERFORM  WITH TEST BEFORE
     , VARYING  sourcePosition
     ,    FROM  lastPosition
     ,      BY  -1
     ,   UNTIL  sourcePosition  <  firstPosition
     ,      OR  codeInvalid
     ,
     ,   EVALUATE  TRUE
     ,   ,
*// copy the digit when the source character is
*// a digit
     ,   , WHEN productString(sourcePosition:1) IS
     ,   ,      NUMERIC
     ,   ,   IF  targetPosition  >  ZERO 
     ,   ,   , MOVE  productString(sourcePosition:1)
     ,   ,   ,   TO  productCode  (targetPosition:1)
     ,   ,   , SUBTRACT  1  FROM   targetPosition
     ,   ,   ELSE
*// numeric code in source (productString) exceeds
*// maximum value possible in target (productCode)
*// result: not all digits copied, code invalid!
*// (Alternate option: define a larger target field)
     ,   ,   , SET  codeInvalid  TO  TRUE
     ,   ,   END-IF
     ,   ,
*// ignore '-' but(!) only when
*// the next adjecent character is a digit.
     ,   , WHEN productString
     ,   ,      (sourcePosition    :1) =  '-'
     ,   , AND  productString
     ,   ,      (sourcePosition - 1:1) IS NUMERIC
     ,   ,   CONTINUE
     ,   ,
*// Invalid character in input, therefore:
*// the whole product code is invalid!
     ,   , WHEN  OTHER
     ,   ,   SET  codeInvalid  TO  TRUE
     ,   ,
     ,   END-EVALUATE
     END-PERFORM
     .

     END PROGRAM  getProductCode.

 

[webrabbit]

Question: is 00-0123 a valid product code?

 

[wahlers]

To: webrabbit
No! 00-0123 is NOT a valid product code.

 

[k5tm]

This thing keeps pulling me back...

New rules (feature creep?) cause program mods:

       IDENTIFICATION DIVISION.
       PROGRAM-ID. getProductCodeNew.

       Environment division.
       Configuration section.
       special-names.
           CLASS nonzero-digit is 50 through 58.
      
       DATA DIVISION.
       WORKING-STORAGE SECTION.

       01  working-string      pic X(50).
       01  working-num         redefines working-string
                               pic z(18)b(32).
       01  c-string            pic X(50).

       01  usage binary.
           02  i                   pic s9(3).
           02  string-length       pic s9(3).
           02  initial-nonspace    pic s9(3).
           02  r                   pic s9(3).
    
       
       LINKAGE SECTION.
      
      *// IN: User supplied product string
       01  passProductString.
         05  productString     PIC  X(50).
      
      *// OUT: product code number
       01  returnProductCode.
         05  productCode       PIC  9(18).
      
      *// OUT: validityIndicator
       01  validityIndicator   PIC  9(01).
           88  codeValid       VALUE    0.
           88  codeInvalid     VALUE    1.
      
       PROCEDURE DIVISION USING  passProductString
                                 returnProductCode
                                 validityIndicator
                                 .
       the-main section.
       a.
           PERFORM  getProductCode
           GOBACK
           .
      
       getProductCode section.
       a.
           set codeInvalid to true.

           move productString to working-string, c-string.
           move 0 to i, string-length, r.
           move 1 to initial-nonspace.
           inspect working-string tallying i for all "--".
           if i > 0 go exit-section.
      *    the string contains no contiguous hyphens
           inspect working-string tallying initial-nonspace 
                                       for leading spaces.
           if initial-nonspace > 50 go exit-section end-if.
      *    the string is not all spaces
           inspect working-string (initial-nonspace:)
                                  tallying initial-nonspace 
                                       for leading "0".
           if initial-nonspace > 50 
           or working-string (initial-nonspace: 1) not nonzero-digit
               go exit-section
           end-if.
      *    the leftmost nonspace, non-leading-zero character is 
      *        a nonzero digit
           inspect c-string (initial-nonspace:)
                            converting "0123456789-" to all "-"
                            before initial space.
           inspect c-string (initial-nonspace:)
                            tallying string-length for leading "-".
           add string-length to initial-nonspace giving r.
           if r < 51
               if c-string (r:) not = spaces
                   go exit-section
               end-if
           end-if.
      *    the string contains no embedded spaces or invalid chars
           subtract 1 from r.
           if working-string (r: 1) not numeric
               go exit-section
           end-if.
      *    the rightmost nonspace character is numeric
           if c-string (initial-nonspace: string-length) not = all "-" 
               go exit-section
           end-if.         
      *    the string contains only hyphens and numeric digits

           inspect working-string converting "-" to space.
           move working-num to productCode.

           if productCode not = 0   set codeValid to true.
           
       exit-section.
           exit.

Here is the results: input, validIndicator and productCode returned by Wim original program, validIndicator and productCode returned by program in this post:

1-23-4505-4-321 0 000000012345054321 0 000000012345054321
 123-450543-21  0 000000012345054321 0 000000012345054321
12345-0-54321   0 000000012345054321 0 000000012345054321
  12345-0-54321 0 000000012345054321 0 000000012345054321
  12345054321   0 000000012345054321 0 000000012345054321
12345054321     0 000000012345054321 0 000000012345054321
    12345054321 0 000000012345054321 0 000000012345054321
 00012345054321 0 000000012345054321 0 000000012345054321
0012345-0-54321 0 000000012345054321 0 000000012345054321
1               0 000000000000000001 0 000000000000000001
    2           0 000000000000000002 0 000000000000000002
              3 0 000000000000000003 0 000000000000000003
    004         0 000000000000000004 0 000000000000000004
00  12345054321 1   <invalid>        1   <invalid>
 12345ù-054321  1   <invalid>        1   <invalid>
 12345054321-   1   <invalid>        1   <invalid>
 û12345054321   1   <invalid>        1   <invalid>
 1-234@45-78    1   <invalid>        1   <invalid>
 1-234 45-78    1   <invalid>        1   <invalid>
 00-00124345    1   <invalid>        1   <invalid>

Tom Morrison

http://www.liant.com

 

[wahlers]

To: k5tm

Your remark:
New rules (feature creep?) cause program mods:

Answer:
No! No features were added.
The logic is still the same.
There were questions about the comments that were not complete.
It is this that I have changed!

Also, I did say it had to be COBOL-85 compliant.
The original code wasn't completely according to the rules.
So, it was that that I changed too!
Except for the 'LENGTH OF' instruction, which turns out to be not COBOL-85 compliant, I left that in!

Regards, Wim.

 

[k5tm]

Wim,

I understand that only comments were changed. It is just that I worked from the comments (which I used as test data for my implementation} and, while I was coding my implementation, treated your code as a 'black box' without inspection of its internal makeup. In other words, I was working from a specification, not reverse engineering.

But, as you observed earlier, my inspiration was indeed from the challenge of coding straight-through code without loops, in the hope that, with your production data, you might test the run time of both approaches, in order to resolve the issue of 'efficiency' which was the original challenge you presented.

Finally, I honestly missed the last requirement in your original comments: a zero product code is invalid.

Tom Morrison

http://www.liant.com

 

[wahlers]

To: k5tm

It is not your mistake because there was no official specification. So, what you did was correct. I know it is a bit irritating when it turns out to be something slightly different. I apologise for that.

Something else...I don't want to flame again an old discussion, but maybe you can look what I was thinking of seeing the code of doods (see my comments on the link):

http://mvshelp.com/cgi-bin/ubb6/ultimatebb.cgi?ubb=get_topic;f=1;t=003239

btw...it was nice weather here today...I hope you didn't spent all of your time behind a computer screen

 

[wahlers]

To: Jefke

His code can be viewed on thread:

http://mvshelp.com/cgi-bin/ubb6/ultimatebb.cgi?ubb=get_topic;f=1;t=003239

Your code:
* THIS BYTE MUST BE A NUMBER, SO MOVE IT UNCONDITIONALLY TO OUTPUT

My comment:
As far as I can judge your code this is not correct, because character may be A through Z (which are all illegal characters), and your code does not test on such conditions.

Your code:
* IF HYPHEN ENCOUNTERED, TEST FOR TRAILING ZEROES


My comment:
As far as I can judge your code this is not correct, because there may be multiple hyphens within one production code. See the following examples:
[1] ' 000-001-123-789 ' <- illegal production code
[2] ' 001-000-123-789 ' <- legal production code
[3] ' 001-001-123-789 ' <- legal production code
[4] ' 1-001-123-789 ' <- legal production code
Only the first [1] is illegal because production codes are not allowed to start with initial zeros.
The second example [2] has a group of included zeros. This is ok (that is: this possibility is not excluded by the original program logic and description).
The third [3] has no group of zeros but does have leading zeros for the first group.
The fourth [4] example is exactly the same as [3] with the only difference that [4] does not have leading zeros.

Conclusion:
In the original program the comments at the top of the source code were correct but not complete. However, as far as I can judge, your code is not even compliant with this original description.
My apologies if the comments were not clear enough. I have re-written the comments in the hope that they are complete and more clear now (see re-written code within one of my previous replies on this thread).

Regards, Wim Ahlers.

 

[wahlers]

To jefke:

Sorry I made a mistake!
I failed to notice that at the end of your code you do a numeric test of the result field.
This will cover all the other characters other then digits.

However, the test on zeros only before the first hyphen still looks incorrect.

minor detail:
I assume it was your intention to copy the original linkage input field passProductString to PRODUCT-ID-IN. I did not see this happen.

Wim.

 

[wahlers]

To: k5tm

Concerning your code jun 12, 2004 some additional remarks:

I have 2 concerns:

[1] I am a little concerned if the move from a numeric edited field z(18)b(32) to a numeric field 9(18) is allowed by the official COBOL-85 standards.
(n.b. I don't have the official COBOL-85 specification)

[2] I think the contents of the receiving field will be wrong (with no warning, just truncation!) when the production code in the sending field (50) exceeds the capacity of the receiving field (18).
(How is this handled on your platform?)


Regards, Wim.

p.s. you may use the 2002 standards. I am not familiar at all with the 2002 standards.

 

[k5tm]

Wim,

[ol][li]Responding to:

I am a little concerned if the move from a numeric edited field ... to a numeric field ... is allowed by the official COBOL-85 standards.

It is right there in Chapter VI, Section 6.19.4 (4) b. (MOVE statement general rules)

When the sending operand is numeric edited, de-editing is implied to establish the operand's unedited numeric value, which may be signed; then the unedited numeric value is moved to the receiving field.

[/li]
[li]While my code does not presently test for this condition, it is easily accomplished, and is left as an exercise for those interested. Hint: near the end of the implementation if string length > 18, then additional testing can be accomplished to assure that the overflow does not occur.[/li][/ol]

I am not using 2002 standards.



Tom Morrison

http://www.liant.com

 

[wahlers]

To: All.


I will not continue with this thread.
The code following is a deriviate of the original and my final result.
I believe that this final result is:

[A] understandable/clear,
robust, and,
[C] efficient.

It is logically optimized.

Logically optimized means that the number of conditions and the number of moves performed and total number of instructions executed are less then the original.
The compiler may (or may not) perform an additional physical optimization.

If and how the compiler optimizes this code can be important but is outside the scope of the original request.

Some remarks concerning the final code:

For some loops the inspect statement would have been an alternative.
Since I could not use inspect as an alternative for all the loops I decided not to use inspect at all.

Some alternatives provided by posted replies use an unconditional move to the target field and, at the end, perform a numeric test (IS NUMERIC).
I decided not to use this technique because of reasons mentioned earlier (e.g. to refresh: the field size may grow beyond the capacity of the standard numeric fields. This is not a problem in my code but is a problem in solutions that explicitly rely on the numeric definition).

The statement:

     IF  targetPosition  >  ZERO
     , MOVE  ZEROS
     ,   TO  productCode(1:targetPosition)
     END-IF

could have been just:

     MOVE  ZEROS
       TO  productCode(1:targetPosition)

But the condition 'IF targetPosition > ZERO' is included in the code because the value productCode(1:0) is logically undefined.

The following code is the end result:

 IDENTIFICATION DIVISION.
 PROGRAM-ID. getProductCode.
*/**
* ---> Interface contract:
*
* The getProductCode routine copies the productCode
* from the passProductString input field and returns
* it into the returnProductCode output field.
* In the process it is strips the productCode from
* hyphens.
*
* Also, the validityIndicator is set to 'codeValid'
* when and only when a valid product code is
* returned.
* (n.b. a valid returned productCode is padded with
* leading zeros).
*
* In all other events the validityIndicator is set
* to 'codeInvalid' and the contents of the returned
* product code field is undetermined.
*
* ---> Call structure:
*
* CALL  getProductCode  USING
* , passProductString X(50) INPUT
*                           (unedited productCode)
* , returnProductCode 9(18) OUTPUT
*                           (edited productCode)
* , validityIndicator X(01) OUTPUT
*                           (valid   = '0') or,
* ,                         (invalid = '1')
* END-CALL
*
* The passProductString field contains a
* productCode.
* A productCode is valid only when:
*
* 1. It must start with a digit.
* 2. It must end with a digit.
* 3. Consecutive digits may be separated
*    by one hyphen and one hyphen only.
* 4. A hyphen character is not allowed when
*    all preceding digits are zeros only.
* 5. A productCode may have one or more leading
*    zeros.
* 6. A productCode only contains hyphens and digits,
*    space or other characters are not allowed.
* 7. productCode zero does not exists and is not
*    allowed.
* 8. The productCode may start on any position
*    within the productString field.
*
* Some examples of valid product codes are:
*
* in: ' 1-234-56-7 ' -> out: '00000000001234567'
* in: ' 00001234-5 ' -> out: '00000000000012345'
* in: '     008    ' -> out: '00000000000000008'
* in: '     800    ' -> out: '00000000000000800'
* in: ' 1-000-00-0 ' -> out: '00000000001000000'
*
* Some examples of invalid productCodes are:
*
* 00000000000 <- productCode zero
* -1-234-45-7 <- leading hyphen
* 1-234-45-7- <- trailing hyphen
* 1-234--45-7 <- contiguous hyphens
* 00-00124345 <- hyphen within leading zeros
* 1-234 45-78 <- illegal including space
* 1-234@45-78 <- other illegal character
*
**/

DATA DIVISION.
 WORKING-STORAGE SECTION.
 01  workFields.
   05  firstPosition      PIC  9(04) BINARY.
   05  lastPosition       PIC  9(04) BINARY.
   05  sourcePosition     PIC  9(04) BINARY.
   05  targetPosition     PIC  9(04) BINARY.
 
 LINKAGE SECTION.

*// IN: User supplied product string
 01  passProductString.
   05  productString      PIC  X(50).

*// OUT: product code number
 01  returnProductCode.
   05  productCode        PIC  9(18).

*// OUT: validityIndicator
 01  validityIndicator    PIC  X(01).
     88  codeValid        VALUE  '0'.
     88  codeInvalid      VALUE  '1'.
 
PROCEDURE DIVISION USING  passProductString
                          returnProductCode
                          validityIndicator
                          .
 begin.
*// Get last relevant character position
*// (only trailing spaces allowed)
     PERFORM  WITH TEST BEFORE
     , VARYING  lastPosition
     ,    FROM  LENGTH OF  productString
     ,      BY  -1
     ,   UNTIL (NOT productString(lastPosition:1)
     ,         =  SPACE)
     ,      OR  lastPosition  =  1
     , CONTINUE
     END-PERFORM

     IF  productString(lastPosition:1) IS NUMERIC
     ,
     , SET  codeValid  TO  TRUE
*// get first non space position 
     , PERFORM  WITH TEST BEFORE
     , , VARYING  firstPosition
     , ,    FROM  1
     , ,      BY  1
     , ,   UNTIL (NOT productString(firstPosition:1)
     , ,         =  SPACE)
     , , CONTINUE
     , END-PERFORM
     ,
*// get first non leading zero position
*// (after leading spaces)
     , PERFORM  WITH TEST BEFORE
     , , VARYING  firstPosition
     , ,    FROM  firstPosition
     , ,      BY  1
     , ,   UNTIL (NOT productString(firstPosition:1)
     , ,         = ZERO)
     , ,      OR  firstPosition  =  lastPosition
     , , CONTINUE
     , END-PERFORM
     ,
*// First valid digit must be numeric > zero
     , IF  productString(firstPosition:1) >= '1'
     , ,   AND
     , ,   productString(firstPosition:1) <= '9'
     , ,
     , , PERFORM  getProductCode
     , ,
     , ELSE
     , , SET  codeInvalid  TO  TRUE 
     , END-IF
     ,
     ELSE
     , SET  codeInvalid  TO  TRUE
     END-IF

     GOBACK
     .
 
 getProductCode.
*--------------------------------------------------
* Extract the product code as numeric value
* with mandatory test on validity!
*--------------------------------------------------

*// position the pointer at the end of the target
*// field
     MOVE  LENGTH OF  productCode
       TO  targetPosition

     PERFORM  WITH TEST BEFORE
     , VARYING  sourcePosition
     ,    FROM  lastPosition
     ,      BY  -1
     ,   UNTIL  sourcePosition  <  firstPosition
     ,
     ,   EVALUATE  TRUE
     ,   ,
*// copy the digit when the source character is
*// a digit
     ,   , WHEN productString(sourcePosition:1) IS
     ,   ,      NUMERIC
     ,   ,   IF  targetPosition  >  ZERO 
     ,   ,   , MOVE  productString(sourcePosition:1)
     ,   ,   ,   TO  productCode  (targetPosition:1)
     ,   ,   , SUBTRACT  1  FROM   targetPosition
     ,   ,   ELSE
*// numeric code in source (productString) exceeds
*// maximum value possible in target (productCode)
*// result: not all digits copied, therefore
*// invalid!
*// (Option: code invalid or define a larger target
*// field)
*// The 'MOVE' statement forces an exit out
*// of the loop!
     ,   ,   , SET  codeInvalid  TO  TRUE
     ,   ,   , MOVE  1  TO  sourcePosition
     ,   ,   END-IF
     ,   ,
*// ignore '-' but only when the adjecent character
*// is NOT  '-'
     ,   , WHEN  productString(sourcePosition    :1)
     ,   ,       =  '-'
     ,   ,   IF  productString(sourcePosition - 1:1)
     ,   ,       =  '-'
     ,   ,   , SET  codeInvalid  TO  TRUE
     ,   ,   , MOVE  1  TO  sourcePosition
     ,   ,   END-IF
     ,   ,
*// Invalid character in input, therefore:
     ,   , WHEN  OTHER
     ,   ,   SET  codeInvalid  TO  TRUE
     ,   ,  MOVE  1  TO  sourcePosition
     ,   ,
     ,   END-EVALUATE
     END-PERFORM

*// Finally: pad target field with leading zeros
     IF  targetPosition  >  ZERO
     , MOVE  ZEROS
     ,   TO  productCode(1:targetPosition)
     END-IF
     .

     END PROGRAM  getProductCode.

Regards, Wim Ahlers...signing off.