Difference between revisions of "UDDS File Display/Update"
From MidrangeWiki
m (→DIS1 CL files with NULL fields cant be processed) |
|||
| (31 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] | ||
| − | |||
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 25: | 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 994: | 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 1,000: | 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,010: | 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,168: | Line 1,177: | ||
ENDFOR; | ENDFOR; | ||
| + | ENDIF; | ||
IF %LEN(RU) > 5 AND %LEN(RU) < 250; | IF %LEN(RU) > 5 AND %LEN(RU) < 250; | ||
| Line 1,796: | 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,814: | 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,784: | 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,790: | 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,800: | 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,958: | Line 2,968: | ||
ENDFOR; | ENDFOR; | ||
| + | ENDIF; | ||
IF %LEN(RU) > 5 AND %LEN(RU) < 250; | IF %LEN(RU) > 5 AND %LEN(RU) < 250; | ||
| Line 3,586: | Line 3,597: | ||
** | ** | ||
0123456789ABCDEF | 0123456789ABCDEF | ||
| + | |||
</pre> | </pre> | ||
[[#top]] | [[#top]] | ||
| − | + | ===DISP2 RPG=== | |
| − | === | ||
<pre> | <pre> | ||
| − | + | H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ | |
| − | + | H OPTION(*NODEBUGIO) | |
| − | + | H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP ) | |
| − | + | 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 IF F32766 800AIDISK KEYLOC(1) | ||
| + | F EXTIND(*INU1) | ||
| + | F INFDS(INFDK) | ||
| + | FINPUTR IF F32766 DISK EXTIND(*INU2) | ||
| + | F INFDS(INFDR) | ||
| − | == | + | * |
| − | === | + | 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 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 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 50 DIM(2) CTDATA PERRCD(1) | ||
| + | D CRS S 1 DIM(16) CTDATA PERRCD(16) | ||
| + | |||
| + | |||
| + | D DS | ||
| + | D D 1 6080 | ||
| + | D DIM(6080) INCOMING DATA | ||
| + | D DA 1 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 | ||
| + | |||
| + | 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 | ||
| + | |||
| + | DDISP2 PR | ||
| + | D 1 | ||
| + | D 1 | ||
| + | D 4 | ||
| + | D 1 | ||
| + | D 500 | ||
| + | D 5 | ||
| + | D 800 | ||
| + | DDISP2 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 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' REAB 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*. | ||
| + | IINPUTK NS 01 | ||
| + | I 1 4048 DA | ||
| + | I 4049 4064 DB 30 | ||
| + | I 4065 4096 DC 31 | ||
| + | I 4097 4128 DD 32 | ||
| + | I 4129 4160 DE 33 | ||
| + | I 4161 4192 DF 34 | ||
| + | I 4193 4224 DG 35 | ||
| + | I 4225 4256 DH 36 | ||
| + | I 4257 4288 DI 37 | ||
| + | I 4289 4320 DJ 38 | ||
| + | I 4321 4352 DK 39 | ||
| + | I 4353 4384 DL 40 | ||
| + | I 4385 4416 DM 41 | ||
| + | I 4417 4448 DN 42 | ||
| + | I 4449 4480 DZ 43 | ||
| + | I 4481 4512 DO 44 | ||
| + | I 4513 4544 DP 45 | ||
| + | I 4545 4576 DQ 46 | ||
| + | I 4577 4608 DR 47 | ||
| + | I 4609 4640 DS 48 | ||
| + | I 4641 4672 DT 49 | ||
| + | I 4673 4704 DU 50 | ||
| + | I 4705 4736 DV 51 | ||
| + | I 4737 4768 DW 52 | ||
| + | I 4769 4800 DX 53 | ||
| + | I 4801 4832 DY 54 | ||
| + | I 4833 4864 D0 55 | ||
| + | I 4865 4896 D1 56 | ||
| + | I 4897 4928 D2 57 | ||
| + | I 4929 4960 D3 58 | ||
| + | I 4961 4992 D4 59 | ||
| + | I 4993 5024 D5 60 | ||
| + | I 5025 5056 D6 61 | ||
| + | I 5057 5088 DBA 62 | ||
| + | I 5089 5120 DCA 63 | ||
| + | I 5121 5152 DDA 64 | ||
| + | I 5153 5184 DEA 65 | ||
| + | I 5185 5216 DFA 66 | ||
| + | I 5217 5248 DGA 67 | ||
| + | I 5249 5280 DHA 68 | ||
| + | I 5281 5312 DIA 69 | ||
| + | I 5313 5344 DJA 70 | ||
| + | I 5345 5376 DKA 71 | ||
| + | I 5377 5408 DLA 72 | ||
| + | I 5409 5440 DMA 73 | ||
| + | I 5441 5472 DNA 74 | ||
| + | I 5473 5504 DOA 75 | ||
| + | I 5505 5536 DPA 76 | ||
| + | I 5537 5568 DQA 77 | ||
| + | I 5569 5600 DRA 78 | ||
| + | I 5601 5632 DSA 79 | ||
| + | I 5633 5664 DTA 80 | ||
| + | I 5665 5696 DUA 81 | ||
| + | I 5697 5728 DVA 82 | ||
| + | I 5729 5760 DWA 83 | ||
| + | I 5761 5792 DXA 84 | ||
| + | I 5793 5824 DYA 85 | ||
| + | I 5825 5856 DZA 86 | ||
| + | I 5857 5888 D0A 87 | ||
| + | I 5889 5920 D1A 88 | ||
| + | I 5921 5952 D2A 89 | ||
| + | I 5953 5984 D3A 90 | ||
| + | I 5985 6016 D4A 91 | ||
| + | I 6017 6048 D5A 92 | ||
| + | I 6049 6080 D6A 93 | ||
| + | IINPUTR NS 01 | ||
| + | I 1 4048 DA | ||
| + | I 4049 4064 DB 30 | ||
| + | I 4065 4096 DC 31 | ||
| + | I 4097 4128 DD 32 | ||
| + | I 4129 4160 DE 33 | ||
| + | I 4161 4192 DF 34 | ||
| + | I 4193 4224 DG 35 | ||
| + | I 4225 4256 DH 36 | ||
| + | I 4257 4288 DI 37 | ||
| + | I 4289 4320 DJ 38 | ||
| + | I 4321 4352 DK 39 | ||
| + | I 4353 4384 DL 40 | ||
| + | I 4385 4416 DM 41 | ||
| + | I 4417 4448 DN 42 | ||
| + | I 4449 4480 DZ 43 | ||
| + | I 4481 4512 DO 44 | ||
| + | I 4513 4544 DP 45 | ||
| + | I 4545 4576 DQ 46 | ||
| + | I 4577 4608 DR 47 | ||
| + | I 4609 4640 DS 48 | ||
| + | I 4641 4672 DT 49 | ||
| + | I 4673 4704 DU 50 | ||
| + | I 4705 4736 DV 51 | ||
| + | I 4737 4768 DW 52 | ||
| + | I 4769 4800 DX 53 | ||
| + | I 4801 4832 DY 54 | ||
| + | I 4833 4864 D0 55 | ||
| + | I 4865 4896 D1 56 | ||
| + | I 4897 4928 D2 57 | ||
| + | I 4929 4960 D3 58 | ||
| + | I 4961 4992 D4 59 | ||
| + | I 4993 5024 D5 60 | ||
| + | I 5025 5056 D6 61 | ||
| + | I 5057 5088 DBA 62 | ||
| + | I 5089 5120 DCA 63 | ||
| + | I 5121 5152 DDA 64 | ||
| + | I 5153 5184 DEA 65 | ||
| + | I 5185 5216 DFA 66 | ||
| + | I 5217 5248 DGA 67 | ||
| + | I 5249 5280 DHA 68 | ||
| + | I 5281 5312 DIA 69 | ||
| + | I 5313 5344 DJA 70 | ||
| + | I 5345 5376 DKA 71 | ||
| + | I 5377 5408 DLA 72 | ||
| + | I 5409 5440 DMA 73 | ||
| + | I 5441 5472 DNA 74 | ||
| + | I 5473 5504 DOA 75 | ||
| + | I 5505 5536 DPA 76 | ||
| + | I 5537 5568 DQA 77 | ||
| + | I 5569 5600 DRA 78 | ||
| + | I 5601 5632 DSA 79 | ||
| + | I 5633 5664 DTA 80 | ||
| + | I 5665 5696 DUA 81 | ||
| + | I 5697 5728 DVA 82 | ||
| + | I 5729 5760 DWA 83 | ||
| + | I 5761 5792 DXA 84 | ||
| + | I 5793 5824 DYA 85 | ||
| + | I 5825 5856 DZA 86 | ||
| + | I 5857 5888 D0A 87 | ||
| + | I 5889 5920 D1A 88 | ||
| + | I 5921 5952 D2A 89 | ||
| + | I 5953 5984 D3A 90 | ||
| + | I 5985 6016 D4A 91 | ||
| + | I 6017 6048 D5A 92 | ||
| + | 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 = 0; | ||
| + | |||
| + | 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 | ||
| + | IF AID = '1'or AID = '4' or AID = '5'; | ||
| + | ELSE; | ||
| + | MX = 1; | ||
| + | EXSR @ERROR; | ||
| + | ENDIF; | ||
| + | |||
| + | IF RTN <> '3'; | ||
| + | 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); | ||
| + | LEAVE; | ||
| + | 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 | ||
| + | W = R(Y) + 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; | ||
| + | |||
| + | |||
| + | /END-FREE | ||
| + | |||
| + | 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 F19-Prev_fld F20-More_fld | ||
| + | ** | ||
| + | 0123456789ABCDEF | ||
| − | |||
</pre> | </pre> | ||
| + | |||
| + | [[#top]] | ||
| + | |||
| + | ===DUSP RPG=== | ||
| + | |||
| + | <pre> | ||
| + | H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ | ||
| + | H OPTION(*NODEBUGIO) | ||
| + | H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP ) | ||
| + | F* | ||
| + | F* LIMITED TO MAXIMUM FILE LENGTH OF 2048 | ||
| + | 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 | ||
| + | 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 -' | ||
| + | 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 2048 | ||
| + | D D 1 2048 | ||
| + | D DIM(2048) INCOMING DATA | ||
| + | D DA 1 16 | ||
| + | D DB 17 32 | ||
| + | D DC 33 64 | ||
| + | D DD 65 96 | ||
| + | D DE 97 128 | ||
| + | D DF 129 160 | ||
| + | D DG 161 192 | ||
| + | D DH 193 224 | ||
| + | D DI 225 256 | ||
| + | D DJ 257 288 | ||
| + | D DK 289 320 | ||
| + | D DL 321 352 | ||
| + | D DM 353 384 | ||
| + | D DN 385 416 | ||
| + | D DZ 417 448 | ||
| + | D DO 449 480 | ||
| + | D DP 481 512 | ||
| + | D DQ 513 544 | ||
| + | D DR 545 576 | ||
| + | D DS 577 608 | ||
| + | D DT 609 640 | ||
| + | D DU 641 672 | ||
| + | D DV 673 704 | ||
| + | D DW 705 736 | ||
| + | D DX 737 768 | ||
| + | D DY 769 800 | ||
| + | D D0 801 832 | ||
| + | D D1 833 864 | ||
| + | D D2 865 896 | ||
| + | D D3 897 928 | ||
| + | D D4 929 960 | ||
| + | D D5 961 992 | ||
| + | D D6 993 1024 | ||
| + | D DBA 1025 1056 | ||
| + | D DCA 1057 1088 | ||
| + | D DDA 1089 1120 | ||
| + | D DEA 1121 1152 | ||
| + | D DFA 1153 1184 | ||
| + | D DGA 1185 1216 | ||
| + | D DHA 1217 1248 | ||
| + | D DIA 1249 1280 | ||
| + | D DJA 1281 1312 | ||
| + | D DKA 1313 1344 | ||
| + | D DLA 1345 1376 | ||
| + | D DMA 1377 1408 | ||
| + | D DNA 1409 1440 | ||
| + | D DOA 1441 1472 | ||
| + | D DPA 1473 1504 | ||
| + | D DQA 1505 1536 | ||
| + | D DRA 1537 1568 | ||
| + | D DSA 1569 1600 | ||
| + | D DTA 1601 1632 | ||
| + | D DUA 1633 1664 | ||
| + | D DVA 1665 1696 | ||
| + | D DWA 1697 1728 | ||
| + | D DXA 1729 1760 | ||
| + | D DYA 1761 1792 | ||
| + | D DZA 1793 1824 | ||
| + | D D0A 1825 1856 | ||
| + | D D1A 1857 1888 | ||
| + | D D2A 1889 1920 | ||
| + | D D3A 1921 1952 | ||
| + | D D4A 1953 1984 | ||
| + | D D5A 1985 2016 | ||
| + | D D6A 2017 2048 | ||
| + | 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 | ||
| + | |||
| + | 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 | ||
| + | |||
| + | DDUSP PR | ||
| + | D 1 | ||
| + | D 1 | ||
| + | D 4 | ||
| + | D 1 | ||
| + | D 500 | ||
| + | D 5 | ||
| + | D 800 | ||
| + | DDUSP 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' REAB 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*. | ||
| + | IINPUTK NS 01 | ||
| + | I 1 16 DA | ||
| + | I 17 32 DB 30 | ||
| + | I 33 64 DC 31 | ||
| + | I 65 96 DD 32 | ||
| + | I 97 128 DE 33 | ||
| + | I 129 160 DF 34 | ||
| + | I 161 192 DG 35 | ||
| + | I 193 224 DH 36 | ||
| + | I 225 256 DI 37 | ||
| + | I 257 288 DJ 38 | ||
| + | I 289 320 DK 39 | ||
| + | I 321 352 DL 40 | ||
| + | I 353 384 DM 41 | ||
| + | I 385 416 DN 42 | ||
| + | I 417 448 DZ 43 | ||
| + | I 449 480 DO 44 | ||
| + | I 481 512 DP 45 | ||
| + | I 513 544 DQ 46 | ||
| + | I 545 576 DR 47 | ||
| + | I 577 608 DS 48 | ||
| + | I 609 640 DT 49 | ||
| + | I 641 672 DU 50 | ||
| + | I 673 704 DV 51 | ||
| + | I 705 736 DW 52 | ||
| + | I 737 768 DX 53 | ||
| + | I 769 800 DY 54 | ||
| + | I 801 832 D0 55 | ||
| + | I 833 864 D1 56 | ||
| + | I 865 896 D2 57 | ||
| + | I 897 928 D3 58 | ||
| + | I 929 960 D4 59 | ||
| + | I 961 992 D5 60 | ||
| + | I 993 1024 D6 61 | ||
| + | I 1025 1056 DBA 62 | ||
| + | I 1057 1088 DCA 63 | ||
| + | I 1089 1120 DDA 64 | ||
| + | I 1121 1152 DEA 65 | ||
| + | I 1153 1184 DFA 66 | ||
| + | I 1185 1216 DGA 67 | ||
| + | I 1217 1248 DHA 68 | ||
| + | I 1249 1280 DIA 69 | ||
| + | I 1281 1312 DJA 70 | ||
| + | I 1313 1344 DKA 71 | ||
| + | I 1345 1376 DLA 72 | ||
| + | I 1377 1408 DMA 73 | ||
| + | I 1409 1440 DNA 74 | ||
| + | I 1441 1472 DOA 75 | ||
| + | I 1473 1504 DPA 76 | ||
| + | I 1505 1536 DQA 77 | ||
| + | I 1537 1568 DRA 78 | ||
| + | I 1569 1600 DSA 79 | ||
| + | I 1601 1632 DTA 80 | ||
| + | I 1633 1664 DUA 81 | ||
| + | I 1665 1696 DVA 82 | ||
| + | I 1697 1728 DWA 83 | ||
| + | I 1729 1760 DXA 84 | ||
| + | I 1761 1792 DYA 85 | ||
| + | I 1793 1824 DZA 86 | ||
| + | I 1825 1856 D0A 87 | ||
| + | I 1857 1888 D1A 88 | ||
| + | I 1889 1920 D2A 89 | ||
| + | I 1921 1952 D3A 90 | ||
| + | I 1953 1984 D4A 91 | ||
| + | I 1985 2016 D5A 92 | ||
| + | I 2017 2048 D6A 93 | ||
| + | IINPUTR NS 01 | ||
| + | I 1 16 DA | ||
| + | I 17 32 DB 30 | ||
| + | I 33 64 DC 31 | ||
| + | I 65 96 DD 32 | ||
| + | I 97 128 DE 33 | ||
| + | I 129 160 DF 34 | ||
| + | I 161 192 DG 35 | ||
| + | I 193 224 DH 36 | ||
| + | I 225 256 DI 37 | ||
| + | I 257 288 DJ 38 | ||
| + | I 289 320 DK 39 | ||
| + | I 321 352 DL 40 | ||
| + | I 353 384 DM 41 | ||
| + | I 385 416 DN 42 | ||
| + | I 417 448 DZ 43 | ||
| + | I 449 480 DO 44 | ||
| + | I 481 512 DP 45 | ||
| + | I 513 544 DQ 46 | ||
| + | I 545 576 DR 47 | ||
| + | I 577 608 DS 48 | ||
| + | I 609 640 DT 49 | ||
| + | I 641 672 DU 50 | ||
| + | I 673 704 DV 51 | ||
| + | I 705 736 DW 52 | ||
| + | I 737 768 DX 53 | ||
| + | I 769 800 DY 54 | ||
| + | I 801 832 D0 55 | ||
| + | I 833 864 D1 56 | ||
| + | I 865 896 D2 57 | ||
| + | I 897 928 D3 58 | ||
| + | I 929 960 D4 59 | ||
| + | I 961 992 D5 60 | ||
| + | I 993 1024 D6 61 | ||
| + | I 1025 1056 DBA 62 | ||
| + | I 1057 1088 DCA 63 | ||
| + | I 1089 1120 DDA 64 | ||
| + | I 1121 1152 DEA 65 | ||
| + | I 1153 1184 DFA 66 | ||
| + | I 1185 1216 DGA 67 | ||
| + | I 1217 1248 DHA 68 | ||
| + | I 1249 1280 DIA 69 | ||
| + | I 1281 1312 DJA 70 | ||
| + | I 1313 1344 DKA 71 | ||
| + | I 1345 1376 DLA 72 | ||
| + | I 1377 1408 DMA 73 | ||
| + | I 1409 1440 DNA 74 | ||
| + | I 1441 1472 DOA 75 | ||
| + | I 1473 1504 DPA 76 | ||
| + | I 1505 1536 DQA 77 | ||
| + | I 1537 1568 DRA 78 | ||
| + | I 1569 1600 DSA 79 | ||
| + | I 1601 1632 DTA 80 | ||
| + | I 1633 1664 DUA 81 | ||
| + | I 1665 1696 DVA 82 | ||
| + | I 1697 1728 DWA 83 | ||
| + | I 1729 1760 DXA 84 | ||
| + | I 1761 1792 DYA 85 | ||
| + | I 1793 1824 DZA 86 | ||
| + | I 1825 1856 D0A 87 | ||
| + | I 1857 1888 D1A 88 | ||
| + | I 1889 1920 D2A 89 | ||
| + | I 1921 1952 D3A 90 | ||
| + | I 1953 1984 D4A 91 | ||
| + | I 1985 2016 D5A 92 | ||
| + | I 2017 2048 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 | ||
| + | DCL V | ||
| + | |||
| + | /FREE | ||
| + | BASE = 0; | ||
| + | |||
| + | 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 | ||
| + | SELECT; | ||
| + | WHEN T(Y) = 'A'; // ALPHA DATA | ||
| + | K = ' '; | ||
| + | K1 = 1; | ||
| + | K2 = Q(Y); | ||
| + | WHEN T(Y) = 'F'; // FLOAT | ||
| + | K = '0'; | ||
| + | K1 = 1; | ||
| + | K2 = L(Y); | ||
| + | OTHER; | ||
| + | K = '0'; | ||
| + | K1 = 1; | ||
| + | K2 = C(Y); | ||
| + | ENDSL; | ||
| + | |||
| + | |||
| + | // 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 | ||
| + | SELECT; | ||
| + | WHEN T(Y) = 'A'; // ALPHA DATA | ||
| + | K = ' '; | ||
| + | K1 = 1; | ||
| + | K2 = Q(Y); | ||
| + | WHEN T(Y) = 'F'; // FLOAT | ||
| + | K = '0'; | ||
| + | K1 = 1; | ||
| + | K2 = L(Y); | ||
| + | OTHER; | ||
| + | K = '0'; | ||
| + | K1 = 1; | ||
| + | K2 = C(Y); | ||
| + | ENDSL; | ||
| + | |||
| + | 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 stick 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; | ||
| + | |||
| + | |||
| + | // 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 | ||
| + | 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 16 | ||
| + | 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 16 | ||
| + | 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 16 | ||
| + | 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 16 | ||
| + | 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]] | ||
| + | |||
| + | ===DUSP1 RPG=== | ||
| + | |||
| + | <pre> | ||
| + | H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ | ||
| + | H OPTION(*NODEBUGIO) | ||
| + | H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP1 ) | ||
| + | F* | ||
| + | F* LIMITED TO MAXIMUM FILE LENGTH OF 4080 | ||
| + | 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 4080 | ||
| + | D D 1 4080 | ||
| + | D DIM(4080) INCOMING DATA | ||
| + | D DA 1 2048 | ||
| + | D DIM(2048) | ||
| + | D DB 2049 2064 | ||
| + | D DC 2065 2096 | ||
| + | D DD 2097 2128 | ||
| + | D DE 2129 2160 | ||
| + | D DF 2161 2192 | ||
| + | D DG 2193 2224 | ||
| + | D DH 2225 2256 | ||
| + | D DI 2257 2288 | ||
| + | D DJ 2289 2320 | ||
| + | D DK 2321 2352 | ||
| + | D DL 2353 2384 | ||
| + | D DM 2385 2416 | ||
| + | D DN 2417 2448 | ||
| + | D DZ 2449 2480 | ||
| + | D DO 2481 2512 | ||
| + | D DP 2513 2544 | ||
| + | D DQ 2545 2576 | ||
| + | D DR 2577 2608 | ||
| + | D DS 2609 2640 | ||
| + | D DT 2641 2672 | ||
| + | D DU 2673 2704 | ||
| + | D DV 2705 2736 | ||
| + | D DW 2737 2768 | ||
| + | D DX 2769 2800 | ||
| + | D DY 2801 2832 | ||
| + | D D0 2833 2864 | ||
| + | D D1 2865 2896 | ||
| + | D D2 2897 2928 | ||
| + | D D3 2929 2960 | ||
| + | D D4 2961 2992 | ||
| + | D D5 2993 3024 | ||
| + | D D6 3025 3056 | ||
| + | D DBA 3057 3088 | ||
| + | D DCA 3089 3120 | ||
| + | D DDA 3121 3152 | ||
| + | D DEA 3153 3184 | ||
| + | D DFA 3185 3216 | ||
| + | D DGA 3217 3248 | ||
| + | D DHA 3249 3280 | ||
| + | D DIA 3281 3312 | ||
| + | D DJA 3313 3344 | ||
| + | D DKA 3345 3376 | ||
| + | D DLA 3377 3408 | ||
| + | D DMA 3409 3440 | ||
| + | D DNA 3441 3472 | ||
| + | D DOA 3473 3504 | ||
| + | D DPA 3505 3536 | ||
| + | D DQA 3537 3568 | ||
| + | D DRA 3569 3600 | ||
| + | D DSA 3601 3632 | ||
| + | D DTA 3633 3664 | ||
| + | D DUA 3665 3696 | ||
| + | D DVA 3697 3728 | ||
| + | D DWA 3729 3760 | ||
| + | D DXA 3761 3792 | ||
| + | D DYA 3793 3824 | ||
| + | D DZA 3825 3856 | ||
| + | D D0A 3857 3888 | ||
| + | D D1A 3889 3920 | ||
| + | D D2A 3921 3952 | ||
| + | D D3A 3953 3984 | ||
| + | D D4A 3985 4016 | ||
| + | D D5A 4017 4048 | ||
| + | D D6A 4049 4080 | ||
| + | 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 | ||
| + | |||
| + | 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 | ||
| + | |||
| + | DDUSP1 PR | ||
| + | D 1 | ||
| + | D 1 | ||
| + | D 4 | ||
| + | D 1 | ||
| + | D 500 | ||
| + | D 5 | ||
| + | D 800 | ||
| + | DDUSP1 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' | ||