RPGIV @ Work

A unique site for RPG and System i Lovers

Welcome!

Hi, this site will provide all what you need in System i and RPG developments.

My Name is Chamara Withanachchi, System i Expert and RPG Developer. And in the field for last 11 years.

I hope you will find lot of valuable information from this site

Blog - Content Section Layout
Call Stored Procedures
User Rating: / 0
Written by Chamara   

In the System i Navigator, Go to the databases icons and connect to the correct one (you've one local and probably one or more remotes Only then, you will see the option "run SQL script" at the bottom of your screen. click on it and issue the following


Call chamaraw.MYTEST(' ','00000824','ORDC','DASANW');

Before this make sure you have the correct libraries loaded via Connections -> JDBC Settings in the menu


QCLSCAN
User Rating: / 0
Written by Chamara   
DCL        VAR(&FILETYPE)   TYPE(*CHAR) LEN(4)  /* File Type     */  
DCL        VAR(&FILETYPE1)  TYPE(*CHAR) LEN(3)  /* File Type HZN */  
DCL        VAR(&FILETYPE2)  TYPE(*CHAR) LEN(4)  /* File Type IPDC */ 
DCL        VAR(&STRLEN)     TYPE(*DEC)  LEN(3 0)  /* String Length */
DCL        VAR(&STRPOS)     TYPE(*DEC)  LEN(3 0)  /* Starting Pos */ 
DCL        VAR(&SCNLEN)     TYPE(*DEC)  LEN(3 0)  /* Scan Length  */ 
DCL        VAR(&RSTLEN)     TYPE(*DEC)  LEN(3 0)  /* Reslt Length */ 


CHGVAR     VAR(&FILETYPE2) VALUE('IPDC')                 
CHGVAR     VAR(&STRLEN) VALUE(40)                        
CHGVAR     VAR(&SCNLEN) VALUE(4)                         
CHGVAR     VAR(&STRPOS) VALUE(1)                         
CALL       PGM(QCLSCAN) PARM(&FILETEXT &STRLEN &STRPOS + 
                             &FILETYPE2 &SCNLEN '0' '0' +
                             '0' &RSTLEN)                
IF         COND(&RSTLEN > 0) THEN(DO)                    
   CHGVAR     VAR(&FILETYPE) VALUE(&FILETYPE2)           
ENDDO      
Write Comment (0 comments)
Method to change the field from USR to ATR
User Rating: / 0
Written by Chamara   

1. Edit the model as *DSNR

2. Usage on the field Transaction Type

3. Option 8 against the record with Reason *OBJECT

4. Note the value of Surrogate

5. Exit the model

6. Make sure no one is using the model

7. YDLTOBJTBL

8. YWRKF YFLDDTARFP

9. F7 Select Field sgt EQ value from step 4

10. Option 5 to Update the record

11. Change Group functions Field sgt from value 1- to 0

12. YEDTDTAARA YSNCMDLRFA, change value to N

13. YSNCMDL

14. Edit the model as *DSNR

15. Check that the field Transaction Type shows Field usage ATR and can now be used on files

Rules for System Name Generation
User Rating: / 0
Written by Chamara   

Rules for System Name Generation

There are specific instances when the system generates a system table, view, index, or column name. These instances and the name generation rules are described in the following sections.

Rules for Column Name Generation

A system-column-name is generated if the system-column-name is not specified when a table or view is created and the column-name is not a valid system-column-name.

If the column-name does not contain special characters and is longer than 10 characters, a 10-character system-column-name will be generated as:

  • The first 5 characters of the name
  • A 5 digit unique number

For example:

The system-column-name for LONGCOLUMNNAME would be LONGC00001

If the column name is delimited:

  • The first 5 characters from within the delimiters will be used as the first 5 characters of the system-column-name. If there are fewer than 5 characters within the delimiters, the name will be padded on the right with underscore (_) characters. Lower case characters are folded to upper case characters. The only valid characters in a system-column-name are: A-Z, 0-9, @, #, $, and _. Any other characters will be changed to the underscore (_) character. If the first character ends up as an underscore, it will be changed to the letter Q.
  • A 5 digit unique number is appended to the 5 characters.

For example:

   The system-column-name for "abc" would be ABC__00001
   The system-column-name for "COL2.NAME" would be COL2_00001
   The system-column-name for "C 3" would be C_3__00001
   The system-column-name for "??" would be Q____00001
   The system-column-name for "*column1" would be QCOLU00001

Rules for Table Name Generation

A system name will be generated if a table, view, alias, or index is created with either:

  • A name longer than 10 characters
  • A name that contains characters not valid in a system name

The SQL name or its corresponding system name may both be used in SQL statements to access the file once it is created. However, the SQL name is only recognized by DB2 for i5/OS and the system name must be used in other environments.

There are two separate methods for generating the system name:

  • If a data area with the name QGENOBJNAM exists in the same schema that the table is created into, the user can influence the generated name.

    The data area is subject to the following restrictions:

    • The user must be authorized to read the data area.
    • The data area must have an attribute of CHAR(10).
    • The first 5 characters of the data area value must be '?????'.
    • The next 5 characters of the data area value must contain 5 numeric digits.

    If any of the above conditions are not satisfied or any error occurs while accessing the starting value in the data area, the default name generation rules will be used as if the data area did not exist at all.

    If the data area meets all of the restrictions above, the generated name will be the same as if the default name generation rules below except that after the first 5 (or 4) characters of the name, the unique number will initially contain the 5 digits specified in the data area (instead of '00001' or '0001').

    For example, if the value of the data area was '?????00999':

       The system name for "??" would be "__00999"
       The system name for "longtablename" would be "lon00999"
       The system name for "LONGTableName" would be LONG00999
       The system name for "A b   " would be "A_b00999"
  • Otherwise, the default name generation rules are used:

    If the name does not contain special characters and is longer than 10 characters, a 10-character system name will be generated as:

    • The first 5 characters of the name
    • A 5 digit unique number

    For example:

       The system name for LONGTABLENAME would be LONGT00001

    If the SQL name contains special characters, the system name is generated as:

    • The first 4 characters of the name
    • A 4 digit unique number

    In addition:

    • All special characters are replaced by the underscore (_)
    • Any trailing blanks are removed from the name
    • The name is delimited by double quotes (") if the delimiters are required for the name to be a valid system name.

    For example:

       The system name for "??" would be "__0001"
       The system name for "longtablename" would be "long0001"
       The system name for "LONGTableName" would be LONG0001
       The system name for "A b   " would be "A_b0001"

    SQL ensures the system name is unique by searching the cross reference file. If the name already exists in the cross reference file, the number is incremented until the name is no longer a duplicate.

    If a unique name cannot be determined using the above rules, an additional character is added to the counter in the name, and the number is incremented until a unique name can be found or the range is exhausted. For example, if creating "longtablename" and names "long0001" through "long9999" already exist, the name would become "lon00001".

NOTE

When you need to search the mapping of the Long Table name and Short Table Name you can have a look at SYSTABLES table, in the TABLE_NAME field system will store the Long table name and in the SYSTEM_TABLE_NAME field you can see the Generated table name.

Source Encryption Tool
User Rating: / 0
Written by Chamara   

Following is written by Kanaka Gunatilake ( ) in 1998 using RPG and CL. This particular program will encrypt and decrypt your source codes using BITON and BITOFF. The beauty of this program is you can encrypt the source using a password and you need to have the password to decrypt the source as well. This is a risky tool to use if you cannot remember the password Enjoy, Anyone can make use of this program and include a pattern to BITON and BITOFF as their preference.


ENCRY.CLP

             PGM        PARM(&ENCRPF &ENCRLIB &ENCRMBR &ENCRPWD +
                          &ENCDCR)

             DCLF       FILE(*LIBL/SRCTMP)

             DCL        VAR(&ENCRPF) TYPE(*CHAR) LEN(10) /* Source +
                          file */
             DCL        VAR(&ENCRLIB) TYPE(*CHAR) LEN(10) /* Library */
             DCL        VAR(&ENCRMBR) TYPE(*CHAR) LEN(10) /* Member */
             DCL        VAR(&ENCRPWD) TYPE(*CHAR) LEN(10) /* +
                          Password */
             DCL        VAR(&ENCDCR) TYPE(*CHAR) LEN(1)
             DCL        VAR(&MEMBER) TYPE(*CHAR) LEN(10) /* Member +
                          name on the file */
             DCL        VAR(&WSID) TYPE(*CHAR) LEN(10)
             DCL        VAR(&JOBIDN) TYPE(*CHAR) LEN(6)
             DCL        VAR(&USER) TYPE(*CHAR) LEN(10)
             DCL        VAR(&PASS) TYPE(*CHAR) LEN(1) VALUE('0')
             DCL        VAR(&MSGID) TYPE(*CHAR) LEN(7)
             DCL        VAR(&MSGDTA) TYPE(*CHAR) LEN(100)
             DCL        VAR(&MSGF) TYPE(*CHAR) LEN(10)
             DCL        VAR(&NBR) TYPE(*DEC) LEN(10 0)
             DCL        VAR(&PTY) TYPE(*DEC) LEN(2 0)
             DCL        VAR(&IN99) TYPE(*CHAR) LEN(1) VALUE('0')

             RTVJOBA    JOB(&WSID) USER(&USER) NBR(&JOBIDN) +
                          RUNPTY(&PTY)
             CHGJOB     JOB(&JOBIDN/&USER/&WSID) RUNPTY(50) +
                          LOGCLPGM(*NO) STSMSG(*NONE)
             MONMSG     MSGID(CPF0000 CPF9999)

/* CHECK WHETHER THE LIBRARY IS AVAILABLE FOR OPERATION */

             CHKOBJ     OBJ(&ENCRLIB) OBJTYPE(*LIB)
             MONMSG     MSGID(CPF9801) EXEC(GOTO CMDLBL(TERMINATE))

/* CHECK WHETHER THE SOURCE FILE IS AVAILABLE FOR OPERATION */

             CHKOBJ     OBJ(&ENCRLIB/&ENCRPF) OBJTYPE(*FILE)
             MONMSG     MSGID(CPF9801) EXEC(GOTO CMDLBL(TERMINATE))

/* TO PROCESS ALL MEMBERS IN THE SOURCE PHYSICAL FILE */

             IF         COND(&ENCRMBR *EQ '*ALL') THEN(DO)
             CALL       PGM(PROGR)
             CMPPFM     NEWFILE(&ENCRLIB/&ENCRPF) NEWMBR(*ALL) +
                          OLDFILE(&ENCRLIB/&ENCRPF) CMPTYPE(*FILE) +
                          OUTPUT(*OUTFILE) OUTFILE(QTEMP/SRCTMP) +
                          OPTION(*IGNORECASE)
             MONMSG     MSGID(SPC5010) EXEC(DO)
             SNDPGMMSG  MSG('Source Physical File Is Empty. Process +
                          Terminated . . . . .')
             GOTO       CMDLBL(END)
             ENDDO

/* PREPARATION OF THE TEMPORARY FILE FOR SOURCE CHANGE */

             CHKOBJ     OBJ(QGPL/QRPGLESRC) OBJTYPE(*FILE)
             MONMSG     MSGID(CPF9801) EXEC(DO)
             CRTSRCPF   FILE(QGPL/QRPGLESRC) RCDLEN(112) +
                          TEXT('Temporary Source Physical File')
             MONMSG     MSGID(CPF0000 CPF9999)
             CHGVAR     VAR(&IN99) VALUE('1')
             ENDDO

             ADDPFM     FILE(QGPL/QRPGLESRC) MBR(XX04G891R) +
                          TEXT('Temporary Member')
             MONMSG     MSGID(CPF0000 CPF9999)

             CPYF       FROMFILE(QGPL/QRPGLESRC) TOFILE(QGPL/SOURCE) +
                          FROMMBR(XX04G891R) CRTFILE(*YES)
             MONMSG     MSGID(CPF0000 CPF9999)

 LOOP:       RCVF       RCDFMT(SRCTMP)

             IF         COND(%SST(&SRCTMP 9 2) *EQ '**') THEN(DO)
             CHGVAR     VAR(&MEMBER) VALUE(%SST(&SRCTMP 23 10))
             CPYF       FROMFILE(&ENCRLIB/&ENCRPF) +
                          TOFILE(QGPL/SOURCE) FROMMBR(&MEMBER) +
                          MBROPT(*REPLACE) CRTFILE(*NO) FMTOPT(*NOCHK)
             MONMSG     MSGID(CPF2817) EXEC(DO)
             SNDPGMMSG  MSGID(CPF2817) MSGF(QCPFMSG) MSGTYPE(*NOTIFY)
             IF COND(&ENCDCR *EQ 'E') THEN(DO)
             SNDPGMMSG  MSG('Member' *BCAT &MEMBER *BCAT 'Not +
                          Encrypted')
             CHGVAR     VAR(&PASS) VALUE('0')
             ENDDO
             ELSE       CMD(DO)
             SNDPGMMSG  MSG('Member' *BCAT &MEMBER *BCAT 'Not +
                          Decrypted')
             CHGVAR     VAR(&PASS) VALUE('0')
             ENDDO
             GOTO       CMDLBL(LOOP)
             ENDDO

             RTVMBRD    FILE(SOURCE) NBRCURRCD(&NBR)

             CALL       PGM(ENCRYPT) PARM(&ENCRPWD &ENCDCR &PASS +
                          &NBR &MEMBER)

             IF         COND(&PASS *EQ '0') THEN(DO)
             CPYF       FROMFILE(QGPL/SOURCE) +
                          TOFILE(&ENCRLIB/&ENCRPF) TOMBR(&MEMBER) +
                          MBROPT(*REPLACE) CRTFILE(*NO) FMTOPT(*NOCHK)
             GOTO       CMDLBL(LOOP)
             ENDDO
             ELSE       CMD(IF COND(&ENCDCR *EQ 'E') THEN(DO))
             SNDPGMMSG  MSG('Member' *BCAT &MEMBER *BCAT 'Not +
                          Encrypted')
             CHGVAR     VAR(&PASS) VALUE('0')
             GOTO       CMDLBL(LOOP)
             ENDDO
             ELSE       CMD(DO)
             SNDPGMMSG  MSG('Member' *BCAT &MEMBER *BCAT 'Not +
                          Decrypted')
             CHGVAR     VAR(&PASS) VALUE('0')
             GOTO       CMDLBL(LOOP)
             ENDDO
             ENDDO
             ELSE       CMD(IF COND((%SST(&SRCTMP 9 2) *EQ 'AM') +
                          *OR (%SST(&SRCTMP 9 2) *EQ 'BM')) +
                          THEN(GOTO CMDLBL(LOOP)))
             ELSE       CMD(IF COND(%SST(&SRCTMP 9 2) *EQ '  ') +
                          THEN(GOTO CMDLBL(LOOP)))
             ELSE       CMD(GOTO CMDLBL(END))

             ENDDO

/* CHECK WHETHER THE MEMBER IS AVAILABLE FOR OPERATION */

             CHKOBJ     OBJ(&ENCRLIB/&ENCRPF) OBJTYPE(*FILE) +
                          MBR(&ENCRMBR)
             MONMSG     MSGID(CPF9815) EXEC(GOTO CMDLBL(TERMINATE))

/* IF ALL OF THE ABOVE CONDITIONS HAS BEEN SATISFIED */
/* PREPARATION OF THE TEMPORARY FILE FOR SOURCE CHANGE */

             CHKOBJ     OBJ(QGPL/QRPGLESRC) OBJTYPE(*FILE)
             MONMSG     MSGID(CPF9801) EXEC(DO)
             CRTSRCPF   FILE(QGPL/QRPGLESRC) RCDLEN(112) +
                          TEXT('Temporary Source Physical File')
             MONMSG     MSGID(CPF0000 CPF9999)
             ENDDO

             ADDPFM     FILE(QGPL/QRPGLESRC) MBR(XX04G891R) +
                          TEXT('Temporary Member')
             MONMSG     MSGID(CPF0000 CPF9999)

             CPYF       FROMFILE(QGPL/QRPGLESRC) TOFILE(QGPL/SOURCE) +
                          FROMMBR(XX04G891R) CRTFILE(*YES)
             MONMSG     MSGID(CPF0000 CPF9999)

             CPYF       FROMFILE(&ENCRLIB/&ENCRPF) +
                          TOFILE(QGPL/SOURCE) FROMMBR(&ENCRMBR) +
                          MBROPT(*REPLACE) CRTFILE(*NO) FMTOPT(*NOCHK)
             MONMSG     MSGID(CPF2817) EXEC(DO)
             SNDPGMMSG  MSGID(CPF2817) MSGF(QCPFMSG) MSGTYPE(*NOTIFY)
             GOTO       CMDLBL(END)
             ENDDO

             RTVMBRD    FILE(SOURCE) NBRCURRCD(&NBR)

             CALL       PGM(ENCRYPT) PARM(&ENCRPWD &ENCDCR &PASS +
                          &NBR &ENCRMBR)

             IF         COND(&PASS *EQ '0') THEN(DO)
             CPYF       FROMFILE(QGPL/SOURCE) +
                          TOFILE(&ENCRLIB/&ENCRPF) TOMBR(&ENCRMBR) +
                          MBROPT(*REPLACE) CRTFILE(*NO) FMTOPT(*NOCHK)
             GOTO       CMDLBL(ENDLOOP)
             ENDDO

             ELSE       CMD(IF COND(&PASS *EQ '1') THEN(DO))
             SNDPGMMSG  MSG('Password Mismatch For Member' *BCAT +
                          &MEMBER)
             GOTO       CMDLBL(END)
             ENDDO
             ELSE       CMD(IF COND(&ENCDCR *EQ 'E') THEN(DO))
             SNDPGMMSG  MSG('Encryption Terminated..  Source Already +
                          Encrypted')
             GOTO       CMDLBL(END)
             ENDDO
             ELSE       CMD(DO)
             SNDPGMMSG  MSG('Decryption Terminated..  Source Already +
                          Decrypted')
             GOTO       CMDLBL(END)
             ENDDO

 TERMINATE:  RCVMSG     MSGDTA(&MSGDTA) MSGID(&MSGID) MSGF(&MSGF)
             SNDPGMMSG  MSGID(&MSGID) MSGF(&MSGF) +
                          MSGDTA(&MSGDTA) MSGTYPE(*NOTIFY)
             GOTO       CMDLBL(END)

 ENDLOOP:    IF         COND(&ENCDCR *EQ 'E') THEN(DO)
             SNDPGMMSG  MSG('Encryption of member' *BCAT &ENCRMBR +
                          *BCAT 'ended successfully')
             ENDDO
             ELSE       CMD(DO)
             SNDPGMMSG  MSG('Decryption of member' *BCAT &ENCRMBR +
                          *BCAT 'ended successfully')
             ENDDO

 END:        DLTF       FILE(QTEMP/SRCTMP)
             MONMSG     MSGID(CPF0000 CPF9999)
             DLTF       FILE(QGPL/SOURCE)
             MONMSG     MSGID(CPF0000 CPF9999)
             IF         COND(&IN99 *EQ '1') THEN(DO)
             RMVM       FILE(QGPL/QRPGLESRC) MBR(XX04G891R)
             MONMSG     MSGID(CPF0000 CPF9999)
             DLTF       FILE(QGPL/QRPGLESRC)
             MONMSG     MSGID(CPF0000 CPF9999)
             ENDDO
             RMVM       FILE(QGPL/QRPGLESRC) MBR(XX04G891R)
             MONMSG     MSGID(CPF0000 CPF9999)

 ERROR:      CHGJOB     JOB(&JOBIDN/&USER/&WSID) RUNPTY(&PTY) +
                          LOGCLPGM(*NO) STSMSG(*SYSVAL)
             MONMSG     MSGID(CPF0000 CPF9999)

             RCLRSC

             ENDPGM

ENCRY.CMD

             CMD        PROMPT('Source Encryption')
             PARM       KWD(ENCRPF) TYPE(*CHAR) LEN(10) MIN(1) +
                          ALWUNPRT(*NO) CHOICE('Name') +
                          PROMPT('Source physical file name')
             PARM       KWD(ENCRLIB) TYPE(*CHAR) LEN(10) MIN(1) +
                          ALWUNPRT(*NO) CHOICE('Name') +
                          PROMPT('Library Name')
             PARM       KWD(ENCRMBR) TYPE(*CHAR) LEN(10) MIN(1) +
                          ALWUNPRT(*NO) CHOICE('Name,*All') +
                          PROMPT('Member Name')
             PARM       KWD(ENCRPWD) TYPE(*CHAR) LEN(10) MIN(1) +
                          ALWUNPRT(*NO) DSPINPUT(*NO) +
                          PROMPT('Password')
             PARM       KWD(ENCDCR) TYPE(*CHAR) LEN(1) MIN(1) +
                          ALWUNPRT(*NO) CHOICE('E,D') +
                          PROMPT('Encrypt or Decrypt')

ENCRYPT.RPG

     FSOURCE  UF  E                    DISK                      A    UC
     F            QRPGLESRC                         KRENAMESRCREC
     FPROGRESSCF  E                    WORKSTN
      *
     E                    AR1       100  1
     E                    AR2        10  1
     E                    AR3        50  1
      *
     C           *ENTRY    PLIST
     C                     PARM           PWD    10
     C                     PARM           ED      1
     C                     PARM           PASS    1
     C                     PARM           NBR    100
     C                     PARM           MEMB   10
     C*
     C                     OPEN SOURCE
     C*
     C*
     C           *HIVAL    SETGTSRCREC
     C                     READPSRCREC                   55
     C*
     C                     SELEC
     C           SRCDAT    WHEQ 999999
     C           ED        ANDEQ'D'
     C                     EXSR S0003
     C           SRCDAT    WHNE 999999
     C           ED        ANDEQ'E'
     C                     CLOSESOURCE
     C                     OPEN SOURCE
     C                     EXSR S0001
     C                     EXSR S0002
     C                     OTHER
     C                     MOVE '2'       PASS
     C                     ENDSL
     C*
     C                     CLOSESOURCE
     C*
     C                     MOVE *ON       *INLR
     C*
     C*****************************************************************
     C* S0001 - ENCRYPTION OR DECRYPTION ROUTINE
     C*****************************************************************
     C           S0001     BEGSR
     C                     Z-ADD1         N1      30
     C                     Z-ADD1         N2      10
     C  N60                READ SRCREC                   30
     C   60                READPSRCREC                   55
BAR  C                     EXSR S0004
     C                     Z-ADDSRCSEQ    SEQNO   62
     C                     MOVEASRCDTA    AR1
     C           *IN30     DOWEQ*OFF
     C           *IN55     ANDEQ*OFF
     C*
     C           N1        DOWLE100
     C*
     C           N2        DOWLE8
     C                     SELEC
     C           N2        WHEQ 1
     C                     TESTB'0'       AR1,N1     50
     C   50                BITON'0'       AR1,N1
     C  N50                BITOF'0'       AR1,N1
     C           N2        WHEQ 2
     C                     TESTB'1'       AR1,N1     50
     C   50                BITON'1'       AR1,N1
     C  N50                BITOF'1'       AR1,N1
     C           N2        WHEQ 3
     C                     TESTB'2'       AR1,N1     50
     C   50                BITON'2'       AR1,N1
     C  N50                BITOF'2'       AR1,N1
     C           N2        WHEQ 4
     C                     TESTB'3'       AR1,N1     50
     C   50                BITON'3'       AR1,N1
     C  N50                BITOF'3'       AR1,N1
     C           N2        WHEQ 5
     C                     TESTB'4'       AR1,N1     50
     C   50                BITON'4'       AR1,N1
     C  N50                BITOF'4'       AR1,N1
     C           N2        WHEQ 6
     C                     TESTB'5'       AR1,N1     50
     C   50                BITON'5'       AR1,N1
     C  N50                BITOF'5'       AR1,N1
     C           N2        WHEQ 7
     C                     TESTB'6'       AR1,N1     50
     C   50                BITON'6'       AR1,N1
     C  N50                BITOF'6'       AR1,N1
     C           N2        WHEQ 8
     C                     TESTB'7'       AR1,N1     50
     C   50                BITON'7'       AR1,N1
     C  N50                BITOF'7'       AR1,N1
     C                     ENDSL
     C                     ADD  1         N2
     C                     ENDDO
     C*
     C                     Z-ADD1         N2
     C                     ADD  1         N1
     C                     ENDDO
     C                     MOVEAAR1       SRCDTA
     C                     UPDATSRCREC
     C                     MOVEA*BLANKS   AR1
     C                     Z-ADD1         N2
     C                     Z-ADD1         N1
     C  N60                READ SRCREC                   30
     C   60                READPSRCREC                   55
BAR  C                     EXSR S0004
     C                     Z-ADDSRCSEQ    SEQNO   62
     C                     MOVEASRCDTA    AR1
     C*
     C                     ENDDO
     C                     ENDSR
     C*
     C*****************************************************************
     C* S0002 - PASSWORD ENCRYPTION OR DECRYPTION
     C*****************************************************************
     C           S0002     BEGSR
     C           ED        IFEQ 'E'
     C                     MOVEAPWD       AR2
     C                     ENDIF
     C                     Z-ADD1         N1
     C                     Z-ADD0         N2
     C           N1        DOWLE10
     C*
     C           N2        DOWLE7
     C                     SELEC
     C           N2        WHEQ 0
     C                     TESTB'0'       AR2,N1     50
     C   50                BITON'0'       AR2,N1
     C  N50                BITOF'0'       AR2,N1
     C           N2        WHEQ 1
     C                     TESTB'1'       AR2,N1     50
     C   50                BITON'1'       AR2,N1
     C  N50                BITOF'1'       AR2,N1
     C           N2        WHEQ 2
     C                     TESTB'2'       AR2,N1     50
     C   50                BITON'2'       AR2,N1
     C  N50                BITOF'2'       AR2,N1
     C           N2        WHEQ 3
     C                     TESTB'3'       AR2,N1     50
     C   50                BITON'3'       AR2,N1
     C  N50                BITOF'3'       AR2,N1
     C           N2        WHEQ 4
     C                     TESTB'4'       AR2,N1     50
     C   50                BITON'4'       AR2,N1
     C  N50                BITOF'4'       AR2,N1
     C           N2        WHEQ 5
     C                     TESTB'5'       AR2,N1     50
     C   50                BITON'5'       AR2,N1
     C  N50                BITOF'5'       AR2,N1
     C           N2        WHEQ 6
     C                     TESTB'6'       AR2,N1     50
     C   50                BITON'6'       AR2,N1
     C  N50                BITOF'6'       AR2,N1
     C           N2        WHEQ 7
     C                     TESTB'7'       AR2,N1     50
     C   50                BITON'7'       AR2,N1
     C  N50                BITOF'7'       AR2,N1
     C                     ENDSL
     C                     ADD  1         N2
     C                     ENDDO
     C*
     C                     Z-ADD0         N2
     C                     ADD  1         N1
     C                     ENDDO
     C*
     C           ED        IFEQ 'E'
     C                     MOVEAAR2       SRCDTA
     C                     ADD  10        SEQNO
     C                     MOVE SEQNO     SRCSEQ
     C                     MOVE 999999    SRCDAT
     C                     WRITESRCREC
     C                     ENDIF
     C                     ENDSR
     C*
     C*****************************************************************
     C* S0003 - VALIDATION
     C*****************************************************************
     C           S0003     BEGSR
     C*
     C                     MOVELSRCDTA    SRCFLD 10
     C                     MOVEASRCFLD    AR2
     C                     EXSR S0002
     C                     MOVE *BLANKS   SRCFLD
     C                     MOVEAAR2       SRCFLD
     C*
     C           SRCFLD    IFEQ PWD
     C                     DELETSRCREC
     C                     MOVE *ON       *IN60
     C                     EXSR S0001
     C                     ELSE
     C                     MOVE '1'       PASS
     C                     ENDIF
     C*
     C                     ENDSR
     C*
     C*****************************************************************
     C* S0004 - PROGRESS BAR CALCULATION
     C*****************************************************************
     C*
     C           S0004     BEGSR
     C                     ADD  1         COUNT  100
     C                     Z-ADD*ZEROS    R       30
     C           COUNT     DIV  NBR       T1     103
     C                     MVR            T4      10
     C           T1        MULT 100       T2     100
     C           T4        IFGT 5
     C                     ADD  1         T2
     C                     ENDIF
     C           T2        MULT 0.5       T3      30
     C           T3        IFGT 0
     C           T3        ANDLE50
     C           R         DOUEQT3
     C                     ADD  1         R
     C                     MOVE X'1F'     AR3,R
     C                     ENDDO
     C                     MOVEAAR3       BAR
     C                     MOVE MEMB      MEMBER
     C                     MOVE T2        PER
     C                     WRITEPRO1
     C                     ENDIF
     C                     WRITEPRO1
     C                     ENDSR


PROGRESS.DSPF

     A*%%TS  SD  19991226  022834  SBKOWNER    REL-V3R7M0  5716-PW1
     A*%%EC
     A                                      DSPSIZ(24 80 *DS3)
     A          R PRO1
     A*%%TS  SD  19991226  022834  SBKOWNER    REL-V3R7M0  5716-PW1
     A                                      OVERLAY
     A                                  3  3'P-L-E-A-S-E   W-A-I-T'
     A                                      DSPATR(HI)
     A                                      DSPATR(BL)
     A            PER            3Y 0O 20 58DSPATR(HI)
     A                                      EDTCDE(Z)
     A                                 20 62'% Completed'
     A                                 22  2'                                  -
     A                                                                         -
     A                                             '
     A                                      DSPATR(UL)
     A                                 18  2'                                  -
     A                                                                         -
     A                                             '
     A                                      DSPATR(UL)
     A                                  6  3'Operation With Member'
     A            MEMBER        10A  O  6 25
     A                                  6 36'Is In Progress . . . . .'
     A            BAR           50A  O 20  2COLOR(BLU)
     A                                      DSPATR(CS)
     A                                 21  2'0'
     A                                      DSPATR(HI)
     A                                 21 50'100'
     A                                      DSPATR(HI)
     A                                 21 26'50'
     A                                      DSPATR(HI)
     A          R PRO2
     A*%%TS  SD  19991225  211702  SBKOWNER    REL-V3R7M0  5716-PW1
     A                                      OVERLAY
     A                                      PUTRETAIN
     A                                  3  3'P-L-E-A-S-E   W-A-I-T'
     A                                      DSPATR(HI)
     A                                      DSPATR(BL)
     A                                  6  3'Operation Is In Progress . . . . .-
     A                                       . . .'
Write Comment (0 comments)
<< Start < Previous 1 2 3 4 5 6 7 8 9 10 Next > End >>

Results 11 - 20 of 626