× The internal search function is temporarily non-functional. The current search engine is no longer viable and we are researching alternatives.
As a stop gap measure, we are using Google's custom search engine service.
If you know of an easy to use, open source, search engine ... please contact support@midrange.com.



Here is something to look at while Bob is bailing:

     FSOCLL001  IF   E           K DISK    RENAME(SCL000:SCL001)

     F* Classes

     F* SOCLP000 by CLCLS


D**********************************************************************************************
     D CmdInf          DS

     D   Cmd                         10A

     D   CmdKwd                      10A

     D   ChcTyp                       1A

     D RtnChcTxt       DS

     D   ClsCnt                       5U 0

     D   ClsChc                    1998A

     D ClsLenAlp       DS

     D   ClsLen                       5U 0


C**********************************************************************************************
     C     *ENTRY        PLIST

     C                   PARM                    CmdInf
        Command info
     C                   PARM                    RtnChcTxt
        Choice field
     C*

     C* Process each command separately

     C*

     C                   SELECT

     C                   WHEN      Cmd = 'CRTOBJ' Or

     C                             Cmd = 'UPDOBJCAT'

     C                   EXSR      SubCRTOBJ

     C                   WHEN      Cmd = 'WRKOBJCAT'

     C                   EXSR      SubWRKOBJCAT

     C                   WHEN      Cmd = 'RLDOBJCAT'

     C                   EXSR      SubRLDOBJCAT

     C                   ENDSL
        Cmd
     C*

     C                   MOVE      *ON           *INLR

     C                   RETURN


C**********************************************************************************************
     C* CRTOBJ command


C**********************************************************************************************
     C     SubCRTOBJ     BEGSR

     C*

     C* Choice text

     C*

     C                   IF        ChcTyp = 'C'

     C                   EVAL      RtnChcTxt = *BLANKS

     C                   READ      SOCLL001
  01
     C                   DOW       *IN01 = *OFF

     C                   IF        %LEN(%TRIM(RtnChcTxt) + ', ' +
CLCLS) > 27
     C                   EVAL      RtnChcTxt = %TRIMR(RtnChcTxt) +
'...'
     C                   LEAVE

     C                   ENDIF

     C                   IF        CLSOT = 'Y'

     C                   IF        RtnChcTxt <> *BLANKS

     C                   EVAL      RtnChcTxt = %TRIMR(RtnChcTxt) + ', '
+ CLCLS
     C                   ELSE

     C                   EVAL      RtnChcTxt = CLCLS

     C                   ENDIF
        ChcTxt<>*BLANKS
     C                   ENDIF
        CLSOT='Y'
     C                   READ      SOCLL001
  01
     C                   ENDDO

     C*

     C* Choices list

     C*

     C                   ELSE

     C                   EVAL      ClsCnt = 0

     C                   EVAL      ClsChc = *BLANKS

     C                   READ      SOCLL001
  01
     C                   DOW       *IN01 = *OFF

     C                   IF        CLSOT = 'Y'

     C                   EVAL      ClsCnt = ClsCnt + 1

     C                   EVAL      ClsLen = %LEN(%TRIMR(CLCLS))

     C                   EVAL      ClsChc = %TRIMR(ClsChc) + ClsLenAlp
+ CLCLS
     C                   ENDIF
        CLSOT='Y'
     C                   READ      SOCLL001
  01
     C                   ENDDO

     C                   ENDIF
        ChcTyp='C'
     C*

     C                   ENDSR


C**********************************************************************************************
     C* WRKOBJCAT command


C**********************************************************************************************
     C     SubWRKOBJCAT  BEGSR

     C*

     C* Choice text

     C*

     C                   IF        ChcTyp = 'C'

     C                   EVAL      RtnChcTxt = '*ALL, *PROMPT'

     C                   READ      SOCLL001
  01
     C                   DOW       *IN01 = *OFF

     C                   IF        %LEN(%TRIM(RtnChcTxt) + ', ' +
CLCLS) > 27
     C                   EVAL      RtnChcTxt = %TRIMR(RtnChcTxt) +
'...'
     C                   LEAVE

     C                   ENDIF

     C                   IF        RtnChcTxt <> *BLANKS

     C                   EVAL      RtnChcTxt = %TRIMR(RtnChcTxt) + ', '
+ CLCLS
     C                   ELSE

     C                   EVAL      RtnChcTxt = CLCLS

     C                   ENDIF
        ChcTxt<>*BLANKS
     C                   READ      SOCLL001
  01
     C                   ENDDO


C**********************************************************************************************
     C* WRKOBJCAT command


C**********************************************************************************************
     C     SubWRKOBJCAT  BEGSR

     C*

     C* Choice text

     C*

     C                   IF        ChcTyp = 'C'

     C                   EVAL      RtnChcTxt = '*ALL, *PROMPT'

     C                   READ      SOCLL001
  01
     C                   DOW       *IN01 = *OFF

     C                   IF        %LEN(%TRIM(RtnChcTxt) + ', ' +
CLCLS) > 27
     C                   EVAL      RtnChcTxt = %TRIMR(RtnChcTxt) +
'...'
     C                   LEAVE

     C                   ENDIF

     C                   IF        RtnChcTxt <> *BLANKS

     C                   EVAL      RtnChcTxt = %TRIMR(RtnChcTxt) + ', '
+ CLCLS
     C                   ELSE

     C                   EVAL      RtnChcTxt = CLCLS

     C                   ENDIF
        ChcTxt<>*BLANKS
     C                   READ      SOCLL001
  01
     C                   ENDDO


C**********************************************************************************************

     C* RLDOBJCAT command


C**********************************************************************************************

     C     SubRLDOBJCAT  BEGSR

     C*

     C* Choice text

     C*

     C                   IF        ChcTyp = 'C'

     C                   EVAL      RtnChcTxt = '*ALL'

     C                   READ      SOCLL001
  01
     C                   DOW       *IN01 = *OFF

     C                   IF        %LEN(%TRIM(RtnChcTxt) + ', ' +
CLCLS) > 27
     C                   EVAL      RtnChcTxt = %TRIMR(RtnChcTxt) +
'...'
     C                   LEAVE

     C                   ENDIF

     C                   IF        CLSOT = 'Y'

     C                   IF        RtnChcTxt <> *BLANKS

     C                   EVAL      RtnChcTxt = %TRIMR(RtnChcTxt) + ', '
+ CLCLS
     C                   ELSE

     C                   EVAL      RtnChcTxt = CLCLS

     C                   ENDIF
        ChcTxt<>*BLANKS
     C                   ENDIF
        CLSOT='Y'
     C                   READ      SOCLL001
  01
     C                   ENDDO

     C*

     C* Choices list

     C*

     C                   ELSE

     C                   EVAL      ClsCnt = 0

     C                   EVAL      ClsChc = *BLANKS

     C                   EVAL      ClsLen = 4

     C                   EVAL      ClsChc = %TRIMR(ClsChc) + ClsLenAlp
+ '*ALL'
     C                   EVAL      ClsCnt = ClsCnt + 1

     C                   READ      SOCLL001
  01
     C                   DOW       *IN01 = *OFF

     C                   IF        CLSOT = 'Y'

     C                   EVAL      ClsCnt = ClsCnt + 1

     C                   EVAL      ClsLen = %LEN(%TRIMR(CLCLS))

     C                   EVAL      ClsChc = %TRIMR(ClsChc) + ClsLenAlp
+ CLCLS
     C                   ENDIF
        CLSOT='Y'
     C                   READ      SOCLL001
  01
     C                   ENDDO

     C                   ENDIF
        ChcTyp='C'
     C*

     C                   ENDSR

I could also supply a CL choice program if you would like (it is
simpler). If you
need to create more than one of these, I would pull the data retrieval
from the
list building.

David Morris

>>> oludare@ix.netcom.com 07/19/02 10:04AM >>>
Bob I will hang around for your findings, meanwhile I look at getting
that
book.


As an Amazon Associate we earn from qualifying purchases.

This thread ...

Follow-Ups:

Follow On AppleNews
Return to Archive home page | Return to MIDRANGE.COM home page

This mailing list archive is Copyright 1997-2024 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].

Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.