Test a packed number for validity - code included

[Buck Calabro <buck.calabro@xxxxxxxxxxxxxxxxx>]

After the recent messages regarding TESTN, I came across a need to validate
a packed number for validity.  I'm getting essentially packed data
(x'00518C5551212C') from a telephone switch and occasionally the data has an
error.  TESTN won't work on packed data so I had to roll my own.  Included
is the code for that solution.  I'm looking for comments (and donating it to
the archives...)

     h bnddir('QC2LE')
     h/copy qrpglesrc,stdhspec
      * dbgview(*list)

     d validFlag       s               n
     d validF          s             10    inz(x'0000000001234567890F')
     d validC          s             10    inz(x'0000000001234567890C')
     d invalid         s             10    inz(x'0110C00001234567890C')

     d tstPackNum      pr              n   opdesc
     d  inpChar                      64    const options(*varsize)

     d H2C             pr                  extProc('cvthc')
     d                                 *   value
     d                                 *   value
     d                               10I 0 value

     d getStrInf       pr                  ExtProc('CEEGSI')
     d  parmNum                      10I 0 const
     d  dataType                     10I 0
     d  currLen                      10I 0
     d  maxLen                       10I 0

     c                   eval      validFlag = tstPackNum(validF)
     c                   eval      validFlag = tstPackNum(validC)
     c                   eval      validFlag = tstPackNum(invalid)

     c                   eval      *inlr = *on

     p tstPackNum      b
     d tstPackNum      pi              n   opdesc
     d  inpChar                      64    const options(*varsize)

     d validFlag       s               n
     d wrkChar         s                   like(inpChar)
     d outChar         s            128
     d recPtr          s               *   inz
     d srcPtr          s               *   inz
     d size            s             10I 0
     d dataType        s             10I 0
     d currLen         s             10I 0
     d maxLen          s             10I 0
     d i               s             10I 0
     d wrkByte         s              1a

     c* Find out how long the input string is
     c                   callp     getStrInf(1: dataType: currLen: maxLen)

     c                   eval      validFlag = *on
     c                   eval      wrkChar = inpChar

      * expand each nybble into a full byte
     c                   eval      srcPtr = %addr(wrkChar)
     c                   eval      recPtr = %addr(outChar)
     c                   eval      size   = currLen * 2

     c                   callp     H2C(recPtr :
     c                                 srcPtr :
     c                                 size)

     c* validate each (expanded) byte
     c                   for       i = 1 to size
     c                   eval      wrkByte = %subst(outChar: i: 1)
      * each byte needs to be between 0 and 9 inclusive...
      *   except the last byte
     c                   if        i < size
     c                   if        wrkByte < '0' or
     c                             wrkByte > '9'
     c                   eval      validFlag = *off
      *     short circuit - why test more now that we have a failure?
     c                   leave
     c                   endif
      *   which needs to be C, D or F
     c                   else
     c                   if        wrkByte <> 'C' and
     c                             wrkByte <> 'D' and
     c                             wrkByte <> 'F'
     c                   eval      validFlag = *off
     c                   endif
     c                   endif
     c                   endfor

     c                   return    validFlag
     p                 e

Buck Calabro
Aptis; Albany, NY
"Nothing is so firmly believed as
 that which we least know" -- Michel Montaigne
Visit the Midrange archives at http://www.midrange.com
+---
| This is the RPG/400 Mailing List!
| To submit a new message, send your mail to RPG400-L@midrange.com.
| To subscribe to this list send email to RPG400-L-SUB@midrange.com.
| To unsubscribe from this list send email to RPG400-L-UNSUB@midrange.com.
| Questions should be directed to the list owner/operator: david@midrange.com
+---