|
midrange.com
Here's the one I had, goto's and All!
Your mileage may vary.... this hasn't been used probably since 1991 or so.
CMD FI2DDS
CMD PROMPT('Convert F & I Specs to DDS')
PARM KWD(SRCPGM) TYPE(*CHAR) LEN(10) +
PROMPT('Member Containing F & I Specs')
PARM KWD(LIBR) TYPE(*CHAR) LEN(10) MIN(1) +
PROMPT('Library')
PARM KWD(DDSMEM) TYPE(*CHAR) LEN(10) MIN(1) +
PROMPT('File Name in F & I Member')
PARM KWD(DDSLIB) TYPE(*CHAR) LEN(10) MIN(1) +
PROMPT('Library Name for DDS Member')
CLP FI2DDS
PGM PARM(&SRCPGM &LIBR &DDSMEM &DDSLIB)
DCL VAR(&SRCPGM) TYPE(*CHAR) LEN(10)
DCL VAR(&LIBR) TYPE(*CHAR) LEN(10)
DCL VAR(&DDSMEM) TYPE(*CHAR) LEN(10)
DCL VAR(&DDSLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGRPY) TYPE(*CHAR) LEN(1)
DCL VAR(&TEXT) TYPE(*CHAR) LEN(50)
DCL VAR(&USERID) TYPE(*CHAR) LEN(10)
/* CHECK IF MEMBER ALREADY THERE, IF YES, ASK IF WANT TO CLEAR */
RTVUSRPRF RTNUSRPRF(&USERID)
RTVMBRD FILE(&LIBR/QS36SRC) MBR(&SRCPGM) TEXT(&TEXT)
ADDPFM FILE(&DDSLIB/QDDSSRC) MBR(&DDSMEM) +
TEXT(&TEXT)
MONMSG MSGID(CPF7306) EXEC(DO)
RMVMSG PGMQ(*EXT) CLEAR(*ALL)
SNDUSRMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Member' +
*BCAT &DDSLIB *TCAT '/' *TCAT 'QDDSSRC' +
*TCAT '/' *TCAT &DDSMEM *BCAT 'already +
exists. Overwrite? (Y/N)') VALUES(Y N) +
DFT(N) MSGRPY(&MSGRPY)
IF COND(&MSGRPY *NE 'Y') THEN(GOTO +
CMDLBL(ENDPROGRAM))
ENDDO
CLRPFM FILE(&DDSLIB/QDDSSRC) MBR(&DDSMEM)
SBMJOB CMD(CALL PGM(FI2DDSS) PARM(&SRCPGM &LIBR +
&DDSMEM &DDSLIB)) JOB(&SRCPGM)
ENDPROGRAM: ENDPGM
CLP FI2DDSS
PGM PARM(&SRCPGM &LIBR &DDSMEM &DDSLIB)
DCL VAR(&SRCPGM) TYPE(*CHAR) LEN(10)
DCL VAR(&LIBR) TYPE(*CHAR) LEN(10)
DCL VAR(&DDSMEM) TYPE(*CHAR) LEN(10)
DCL VAR(&DDSLIB) TYPE(*CHAR) LEN(10)
ADDPFM FILE(&DDSLIB/QDDSSRC) MBR(&DDSMEM) +
TEXT('Created by FI2DDS')
MONMSG MSGID(CPF7306) EXEC(CLRPFM +
FILE(&DDSLIB/QDDSSRC) MBR(&DDSMEM))
OVRDBF FILE(SRCIN) TOFILE(&LIBR/QS36SRC) +
MBR(&SRCPGM) POSITION(*START)
OVRDBF FILE(SRCOUT) TOFILE(&DDSLIB/QDDSSRC) +
MBR(&DDSMEM)
CALL PGM(FI2DDSR1) PARM(&DDSMEM)
DLTOVR FILE(*ALL)
RGZPFM FILE(&DDSLIB/QDDSSRC) MBR(&DDSMEM) +
SRCOPT(*DATE *SEQNBR)
ENDPROGRAM: ENDPGM
Love the RPG II!
F***********************************************************
F* Unpublished- All Rights Reserved *
F* Under the Copyright Laws *
F* (C) Tostaine Computer Services, Inc. *
F* 1989 *
F***********************************************************
F*FI2DDSR1-Convert F & I Specs to DDS *
F*Written -- 08/14/89 -- by -- Art Tostaine Jr. *
F***********************************************************
F*
FSRCIN IP F 132 DISK
FSRCOUT O F 92 DISK
ISRCIN NS 01 18 CI 19NC* 27NC
I 19 26 FILE
I NS 02 18 CI 19 C 27 C
I** 19 26 FILE
I 55 55 PACKED
I 56 59 F
I 60 63 T
I 64 64 DEC
I 65 70 FIELD
I 87 102 COMMN1
I NS
C******************************************
C *ENTRY PLIST
C PARM LDFILE 10
C**
C** SETUP APOSTROPHE USING HEX CODE 7D
C**
B01 C ONCE DO 0 ONCE 10
01 C BITOF'01234567'APOST 1
01 C BITON'123457' APOST
01 C MOVELCOMMN1 ONE 1
01 C MOVEL'COLHDG(' COLHDG 7
01 C MOVEL')' PARENH 1
E01 C END
C**
B01 C 01 DO
01 C**
01 C**SKIP ANY OTHER FILES IN THE SOURCE
01 C**
B02 C FILE IFGT *BLANKS
02 C FILE ANDNELDFILE
B03 C FOUND IFEQ 'Y'
03 C SETON LR
E03 C END
02 C GOTO DONE
E02 C END
01 C**
01 C**FILE NAME FOR THAT FILE
01 C**
B02 C FILE IFEQ LDFILE
02 C MOVE FILE FILESV 8
E02 C END
B02 C FILE IFEQ LDFILE
02 C FOUND OREQ 'Y'
02 C FILE ANDEQ*BLANKS
02 C MOVE 'Y' FOUND 1
02 C EXCPTHDR
E02 C END
E01 C END
C**
C**FIELD FOR OUR FILE
C**
B01 C 02 FOUND IFEQ 'Y'
01 C MOVE F FROM 40
01 C MOVE T TO 40
01 C TO SUB FROM LEN 30
01 C ADD 1 LEN
B02 C PACKED IFEQ ' '
02 C DEC ANDNE' '
02 C MOVE 'S' PACKED
E02 C END
B02 C PACKED IFEQ 'P'
02 C LEN MULT 2 LEN
02 C LEN SUB 1 LEN
E02 C END
01 C CALL 'FI2TXTC' FI2PLS
01 C EXCPTDET01
E01 C END
C**
C DONE TAG
C FI2PLS PLIST
C PARM COLHDG
C PARM APOST
C PARM COMMN1
C PARM APOST
C PARM PARENH
C PARM STRING 26
C******************************************
OSRCOUT E HDR
O 18 'A'
O 29 'R'
O FILESV 38
OSRCOUT E DET01
O 18 'A'
O FIELD 36
O LEN Z 46
O PACKED 47
O DEC 49
O STRING 82
CLP FI2TXTC
PGM PARM(&COLHDG &APOST1 &COMMN1 &APOST2 &PARENH +
&STRING)
DCL VAR(&COLHDG) TYPE(*CHAR) LEN(7)
DCL VAR(&APOST1) TYPE(*CHAR) LEN(1)
DCL VAR(&COMMN1) TYPE(*CHAR) LEN(16)
DCL VAR(&APOST2) TYPE(*CHAR) LEN(1)
DCL VAR(&PARENH) TYPE(*CHAR) LEN(1)
DCL VAR(&STRING) TYPE(*CHAR) LEN(26)
CHGVAR VAR(&STRING) VALUE(&COLHDG *TCAT &APOST1 +
*TCAT &COMMN1 *TCAT &APOST2 *TCAT &PARENH)
RETURN
ENDPROGRAM: ENDPGM
_________________
Art Tostaine, Jr.
CCA, Inc.
Jackson, NJ 08527
> -----Original Message-----
> From: rpg400-l-admin@midrange.com [mailto:rpg400-l-admin@midrange.com]On
> Behalf Of David Schopp
> Sent: Wednesday, May 01, 2002 10:12 AM
> To: rpg400-l@midrange.com
> Subject: Re: Tool to convert s/36 I-specs to DDS???
>
>
> Carsten,
>
> I would be interested in your utility as we too are making a jump
> (baby-step?) from our '36 specs to native!
>
> Thanks in advance
> Dave
>
> "Carsten Flensburg" <flensburg@novasol.dk> wrote in message
> news:<00c601c1f0d2$fd9b5b20$0250a8c0@CF101>...
> > Hello Dan,
> >
> > Did you get a tool? I have a slightly modified version of Art Tostaine's
> > FI2DDS - let me know if you want it.
> >
> > Best regards,
> > Carsten Flensburg
> >
>
>
> _______________________________________________
> This is the RPG programming on the AS400 / iSeries (RPG400-L) mailing list
> To post a message email: RPG400-L@midrange.com
> To subscribe, unsubscribe, or change list options,
> visit: http://lists.midrange.com/cgi-bin/listinfo/rpg400-l
> or email: RPG400-L-request@midrange.com
> Before posting, please take a moment to review the archives
> at http://archive.midrange.com/rpg400-l.
>
As an Amazon Associate we earn from qualifying purchases.
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.
