Difference between revisions of "UDDS File Display/Update"
From MidrangeWiki
(→DUSP1 RPG) |
m (→DIS1 CL files with NULL fields cant be processed) |
||
| (25 intermediate revisions by the same user not shown) | |||
| Line 2: | Line 2: | ||
| − | ==UDDS | + | ==UDDS PROGRAMS THAT SHOW FILES FIELDS AND RELATIONS AND ALLOWS UPDATE == |
The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. SC30-3533-04 (topic 15) [http://tn5250.sourceforge.net/resources.html] | The manual that describes the 5250 data stream is 5494 Remote Control Unit, Functions Reference. SC30-3533-04 (topic 15) [http://tn5250.sourceforge.net/resources.html] | ||
| Line 8: | Line 8: | ||
The purpose of this program is to demo an example of a program using UDDS. | The purpose of this program is to demo an example of a program using UDDS. | ||
| − | It shows file data, but is limited to 6048 max rcdlen. | + | It shows file data, but is limited to 6048 max rcdlen. There are 3 programs first is limited to 2048 last to 6048. |
Use the code below at your own risk, no warranty is expressed or implied or even that the code is functional. | Use the code below at your own risk, no warranty is expressed or implied or even that the code is functional. | ||
| − | I am also inculding wrapper programs to make the displayer more useful | + | I am also inculding wrapper programs to make the displayer more useful. |
| + | The COMPILE CL will create the objects once you have copied the source code into a source file. | ||
| + | |||
| + | Once compiled the command to run it is 'DSPFL yourlib/yourfile ' | ||
| + | |||
===DISP RPG=== | ===DISP RPG=== | ||
<pre> | <pre> | ||
| − | H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ | + | H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ |
H OPTION(*NODEBUGIO) | H OPTION(*NODEBUGIO) | ||
H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP ) | H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP ) | ||
| Line 24: | Line 28: | ||
F* LIMITED TO MAXIMUM FILE LENGTH OF 2048 | F* LIMITED TO MAXIMUM FILE LENGTH OF 2048 | ||
F* TEST | F* TEST | ||
| + | F* REQUIRES FILE TO COMPILE | ||
| + | F* DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) | ||
| + | |||
FFFD IF E DISK | FFFD IF E DISK | ||
FDISPF CF F 803 WORKSTN | FDISPF CF F 803 WORKSTN | ||
| Line 993: | Line 1,000: | ||
BEGSR @PUTF; | BEGSR @PUTF; | ||
| − | // | + | SELECT; |
| + | WHEN *INU1; | ||
| + | RRN = RN1; | ||
| + | WHEN *INU2; | ||
| + | RRN = RN2; | ||
| + | ENDSL; | ||
| + | |||
| + | // IF GOT RECORDS WRITE DATA TO THE DISPLAY | ||
NEWRU = '1'; | NEWRU = '1'; | ||
| Line 999: | Line 1,013: | ||
RU = *ALLX'00'; | RU = *ALLX'00'; | ||
CLEAR RU; // initialise Request Unit 255 bytes max | CLEAR RU; // initialise Request Unit 255 bytes max | ||
| + | |||
| + | IF RRN > 0 ; | ||
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | ||
| Line 1,009: | Line 1,025: | ||
WRTRRN = '0'; | WRTRRN = '0'; | ||
RU = RU + SBA + RBA ; | RU = RU + SBA + RBA ; | ||
| − | |||
| − | |||
| − | |||
| − | |||
| − | |||
| − | |||
RU = RU + %TRIM(%EDITC(RRN:'Z')); | RU = RU + %TRIM(%EDITC(RRN:'Z')); | ||
ENDIF; | ENDIF; | ||
| Line 1,167: | Line 1,177: | ||
ENDFOR; | ENDFOR; | ||
| + | ENDIF; | ||
IF %LEN(RU) > 5 AND %LEN(RU) < 250; | IF %LEN(RU) > 5 AND %LEN(RU) < 250; | ||
| Line 1,795: | Line 1,806: | ||
** | ** | ||
0123456789ABCDEF | 0123456789ABCDEF | ||
| − | |||
</pre> | </pre> | ||
[[#top]] | [[#top]] | ||
| − | + | ===DISP1 RPG=== | |
| − | ===DISP1 | ||
<pre> | <pre> | ||
| − | + | H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ | |
| − | |||
| − | |||
| − | H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ | ||
H OPTION(*NODEBUGIO) | H OPTION(*NODEBUGIO) | ||
H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP ) | H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP ) | ||
| Line 1,813: | Line 1,819: | ||
F* LIMITED TO MAXIMUM FILE LENGTH OF 4080 | F* LIMITED TO MAXIMUM FILE LENGTH OF 4080 | ||
F* TEST | F* TEST | ||
| + | F* REQUIRES FILE TO COMPILE | ||
| + | F* DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) | ||
| + | |||
FFFD IF E DISK | FFFD IF E DISK | ||
FDISPF CF F 803 WORKSTN | FDISPF CF F 803 WORKSTN | ||
| Line 2,783: | Line 2,792: | ||
BEGSR @PUTF; | BEGSR @PUTF; | ||
| − | // | + | SELECT; |
| + | WHEN *INU1; | ||
| + | RRN = RN1; | ||
| + | WHEN *INU2; | ||
| + | RRN = RN2; | ||
| + | ENDSL; | ||
| + | // IF GOT RECORDS WRITE DATA TO THE DISPLAY | ||
NEWRU = '1'; | NEWRU = '1'; | ||
| Line 2,789: | Line 2,804: | ||
RU = *ALLX'00'; | RU = *ALLX'00'; | ||
CLEAR RU; // initialise Request Unit 255 bytes max | CLEAR RU; // initialise Request Unit 255 bytes max | ||
| + | |||
| + | IF RRN > 0 ; | ||
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | ||
| Line 2,799: | Line 2,816: | ||
WRTRRN = '0'; | WRTRRN = '0'; | ||
RU = RU + SBA + RBA ; | RU = RU + SBA + RBA ; | ||
| − | |||
| − | |||
| − | |||
| − | |||
| − | |||
| − | |||
RU = RU + %TRIM(%EDITC(RRN:'Z')); | RU = RU + %TRIM(%EDITC(RRN:'Z')); | ||
ENDIF; | ENDIF; | ||
| Line 2,957: | Line 2,968: | ||
ENDFOR; | ENDFOR; | ||
| + | ENDIF; | ||
IF %LEN(RU) > 5 AND %LEN(RU) < 250; | IF %LEN(RU) > 5 AND %LEN(RU) < 250; | ||
| Line 3,585: | Line 3,597: | ||
** | ** | ||
0123456789ABCDEF | 0123456789ABCDEF | ||
| + | |||
</pre> | </pre> | ||
[[#top]] | [[#top]] | ||
| − | + | ===DISP2 RPG=== | |
| − | ===DISP2 | ||
<pre> | <pre> | ||
| − | + | H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ | |
| − | H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ | ||
H OPTION(*NODEBUGIO) | H OPTION(*NODEBUGIO) | ||
H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP ) | H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP ) | ||
F* | F* | ||
F* LIMITED TO MAXIMUM FILE LENGTH OF 6080 | F* LIMITED TO MAXIMUM FILE LENGTH OF 6080 | ||
| − | + | ||
F* REQUIRES FILE QTEMP/FFD TO COMPILE | F* REQUIRES FILE QTEMP/FFD TO COMPILE | ||
F* use cmd DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) | F* use cmd DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) | ||
| − | + | ||
FFFD IF E DISK | FFFD IF E DISK | ||
FDISPF CF F 803 WORKSTN | FDISPF CF F 803 WORKSTN | ||
| Line 4,573: | Line 4,584: | ||
BEGSR @PUTF; | BEGSR @PUTF; | ||
| − | // | + | SELECT; |
| + | WHEN *INU1; | ||
| + | RRN = RN1; | ||
| + | WHEN *INU2; | ||
| + | RRN = RN2; | ||
| + | ENDSL; | ||
| + | |||
| + | // IF GOT RECORDS WRITE DATA TO THE DISPLAY | ||
NEWRU = '1'; | NEWRU = '1'; | ||
| Line 4,579: | Line 4,597: | ||
RU = *ALLX'00'; | RU = *ALLX'00'; | ||
CLEAR RU; // initialise Request Unit 255 bytes max | CLEAR RU; // initialise Request Unit 255 bytes max | ||
| + | |||
| + | IF RRN > 0 ; | ||
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | ||
| Line 4,588: | Line 4,608: | ||
IF WRTRRN = '1'; | IF WRTRRN = '1'; | ||
WRTRRN = '0'; | WRTRRN = '0'; | ||
| − | RU | + | RU = RU + SBA + RBA ; |
| − | |||
| − | |||
| − | |||
| − | |||
| − | |||
| − | |||
RU = RU + %TRIM(%EDITC(RRN:'Z')); | RU = RU + %TRIM(%EDITC(RRN:'Z')); | ||
ENDIF; | ENDIF; | ||
| Line 4,747: | Line 4,761: | ||
ENDFOR; | ENDFOR; | ||
| + | ENDIF; | ||
IF %LEN(RU) > 5 AND %LEN(RU) < 250; | IF %LEN(RU) > 5 AND %LEN(RU) < 250; | ||
| Line 5,380: | Line 5,395: | ||
[[#top]] | [[#top]] | ||
| − | ===DUSP | + | ===DUSP RPG=== |
<pre> | <pre> | ||
| − | H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ | + | H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ |
H OPTION(*NODEBUGIO) | H OPTION(*NODEBUGIO) | ||
| − | H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME( | + | H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP ) |
F* | F* | ||
F* LIMITED TO MAXIMUM FILE LENGTH OF 2048 | F* LIMITED TO MAXIMUM FILE LENGTH OF 2048 | ||
F* REQUIRES FILE QTEMP/FFD TO COMPILE | F* REQUIRES FILE QTEMP/FFD TO COMPILE | ||
F* use cmd DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) | F* use cmd DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) | ||
| − | + | ||
FFFD IF E DISK | FFFD IF E DISK | ||
FDISPF CF F 803 WORKSTN | FDISPF CF F 803 WORKSTN | ||
| Line 5,400: | Line 5,415: | ||
FINPUTR UF A F32766 DISK EXTIND(*INU2) | FINPUTR UF A F32766 DISK EXTIND(*INU2) | ||
F INFDS(INFDR) | F INFDS(INFDR) | ||
| + | |||
| + | |||
| + | D DISBIN PR extpgm('DISBIN') | ||
| + | D NUM 15P 0 | ||
| + | D BAN2 2 | ||
| + | D BAN4 4 | ||
| + | D BINTYP 1 CONST | ||
* | * | ||
| Line 5,487: | Line 5,509: | ||
D NUP 29 60P 0 | D NUP 29 60P 0 | ||
| − | D WRU S 61 | + | D NUC S 15P 0 |
| − | D WRX S 64 | + | D BAN2 S 2 |
| + | D BAN4 S 4 | ||
| + | |||
| + | D DS | ||
| + | D NUFA 1 60A | ||
| + | D NUF 1 23A | ||
| + | D NUF1 1 14A | ||
| + | |||
| + | D DS | ||
| + | D result8 8F | ||
| + | D NUFW8 1 8A | ||
| + | |||
| + | D DS | ||
| + | D result4 4F | ||
| + | D NUFW4 1 4A | ||
| + | |||
| + | D WRU S 61 | ||
| + | D WRX S 64 | ||
D WRXWRD C '0 - | D WRXWRD C '0 - | ||
D -' | D -' | ||
| Line 5,880: | Line 5,919: | ||
I 644 723 ID8 27 | I 644 723 ID8 27 | ||
I 724 803 ID9 28 | I 724 803 ID9 28 | ||
| − | + | DCL V | |
/FREE | /FREE | ||
| Line 6,090: | Line 6,129: | ||
// MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS) | // MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS) | ||
| − | + | // GET SIZE OF FIELD IN BYTES | |
| − | + | SELECT; | |
| + | WHEN T(Y) = 'A'; // ALPHA DATA | ||
K = ' '; | K = ' '; | ||
K1 = 1; | K1 = 1; | ||
K2 = Q(Y); | K2 = Q(Y); | ||
| − | + | WHEN T(Y) = 'F'; // FLOAT | |
| + | K = '0'; | ||
| + | K1 = 1; | ||
| + | K2 = L(Y); | ||
| + | OTHER; | ||
K = '0'; | K = '0'; | ||
K1 = 1; | K1 = 1; | ||
K2 = C(Y); | K2 = C(Y); | ||
| − | + | ENDSL; | |
| + | |||
// IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT | // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT | ||
| Line 6,408: | Line 6,453: | ||
BEGSR @PUTF; | BEGSR @PUTF; | ||
| − | // | + | SELECT; |
| + | WHEN *INU1; | ||
| + | RRN = RN1; | ||
| + | WHEN *INU2; | ||
| + | RRN = RN2; | ||
| + | ENDSL; | ||
| + | // IF GOT RECORDS WRITE DATA TO THE DISPLAY | ||
NEWRU = '1'; | NEWRU = '1'; | ||
| Line 6,414: | Line 6,465: | ||
RU = *ALLX'00'; | RU = *ALLX'00'; | ||
CLEAR RU; // initialise Request Unit 255 bytes max | CLEAR RU; // initialise Request Unit 255 bytes max | ||
| + | |||
| + | IF RRN > 0 ; | ||
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | ||
| Line 6,424: | Line 6,477: | ||
WRTRRN = '0'; | WRTRRN = '0'; | ||
RU = RU + SBA + RBA ; | RU = RU + SBA + RBA ; | ||
| − | |||
| − | |||
| − | |||
| − | |||
| − | |||
| − | |||
RU = RU + %TRIM(%EDITC(RRN:'Z')); | RU = RU + %TRIM(%EDITC(RRN:'Z')); | ||
ENDIF; | ENDIF; | ||
| Line 6,582: | Line 6,629: | ||
ENDFOR; | ENDFOR; | ||
| + | ENDIF; | ||
IF %LEN(RU) > 5 AND %LEN(RU) < 250; | IF %LEN(RU) > 5 AND %LEN(RU) < 250; | ||
| Line 7,205: | Line 7,253: | ||
// GET SIZE OF FIELD IN BYTES | // GET SIZE OF FIELD IN BYTES | ||
| − | + | SELECT; | |
| + | WHEN T(Y) = 'A'; // ALPHA DATA | ||
K = ' '; | K = ' '; | ||
K1 = 1; | K1 = 1; | ||
K2 = Q(Y); | K2 = Q(Y); | ||
| − | + | WHEN T(Y) = 'F'; // FLOAT | |
| + | K = '0'; | ||
| + | K1 = 1; | ||
| + | K2 = L(Y); | ||
| + | OTHER; | ||
K = '0'; | K = '0'; | ||
K1 = 1; | K1 = 1; | ||
K2 = C(Y); | K2 = C(Y); | ||
| − | + | ENDSL; | |
X = 1; | X = 1; | ||
| Line 7,284: | Line 7,337: | ||
// the data start is in S(Y) | // the data start is in S(Y) | ||
// the data is in array K | // the data is in array K | ||
| − | // get the length of the data cvt to bin and | + | // get the length of the data cvt to bin and stick in pos 1 2 |
// put the rest in pos 3 onwards | // put the rest in pos 3 onwards | ||
| Line 7,337: | Line 7,390: | ||
// BINARY FIELDS | // BINARY FIELDS | ||
IF T(Y) = 'B'; | IF T(Y) = 'B'; | ||
| + | |||
| + | NUSA= *BLANKS; | ||
| + | FOR VX = 1 TO 60; | ||
| + | NUSA = %TRIM(NUSA) + NU(VX); | ||
| + | ENDFOR; | ||
| + | NUC = NUS; | ||
IF Q(Y) = 2 ; | IF Q(Y) = 2 ; | ||
| − | + | DISBIN ( NUC : BAN2 : BAN4 : '2'); | |
| − | + | %SUBST(DATA : W : 2) = BAN2; | |
ENDIF; | ENDIF; | ||
IF Q(Y) = 4 ; | IF Q(Y) = 4 ; | ||
| − | + | DISBIN ( NUC : BAN2 : BAN4 : '4'); | |
| − | + | %SUBST(DATA : W : 4) = BAN4; | |
ENDIF; | ENDIF; | ||
ENDIF; | ENDIF; | ||
| + | |||
| + | |||
| + | // FLOAT FIELDS | ||
| + | IF T(Y) = 'F'; | ||
| + | |||
| + | IF Q(Y) = 4; | ||
| + | NUFA= *BLANKS; | ||
| + | FOR VX = 1 TO 14; | ||
| + | NUFA = %TRIM(NUFA) + K(VX); | ||
| + | ENDFOR; | ||
| + | |||
| + | result4 = %float(NUF1); | ||
| + | %SUBST(DATA : W : 4) = NUFW4; | ||
| + | |||
| + | ENDIF; | ||
| + | |||
| + | |||
| + | IF Q(Y) = 8; | ||
| + | NUFA= *BLANKS; | ||
| + | FOR VX = 1 TO 23; | ||
| + | NUFA = %TRIM(NUFA) + K(VX); | ||
| + | ENDFOR; | ||
| + | |||
| + | result8 = %float(NUF); | ||
| + | %SUBST(DATA : W : 8) = NUFW8; | ||
| + | |||
| + | ENDIF; | ||
| + | |||
| + | ENDIF; | ||
| + | |||
| + | |||
// UPDATE KEY IF NECESSARY | // UPDATE KEY IF NECESSARY | ||
| Line 7,668: | Line 7,758: | ||
** | ** | ||
0123456789ABCDEF | 0123456789ABCDEF | ||
| + | |||
</pre> | </pre> | ||
| Line 7,673: | Line 7,764: | ||
[[#top]] | [[#top]] | ||
| − | ===DUSP1 | + | ===DUSP1 RPG=== |
<pre> | <pre> | ||
| − | H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ | + | H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ |
H OPTION(*NODEBUGIO) | H OPTION(*NODEBUGIO) | ||
| − | H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME( | + | H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP1 ) |
F* | F* | ||
F* LIMITED TO MAXIMUM FILE LENGTH OF 4080 | F* LIMITED TO MAXIMUM FILE LENGTH OF 4080 | ||
F* REQUIRES FILE QTEMP/FFD TO COMPILE | F* REQUIRES FILE QTEMP/FFD TO COMPILE | ||
F* use cmd DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) | F* use cmd DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) | ||
| − | + | ||
FFFD IF E DISK | FFFD IF E DISK | ||
FDISPF CF F 803 WORKSTN | FDISPF CF F 803 WORKSTN | ||
| Line 7,693: | Line 7,784: | ||
FINPUTR UF A F32766 DISK EXTIND(*INU2) | FINPUTR UF A F32766 DISK EXTIND(*INU2) | ||
F INFDS(INFDR) | F INFDS(INFDR) | ||
| + | |||
| + | D DISBIN PR extpgm('DISBIN') | ||
| + | D NUM 15P 0 | ||
| + | D BAN2 2 | ||
| + | D BAN4 4 | ||
| + | D BINTYP 1 CONST | ||
* | * | ||
| Line 7,779: | Line 7,876: | ||
D NUPA 1 60 | D NUPA 1 60 | ||
D NUP 29 60P 0 | D NUP 29 60P 0 | ||
| + | |||
| + | D NUC S 15P 0 | ||
| + | D BAN2 S 2 | ||
| + | DCL D BAN4 S 4 | ||
D WRU S 61 | D WRU S 61 | ||
| Line 7,817: | Line 7,918: | ||
D DS | D DS | ||
| + | D DATA 1 4080 | ||
D D 1 4080 | D D 1 4080 | ||
D DIM(4080) INCOMING DATA | D DIM(4080) INCOMING DATA | ||
| Line 7,951: | Line 8,053: | ||
D KEYLNA 1 4 | D KEYLNA 1 4 | ||
| − | + | DDUSP1 PR | |
D 1 | D 1 | ||
D 1 | D 1 | ||
| Line 7,959: | Line 8,061: | ||
D 5 | D 5 | ||
D 800 | D 800 | ||
| − | + | DDUSP1 PI | |
D ALL 1 | D ALL 1 | ||
D RTN 1 | D RTN 1 | ||
| Line 8,702: | Line 8,804: | ||
BEGSR @PUTF; | BEGSR @PUTF; | ||
| − | // | + | SELECT; |
| + | WHEN *INU1; | ||
| + | RRN = RN1; | ||
| + | WHEN *INU2; | ||
| + | RRN = RN2; | ||
| + | ENDSL; | ||
| + | // IF GOT RECORDS WRITE DATA TO THE DISPLAY | ||
| − | + | NEWRU = '1'; | |
| − | + | WRTRRN = '1'; | |
RU = *ALLX'00'; | RU = *ALLX'00'; | ||
CLEAR RU; // initialise Request Unit 255 bytes max | CLEAR RU; // initialise Request Unit 255 bytes max | ||
| + | |||
| + | IF RRN > 0 ; | ||
FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | ||
| Line 8,718: | Line 8,828: | ||
WRTRRN = '0'; | WRTRRN = '0'; | ||
RU = RU + SBA + RBA ; | RU = RU + SBA + RBA ; | ||
| − | |||
| − | |||
| − | |||
| − | |||
| − | |||
| − | |||
RU = RU + %TRIM(%EDITC(RRN:'Z')); | RU = RU + %TRIM(%EDITC(RRN:'Z')); | ||
ENDIF; | ENDIF; | ||
| Line 8,876: | Line 8,980: | ||
ENDFOR; | ENDFOR; | ||
| + | ENDIF; | ||
IF %LEN(RU) > 5 AND %LEN(RU) < 250; | IF %LEN(RU) > 5 AND %LEN(RU) < 250; | ||
| Line 9,631: | Line 9,736: | ||
// BINARY FIELDS | // BINARY FIELDS | ||
IF T(Y) = 'B'; | IF T(Y) = 'B'; | ||
| + | |||
| + | NUSA= *BLANKS; | ||
| + | FOR VX = 1 TO 60; | ||
| + | NUSA = %TRIM(NUSA) + NU(VX); | ||
| + | ENDFOR; | ||
| + | NUC = NUS; | ||
IF Q(Y) = 2 ; | IF Q(Y) = 2 ; | ||
| − | + | DISBIN ( NUC : BAN2 : BAN4 : '2'); | |
| − | + | %SUBST(DATA : W : 2) = BAN2; | |
ENDIF; | ENDIF; | ||
IF Q(Y) = 4 ; | IF Q(Y) = 4 ; | ||
| − | + | DISBIN ( NUC : BAN2 : BAN4 : '4'); | |
| − | + | %SUBST(DATA : W : 4) = BAN4; | |
ENDIF; | ENDIF; | ||
| Line 9,666: | Line 9,777: | ||
OINPUTK E U1 UPDATREC | OINPUTK E U1 UPDATREC | ||
| − | O DA | + | O DA |
O 30 DB | O 30 DB | ||
O 31 DC | O 31 DC | ||
| Line 9,732: | Line 9,843: | ||
O 93 D6A | O 93 D6A | ||
OINPUTR E U2 UPDATREC | OINPUTR E U2 UPDATREC | ||
| − | O DA | + | O DA |
O 30 DB | O 30 DB | ||
O 31 DC | O 31 DC | ||
| Line 9,799: | Line 9,910: | ||
OINPUTK EADD U1 ADDREC | OINPUTK EADD U1 ADDREC | ||
| − | O DA | + | O DA |
O 30 DB | O 30 DB | ||
O 31 DC | O 31 DC | ||
| Line 9,865: | Line 9,976: | ||
O 93 D6A | O 93 D6A | ||
OINPUTR EADD U2 ADDREC | OINPUTR EADD U2 ADDREC | ||
| − | O DA | + | O DA |
O 30 DB | O 30 DB | ||
O 31 DC | O 31 DC | ||
| Line 9,963: | Line 10,074: | ||
0123456789ABCDEF | 0123456789ABCDEF | ||
| − | |||
| − | |||
| − | |||
| − | |||
| − | |||
| − | |||
| − | |||
</pre> | </pre> | ||
| Line 9,975: | Line 10,079: | ||
[[#top]] | [[#top]] | ||
| − | === | + | ===DUSP2 RPG=== |
<pre> | <pre> | ||
| − | + | H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ | |
| − | + | H OPTION(*NODEBUGIO) | |
| − | + | H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP2 ) | |
| − | + | F* | |
| − | + | F* LIMITED TO MAXIMUM FILE LENGTH OF 6080 | |
| − | + | F* REQUIRES FILE QTEMP/FFD TO COMPILE | |
| − | + | F* use cmd DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) | |
| − | |||
| − | |||
| + | FFFD IF E DISK | ||
| + | FDISPF CF F 803 WORKSTN | ||
| + | F* | ||
| + | F INFDS(INFDS) | ||
| + | FINPUTK UF A F32766 800AIDISK KEYLOC(1) | ||
| + | F EXTIND(*INU1) | ||
| + | F INFDS(INFDK) | ||
| + | FINPUTR UF A F32766 DISK EXTIND(*INU2) | ||
| + | F INFDS(INFDR) | ||
| − | + | D DISBIN PR extpgm('DISBIN') | |
| + | D NUM 15P 0 | ||
| + | D BAN2 2 | ||
| + | D BAN4 4 | ||
| + | D BINTYP 1 CONST | ||
| − | + | * | |
| − | + | D A S 255 WORK RU | |
| − | + | D RU S 255 varying | |
| − | + | D RW S 1 ROW 1 byte binary | |
| − | + | D CL S 1 COL 1 byte binary | |
| − | + | D FNC S 1 | |
| − | + | D OUTLEN S 2 | |
| + | D INLEN S 2 | ||
| + | D IPL S 5 0 | ||
| + | D ROW S 3 0 | ||
| + | D XROW S 3 0 | ||
| + | D COL S 3 0 | ||
| + | D KEYSOK S 1 | ||
| + | D LENDSC S 3 0 | ||
| + | D LENWRK S 5 0 | ||
| + | D STRX S 5 0 | ||
| + | D ENDX S 5 0 | ||
| + | D VX S 5 0 | ||
| + | D X S 5 0 | ||
| + | D X1 S 5 0 | ||
| + | D X2 S 5 0 | ||
| + | D XX S 5 0 | ||
| + | D XP S 5 0 | ||
| + | D MX S 5 0 | ||
| + | D ONCE S 1 | ||
| + | D RBA S 2 | ||
| + | D LF S 5 0 | ||
| + | D ST S 5 0 | ||
| + | D Y S 5 0 | ||
| + | D Z S 5 0 | ||
| + | D OFF S 5 0 | ||
| + | D CGKY S 1 | ||
| + | D UPDDONE S 1 | ||
| + | D SUPZ S 1 | ||
| + | D NUMFLD S 5 0 | ||
| + | D WX S 5 0 | ||
| + | D NUMKEY S 5 0 | ||
| + | D NUMFKY S 5 0 | ||
| + | D SCRST S 10 | ||
| + | D SCRSTN S 1 | ||
| + | D KEYA S 800 | ||
| + | D RRNA S 11 0 | ||
| + | D RRN S 11 0 | ||
| + | D REHEAD S 1 | ||
| + | D NEWRU S 1 | ||
| + | D WRTRRN S 1 | ||
| + | D LVX S 5 0 | ||
| + | D LVL S 5 0 | ||
| + | D K1 S 5 0 | ||
| + | D K2 S 5 0 | ||
| + | D Z1 S 5 0 | ||
| + | D W S 5 0 | ||
| + | D WK2 S 2 | ||
| + | D MSSG S 32 | ||
| + | * | ||
| + | D BASE S 5 0 | ||
| + | D INZ S 1 | ||
| − | + | D FILE S 10 | |
| + | D LIB S 10 | ||
| + | D MBR S 10 | ||
| + | D RCDL S 5 0 | ||
| + | D ACCTP S 1 | ||
| + | D RLEN S 5 0 | ||
| + | D RLENTH S 5 | ||
| + | D LENF S 5 0 | ||
| − | |||
| − | + | D DS | |
| + | D TEXT500 500 | ||
| + | D LVW 10 DIM(50) overlay(TEXT500:1) | ||
| − | + | D TEXT800 S 800 | |
| + | D KW S 800 | ||
| − | + | D DS | |
| + | D WRK11 1 11 | ||
| + | D NUM11 1 11S 0 | ||
| − | + | D DS | |
| + | D NUSA 1 60 | ||
| + | D NUS 1 60S 0 | ||
| + | D DS | ||
| + | D NUPA 1 60 | ||
| + | D NUP 29 60P 0 | ||
| − | + | D NUC S 15P 0 | |
| + | D BAN2 S 2 | ||
| + | DCL D BAN4 S 4 | ||
| − | |||
| − | + | D WRU S 61 | |
| + | D WRX S 64 | ||
| + | D WRXWRD C '0 - | ||
| + | D -' | ||
| + | D WRSWRD C '0 - | ||
| + | D -' | ||
| + | D WRV S 60 varying | ||
| − | + | D FLT14 S 14 | |
| + | D FLT23 S 23 | ||
| − | + | * SET FILE SIZE INCREMENTS (64 OF THEM) | |
| − | + | D SZ S 5 0 DIM(64) | |
| − | + | D S S 5 0 DIM(9000) START OF FLD | |
| − | + | D E S 5 0 DIM(9000) END OF FLD | |
| − | + | D Q S 5 0 DIM(9000) BYTES IN FIELD | |
| − | + | D L S 5 0 DIM(9000) LENGTH OF FLD | |
| − | + | D C S 3 0 DIM(9000) DEC DIGITS | |
| − | + | D P S 3 0 DIM(9000) DEC PRECISION | |
| − | + | D B S 2 DIM(9000) ASCEND BUFFER ADD | |
| − | + | D I S 2 DIM(9000) FLD FMT | |
| − | + | D N S 10 DIM(9000) FLD NAME | |
| − | + | D T S 1 DIM(9000) FLD TYPE | |
| − | + | D V S 1 DIM(9000) VARYING | |
| − | + | D KY S 1 DIM(9000) KEYED | |
| − | + | D KE S 10 DIM(128) KEY FLDS | |
| − | + | D R S 3 0 DIM(9000) KEY FLD START | |
| − | + | D K S 1 DIM(800) KEY | |
| − | + | D NA S 1 DIM(10) NAME WORK | |
| − | + | D NU S 1 DIM(60) NUM. WORK | |
| − | + | D LV S 10 DIM(50) SCREEN LEVELS | |
| − | + | D MSG S 32 DIM(8) CTDATA PERRCD(1) MESSAGES | |
| − | + | D CNS S 79 DIM(2) CTDATA PERRCD(1) | |
| − | + | D CRS S 1 DIM(16) CTDATA PERRCD(16) | |
| − | + | D DS | |
| − | + | D DATA 1 6080 | |
| − | + | D D 1 6080 | |
| − | + | D DIM(6080) INCOMING DATA | |
| − | + | D DA 1 4048 | |
| − | + | D DIM(4048) | |
| − | + | D DB 4049 4064 | |
| − | + | D DC 4065 4096 | |
| − | + | D DD 4097 4128 | |
| − | + | D DE 4129 4160 | |
| − | + | D DF 4161 4192 | |
| − | + | D DG 4193 4224 | |
| − | + | D DH 4225 4256 | |
| − | + | D DI 4257 4288 | |
| + | D DJ 4289 4320 | ||
| + | D DK 4321 4352 | ||
| + | D DL 4353 4384 | ||
| + | D DM 4385 4416 | ||
| + | D DN 4417 4448 | ||
| + | D DZ 4449 4480 | ||
| + | D DO 4481 4512 | ||
| + | D DP 4513 4544 | ||
| + | D DQ 4545 4576 | ||
| + | D DR 4577 4608 | ||
| + | D DS 4609 4640 | ||
| + | D DT 4641 4672 | ||
| + | D DU 4673 4704 | ||
| + | D DV 4705 4736 | ||
| + | D DW 4737 4768 | ||
| + | D DX 4769 4800 | ||
| + | D DY 4801 4832 | ||
| + | D D0 4833 4864 | ||
| + | D D1 4865 4896 | ||
| + | D D2 4897 4928 | ||
| + | D D3 4929 4960 | ||
| + | D D4 4961 4992 | ||
| + | D D5 4993 5024 | ||
| + | D D6 5025 5056 | ||
| + | D DBA 5057 5088 | ||
| + | D DCA 5089 5120 | ||
| + | D DDA 5121 5152 | ||
| + | D DEA 5153 5184 | ||
| + | D DFA 5185 5216 | ||
| + | D DGA 5217 5248 | ||
| + | D DHA 5249 5280 | ||
| + | D DIA 5281 5312 | ||
| + | D DJA 5313 5344 | ||
| + | D DKA 5345 5376 | ||
| + | D DLA 5377 5408 | ||
| + | D DMA 5409 5440 | ||
| + | D DNA 5441 5472 | ||
| + | D DOA 5473 5504 | ||
| + | D DPA 5505 5536 | ||
| + | D DQA 5537 5568 | ||
| + | D DRA 5569 5600 | ||
| + | D DSA 5601 5632 | ||
| + | D DTA 5633 5664 | ||
| + | D DUA 5665 5696 | ||
| + | D DVA 5697 5728 | ||
| + | D DWA 5729 5760 | ||
| + | D DXA 5761 5792 | ||
| + | D DYA 5793 5824 | ||
| + | D DZA 5825 5856 | ||
| + | D D0A 5857 5888 | ||
| + | D D1A 5889 5920 | ||
| + | D D2A 5921 5952 | ||
| + | D D3A 5953 5984 | ||
| + | D D4A 5985 6016 | ||
| + | D D5A 6017 6048 | ||
| + | D D6A 6049 6080 | ||
| + | D DS | ||
| + | D ID 1 800 | ||
| + | D DIM(800) INCOMING DATA | ||
| + | D IDA 1 800 | ||
| + | D ID0 1 80 | ||
| + | D ID1 81 160 | ||
| + | D ID2 161 240 | ||
| + | D ID3 241 320 | ||
| + | D ID4 321 400 | ||
| + | D ID5 401 480 | ||
| + | D ID6 481 560 | ||
| + | D ID7 561 640 | ||
| + | D ID8 641 720 | ||
| + | D ID9 721 800 | ||
| + | D DS | ||
| + | D BIN 1 2B 0 | ||
| + | D HX1 2 2 | ||
| + | D HX2 1 2 | ||
| + | D DS | ||
| + | D PCK 1 1P 0 | ||
| + | D PCK1 1 1 | ||
| + | D DS | ||
| + | D SGN 1 1S 0 | ||
| + | D SGN1 1 1 | ||
| − | + | D DS | |
| + | D BIN4 1 4B 0 | ||
| + | D BY4 1 4 | ||
| − | + | D DS | |
| + | D BIN2 1 2B 0 | ||
| + | D BY2 1 2 | ||
| − | + | D DS | |
| + | D FLT4 1 4F | ||
| + | D FL4 1 4 | ||
| − | [[#top]] | + | D DS |
| − | + | D FLT8 1 8F | |
| − | === | + | D FL8 1 8 |
| + | |||
| + | D INFDK DS | ||
| + | D F1 83 92 | ||
| + | D L1 93 102 | ||
| + | D M1 129 138 | ||
| + | D R1 125 126B 0 | ||
| + | D A1 160 160 | ||
| + | D LOP1 260 260 | ||
| + | D KEY_LEN 393 394I 0 Key length | ||
| + | D RN1 397 400B 0 | ||
| + | D LKY 401 1200 | ||
| + | D INFDR DS | ||
| + | D F2 83 92 | ||
| + | D L2 93 102 | ||
| + | D M2 129 138 | ||
| + | D R2 125 126B 0 | ||
| + | D A2 160 160 | ||
| + | D LOP2 260 260 | ||
| + | D RN2 397 400B 0 | ||
| + | D* | ||
| + | D INFDS DS | ||
| + | D CURLOC 370 371 | ||
| + | D DS | ||
| + | D KEYLN 1 4S 0 | ||
| + | D KEYLNA 1 4 | ||
| + | |||
| + | DDUSP2 PR | ||
| + | D 1 | ||
| + | D 1 | ||
| + | D 4 | ||
| + | D 1 | ||
| + | D 500 | ||
| + | D 5 | ||
| + | D 800 | ||
| + | DDUSP2 PI | ||
| + | D ALL 1 | ||
| + | D RTN 1 | ||
| + | D KEYLNG 4 | ||
| + | D UPDF 1 | ||
| + | D SCNLV 500 | ||
| + | D SCNLVL 5 | ||
| + | D SCNKEY 800 | ||
| + | |||
| + | |||
| + | D @LOOP C '1' | ||
| + | D @FALSE C '0' | ||
| + | D @TRUE C '1' | ||
| + | |||
| + | D SND C X'71' SEND TO DISP | ||
| + | D SNR C X'73' SND/RCV | ||
| + | D RED C X'42' READ | ||
| + | D RDM C X'52' READ MTD | ||
| + | D ESC C X'04' ESCAPE | ||
| + | D CLR C X'40' CLEAR UNIT | ||
| + | D CC1 C X'00' CNTRL CHAR | ||
| + | D CC2 C X'08' CNTRL CHAR | ||
| + | D SBA C X'11' SET BUFF ADR | ||
| + | D IC C X'13' INSERT CURS | ||
| + | D WTD C X'11' WRITE TO DSP | ||
| + | D WER C X'21' WRITE ERROR | ||
| + | D SF C X'1D' START FLD | ||
| + | D ATC C X'20' ATTR CHAR | ||
| + | D ATN C X'24' ATTR NUM | ||
| + | D X00 C X'00' | ||
| + | D X01 C X'01' | ||
| + | D X02 C X'02' | ||
| + | D X03 C X'03' | ||
| + | D X0D C X'0D' | ||
| + | D X0F C X'0F' | ||
| + | D X000 C X'0000' | ||
| + | D X1F C X'1F' | ||
| + | D X20 C X'20' SCRN ATT NORMAL | ||
| + | D X22 C X'22' SCRN ATTR HI | ||
| + | D X25 C X'25' | ||
| + | D X26 C X'26' | ||
| + | D X31 C X'31' CMD 1 KEY | ||
| + | D X32 C X'32' CMD 2 KEY | ||
| + | D X33 C X'33' CMD 3 KEY | ||
| + | D X36 C X'36' CMD 6 KEY | ||
| + | D X37 C X'37' CMD 7 KEY | ||
| + | D X38 C X'38' CMD 8 KEY | ||
| + | D X39 C X'39' CMD 9 KEY | ||
| + | D X3B C X'3B' CMD11 KEY | ||
| + | D XB7 C X'B7' CMD19 KEY | ||
| + | D XB8 C X'B8' CMD20 KEY | ||
| + | D X40 C X'40' | ||
| + | D X43 C X'43' | ||
| + | D X47 C X'47' | ||
| + | D X60 C X'60' | ||
| + | D X67 C X'67' | ||
| + | D X9F C X'9F' | ||
| + | D XF0 C X'F0' | ||
| + | D XD0 C X'D0' | ||
| + | D X4000 C X'4000' | ||
| + | D X4800 C X'4800' FF ALPHA | ||
| + | D X4F06 C X'4F06' FF NUMERIC | ||
| + | D X6000 C X'6000' FF ALPHA | ||
| + | D X6706 C X'6706' FF NUMERIC | ||
| + | D CLRWTD C X'044004112000' INCLUDES ESC CHARS | ||
| + | D RDDSP C X'0411200804524000' READ FROM DISPLAY | ||
| + | D FFA1 S 1 INZ(X'40') F.FMT 1 ALPH 60 BYP | ||
| + | D FFA2 S 1 INZ(X'00') F.FMT 2 ALPH | ||
| + | D FFN1 S 1 INZ(X'47') F.FMT 1 NUM 67 BYP | ||
| + | D FFN2 S 1 INZ(X'06') F.FMT 2 NUM | ||
| + | I*. | ||
| + | |||
| + | 0038 IINPUTK NS 01 | ||
| + | 0039 I 1 4048 DA | ||
| + | 0040 I 4049 4064 DB 30 | ||
| + | 0041 I 4065 4096 DC 31 | ||
| + | 0042 I 4097 4128 DD 32 | ||
| + | 0043 I 4129 4160 DE 33 | ||
| + | 0044 I 4161 4192 DF 34 | ||
| + | 0045 I 4193 4224 DG 35 | ||
| + | 0046 I 4225 4256 DH 36 | ||
| + | 0047 I 4257 4288 DI 37 | ||
| + | 0048 I 4289 4320 DJ 38 | ||
| + | 0049 I 4321 4352 DK 39 | ||
| + | 0050 I 4353 4384 DL 40 | ||
| + | 0051 I 4385 4416 DM 41 | ||
| + | 0052 I 4417 4448 DN 42 | ||
| + | 0053 I 4449 4480 DZ 43 | ||
| + | 0054 I 4481 4512 DO 44 | ||
| + | 0055 I 4513 4544 DP 45 | ||
| + | 0056 I 4545 4576 DQ 46 | ||
| + | 0057 I 4577 4608 DR 47 | ||
| + | 0058 I 4609 4640 DS 48 | ||
| + | 0059 I 4641 4672 DT 49 | ||
| + | 0060 I 4673 4704 DU 50 | ||
| + | 0061 I 4705 4736 DV 51 | ||
| + | 0062 I 4737 4768 DW 52 | ||
| + | 0063 I 4769 4800 DX 53 | ||
| + | 0064 I 4801 4832 DY 54 | ||
| + | 0065 I 4833 4864 D0 55 | ||
| + | 0066 I 4865 4896 D1 56 | ||
| + | 0067 I 4897 4928 D2 57 | ||
| + | 0068 I 4929 4960 D3 58 | ||
| + | 0069 I 4961 4992 D4 59 | ||
| + | 0070 I 4993 5024 D5 60 | ||
| + | 0071 I 5025 5056 D6 61 | ||
| + | 0072 I 5057 5088 DBA 62 | ||
| + | 0073 I 5089 5120 DCA 63 | ||
| + | 0074 I 5121 5152 DDA 64 | ||
| + | 0075 I 5153 5184 DEA 65 | ||
| + | 0076 I 5185 5216 DFA 66 | ||
| + | 0077 I 5217 5248 DGA 67 | ||
| + | 0078 I 5249 5280 DHA 68 | ||
| + | 0079 I 5281 5312 DIA 69 | ||
| + | 0080 I 5313 5344 DJA 70 | ||
| + | 0081 I 5345 5376 DKA 71 | ||
| + | 0082 I 5377 5408 DLA 72 | ||
| + | 0083 I 5409 5440 DMA 73 | ||
| + | 0084 I 5441 5472 DNA 74 | ||
| + | 0085 I 5473 5504 DOA 75 | ||
| + | 0086 I 5505 5536 DPA 76 | ||
| + | 0087 I 5537 5568 DQA 77 | ||
| + | 0088 I 5569 5600 DRA 78 | ||
| + | 0089 I 5601 5632 DSA 79 | ||
| + | 0090 I 5633 5664 DTA 80 | ||
| + | 0091 I 5665 5696 DUA 81 | ||
| + | 0092 I 5697 5728 DVA 82 | ||
| + | 0093 I 5729 5760 DWA 83 | ||
| + | 0094 I 5761 5792 DXA 84 | ||
| + | 0095 I 5793 5824 DYA 85 | ||
| + | 0096 I 5825 5856 DZA 86 | ||
| + | 0097 I 5857 5888 D0A 87 | ||
| + | 0098 I 5889 5920 D1A 88 | ||
| + | 0099 I 5921 5952 D2A 89 | ||
| + | 0100 I 5953 5984 D3A 90 | ||
| + | 0101 I 5985 6016 D4A 91 | ||
| + | 0102 I 6017 6048 D5A 92 | ||
| + | 0103 I 6049 6080 D6A 93 | ||
| + | 0104 IINPUTR NS 01 | ||
| + | 0105 I 1 4048 DA | ||
| + | 0106 I 4049 4064 DB 30 | ||
| + | 0107 I 4065 4096 DC 31 | ||
| + | 0108 I 4097 4128 DD 32 | ||
| + | 0109 I 4129 4160 DE 33 | ||
| + | 0110 I 4161 4192 DF 34 | ||
| + | 0111 I 4193 4224 DG 35 | ||
| + | 0112 I 4225 4256 DH 36 | ||
| + | 0113 I 4257 4288 DI 37 | ||
| + | 0114 I 4289 4320 DJ 38 | ||
| + | 0115 I 4321 4352 DK 39 | ||
| + | 0116 I 4353 4384 DL 40 | ||
| + | 0117 I 4385 4416 DM 41 | ||
| + | 0118 I 4417 4448 DN 42 | ||
| + | 0119 I 4449 4480 DZ 43 | ||
| + | 0120 I 4481 4512 DO 44 | ||
| + | 0121 I 4513 4544 DP 45 | ||
| + | 0122 I 4545 4576 DQ 46 | ||
| + | 0123 I 4577 4608 DR 47 | ||
| + | 0124 I 4609 4640 DS 48 | ||
| + | 0125 I 4641 4672 DT 49 | ||
| + | 0126 I 4673 4704 DU 50 | ||
| + | 0127 I 4705 4736 DV 51 | ||
| + | 0128 I 4737 4768 DW 52 | ||
| + | 0129 I 4769 4800 DX 53 | ||
| + | 0130 I 4801 4832 DY 54 | ||
| + | 0131 I 4833 4864 D0 55 | ||
| + | 0132 I 4865 4896 D1 56 | ||
| + | 0133 I 4897 4928 D2 57 | ||
| + | 0134 I 4929 4960 D3 58 | ||
| + | 0135 I 4961 4992 D4 59 | ||
| + | 0136 I 4993 5024 D5 60 | ||
| + | 0137 I 5025 5056 D6 61 | ||
| + | 0138 I 5057 5088 DBA 62 | ||
| + | 0139 I 5089 5120 DCA 63 | ||
| + | 0140 I 5121 5152 DDA 64 | ||
| + | 0141 I 5153 5184 DEA 65 | ||
| + | 0142 I 5185 5216 DFA 66 | ||
| + | 0143 I 5217 5248 DGA 67 | ||
| + | 0144 I 5249 5280 DHA 68 | ||
| + | 0145 I 5281 5312 DIA 69 | ||
| + | 0146 I 5313 5344 DJA 70 | ||
| + | 0147 I 5345 5376 DKA 71 | ||
| + | 0148 I 5377 5408 DLA 72 | ||
| + | 0149 I 5409 5440 DMA 73 | ||
| + | 0150 I 5441 5472 DNA 74 | ||
| + | 0151 I 5473 5504 DOA 75 | ||
| + | 0152 I 5505 5536 DPA 76 | ||
| + | 0153 I 5537 5568 DQA 77 | ||
| + | 0154 I 5569 5600 DRA 78 | ||
| + | 0155 I 5601 5632 DSA 79 | ||
| + | 0156 I 5633 5664 DTA 80 | ||
| + | 0157 I 5665 5696 DUA 81 | ||
| + | 0158 I 5697 5728 DVA 82 | ||
| + | 0159 I 5729 5760 DWA 83 | ||
| + | 0160 I 5761 5792 DXA 84 | ||
| + | 0161 I 5793 5824 DYA 85 | ||
| + | 0162 I 5825 5856 DZA 86 | ||
| + | 0163 I 5857 5888 D0A 87 | ||
| + | 0164 I 5889 5920 D1A 88 | ||
| + | 0165 I 5921 5952 D2A 89 | ||
| + | 0166 I 5953 5984 D3A 90 | ||
| + | 0167 I 5985 6016 D4A 91 | ||
| + | 0168 I 6017 6048 D5A 92 | ||
| + | 0169 I 6049 6080 D6A 93 | ||
| + | IDISPF NS 02 | ||
| + | I 3 3 AID | ||
| + | I 4 83 ID0 | ||
| + | I 84 163 ID1 20 | ||
| + | I 164 243 ID2 21 | ||
| + | I 244 323 ID3 22 | ||
| + | I 324 403 ID4 23 | ||
| + | I 404 483 ID5 24 | ||
| + | I 484 563 ID6 25 | ||
| + | I 564 643 ID7 26 | ||
| + | I 644 723 ID8 27 | ||
| + | I 724 803 ID9 28 | ||
| + | |||
| + | |||
| + | /FREE | ||
| + | BASE = 4048; | ||
| + | |||
| + | IF ONCE = ' '; | ||
| + | EXSR @INITZ ; | ||
| + | ENDIF; | ||
| + | |||
| + | // START TAG | ||
| + | DOW @LOOP = @LOOP; | ||
| + | |||
| + | IF RTN = '3'; | ||
| + | |||
| + | IF *INU1; | ||
| + | KEYA = SCNKEY; | ||
| + | ENDIF; | ||
| + | IF *INU2; | ||
| + | RRNA = %DEC(%SUBST(SCNKEY:1:11):11:0); | ||
| + | ENDIF; | ||
| + | RTN = '0'; | ||
| + | AID = '1'; | ||
| + | ELSE; | ||
| + | RTN = '0'; | ||
| + | READ(E) DISPF; | ||
| + | ENDIF; | ||
| + | |||
| + | // CF3 EXIT | ||
| + | IF AID = X33; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | // CF2 RETURN | ||
| + | IF AID = X32; | ||
| + | RTN = '1'; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | // CF1 HEX A FIELD | ||
| + | IF AID = X31; | ||
| + | Y = %LOOKUPLE( CURLOC : B ); | ||
| + | IF Y > 0; | ||
| + | IF KY(Y) <= '1'; | ||
| + | EXSR @HXDSP; | ||
| + | REHEAD = '1'; | ||
| + | EXSR @PUTHED; | ||
| + | REHEAD = ' '; | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | |||
| + | // CF20 MORE FIELDS | ||
| + | IF AID = XB8; | ||
| + | |||
| + | LVX = LVL + 1; | ||
| + | IF LV(LVX) <> *BLANK; | ||
| + | LVL = LVL +1 ; | ||
| + | |||
| + | LVW = LV; | ||
| + | SCNLV = TEXT500; | ||
| + | SCNLVL = %EDITC(LVL :'X'); | ||
| + | |||
| + | SCNKEY = *BLANKS; | ||
| + | IF *INU1; | ||
| + | SCNKEY = KEYA; | ||
| + | ENDIF; | ||
| + | IF *INU2; | ||
| + | SCNKEY = %EDITC(RRNA:'X'); | ||
| + | ENDIF; | ||
| + | |||
| + | RTN = '3'; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | |||
| + | // CF19 PREVIOUS FIELDS | ||
| + | IF AID = XB7; | ||
| + | |||
| + | LVX = LVL - 1; | ||
| + | IF LVX >= 0 ; | ||
| + | LVL = LVL - 1 ; | ||
| + | |||
| + | LVW = LV; | ||
| + | SCNLV = TEXT500; | ||
| + | SCNLVL = %EDITC(LVL :'X'); | ||
| + | |||
| + | SCNKEY = *BLANKS; | ||
| + | IF *INU1; | ||
| + | SCNKEY = KEYA; | ||
| + | ENDIF; | ||
| + | IF *INU2; | ||
| + | SCNKEY = %EDITC(RRNA:'X'); | ||
| + | ENDIF; | ||
| + | |||
| + | RTN = '3'; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | |||
| + | // 1 ENTER 4 ROLL DN 5 ROLL UP | ||
| + | // F6 = X36 F9 = X39 F11 = X3B | ||
| + | IF AID = '1'or AID = '4' or AID = '5' or | ||
| + | AID = X36 or AID = X39 or AID = X3B; | ||
| + | ELSE; | ||
| + | MX = 1; // INVALID KEY | ||
| + | EXSR @ERROR; | ||
| + | ENDIF; | ||
| + | |||
| + | // UPDATE MODE | ||
| + | IF UPDF = 'Y'; | ||
| + | UPDDONE = @FALSE; | ||
| + | // F6 | ||
| + | IF *INU1 AND AID = X36 AND | ||
| + | (LOP1 = X01 OR LOP1 = X03); | ||
| + | EXSR @UPD; | ||
| + | EXCEPT UPDATREC; | ||
| + | UPDDONE = @TRUE; | ||
| + | ENDIF; | ||
| + | |||
| + | IF *INU2 AND AID = X36 AND | ||
| + | (LOP2 = X01 OR LOP2 = X02); | ||
| + | EXSR @UPD; | ||
| + | EXCEPT UPDATREC; | ||
| + | UPDDONE = @TRUE; | ||
| + | ENDIF; | ||
| + | |||
| + | // F9 | ||
| + | IF AID = X39; | ||
| + | EXSR @UPD; | ||
| + | EXCEPT ADDREC; | ||
| + | UPDDONE = @TRUE; | ||
| + | ENDIF; | ||
| + | |||
| + | // F11 | ||
| + | IF *INU1 AND AID = X3B AND | ||
| + | (LOP1 = X01 OR LOP1 = X03); | ||
| + | EXCEPT DELREC; | ||
| + | UPDDONE = @TRUE; | ||
| + | ENDIF; | ||
| + | |||
| + | IF *INU2 AND AID = X3B AND | ||
| + | (LOP2 = X01 OR LOP2 = X02); | ||
| + | EXCEPT DELREC; | ||
| + | UPDDONE = @TRUE; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDIF; | ||
| + | |||
| + | |||
| + | IF RTN = '3' OR UPDDONE = @TRUE; | ||
| + | ELSE; | ||
| + | EXSR @PCKD; | ||
| + | ENDIF; | ||
| + | |||
| + | |||
| + | // CONT1 GET A RECORD, KEY FROM DATA | ||
| + | EXSR @SETIN; | ||
| + | EXSR @GETF ; | ||
| + | EXSR @PUTF ; | ||
| + | EXSR @KEYIN; | ||
| + | |||
| + | ENDDO ; | ||
| + | |||
| + | *INLR = *ON; | ||
| + | |||
| + | // @@@@@@@ @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@ | ||
| + | BEGSR @INITZ; | ||
| + | ONCE = '1'; | ||
| + | KEYLNA = KEYLNG ; | ||
| + | EXSR @INIT ; | ||
| + | EXSR @GETFLD ; | ||
| + | EXSR @GETADD ; | ||
| + | EXSR @PUTHED ; | ||
| + | EXSR @KEYIN ; | ||
| + | INZ = '1'; | ||
| + | EXSR @PCKD ; | ||
| + | INZ = ' '; | ||
| + | ENDSR; | ||
| + | |||
| + | // @@@@@@@ @PCKD @@@@@@@@@@@@@@@@@@@@@@@@@@ | ||
| + | |||
| + | BEGSR @PCKD ; | ||
| + | |||
| + | // CONVERT KEY DATA | ||
| + | IF *INU1 ; | ||
| + | EXSR @CVTKEY; | ||
| + | ENDIF; | ||
| + | IF *INU2 ; | ||
| + | EXSR @CVTRRN; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDSR; | ||
| + | |||
| + | // @@@@@@@ @CVTKEY @@@@@@@@@@@@@@@@@@@@@@@@ | ||
| + | |||
| + | BEGSR @CVTKEY; | ||
| + | |||
| + | // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING | ||
| + | |||
| + | // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE | ||
| + | // THE MODIFIED DATA INTO THE COMPOSITE KEY | ||
| + | |||
| + | K1 = 0; | ||
| + | K2 = 0; | ||
| + | W = 1; | ||
| + | |||
| + | FOR Y = 1 TO NUMKEY ; | ||
| + | |||
| + | // MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS) | ||
| + | |||
| + | // GET SIZE OF FIELD IN BYTES | ||
| + | IF T(Y) = 'A'; // ALPHA DATA | ||
| + | K = ' '; | ||
| + | K1 = 1; | ||
| + | K2 = Q(Y); | ||
| + | ELSE; | ||
| + | K = '0'; | ||
| + | K1 = 1; | ||
| + | K2 = C(Y); | ||
| + | ENDIF; | ||
| + | |||
| + | // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT | ||
| + | IF INZ = '1' ; | ||
| + | KW = *BLANK; | ||
| + | EXSR @PCKMOV; | ||
| + | ITER; | ||
| + | ENDIF; | ||
| + | |||
| + | X = 1; | ||
| + | |||
| + | DOW @LOOP = @LOOP; | ||
| + | |||
| + | // NXTSBA | ||
| + | X = %LOOKUP(SBA : ID : X ); | ||
| + | IF X = 0; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | // IS THIS THE FIELD? CHECK THE BUFFER ADDRESS | ||
| + | X = X +1; | ||
| + | IF B(Y) <> %SUBST(IDA : X :2); | ||
| + | ITER; | ||
| + | ENDIF; | ||
| + | |||
| + | // FOUND A MTD FOR THIS FIELD | ||
| + | X = X + 2; | ||
| + | |||
| + | // CHECK IF FIELD WAS CLEARED ONLY | ||
| + | IF ID(X) = SBA; | ||
| + | EXSR @PCKMOV; | ||
| + | LEAVE ; | ||
| + | ENDIF; | ||
| + | |||
| + | // IF FIELD HAS DECIMALS BUMP X | ||
| + | IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND | ||
| + | P(Y) > 0; | ||
| + | X = X + 1; | ||
| + | ENDIF; | ||
| + | |||
| + | // CHECK IF ONLY BLANKS RETURNED | ||
| + | IF %SUBST(IDA : X :K2) = *BLANKS; | ||
| + | EXSR @PCKMOV; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | // EXTRACT THE DATA FROM THE INCOMING STRING | ||
| + | X1 = X; | ||
| + | FOR X2 = 1 TO K2 ; | ||
| + | |||
| + | IF ID(X1) < ' '; | ||
| + | // TRAP NULLS CAUSED BY FLD EXIT | ||
| + | EXSR @PCKMOV; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | K(X2) = ID(X1); | ||
| + | X1 = X1 +1; | ||
| + | ENDFOR; | ||
| + | |||
| + | // CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED | ||
| + | // INTO ARRAY KW | ||
| + | EXSR @PCKMOV; | ||
| + | LEAVE; | ||
| + | ENDDO; | ||
| + | |||
| + | ENDFOR; | ||
| + | |||
| + | // | ||
| + | KEYA = KW; | ||
| + | CLEAR KW; | ||
| + | ENDSR ; | ||
| + | |||
| + | // @@@@@@@ @CVTRRN @@@@@@@@@@@@@@@@@@@@@@@@ | ||
| + | |||
| + | BEGSR @CVTRRN; | ||
| + | |||
| + | // RRN | ||
| + | |||
| + | NUM11 = 0; | ||
| + | |||
| + | DOW @LOOP = @LOOP; // NOT REALLY A LOOP(SIMULATES GOTO) | ||
| + | |||
| + | // GET THE FIRST SBA | ||
| + | X = 1; | ||
| + | X = %LOOKUP(SBA : ID : X ); | ||
| + | IF X = 0; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | // CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD | ||
| + | X = X +1; | ||
| + | IF B(1) <> %SUBST(IDA : X :2); | ||
| + | ITER; | ||
| + | ENDIF; | ||
| + | |||
| + | // FOUND A MTD FOR RRN FIELD | ||
| + | X = X +2; | ||
| + | |||
| + | //CHECK IF FIELD WAS CLEARED ONLY | ||
| + | IF ID(X) = SBA; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | // CHECK IF ONLY BLANKS RETURNED | ||
| + | IF %SUBST(IDA : X :11) = *BLANKS; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | |||
| + | // WRK11 OVERLAYS NUM11 | ||
| + | WRK11 = %SUBST(IDA : X :11); | ||
| + | |||
| + | LEAVE; | ||
| + | ENDDO; | ||
| + | |||
| + | |||
| + | RRNA = NUM11; | ||
| + | IF RRNA < 0; | ||
| + | RRNA = 1; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDSR; | ||
| + | |||
| + | // @@@@@@@ @PCKMOV @@@@@@@@@@@@@@@@@@@@@@@@ | ||
| + | |||
| + | BEGSR @PCKMOV; | ||
| + | // | ||
| + | // CONVERT KEY DATA | ||
| + | // SET START POSN IN KEY USING OFFSET IN R | ||
| + | X1 = %LOOKUP(N(Y) : N ); | ||
| + | W = R(X1) + 1; | ||
| + | |||
| + | // ALPHA | ||
| + | IF T(Y) = 'A'; | ||
| + | X1 = 1; | ||
| + | FOR Z = W TO W + Q(Y); | ||
| + | %SUBST(KW : Z : 1) = K(X1); | ||
| + | X1 = X1 + 1; | ||
| + | ENDFOR; | ||
| + | ENDIF; | ||
| + | |||
| + | // NUMERIC FIELD | ||
| + | // RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS | ||
| + | IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B'); | ||
| + | NU = '0'; | ||
| + | |||
| + | Z1 = 60; | ||
| + | FOR Z = K2 DOWNTO K1; | ||
| + | |||
| + | IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$'; | ||
| + | ITER; | ||
| + | ENDIF; | ||
| + | |||
| + | IF K(Z) = ' ' ; | ||
| + | NU(Z1) = '0'; | ||
| + | ELSE; | ||
| + | NU(Z1) = K(Z); | ||
| + | ENDIF; | ||
| + | |||
| + | Z1 = Z1 -1; | ||
| + | ENDFOR; | ||
| + | |||
| + | ENDIF; | ||
| + | |||
| + | // SIGNED FIELDS (END POSN = OFFSET + SIZE) | ||
| + | IF T(Y) = 'S'; | ||
| + | NUS = 0; | ||
| + | FOR VX = 1 TO 60; | ||
| + | NUSA = %TRIM(NUSA) + NU(VX); | ||
| + | ENDFOR; | ||
| + | %SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y)); | ||
| + | |||
| + | ENDIF; | ||
| + | |||
| + | // PACKED FIELDS | ||
| + | IF T(Y) = 'P'; | ||
| + | NUSA= *BLANKS; | ||
| + | FOR VX = 1 TO 60; | ||
| + | NUSA = %TRIM(NUSA) + NU(VX); | ||
| + | ENDFOR; | ||
| + | NUP = %DEC(NUSA : 60 : 0); | ||
| + | |||
| + | %SUBST(KW : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y)); | ||
| + | |||
| + | ENDIF; | ||
| + | |||
| + | // BINARY FIELDS | ||
| + | IF T(Y) = 'B'; | ||
| + | |||
| + | IF Q(Y) = 2 ; | ||
| + | BY2 = NU(1) + NU(2); | ||
| + | %SUBST(KW : W : 2) = BY2; | ||
| + | ENDIF; | ||
| + | |||
| + | IF Q(Y) = 4 ; | ||
| + | BY4 = NU(1) + NU(2) + NU(3) + NU(4); | ||
| + | %SUBST(KW : W : 4) = BY4; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDIF; | ||
| + | |||
| + | ENDSR; | ||
| + | |||
| + | |||
| + | // @@@@@@@ SETIN @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
| + | BEGSR @SETIN; | ||
| + | |||
| + | // SET the FFR indicators to get the Input buffer somewhat aligned with the | ||
| + | // actual data. RPG is somewhat tolerant to a difference between the Ispecs | ||
| + | // and the actual file size but it can fail on big differences. | ||
| + | // INCREMENT OF 32 BYTES | ||
| + | SZ(1) = BASE + 16; | ||
| + | SZ(2) = SZ(1) + 16; | ||
| + | |||
| + | *IN30 = *ON; | ||
| + | IF (RLEN > SZ(2)) ; | ||
| + | *IN31 = *ON; | ||
| + | ENDIF; | ||
| + | |||
| + | FOR X = 3 TO 64; | ||
| + | SZ(X) = SZ(X-1) + 32; | ||
| + | IF (RLEN > SZ(X)) ; | ||
| + | *IN(29+X) = *ON; | ||
| + | ENDIF; | ||
| + | ENDFOR; | ||
| + | ENDSR; | ||
| + | |||
| + | |||
| + | //@@@@@@@@@@@@@@@@@ @GETF @@@@@@@@@@@@@@@@@ | ||
| + | BEGSR @GETF; | ||
| + | // GET A DATA RECORD | ||
| + | IF (*INU1); | ||
| + | IF AID = '1' OR AID = X36 OR | ||
| + | AID = X39 OR AID = X3B ; | ||
| + | SETLL(E) KEYA INPUTK; | ||
| + | READ(E) INPUTK; | ||
| + | IF %EOF; | ||
| + | SETLL(E) KEYA INPUTK; | ||
| + | READP(E) INPUTK; | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | |||
| + | IF AID = '4'; | ||
| + | READP(E) INPUTK; | ||
| + | ENDIF; | ||
| + | |||
| + | IF AID = '5'; | ||
| + | READ(E) INPUTK; | ||
| + | ENDIF; | ||
| + | |||
| + | IF %ERROR; | ||
| + | SETLL(E) KEYA INPUTK; | ||
| + | READ(E) INPUTK; | ||
| + | MX = 7; | ||
| + | EXSR @ERROR; | ||
| + | EXSR @PUTF ; | ||
| + | EXSR @KEYIN; | ||
| + | ENDIF; | ||
| + | |||
| + | KEYA = LKY; | ||
| + | |||
| + | |||
| + | CLEAR KW; | ||
| + | KW = LKY; | ||
| + | |||
| + | ENDIF; | ||
| + | |||
| + | IF (*INU2); | ||
| + | IF AID = '1'; | ||
| + | CHAIN(E) RRNA INPUTR; | ||
| + | IF %ERROR; | ||
| + | SETLL(E) RRNA INPUTR; | ||
| + | READP(E) INPUTR; | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | |||
| + | IF AID = X36; | ||
| + | CHAIN(E) RRNA INPUTR; | ||
| + | ENDIF; | ||
| + | |||
| + | IF AID = '4'; | ||
| + | READP(E) INPUTR; | ||
| + | ENDIF; | ||
| + | |||
| + | IF AID = '5' OR AID = X3B; | ||
| + | READ(E) INPUTR; | ||
| + | ENDIF; | ||
| + | |||
| + | IF AID = X39; | ||
| + | SETLL(E) *HIVAL INPUTR; | ||
| + | READP(E) INPUTR; | ||
| + | ENDIF; | ||
| + | |||
| + | IF %ERROR; | ||
| + | CHAIN 1 INPUTR; | ||
| + | MX = 7; | ||
| + | EXSR @ERROR; | ||
| + | EXSR @PUTF ; | ||
| + | EXSR @KEYIN; | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDSR; | ||
| + | |||
| + | |||
| + | //@@@@@@@@@@@@@@@@@ @PUTF @@@@@@@@@@@@@@@@@ | ||
| + | BEGSR @PUTF; | ||
| + | |||
| + | SELECT; | ||
| + | WHEN *INU1; | ||
| + | RRN = RN1; | ||
| + | WHEN *INU2; | ||
| + | RRN = RN2; | ||
| + | ENDSL; | ||
| + | // IF GOT RECORDS WRITE DATA TO THE DISPLAY | ||
| + | |||
| + | NEWRU = '1'; | ||
| + | WRTRRN = '1'; | ||
| + | RU = *ALLX'00'; | ||
| + | CLEAR RU; // initialise Request Unit 255 bytes max | ||
| + | |||
| + | IF RRN > 0 ; | ||
| + | FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | ||
| + | |||
| + | IF NEWRU = '1'; | ||
| + | NEWRU = '0'; | ||
| + | RU = ESC + WTD + X20 + X00; | ||
| + | ENDIF; | ||
| + | |||
| + | IF WRTRRN = '1'; | ||
| + | WRTRRN = '0'; | ||
| + | RU = RU + SBA + RBA ; | ||
| + | RU = RU + %TRIM(%EDITC(RRN:'Z')); | ||
| + | ENDIF; | ||
| + | |||
| + | // BUFFER ADDRESS | ||
| + | RU = RU + SBA + B(XX); | ||
| + | |||
| + | // PROCESS ALPHA DATA TYPE | ||
| + | IF T(XX) = 'A' OR T(XX) = 'T' OR T(XX) = 'Z' OR | ||
| + | T(XX) = 'L'; | ||
| + | |||
| + | STRX = S(XX); | ||
| + | ENDX = E(XX); | ||
| + | |||
| + | IF V(XX) = 'Y'; //VARYING | ||
| + | VX = S(XX); | ||
| + | HX2 = D(VX) + D(VX+1); | ||
| + | STRX = S(XX) + 2 ; | ||
| + | ENDX = S(XX) + BIN; | ||
| + | ENDIF; | ||
| + | |||
| + | FOR Y = STRX TO ENDX ; | ||
| + | IF D(Y) >= ' '; | ||
| + | RU = RU + D(Y); | ||
| + | ELSE; | ||
| + | RU = RU + X1F ; //IF NOT DISPLAYABLE REPLACE WITH X'1F' | ||
| + | ENDIF; | ||
| + | ENDFOR; | ||
| + | ENDIF; | ||
| + | |||
| + | // PROCESS SIGNED DATA TYPE (not the RRN field) | ||
| + | IF T(XX) = 'S' and KY(XX) <> '3'; | ||
| + | NUSA = *ALL'0'; | ||
| + | WRV = *ALLX'00'; | ||
| + | CLEAR WRV; | ||
| + | FOR Y = S(XX) TO E(XX); | ||
| + | IF D(Y) >= XD0; | ||
| + | WRV = WRV + D(Y); | ||
| + | ENDIF; | ||
| + | ENDFOR; | ||
| + | EVAL NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV; | ||
| + | CLEAR WRU; | ||
| + | WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD); | ||
| + | IF P(XX) > 0; | ||
| + | RU = RU + | ||
| + | %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' + | ||
| + | %SUBST(WRU :61-P(XX)) ; | ||
| + | ELSE; | ||
| + | RU = RU + | ||
| + | %SUBST(WRU :61-C(XX)); | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | |||
| + | |||
| + | // PROCESS SIGNED DATA TYPE (the RRN field) | ||
| + | IF T(XX) = 'S' and KY(XX) = '3'; | ||
| + | RRN = RN2; | ||
| + | RU = RU + %TRIM(%EDITC(RRN:'X')); | ||
| + | ENDIF; | ||
| + | |||
| + | // PROCESS PACKED DATA TYPE | ||
| + | IF T(XX) = 'P'; | ||
| + | NUPA = *ALLX'00'; | ||
| + | WRV = *ALLX'00'; | ||
| + | CLEAR WRV; | ||
| + | FOR Y = S(XX) TO E(XX); | ||
| + | WRV = WRV + D(Y); | ||
| + | ENDFOR; | ||
| + | |||
| + | IF %BITAND(D(E(XX)) :X0F) = X0F OR | ||
| + | %BITAND(D(E(XX)) :X0D) = X0D; | ||
| + | |||
| + | EVAL NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV; | ||
| + | CLEAR WRX; | ||
| + | WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD); | ||
| + | IF P(XX) > 0; | ||
| + | RU = RU + | ||
| + | %SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' + | ||
| + | %SUBST(WRX :64-P(XX)) ; | ||
| + | ELSE; | ||
| + | RU = RU + | ||
| + | %SUBST(WRX :64-C(XX)); | ||
| + | ENDIF; | ||
| + | ELSE; | ||
| + | // PACKED FIELD IN ERROR | ||
| + | RU = RU + X1F; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDIF; | ||
| + | |||
| + | // PROCESS BINARY DATA TYPE | ||
| + | IF T(XX) = 'B'; | ||
| + | |||
| + | ST = S(XX); | ||
| + | CLEAR NUSA; | ||
| + | IF Q(XX) = 2; | ||
| + | BY2 = D(ST) + D(ST+1); | ||
| + | NUS = BIN2; | ||
| + | ENDIF; | ||
| + | IF Q(XX) = 4; | ||
| + | BY4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3); | ||
| + | NUS = BIN4; | ||
| + | ENDIF; | ||
| + | |||
| + | WRU = %EDITW(NUS :WRSWRD); | ||
| + | IF P(XX) > 0; | ||
| + | RU = RU + | ||
| + | %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' + | ||
| + | %SUBST(WRU :61-P(XX)) ; | ||
| + | ELSE; | ||
| + | RU = RU + | ||
| + | %SUBST(WRU :61-C(XX)); | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | |||
| + | |||
| + | // PROCESS FLOAT DATA TYPE | ||
| + | IF T(XX) = 'F'; | ||
| + | |||
| + | ST = S(XX); | ||
| + | |||
| + | IF Q(XX) = 4; | ||
| + | FL4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3); | ||
| + | FLT14 = %EDITFLT(FLT4); | ||
| + | RU = RU + FLT14; | ||
| + | ENDIF; | ||
| + | |||
| + | IF Q(XX) = 8; | ||
| + | FL8 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) + | ||
| + | D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7); | ||
| + | FLT23 = %EDITFLT(FLT8); | ||
| + | RU = RU + FLT23; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDIF; | ||
| + | |||
| + | |||
| + | // SEND A REQUEST UNIT IF GOT ENOUGH DATA | ||
| + | |||
| + | IF %LEN(RU) + L(XX + 1) >= 200; | ||
| + | RU = RU + X20; | ||
| + | BIN = %LEN(RU); | ||
| + | OUTLEN = HX2; | ||
| + | INLEN = X000; | ||
| + | FNC = SND; | ||
| + | A = RU; | ||
| + | EXCEPT DATAO; | ||
| + | NEWRU = '1'; | ||
| + | RU = *ALLX'00'; | ||
| + | CLEAR RU; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDFOR; | ||
| + | ENDIF; | ||
| + | |||
| + | IF %LEN(RU) > 5 AND %LEN(RU) < 250; | ||
| + | RU = RU + X20; | ||
| + | BIN = %LEN(RU); | ||
| + | OUTLEN = HX2; | ||
| + | INLEN = X000; | ||
| + | FNC = SND; | ||
| + | A = RU; | ||
| + | EXCEPT DATAO; | ||
| + | ENDIF; | ||
| + | ENDSR; | ||
| + | |||
| + | |||
| + | // @@@@@@@@@@@@@@@ ROWINC @@@@@@@@@@@@@@@ | ||
| + | |||
| + | // INCREMENT THE ROW | ||
| + | BEGSR @ROWINC; | ||
| + | ROW = ROW + 2; | ||
| + | IF ROW > 20; | ||
| + | MX = 3; | ||
| + | ENDIF; | ||
| + | ENDSR; | ||
| + | |||
| + | |||
| + | |||
| + | // @@@@@@@@@@@@@@@ GETFLD @@@@@@@@@@@@@@@ | ||
| + | |||
| + | // LOAD FIELD DESCRIPTION ARRAYS | ||
| + | BEGSR @GETFLD; | ||
| + | MX = 0; | ||
| + | X = 0; | ||
| + | |||
| + | IF (*INU2 = *ON); | ||
| + | // IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN | ||
| + | N(1) = 'RRN'; | ||
| + | T(1) = 'S' ; | ||
| + | C(1) = 11 ; | ||
| + | P(1) = 0 ; | ||
| + | S(1) = 0 ; | ||
| + | E(1) = 0 ; | ||
| + | L(1) = 12 ; | ||
| + | I(1) = X4F06 ; | ||
| + | KY(1)= '3' ; | ||
| + | X = 1 ; | ||
| + | ENDIF; | ||
| + | |||
| + | SCRST = *BLANK; | ||
| + | SCRSTN = *BLANK; | ||
| + | |||
| + | LVL = %DEC(SCNLVL : 5:0); | ||
| + | |||
| + | TEXT500 = SCNLV ; | ||
| + | LV = LVW; | ||
| + | |||
| + | IF LVL <> 0; | ||
| + | SCRST = LV(LVL); | ||
| + | ENDIF; | ||
| + | |||
| + | SETLL 1 QWHDRFFD ; | ||
| + | |||
| + | DOW @LOOP = @LOOP; | ||
| + | // REREAD TAG | ||
| + | READ QWHDRFFD; | ||
| + | IF %EOF; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | // SELECT OR OMIT | ||
| + | IF ALL <> '1'; | ||
| + | IF ALL = 'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS | ||
| + | IF WHFIOB <> 'S'; | ||
| + | ITER; | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | IF ALL = 'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS | ||
| + | IF WHFIOB = 'O'; | ||
| + | ITER; | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | |||
| + | // FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS) | ||
| + | IF WHDFTL <> 0 ; | ||
| + | ELSE; | ||
| + | IF SCRST <> ' ' AND SCRSTN = ' '; | ||
| + | IF WHFLDE = SCRST; | ||
| + | SCRSTN = '1'; // FOUND THE START | ||
| + | ELSE; | ||
| + | ITER; | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | |||
| + | |||
| + | X = X + 1; | ||
| + | // CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT | ||
| + | IF WHDFTL <> 0; | ||
| + | KY(X) = '1'; | ||
| + | WX = WHDFTL ; | ||
| + | KE(WX) = WHFLDE; | ||
| + | IF NUMKEY < WHDFTL; | ||
| + | NUMKEY = WHDFTL; | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | |||
| + | N(X) = WHFLDE ; // NAME | ||
| + | T(X) = WHFLDT ; // TYPE | ||
| + | V(X) = WHVARL ; // VARYING | ||
| + | C(X) = WHFLDD ; // DEC DIGITS | ||
| + | P(X) = WHFLDP ; // DEC PREC | ||
| + | S(X) = WHFOBO ; // START | ||
| + | Q(X) = WHFLDB ; // BTYES | ||
| + | E(X) = WHFOBO + WHFLDB -1 ; // END | ||
| + | |||
| + | IF T(X) = 'F' ; // FLOAT | ||
| + | |||
| + | I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA | ||
| + | L(X) = 14; | ||
| + | IF Q(X) = 8; | ||
| + | L(X) = 23; | ||
| + | ENDIF; | ||
| + | |||
| + | ELSE; | ||
| + | IF WHFLDD <> 0 ; | ||
| + | IF WHFLDP <> 0 ; | ||
| + | L(X) = WHFLDD + 2 ; // LENGTH | ||
| + | ELSE; | ||
| + | L(X) = WHFLDD + 1 ; // LENGTH | ||
| + | ENDIF; | ||
| + | |||
| + | I(X) = FFN1 + FFN2; // SCRN FIELD FORMAT NUMERIC | ||
| + | |||
| + | ELSE; | ||
| + | L(X) = WHFLDB ; | ||
| + | I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDDO; | ||
| + | // NUMBER OF FIELDS | ||
| + | NUMFLD = X ; | ||
| + | |||
| + | // MAKE ROOM FOR KEYS | ||
| + | IF NUMKEY > 0 ; | ||
| + | X1 = NUMKEY + NUMFLD; | ||
| + | |||
| + | FOR X = NUMFLD DOWNTO 1; | ||
| + | KY(X1) = KY(X) ; | ||
| + | L(X1) = L(X) ; | ||
| + | I(X1) = I(X) ; | ||
| + | N(X1) = N(X) ; | ||
| + | T(X1) = T(X) ; | ||
| + | V(X1) = V(X) ; | ||
| + | C(X1) = C(X) ; | ||
| + | P(X1) = P(X) ; | ||
| + | S(X1) = S(X) ; | ||
| + | E(X1) = E(X) ; | ||
| + | Q(X1) = Q(X) ; | ||
| + | X1 = X1 - 1; | ||
| + | ENDFOR; | ||
| + | |||
| + | // PUT KEY FIELDS AT TOP | ||
| + | OFF = 0; | ||
| + | FOR X = 1 TO NUMKEY; | ||
| + | X1 = %LOOKUP(KE(X) : N : NUMKEY+1); | ||
| + | |||
| + | KY(X) = '2'; | ||
| + | L(X) = L(X1); | ||
| + | I(X) = I(X1); // FIELD FMT | ||
| + | SELECT; // INPUT ENABLE | ||
| + | WHEN I(X) = X6000; | ||
| + | I(X) = X4800; | ||
| + | WHEN I(X) = X6706; | ||
| + | I(X) = X4F06; | ||
| + | ENDSL; | ||
| + | N(X) = N(X1); | ||
| + | T(X) = T(X1); | ||
| + | V(X) = V(X1); | ||
| + | C(X) = C(X1); | ||
| + | P(X) = P(X1); | ||
| + | S(X) = S(X1); | ||
| + | E(X) = E(X1); | ||
| + | Q(X) = Q(X1); | ||
| + | R(X) = OFF; | ||
| + | OFF = OFF + Q(X1); | ||
| + | ENDFOR; | ||
| + | |||
| + | ENDIF; | ||
| + | // NUMBER OF FIELDS AND KEYS | ||
| + | NUMFKY = NUMFLD + NUMKEY; | ||
| + | |||
| + | ENDSR; | ||
| + | |||
| + | |||
| + | // @@@@@@@@@@@@@@@ GETADD @@@@@@@@@@@@@@@ | ||
| + | |||
| + | // LOAD FIELD BUFFER ADDRESSES | ||
| + | BEGSR @GETADD; | ||
| + | MX = 0; | ||
| + | X = 0; | ||
| + | ROW = 3; | ||
| + | COL = 1; | ||
| + | |||
| + | FOR X = 1 TO NUMFKY; | ||
| + | |||
| + | // IF FINISHED WITH THE KEY FIELDS | ||
| + | // INC ROW FOR 1ST DATA FIELD | ||
| + | IF KEYSOK = ' ' ; | ||
| + | IF KY(X) = ' ' OR KY(X) = '1'; | ||
| + | KEYSOK = '1' ; | ||
| + | ROW = ROW + 2; | ||
| + | COL = 1; | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | |||
| + | // SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE | ||
| + | LENDSC = %LEN(%TRIM(N(X))); | ||
| + | LENWRK = L(X); | ||
| + | IF LENDSC > L(X); | ||
| + | LENWRK = LENDSC; | ||
| + | ENDIF; | ||
| + | LENWRK = LENWRK + 2; | ||
| + | |||
| + | // TRAP FIELDS THAT OVERFLOW | ||
| + | ROW = ROW + XROW; | ||
| + | XROW = %DIV(LENWRK : 80); | ||
| + | |||
| + | IF (COL + LENWRK) > 78; | ||
| + | EXSR @ROWINC; | ||
| + | IF MX = 3; | ||
| + | X= X-1; | ||
| + | NUMFKY = X; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | COL = 1; | ||
| + | ENDIF; | ||
| + | |||
| + | // INC COL. FOR FIELD START | ||
| + | CLEAR B(X); | ||
| + | BIN = ROW; | ||
| + | B(X) = %TRIM(B(X)) + HX1; | ||
| + | BIN = COL + 1; | ||
| + | B(X) = %TRIM(B(X)) + HX1; | ||
| + | |||
| + | // INC COL. FOR NEXT FIELD | ||
| + | COL = COL + LENWRK; | ||
| + | IF COL > 78; | ||
| + | EXSR @ROWINC; | ||
| + | IF MX = 3; // NO ROOM FOR THE FIELD | ||
| + | X= X-1; | ||
| + | NUMFKY = X; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | COL = 1; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDFOR; | ||
| + | |||
| + | // FIELD LEVEL | ||
| + | LVX = LVL + 1; | ||
| + | LV(LVX) = N(X); | ||
| + | |||
| + | ENDSR; | ||
| + | |||
| + | |||
| + | // @@@@@@@@@@@@@@@ PUTHED @@@@@@@@@@@@@@@ | ||
| + | |||
| + | // PUT FIELD HEADINGS | ||
| + | BEGSR @PUTHED; | ||
| + | |||
| + | |||
| + | NEWRU = '1'; | ||
| + | |||
| + | RU = *ALLX'00'; | ||
| + | CLEAR RU; // initialise Request Unit 255 bytes max | ||
| + | FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | ||
| + | |||
| + | IF NEWRU = '1'; | ||
| + | NEWRU = '0'; | ||
| + | RU = ESC + WTD + X20 + X00; | ||
| + | ENDIF; | ||
| + | |||
| + | RU = RU + SBA; | ||
| + | BIN = 0; | ||
| + | // CONVERT DATA BUFADR TO HEADING BUFADR | ||
| + | HX1 = %SUBST(B(XX) :1:1); | ||
| + | BIN = BIN - 1; | ||
| + | RU = RU + HX1; | ||
| + | |||
| + | IF REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR | ||
| + | BIN = 0; | ||
| + | HX1 = %SUBST(B(XX) :2:1); | ||
| + | BIN = BIN -1 ; | ||
| + | RU = RU + HX1; | ||
| + | ELSE; | ||
| + | RU = RU + %SUBST(B(XX) :2); | ||
| + | ENDIF; | ||
| + | |||
| + | RU = RU + ATC ; | ||
| + | |||
| + | // LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS | ||
| + | LENDSC = %LEN(%TRIM(N(XX))); | ||
| + | IF T(XX) <> 'A' AND LENDSC < (L(XX) -1); | ||
| + | FOR Y = 1 TO (L(XX) -(LENDSC +1)); | ||
| + | RU = RU + ' '; | ||
| + | ENDFOR; | ||
| + | ENDIF; | ||
| + | |||
| + | RU = RU + %TRIM(N(XX)); | ||
| + | |||
| + | IF %LEN(RU) >= 200; | ||
| + | BIN = %LEN(RU); | ||
| + | OUTLEN = HX2; | ||
| + | INLEN = X000; | ||
| + | FNC = SND; | ||
| + | A = RU; | ||
| + | EXCEPT DATAO; | ||
| + | NEWRU = '1'; | ||
| + | RU = *ALLX'00'; | ||
| + | CLEAR RU; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDFOR; | ||
| + | |||
| + | IF %LEN(RU) > 5 AND %LEN(RU) < 200; | ||
| + | BIN = %LEN(RU); | ||
| + | OUTLEN = HX2; | ||
| + | INLEN = X000; | ||
| + | FNC = SND; | ||
| + | A = RU; | ||
| + | EXCEPT DATAO; | ||
| + | ENDIF; | ||
| + | |||
| + | IF REHEAD <> '1'; | ||
| + | // FORMAT FIELDS | ||
| + | |||
| + | |||
| + | NEWRU = '1'; | ||
| + | RU = *ALLX'00'; | ||
| + | CLEAR RU; // initialise Request Unit 255 bytes max | ||
| + | FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | ||
| + | |||
| + | IF NEWRU = '1'; | ||
| + | NEWRU = '0'; | ||
| + | RU = ESC + WTD + X20 + X00; | ||
| + | ENDIF; | ||
| + | |||
| + | RU = RU + SBA +B(XX)+SF + I(XX); | ||
| + | |||
| + | IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3'; | ||
| + | RU = RU + X25; | ||
| + | ELSE; | ||
| + | RU = RU + X26; | ||
| + | ENDIF; | ||
| + | |||
| + | BIN = L(XX); | ||
| + | RU = RU + HX2; | ||
| + | |||
| + | // LENGTH OF INPUT FIELDS | ||
| + | LENF = LENF + L(XX) + 3; | ||
| + | |||
| + | |||
| + | IF %LEN(RU) >= 200; | ||
| + | BIN = %LEN(RU); | ||
| + | OUTLEN = HX2; | ||
| + | INLEN = X000; | ||
| + | FNC = SND; | ||
| + | A = RU; | ||
| + | EXCEPT DATAO; | ||
| + | NEWRU = '1'; | ||
| + | RU = *ALLX'00'; | ||
| + | CLEAR RU; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDFOR; | ||
| + | |||
| + | // PUT LAST R/U | ||
| + | IF %LEN(RU) > 5 AND %LEN(RU) < 200; | ||
| + | BIN = %LEN(RU); | ||
| + | OUTLEN = HX2; | ||
| + | INLEN = X000; | ||
| + | FNC = SND; | ||
| + | A = RU; | ||
| + | EXCEPT DATAO; | ||
| + | ENDIF; | ||
| + | |||
| + | //INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT | ||
| + | FOR XP = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | ||
| + | HX2 = B(XP); | ||
| + | BIN = BIN + 1; | ||
| + | B(XP) = HX2; | ||
| + | ENDFOR; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDSR; | ||
| + | |||
| + | // @@@@@@@ INIT @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
| + | BEGSR @INIT; | ||
| + | |||
| + | CLEAR KW; | ||
| + | |||
| + | // UPDATE | ||
| + | IF UPDF = 'Y'; | ||
| + | FFA1 = X40; | ||
| + | FFN1 = X47; | ||
| + | ELSE; | ||
| + | FFA1 = X60; | ||
| + | FFN1 = X67; | ||
| + | ENDIF; | ||
| + | |||
| + | SELECT; | ||
| + | WHEN *INU1 = '1'; | ||
| + | FILE = F1 ; | ||
| + | LIB = L1 ; | ||
| + | MBR = M1 ; | ||
| + | RCDL = R1 ; | ||
| + | ACCTP = A1 ; | ||
| + | WHEN *INU2 = '1'; | ||
| + | FILE = F2 ; | ||
| + | LIB = L2 ; | ||
| + | MBR = M2 ; | ||
| + | RCDL = R2 ; | ||
| + | ACCTP = A2 ; | ||
| + | ENDSL; | ||
| + | RLEN = RCDL ; | ||
| + | RLENTH = %EDITC(RLEN: 'X') ; | ||
| + | LENF = 0 ; | ||
| + | |||
| + | |||
| + | // Control commands and data are constructed into RUs Request UNITS | ||
| + | // Each RU is 256 bytes max size. | ||
| + | // Construct and send as many RUs as needed to format the display. | ||
| + | RU = *ALLX'00'; | ||
| + | CLEAR RU; // initialise Request Unit 255 bytes max | ||
| + | RU = CLRWTD ; | ||
| + | //set up the screen headings | ||
| + | BIN = 1; // set ROW to 1 | ||
| + | RW = HX1; | ||
| + | BIN = 2; // set COL to 2 | ||
| + | CL = HX1; | ||
| + | RU = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE); | ||
| + | RU = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN : 'Z') ; | ||
| + | RU = RU + ' RRN ' ; | ||
| + | BIN = %len(RU) -4; | ||
| + | RBA = RW + HX1 ; // address of the RRN field | ||
| + | RU = RU + SBA + RBA + ' '; | ||
| + | |||
| + | // FUNCTION KEYS | ||
| + | BIN = 23; | ||
| + | RW = HX1; | ||
| + | BIN = 02; | ||
| + | CL = HX1; | ||
| + | IF UPDF = 'Y'; // UPDATE IS ON | ||
| + | RU = RU + SBA + RW + CL + %TRIM(CNS(2)); | ||
| + | ELSE; | ||
| + | RU = RU + SBA + RW + CL + %TRIM(CNS(1)); | ||
| + | ENDIF; | ||
| + | |||
| + | // THIS IS A SEND ONLY FUNCTION | ||
| + | FNC = SND; | ||
| + | CLEAR A; | ||
| + | A = RU; | ||
| + | BIN2 = %LEN(RU); | ||
| + | OUTLEN = BY2; | ||
| + | INLEN = x000; | ||
| + | |||
| + | EXCEPT DATAO; | ||
| + | |||
| + | ENDSR; | ||
| + | |||
| + | |||
| + | // @@@@@@@ KEYIN @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
| + | BEGSR @KEYIN; | ||
| + | // ISSUE A READ FROM DISPLAY | ||
| + | FNC = SNR; | ||
| + | BIN2 = 8; | ||
| + | OUTLEN = BY2; | ||
| + | IPL = LENF + 34; | ||
| + | BIN2 = IPL; | ||
| + | INLEN = BY2; | ||
| + | |||
| + | // SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW | ||
| + | FOR X = 1 TO 9; | ||
| + | IF IPL > ( X*80 +3); | ||
| + | *IN(X+19) = *ON; | ||
| + | ENDIF; | ||
| + | ENDFOR; | ||
| + | |||
| + | RU = *ALLX'00'; | ||
| + | CLEAR RU; | ||
| + | RU = RDDSP; | ||
| + | A = RU; | ||
| + | |||
| + | EXCEPT DATAI; | ||
| + | ENDSR; | ||
| + | |||
| + | // @@@@@@@ ERROR @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
| + | BEGSR @ERROR; | ||
| + | |||
| + | // SETUP PUT ERROR MESSAGE X'21' | ||
| + | RU = *ALLX'00'; | ||
| + | CLEAR RU; | ||
| + | |||
| + | FNC = SNR; | ||
| + | BIN = 42; | ||
| + | OUTLEN = HX2; | ||
| + | BIN = LENF + 34; | ||
| + | IPL = BIN; | ||
| + | INLEN = HX2; | ||
| + | |||
| + | FOR X = 1 TO 9; | ||
| + | IF IPL > (X * 80 +3) ; | ||
| + | *IN(X + 19) = *ON; // SETON FFR 20 - 29 FOR INPUT | ||
| + | ENDIF; | ||
| + | ENDFOR; | ||
| + | |||
| + | RU = ESC + WER + IC + B(1) + ATC + MSG(MX); | ||
| + | RU = RU + ESC + RDM + X40+ X00; | ||
| + | |||
| + | A = RU; | ||
| + | EXCEPT DATAI; | ||
| + | RU = *ALLX'00'; | ||
| + | CLEAR RU; | ||
| + | ENDSR; | ||
| + | |||
| + | |||
| + | // @@@@@@@ HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
| + | BEGSR @HXDSP; | ||
| + | |||
| + | RU = *ALLX'00'; | ||
| + | CLEAR RU; | ||
| + | Y = %LOOKUPLE( CURLOC : B ); | ||
| + | // | ||
| + | RU = ESC + WTD + X20 + X00 + SBA; | ||
| + | BIN = 0; | ||
| + | HX1 = %SUBST(B(Y) :1:1); | ||
| + | BIN = BIN - 1; | ||
| + | RU = RU + HX1; | ||
| + | RU = RU + %SUBST(B(Y) :2:1); | ||
| + | |||
| + | FOR X = S(Y) TO E(Y); | ||
| + | BIN = 0; | ||
| + | HX1 = D(X); | ||
| + | HX1 = %BITAND(HX1 : XF0); | ||
| + | Z = BIN / 16 + 1; | ||
| + | RU = RU + CRS(Z); | ||
| + | ENDFOR; | ||
| + | |||
| + | RU = RU + X20; | ||
| + | |||
| + | RU = RU + SBA + B(Y); | ||
| + | FOR X = S(Y) TO E(Y); | ||
| + | BIN = 0; | ||
| + | HX1 = D(X); | ||
| + | HX1 = %BITAND(HX1 : X0F); | ||
| + | Z = BIN + 1; | ||
| + | RU = RU + CRS(Z); | ||
| + | ENDFOR; | ||
| + | |||
| + | |||
| + | BIN = %LEN(RU); | ||
| + | OUTLEN = HX2; | ||
| + | INLEN = X000; | ||
| + | FNC = SND; | ||
| + | A = RU; | ||
| + | EXCEPT DATAO; | ||
| + | RU = *ALLX'00'; | ||
| + | CLEAR RU; | ||
| + | |||
| + | |||
| + | EXSR @KEYIN; | ||
| + | READ DISPF; | ||
| + | |||
| + | |||
| + | // CLEAR HEADINGS | ||
| + | RU = *ALLX'00'; | ||
| + | CLEAR RU; | ||
| + | |||
| + | RU = RU + ESC + WTD + X20 + X00 + SBA; | ||
| + | HX1 = %SUBST(B(Y) :1:1) ; | ||
| + | BIN = BIN - 1; | ||
| + | RU = RU + HX1 + %SUBST(B(Y):2:1); | ||
| + | FOR X = S(Y) TO E(Y); | ||
| + | RU = RU + ' '; | ||
| + | ENDFOR; | ||
| + | RU = RU + ' '; | ||
| + | |||
| + | BIN = %LEN(RU); | ||
| + | OUTLEN = HX2; | ||
| + | INLEN = X000; | ||
| + | FNC = SND; | ||
| + | A = RU; | ||
| + | EXCEPT DATAO; | ||
| + | RU = *ALLX'00'; | ||
| + | CLEAR RU; | ||
| + | |||
| + | ENDSR; | ||
| + | |||
| + | |||
| + | |||
| + | // @@@@@@@ UPD @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
| + | BEGSR @UPD; | ||
| + | |||
| + | // CONVERT DATA FOR OUTPUT | ||
| + | |||
| + | // FOR EACH FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE | ||
| + | // THE MODIFIED DATA INTO THE OUTPUT ARRAY | ||
| + | K1 = 0; | ||
| + | K2 = 0; | ||
| + | W = 1; | ||
| + | CGKY = *BLANK; // KEY CHANGED | ||
| + | KW = KEYA; | ||
| + | |||
| + | FOR Y = 1 TO NUMFKY ; | ||
| + | |||
| + | IF KY(Y) > '1'; | ||
| + | ITER; | ||
| + | ENDIF; | ||
| + | |||
| + | |||
| + | // MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY | ||
| + | |||
| + | // GET SIZE OF FIELD IN BYTES | ||
| + | IF T(Y) = 'A'; // ALPHA DATA | ||
| + | K = ' '; | ||
| + | K1 = 1; | ||
| + | K2 = Q(Y); | ||
| + | ELSE; | ||
| + | K = '0'; | ||
| + | K1 = 1; | ||
| + | K2 = C(Y); | ||
| + | ENDIF; | ||
| + | |||
| + | X = 1; | ||
| + | |||
| + | DOW @LOOP = @LOOP; | ||
| + | |||
| + | // NXTSBA | ||
| + | X = %LOOKUP(SBA : ID : X ); | ||
| + | IF X = 0; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | // IS THIS THE FIELD? CHECK THE BUFFER ADDRESS | ||
| + | X = X +1; | ||
| + | IF B(Y) <> %SUBST(IDA : X :2); | ||
| + | ITER; | ||
| + | ENDIF; | ||
| + | |||
| + | |||
| + | // FOUND A MTD FOR THIS FIELD | ||
| + | |||
| + | |||
| + | // CHECK IF FIELD WAS CLEARED ONLY | ||
| + | DOW @LOOP = @LOOP; // not a loop | ||
| + | X = X + 2; | ||
| + | IF ID(X) = SBA; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | // IF FIELD HAS DECIMALS BUMP X | ||
| + | IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND | ||
| + | P(Y) > 0; | ||
| + | X = X + 1; | ||
| + | ENDIF; | ||
| + | |||
| + | |||
| + | // CHECK IF ONLY BLANKS RETURNED | ||
| + | IF %SUBST(IDA : X :K2) = *BLANKS; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | // MOVE DATA TO WORK ARRAY K | ||
| + | X1 = X; | ||
| + | FOR X2 = 1 TO K2; | ||
| + | |||
| + | IF ID(X1) < ' '; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | K(X2) = ID(X1); | ||
| + | X1 = X1 + 1; | ||
| + | ENDFOR; | ||
| + | |||
| + | LEAVE; | ||
| + | ENDDO; | ||
| + | |||
| + | // * SET START POSN | ||
| + | W = S(Y); | ||
| + | |||
| + | // ALPHA | ||
| + | IF T(Y) = 'A' and V(XX) <> 'Y'; | ||
| + | FOR Z = K1 to K2; | ||
| + | D(W) = K(Z); | ||
| + | W = W + 1; | ||
| + | ENDFOR; | ||
| + | ENDIF; | ||
| + | |||
| + | IF T(Y) = 'A' and V(XX) = 'Y'; //VARYING | ||
| + | |||
| + | // the data start is in S(Y) | ||
| + | // the data is in array K | ||
| + | // get the length of the data cvt to bin and stik in pos 1 2 | ||
| + | // put the rest in pos 3 onwards | ||
| + | |||
| + | ENDIF; | ||
| + | |||
| + | // NUMERIC FIELD | ||
| + | // RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS | ||
| + | IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B'); | ||
| + | NU = '0'; | ||
| + | |||
| + | Z1 = 60; | ||
| + | FOR Z = K2 DOWNTO K1; | ||
| + | |||
| + | IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$'; | ||
| + | ITER; | ||
| + | ENDIF; | ||
| + | |||
| + | IF K(Z) = ' ' ; | ||
| + | NU(Z1) = '0'; | ||
| + | ELSE; | ||
| + | NU(Z1) = K(Z); | ||
| + | ENDIF; | ||
| + | |||
| + | Z1 = Z1 -1; | ||
| + | ENDFOR; | ||
| + | |||
| + | ENDIF; | ||
| + | |||
| + | |||
| + | // SIGNED FIELDS (END POSN = OFFSET + SIZE) | ||
| + | IF T(Y) = 'S'; | ||
| + | NUSA= *BLANKS; | ||
| + | FOR VX = 1 TO 60; | ||
| + | NUSA = %TRIM(NUSA) + NU(VX); | ||
| + | ENDFOR; | ||
| + | %SUBST(DATA : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y)); | ||
| + | |||
| + | ENDIF; | ||
| + | |||
| + | |||
| + | // PACKED FIELDS | ||
| + | IF T(Y) = 'P'; | ||
| + | NUSA= *BLANKS; | ||
| + | FOR VX = 1 TO 60; | ||
| + | NUSA = %TRIM(NUSA) + NU(VX); | ||
| + | ENDFOR; | ||
| + | NUP = %DEC(NUSA : 60 : 0); | ||
| + | |||
| + | %SUBST(DATA : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y)); | ||
| + | ENDIF; | ||
| + | |||
| + | // BINARY FIELDS | ||
| + | IF T(Y) = 'B'; | ||
| + | |||
| + | NUSA= *BLANKS; | ||
| + | FOR VX = 1 TO 60; | ||
| + | NUSA = %TRIM(NUSA) + NU(VX); | ||
| + | ENDFOR; | ||
| + | NUC = NUS; | ||
| + | |||
| + | IF Q(Y) = 2 ; | ||
| + | DISBIN ( NUC : BAN2 : BAN4 : '2'); | ||
| + | %SUBST(DATA : W : 2) = BAN2; | ||
| + | ENDIF; | ||
| + | |||
| + | IF Q(Y) = 4 ; | ||
| + | DISBIN ( NUC : BAN2 : BAN4 : '4'); | ||
| + | %SUBST(DATA : W : 4) = BAN4; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDIF; | ||
| + | |||
| + | // UPDATE KEY IF NECESSARY | ||
| + | IF KY(Y) = '1'; | ||
| + | CGKY = '1'; | ||
| + | EXSR @PCKMOV; | ||
| + | ENDIF; | ||
| + | |||
| + | |||
| + | ENDDO; | ||
| + | ENDFOR; | ||
| + | |||
| + | |||
| + | IF CGKY = '1'; | ||
| + | KEYA = KW; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDSR; | ||
| + | |||
| + | |||
| + | |||
| + | /END-FREE | ||
| + | |||
| + | OINPUTK E U1 UPDATREC | ||
| + | O DA | ||
| + | O 30 DB | ||
| + | O 31 DC | ||
| + | O 32 DD | ||
| + | O 33 DE | ||
| + | O 34 DF | ||
| + | O 35 DG | ||
| + | O 36 DH | ||
| + | O 37 DI | ||
| + | O 38 DJ | ||
| + | O 39 DK | ||
| + | O 40 DL | ||
| + | O 41 DM | ||
| + | O 42 DN | ||
| + | O 43 DZ | ||
| + | O 44 DO | ||
| + | O 45 DP | ||
| + | O 46 DQ | ||
| + | O 47 DR | ||
| + | O 48 DS | ||
| + | O 49 DT | ||
| + | O 50 DU | ||
| + | O 51 DV | ||
| + | O 52 DW | ||
| + | O 53 DX | ||
| + | O 54 DY | ||
| + | O 55 D0 | ||
| + | O 56 D1 | ||
| + | O 57 D2 | ||
| + | O 58 D3 | ||
| + | O 59 D4 | ||
| + | O 60 D5 | ||
| + | O 61 D6 | ||
| + | O 62 DBA | ||
| + | O 63 DCA | ||
| + | O 64 DDA | ||
| + | O 65 DEA | ||
| + | O 66 DFA | ||
| + | O 67 DGA | ||
| + | O 68 DHA | ||
| + | O 69 DIA | ||
| + | O 70 DJA | ||
| + | O 71 DKA | ||
| + | O 72 DLA | ||
| + | O 73 DMA | ||
| + | O 74 DNA | ||
| + | O 75 DOA | ||
| + | O 76 DPA | ||
| + | O 77 DQA | ||
| + | O 78 DRA | ||
| + | O 79 DSA | ||
| + | O 80 DTA | ||
| + | O 81 DUA | ||
| + | O 82 DVA | ||
| + | O 83 DWA | ||
| + | O 84 DXA | ||
| + | O 85 DYA | ||
| + | O 86 DZA | ||
| + | O 87 D0A | ||
| + | O 88 D1A | ||
| + | O 89 D2A | ||
| + | O 90 D3A | ||
| + | O 91 D4A | ||
| + | O 92 D5A | ||
| + | O 93 D6A | ||
| + | OINPUTR E U2 UPDATREC | ||
| + | O DA | ||
| + | O 30 DB | ||
| + | O 31 DC | ||
| + | O 32 DD | ||
| + | O 33 DE | ||
| + | O 34 DF | ||
| + | O 35 DG | ||
| + | O 36 DH | ||
| + | O 37 DI | ||
| + | O 38 DJ | ||
| + | O 39 DK | ||
| + | O 40 DL | ||
| + | O 41 DM | ||
| + | O 42 DN | ||
| + | O 43 DZ | ||
| + | O 44 DO | ||
| + | O 45 DP | ||
| + | O 46 DQ | ||
| + | O 47 DR | ||
| + | O 48 DS | ||
| + | O 49 DT | ||
| + | O 50 DU | ||
| + | O 51 DV | ||
| + | O 52 DW | ||
| + | O 53 DX | ||
| + | O 54 DY | ||
| + | O 55 D0 | ||
| + | O 56 D1 | ||
| + | O 57 D2 | ||
| + | O 58 D3 | ||
| + | O 59 D4 | ||
| + | O 60 D5 | ||
| + | O 61 D6 | ||
| + | O 62 DBA | ||
| + | O 63 DCA | ||
| + | O 64 DDA | ||
| + | O 65 DEA | ||
| + | O 66 DFA | ||
| + | O 67 DGA | ||
| + | O 68 DHA | ||
| + | O 69 DIA | ||
| + | O 70 DJA | ||
| + | O 71 DKA | ||
| + | O 72 DLA | ||
| + | O 73 DMA | ||
| + | O 74 DNA | ||
| + | O 75 DOA | ||
| + | O 76 DPA | ||
| + | O 77 DQA | ||
| + | O 78 DRA | ||
| + | O 79 DSA | ||
| + | O 80 DTA | ||
| + | O 81 DUA | ||
| + | O 82 DVA | ||
| + | O 83 DWA | ||
| + | O 84 DXA | ||
| + | O 85 DYA | ||
| + | O 86 DZA | ||
| + | O 87 D0A | ||
| + | O 88 D1A | ||
| + | O 89 D2A | ||
| + | O 90 D3A | ||
| + | O 91 D4A | ||
| + | O 92 D5A | ||
| + | O 93 D6A | ||
| + | |||
| + | OINPUTK EADD U1 ADDREC | ||
| + | O DA | ||
| + | O 30 DB | ||
| + | O 31 DC | ||
| + | O 32 DD | ||
| + | O 33 DE | ||
| + | O 34 DF | ||
| + | O 35 DG | ||
| + | O 36 DH | ||
| + | O 37 DI | ||
| + | O 38 DJ | ||
| + | O 39 DK | ||
| + | O 40 DL | ||
| + | O 41 DM | ||
| + | O 42 DN | ||
| + | O 43 DZ | ||
| + | O 44 DO | ||
| + | O 45 DP | ||
| + | O 46 DQ | ||
| + | O 47 DR | ||
| + | O 48 DS | ||
| + | O 49 DT | ||
| + | O 50 DU | ||
| + | O 51 DV | ||
| + | O 52 DW | ||
| + | O 53 DX | ||
| + | O 54 DY | ||
| + | O 55 D0 | ||
| + | O 56 D1 | ||
| + | O 57 D2 | ||
| + | O 58 D3 | ||
| + | O 59 D4 | ||
| + | O 60 D5 | ||
| + | O 61 D6 | ||
| + | O 62 DBA | ||
| + | O 63 DCA | ||
| + | O 64 DDA | ||
| + | O 65 DEA | ||
| + | O 66 DFA | ||
| + | O 67 DGA | ||
| + | O 68 DHA | ||
| + | O 69 DIA | ||
| + | O 70 DJA | ||
| + | O 71 DKA | ||
| + | O 72 DLA | ||
| + | O 73 DMA | ||
| + | O 74 DNA | ||
| + | O 75 DOA | ||
| + | O 76 DPA | ||
| + | O 77 DQA | ||
| + | O 78 DRA | ||
| + | O 79 DSA | ||
| + | O 80 DTA | ||
| + | O 81 DUA | ||
| + | O 82 DVA | ||
| + | O 83 DWA | ||
| + | O 84 DXA | ||
| + | O 85 DYA | ||
| + | O 86 DZA | ||
| + | O 87 D0A | ||
| + | O 88 D1A | ||
| + | O 89 D2A | ||
| + | O 90 D3A | ||
| + | O 91 D4A | ||
| + | O 92 D5A | ||
| + | O 93 D6A | ||
| + | OINPUTR EADD U2 ADDREC | ||
| + | O DA | ||
| + | O 30 DB | ||
| + | O 31 DC | ||
| + | O 32 DD | ||
| + | O 33 DE | ||
| + | O 34 DF | ||
| + | O 35 DG | ||
| + | O 36 DH | ||
| + | O 37 DI | ||
| + | O 38 DJ | ||
| + | O 39 DK | ||
| + | O 40 DL | ||
| + | O 41 DM | ||
| + | O 42 DN | ||
| + | O 43 DZ | ||
| + | O 44 DO | ||
| + | O 45 DP | ||
| + | O 46 DQ | ||
| + | O 47 DR | ||
| + | O 48 DS | ||
| + | O 49 DT | ||
| + | O 50 DU | ||
| + | O 51 DV | ||
| + | O 52 DW | ||
| + | O 53 DX | ||
| + | O 54 DY | ||
| + | O 55 D0 | ||
| + | O 56 D1 | ||
| + | O 57 D2 | ||
| + | O 58 D3 | ||
| + | O 59 D4 | ||
| + | O 60 D5 | ||
| + | O 61 D6 | ||
| + | O 62 DBA | ||
| + | O 63 DCA | ||
| + | O 64 DDA | ||
| + | O 65 DEA | ||
| + | O 66 DFA | ||
| + | O 67 DGA | ||
| + | O 68 DHA | ||
| + | O 69 DIA | ||
| + | O 70 DJA | ||
| + | O 71 DKA | ||
| + | O 72 DLA | ||
| + | O 73 DMA | ||
| + | O 74 DNA | ||
| + | O 75 DOA | ||
| + | O 76 DPA | ||
| + | O 77 DQA | ||
| + | O 78 DRA | ||
| + | O 79 DSA | ||
| + | O 80 DTA | ||
| + | O 81 DUA | ||
| + | O 82 DVA | ||
| + | O 83 DWA | ||
| + | O 84 DXA | ||
| + | O 85 DYA | ||
| + | O 86 DZA | ||
| + | O 87 D0A | ||
| + | O 88 D1A | ||
| + | O 89 D2A | ||
| + | O 90 D3A | ||
| + | O 91 D4A | ||
| + | O 92 D5A | ||
| + | O 93 D6A | ||
| + | |||
| + | OINPUTK EDEL U1 DELREC | ||
| + | OINPUTR EDEL U2 DELREC | ||
| + | |||
| + | |||
| + | ODISPF E DATAO | ||
| + | O K3 'PUT' | ||
| + | O OUTLEN 2 | ||
| + | O INLEN | ||
| + | O FNC | ||
| + | O A | ||
| + | |||
| + | O E DATAI | ||
| + | O K3 'GET' | ||
| + | O OUTLEN 2 | ||
| + | O INLEN | ||
| + | O FNC | ||
| + | O A | ||
| + | ** | ||
| + | 0000 INVALID COMMAND KEY | ||
| + | 0001 - A FIELD IS TOO LONG | ||
| + | 0002 - TOO MANY FIELDS | ||
| + | 0003 - ALPHAS IN PACKED KEY | ||
| + | 0004 - MISSING ' IN PACKED KEY | ||
| + | 0005 - MISSING DATA IN PCKD KEY | ||
| + | 0006 - RECORD NOT FOUND | ||
| + | PRESS RESET TO CONTINUE | ||
| + | ** | ||
| + | F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld | ||
| + | F1-HEX F2-Return F3-Exit F6-Update F9-Add F11-Del F19-Prev_fld F20-More_fld | ||
| + | ** | ||
| + | 0123456789ABCDEF | ||
| + | |||
| + | |||
| + | </pre> | ||
| + | |||
| + | [[#top]] | ||
| + | |||
| + | |||
| + | ===DISPF DSPF === | ||
<pre> | <pre> | ||
| + | A DSPSIZ(24 80 *DS3) | ||
| + | A PRINT | ||
| + | A OPENPRT | ||
| + | A HELP | ||
| + | A INDARA | ||
| + | A R PUT USRDFN | ||
| + | A R GET USRDFN | ||
| + | A INVITE | ||
| + | </pre> | ||
| + | |||
| + | |||
| + | [[#top]] | ||
| + | |||
| + | == WRAPPER CODE == | ||
| + | |||
| + | ===DSPFL CMD === | ||
| + | |||
| + | <pre> | ||
| + | /* TO COMPILE */ | ||
| + | /* CRTCMD CMD(*CURLIB/DSPFL) PGM(*LIBL/DIS) SRCFILE(*LIBL/QCMDSRC) */ | ||
| + | /* SRCMBR(DSPFL) VLDCKR(DISV) */ | ||
| + | |||
| + | CMD PROMPT('Display file in field format') | ||
| + | |||
| + | PARM KWD(FILE) TYPE(QUAL1) MIN(1) MAX(1) + | ||
| + | PROMPT('File') | ||
| + | |||
| + | PARM KWD(MBR) TYPE(*NAME) DFT(*FIRST) + | ||
| + | SPCVAL((*FILE) (*FIRST)) MIN(0) MAX(1) + | ||
| + | PROMPT('Member') | ||
| + | |||
| + | PARM KWD(UPD ) TYPE(*CHAR) LEN(1) DFT(N) + | ||
| + | RSTD(*YES) VALUES('Y' 'N' 'y' 'n') + | ||
| + | PROMPT('Update data (Y/N)') | ||
| + | |||
| + | PARM KWD(RST ) TYPE(*CHAR) LEN(1) DFT(N) + | ||
| + | RSTD(*YES) VALUES('Y' 'N' 'y' 'n') + | ||
| + | PROMPT('Get DDS again.') | ||
| + | |||
| + | PARM KWD(REL ) TYPE(*CHAR) LEN(1) DFT(N) + | ||
| + | RSTD(*YES) VALUES('Y' 'N' 'y' 'n') + | ||
| + | PROMPT('Show Relations') | ||
| + | |||
| + | |||
| + | QUAL1: QUAL TYPE(*NAME) LEN(10) | ||
| + | QUAL TYPE(*NAME) LEN(10) DFT(*LIBL ) + | ||
| + | SPCVAL(*LIBL ) + | ||
| + | PROMPT('Library name') | ||
| + | |||
| + | |||
| + | </pre> | ||
| + | |||
| + | [[#top]] | ||
| + | |||
| + | ===DIS CL === | ||
| + | |||
| + | <pre> | ||
| + | |||
| + | /* Command processing program for DSPFF command */ | ||
| + | |||
| + | PGM (&FILIB &MBR &UPD &RST &REL) | ||
| + | |||
| + | DCL &FILIB *CHAR 20 | ||
| + | DCL &FILE *CHAR 10 | ||
| + | DCL &LIB *CHAR 10 | ||
| + | DCL &SFILE *CHAR 10 | ||
| + | DCL &SLIB *CHAR 10 | ||
| + | DCL &MBR *CHAR 10 | ||
| + | DCL &OPT *CHAR 10 | ||
| + | DCL &ALL *CHAR 1 | ||
| + | DCL &RTN *CHAR 1 | ||
| + | DCL &RMBR *CHAR 10 | ||
| + | |||
| + | DCL &QRY *LGL | ||
| + | DCL &UPD *LGL | ||
| + | DCL &REL *CHAR 1 | ||
| + | DCL &RST *CHAR 1 | ||
| + | |||
| + | DCL &RCDL *CHAR 5 | ||
| + | DCL &RCDLN *DEC (5 0) | ||
| + | DCL &ACCP *CHAR 1 | ||
| + | DCL &OVR *LGL VALUE('0') | ||
| + | DCL &FILEF *CHAR 10 | ||
| + | DCL &FILEK *CHAR 10 | ||
| + | DCL &ID *CHAR 7 | ||
| + | DCL &MF *CHAR 10 | ||
| + | DCL &ML *CHAR 10 | ||
| + | DCL &TYPE *CHAR 1 | ||
| + | DCL &PHY *CHAR 10 | ||
| + | DCL &PHYLIB *CHAR 10 | ||
| + | |||
| + | RMVLIBLE QTEMP | ||
| + | MONMSG CPF0000 | ||
| + | ADDLIBLE QTEMP *FIRST | ||
| + | MONMSG CPF0000 EXEC(GOTO END) | ||
| + | |||
| + | RESET: | ||
| + | CHGVAR &FILE &FILIB | ||
| + | CHGVAR &LIB (%SST(&FILIB 11 10)) | ||
| + | IF (&LIB *EQ ' ') (CHGVAR &LIB '*LIBL') | ||
| + | IF (&MBR *EQ '*FILE') (CHGVAR &MBR &FILE) | ||
| + | IF (&MBR *EQ '*FIRST') (DO) | ||
| + | RTVMBRD FILE(&LIB/&FILE) RTNMBR(&RMBR) | ||
| + | CHGVAR &MBR &RMBR | ||
| + | ENDDO | ||
| + | CHGVAR &FILEF ('FF'||(%SST(&FILE 1 8))) | ||
| + | CHGVAR &FILEK ('KF'||(%SST(&FILE 1 8))) | ||
| + | |||
| + | IF (&RST= 'Y') DO | ||
| + | DLTF &FILEF | ||
| + | MONMSG CPF0000 | ||
| + | DLTF &FILEK | ||
| + | MONMSG CPF0000 | ||
| + | ENDDO | ||
| + | |||
| + | |||
| + | CHKOBJ (QTEMP/&FILEF) *FILE | ||
| + | MONMSG CPF9801 EXEC(DO) | ||
| + | DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEF) | ||
| + | DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEK) | ||
| + | CHGVAR &RTN '2' | ||
| + | ENDDO | ||
| + | |||
| + | CHGPF QTEMP/&FILEF LVLCHK(*NO) | ||
| + | CHGPF QTEMP/&FILEK LVLCHK(*NO) | ||
| + | |||
| + | IF (&REL = 'Y' ) DO | ||
| + | CALL DISF (&FILEK &TYPE &PHY &PHYLIB) | ||
| + | IF (&TYPE *EQ 'P') DO | ||
| + | CHGVAR &PHY &FILE | ||
| + | CHGVAR &PHYLIB &LIB | ||
| + | ENDDO | ||
| + | CALL DIS3 (&PHY &PHYLIB &SFILE &SLIB) | ||
| + | IF (&SFILE *NE ' ') DO | ||
| + | IF ((&SFILE *NE &FILE) *OR (&SLIB *NE &LIB)) DO | ||
| + | CHGVAR &FILIB (&SFILE||&SLIB) | ||
| + | CHGVAR &REL '0' | ||
| + | RTVMBRD FILE(&SLIB/&SFILE) RTNMBR(&RMBR) | ||
| + | CHGVAR &MBR &RMBR | ||
| + | IF (&MBR *EQ &FILE) THEN(CHGVAR &MBR '*FILE ') | ||
| + | GOTO RESET | ||
| + | ENDDO | ||
| + | ENDDO | ||
| + | ENDDO | ||
| + | |||
| + | CALL DIS1 (&FILIB &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK) | ||
| + | |||
| + | RCLRSC | ||
| + | |||
| + | END: | ||
| + | CLOF OPNID(&FILE) | ||
| + | MONMSG CPF0000 | ||
| + | |||
| + | |||
| + | |||
| + | ENDPGM | ||
| + | |||
| + | </pre> | ||
| + | |||
| + | [[#top]] | ||
| + | |||
| + | ===DIS1 CL === | ||
| + | |||
| + | <pre> | ||
| + | /* CALLED BY DIS TO DRIVE SELECTION OF UDDS RPG PROGRAM */ | ||
| + | /* FILE DISPLAYER DRIVER */ | ||
| + | /* SHOWS A LIST OF FIELDS IN A FILE , ALLOWS SELECTION OF FIELDS */ | ||
| + | |||
| + | /* WHEN ALL THE FIELDS DONT FIT ON ONE SCREEN */ | ||
| + | /* THIS CONTAINS A LOOP SO THAT MORE FIELDS CAN BE DISPLAYED */ | ||
| + | |||
| + | |||
| + | PGM (&FILIB &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK) | ||
| + | |||
| + | DCL &FILIB *CHAR 20 | ||
| + | DCL &FILE *CHAR 10 | ||
| + | DCL &LIB *CHAR 10 | ||
| + | DCL &MBR *CHAR 10 | ||
| + | DCL &PRG *CHAR 10 | ||
| + | DCL &OPT *CHAR 10 | ||
| + | DCL &ALL *CHAR 1 | ||
| + | DCL &RTN *CHAR 1 | ||
| + | DCL &RMV *CHAR 1 | ||
| + | DCL &QRY *LGL | ||
| + | DCL &UPD *CHAR 1 | ||
| + | DCL &RST *LGL | ||
| + | DCL &KEYL *CHAR 4 | ||
| + | DCL &RCDL *CHAR 5 | ||
| + | DCL &RCDLN *DEC (5 0) | ||
| + | DCL &ACCP *CHAR 1 | ||
| + | DCL &OVR *LGL VALUE('0') | ||
| + | DCL &FILEF *CHAR 10 | ||
| + | DCL &FILEK *CHAR 10 | ||
| + | DCL &ID *CHAR 7 | ||
| + | DCL &MF *CHAR 10 | ||
| + | DCL &ML *CHAR 10 | ||
| + | DCL &SCNLV *CHAR 500 | ||
| + | DCL &SCNLVL *CHAR 5 | ||
| + | DCL &SCNKEY *CHAR 800 | ||
| + | DCL &JOB *CHAR 10 | ||
| + | DCL &MSG *CHAR 80 | ||
| + | DCLF DISPX | ||
| + | |||
| + | CHGVAR &PGMQ DIS | ||
| + | CHGVAR &SCNLVL '00000' | ||
| + | |||
| + | OVRDBF FFD QTEMP/&FILEF SECURE(*YES) | ||
| + | OVRDBF KF QTEMP/&FILEK SECURE(*YES) | ||
| + | |||
| + | |||
| + | RTN: | ||
| + | OVRDBF INPUT &LIB/&FILE SHARE(*NO) | ||
| + | CALL DISPY (&ALL &RTN &KEYL &ACCP &QRY &RCDL) | ||
| + | MONMSG MSGID(CPF5035 CPF5029 RNQ1299 RNX0000) EXEC(DO) | ||
| + | RTVJOBA JOB(&JOB) | ||
| + | SNDBRKMSG MSG('Cannot handle this file type. Possibly + | ||
| + | has NULL data field.') TOMSGQ(&job) + | ||
| + | MSGTYPE(*INQ) RPYMSGQ(&job) | ||
| + | |||
| + | goto end | ||
| + | ENDDO | ||
| + | |||
| + | DLTOVR INPUT | ||
| + | MONMSG CPF0000 | ||
| + | |||
| + | IF (&RTN *EQ '1') (GOTO END) | ||
| + | |||
| + | IF (&ACCP *EQ 'K') DO | ||
| + | CHGJOB SWS(10XXXXXX) | ||
| + | OVRDBF FILE(INPUTK) TOFILE(&LIB/&FILE) MBR(&MBR) + | ||
| + | SHARE(*YES) SEQONLY(*NO) SECURE(*YES) | ||
| + | IF (&QRY ) DO | ||
| + | REMSG: | ||
| + | |||
| + | REQRY: SNDRCVF RCDFMT(SLT) | ||
| + | IF (&IN01 *OR &IN02) GOTO BYQRY | ||
| + | CHGVAR &OPT '*INP' | ||
| + | IF (&UPD *EQ 'Y') (CHGVAR &OPT '*ALL') | ||
| + | OPNQRYF FILE((INPUTK)) OPTION(&OPT) QRYSLT(&QSLT) + | ||
| + | KEYFLD(*FILE) SEQONLY(*NO) | ||
| + | MONMSG CPF9899 EXEC(DO) | ||
| + | RCVMSG MSGTYPE(*ANY) | ||
| + | SNDF RCDFMT(SLTC) | ||
| + | GOTO REMSG | ||
| + | ENDDO | ||
| + | ENDDO | ||
| + | ENDDO | ||
| + | BYQRY: | ||
| + | IF (&ACCP *EQ 'A') DO | ||
| + | CHGJOB SWS(01XXXXXX) | ||
| + | OVRDBF FILE(INPUTR) TOFILE(&LIB/&FILE) MBR(&MBR) + | ||
| + | SHARE(*YES) SEQONLY(*NO) SECURE(*YES) | ||
| + | IF (&QRY ) DO | ||
| + | REMSGA: | ||
| + | |||
| + | REQRYA: SNDRCVF RCDFMT(SLT) | ||
| + | IF (&IN01 *OR &IN02) GOTO BYQRYA | ||
| + | CHGVAR &OPT '*INP' | ||
| + | IF (&UPD = 'Y') (CHGVAR &OPT '*ALL') | ||
| + | OPNQRYF FILE((INPUTR)) OPTION(&OPT) QRYSLT(&QSLT) + | ||
| + | KEYFLD(*FILE) SEQONLY(*NO) | ||
| + | MONMSG CPF9899 EXEC(DO) | ||
| + | RCVMSG MSGTYPE(*ANY) | ||
| + | SNDF RCDFMT(SLTC) | ||
| + | GOTO REMSGA | ||
| + | CHGVAR VAR(&IN20) VALUE('1') | ||
| + | SDAMSG: RCVMSG RMV(*NO) MSG(&MSG) | ||
| + | IF COND(&MSG ¬= ' ') THEN(DO) | ||
| + | SNDPGMMSG MSG(&MSG) | ||
| + | GOTO SDAMSG | ||
| + | ENDDO | ||
| + | SNDF RCDFMT(SLTC) | ||
| + | GOTO REMSGA | ||
| + | ENDDO | ||
| + | |||
| + | ENDDO | ||
| + | ENDDO | ||
| + | BYQRYA: | ||
| + | CHGVAR &RCDLN &RCDL | ||
| + | |||
| + | IF ( &UPD= 'Y') (DO) | ||
| + | IF ((&RCDLN *GT 0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DUSP ') | ||
| + | IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DUSP1') | ||
| + | IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DUSP2') | ||
| + | ENDDO | ||
| + | IF (&UPD *NE 'Y') (DO) | ||
| + | IF ((&RCDLN *GT 0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DISP ') | ||
| + | IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DISP1') | ||
| + | IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DISP2') | ||
| + | ENDDO | ||
| + | |||
| + | |||
| + | CALL &PRG (&ALL &RTN &KEYL &UPD &SCNLV &SCNLVL &SCNKEY) | ||
| + | |||
| + | IF (&QRY ) (DO) | ||
| + | IF (&ACCP *EQ 'K') DO | ||
| + | CLOF INPUTK | ||
| + | MONMSG CPF0000 | ||
| + | ENDDO | ||
| + | IF (&ACCP *EQ 'A') DO | ||
| + | CLOF INPUTR | ||
| + | MONMSG CPF0000 | ||
| + | ENDDO | ||
| + | ENDDO | ||
| + | |||
| + | IF (&RTN *EQ '3') DO | ||
| + | GOTO BYQRYA | ||
| + | ENDDO | ||
| + | |||
| + | IF (&RTN *EQ '1') DO | ||
| + | CHGVAR &RTN '0' | ||
| + | GOTO RTN | ||
| + | ENDDO | ||
| + | |||
| + | |||
| + | |||
| + | END: ENDPGM | ||
| + | |||
| + | </pre> | ||
| + | |||
| + | [[#top]] | ||
| + | |||
| + | ===DIS3 CL === | ||
| + | |||
| + | <pre> | ||
| + | |||
| + | /* CALL BY DIS TO SHOW FILE RELATIONS / ACCESS PATHS */ | ||
| + | |||
| + | PGM (&PHY &PHYLIB &SFILE &SLIB) | ||
| + | |||
| + | /* DISPLAY ACCESS PATHS */ | ||
| + | |||
| + | DCL &PHY *CHAR 10 | ||
| + | DCL &PHYLIB *CHAR 10 | ||
| + | DCL &SFILE *CHAR 10 | ||
| + | DCL &SLIB *CHAR 10 | ||
| + | |||
| + | |||
| + | DCLF QTEMP/DBR | ||
| + | |||
| + | /* CREATE WORK FILES */ | ||
| + | CALL DIS4 | ||
| + | |||
| + | DLTF QTEMP/DBR | ||
| + | MONMSG CPF0000 | ||
| + | |||
| + | DSPDBR FILE(&PHYLIB/&PHY) OUTPUT(*OUTFILE) + | ||
| + | OUTFILE(QTEMP/DBR) OUTMBR(*FIRST *REPLACE) | ||
| + | CHGPF QTEMP/DBR LVLCHK(*NO) | ||
| + | |||
| + | NEXT: RCVF | ||
| + | MONMSG CPF0000 EXEC(GOTO END) | ||
| + | IF (&WHREFI *NE ' ') DO | ||
| + | DSPFD FILE(&WHRELI/&WHREFI) TYPE(*ACCPTH) + | ||
| + | OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD) | ||
| + | CHGPF QTEMP/REL LVLCHK(*NO) | ||
| + | DSPFD FILE(&WHRELI/&WHREFI) TYPE(*SELECT) + | ||
| + | OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL) OUTMBR(*FIRST *ADD) | ||
| + | CHGPF QTEMP/SEL LVLCHK(*NO) | ||
| + | ENDDO | ||
| + | GOTO NEXT | ||
| + | |||
| + | END: | ||
| + | DSPFD FILE(&PHYLIB/&PHY ) TYPE(*ACCPTH) + | ||
| + | OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD) | ||
| + | CHGPF QTEMP/REL LVLCHK(*NO) | ||
| + | |||
| + | CHGVAR &SFILE ' ' | ||
| + | CHGVAR &SLIB ' ' | ||
| + | |||
| + | OVRDBF SEL QTEMP/SEL | ||
| + | OVRDBF REL QTEMP/REL | ||
| + | CALL DISPR (&SFILE &SLIB) | ||
| + | DLTOVR *ALL | ||
| + | |||
| + | ENDPGM | ||
| + | |||
| + | </pre> | ||
| + | |||
| + | [[#top]] | ||
| + | |||
| + | ===DIS4 CL === | ||
| + | |||
| + | <pre> | ||
| + | |||
| + | /* CALL BY DIS3 TO CREATE WORK FILES */ | ||
| + | |||
| + | PGM | ||
| + | |||
| + | DCL &LIB *CHAR 10 | ||
| + | DCL &SRCF *CHAR 10 | ||
| + | |||
| + | RTVDTAARA DTAARA(UDDSSRC *ALL) RTNVAR(&SRCF) | ||
| + | |||
| + | DLTF QTEMP/XXXXFILE | ||
| + | monmsg cpf0000 | ||
| + | CRTPF FILE(QTEMP/XXXXFILE) RCDLEN(80) OPTION(*NOLIST) | ||
| + | |||
| + | DSPFFD FILE(QTEMP/XXXXFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) | ||
| + | CLRPFM QTEMP/FFD | ||
| + | DLTF FILE(QTEMP/FFDL01) | ||
| + | MONMSG CPF0000 | ||
| + | |||
| + | RTVMBRD FILE(&SRCF) RTNLIB(&LIB) | ||
| + | CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) + | ||
| + | OPTION(*NOSRC *NOLIST) | ||
| + | |||
| + | DLTF FILE(QTEMP/REL) | ||
| + | MONMSG CPF0000 | ||
| + | DLTF FILE(QTEMP/SEL) | ||
| + | MONMSG CPF0000 | ||
| + | DLTF FILE(QTEMP/DBR) | ||
| + | MONMSG CPF0000 | ||
| + | |||
| + | DSPFD FILE(QTEMP/FFD) TYPE(*ACCPTH) + | ||
| + | OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD) | ||
| + | |||
| + | DSPFD FILE(QTEMP/FFDL01) TYPE(*SELECT) OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL) | ||
| + | CLRPFM FILE(QTEMP/REL) | ||
| + | CLRPFM FILE(QTEMP/SEL) | ||
| + | |||
| + | DLTF QTEMP/XXXXFILE | ||
| + | monmsg cpf0000 | ||
| + | |||
| + | |||
| + | ENDPGM | ||
| + | |||
| + | </pre> | ||
| + | |||
| + | [[#top]] | ||
| + | |||
| + | ===DISBIN CL === | ||
| + | |||
| + | <pre> | ||
| + | /* NUMERIC TO BINARY CONVERTER */ | ||
| + | |||
| + | |||
| + | PGM (&NUM &BIN2 &BIN4 &BINTYP ) | ||
| + | |||
| + | DCL VAR(&NUM) TYPE(*DEC) LEN(15 0) | ||
| + | DCL VAR(&BINTYP) TYPE(*CHAR) LEN(1) | ||
| + | DCL VAR(&BIN2) TYPE(*CHAR) LEN(2) | ||
| + | DCL VAR(&BIN4) TYPE(*CHAR) LEN(4) | ||
| + | |||
| + | IF (&BINTYP = '4') (CHGVAR %BIN(&BIN4) &NUM) | ||
| + | IF (&BINTYP = '2') (CHGVAR %BIN(&BIN2) &NUM) | ||
| + | ENDPGM | ||
| + | |||
| + | </pre> | ||
| + | |||
| + | [[#top]] | ||
| + | |||
| + | ===DISF CL === | ||
| + | |||
| + | <pre> | ||
| + | |||
| + | /* CHECK FILE TYPE */ | ||
| + | |||
| + | PGM (&DISF &TYPE &PHY &PHYLIB) | ||
| + | |||
| + | |||
| + | DCL &DISF *CHAR 10 | ||
| + | DCL &TYPE *CHAR 1 | ||
| + | DCL &PHY *CHAR 10 | ||
| + | DCL &PHYLIB *CHAR 10 | ||
| + | DCLF KF | ||
| + | |||
| + | OVRDBF FILE(KF) TOFILE(QTEMP/&DISF) | ||
| + | OPNDBF FILE(KF) OPTION(*INP) | ||
| + | RCVF | ||
| + | CHGVAR &TYPE &APFTYP | ||
| + | |||
| + | IF (&TYPE *EQ 'L') DO | ||
| + | CHGVAR &PHY &APBOF | ||
| + | CHGVAR &PHYLIB &APBOL | ||
| + | ENDDO | ||
| + | |||
| + | CLOF OPNID(KF) | ||
| + | ENDPGM | ||
| + | |||
| + | </pre> | ||
| + | |||
| + | [[#top]] | ||
| + | |||
| + | |||
| + | |||
| + | ===DISV CL === | ||
| + | |||
| + | <pre> | ||
| + | /* VALIDITY CHECKER FOR DSPFL COMMAND */ | ||
| + | |||
| + | |||
| + | PGM (&FILIB &MBR &UPD &RST &REL) | ||
| + | |||
| + | DCL &FILIB *CHAR 20 | ||
| + | DCL &FILE *CHAR 10 | ||
| + | DCL &LIB *CHAR 10 | ||
| + | DCL &MBR *CHAR 10 | ||
| + | DCL &UPD *CHAR 1 | ||
| + | DCL &RST *CHAR 1 | ||
| + | DCL &REL *CHAR 1 | ||
| + | DCL &OBJATR *CHAR 10 | ||
| + | DCL &AUT *CHAR 8 | ||
| + | |||
| + | DCL &MSGDTA *CHAR 40 | ||
| + | DCL &ERROR *LGL | ||
| + | |||
| + | CHGVAR &FILE &FILIB | ||
| + | CHGVAR &LIB (%SST(&FILIB 11 10)) | ||
| + | IF (&MBR *EQ '*FILE') (CHGVAR &MBR &FILE ) | ||
| + | |||
| + | CHGVAR &AUT '*READ ' | ||
| + | IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE') | ||
| + | |||
| + | CHKOBJ (&LIB/&FILE) OBJTYPE(*FILE) MBR(*NONE) + | ||
| + | AUT( &AUT ) | ||
| + | MONMSG (CPF9899 CPF9801 CPF9802 CPF9820 CPF9830) EXEC(DO) | ||
| + | /* CHGVAR (&MSGDTA) VALUE(' '||&FILE||&LIB) */ | ||
| + | /* SNDPGMMSG MSGID(USR0006) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) +*/ | ||
| + | /* MSGDTA(&MSGDTA) */ | ||
| + | SNDPGMMSG MSG('Not authorised to the file.') + | ||
| + | MSGTYPE(*DIAG) | ||
| + | CHGVAR (&ERROR) '1' | ||
| + | ENDDO | ||
| + | MONMSG (CPF9810) EXEC(DO) | ||
| + | CHGVAR (&MSGDTA) VALUE(' '||&LIB) | ||
| + | /* SNDPGMMSG MSGID(USR0008) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) +*/ | ||
| + | /* MSGDTA(&MSGDTA) */ | ||
| + | SNDPGMMSG MSG('Not authorised to the file.') + | ||
| + | MSGTYPE(*DIAG) | ||
| + | CHGVAR (&ERROR) '1' | ||
| + | ENDDO | ||
| + | |||
| + | |||
| + | IF (*NOT &ERROR) DO | ||
| + | |||
| + | RTVOBJD OBJ(&LIB/&FILE) OBJTYPE(*FILE) OBJATR(&OBJATR) | ||
| + | CHGVAR &AUT '*READ ' | ||
| + | IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE') | ||
| + | |||
| + | CHKOBJ OBJ(&LIB/&FILE) OBJTYPE(*FILE) MBR(&MBR) + | ||
| + | AUT(&AUT) | ||
| + | |||
| + | MONMSG (CPF9815 ) EXEC(DO) | ||
| + | /* CHGVAR (&MSGDTA) VALUE(' '||&MBR||&FILE||&LIB) */ | ||
| + | /* SNDPGMMSG MSGID(USR0007) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */ | ||
| + | /* MSGDTA(&MSGDTA) */ | ||
| + | SNDPGMMSG MSG('Not authorised to the file.') + | ||
| + | MSGTYPE(*DIAG) | ||
| + | CHGVAR (&ERROR) '1' | ||
| + | ENDDO | ||
| + | MONMSG (CPF0000 ) EXEC(DO) | ||
| + | /* SNDPGMMSG MSGID(USR0022) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */ | ||
| + | /* MSGDTA(&MSGDTA) */ | ||
| + | SNDPGMMSG MSG('Not authorised to the file.') + | ||
| + | MSGTYPE(*DIAG) | ||
| + | CHGVAR (&ERROR) '1' | ||
| + | ENDDO | ||
| + | ENDDO | ||
| + | |||
| + | IF (&ERROR) (SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE)) | ||
| + | |||
| + | |||
| + | |||
| + | ENDPGM | ||
| + | |||
| + | </pre> | ||
| + | |||
| + | [[#top]] | ||
| + | |||
| + | |||
| + | ===DISPR RPG === | ||
| + | |||
| + | <pre> | ||
| + | H OPTIMIZE(*NONE) OPTION(*NODEBUGIO) | ||
| + | H DFTACTGRP(*NO) ACTGRP(*CALLER) | ||
| + | |||
| + | * FILE RELATIONS DISPLAYER | ||
| + | * REQUIRES FILES TO COMPILE | ||
| + | * | ||
| + | |||
| + | FREL IF E DISK | ||
| + | FSEL IF E DISK | ||
| + | FDISPRF CF E WORKSTN | ||
| + | F SFILE(S01:RS01) | ||
| + | F SFILE(S02:RS02) | ||
| + | F INFDS(SFINF) | ||
| + | * | ||
| + | |||
| + | * | ||
| + | DDISPR PR | ||
| + | D 10 | ||
| + | D 10 | ||
| + | DDISPR PI | ||
| + | D SFILE 10 | ||
| + | D SLIB 10 | ||
| + | |||
| + | // SCREEN LEVELS | ||
| + | D @SCN S 6 DIM(50) | ||
| + | D @NSCN S 6 | ||
| + | D @LV S 5 0 | ||
| + | D @ERR S LIKE(@TRUE) | ||
| + | D @FILE S 10A INZ('DISPY ') | ||
| + | D WRKSWS S 1 | ||
| + | D I S 4B 0 | ||
| + | |||
| + | |||
| + | D @TRUE S 1A INZ('1') | ||
| + | D @FALSE S 1A INZ('0') | ||
| + | D @OK S LIKE(@TRUE) | ||
| + | D @LOOP S LIKE(@TRUE) | ||
| + | |||
| + | // | ||
| + | D RS01 S 4S 0 | ||
| + | D RS02 S 4S 0 | ||
| + | // | ||
| + | // PARMS FOR SFL LOOPING | ||
| + | D SFC01 S LIKE(RS01) | ||
| + | D SFC02 S LIKE(RS01) | ||
| + | |||
| + | // Program Status | ||
| + | D SDS | ||
| + | D PGM 1 10 | ||
| + | D WSID 244 253 | ||
| + | D USER 254 263 | ||
| + | // | ||
| + | // | ||
| + | D SFINF DS | ||
| + | D RRRN 376 377B 0 | ||
| + | D SRN 378 379B 0 | ||
| + | |||
| + | // MESSAGE DATA | ||
| + | D @DTA1 DS 80 | ||
| + | D @DTA2 DS 500 | ||
| + | // | ||
| + | D MAIN PR | ||
| + | |||
| + | D @S01BLD PR | ||
| + | D @S01PRC PR | ||
| + | D @S01PRS PR | ||
| + | D @S02BLD PR | ||
| + | D @S02PRC PR | ||
| + | D | ||
| + | D @R9999 PR | ||
| + | |||
| + | D @OPADJ PR 2A | ||
| + | D OPT 2A | ||
| + | |||
| + | |||
| + | /FREE | ||
| + | *INLR = *ON; | ||
| + | MAIN(); | ||
| + | |||
| + | |||
| + | //--------------*INZSR-------------------------------// | ||
| + | BEGSR *INZSR; | ||
| + | |||
| + | // Set the TOP level (Exit if user backs up to here) | ||
| + | @LV = 1; | ||
| + | @SCN(@LV) = '*END '; | ||
| + | // Set the Initial Screen to display | ||
| + | @LV = @LV + 1; | ||
| + | @SCN(@LV) = 'S01BLD '; | ||
| + | |||
| + | ENDSR; | ||
| + | /END-FREE | ||
| + | //###################################################// | ||
| + | |||
| + | //************************************************************* | ||
| + | P MAIN B | ||
| + | |||
| + | D MAIN PI | ||
| + | |||
| + | D I S 4B 0 | ||
| + | |||
| + | /FREE | ||
| + | EXSR @INZSR; | ||
| + | // | ||
| + | // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY | ||
| + | DOW @LOOP = @LOOP; | ||
| + | // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY | ||
| + | @NSCN = @SCN(@LV); | ||
| + | SELECT; | ||
| + | // SELECT FIELDS FOR DISPLAY | ||
| + | |||
| + | // SFL TO SELECT THE FILE FIELDS | ||
| + | WHEN @NSCN = 'S01BLD'; | ||
| + | @S01BLD(); | ||
| + | WHEN @NSCN = 'S01PRC'; | ||
| + | @S01PRC(); | ||
| + | WHEN @NSCN = 'S01PRS'; | ||
| + | @S01PRS(); | ||
| + | WHEN @NSCN = 'S02BLD'; | ||
| + | @S02BLD(); | ||
| + | WHEN @NSCN = 'S02PRC'; | ||
| + | @S02PRC(); | ||
| + | OTHER; | ||
| + | // CATCH ALL (NEVER USED) | ||
| + | @R9999(); | ||
| + | LEAVE; | ||
| + | ENDSL; | ||
| + | |||
| + | // CF3 EXIT | ||
| + | IF *IN03 = *ON; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | // CF12 PREVIOUS | ||
| + | IF *IN12 = *ON; | ||
| + | *IN12 = *OFF; | ||
| + | @LV = @LV -1; | ||
| + | @NSCN = @SCN(@LV); | ||
| + | ENDIF; | ||
| + | |||
| + | // Backed out to last level, Exit | ||
| + | IF @NSCN = '*END'; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDDO; | ||
| + | |||
| + | RETURN; | ||
| + | |||
| + | //--------------*INZSR-------------------------------// | ||
| + | BEGSR @INZSR; | ||
| + | @NSCN = *BLANK; | ||
| + | |||
| + | ENDSR; | ||
| + | //-ENDSR---*INZSR-------------------------------// | ||
| + | /END-FREE | ||
| + | |||
| + | P MAIN E | ||
| + | |||
| + | |||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | /space 3 | ||
| + | P @S01BLD B | ||
| + | |||
| + | D @S01BLD PI | ||
| + | |||
| + | D WFILE S LIKE(APFILE ) | ||
| + | D WLIB S LIKE(APLIB ) | ||
| + | |||
| + | // Build/Rebuild the subfile | ||
| + | |||
| + | /FREE | ||
| + | EXSR @INZSR; | ||
| + | |||
| + | EXSR BLD; | ||
| + | |||
| + | // SFL IS BUILT, PROCESS THE SFL CONTROL | ||
| + | @LV = @LV + 1; | ||
| + | @SCN(@LV) = 'S01PRC ' ; | ||
| + | RETURN ; | ||
| + | |||
| + | //-------------- BLD -------------------------------// | ||
| + | BEGSR BLD; | ||
| + | |||
| + | EXSR CLR; | ||
| + | |||
| + | |||
| + | SETLL 1 QWHFDACP; | ||
| + | |||
| + | DOW @LOOP = @LOOP; | ||
| + | READ QWHFDACP; | ||
| + | IF %EOF; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | |||
| + | EXSR MOV; | ||
| + | // | ||
| + | RS01 = RS01 + 1; | ||
| + | WRITE S01; | ||
| + | ENDDO; | ||
| + | |||
| + | |||
| + | // Position to TOP of subfile | ||
| + | SRS01 = 1; | ||
| + | SFC01 = RS01; | ||
| + | ENDSR; | ||
| + | |||
| + | //-------------- CLR -------------------------------// | ||
| + | BEGSR CLR; | ||
| + | |||
| + | *IN51 = *OFF; | ||
| + | *IN52 = *OFF; | ||
| + | *IN53 = *ON; | ||
| + | WRITE C01; | ||
| + | *IN53 = *OFF; | ||
| + | RS01 = 0 ; | ||
| + | SFC01 = 0 ; | ||
| + | S01FUNC = *BLANK; | ||
| + | ENDSR; | ||
| + | |||
| + | //-------------- MOV -------------------------------// | ||
| + | BEGSR MOV; | ||
| + | |||
| + | C01APBOF = APBOF ; | ||
| + | C01APBOL = APBOL ; | ||
| + | |||
| + | IF APBOF = *BLANK AND APBOL = *BLANK; | ||
| + | C01APBOF = APFILE; | ||
| + | C01APBOL = APLIB; | ||
| + | ENDIF; | ||
| + | |||
| + | // Load the subfile record | ||
| + | |||
| + | IF APFILE = WFILE AND | ||
| + | APLIB = WLIB ; | ||
| + | *IN56 = *ON ; | ||
| + | S01APFILE = *BLANK; | ||
| + | S01APLIB = *BLANK; | ||
| + | S01APACCP = *BLANK; | ||
| + | S01APUNIQ = *BLANK; | ||
| + | S01APSELO = *BLANK; | ||
| + | S01APFTYP = *BLANK; | ||
| + | S01APJOIN = *BLANK; | ||
| + | S01APKEYO = *BLANK; | ||
| + | S01APKSEQ = APKSEQ ; | ||
| + | S01APKSIN = APKSIN ; | ||
| + | S01APKEYF = APKEYF ; | ||
| + | ELSE ; | ||
| + | WFILE = APFILE; | ||
| + | WLIB = APLIB ; | ||
| + | *IN56 = *OFF; | ||
| + | S01APFILE = APFILE ; | ||
| + | S01APLIB = APLIB ; | ||
| + | S01APACCP = APACCP ; | ||
| + | S01APUNIQ = APUNIQ ; | ||
| + | S01APSELO = APSELO ; | ||
| + | S01APFTYP = APFTYP ; | ||
| + | S01APJOIN = APJOIN ; | ||
| + | S01APKEYO = APKEYO ; | ||
| + | S01APKSEQ = APKSEQ ; | ||
| + | S01APKSIN = APKSIN ; | ||
| + | S01APKEYF = APKEYF ; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDSR; | ||
| + | |||
| + | //--------------*INZSR-------------------------------// | ||
| + | BEGSR @INZSR; | ||
| + | @NSCN = *BLANK; | ||
| + | ENDSR; | ||
| + | /END-FREE | ||
| + | |||
| + | P @S01BLD E | ||
| + | |||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | |||
| + | /space 3 | ||
| + | P @S01PRC B | ||
| + | |||
| + | D @S01PRC PI | ||
| + | |||
| + | // | ||
| + | // | ||
| + | D WRKRC S 4S 0 | ||
| + | |||
| + | /FREE | ||
| + | EXSR @INZSR; | ||
| + | |||
| + | WRITE R01; | ||
| + | // | ||
| + | DOW @LOOP = @LOOP; | ||
| + | |||
| + | // | ||
| + | // Write SFL Control | ||
| + | IF SFC01 > 0; | ||
| + | *IN51 = *ON; | ||
| + | ENDIF; | ||
| + | *IN52 = *ON; | ||
| + | |||
| + | |||
| + | EXFMT C01; | ||
| + | // Setoff errors | ||
| + | *IN89 = *OFF; | ||
| + | // | ||
| + | // Exit and Previous Screen | ||
| + | IF *IN03 = *ON; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | IF *IN12 = *ON; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | |||
| + | // Process the subfile | ||
| + | @LV = @LV + 1; | ||
| + | @SCN(@LV) = 'S01PRS'; | ||
| + | LEAVE; | ||
| + | |||
| + | ENDDO; | ||
| + | // | ||
| + | RETURN; | ||
| + | |||
| + | /space 3 | ||
| + | |||
| + | |||
| + | //--------------*INZSR-------------------------------// | ||
| + | BEGSR @INZSR; | ||
| + | @NSCN = *BLANK; | ||
| + | ENDSR; | ||
| + | /END-FREE | ||
| + | P @S01PRC E | ||
| + | |||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | /space 3 | ||
| + | P @S01PRS B | ||
| + | |||
| + | D @S01PRS PI | ||
| + | |||
| + | // | ||
| + | // | ||
| + | D WRKRC S 4S 0 | ||
| + | |||
| + | /FREE | ||
| + | |||
| + | EXSR @INZSR; | ||
| + | |||
| + | // Process the subfile | ||
| + | EXSR SFL; | ||
| + | RETURN; | ||
| + | |||
| + | //-------------- SFL -------------------------------// | ||
| + | BEGSR SFL; | ||
| + | // Process the subfile | ||
| + | |||
| + | FOR WRKRC = 1 TO SFC01 + 1 ; | ||
| + | CHAIN WRKRC S01; | ||
| + | IF NOT %FOUND; | ||
| + | // Finished with the subfile | ||
| + | @LV = @LV -1; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | // GET SELECTED FILE | ||
| + | IF @OPADJ(S01FUNC) = ' X'; | ||
| + | SFILE = S01APFILE; | ||
| + | SLIB = S01APLIB ; | ||
| + | *IN03 = '1'; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | |||
| + | // SHOW SELECT RULES | ||
| + | IF @OPADJ(S01FUNC) = ' R'; | ||
| + | @LV = @LV + 1; | ||
| + | @SCN(@LV) = 'S02BLD '; | ||
| + | S01FUNC = ' '; | ||
| + | UPDATE S01; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDFOR; | ||
| + | |||
| + | ENDSR; | ||
| + | //---------------------------------------------------// | ||
| + | |||
| + | |||
| + | |||
| + | //--------------*INZSR-------------------------------// | ||
| + | BEGSR @INZSR; | ||
| + | @NSCN = *BLANK; | ||
| + | ENDSR; | ||
| + | |||
| + | |||
| + | /END-FREE | ||
| + | P @S01PRS E | ||
| + | |||
| + | |||
| + | /space 3 | ||
| + | P @S02BLD B | ||
| + | |||
| + | D @S02BLD PI | ||
| + | |||
| + | // Build/Rebuild the subfile | ||
| + | /FREE | ||
| + | |||
| + | EXSR @INZSR; | ||
| + | |||
| + | C02APFILE = S01APFILE ; | ||
| + | C02APLIB = S01APLIB ; | ||
| + | |||
| + | EXSR BLD; | ||
| + | |||
| + | // SFL IS BUILT, PROCESS THE CONTROL | ||
| + | @LV = @LV + 1; | ||
| + | @SCN(@LV) = 'S02PRC '; | ||
| + | RETURN; | ||
| + | //-------------- BLD -------------------------------// | ||
| + | BEGSR BLD; | ||
| + | |||
| + | EXSR CLR; | ||
| + | |||
| + | |||
| + | SETLL 1 QWHFDSO ; | ||
| + | |||
| + | DOW @LOOP = @LOOP; | ||
| + | |||
| + | READ QWHFDSO ; | ||
| + | IF %EOF; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | If SOFILE = S01APFILE AND | ||
| + | SOLIB = S01APLIB ; | ||
| + | EXSR MOV; | ||
| + | |||
| + | // | ||
| + | RS02 = RS02 + 1; | ||
| + | WRITE S02; | ||
| + | ENDIF; | ||
| + | ENDDO; | ||
| + | |||
| + | // Position to TOP of subfile | ||
| + | SRS02 = 1; | ||
| + | SFC02 = RS02; | ||
| + | ENDSR; | ||
| + | |||
| + | //-------------- CLR -------------------------------// | ||
| + | BEGSR CLR; | ||
| + | *IN51 = *OFF; | ||
| + | *IN52 = *OFF; | ||
| + | *IN53 = *ON; | ||
| + | WRITE C02; | ||
| + | *IN53 = *OFF; | ||
| + | RS02 =0; | ||
| + | SFC02=0; | ||
| + | |||
| + | ENDSR; | ||
| + | |||
| + | //-------------- MOV -------------------------------// | ||
| + | BEGSR MOV; | ||
| + | // Load the subfile record | ||
| + | |||
| + | S02SOFLD = SOFLD ; | ||
| + | S02SORULE = SORULE ; | ||
| + | S02SOCOMP = SOCOMP ; | ||
| + | S02SOVALU = SOVALU ; | ||
| + | |||
| + | |||
| + | |||
| + | ENDSR; | ||
| + | |||
| + | //--------------*INZSR-------------------------------// | ||
| + | BEGSR @INZSR; | ||
| + | @NSCN = *BLANK; | ||
| + | ENDSR; | ||
| + | |||
| + | /END-FREE | ||
| + | P @S02BLD E | ||
| + | |||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | /space 3 | ||
| + | P @S02PRC B | ||
| + | |||
| + | D @S02PRC PI | ||
| + | |||
| + | // | ||
| + | // | ||
| + | D WRKRC S 4S 0 | ||
| + | |||
| + | /FREE | ||
| + | |||
| + | EXSR @INZSR; | ||
| + | |||
| + | WRITE R02; | ||
| + | |||
| + | // | ||
| + | DOW @LOOP = @LOOP; | ||
| + | |||
| + | // | ||
| + | // Write SFL Control | ||
| + | IF SFC02 > 0; | ||
| + | *IN51 = *ON; | ||
| + | ENDIF; | ||
| + | *IN52 = *ON; | ||
| + | EXFMT C02; | ||
| + | // | ||
| + | // Setoff errors | ||
| + | *IN89 = *OFF; | ||
| + | // | ||
| + | // Exit and Previous Screen | ||
| + | |||
| + | @LV = @LV -2; | ||
| + | LEAVE; | ||
| + | |||
| + | |||
| + | // Process the subfile | ||
| + | |||
| + | ENDDO; | ||
| + | // | ||
| + | RETURN; | ||
| + | |||
| + | /space 3 | ||
| + | //--------------*INZSR-------------------------------// | ||
| + | BEGSR @INZSR; | ||
| + | |||
| + | @NSCN = *BLANK; | ||
| + | ENDSR; | ||
| + | /END-FREE | ||
| + | P @S02PRC E | ||
| + | |||
| + | |||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | |||
| + | P @R9999 B | ||
| + | // Invalid Panel | ||
| + | D @R9999 PI | ||
| + | |||
| + | P @R9999 E | ||
| + | |||
| + | |||
| + | /space 3 | ||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | P @OPADJ B | ||
| + | // RIGHT ADJ OPTION , zero suppress | ||
| + | |||
| + | D @OPADJ PI 2A | ||
| + | D OPT 2A | ||
| + | |||
| + | /FREE | ||
| + | EVALR OPT = %trimr(OPT); | ||
| + | If %SubSt(OPT:1:1) = '0'; | ||
| + | OPT = ' ' + %SubSt(OPT:2:1); | ||
| + | EndIf; | ||
| + | RETURN OPT; | ||
| + | /END-FREE | ||
| + | P @OPADJ E | ||
| + | |||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | |||
| + | </pre> | ||
| + | |||
| + | [[#top]] | ||
| + | |||
| + | ===DISPRF DSPF === | ||
| + | |||
| + | <pre> | ||
| + | |||
| + | A*%%TS SD 20101208 163705 KOLMANNF REL-V5R4M0 5722-WDS | ||
| + | A* | ||
| + | * REQUIRES FILES TO COMPILE | ||
| + | * CRTDUPOBJ OBJ(QAFDSELO) FROMLIB(QSYS) | ||
| + | * OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(SEL) | ||
| + | * CRTDUPOBJ OBJ(QAFDACCP) FROMLIB(QSYS) | ||
| + | * OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(ACC) | ||
| + | |||
| + | |||
| + | A*%%EC | ||
| + | A DSPSIZ(24 80 *DS3) | ||
| + | A PRINT | ||
| + | A CF03(03) | ||
| + | A CF12(12) | ||
| + | A R S01 SFL | ||
| + | A*%%TS SD 20101208 163705 KOLMANNF REL-V5R4M0 5722-WDS | ||
| + | A S01FUNC 2A I 4 3 | ||
| + | A 55 | ||
| + | AO 56 DSPATR(PR) | ||
| + | A S01APFILE R O 4 6REFFLD(QWHFDACP/APFILE QTEMP/REL) | ||
| + | A S01APLIB R O 4 17REFFLD(QWHFDACP/APLIB QTEMP/REL) | ||
| + | A S01APACCP R O 4 29REFFLD(QWHFDACP/APACCP QTEMP/REL) | ||
| + | A S01APUNIQ R O 4 33REFFLD(QWHFDACP/APUNIQ QTEMP/REL) | ||
| + | A S01APSELO R O 4 37REFFLD(QWHFDACP/APSELO QTEMP/REL) | ||
| + | A S01APFTYP R O 4 41REFFLD(QWHFDACP/APFTYP QTEMP/REL) | ||
| + | A S01APJOIN R O 4 45REFFLD(QWHFDACP/APJOIN QTEMP/REL) | ||
| + | A S01APKEYO R O 4 48REFFLD(QWHFDACP/APKEYO QTEMP/REL) | ||
| + | A S01APKSEQ R O 4 53REFFLD(QWHFDACP/APKSEQ QTEMP/REL) | ||
| + | A S01APKSIN R O 4 57REFFLD(QWHFDACP/APKSIN QTEMP/REL) | ||
| + | A S01APKEYF R O 4 61REFFLD(QWHFDACP/APKEYF QTEMP/REL) | ||
| + | A R C01 SFLCTL(S01) | ||
| + | A*%%TS SD 20101208 163705 KOLMANNF REL-V5R4M0 5722-WDS | ||
| + | A SFLSIZ(0019) | ||
| + | A SFLPAG(0018) | ||
| + | A OVERLAY | ||
| + | A 50 SFLEND | ||
| + | A 51 SFLDSP | ||
| + | A 52 SFLDSPCTL | ||
| + | A 53 SFLCLR | ||
| + | A SRS01 4S 0H SFLRCDNBR(CURSOR) | ||
| + | A* | ||
| + | A 1 18'FILE RELATIONS for ' | ||
| + | A C01APBOF R O 1 39REFFLD(QWHFDACP/APBOF QTEMP/REL) | ||
| + | A 1 51'Lib.' | ||
| + | A C01APBOL R O 1 56REFFLD(QWHFDACP/APBOL QTEMP/REL) | ||
| + | A 2 32'Uni SEL LIFO ASC Key' | ||
| + | A 3 6'File Library Acc Key OMT - | ||
| + | A TYP J FIFO DSC Sgn Key' | ||
| + | A R R01 | ||
| + | A 24 3'F3-Exit' | ||
| + | A 22 3'R - Display Select/Omit rules' | ||
| + | A 23 3'X - Select for display' | ||
| + | * | ||
| + | A R R02 | ||
| + | A 24 3'F3-Exit' | ||
| + | A R S02 SFL | ||
| + | A SFLNXTCHG | ||
| + | A S02SOFLD R O 4 4REFFLD(QWHFDSO/SOFLD QTEMP/SEL) | ||
| + | A S02SORULE R O 4 17REFFLD(QWHFDSO/SORULE QTEMP/SEL) | ||
| + | A S02SOCOMP R O 4 22REFFLD(QWHFDSO/SOCOMP QTEMP/SEL) | ||
| + | A S02SOVALU R O 4 28REFFLD(QWHFDSO/SOVALU QTEMP/SEL) | ||
| + | |||
| + | A R C02 SFLCTL(S02 ) | ||
| + | A OVERLAY | ||
| + | A 50 SFLEND | ||
| + | A 51 SFLDSP | ||
| + | A 52 SFLDSPCTL | ||
| + | A 53 SFLCLR | ||
| + | A SFLSIZ(0019) | ||
| + | A SFLPAG(0018) | ||
| + | A SRS02 4S 0H SFLRCDNBR(CURSOR) | ||
| + | A* | ||
| + | A 1 6'FILE SELECTS for ' | ||
| + | A C02APFILE R O 2 7REFFLD(QWHFDSO/SOFILE QTEMP/SEL) | ||
| + | A 2 20'Lib.' | ||
| + | A C02APLIB R O 2 25REFFLD(QWHFDSO/SOLIB QTEMP/SEL) | ||
| + | A 3 4'Field' | ||
| + | A 3 28'Select/Omit Value' | ||
| + | A 3 16'S/O' | ||
| + | A 3 21'COMP' | ||
| + | |||
| + | </pre> | ||
| + | |||
| + | [[#top]] | ||
| + | |||
| + | |||
| + | ===DISPY RPG === | ||
| + | |||
| + | <pre> | ||
| + | H OPTIMIZE(*NONE) OPTION(*NODEBUGIO) | ||
| + | H DFTACTGRP(*NO) ACTGRP(*CALLER) | ||
| + | |||
| + | //*************************************************************** | ||
| + | // | ||
| + | // PROGRAM ID : DISPY | ||
| + | // Description: DISPLAY A FILES FIELDS FOR SELECTION | ||
| + | |||
| + | // needs files KF FFD to compile use following commands | ||
| + | // DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KF) | ||
| + | // DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) | ||
| + | //*************************************************************** | ||
| + | // MODIFICATIONS: | ||
| + | // MOD SR DATE MODIFICATION SUMMARY | ||
| + | // | ||
| + | //*************************************************************** | ||
| + | // | ||
| + | FKF IF E DISK | ||
| + | FFFD UF E DISK | ||
| + | FINPUT IF F32766 2000AIDISK KEYLOC(1) | ||
| + | F INFDS(INFDS) | ||
| + | FDISPYF CF E WORKSTN | ||
| + | F SFILE(S01:RS01) | ||
| + | F INFDS(SFINF) | ||
| + | // | ||
| + | // | ||
| + | |||
| + | // SCREEN LEVELS | ||
| + | D @SCN S 6 DIM(50) | ||
| + | D @NSCN S 6 | ||
| + | D @LV S 5 0 | ||
| + | D @ERR S LIKE(@TRUE) | ||
| + | D @FILE S 10A INZ('DISPY ') | ||
| + | D WRKSWS S 1 | ||
| + | D I S 4B 0 | ||
| + | |||
| + | |||
| + | D @TRUE S 1A INZ('1') | ||
| + | D @FALSE S 1A INZ('0') | ||
| + | D @OK S LIKE(@TRUE) | ||
| + | D @LOOP S LIKE(@TRUE) | ||
| + | |||
| + | // | ||
| + | D RS01 S 4S 0 | ||
| + | // | ||
| + | // PARMS FOR SFL LOOPING | ||
| + | D SFC01 S LIKE(RS01) | ||
| + | |||
| + | // Program Status | ||
| + | D SDS | ||
| + | D PGM 1 10 | ||
| + | D WSID 244 253 | ||
| + | D USER 254 263 | ||
| + | // | ||
| + | // | ||
| + | D SFINF DS | ||
| + | D RRRN 376 377B 0 | ||
| + | D SRN 378 379B 0 | ||
| + | |||
| + | // | ||
| + | D FLD S 10 DIM(9000) | ||
| + | D KEY S 10 DIM(99) | ||
| + | |||
| + | D INFDS DS | ||
| + | D FILE 83 92 | ||
| + | D LIB 93 102 | ||
| + | D MBR 129 138 | ||
| + | D RCDL 125 126B 0 | ||
| + | D RCDS 156 159B 0 | ||
| + | D ACCTP 160 160 | ||
| + | |||
| + | D DS | ||
| + | D WHCOLD 1 60 | ||
| + | D WHCHD1 1 20 | ||
| + | D WHCHD2 21 40 | ||
| + | D WHCHD3 41 60 | ||
| + | |||
| + | D DS | ||
| + | D POSN 1 10 | ||
| + | D P1 1 10 DIM(10) | ||
| + | |||
| + | D POSNN 11 20 | ||
| + | D P2 11 20 DIM(10) | ||
| + | |||
| + | |||
| + | * | ||
| + | // MESSAGE DATA | ||
| + | D @DTA1 DS 80 | ||
| + | D @DTA2 DS 500 | ||
| + | // | ||
| + | D MAIN PR | ||
| + | |||
| + | D @S01BLD PR | ||
| + | D @S01PRC PR | ||
| + | D @S01PRS PR | ||
| + | D | ||
| + | D @R9999 PR | ||
| + | |||
| + | D @OPADJ PR 2A | ||
| + | D OPT 2A | ||
| + | |||
| + | * | ||
| + | DDISPY PR | ||
| + | D 1 | ||
| + | D 1 | ||
| + | D 4 | ||
| + | D 1 | ||
| + | D 1 | ||
| + | D 5 | ||
| + | DDISPY PI | ||
| + | D ALL 1 | ||
| + | D RTN 1 | ||
| + | D KEYLNG 4 | ||
| + | D ACCP 1 | ||
| + | D QRY 1 | ||
| + | D RCDLN 5 | ||
| + | * | ||
| + | D KEYLN S 4S 0 | ||
| + | D RCDLEN S 5S 0 | ||
| + | *------------------------------------------------------------------- | ||
| + | * QMHRTVM API (Retrieve Message text) | ||
| + | *------------------------------------------------------------------- | ||
| + | D RtvMsgTxt PR 1024 | ||
| + | D RMsgId 7 Const | ||
| + | D RMsgFle 10 Const | ||
| + | D RMsgLib 10 Const | ||
| + | D RMsgLvl 1 Const | ||
| + | |||
| + | D GETROWCOL PR | ||
| + | D 10A const | ||
| + | D 10A const | ||
| + | D 10A const | ||
| + | D 32A const | ||
| + | D 3P 0 | ||
| + | D 3P 0 | ||
| + | |||
| + | D SysDate PR 8S 0 | ||
| + | D SysTime PR 6S 0 | ||
| + | D DayOfWeek PR 10I 0 | ||
| + | D D value datfmt(*iso) | ||
| + | // Message file names | ||
| + | D cMsgLib C Const('*LIBL ') | ||
| + | D cMsgF1 C Const('MSGF1 ') | ||
| + | D cMsgF2 C Const('MSGF2 ') | ||
| + | D cMsgLvl1 C Const('1') | ||
| + | D cMsgLvl2 C Const('2') | ||
| + | |||
| + | * | ||
| + | IINPUT NS 01 | ||
| + | I 1 256 D | ||
| + | |||
| + | /FREE | ||
| + | *INLR = *ON; | ||
| + | MAIN(); | ||
| + | |||
| + | |||
| + | //--------------*INZSR-------------------------------// | ||
| + | BEGSR *INZSR; | ||
| + | |||
| + | // Set the TOP level (Exit if user backs up to here) | ||
| + | @LV = 1; | ||
| + | @SCN(@LV) = '*END '; | ||
| + | // Set the Initial Screen to display | ||
| + | @LV = @LV + 1; | ||
| + | @SCN(@LV) = 'S01BLD '; | ||
| + | |||
| + | // DUMMY I/O TO GET NUMBER OF RECORDS IN FILE | ||
| + | READ INPUT; | ||
| + | // SFL IS NOT LOADED | ||
| + | // READ THE LIST OF KEY FIELDS IN THE FILE SO THAT WE CAN LATER MARK THEM | ||
| + | ACCP = ACCTP; | ||
| + | |||
| + | I = 0; | ||
| + | |||
| + | DOW @LOOP = @LOOP; | ||
| + | READ QWHFDACP; | ||
| + | IF %EOF; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | I = I + 1; | ||
| + | KEY(I) = APKEYF; | ||
| + | ENDDO; | ||
| + | ENDSR; | ||
| + | /END-FREE | ||
| + | //###################################################// | ||
| + | |||
| + | //************************************************************* | ||
| + | P MAIN B | ||
| + | |||
| + | D MAIN PI | ||
| + | |||
| + | D I S 4B 0 | ||
| + | |||
| + | /FREE | ||
| + | EXSR @INZSR; | ||
| + | // | ||
| + | // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY | ||
| + | DOW @LOOP = @LOOP; | ||
| + | // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY | ||
| + | @NSCN = @SCN(@LV); | ||
| + | SELECT; | ||
| + | // SELECT FIELDS FOR DISPLAY | ||
| + | |||
| + | // SFL TO SELECT THE FILE FIELDS | ||
| + | WHEN @NSCN = 'S01BLD'; | ||
| + | @S01BLD(); | ||
| + | WHEN @NSCN = 'S01PRC'; | ||
| + | @S01PRC(); | ||
| + | WHEN @NSCN = 'S01PRS'; | ||
| + | @S01PRS(); | ||
| + | OTHER; | ||
| + | // CATCH ALL (NEVER USED) | ||
| + | @R9999(); | ||
| + | LEAVE; | ||
| + | ENDSL; | ||
| + | |||
| + | // CF3 EXIT | ||
| + | IF *IN03 = *ON; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | // CF12 PREVIOUS | ||
| + | IF *IN12 = *ON; | ||
| + | *IN12 = *OFF; | ||
| + | @LV = @LV -1; | ||
| + | @NSCN = @SCN(@LV); | ||
| + | ENDIF; | ||
| + | |||
| + | // Backed out to last level, Exit | ||
| + | IF @NSCN = '*END'; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDDO; | ||
| + | |||
| + | KEYLNG = %EDITC(KEYLN:'X'); | ||
| + | RETURN; | ||
| + | |||
| + | //--------------*INZSR-------------------------------// | ||
| + | BEGSR @INZSR; | ||
| + | @NSCN = *BLANK; | ||
| + | RCDLEN = RCDL; | ||
| + | RCDLN = %CHAR(RCDLEN); | ||
| + | |||
| + | // CLEAR FIELD SELECTIONS | ||
| + | IF RTN = '2'; | ||
| + | SETLL 1 QWHDRFFD; | ||
| + | DOW @LOOP = @LOOP; | ||
| + | READ QWHDRFFD ; | ||
| + | IF %EOF; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | WHFIOB = ' '; | ||
| + | UPDATE QWHDRFFD; | ||
| + | ENDDO; | ||
| + | |||
| + | // SET FILE I/O TO FIRST RCD IN FILE | ||
| + | SETLL 1 QWHDRFFD; | ||
| + | RTN = '0'; | ||
| + | ELSE; | ||
| + | CHAIN 1 QWHDRFFD; | ||
| + | SETLL 1 QWHDRFFD; | ||
| + | ENDIF; | ||
| + | ENDSR; | ||
| + | //-ENDSR---*INZSR-------------------------------// | ||
| + | /END-FREE | ||
| + | |||
| + | P MAIN E | ||
| + | |||
| + | |||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | /space 3 | ||
| + | P @S01BLD B | ||
| + | |||
| + | D @S01BLD PI | ||
| + | |||
| + | D SZ DS 6 | ||
| + | D LEN1 1 1 | ||
| + | D LEN2 2 3 | ||
| + | D LEN3 1 3 | ||
| + | D COMA 4 4 | ||
| + | D DEC1 5 5 | ||
| + | D DEC2 5 6 | ||
| + | |||
| + | D DS | ||
| + | D K 1 3 0 | ||
| + | D KA 2 3 | ||
| + | |||
| + | // Build/Rebuild the subfile | ||
| + | |||
| + | /FREE | ||
| + | EXSR @INZSR; | ||
| + | |||
| + | EXSR BLD; | ||
| + | |||
| + | // SFL IS BUILT, PROCESS THE SFL CONTROL | ||
| + | @LV = @LV + 1; | ||
| + | @SCN(@LV) = 'S01PRC ' ; | ||
| + | RETURN ; | ||
| + | //-------------- BLD -------------------------------// | ||
| + | BEGSR BLD; | ||
| + | |||
| + | EXSR CLR; | ||
| + | |||
| + | DOW @LOOP = @LOOP; | ||
| + | |||
| + | READ QWHDRFFD; | ||
| + | IF %EOF; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | EXSR MOV; | ||
| + | |||
| + | // FLAG THE KEY FIELDS | ||
| + | K = %LOOKUP(WHFLDE :KEY); | ||
| + | WHDFTL = K ; | ||
| + | UPDATE QWHDRFFD; | ||
| + | |||
| + | RS01 = RS01 + 1; | ||
| + | WRITE S01; | ||
| + | ENDDO; | ||
| + | |||
| + | // Position to TOP of subfile | ||
| + | SRS01 = 1; | ||
| + | SFC01 = RS01; | ||
| + | ENDSR; | ||
| + | |||
| + | //-------------- CLR -------------------------------// | ||
| + | BEGSR CLR; | ||
| + | I = 0; | ||
| + | CLEAR FLD; | ||
| + | KEYLN = 0; | ||
| + | |||
| + | *IN51 = *OFF; | ||
| + | *IN52 = *OFF; | ||
| + | *IN53 = *ON; | ||
| + | WRITE C01; | ||
| + | *IN53 = *OFF; | ||
| + | RS01 = 0 ; | ||
| + | SFC01 = 0 ; | ||
| + | S01OPT= *BLANK; | ||
| + | ENDSR; | ||
| + | |||
| + | //-------------- MOV -------------------------------// | ||
| + | BEGSR MOV; | ||
| + | // Load the subfile record | ||
| + | |||
| + | |||
| + | S01OPT = WHFIOB ; | ||
| + | S01WHFLDB = WHFLDB; | ||
| + | S01WHFLDT = WHFLDT; | ||
| + | S01WHFLD = WHFLDE ; | ||
| + | S01SFLD = WHFLDE ; | ||
| + | S01FROM = WHFOBO; | ||
| + | S01TO = WHFLDB + WHFOBO -1 ; | ||
| + | |||
| + | // KEY FIELDS | ||
| + | S01KEYFLD = ' '; | ||
| + | K = %LOOKUP(WHFLDE :KEY); | ||
| + | IF K <> 0; | ||
| + | S01KEYFLD = KA; | ||
| + | IF K < 10; | ||
| + | %SUBST(S01KEYFLD:1:1) = 'K'; | ||
| + | ENDIF; | ||
| + | KEYLN = KEYLN + WHFLDB; | ||
| + | ENDIF; | ||
| + | // FORMAT THE FIELD LENGTH | ||
| + | S01SIZE = ' '; | ||
| + | SZ = ' '; | ||
| + | IF WHFLDD = 0; | ||
| + | LEN3 = %SUBST(%EDITC(WHFLDB:'Z'):3:3); | ||
| + | ELSE; | ||
| + | LEN2 = %EDITC(WHFLDD:'Z') ; | ||
| + | COMA = ','; | ||
| + | |||
| + | IF WHFLDP > 9; | ||
| + | DEC2 = %CHAR(WHFLDP); | ||
| + | ELSE; | ||
| + | DEC1 = %CHAR(WHFLDP); | ||
| + | ENDIF; | ||
| + | ENDIF; | ||
| + | IF LEN1 = '0'; | ||
| + | LEN1 = ' '; | ||
| + | ENDIF; | ||
| + | S01SIZE = SZ; | ||
| + | |||
| + | S01DESC = WHFTXT; | ||
| + | IF S01DESC= ' '; | ||
| + | S01DESC = WHCOLD ; | ||
| + | ENDIF; | ||
| + | |||
| + | I = I + 1; | ||
| + | FLD(I) = S01WHFLD; | ||
| + | |||
| + | ENDSR; | ||
| + | |||
| + | //--------------*INZSR-------------------------------// | ||
| + | BEGSR @INZSR; | ||
| + | @NSCN = *BLANK; | ||
| + | ENDSR; | ||
| + | /END-FREE | ||
| + | |||
| + | P @S01BLD E | ||
| + | |||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | |||
| + | /space 3 | ||
| + | P @S01PRC B | ||
| + | |||
| + | D @S01PRC PI | ||
| + | |||
| + | // | ||
| + | // | ||
| + | D WRKRC S 4S 0 | ||
| + | D C01CHK S LIKE(C01POSN) | ||
| + | |||
| + | /FREE | ||
| + | EXSR @INZSR; | ||
| + | |||
| + | WRITE R01; | ||
| + | |||
| + | // | ||
| + | DOW @LOOP = @LOOP; | ||
| + | |||
| + | // | ||
| + | // Write SFL Control | ||
| + | IF SFC01 > 0; | ||
| + | *IN51 = *ON; | ||
| + | ENDIF; | ||
| + | *IN52 = *ON; | ||
| + | EXFMT C01; | ||
| + | // Setoff errors | ||
| + | *IN89 = *OFF; | ||
| + | // | ||
| + | // Exit and Previous Screen | ||
| + | IF *IN03 = *ON; | ||
| + | RTN = '1'; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | IF *IN12 = *ON; | ||
| + | @LV = @LV -1; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | // Set up for qry selection and exit | ||
| + | IF *IN06 = *ON; | ||
| + | *IN03 = *ON; | ||
| + | QRY = '1'; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | // POSITION | ||
| + | IF C01POSN <> ' '; | ||
| + | EXSR POS; | ||
| + | ITER; | ||
| + | ENDIF; | ||
| + | |||
| + | // Process the subfile | ||
| + | @LV = @LV + 1; | ||
| + | @SCN(@LV) = 'S01PRS'; | ||
| + | LEAVE; | ||
| + | |||
| + | ENDDO; | ||
| + | // | ||
| + | RETURN; | ||
| + | |||
| + | /space 3 | ||
| + | |||
| + | //--------------POS -------------------------------// | ||
| + | BEGSR POS; | ||
| + | |||
| + | |||
| + | FOR WRKRC = 1 TO SFC01; | ||
| + | CHAIN WRKRC S01; | ||
| + | IF NOT %FOUND; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | C01CHK = %SUBST(S01WHFLD :1 : %LEN(%TRIM(C01POSN))); | ||
| + | IF (C01POSN = C01CHK ); | ||
| + | SRS01 = WRKRC; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | ENDFOR; | ||
| + | |||
| + | |||
| + | ENDSR; | ||
| + | |||
| + | |||
| + | //--------------*INZSR-------------------------------// | ||
| + | BEGSR @INZSR; | ||
| + | @NSCN = *BLANK; | ||
| + | |||
| + | C01FILE = FILE; | ||
| + | C01LIB = LIB; | ||
| + | C01MBR = MBR; | ||
| + | C01RCDL = RCDL; | ||
| + | C01ACCTP = ACCTP; | ||
| + | C01WHTEXT = WHTEXT; | ||
| + | C01RCORDS = RCDS; | ||
| + | C01POSN = ' ' ; | ||
| + | C01WHNAME = WHNAME; | ||
| + | |||
| + | ENDSR; | ||
| + | /END-FREE | ||
| + | |||
| + | P @S01PRC E | ||
| + | |||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | /space 3 | ||
| + | P @S01PRS B | ||
| + | |||
| + | D @S01PRS PI | ||
| + | |||
| + | // | ||
| + | // | ||
| + | D WRKRC S 4S 0 | ||
| + | D FX S 5S 0 | ||
| + | |||
| + | /FREE | ||
| + | |||
| + | EXSR @INZSR; | ||
| + | |||
| + | // Process the subfile | ||
| + | EXSR SFL; | ||
| + | *IN03 = '1'; | ||
| + | RETURN; | ||
| + | |||
| + | //-------------- SFL -------------------------------// | ||
| + | BEGSR SFL; | ||
| + | // Process the subfile | ||
| + | |||
| + | FOR WRKRC = 1 TO SFC01+1; | ||
| + | CHAIN WRKRC S01; | ||
| + | IF NOT %FOUND; | ||
| + | // Finished with the subfile | ||
| + | // RETURN TO REBUILD LEVEL | ||
| + | @LV = @LV -2; | ||
| + | LEAVE; | ||
| + | ENDIF; | ||
| + | |||
| + | // RIGHT ADJUST OPTION | ||
| + | S01OPT = @OPADJ(S01OPT); | ||
| + | |||
| + | // UPDATE SELECTIONS | ||
| + | EXSR UPD; | ||
| + | |||
| + | ENDFOR; | ||
| + | |||
| + | ENDSR; | ||
| + | //---------------------------------------------------// | ||
| + | |||
| + | //--------------UPD ---------------------------------// | ||
| + | BEGSR UPD; | ||
| + | |||
| + | // UPDATE FIELD NAMES AND SELECT FLAG | ||
| + | FX = %LOOKUP(S01SFLD :FLD); | ||
| + | CHAIN FX QWHDRFFD; | ||
| + | WHFLDE = S01WHFLD; | ||
| + | |||
| + | IF @OPADJ(S01OPT) = ' S' OR | ||
| + | @OPADJ(S01OPT) = ' O'; | ||
| + | ALL = %TRIM(S01OPT); | ||
| + | WHFIOB = %TRIM(S01OPT); | ||
| + | ENDIF; | ||
| + | |||
| + | IF @OPADJ(S01OPT) = ' '; | ||
| + | WHFIOB = ' '; | ||
| + | ENDIF; | ||
| + | UPDATE QWHDRFFD; | ||
| + | |||
| + | ENDSR; | ||
| + | |||
| + | |||
| + | //--------------*INZSR-------------------------------// | ||
| + | BEGSR @INZSR; | ||
| + | ALL = '1'; | ||
| + | @NSCN = *BLANK; | ||
| + | ENDSR; | ||
| + | |||
| + | |||
| + | /END-FREE | ||
| + | P @S01PRS E | ||
| + | |||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | |||
| + | P @R9999 B | ||
| + | // Invalid Panel | ||
| + | D @R9999 PI | ||
| + | |||
| + | P @R9999 E | ||
| + | |||
| + | |||
| + | /space 3 | ||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | P @OPADJ B | ||
| + | // RIGHT ADJ OPTION , zero suppress | ||
| + | |||
| + | D @OPADJ PI 2A | ||
| + | D OPT 2A | ||
| + | |||
| + | /FREE | ||
| + | EVALR OPT = %trimr(OPT); | ||
| + | If %SubSt(OPT:1:1) = '0'; | ||
| + | OPT = ' ' + %SubSt(OPT:2:1); | ||
| + | EndIf; | ||
| + | RETURN OPT; | ||
| + | /END-FREE | ||
| + | P @OPADJ E | ||
| + | |||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | //###################################################// | ||
| + | P RtvMsgTxt B | ||
| + | //************************************************************************ | ||
| + | // API Call: QMHRTVM Retrieve Message text | ||
| + | //************************************************************************ | ||
| + | |||
| + | |||
| + | // USAGE | ||
| + | // MsgTxt = RtvMsgTxt('MSG0001':cMsgF3:cMsgLib:cMsgLvl1); | ||
| + | |||
| + | D RtvMsgTxt PI 1024 | ||
| + | D RMsgId 7 Const | ||
| + | D RMsgFle 10 Const | ||
| + | D RMsgLib 10 Const | ||
| + | D RMsgLvl 1 Const | ||
| + | |||
| + | // Retrieve Message Description API Prototype | ||
| + | D Get_Message PR ExtPgm('QMHRTVM') | ||
| + | D 4000 Options(*VarSize) | ||
| + | D 10I 0 Const | ||
| + | D 8 Const | ||
| + | D 7 | ||
| + | D 20 Const | ||
| + | D 32765 Options(*VarSize) | ||
| + | D 10I 0 Const | ||
| + | D 10 Const | ||
| + | D 10 Const | ||
| + | D 8192 Options(*VarSize) | ||
| + | D 10 | ||
| + | D 9B 0 | ||
| + | D 9B 0 | ||
| + | |||
| + | // Define Variables for QMHRTVM API call: | ||
| + | // -------------------------------------- | ||
| + | // Return variables | ||
| + | D MessageInfo DS 4000 | ||
| + | D Data 1 4000 | ||
| + | D OSMSG 65 68B 0 | ||
| + | D LMsgR 69 72B 0 | ||
| + | D LMsgA 73 76B 0 | ||
| + | D OSMSGH 77 80B 0 | ||
| + | D LMsgHR 81 84B 0 | ||
| + | D LMsgHA 85 88B 0 | ||
| + | |||
| + | // Required input variables | ||
| + | D MessageLen S 10I 0 | ||
| + | D MessageForm S 8 | ||
| + | D MessageIden S 7 | ||
| + | D MessageFile S 20 | ||
| + | D Replacement S 32765 | ||
| + | D ReplaceLen S 10I 0 | ||
| + | D ReplaceSub S 10 | ||
| + | D ReturnCtl S 10 | ||
| + | |||
| + | D RetrieveOpt S 10 | ||
| + | D ConvToCCSID S 9B 0 | ||
| + | D ReplDtaCCSID S 9B 0 | ||
| + | |||
| + | D Return_Text S 1024 | ||
| + | |||
| + | D ErrorCode DS Qualified | ||
| + | D BytesProv 4B 0 Inz(0) | ||
| + | D BytesAvail 8B 0 Inz(0) | ||
| + | D ExceptionId 7 | ||
| + | D Reserved 1 | ||
| + | D ExceptionDta | ||