|
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 mailing list archive is Copyright 1997-2025 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.
