Remember the days of wild-west RPG coding, where GOTO tags ran rampant and subroutines tangled like tumbleweeds in a windstorm? Yep, I’ve wrangled that beast too. But today, we’re trading chaos for clarity.
In this video, we’ll take a gnarly chunk of legacy RPG and refactor it into sleek, modern RPGLE using sub-procedures that actually make sense. Real code. Real upgrades. Less head-scratching.
If you’re an IBM i developer tired of duct-taping your way through ancient logic, this is your sign to evolve. Hit play, smash that like if you’ve ever cursed a GOTO, and subscribe for more RPGLE wizardry.
Source Code three ways:
OLD RPG
// ----------------------------------------------------------
// AUTHOR: NICK LITTEN
// SOME OLD SAMPLE CODE WRITTEN IN THE 1990S FOR RPG400 STYLE
// WITH GOTO STATEMENTS AND SUBROUTINES. THIS CODE HAS BEEN
// CONVERTED TO FREE FORMAT RPG AS PART OF A VIDEO RPG UPGRADE.
// ----------------------------------------------------------
// WRITTEN : DURING A 1990'S RAVE
// MODIFICATION HISTORY:
// 2025.10.06 NJL PLAYED WITH AS PART OF A VIDEO RPG UPGRADE
// https://www.nicklitten.com/course/old-rpg-with-goto-tag-and-subroutines-to-modern-rpgle-with-sub_procedures
// ----------------------------------------------------------
// AUTHOR: NICK LITTEN
// SOME OLD SAMPLE CODE WRITTEN IN THE 1990S FOR RPG400 STYLE
// WITH GOTO STATEMENTS AND SUBROUTINES. THIS CODE HAS BEEN
// CONVERTED TO FREE FORMAT RPG AS PART OF A VIDEO RPG UPGRADE.
// ----------------------------------------------------------
// WRITTEN : DURING A 1990'S RAVE
// MODIFICATION HISTORY:
// 2025.10.06 NJL PLAYED WITH AS PART OF A VIDEO RPG UPGRADE
// https://www.nicklitten.com/course/old-rpg-with-goto-tag-and-subroutines-to-modern-rpgle-with-sub_procedures
// ----------------------------------------------------------
FQTXTSRC IF E K DISK RENAME(QTXTSRC:RECTXT)
// ----------------------------------------------------------
// THIS PROGRAM READS A RECORD FROM A FILE AND PROCESSES IT.
// IT USES OLD STYLE RPG WITH GOTO STATEMENTS AND SUBROUTINES.
// ----------------------------------------------------------
DDATA DS
DRECORD 92A INZ
DFLAG 8A OVERLAY(RECORD:1)
DPARTN 20A OVERLAY(RECORD:10)
C *ENTRY PLIST
C PARM RTN 10
C START TAG
C READ QTXTSRC 50
C IF *IN50 = '1'
C MOVEL 'NOT FOUND' RTN
C GOTO ENDPGM
C ENDIF
C EXSR LOGIC
C GOTO START
// PROGRAM EXIT POINT
C ENDPGM TAG
C EVAL *INLR = *ON
// ----------------------------------------------------------
// THIS IS A SUBROUTINE TO DEMONSTRATE THE OLD STYLE OF RPG400
// SUBROUTINES.
// ----------------------------------------------------------
C LOGIC BEGSR
C MOVEL SRCDTA RECORD
C IF FLAG = 'THISONE'
C IF PARTN <> *BLANKS
C MOVEL 'EXISTS' RTN
C GOTO ENDPGM
C ENDIF
C ENDIF
C ENDSR
OLDISH RPG
// ----------------------------------------------------------
// AUTHOR: NICK LITTEN
// SOME OLD SAMPLE CODE WRITTEN IN THE 1990S FOR RPG400 STYLE
// WITH GOTO STATEMENTS AND SUBROUTINES. THIS CODE HAS BEEN
// CONVERTED TO FREE FORMAT RPG AS PART OF A VIDEO RPG UPGRADE.
// ----------------------------------------------------------
// WRITTEN : DURING A 1990'S RAVE
// MODIFICATION HISTORY:
// 2025.10.06 NJL PLAYED WITH AS PART OF A VIDEO RPG UPGRADE
// https://www.nicklitten.com/course/old-rpg-with-goto-tag-and-subroutines-to-modern-rpgle-with-sub_procedures
// ----------------------------------------------------------
FQTXTSRC IF E K DISK RENAME(QTXTSRC:RECTXT)
DDATA DS
DRECORD 92A INZ
DFLAG 8A OVERLAY(RECORD:1)
DPARTN 20A OVERLAY(RECORD:10)
C *ENTRY PLIST
C PARM RTN 10
C MOVEL 'NOT FOUND' RTN
// outside DO loop
C READ QTXTSRC 50
C DOW *IN50 = '0'
C EXSR LOGIC
C IF RTN = 'EXISTS'
C LEAVE
C ENDIF
C READ QTXTSRC 50
C ENDDO
// inside do loop (alternate logic for reference)
//C DOU 1 <> 1
//C READ QTXTSRC 50
//C IF *IN50 = '1'
//C LEAVE
//C ENDIF
//C EXSR LOGIC
//C ENDDO
// PROGRAM EXIT POINT
C EVAL *INLR = *ON
// ----------------------------------------------------------
// THIS IS A SUBROUTINE TO DEMONSTRATE THE OLD STYLE OF RPG400
// SUBROUTINES.
// ----------------------------------------------------------
C LOGIC BEGSR
C MOVEL SRCDTA RECORD
C IF FLAG = 'THISONE'
C IF PARTN <> *BLANKS
C MOVEL 'EXISTS' RTN
C LEAVESR
C ENDIF
C ENDIF
// here might be other processing
C ENDSR
// AUTHOR: NICK LITTEN
// SOME OLD SAMPLE CODE WRITTEN IN THE 1990S FOR RPG400 STYLE
// WITH GOTO STATEMENTS AND SUBROUTINES. THIS CODE HAS BEEN
// CONVERTED TO FREE FORMAT RPG AS PART OF A VIDEO RPG UPGRADE.
// ----------------------------------------------------------
// WRITTEN : DURING A 1990'S RAVE
// MODIFICATION HISTORY:
// 2025.10.06 NJL PLAYED WITH AS PART OF A VIDEO RPG UPGRADE
// https://www.nicklitten.com/course/old-rpg-with-goto-tag-and-subroutines-to-modern-rpgle-with-sub_procedures
// ----------------------------------------------------------
FQTXTSRC IF E K DISK RENAME(QTXTSRC:RECTXT)
DDATA DS
DRECORD 92A INZ
DFLAG 8A OVERLAY(RECORD:1)
DPARTN 20A OVERLAY(RECORD:10)
C *ENTRY PLIST
C PARM RTN 10
C MOVEL 'NOT FOUND' RTN
// outside DO loop
C READ QTXTSRC 50
C DOW *IN50 = '0'
C EXSR LOGIC
C IF RTN = 'EXISTS'
C LEAVE
C ENDIF
C READ QTXTSRC 50
C ENDDO
// inside do loop (alternate logic for reference)
//C DOU 1 <> 1
//C READ QTXTSRC 50
//C IF *IN50 = '1'
//C LEAVE
//C ENDIF
//C EXSR LOGIC
//C ENDDO
// PROGRAM EXIT POINT
C EVAL *INLR = *ON
// ----------------------------------------------------------
// THIS IS A SUBROUTINE TO DEMONSTRATE THE OLD STYLE OF RPG400
// SUBROUTINES.
// ----------------------------------------------------------
C LOGIC BEGSR
C MOVEL SRCDTA RECORD
C IF FLAG = 'THISONE'
C IF PARTN <> *BLANKS
C MOVEL 'EXISTS' RTN
C LEAVESR
C ENDIF
C ENDIF
// here might be other processing
C ENDSR
NEW RPGLE
**free
// ----------------------------------------------------------
// author: nick litten
// some old sample code written in the 1990s for rpg400 style
// with goto statements and subroutines. this code has been
// converted to free format rpg as part of a video rpg upgrade.
// ----------------------------------------------------------
// written : during a 1990's rave
// modification history:
// 2025.10.06 njl played with as part of a video rpg upgrade
// https://www.nicklitten.com/course/old-rpg-with-goto-tag-and-subroutines-to-modern-rpgle-with-sub_procedures
// ----------------------------------------------------------
ctl-opt dftactgrp(*no) actgrp('NICKLITTEN') option(*srcstmt:*nodebugio);
dcl-f qtxtsrc disk usage(*input) rename(qtxtsrc:rectxt);
dcl-pi *n;
rtn char(10);
end-pi;
dcl-ds srcdta qualified inz;
flag char(8) pos(1);
partnumber char(20) pos(11);
end-ds;
rtn = 'NOT FOUND';
// read every row in QTXTSRC and update 'RTN' if match found
read qtxtsrc;
dow not %eof(qtxtsrc) and no_match_found(srcdta.flag:srcdta.partnumber);
read qtxtsrc;
enddo;
dsply %char('Rtn=' + rtn);
*inlr = *on;
// ----------------------------------------------------------
// this is a subprocedure that replaces a goto tag subroutine
// ----------------------------------------------------------
dcl-proc no_match_found;
dcl-pi *n ind;
myFlag like(srcdta.flag);
myPartnumber like(srcdta.partnumber);
end-pi;
dcl-s myStatus ind inz(*on);
if myFlag = 'THISONE' and myPartnumber <> *BLANKS;
rtn = 'EXISTS';
myStatus = *off;
endif;
return myStatus;
end-proc;
// ----------------------------------------------------------
// author: nick litten
// some old sample code written in the 1990s for rpg400 style
// with goto statements and subroutines. this code has been
// converted to free format rpg as part of a video rpg upgrade.
// ----------------------------------------------------------
// written : during a 1990's rave
// modification history:
// 2025.10.06 njl played with as part of a video rpg upgrade
// https://www.nicklitten.com/course/old-rpg-with-goto-tag-and-subroutines-to-modern-rpgle-with-sub_procedures
// ----------------------------------------------------------
ctl-opt dftactgrp(*no) actgrp('NICKLITTEN') option(*srcstmt:*nodebugio);
dcl-f qtxtsrc disk usage(*input) rename(qtxtsrc:rectxt);
dcl-pi *n;
rtn char(10);
end-pi;
dcl-ds srcdta qualified inz;
flag char(8) pos(1);
partnumber char(20) pos(11);
end-ds;
rtn = 'NOT FOUND';
// read every row in QTXTSRC and update 'RTN' if match found
read qtxtsrc;
dow not %eof(qtxtsrc) and no_match_found(srcdta.flag:srcdta.partnumber);
read qtxtsrc;
enddo;
dsply %char('Rtn=' + rtn);
*inlr = *on;
// ----------------------------------------------------------
// this is a subprocedure that replaces a goto tag subroutine
// ----------------------------------------------------------
dcl-proc no_match_found;
dcl-pi *n ind;
myFlag like(srcdta.flag);
myPartnumber like(srcdta.partnumber);
end-pi;
dcl-s myStatus ind inz(*on);
if myFlag = 'THISONE' and myPartnumber <> *BLANKS;
rtn = 'EXISTS';
myStatus = *off;
endif;
return myStatus;
end-proc;