Difference between revisions of "UDDS File Display/Update"
From MidrangeWiki
m (→DIS1 CL files with NULL fields cant be processed) |
|||
(34 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 OPTION(*NODEBUGIO) | ||
+ | H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP ) | ||
+ | F* | ||
+ | F* LIMITED TO MAXIMUM FILE LENGTH OF 2048 | ||
+ | F* TEST | ||
+ | F* REQUIRES FILE TO COMPILE | ||
+ | F* 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 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 | ||
+ | |||
+ | DDISP PR | ||
+ | D 1 | ||
+ | D 1 | ||
+ | D 4 | ||
+ | D 1 | ||
+ | D 500 | ||
+ | D 5 | ||
+ | D 800 | ||
+ | DDISP 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 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 | ||
+ | |||
+ | |||
+ | /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> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | ===DISP1 RPG=== | ||
+ | |||
+ | <pre> | ||
+ | H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ | ||
+ | H OPTION(*NODEBUGIO) | ||
+ | H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP ) | ||
+ | F* | ||
+ | F* LIMITED TO MAXIMUM FILE LENGTH OF 4080 | ||
+ | F* TEST | ||
+ | F* REQUIRES FILE TO COMPILE | ||
+ | F* 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 79 DIM(2) CTDATA PERRCD(1) | ||
+ | D CRS S 1 DIM(16) CTDATA PERRCD(16) | ||
+ | |||
+ | D DS | ||
+ | D D 1 4080 | ||
+ | D DIM(4080) INCOMING DATA | ||
+ | D DA 1 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 | ||
+ | |||
+ | DDISP1 PR | ||
+ | D 1 | ||
+ | D 1 | ||
+ | D 4 | ||
+ | D 1 | ||
+ | D 500 | ||
+ | D 5 | ||
+ | D 800 | ||
+ | DDISP1 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 2048 DA | ||
+ | I 2049 2064 DB 30 | ||
+ | I 2065 2096 DC 31 | ||
+ | I 2097 2128 DD 32 | ||
+ | I 2129 2160 DE 33 | ||
+ | I 2161 2192 DF 34 | ||
+ | I 2193 2224 DG 35 | ||
+ | I 2225 2256 DH 36 | ||
+ | I 2257 2288 DI 37 | ||
+ | I 2289 2320 DJ 38 | ||
+ | I 2321 2352 DK 39 | ||
+ | I 2353 2384 DL 40 | ||
+ | I 2385 2416 DM 41 | ||
+ | I 2417 2448 DN 42 | ||
+ | I 2449 2480 DZ 43 | ||
+ | I 2481 2512 DO 44 | ||
+ | I 2513 2544 DP 45 | ||
+ | I 2545 2576 DQ 46 | ||
+ | I 2577 2608 DR 47 | ||
+ | I 2609 2640 DS 48 | ||
+ | I 2641 2672 DT 49 | ||
+ | I 2673 2704 DU 50 | ||
+ | I 2705 2736 DV 51 | ||
+ | I 2737 2768 DW 52 | ||
+ | I 2769 2800 DX 53 | ||
+ | I 2801 2832 DY 54 | ||
+ | I 2833 2864 D0 55 | ||
+ | I 2865 2896 D1 56 | ||
+ | I 2897 2928 D2 57 | ||
+ | I 2929 2960 D3 58 | ||
+ | I 2961 2992 D4 59 | ||
+ | I 2993 3024 D5 60 | ||
+ | I 3025 3056 D6 61 | ||
+ | I 3057 3088 DBA 62 | ||
+ | I 3089 3120 DCA 63 | ||
+ | I 3121 3152 DDA 64 | ||
+ | I 3153 3184 DEA 65 | ||
+ | I 3185 3216 DFA 66 | ||
+ | I 3217 3248 DGA 67 | ||
+ | I 3249 3280 DHA 68 | ||
+ | I 3281 3312 DIA 69 | ||
+ | I 3313 3344 DJA 70 | ||
+ | I 3345 3376 DKA 71 | ||
+ | I 3377 3408 DLA 72 | ||
+ | I 3409 3440 DMA 73 | ||
+ | I 3441 3472 DNA 74 | ||
+ | I 3473 3504 DOA 75 | ||
+ | I 3505 3536 DPA 76 | ||
+ | I 3537 3568 DQA 77 | ||
+ | I 3569 3600 DRA 78 | ||
+ | I 3601 3632 DSA 79 | ||
+ | I 3633 3664 DTA 80 | ||
+ | I 3665 3696 DUA 81 | ||
+ | I 3697 3728 DVA 82 | ||
+ | I 3729 3760 DWA 83 | ||
+ | I 3761 3792 DXA 84 | ||
+ | I 3793 3824 DYA 85 | ||
+ | I 3825 3856 DZA 86 | ||
+ | I 3857 3888 D0A 87 | ||
+ | I 3889 3920 D1A 88 | ||
+ | I 3921 3952 D2A 89 | ||
+ | I 3953 3984 D3A 90 | ||
+ | I 3985 4016 D4A 91 | ||
+ | I 4017 4048 D5A 92 | ||
+ | I 4049 4080 D6A 93 | ||
+ | IINPUTR NS 01 | ||
+ | I 1 2048 DA | ||
+ | I 2049 2064 DB 30 | ||
+ | I 2065 2096 DC 31 | ||
+ | I 2097 2128 DD 32 | ||
+ | I 2129 2160 DE 33 | ||
+ | I 2161 2192 DF 34 | ||
+ | I 2193 2224 DG 35 | ||
+ | I 2225 2256 DH 36 | ||
+ | I 2257 2288 DI 37 | ||
+ | I 2289 2320 DJ 38 | ||
+ | I 2321 2352 DK 39 | ||
+ | I 2353 2384 DL 40 | ||
+ | I 2385 2416 DM 41 | ||
+ | I 2417 2448 DN 42 | ||
+ | I 2449 2480 DZ 43 | ||
+ | I 2481 2512 DO 44 | ||
+ | I 2513 2544 DP 45 | ||
+ | I 2545 2576 DQ 46 | ||
+ | I 2577 2608 DR 47 | ||
+ | I 2609 2640 DS 48 | ||
+ | I 2641 2672 DT 49 | ||
+ | I 2673 2704 DU 50 | ||
+ | I 2705 2736 DV 51 | ||
+ | I 2737 2768 DW 52 | ||
+ | I 2769 2800 DX 53 | ||
+ | I 2801 2832 DY 54 | ||
+ | I 2833 2864 D0 55 | ||
+ | I 2865 2896 D1 56 | ||
+ | I 2897 2928 D2 57 | ||
+ | I 2929 2960 D3 58 | ||
+ | I 2961 2992 D4 59 | ||
+ | I 2993 3024 D5 60 | ||
+ | I 3025 3056 D6 61 | ||
+ | I 3057 3088 DBA 62 | ||
+ | I 3089 3120 DCA 63 | ||
+ | I 3121 3152 DDA 64 | ||
+ | I 3153 3184 DEA 65 | ||
+ | I 3185 3216 DFA 66 | ||
+ | I 3217 3248 DGA 67 | ||
+ | I 3249 3280 DHA 68 | ||
+ | I 3281 3312 DIA 69 | ||
+ | I 3313 3344 DJA 70 | ||
+ | I 3345 3376 DKA 71 | ||
+ | I 3377 3408 DLA 72 | ||
+ | I 3409 3440 DMA 73 | ||
+ | I 3441 3472 DNA 74 | ||
+ | I 3473 3504 DOA 75 | ||
+ | I 3505 3536 DPA 76 | ||
+ | I 3537 3568 DQA 77 | ||
+ | I 3569 3600 DRA 78 | ||
+ | I 3601 3632 DSA 79 | ||
+ | I 3633 3664 DTA 80 | ||
+ | I 3665 3696 DUA 81 | ||
+ | I 3697 3728 DVA 82 | ||
+ | I 3729 3760 DWA 83 | ||
+ | I 3761 3792 DXA 84 | ||
+ | I 3793 3824 DYA 85 | ||
+ | I 3825 3856 DZA 86 | ||
+ | I 3857 3888 D0A 87 | ||
+ | I 3889 3920 D1A 88 | ||
+ | I 3921 3952 D2A 89 | ||
+ | I 3953 3984 D3A 90 | ||
+ | I 3985 4016 D4A 91 | ||
+ | I 4017 4048 D5A 92 | ||
+ | I 4049 4080 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> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | ===DISP2 RPG=== | ||
+ | |||
+ | <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> | ||
+ | |||
+ | [[#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' ATTR NUM | ||
+ | D X00 C X'00' | ||
+ | D X01 C X'01' | ||
+ | D X02 C X'02' | ||
+ | D X03 C X'03' | ||
+ | D X0D C X'0D' | ||
+ | D X0F C X'0F' | ||
+ | D X000 C X'0000' | ||
+ | D X1F C X'1F' | ||
+ | D X20 C X'20' SCRN ATT NORMAL | ||
+ | D X22 C X'22' SCRN ATTR HI | ||
+ | D X25 C X'25' | ||
+ | D X26 C X'26' | ||
+ | D X31 C X'31' CMD 1 KEY | ||
+ | D X32 C X'32' CMD 2 KEY | ||
+ | D X33 C X'33' CMD 3 KEY | ||
+ | D X36 C X'36' CMD 6 KEY | ||
+ | D X37 C X'37' CMD 7 KEY | ||
+ | D X38 C X'38' CMD 8 KEY | ||
+ | D X39 C X'39' CMD 9 KEY | ||
+ | D X3B C X'3B' CMD11 KEY | ||
+ | D XB7 C X'B7' CMD19 KEY | ||
+ | D XB8 C X'B8' CMD20 KEY | ||
+ | D X40 C X'40' | ||
+ | D X43 C X'43' | ||
+ | D X47 C X'47' | ||
+ | D X60 C X'60' | ||
+ | D X67 C X'67' | ||
+ | D X9F C X'9F' | ||
+ | D XF0 C X'F0' | ||
+ | D XD0 C X'D0' | ||
+ | D X4000 C X'4000' | ||
+ | D X4800 C X'4800' FF ALPHA | ||
+ | D X4F06 C X'4F06' FF NUMERIC | ||
+ | D X6000 C X'6000' FF ALPHA | ||
+ | D X6706 C X'6706' FF NUMERIC | ||
+ | D CLRWTD C X'044004112000' INCLUDES ESC CHARS | ||
+ | D RDDSP C X'0411200804524000' READ FROM DISPLAY | ||
+ | D FFA1 S 1 INZ(X'40') F.FMT 1 ALPH 60 BYP | ||
+ | D FFA2 S 1 INZ(X'00') F.FMT 2 ALPH | ||
+ | D FFN1 S 1 INZ(X'47') F.FMT 1 NUM 67 BYP | ||
+ | D FFN2 S 1 INZ(X'06') F.FMT 2 NUM | ||
+ | I*. | ||
+ | IINPUTK NS 01 | ||
+ | I 1 2048 DA | ||
+ | I 2049 2064 DB 30 | ||
+ | I 2065 2096 DC 31 | ||
+ | I 2097 2128 DD 32 | ||
+ | I 2129 2160 DE 33 | ||
+ | I 2161 2192 DF 34 | ||
+ | I 2193 2224 DG 35 | ||
+ | I 2225 2256 DH 36 | ||
+ | I 2257 2288 DI 37 | ||
+ | I 2289 2320 DJ 38 | ||
+ | I 2321 2352 DK 39 | ||
+ | I 2353 2384 DL 40 | ||
+ | I 2385 2416 DM 41 | ||
+ | I 2417 2448 DN 42 | ||
+ | I 2449 2480 DZ 43 | ||
+ | I 2481 2512 DO 44 | ||
+ | I 2513 2544 DP 45 | ||
+ | I 2545 2576 DQ 46 | ||
+ | I 2577 2608 DR 47 | ||
+ | I 2609 2640 DS 48 | ||
+ | I 2641 2672 DT 49 | ||
+ | I 2673 2704 DU 50 | ||
+ | I 2705 2736 DV 51 | ||
+ | I 2737 2768 DW 52 | ||
+ | I 2769 2800 DX 53 | ||
+ | I 2801 2832 DY 54 | ||
+ | I 2833 2864 D0 55 | ||
+ | I 2865 2896 D1 56 | ||
+ | I 2897 2928 D2 57 | ||
+ | I 2929 2960 D3 58 | ||
+ | I 2961 2992 D4 59 | ||
+ | I 2993 3024 D5 60 | ||
+ | I 3025 3056 D6 61 | ||
+ | I 3057 3088 DBA 62 | ||
+ | I 3089 3120 DCA 63 | ||
+ | I 3121 3152 DDA 64 | ||
+ | I 3153 3184 DEA 65 | ||
+ | I 3185 3216 DFA 66 | ||
+ | I 3217 3248 DGA 67 | ||
+ | I 3249 3280 DHA 68 | ||
+ | I 3281 3312 DIA 69 | ||
+ | I 3313 3344 DJA 70 | ||
+ | I 3345 3376 DKA 71 | ||
+ | I 3377 3408 DLA 72 | ||
+ | I 3409 3440 DMA 73 | ||
+ | I 3441 3472 DNA 74 | ||
+ | I 3473 3504 DOA 75 | ||
+ | I 3505 3536 DPA 76 | ||
+ | I 3537 3568 DQA 77 | ||
+ | I 3569 3600 DRA 78 | ||
+ | I 3601 3632 DSA 79 | ||
+ | I 3633 3664 DTA 80 | ||
+ | I 3665 3696 DUA 81 | ||
+ | I 3697 3728 DVA 82 | ||
+ | I 3729 3760 DWA 83 | ||
+ | I 3761 3792 DXA 84 | ||
+ | I 3793 3824 DYA 85 | ||
+ | I 3825 3856 DZA 86 | ||
+ | I 3857 3888 D0A 87 | ||
+ | I 3889 3920 D1A 88 | ||
+ | I 3921 3952 D2A 89 | ||
+ | I 3953 3984 D3A 90 | ||
+ | I 3985 4016 D4A 91 | ||
+ | I 4017 4048 D5A 92 | ||
+ | I 4049 4080 D6A 93 | ||
+ | IINPUTR NS 01 | ||
+ | I 1 2048 DA | ||
+ | I 2049 2064 DB 30 | ||
+ | I 2065 2096 DC 31 | ||
+ | I 2097 2128 DD 32 | ||
+ | I 2129 2160 DE 33 | ||
+ | I 2161 2192 DF 34 | ||
+ | I 2193 2224 DG 35 | ||
+ | I 2225 2256 DH 36 | ||
+ | I 2257 2288 DI 37 | ||
+ | I 2289 2320 DJ 38 | ||
+ | I 2321 2352 DK 39 | ||
+ | I 2353 2384 DL 40 | ||
+ | I 2385 2416 DM 41 | ||
+ | I 2417 2448 DN 42 | ||
+ | I 2449 2480 DZ 43 | ||
+ | I 2481 2512 DO 44 | ||
+ | I 2513 2544 DP 45 | ||
+ | I 2545 2576 DQ 46 | ||
+ | I 2577 2608 DR 47 | ||
+ | I 2609 2640 DS 48 | ||
+ | I 2641 2672 DT 49 | ||
+ | I 2673 2704 DU 50 | ||
+ | I 2705 2736 DV 51 | ||
+ | I 2737 2768 DW 52 | ||
+ | I 2769 2800 DX 53 | ||
+ | I 2801 2832 DY 54 | ||
+ | I 2833 2864 D0 55 | ||
+ | I 2865 2896 D1 56 | ||
+ | I 2897 2928 D2 57 | ||
+ | I 2929 2960 D3 58 | ||
+ | I 2961 2992 D4 59 | ||
+ | I 2993 3024 D5 60 | ||
+ | I 3025 3056 D6 61 | ||
+ | I 3057 3088 DBA 62 | ||
+ | I 3089 3120 DCA 63 | ||
+ | I 3121 3152 DDA 64 | ||
+ | I 3153 3184 DEA 65 | ||
+ | I 3185 3216 DFA 66 | ||
+ | I 3217 3248 DGA 67 | ||
+ | I 3249 3280 DHA 68 | ||
+ | I 3281 3312 DIA 69 | ||
+ | I 3313 3344 DJA 70 | ||
+ | I 3345 3376 DKA 71 | ||
+ | I 3377 3408 DLA 72 | ||
+ | I 3409 3440 DMA 73 | ||
+ | I 3441 3472 DNA 74 | ||
+ | I 3473 3504 DOA 75 | ||
+ | I 3505 3536 DPA 76 | ||
+ | I 3537 3568 DQA 77 | ||
+ | I 3569 3600 DRA 78 | ||
+ | I 3601 3632 DSA 79 | ||
+ | I 3633 3664 DTA 80 | ||
+ | I 3665 3696 DUA 81 | ||
+ | I 3697 3728 DVA 82 | ||
+ | I 3729 3760 DWA 83 | ||
+ | I 3761 3792 DXA 84 | ||
+ | I 3793 3824 DYA 85 | ||
+ | I 3825 3856 DZA 86 | ||
+ | I 3857 3888 D0A 87 | ||
+ | I 3889 3920 D1A 88 | ||
+ | I 3921 3952 D2A 89 | ||
+ | I 3953 3984 D3A 90 | ||
+ | I 3985 4016 D4A 91 | ||
+ | I 4017 4048 D5A 92 | ||
+ | I 4049 4080 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 = 2048; | ||
+ | |||
+ | IF ONCE = ' '; | ||
+ | EXSR @INITZ ; | ||
+ | ENDIF; | ||
+ | |||
+ | // START TAG | ||
+ | DOW @LOOP = @LOOP; | ||
+ | |||
+ | IF RTN = '3'; | ||
+ | |||
+ | IF *INU1; | ||
+ | KEYA = SCNKEY; | ||
+ | ENDIF; | ||
+ | IF *INU2; | ||
+ | RRNA = %DEC(%SUBST(SCNKEY:1:11):11:0); | ||
+ | ENDIF; | ||
+ | RTN = '0'; | ||
+ | AID = '1'; | ||
+ | ELSE; | ||
+ | RTN = '0'; | ||
+ | READ(E) DISPF; | ||
+ | ENDIF; | ||
+ | |||
+ | // CF3 EXIT | ||
+ | IF AID = X33; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // CF2 RETURN | ||
+ | IF AID = X32; | ||
+ | RTN = '1'; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // CF1 HEX A FIELD | ||
+ | IF AID = X31; | ||
+ | Y = %LOOKUPLE( CURLOC : B ); | ||
+ | IF Y > 0; | ||
+ | IF KY(Y) <= '1'; | ||
+ | EXSR @HXDSP; | ||
+ | REHEAD = '1'; | ||
+ | EXSR @PUTHED; | ||
+ | REHEAD = ' '; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | // CF20 MORE FIELDS | ||
+ | IF AID = XB8; | ||
+ | |||
+ | LVX = LVL + 1; | ||
+ | IF LV(LVX) <> *BLANK; | ||
+ | LVL = LVL +1 ; | ||
+ | |||
+ | LVW = LV; | ||
+ | SCNLV = TEXT500; | ||
+ | SCNLVL = %EDITC(LVL :'X'); | ||
+ | |||
+ | SCNKEY = *BLANKS; | ||
+ | IF *INU1; | ||
+ | SCNKEY = KEYA; | ||
+ | ENDIF; | ||
+ | IF *INU2; | ||
+ | SCNKEY = %EDITC(RRNA:'X'); | ||
+ | ENDIF; | ||
+ | |||
+ | RTN = '3'; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | // CF19 PREVIOUS FIELDS | ||
+ | IF AID = XB7; | ||
+ | |||
+ | LVX = LVL - 1; | ||
+ | IF LVX >= 0 ; | ||
+ | LVL = LVL - 1 ; | ||
+ | |||
+ | LVW = LV; | ||
+ | SCNLV = TEXT500; | ||
+ | SCNLVL = %EDITC(LVL :'X'); | ||
+ | |||
+ | SCNKEY = *BLANKS; | ||
+ | IF *INU1; | ||
+ | SCNKEY = KEYA; | ||
+ | ENDIF; | ||
+ | IF *INU2; | ||
+ | SCNKEY = %EDITC(RRNA:'X'); | ||
+ | ENDIF; | ||
+ | |||
+ | RTN = '3'; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | // 1 ENTER 4 ROLL DN 5 ROLL UP | ||
+ | // F6 = X36 F9 = X39 F11 = X3B | ||
+ | IF AID = '1'or AID = '4' or AID = '5' or | ||
+ | AID = X36 or AID = X39 or AID = X3B; | ||
+ | ELSE; | ||
+ | MX = 1; // INVALID KEY | ||
+ | EXSR @ERROR; | ||
+ | ENDIF; | ||
+ | |||
+ | // UPDATE MODE | ||
+ | IF UPDF = 'Y'; | ||
+ | UPDDONE = @FALSE; | ||
+ | // F6 | ||
+ | IF *INU1 AND AID = X36 AND | ||
+ | (LOP1 = X01 OR LOP1 = X03); | ||
+ | EXSR @UPD; | ||
+ | EXCEPT UPDATREC; | ||
+ | UPDDONE = @TRUE; | ||
+ | ENDIF; | ||
+ | |||
+ | IF *INU2 AND AID = X36 AND | ||
+ | (LOP2 = X01 OR LOP2 = X02); | ||
+ | EXSR @UPD; | ||
+ | EXCEPT UPDATREC; | ||
+ | UPDDONE = @TRUE; | ||
+ | ENDIF; | ||
+ | |||
+ | // F9 | ||
+ | IF AID = X39; | ||
+ | EXSR @UPD; | ||
+ | EXCEPT ADDREC; | ||
+ | UPDDONE = @TRUE; | ||
+ | ENDIF; | ||
+ | |||
+ | // F11 | ||
+ | IF *INU1 AND AID = X3B AND | ||
+ | (LOP1 = X01 OR LOP1 = X03); | ||
+ | EXCEPT DELREC; | ||
+ | UPDDONE = @TRUE; | ||
+ | ENDIF; | ||
+ | |||
+ | IF *INU2 AND AID = X3B AND | ||
+ | (LOP2 = X01 OR LOP2 = X02); | ||
+ | EXCEPT DELREC; | ||
+ | UPDDONE = @TRUE; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | IF RTN = '3' OR UPDDONE = @TRUE; | ||
+ | ELSE; | ||
+ | EXSR @PCKD; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // CONT1 GET A RECORD, KEY FROM DATA | ||
+ | EXSR @SETIN; | ||
+ | EXSR @GETF ; | ||
+ | EXSR @PUTF ; | ||
+ | EXSR @KEYIN; | ||
+ | |||
+ | ENDDO ; | ||
+ | |||
+ | *INLR = *ON; | ||
+ | |||
+ | // @@@@@@@ @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @INITZ; | ||
+ | ONCE = '1'; | ||
+ | KEYLNA = KEYLNG ; | ||
+ | EXSR @INIT ; | ||
+ | EXSR @GETFLD ; | ||
+ | EXSR @GETADD ; | ||
+ | EXSR @PUTHED ; | ||
+ | EXSR @KEYIN ; | ||
+ | INZ = '1'; | ||
+ | EXSR @PCKD ; | ||
+ | INZ = ' '; | ||
+ | ENDSR; | ||
+ | |||
+ | // @@@@@@@ @PCKD @@@@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | |||
+ | BEGSR @PCKD ; | ||
+ | |||
+ | // CONVERT KEY DATA | ||
+ | IF *INU1 ; | ||
+ | EXSR @CVTKEY; | ||
+ | ENDIF; | ||
+ | IF *INU2 ; | ||
+ | EXSR @CVTRRN; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | // @@@@@@@ @CVTKEY @@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | |||
+ | BEGSR @CVTKEY; | ||
+ | |||
+ | // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING | ||
+ | |||
+ | // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE | ||
+ | // THE MODIFIED DATA INTO THE COMPOSITE KEY | ||
+ | |||
+ | K1 = 0; | ||
+ | K2 = 0; | ||
+ | W = 1; | ||
+ | |||
+ | FOR Y = 1 TO NUMKEY ; | ||
+ | |||
+ | // MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS) | ||
+ | |||
+ | // GET SIZE OF FIELD IN BYTES | ||
+ | IF T(Y) = 'A'; // ALPHA DATA | ||
+ | K = ' '; | ||
+ | K1 = 1; | ||
+ | K2 = Q(Y); | ||
+ | ELSE; | ||
+ | K = '0'; | ||
+ | K1 = 1; | ||
+ | K2 = C(Y); | ||
+ | ENDIF; | ||
+ | |||
+ | // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT | ||
+ | IF INZ = '1' ; | ||
+ | KW = *BLANK; | ||
+ | EXSR @PCKMOV; | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | |||
+ | X = 1; | ||
+ | |||
+ | DOW @LOOP = @LOOP; | ||
+ | |||
+ | // NXTSBA | ||
+ | X = %LOOKUP(SBA : ID : X ); | ||
+ | IF X = 0; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // IS THIS THE FIELD? CHECK THE BUFFER ADDRESS | ||
+ | X = X +1; | ||
+ | IF B(Y) <> %SUBST(IDA : X :2); | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | |||
+ | // FOUND A MTD FOR THIS FIELD | ||
+ | X = X + 2; | ||
+ | |||
+ | // CHECK IF FIELD WAS CLEARED ONLY | ||
+ | IF ID(X) = SBA; | ||
+ | EXSR @PCKMOV; | ||
+ | LEAVE ; | ||
+ | ENDIF; | ||
+ | |||
+ | // IF FIELD HAS DECIMALS BUMP X | ||
+ | IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND | ||
+ | P(Y) > 0; | ||
+ | X = X + 1; | ||
+ | ENDIF; | ||
+ | |||
+ | // CHECK IF ONLY BLANKS RETURNED | ||
+ | IF %SUBST(IDA : X :K2) = *BLANKS; | ||
+ | EXSR @PCKMOV; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // EXTRACT THE DATA FROM THE INCOMING STRING | ||
+ | X1 = X; | ||
+ | FOR X2 = 1 TO K2 ; | ||
+ | |||
+ | IF ID(X1) < ' '; | ||
+ | // TRAP NULLS CAUSED BY FLD EXIT | ||
+ | EXSR @PCKMOV; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | K(X2) = ID(X1); | ||
+ | X1 = X1 +1; | ||
+ | ENDFOR; | ||
+ | |||
+ | // CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED | ||
+ | // INTO ARRAY KW | ||
+ | EXSR @PCKMOV; | ||
+ | LEAVE; | ||
+ | ENDDO; | ||
+ | |||
+ | ENDFOR; | ||
+ | |||
+ | // | ||
+ | KEYA = KW; | ||
+ | CLEAR KW; | ||
+ | ENDSR ; | ||
+ | |||
+ | // @@@@@@@ @CVTRRN @@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | |||
+ | BEGSR @CVTRRN; | ||
+ | |||
+ | // RRN | ||
+ | |||
+ | NUM11 = 0; | ||
+ | |||
+ | DOW @LOOP = @LOOP; // NOT REALLY A LOOP(SIMULATES GOTO) | ||
+ | |||
+ | // GET THE FIRST SBA | ||
+ | X = 1; | ||
+ | X = %LOOKUP(SBA : ID : X ); | ||
+ | IF X = 0; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD | ||
+ | X = X +1; | ||
+ | IF B(1) <> %SUBST(IDA : X :2); | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | |||
+ | // FOUND A MTD FOR RRN FIELD | ||
+ | X = X +2; | ||
+ | |||
+ | //CHECK IF FIELD WAS CLEARED ONLY | ||
+ | IF ID(X) = SBA; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // CHECK IF ONLY BLANKS RETURNED | ||
+ | IF %SUBST(IDA : X :11) = *BLANKS; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // WRK11 OVERLAYS NUM11 | ||
+ | WRK11 = %SUBST(IDA : X :11); | ||
+ | |||
+ | LEAVE; | ||
+ | ENDDO; | ||
+ | |||
+ | |||
+ | RRNA = NUM11; | ||
+ | IF RRNA < 0; | ||
+ | RRNA = 1; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | // @@@@@@@ @PCKMOV @@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | |||
+ | BEGSR @PCKMOV; | ||
+ | // | ||
+ | // CONVERT KEY DATA | ||
+ | // SET START POSN IN KEY USING OFFSET IN R | ||
+ | X1 = %LOOKUP(N(Y) : N ); | ||
+ | W = R(X1) + 1; | ||
+ | |||
+ | // ALPHA | ||
+ | IF T(Y) = 'A'; | ||
+ | X1 = 1; | ||
+ | FOR Z = W TO W + Q(Y); | ||
+ | %SUBST(KW : Z : 1) = K(X1); | ||
+ | X1 = X1 + 1; | ||
+ | ENDFOR; | ||
+ | ENDIF; | ||
+ | |||
+ | // NUMERIC FIELD | ||
+ | // RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS | ||
+ | IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B'); | ||
+ | NU = '0'; | ||
+ | |||
+ | Z1 = 60; | ||
+ | FOR Z = K2 DOWNTO K1; | ||
+ | |||
+ | IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$'; | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | |||
+ | IF K(Z) = ' ' ; | ||
+ | NU(Z1) = '0'; | ||
+ | ELSE; | ||
+ | NU(Z1) = K(Z); | ||
+ | ENDIF; | ||
+ | |||
+ | Z1 = Z1 -1; | ||
+ | ENDFOR; | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | // SIGNED FIELDS (END POSN = OFFSET + SIZE) | ||
+ | IF T(Y) = 'S'; | ||
+ | NUS = 0; | ||
+ | FOR VX = 1 TO 60; | ||
+ | NUSA = %TRIM(NUSA) + NU(VX); | ||
+ | ENDFOR; | ||
+ | %SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y)); | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | // PACKED FIELDS | ||
+ | IF T(Y) = 'P'; | ||
+ | NUSA= *BLANKS; | ||
+ | FOR VX = 1 TO 60; | ||
+ | NUSA = %TRIM(NUSA) + NU(VX); | ||
+ | ENDFOR; | ||
+ | NUP = %DEC(NUSA : 60 : 0); | ||
+ | |||
+ | %SUBST(KW : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y)); | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | // BINARY FIELDS | ||
+ | IF T(Y) = 'B'; | ||
+ | |||
+ | IF Q(Y) = 2 ; | ||
+ | BY2 = NU(1) + NU(2); | ||
+ | %SUBST(KW : W : 2) = BY2; | ||
+ | ENDIF; | ||
+ | |||
+ | IF Q(Y) = 4 ; | ||
+ | BY4 = NU(1) + NU(2) + NU(3) + NU(4); | ||
+ | %SUBST(KW : W : 4) = BY4; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | // @@@@@@@ SETIN @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @SETIN; | ||
+ | |||
+ | // SET the FFR indicators to get the Input buffer somewhat aligned with the | ||
+ | // actual data. RPG is somewhat tolerant to a difference between the Ispecs | ||
+ | // and the actual file size but it can fail on big differences. | ||
+ | // INCREMENT OF 32 BYTES | ||
+ | SZ(1) = BASE + 16; | ||
+ | SZ(2) = SZ(1) + 16; | ||
+ | |||
+ | *IN30 = *ON; | ||
+ | IF (RLEN > SZ(2)) ; | ||
+ | *IN31 = *ON; | ||
+ | ENDIF; | ||
+ | |||
+ | FOR X = 3 TO 64; | ||
+ | SZ(X) = SZ(X-1) + 32; | ||
+ | IF (RLEN > SZ(X)) ; | ||
+ | *IN(29+X) = *ON; | ||
+ | ENDIF; | ||
+ | ENDFOR; | ||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | //@@@@@@@@@@@@@@@@@ @GETF @@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @GETF; | ||
+ | // GET A DATA RECORD | ||
+ | IF (*INU1); | ||
+ | IF AID = '1' OR AID = X36 OR | ||
+ | AID = X39 OR AID = X3B ; | ||
+ | SETLL(E) KEYA INPUTK; | ||
+ | READ(E) INPUTK; | ||
+ | IF %EOF; | ||
+ | SETLL(E) KEYA INPUTK; | ||
+ | READP(E) INPUTK; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | IF AID = '4'; | ||
+ | READP(E) INPUTK; | ||
+ | ENDIF; | ||
+ | |||
+ | IF AID = '5'; | ||
+ | READ(E) INPUTK; | ||
+ | ENDIF; | ||
+ | |||
+ | IF %ERROR; | ||
+ | SETLL(E) KEYA INPUTK; | ||
+ | READ(E) INPUTK; | ||
+ | MX = 7; | ||
+ | EXSR @ERROR; | ||
+ | EXSR @PUTF ; | ||
+ | EXSR @KEYIN; | ||
+ | ENDIF; | ||
+ | |||
+ | KEYA = LKY; | ||
+ | |||
+ | |||
+ | CLEAR KW; | ||
+ | KW = LKY; | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | IF (*INU2); | ||
+ | IF AID = '1'; | ||
+ | CHAIN(E) RRNA INPUTR; | ||
+ | IF %ERROR; | ||
+ | SETLL(E) RRNA INPUTR; | ||
+ | READP(E) INPUTR; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | IF AID = X36; | ||
+ | CHAIN(E) RRNA INPUTR; | ||
+ | ENDIF; | ||
+ | |||
+ | IF AID = '4'; | ||
+ | READP(E) INPUTR; | ||
+ | ENDIF; | ||
+ | |||
+ | IF AID = '5' OR AID = X3B; | ||
+ | READ(E) INPUTR; | ||
+ | ENDIF; | ||
+ | |||
+ | IF AID = X39; | ||
+ | SETLL(E) *HIVAL INPUTR; | ||
+ | READP(E) INPUTR; | ||
+ | ENDIF; | ||
+ | |||
+ | IF %ERROR; | ||
+ | CHAIN 1 INPUTR; | ||
+ | MX = 7; | ||
+ | EXSR @ERROR; | ||
+ | EXSR @PUTF ; | ||
+ | EXSR @KEYIN; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | //@@@@@@@@@@@@@@@@@ @PUTF @@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @PUTF; | ||
+ | |||
+ | SELECT; | ||
+ | WHEN *INU1; | ||
+ | RRN = RN1; | ||
+ | WHEN *INU2; | ||
+ | RRN = RN2; | ||
+ | ENDSL; | ||
+ | // IF GOT RECORDS WRITE DATA TO THE DISPLAY | ||
+ | |||
+ | NEWRU = '1'; | ||
+ | WRTRRN = '1'; | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; // initialise Request Unit 255 bytes max | ||
+ | |||
+ | IF RRN > 0 ; | ||
+ | FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | ||
+ | |||
+ | IF NEWRU = '1'; | ||
+ | NEWRU = '0'; | ||
+ | RU = ESC + WTD + X20 + X00; | ||
+ | ENDIF; | ||
+ | |||
+ | IF WRTRRN = '1'; | ||
+ | WRTRRN = '0'; | ||
+ | RU = RU + SBA + RBA ; | ||
+ | RU = RU + %TRIM(%EDITC(RRN:'Z')); | ||
+ | ENDIF; | ||
+ | |||
+ | // BUFFER ADDRESS | ||
+ | RU = RU + SBA + B(XX); | ||
+ | |||
+ | // PROCESS ALPHA DATA TYPE | ||
+ | IF T(XX) = 'A' OR T(XX) = 'T' OR T(XX) = 'Z' OR | ||
+ | T(XX) = 'L'; | ||
+ | |||
+ | STRX = S(XX); | ||
+ | ENDX = E(XX); | ||
+ | |||
+ | IF V(XX) = 'Y'; //VARYING | ||
+ | VX = S(XX); | ||
+ | HX2 = D(VX) + D(VX+1); | ||
+ | STRX = S(XX) + 2 ; | ||
+ | ENDX = S(XX) + BIN; | ||
+ | ENDIF; | ||
+ | |||
+ | FOR Y = STRX TO ENDX ; | ||
+ | IF D(Y) >= ' '; | ||
+ | RU = RU + D(Y); | ||
+ | ELSE; | ||
+ | RU = RU + X1F ; //IF NOT DISPLAYABLE REPLACE WITH X'1F' | ||
+ | ENDIF; | ||
+ | ENDFOR; | ||
+ | ENDIF; | ||
+ | |||
+ | // PROCESS SIGNED DATA TYPE (not the RRN field) | ||
+ | IF T(XX) = 'S' and KY(XX) <> '3'; | ||
+ | NUSA = *ALL'0'; | ||
+ | WRV = *ALLX'00'; | ||
+ | CLEAR WRV; | ||
+ | FOR Y = S(XX) TO E(XX); | ||
+ | IF D(Y) >= XD0; | ||
+ | WRV = WRV + D(Y); | ||
+ | ENDIF; | ||
+ | ENDFOR; | ||
+ | EVAL NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV; | ||
+ | CLEAR WRU; | ||
+ | WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD); | ||
+ | IF P(XX) > 0; | ||
+ | RU = RU + | ||
+ | %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' + | ||
+ | %SUBST(WRU :61-P(XX)) ; | ||
+ | ELSE; | ||
+ | RU = RU + | ||
+ | %SUBST(WRU :61-C(XX)); | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // PROCESS SIGNED DATA TYPE (the RRN field) | ||
+ | IF T(XX) = 'S' and KY(XX) = '3'; | ||
+ | RRN = RN2; | ||
+ | RU = RU + %TRIM(%EDITC(RRN:'X')); | ||
+ | ENDIF; | ||
+ | |||
+ | // PROCESS PACKED DATA TYPE | ||
+ | IF T(XX) = 'P'; | ||
+ | NUPA = *ALLX'00'; | ||
+ | WRV = *ALLX'00'; | ||
+ | CLEAR WRV; | ||
+ | FOR Y = S(XX) TO E(XX); | ||
+ | WRV = WRV + D(Y); | ||
+ | ENDFOR; | ||
+ | |||
+ | IF %BITAND(D(E(XX)) :X0F) = X0F OR | ||
+ | %BITAND(D(E(XX)) :X0D) = X0D; | ||
+ | |||
+ | EVAL NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV; | ||
+ | CLEAR WRX; | ||
+ | WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD); | ||
+ | IF P(XX) > 0; | ||
+ | RU = RU + | ||
+ | %SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' + | ||
+ | %SUBST(WRX :64-P(XX)) ; | ||
+ | ELSE; | ||
+ | RU = RU + | ||
+ | %SUBST(WRX :64-C(XX)); | ||
+ | ENDIF; | ||
+ | ELSE; | ||
+ | // PACKED FIELD IN ERROR | ||
+ | RU = RU + X1F; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | // PROCESS BINARY DATA TYPE | ||
+ | IF T(XX) = 'B'; | ||
+ | |||
+ | ST = S(XX); | ||
+ | CLEAR NUSA; | ||
+ | IF Q(XX) = 2; | ||
+ | BY2 = D(ST) + D(ST+1); | ||
+ | NUS = BIN2; | ||
+ | ENDIF; | ||
+ | IF Q(XX) = 4; | ||
+ | BY4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3); | ||
+ | NUS = BIN4; | ||
+ | ENDIF; | ||
+ | |||
+ | WRU = %EDITW(NUS :WRSWRD); | ||
+ | IF P(XX) > 0; | ||
+ | RU = RU + | ||
+ | %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' + | ||
+ | %SUBST(WRU :61-P(XX)) ; | ||
+ | ELSE; | ||
+ | RU = RU + | ||
+ | %SUBST(WRU :61-C(XX)); | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // PROCESS FLOAT DATA TYPE | ||
+ | IF T(XX) = 'F'; | ||
+ | |||
+ | ST = S(XX); | ||
+ | |||
+ | IF Q(XX) = 4; | ||
+ | FL4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3); | ||
+ | FLT14 = %EDITFLT(FLT4); | ||
+ | RU = RU + FLT14; | ||
+ | ENDIF; | ||
+ | |||
+ | IF Q(XX) = 8; | ||
+ | FL8 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) + | ||
+ | D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7); | ||
+ | FLT23 = %EDITFLT(FLT8); | ||
+ | RU = RU + FLT23; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // SEND A REQUEST UNIT IF GOT ENOUGH DATA | ||
+ | |||
+ | IF %LEN(RU) + L(XX + 1) >= 200; | ||
+ | RU = RU + X20; | ||
+ | BIN = %LEN(RU); | ||
+ | OUTLEN = HX2; | ||
+ | INLEN = X000; | ||
+ | FNC = SND; | ||
+ | A = RU; | ||
+ | EXCEPT DATAO; | ||
+ | NEWRU = '1'; | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDFOR; | ||
+ | ENDIF; | ||
+ | |||
+ | IF %LEN(RU) > 5 AND %LEN(RU) < 250; | ||
+ | RU = RU + X20; | ||
+ | BIN = %LEN(RU); | ||
+ | OUTLEN = HX2; | ||
+ | INLEN = X000; | ||
+ | FNC = SND; | ||
+ | A = RU; | ||
+ | EXCEPT DATAO; | ||
+ | ENDIF; | ||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | // @@@@@@@@@@@@@@@ ROWINC @@@@@@@@@@@@@@@ | ||
+ | |||
+ | // INCREMENT THE ROW | ||
+ | BEGSR @ROWINC; | ||
+ | ROW = ROW + 2; | ||
+ | IF ROW > 20; | ||
+ | MX = 3; | ||
+ | ENDIF; | ||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | |||
+ | // @@@@@@@@@@@@@@@ GETFLD @@@@@@@@@@@@@@@ | ||
+ | |||
+ | // LOAD FIELD DESCRIPTION ARRAYS | ||
+ | BEGSR @GETFLD; | ||
+ | MX = 0; | ||
+ | X = 0; | ||
+ | |||
+ | IF (*INU2 = *ON); | ||
+ | // IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN | ||
+ | N(1) = 'RRN'; | ||
+ | T(1) = 'S' ; | ||
+ | C(1) = 11 ; | ||
+ | P(1) = 0 ; | ||
+ | S(1) = 0 ; | ||
+ | E(1) = 0 ; | ||
+ | L(1) = 12 ; | ||
+ | I(1) = X4F06 ; | ||
+ | KY(1)= '3' ; | ||
+ | X = 1 ; | ||
+ | ENDIF; | ||
+ | |||
+ | SCRST = *BLANK; | ||
+ | SCRSTN = *BLANK; | ||
+ | |||
+ | LVL = %DEC(SCNLVL : 5:0); | ||
+ | |||
+ | TEXT500 = SCNLV ; | ||
+ | LV = LVW; | ||
+ | |||
+ | IF LVL <> 0; | ||
+ | SCRST = LV(LVL); | ||
+ | ENDIF; | ||
+ | |||
+ | SETLL 1 QWHDRFFD ; | ||
+ | |||
+ | DOW @LOOP = @LOOP; | ||
+ | // REREAD TAG | ||
+ | READ QWHDRFFD; | ||
+ | IF %EOF; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // SELECT OR OMIT | ||
+ | IF ALL <> '1'; | ||
+ | IF ALL = 'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS | ||
+ | IF WHFIOB <> 'S'; | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | IF ALL = 'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS | ||
+ | IF WHFIOB = 'O'; | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | // FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS) | ||
+ | IF WHDFTL <> 0 ; | ||
+ | ELSE; | ||
+ | IF SCRST <> ' ' AND SCRSTN = ' '; | ||
+ | IF WHFLDE = SCRST; | ||
+ | SCRSTN = '1'; // FOUND THE START | ||
+ | ELSE; | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | X = X + 1; | ||
+ | // CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT | ||
+ | IF WHDFTL <> 0; | ||
+ | KY(X) = '1'; | ||
+ | WX = WHDFTL ; | ||
+ | KE(WX) = WHFLDE; | ||
+ | IF NUMKEY < WHDFTL; | ||
+ | NUMKEY = WHDFTL; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | N(X) = WHFLDE ; // NAME | ||
+ | T(X) = WHFLDT ; // TYPE | ||
+ | V(X) = WHVARL ; // VARYING | ||
+ | C(X) = WHFLDD ; // DEC DIGITS | ||
+ | P(X) = WHFLDP ; // DEC PREC | ||
+ | S(X) = WHFOBO ; // START | ||
+ | Q(X) = WHFLDB ; // BTYES | ||
+ | E(X) = WHFOBO + WHFLDB -1 ; // END | ||
+ | |||
+ | IF T(X) = 'F' ; // FLOAT | ||
+ | |||
+ | I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA | ||
+ | L(X) = 14; | ||
+ | IF Q(X) = 8; | ||
+ | L(X) = 23; | ||
+ | ENDIF; | ||
+ | |||
+ | ELSE; | ||
+ | IF WHFLDD <> 0 ; | ||
+ | IF WHFLDP <> 0 ; | ||
+ | L(X) = WHFLDD + 2 ; // LENGTH | ||
+ | ELSE; | ||
+ | L(X) = WHFLDD + 1 ; // LENGTH | ||
+ | ENDIF; | ||
+ | |||
+ | I(X) = FFN1 + FFN2; // SCRN FIELD FORMAT NUMERIC | ||
+ | |||
+ | ELSE; | ||
+ | L(X) = WHFLDB ; | ||
+ | I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDDO; | ||
+ | // NUMBER OF FIELDS | ||
+ | NUMFLD = X ; | ||
+ | |||
+ | // MAKE ROOM FOR KEYS | ||
+ | IF NUMKEY > 0 ; | ||
+ | X1 = NUMKEY + NUMFLD; | ||
+ | |||
+ | FOR X = NUMFLD DOWNTO 1; | ||
+ | KY(X1) = KY(X) ; | ||
+ | L(X1) = L(X) ; | ||
+ | I(X1) = I(X) ; | ||
+ | N(X1) = N(X) ; | ||
+ | T(X1) = T(X) ; | ||
+ | V(X1) = V(X) ; | ||
+ | C(X1) = C(X) ; | ||
+ | P(X1) = P(X) ; | ||
+ | S(X1) = S(X) ; | ||
+ | E(X1) = E(X) ; | ||
+ | Q(X1) = Q(X) ; | ||
+ | X1 = X1 - 1; | ||
+ | ENDFOR; | ||
+ | |||
+ | // PUT KEY FIELDS AT TOP | ||
+ | OFF = 0; | ||
+ | FOR X = 1 TO NUMKEY; | ||
+ | X1 = %LOOKUP(KE(X) : N : NUMKEY+1); | ||
+ | |||
+ | KY(X) = '2'; | ||
+ | L(X) = L(X1); | ||
+ | I(X) = I(X1); // FIELD FMT | ||
+ | SELECT; // INPUT ENABLE | ||
+ | WHEN I(X) = X6000; | ||
+ | I(X) = X4800; | ||
+ | WHEN I(X) = X6706; | ||
+ | I(X) = X4F06; | ||
+ | ENDSL; | ||
+ | N(X) = N(X1); | ||
+ | T(X) = T(X1); | ||
+ | V(X) = V(X1); | ||
+ | C(X) = C(X1); | ||
+ | P(X) = P(X1); | ||
+ | S(X) = S(X1); | ||
+ | E(X) = E(X1); | ||
+ | Q(X) = Q(X1); | ||
+ | R(X) = OFF; | ||
+ | OFF = OFF + Q(X1); | ||
+ | ENDFOR; | ||
+ | |||
+ | ENDIF; | ||
+ | // NUMBER OF FIELDS AND KEYS | ||
+ | NUMFKY = NUMFLD + NUMKEY; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | // @@@@@@@@@@@@@@@ GETADD @@@@@@@@@@@@@@@ | ||
+ | |||
+ | // LOAD FIELD BUFFER ADDRESSES | ||
+ | BEGSR @GETADD; | ||
+ | MX = 0; | ||
+ | X = 0; | ||
+ | ROW = 3; | ||
+ | COL = 1; | ||
+ | |||
+ | FOR X = 1 TO NUMFKY; | ||
+ | |||
+ | // IF FINISHED WITH THE KEY FIELDS | ||
+ | // INC ROW FOR 1ST DATA FIELD | ||
+ | IF KEYSOK = ' ' ; | ||
+ | IF KY(X) = ' ' OR KY(X) = '1'; | ||
+ | KEYSOK = '1' ; | ||
+ | ROW = ROW + 2; | ||
+ | COL = 1; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | // SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE | ||
+ | LENDSC = %LEN(%TRIM(N(X))); | ||
+ | LENWRK = L(X); | ||
+ | IF LENDSC > L(X); | ||
+ | LENWRK = LENDSC; | ||
+ | ENDIF; | ||
+ | LENWRK = LENWRK + 2; | ||
+ | |||
+ | // TRAP FIELDS THAT OVERFLOW | ||
+ | ROW = ROW + XROW; | ||
+ | XROW = %DIV(LENWRK : 80); | ||
+ | |||
+ | IF (COL + LENWRK) > 78; | ||
+ | EXSR @ROWINC; | ||
+ | IF MX = 3; | ||
+ | X= X-1; | ||
+ | NUMFKY = X; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | COL = 1; | ||
+ | ENDIF; | ||
+ | |||
+ | // INC COL. FOR FIELD START | ||
+ | CLEAR B(X); | ||
+ | BIN = ROW; | ||
+ | B(X) = %TRIM(B(X)) + HX1; | ||
+ | BIN = COL + 1; | ||
+ | B(X) = %TRIM(B(X)) + HX1; | ||
+ | |||
+ | // INC COL. FOR NEXT FIELD | ||
+ | COL = COL + LENWRK; | ||
+ | IF COL > 78; | ||
+ | EXSR @ROWINC; | ||
+ | IF MX = 3; // NO ROOM FOR THE FIELD | ||
+ | X= X-1; | ||
+ | NUMFKY = X; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | COL = 1; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDFOR; | ||
+ | |||
+ | // FIELD LEVEL | ||
+ | LVX = LVL + 1; | ||
+ | LV(LVX) = N(X); | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | // @@@@@@@@@@@@@@@ PUTHED @@@@@@@@@@@@@@@ | ||
+ | |||
+ | // PUT FIELD HEADINGS | ||
+ | BEGSR @PUTHED; | ||
+ | |||
+ | |||
+ | NEWRU = '1'; | ||
+ | |||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; // initialise Request Unit 255 bytes max | ||
+ | FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | ||
+ | |||
+ | IF NEWRU = '1'; | ||
+ | NEWRU = '0'; | ||
+ | RU = ESC + WTD + X20 + X00; | ||
+ | ENDIF; | ||
+ | |||
+ | RU = RU + SBA; | ||
+ | BIN = 0; | ||
+ | // CONVERT DATA BUFADR TO HEADING BUFADR | ||
+ | HX1 = %SUBST(B(XX) :1:1); | ||
+ | BIN = BIN - 1; | ||
+ | RU = RU + HX1; | ||
+ | |||
+ | IF REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR | ||
+ | BIN = 0; | ||
+ | HX1 = %SUBST(B(XX) :2:1); | ||
+ | BIN = BIN -1 ; | ||
+ | RU = RU + HX1; | ||
+ | ELSE; | ||
+ | RU = RU + %SUBST(B(XX) :2); | ||
+ | ENDIF; | ||
+ | |||
+ | RU = RU + ATC ; | ||
+ | |||
+ | // LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS | ||
+ | LENDSC = %LEN(%TRIM(N(XX))); | ||
+ | IF T(XX) <> 'A' AND LENDSC < (L(XX) -1); | ||
+ | FOR Y = 1 TO (L(XX) -(LENDSC +1)); | ||
+ | RU = RU + ' '; | ||
+ | ENDFOR; | ||
+ | ENDIF; | ||
+ | |||
+ | RU = RU + %TRIM(N(XX)); | ||
+ | |||
+ | IF %LEN(RU) >= 200; | ||
+ | BIN = %LEN(RU); | ||
+ | OUTLEN = HX2; | ||
+ | INLEN = X000; | ||
+ | FNC = SND; | ||
+ | A = RU; | ||
+ | EXCEPT DATAO; | ||
+ | NEWRU = '1'; | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDFOR; | ||
+ | |||
+ | IF %LEN(RU) > 5 AND %LEN(RU) < 200; | ||
+ | BIN = %LEN(RU); | ||
+ | OUTLEN = HX2; | ||
+ | INLEN = X000; | ||
+ | FNC = SND; | ||
+ | A = RU; | ||
+ | EXCEPT DATAO; | ||
+ | ENDIF; | ||
+ | |||
+ | IF REHEAD <> '1'; | ||
+ | // FORMAT FIELDS | ||
+ | |||
+ | |||
+ | NEWRU = '1'; | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; // initialise Request Unit 255 bytes max | ||
+ | FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | ||
+ | |||
+ | IF NEWRU = '1'; | ||
+ | NEWRU = '0'; | ||
+ | RU = ESC + WTD + X20 + X00; | ||
+ | ENDIF; | ||
+ | |||
+ | RU = RU + SBA +B(XX)+SF + I(XX); | ||
+ | |||
+ | IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3'; | ||
+ | RU = RU + X25; | ||
+ | ELSE; | ||
+ | RU = RU + X26; | ||
+ | ENDIF; | ||
+ | |||
+ | BIN = L(XX); | ||
+ | RU = RU + HX2; | ||
+ | |||
+ | // LENGTH OF INPUT FIELDS | ||
+ | LENF = LENF + L(XX) + 3; | ||
+ | |||
+ | |||
+ | IF %LEN(RU) >= 200; | ||
+ | BIN = %LEN(RU); | ||
+ | OUTLEN = HX2; | ||
+ | INLEN = X000; | ||
+ | FNC = SND; | ||
+ | A = RU; | ||
+ | EXCEPT DATAO; | ||
+ | NEWRU = '1'; | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDFOR; | ||
+ | |||
+ | // PUT LAST R/U | ||
+ | IF %LEN(RU) > 5 AND %LEN(RU) < 200; | ||
+ | BIN = %LEN(RU); | ||
+ | OUTLEN = HX2; | ||
+ | INLEN = X000; | ||
+ | FNC = SND; | ||
+ | A = RU; | ||
+ | EXCEPT DATAO; | ||
+ | ENDIF; | ||
+ | |||
+ | //INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT | ||
+ | FOR XP = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | ||
+ | HX2 = B(XP); | ||
+ | BIN = BIN + 1; | ||
+ | B(XP) = HX2; | ||
+ | ENDFOR; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | // @@@@@@@ INIT @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @INIT; | ||
+ | |||
+ | CLEAR KW; | ||
+ | |||
+ | // UPDATE | ||
+ | IF UPDF = 'Y'; | ||
+ | FFA1 = X40; | ||
+ | FFN1 = X47; | ||
+ | ELSE; | ||
+ | FFA1 = X60; | ||
+ | FFN1 = X67; | ||
+ | ENDIF; | ||
+ | |||
+ | SELECT; | ||
+ | WHEN *INU1 = '1'; | ||
+ | FILE = F1 ; | ||
+ | LIB = L1 ; | ||
+ | MBR = M1 ; | ||
+ | RCDL = R1 ; | ||
+ | ACCTP = A1 ; | ||
+ | WHEN *INU2 = '1'; | ||
+ | FILE = F2 ; | ||
+ | LIB = L2 ; | ||
+ | MBR = M2 ; | ||
+ | RCDL = R2 ; | ||
+ | ACCTP = A2 ; | ||
+ | ENDSL; | ||
+ | RLEN = RCDL ; | ||
+ | RLENTH = %EDITC(RLEN: 'X') ; | ||
+ | LENF = 0 ; | ||
+ | |||
+ | |||
+ | // Control commands and data are constructed into RUs Request UNITS | ||
+ | // Each RU is 256 bytes max size. | ||
+ | // Construct and send as many RUs as needed to format the display. | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; // initialise Request Unit 255 bytes max | ||
+ | RU = CLRWTD ; | ||
+ | //set up the screen headings | ||
+ | BIN = 1; // set ROW to 1 | ||
+ | RW = HX1; | ||
+ | BIN = 2; // set COL to 2 | ||
+ | CL = HX1; | ||
+ | RU = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE); | ||
+ | RU = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN : 'Z') ; | ||
+ | RU = RU + ' RRN ' ; | ||
+ | BIN = %len(RU) -4; | ||
+ | RBA = RW + HX1 ; // address of the RRN field | ||
+ | RU = RU + SBA + RBA + ' '; | ||
+ | |||
+ | // FUNCTION KEYS | ||
+ | BIN = 23; | ||
+ | RW = HX1; | ||
+ | BIN = 02; | ||
+ | CL = HX1; | ||
+ | IF UPDF = 'Y'; // UPDATE IS ON | ||
+ | RU = RU + SBA + RW + CL + %TRIM(CNS(2)); | ||
+ | ELSE; | ||
+ | RU = RU + SBA + RW + CL + %TRIM(CNS(1)); | ||
+ | ENDIF; | ||
+ | |||
+ | // THIS IS A SEND ONLY FUNCTION | ||
+ | FNC = SND; | ||
+ | CLEAR A; | ||
+ | A = RU; | ||
+ | BIN2 = %LEN(RU); | ||
+ | OUTLEN = BY2; | ||
+ | INLEN = x000; | ||
+ | |||
+ | EXCEPT DATAO; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | // @@@@@@@ KEYIN @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @KEYIN; | ||
+ | // ISSUE A READ FROM DISPLAY | ||
+ | FNC = SNR; | ||
+ | BIN2 = 8; | ||
+ | OUTLEN = BY2; | ||
+ | IPL = LENF + 34; | ||
+ | BIN2 = IPL; | ||
+ | INLEN = BY2; | ||
+ | |||
+ | // SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW | ||
+ | FOR X = 1 TO 9; | ||
+ | IF IPL > ( X*80 +3); | ||
+ | *IN(X+19) = *ON; | ||
+ | ENDIF; | ||
+ | ENDFOR; | ||
+ | |||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | RU = RDDSP; | ||
+ | A = RU; | ||
+ | |||
+ | EXCEPT DATAI; | ||
+ | ENDSR; | ||
+ | |||
+ | // @@@@@@@ ERROR @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @ERROR; | ||
+ | |||
+ | // SETUP PUT ERROR MESSAGE X'21' | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | |||
+ | FNC = SNR; | ||
+ | BIN = 42; | ||
+ | OUTLEN = HX2; | ||
+ | BIN = LENF + 34; | ||
+ | IPL = BIN; | ||
+ | INLEN = HX2; | ||
+ | |||
+ | FOR X = 1 TO 9; | ||
+ | IF IPL > (X * 80 +3) ; | ||
+ | *IN(X + 19) = *ON; // SETON FFR 20 - 29 FOR INPUT | ||
+ | ENDIF; | ||
+ | ENDFOR; | ||
+ | |||
+ | RU = ESC + WER + IC + B(1) + ATC + MSG(MX); | ||
+ | RU = RU + ESC + RDM + X40+ X00; | ||
+ | |||
+ | A = RU; | ||
+ | EXCEPT DATAI; | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | // @@@@@@@ HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @HXDSP; | ||
+ | |||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | Y = %LOOKUPLE( CURLOC : B ); | ||
+ | // | ||
+ | RU = ESC + WTD + X20 + X00 + SBA; | ||
+ | BIN = 0; | ||
+ | HX1 = %SUBST(B(Y) :1:1); | ||
+ | BIN = BIN - 1; | ||
+ | RU = RU + HX1; | ||
+ | RU = RU + %SUBST(B(Y) :2:1); | ||
+ | |||
+ | FOR X = S(Y) TO E(Y); | ||
+ | BIN = 0; | ||
+ | HX1 = D(X); | ||
+ | HX1 = %BITAND(HX1 : XF0); | ||
+ | Z = BIN / 16 + 1; | ||
+ | RU = RU + CRS(Z); | ||
+ | ENDFOR; | ||
+ | |||
+ | RU = RU + X20; | ||
+ | |||
+ | RU = RU + SBA + B(Y); | ||
+ | FOR X = S(Y) TO E(Y); | ||
+ | BIN = 0; | ||
+ | HX1 = D(X); | ||
+ | HX1 = %BITAND(HX1 : X0F); | ||
+ | Z = BIN + 1; | ||
+ | RU = RU + CRS(Z); | ||
+ | ENDFOR; | ||
+ | |||
+ | |||
+ | BIN = %LEN(RU); | ||
+ | OUTLEN = HX2; | ||
+ | INLEN = X000; | ||
+ | FNC = SND; | ||
+ | A = RU; | ||
+ | EXCEPT DATAO; | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | |||
+ | |||
+ | EXSR @KEYIN; | ||
+ | READ DISPF; | ||
+ | |||
+ | |||
+ | // CLEAR HEADINGS | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | |||
+ | RU = RU + ESC + WTD + X20 + X00 + SBA; | ||
+ | HX1 = %SUBST(B(Y) :1:1) ; | ||
+ | BIN = BIN - 1; | ||
+ | RU = RU + HX1 + %SUBST(B(Y):2:1); | ||
+ | FOR X = S(Y) TO E(Y); | ||
+ | RU = RU + ' '; | ||
+ | ENDFOR; | ||
+ | RU = RU + ' '; | ||
+ | |||
+ | BIN = %LEN(RU); | ||
+ | OUTLEN = HX2; | ||
+ | INLEN = X000; | ||
+ | FNC = SND; | ||
+ | A = RU; | ||
+ | EXCEPT DATAO; | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | |||
+ | // @@@@@@@ UPD @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @UPD; | ||
+ | |||
+ | // CONVERT DATA FOR OUTPUT | ||
+ | |||
+ | // FOR EACH FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE | ||
+ | // THE MODIFIED DATA INTO THE OUTPUT ARRAY | ||
+ | K1 = 0; | ||
+ | K2 = 0; | ||
+ | W = 1; | ||
+ | CGKY = *BLANK; // KEY CHANGED | ||
+ | KW = KEYA; | ||
+ | |||
+ | FOR Y = 1 TO NUMFKY ; | ||
+ | |||
+ | IF KY(Y) > '1'; | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY | ||
+ | |||
+ | // GET SIZE OF FIELD IN BYTES | ||
+ | IF T(Y) = 'A'; // ALPHA DATA | ||
+ | K = ' '; | ||
+ | K1 = 1; | ||
+ | K2 = Q(Y); | ||
+ | ELSE; | ||
+ | K = '0'; | ||
+ | K1 = 1; | ||
+ | K2 = C(Y); | ||
+ | ENDIF; | ||
+ | |||
+ | X = 1; | ||
+ | |||
+ | DOW @LOOP = @LOOP; | ||
+ | |||
+ | // NXTSBA | ||
+ | X = %LOOKUP(SBA : ID : X ); | ||
+ | IF X = 0; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // IS THIS THE FIELD? CHECK THE BUFFER ADDRESS | ||
+ | X = X +1; | ||
+ | IF B(Y) <> %SUBST(IDA : X :2); | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // FOUND A MTD FOR THIS FIELD | ||
+ | |||
+ | |||
+ | // CHECK IF FIELD WAS CLEARED ONLY | ||
+ | DOW @LOOP = @LOOP; // not a loop | ||
+ | X = X + 2; | ||
+ | IF ID(X) = SBA; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // IF FIELD HAS DECIMALS BUMP X | ||
+ | IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND | ||
+ | P(Y) > 0; | ||
+ | X = X + 1; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // CHECK IF ONLY BLANKS RETURNED | ||
+ | IF %SUBST(IDA : X :K2) = *BLANKS; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // MOVE DATA TO WORK ARRAY K | ||
+ | X1 = X; | ||
+ | FOR X2 = 1 TO K2; | ||
+ | |||
+ | IF ID(X1) < ' '; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | K(X2) = ID(X1); | ||
+ | X1 = X1 + 1; | ||
+ | ENDFOR; | ||
+ | |||
+ | LEAVE; | ||
+ | ENDDO; | ||
+ | |||
+ | // * SET START POSN | ||
+ | W = S(Y); | ||
+ | |||
+ | // ALPHA | ||
+ | IF T(Y) = 'A' and V(XX) <> 'Y'; | ||
+ | FOR Z = K1 to K2; | ||
+ | D(W) = K(Z); | ||
+ | W = W + 1; | ||
+ | ENDFOR; | ||
+ | ENDIF; | ||
+ | |||
+ | IF T(Y) = 'A' and V(XX) = 'Y'; //VARYING | ||
+ | |||
+ | // the data start is in S(Y) | ||
+ | // the data is in array K | ||
+ | // get the length of the data cvt to bin and stik in pos 1 2 | ||
+ | // put the rest in pos 3 onwards | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | // NUMERIC FIELD | ||
+ | // RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS | ||
+ | IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B'); | ||
+ | NU = '0'; | ||
+ | |||
+ | Z1 = 60; | ||
+ | FOR Z = K2 DOWNTO K1; | ||
+ | |||
+ | IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$'; | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | |||
+ | IF K(Z) = ' ' ; | ||
+ | NU(Z1) = '0'; | ||
+ | ELSE; | ||
+ | NU(Z1) = K(Z); | ||
+ | ENDIF; | ||
+ | |||
+ | Z1 = Z1 -1; | ||
+ | ENDFOR; | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // SIGNED FIELDS (END POSN = OFFSET + SIZE) | ||
+ | IF T(Y) = 'S'; | ||
+ | NUSA= *BLANKS; | ||
+ | FOR VX = 1 TO 60; | ||
+ | NUSA = %TRIM(NUSA) + NU(VX); | ||
+ | ENDFOR; | ||
+ | %SUBST(DATA : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y)); | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // PACKED FIELDS | ||
+ | IF T(Y) = 'P'; | ||
+ | NUSA= *BLANKS; | ||
+ | FOR VX = 1 TO 60; | ||
+ | NUSA = %TRIM(NUSA) + NU(VX); | ||
+ | ENDFOR; | ||
+ | NUP = %DEC(NUSA : 60 : 0); | ||
+ | |||
+ | %SUBST(DATA : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y)); | ||
+ | ENDIF; | ||
+ | |||
+ | // BINARY FIELDS | ||
+ | IF T(Y) = 'B'; | ||
+ | |||
+ | NUSA= *BLANKS; | ||
+ | FOR VX = 1 TO 60; | ||
+ | NUSA = %TRIM(NUSA) + NU(VX); | ||
+ | ENDFOR; | ||
+ | NUC = NUS; | ||
+ | |||
+ | IF Q(Y) = 2 ; | ||
+ | DISBIN ( NUC : BAN2 : BAN4 : '2'); | ||
+ | %SUBST(DATA : W : 2) = BAN2; | ||
+ | ENDIF; | ||
+ | |||
+ | IF Q(Y) = 4 ; | ||
+ | DISBIN ( NUC : BAN2 : BAN4 : '4'); | ||
+ | %SUBST(DATA : W : 4) = BAN4; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | // UPDATE KEY IF NECESSARY | ||
+ | IF KY(Y) = '1'; | ||
+ | CGKY = '1'; | ||
+ | EXSR @PCKMOV; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | ENDDO; | ||
+ | ENDFOR; | ||
+ | |||
+ | |||
+ | IF CGKY = '1'; | ||
+ | KEYA = KW; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | |||
+ | /END-FREE | ||
+ | |||
+ | OINPUTK E U1 UPDATREC | ||
+ | O DA | ||
+ | O 30 DB | ||
+ | O 31 DC | ||
+ | O 32 DD | ||
+ | O 33 DE | ||
+ | O 34 DF | ||
+ | O 35 DG | ||
+ | O 36 DH | ||
+ | O 37 DI | ||
+ | O 38 DJ | ||
+ | O 39 DK | ||
+ | O 40 DL | ||
+ | O 41 DM | ||
+ | O 42 DN | ||
+ | O 43 DZ | ||
+ | O 44 DO | ||
+ | O 45 DP | ||
+ | O 46 DQ | ||
+ | O 47 DR | ||
+ | O 48 DS | ||
+ | O 49 DT | ||
+ | O 50 DU | ||
+ | O 51 DV | ||
+ | O 52 DW | ||
+ | O 53 DX | ||
+ | O 54 DY | ||
+ | O 55 D0 | ||
+ | O 56 D1 | ||
+ | O 57 D2 | ||
+ | O 58 D3 | ||
+ | O 59 D4 | ||
+ | O 60 D5 | ||
+ | O 61 D6 | ||
+ | O 62 DBA | ||
+ | O 63 DCA | ||
+ | O 64 DDA | ||
+ | O 65 DEA | ||
+ | O 66 DFA | ||
+ | O 67 DGA | ||
+ | O 68 DHA | ||
+ | O 69 DIA | ||
+ | O 70 DJA | ||
+ | O 71 DKA | ||
+ | O 72 DLA | ||
+ | O 73 DMA | ||
+ | O 74 DNA | ||
+ | O 75 DOA | ||
+ | O 76 DPA | ||
+ | O 77 DQA | ||
+ | O 78 DRA | ||
+ | O 79 DSA | ||
+ | O 80 DTA | ||
+ | O 81 DUA | ||
+ | O 82 DVA | ||
+ | O 83 DWA | ||
+ | O 84 DXA | ||
+ | O 85 DYA | ||
+ | O 86 DZA | ||
+ | O 87 D0A | ||
+ | O 88 D1A | ||
+ | O 89 D2A | ||
+ | O 90 D3A | ||
+ | O 91 D4A | ||
+ | O 92 D5A | ||
+ | O 93 D6A | ||
+ | OINPUTR E U2 UPDATREC | ||
+ | O DA | ||
+ | O 30 DB | ||
+ | O 31 DC | ||
+ | O 32 DD | ||
+ | O 33 DE | ||
+ | O 34 DF | ||
+ | O 35 DG | ||
+ | O 36 DH | ||
+ | O 37 DI | ||
+ | O 38 DJ | ||
+ | O 39 DK | ||
+ | O 40 DL | ||
+ | O 41 DM | ||
+ | O 42 DN | ||
+ | O 43 DZ | ||
+ | O 44 DO | ||
+ | O 45 DP | ||
+ | O 46 DQ | ||
+ | O 47 DR | ||
+ | O 48 DS | ||
+ | O 49 DT | ||
+ | O 50 DU | ||
+ | O 51 DV | ||
+ | O 52 DW | ||
+ | O 53 DX | ||
+ | O 54 DY | ||
+ | O 55 D0 | ||
+ | O 56 D1 | ||
+ | O 57 D2 | ||
+ | O 58 D3 | ||
+ | O 59 D4 | ||
+ | O 60 D5 | ||
+ | O 61 D6 | ||
+ | O 62 DBA | ||
+ | O 63 DCA | ||
+ | O 64 DDA | ||
+ | O 65 DEA | ||
+ | O 66 DFA | ||
+ | O 67 DGA | ||
+ | O 68 DHA | ||
+ | O 69 DIA | ||
+ | O 70 DJA | ||
+ | O 71 DKA | ||
+ | O 72 DLA | ||
+ | O 73 DMA | ||
+ | O 74 DNA | ||
+ | O 75 DOA | ||
+ | O 76 DPA | ||
+ | O 77 DQA | ||
+ | O 78 DRA | ||
+ | O 79 DSA | ||
+ | O 80 DTA | ||
+ | O 81 DUA | ||
+ | O 82 DVA | ||
+ | O 83 DWA | ||
+ | O 84 DXA | ||
+ | O 85 DYA | ||
+ | O 86 DZA | ||
+ | O 87 D0A | ||
+ | O 88 D1A | ||
+ | O 89 D2A | ||
+ | O 90 D3A | ||
+ | O 91 D4A | ||
+ | O 92 D5A | ||
+ | O 93 D6A | ||
+ | |||
+ | OINPUTK EADD U1 ADDREC | ||
+ | O DA | ||
+ | O 30 DB | ||
+ | O 31 DC | ||
+ | O 32 DD | ||
+ | O 33 DE | ||
+ | O 34 DF | ||
+ | O 35 DG | ||
+ | O 36 DH | ||
+ | O 37 DI | ||
+ | O 38 DJ | ||
+ | O 39 DK | ||
+ | O 40 DL | ||
+ | O 41 DM | ||
+ | O 42 DN | ||
+ | O 43 DZ | ||
+ | O 44 DO | ||
+ | O 45 DP | ||
+ | O 46 DQ | ||
+ | O 47 DR | ||
+ | O 48 DS | ||
+ | O 49 DT | ||
+ | O 50 DU | ||
+ | O 51 DV | ||
+ | O 52 DW | ||
+ | O 53 DX | ||
+ | O 54 DY | ||
+ | O 55 D0 | ||
+ | O 56 D1 | ||
+ | O 57 D2 | ||
+ | O 58 D3 | ||
+ | O 59 D4 | ||
+ | O 60 D5 | ||
+ | O 61 D6 | ||
+ | O 62 DBA | ||
+ | O 63 DCA | ||
+ | O 64 DDA | ||
+ | O 65 DEA | ||
+ | O 66 DFA | ||
+ | O 67 DGA | ||
+ | O 68 DHA | ||
+ | O 69 DIA | ||
+ | O 70 DJA | ||
+ | O 71 DKA | ||
+ | O 72 DLA | ||
+ | O 73 DMA | ||
+ | O 74 DNA | ||
+ | O 75 DOA | ||
+ | O 76 DPA | ||
+ | O 77 DQA | ||
+ | O 78 DRA | ||
+ | O 79 DSA | ||
+ | O 80 DTA | ||
+ | O 81 DUA | ||
+ | O 82 DVA | ||
+ | O 83 DWA | ||
+ | O 84 DXA | ||
+ | O 85 DYA | ||
+ | O 86 DZA | ||
+ | O 87 D0A | ||
+ | O 88 D1A | ||
+ | O 89 D2A | ||
+ | O 90 D3A | ||
+ | O 91 D4A | ||
+ | O 92 D5A | ||
+ | O 93 D6A | ||
+ | OINPUTR EADD U2 ADDREC | ||
+ | O DA | ||
+ | O 30 DB | ||
+ | O 31 DC | ||
+ | O 32 DD | ||
+ | O 33 DE | ||
+ | O 34 DF | ||
+ | O 35 DG | ||
+ | O 36 DH | ||
+ | O 37 DI | ||
+ | O 38 DJ | ||
+ | O 39 DK | ||
+ | O 40 DL | ||
+ | O 41 DM | ||
+ | O 42 DN | ||
+ | O 43 DZ | ||
+ | O 44 DO | ||
+ | O 45 DP | ||
+ | O 46 DQ | ||
+ | O 47 DR | ||
+ | O 48 DS | ||
+ | O 49 DT | ||
+ | O 50 DU | ||
+ | O 51 DV | ||
+ | O 52 DW | ||
+ | O 53 DX | ||
+ | O 54 DY | ||
+ | O 55 D0 | ||
+ | O 56 D1 | ||
+ | O 57 D2 | ||
+ | O 58 D3 | ||
+ | O 59 D4 | ||
+ | O 60 D5 | ||
+ | O 61 D6 | ||
+ | O 62 DBA | ||
+ | O 63 DCA | ||
+ | O 64 DDA | ||
+ | O 65 DEA | ||
+ | O 66 DFA | ||
+ | O 67 DGA | ||
+ | O 68 DHA | ||
+ | O 69 DIA | ||
+ | O 70 DJA | ||
+ | O 71 DKA | ||
+ | O 72 DLA | ||
+ | O 73 DMA | ||
+ | O 74 DNA | ||
+ | O 75 DOA | ||
+ | O 76 DPA | ||
+ | O 77 DQA | ||
+ | O 78 DRA | ||
+ | O 79 DSA | ||
+ | O 80 DTA | ||
+ | O 81 DUA | ||
+ | O 82 DVA | ||
+ | O 83 DWA | ||
+ | O 84 DXA | ||
+ | O 85 DYA | ||
+ | O 86 DZA | ||
+ | O 87 D0A | ||
+ | O 88 D1A | ||
+ | O 89 D2A | ||
+ | O 90 D3A | ||
+ | O 91 D4A | ||
+ | O 92 D5A | ||
+ | O 93 D6A | ||
+ | |||
+ | OINPUTK EDEL U1 DELREC | ||
+ | OINPUTR EDEL U2 DELREC | ||
+ | |||
+ | |||
+ | ODISPF E DATAO | ||
+ | O K3 'PUT' | ||
+ | O OUTLEN 2 | ||
+ | O INLEN | ||
+ | O FNC | ||
+ | O A | ||
+ | |||
+ | O E DATAI | ||
+ | O K3 'GET' | ||
+ | O OUTLEN 2 | ||
+ | O INLEN | ||
+ | O FNC | ||
+ | O A | ||
+ | ** | ||
+ | 0000 INVALID COMMAND KEY | ||
+ | 0001 - A FIELD IS TOO LONG | ||
+ | 0002 - TOO MANY FIELDS | ||
+ | 0003 - ALPHAS IN PACKED KEY | ||
+ | 0004 - MISSING ' IN PACKED KEY | ||
+ | 0005 - MISSING DATA IN PCKD KEY | ||
+ | 0006 - RECORD NOT FOUND | ||
+ | PRESS RESET TO CONTINUE | ||
+ | ** | ||
+ | F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld | ||
+ | F1-HEX F2-Return F3-Exit F6-Update F9-Add F11-Del F19-Prev_fld F20-More_fld | ||
+ | ** | ||
+ | 0123456789ABCDEF | ||
+ | |||
+ | |||
</pre> | </pre> | ||
+ | [[#top]] | ||
+ | |||
+ | ===DUSP2 RPG=== | ||
+ | |||
+ | <pre> | ||
+ | H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ | ||
+ | H OPTION(*NODEBUGIO) | ||
+ | H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP2 ) | ||
+ | F* | ||
+ | F* LIMITED TO MAXIMUM FILE LENGTH OF 6080 | ||
+ | F* REQUIRES FILE QTEMP/FFD TO COMPILE | ||
+ | F* use cmd DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) | ||
+ | |||
+ | FFFD IF E DISK | ||
+ | FDISPF CF F 803 WORKSTN | ||
+ | F* | ||
+ | F INFDS(INFDS) | ||
+ | FINPUTK UF A F32766 800AIDISK KEYLOC(1) | ||
+ | F EXTIND(*INU1) | ||
+ | F INFDS(INFDK) | ||
+ | FINPUTR UF A F32766 DISK EXTIND(*INU2) | ||
+ | F INFDS(INFDR) | ||
+ | |||
+ | D DISBIN PR extpgm('DISBIN') | ||
+ | D NUM 15P 0 | ||
+ | D BAN2 2 | ||
+ | D BAN4 4 | ||
+ | D BINTYP 1 CONST | ||
+ | |||
+ | * | ||
+ | D A S 255 WORK RU | ||
+ | D RU S 255 varying | ||
+ | D RW S 1 ROW 1 byte binary | ||
+ | D CL S 1 COL 1 byte binary | ||
+ | D FNC S 1 | ||
+ | D OUTLEN S 2 | ||
+ | D INLEN S 2 | ||
+ | D IPL S 5 0 | ||
+ | D ROW S 3 0 | ||
+ | D XROW S 3 0 | ||
+ | D COL S 3 0 | ||
+ | D KEYSOK S 1 | ||
+ | D LENDSC S 3 0 | ||
+ | D LENWRK S 5 0 | ||
+ | D STRX S 5 0 | ||
+ | D ENDX S 5 0 | ||
+ | D VX S 5 0 | ||
+ | D X S 5 0 | ||
+ | D X1 S 5 0 | ||
+ | D X2 S 5 0 | ||
+ | D XX S 5 0 | ||
+ | D XP S 5 0 | ||
+ | D MX S 5 0 | ||
+ | D ONCE S 1 | ||
+ | D RBA S 2 | ||
+ | D LF S 5 0 | ||
+ | D ST S 5 0 | ||
+ | D Y S 5 0 | ||
+ | D Z S 5 0 | ||
+ | D OFF S 5 0 | ||
+ | D CGKY S 1 | ||
+ | D UPDDONE S 1 | ||
+ | D SUPZ S 1 | ||
+ | D NUMFLD S 5 0 | ||
+ | D WX S 5 0 | ||
+ | D NUMKEY S 5 0 | ||
+ | D NUMFKY S 5 0 | ||
+ | D SCRST S 10 | ||
+ | D SCRSTN S 1 | ||
+ | D KEYA S 800 | ||
+ | D RRNA S 11 0 | ||
+ | D RRN S 11 0 | ||
+ | D REHEAD S 1 | ||
+ | D NEWRU S 1 | ||
+ | D WRTRRN S 1 | ||
+ | D LVX S 5 0 | ||
+ | D LVL S 5 0 | ||
+ | D K1 S 5 0 | ||
+ | D K2 S 5 0 | ||
+ | D Z1 S 5 0 | ||
+ | D W S 5 0 | ||
+ | D WK2 S 2 | ||
+ | D MSSG S 32 | ||
+ | * | ||
+ | D BASE S 5 0 | ||
+ | D INZ S 1 | ||
+ | |||
+ | D FILE S 10 | ||
+ | D LIB S 10 | ||
+ | D MBR S 10 | ||
+ | D RCDL S 5 0 | ||
+ | D ACCTP S 1 | ||
+ | D RLEN S 5 0 | ||
+ | D RLENTH S 5 | ||
+ | D LENF S 5 0 | ||
+ | |||
+ | |||
+ | D DS | ||
+ | D TEXT500 500 | ||
+ | D LVW 10 DIM(50) overlay(TEXT500:1) | ||
+ | |||
+ | D TEXT800 S 800 | ||
+ | D KW S 800 | ||
+ | |||
+ | D DS | ||
+ | D WRK11 1 11 | ||
+ | D NUM11 1 11S 0 | ||
+ | |||
+ | D DS | ||
+ | D NUSA 1 60 | ||
+ | D NUS 1 60S 0 | ||
+ | D DS | ||
+ | D NUPA 1 60 | ||
+ | D NUP 29 60P 0 | ||
+ | |||
+ | D NUC S 15P 0 | ||
+ | D BAN2 S 2 | ||
+ | DCL D BAN4 S 4 | ||
+ | |||
+ | |||
+ | D WRU S 61 | ||
+ | D WRX S 64 | ||
+ | D WRXWRD C '0 - | ||
+ | D -' | ||
+ | D WRSWRD C '0 - | ||
+ | D -' | ||
+ | D WRV S 60 varying | ||
+ | |||
+ | D FLT14 S 14 | ||
+ | D FLT23 S 23 | ||
+ | |||
+ | * SET FILE SIZE INCREMENTS (64 OF THEM) | ||
+ | D SZ S 5 0 DIM(64) | ||
+ | D S S 5 0 DIM(9000) START OF FLD | ||
+ | D E S 5 0 DIM(9000) END OF FLD | ||
+ | D Q S 5 0 DIM(9000) BYTES IN FIELD | ||
+ | D L S 5 0 DIM(9000) LENGTH OF FLD | ||
+ | D C S 3 0 DIM(9000) DEC DIGITS | ||
+ | D P S 3 0 DIM(9000) DEC PRECISION | ||
+ | D B S 2 DIM(9000) ASCEND BUFFER ADD | ||
+ | D I S 2 DIM(9000) FLD FMT | ||
+ | D N S 10 DIM(9000) FLD NAME | ||
+ | D T S 1 DIM(9000) FLD TYPE | ||
+ | D V S 1 DIM(9000) VARYING | ||
+ | D KY S 1 DIM(9000) KEYED | ||
+ | D KE S 10 DIM(128) KEY FLDS | ||
+ | D R S 3 0 DIM(9000) KEY FLD START | ||
+ | D K S 1 DIM(800) KEY | ||
+ | D NA S 1 DIM(10) NAME WORK | ||
+ | D NU S 1 DIM(60) NUM. WORK | ||
+ | D LV S 10 DIM(50) SCREEN LEVELS | ||
+ | D MSG S 32 DIM(8) CTDATA PERRCD(1) MESSAGES | ||
+ | D CNS S 79 DIM(2) CTDATA PERRCD(1) | ||
+ | D CRS S 1 DIM(16) CTDATA PERRCD(16) | ||
+ | D DS | ||
+ | D DATA 1 6080 | ||
+ | D D 1 6080 | ||
+ | D DIM(6080) INCOMING DATA | ||
+ | D DA 1 4048 | ||
+ | D DIM(4048) | ||
+ | D DB 4049 4064 | ||
+ | D DC 4065 4096 | ||
+ | D DD 4097 4128 | ||
+ | D DE 4129 4160 | ||
+ | D DF 4161 4192 | ||
+ | D DG 4193 4224 | ||
+ | D DH 4225 4256 | ||
+ | D DI 4257 4288 | ||
+ | D DJ 4289 4320 | ||
+ | D DK 4321 4352 | ||
+ | D DL 4353 4384 | ||
+ | D DM 4385 4416 | ||
+ | D DN 4417 4448 | ||
+ | D DZ 4449 4480 | ||
+ | D DO 4481 4512 | ||
+ | D DP 4513 4544 | ||
+ | D DQ 4545 4576 | ||
+ | D DR 4577 4608 | ||
+ | D DS 4609 4640 | ||
+ | D DT 4641 4672 | ||
+ | D DU 4673 4704 | ||
+ | D DV 4705 4736 | ||
+ | D DW 4737 4768 | ||
+ | D DX 4769 4800 | ||
+ | D DY 4801 4832 | ||
+ | D D0 4833 4864 | ||
+ | D D1 4865 4896 | ||
+ | D D2 4897 4928 | ||
+ | D D3 4929 4960 | ||
+ | D D4 4961 4992 | ||
+ | D D5 4993 5024 | ||
+ | D D6 5025 5056 | ||
+ | D DBA 5057 5088 | ||
+ | D DCA 5089 5120 | ||
+ | D DDA 5121 5152 | ||
+ | D DEA 5153 5184 | ||
+ | D DFA 5185 5216 | ||
+ | D DGA 5217 5248 | ||
+ | D DHA 5249 5280 | ||
+ | D DIA 5281 5312 | ||
+ | D DJA 5313 5344 | ||
+ | D DKA 5345 5376 | ||
+ | D DLA 5377 5408 | ||
+ | D DMA 5409 5440 | ||
+ | D DNA 5441 5472 | ||
+ | D DOA 5473 5504 | ||
+ | D DPA 5505 5536 | ||
+ | D DQA 5537 5568 | ||
+ | D DRA 5569 5600 | ||
+ | D DSA 5601 5632 | ||
+ | D DTA 5633 5664 | ||
+ | D DUA 5665 5696 | ||
+ | D DVA 5697 5728 | ||
+ | D DWA 5729 5760 | ||
+ | D DXA 5761 5792 | ||
+ | D DYA 5793 5824 | ||
+ | D DZA 5825 5856 | ||
+ | D D0A 5857 5888 | ||
+ | D D1A 5889 5920 | ||
+ | D D2A 5921 5952 | ||
+ | D D3A 5953 5984 | ||
+ | D D4A 5985 6016 | ||
+ | D D5A 6017 6048 | ||
+ | D D6A 6049 6080 | ||
+ | D DS | ||
+ | D ID 1 800 | ||
+ | D DIM(800) INCOMING DATA | ||
+ | D IDA 1 800 | ||
+ | D ID0 1 80 | ||
+ | D ID1 81 160 | ||
+ | D ID2 161 240 | ||
+ | D ID3 241 320 | ||
+ | D ID4 321 400 | ||
+ | D ID5 401 480 | ||
+ | D ID6 481 560 | ||
+ | D ID7 561 640 | ||
+ | D ID8 641 720 | ||
+ | D ID9 721 800 | ||
+ | D DS | ||
+ | D BIN 1 2B 0 | ||
+ | D HX1 2 2 | ||
+ | D HX2 1 2 | ||
+ | D DS | ||
+ | D PCK 1 1P 0 | ||
+ | D PCK1 1 1 | ||
+ | D DS | ||
+ | D SGN 1 1S 0 | ||
+ | D SGN1 1 1 | ||
+ | |||
+ | D DS | ||
+ | D BIN4 1 4B 0 | ||
+ | D BY4 1 4 | ||
+ | |||
+ | D DS | ||
+ | D BIN2 1 2B 0 | ||
+ | D BY2 1 2 | ||
+ | |||
+ | D DS | ||
+ | D FLT4 1 4F | ||
+ | D FL4 1 4 | ||
+ | |||
+ | D DS | ||
+ | D FLT8 1 8F | ||
+ | D FL8 1 8 | ||
+ | |||
+ | D INFDK DS | ||
+ | D F1 83 92 | ||
+ | D L1 93 102 | ||
+ | D M1 129 138 | ||
+ | D R1 125 126B 0 | ||
+ | D A1 160 160 | ||
+ | D LOP1 260 260 | ||
+ | D KEY_LEN 393 394I 0 Key length | ||
+ | D RN1 397 400B 0 | ||
+ | D LKY 401 1200 | ||
+ | D INFDR DS | ||
+ | D F2 83 92 | ||
+ | D L2 93 102 | ||
+ | D M2 129 138 | ||
+ | D R2 125 126B 0 | ||
+ | D A2 160 160 | ||
+ | D LOP2 260 260 | ||
+ | D RN2 397 400B 0 | ||
+ | D* | ||
+ | D INFDS DS | ||
+ | D CURLOC 370 371 | ||
+ | D DS | ||
+ | D KEYLN 1 4S 0 | ||
+ | D KEYLNA 1 4 | ||
+ | |||
+ | DDUSP2 PR | ||
+ | D 1 | ||
+ | D 1 | ||
+ | D 4 | ||
+ | D 1 | ||
+ | D 500 | ||
+ | D 5 | ||
+ | D 800 | ||
+ | DDUSP2 PI | ||
+ | D ALL 1 | ||
+ | D RTN 1 | ||
+ | D KEYLNG 4 | ||
+ | D UPDF 1 | ||
+ | D SCNLV 500 | ||
+ | D SCNLVL 5 | ||
+ | D SCNKEY 800 | ||
+ | |||
+ | |||
+ | D @LOOP C '1' | ||
+ | D @FALSE C '0' | ||
+ | D @TRUE C '1' | ||
+ | |||
+ | D SND C X'71' SEND TO DISP | ||
+ | D SNR C X'73' SND/RCV | ||
+ | D RED C X'42' READ | ||
+ | D RDM C X'52' READ MTD | ||
+ | D ESC C X'04' ESCAPE | ||
+ | D CLR C X'40' CLEAR UNIT | ||
+ | D CC1 C X'00' CNTRL CHAR | ||
+ | D CC2 C X'08' CNTRL CHAR | ||
+ | D SBA C X'11' SET BUFF ADR | ||
+ | D IC C X'13' INSERT CURS | ||
+ | D WTD C X'11' WRITE TO DSP | ||
+ | D WER C X'21' WRITE ERROR | ||
+ | D SF C X'1D' START FLD | ||
+ | D ATC C X'20' ATTR CHAR | ||
+ | D ATN C X'24' ATTR NUM | ||
+ | D X00 C X'00' | ||
+ | D X01 C X'01' | ||
+ | D X02 C X'02' | ||
+ | D X03 C X'03' | ||
+ | D X0D C X'0D' | ||
+ | D X0F C X'0F' | ||
+ | D X000 C X'0000' | ||
+ | D X1F C X'1F' | ||
+ | D X20 C X'20' SCRN ATT NORMAL | ||
+ | D X22 C X'22' SCRN ATTR HI | ||
+ | D X25 C X'25' | ||
+ | D X26 C X'26' | ||
+ | D X31 C X'31' CMD 1 KEY | ||
+ | D X32 C X'32' CMD 2 KEY | ||
+ | D X33 C X'33' CMD 3 KEY | ||
+ | D X36 C X'36' CMD 6 KEY | ||
+ | D X37 C X'37' CMD 7 KEY | ||
+ | D X38 C X'38' CMD 8 KEY | ||
+ | D X39 C X'39' CMD 9 KEY | ||
+ | D X3B C X'3B' CMD11 KEY | ||
+ | D XB7 C X'B7' CMD19 KEY | ||
+ | D XB8 C X'B8' CMD20 KEY | ||
+ | D X40 C X'40' | ||
+ | D X43 C X'43' | ||
+ | D X47 C X'47' | ||
+ | D X60 C X'60' | ||
+ | D X67 C X'67' | ||
+ | D X9F C X'9F' | ||
+ | D XF0 C X'F0' | ||
+ | D XD0 C X'D0' | ||
+ | D X4000 C X'4000' | ||
+ | D X4800 C X'4800' FF ALPHA | ||
+ | D X4F06 C X'4F06' FF NUMERIC | ||
+ | D X6000 C X'6000' FF ALPHA | ||
+ | D X6706 C X'6706' FF NUMERIC | ||
+ | D CLRWTD C X'044004112000' INCLUDES ESC CHARS | ||
+ | D RDDSP C X'0411200804524000' READ FROM DISPLAY | ||
+ | D FFA1 S 1 INZ(X'40') F.FMT 1 ALPH 60 BYP | ||
+ | D FFA2 S 1 INZ(X'00') F.FMT 2 ALPH | ||
+ | D FFN1 S 1 INZ(X'47') F.FMT 1 NUM 67 BYP | ||
+ | D FFN2 S 1 INZ(X'06') F.FMT 2 NUM | ||
+ | I*. | ||
+ | |||
+ | 0038 IINPUTK NS 01 | ||
+ | 0039 I 1 4048 DA | ||
+ | 0040 I 4049 4064 DB 30 | ||
+ | 0041 I 4065 4096 DC 31 | ||
+ | 0042 I 4097 4128 DD 32 | ||
+ | 0043 I 4129 4160 DE 33 | ||
+ | 0044 I 4161 4192 DF 34 | ||
+ | 0045 I 4193 4224 DG 35 | ||
+ | 0046 I 4225 4256 DH 36 | ||
+ | 0047 I 4257 4288 DI 37 | ||
+ | 0048 I 4289 4320 DJ 38 | ||
+ | 0049 I 4321 4352 DK 39 | ||
+ | 0050 I 4353 4384 DL 40 | ||
+ | 0051 I 4385 4416 DM 41 | ||
+ | 0052 I 4417 4448 DN 42 | ||
+ | 0053 I 4449 4480 DZ 43 | ||
+ | 0054 I 4481 4512 DO 44 | ||
+ | 0055 I 4513 4544 DP 45 | ||
+ | 0056 I 4545 4576 DQ 46 | ||
+ | 0057 I 4577 4608 DR 47 | ||
+ | 0058 I 4609 4640 DS 48 | ||
+ | 0059 I 4641 4672 DT 49 | ||
+ | 0060 I 4673 4704 DU 50 | ||
+ | 0061 I 4705 4736 DV 51 | ||
+ | 0062 I 4737 4768 DW 52 | ||
+ | 0063 I 4769 4800 DX 53 | ||
+ | 0064 I 4801 4832 DY 54 | ||
+ | 0065 I 4833 4864 D0 55 | ||
+ | 0066 I 4865 4896 D1 56 | ||
+ | 0067 I 4897 4928 D2 57 | ||
+ | 0068 I 4929 4960 D3 58 | ||
+ | 0069 I 4961 4992 D4 59 | ||
+ | 0070 I 4993 5024 D5 60 | ||
+ | 0071 I 5025 5056 D6 61 | ||
+ | 0072 I 5057 5088 DBA 62 | ||
+ | 0073 I 5089 5120 DCA 63 | ||
+ | 0074 I 5121 5152 DDA 64 | ||
+ | 0075 I 5153 5184 DEA 65 | ||
+ | 0076 I 5185 5216 DFA 66 | ||
+ | 0077 I 5217 5248 DGA 67 | ||
+ | 0078 I 5249 5280 DHA 68 | ||
+ | 0079 I 5281 5312 DIA 69 | ||
+ | 0080 I 5313 5344 DJA 70 | ||
+ | 0081 I 5345 5376 DKA 71 | ||
+ | 0082 I 5377 5408 DLA 72 | ||
+ | 0083 I 5409 5440 DMA 73 | ||
+ | 0084 I 5441 5472 DNA 74 | ||
+ | 0085 I 5473 5504 DOA 75 | ||
+ | 0086 I 5505 5536 DPA 76 | ||
+ | 0087 I 5537 5568 DQA 77 | ||
+ | 0088 I 5569 5600 DRA 78 | ||
+ | 0089 I 5601 5632 DSA 79 | ||
+ | 0090 I 5633 5664 DTA 80 | ||
+ | 0091 I 5665 5696 DUA 81 | ||
+ | 0092 I 5697 5728 DVA 82 | ||
+ | 0093 I 5729 5760 DWA 83 | ||
+ | 0094 I 5761 5792 DXA 84 | ||
+ | 0095 I 5793 5824 DYA 85 | ||
+ | 0096 I 5825 5856 DZA 86 | ||
+ | 0097 I 5857 5888 D0A 87 | ||
+ | 0098 I 5889 5920 D1A 88 | ||
+ | 0099 I 5921 5952 D2A 89 | ||
+ | 0100 I 5953 5984 D3A 90 | ||
+ | 0101 I 5985 6016 D4A 91 | ||
+ | 0102 I 6017 6048 D5A 92 | ||
+ | 0103 I 6049 6080 D6A 93 | ||
+ | 0104 IINPUTR NS 01 | ||
+ | 0105 I 1 4048 DA | ||
+ | 0106 I 4049 4064 DB 30 | ||
+ | 0107 I 4065 4096 DC 31 | ||
+ | 0108 I 4097 4128 DD 32 | ||
+ | 0109 I 4129 4160 DE 33 | ||
+ | 0110 I 4161 4192 DF 34 | ||
+ | 0111 I 4193 4224 DG 35 | ||
+ | 0112 I 4225 4256 DH 36 | ||
+ | 0113 I 4257 4288 DI 37 | ||
+ | 0114 I 4289 4320 DJ 38 | ||
+ | 0115 I 4321 4352 DK 39 | ||
+ | 0116 I 4353 4384 DL 40 | ||
+ | 0117 I 4385 4416 DM 41 | ||
+ | 0118 I 4417 4448 DN 42 | ||
+ | 0119 I 4449 4480 DZ 43 | ||
+ | 0120 I 4481 4512 DO 44 | ||
+ | 0121 I 4513 4544 DP 45 | ||
+ | 0122 I 4545 4576 DQ 46 | ||
+ | 0123 I 4577 4608 DR 47 | ||
+ | 0124 I 4609 4640 DS 48 | ||
+ | 0125 I 4641 4672 DT 49 | ||
+ | 0126 I 4673 4704 DU 50 | ||
+ | 0127 I 4705 4736 DV 51 | ||
+ | 0128 I 4737 4768 DW 52 | ||
+ | 0129 I 4769 4800 DX 53 | ||
+ | 0130 I 4801 4832 DY 54 | ||
+ | 0131 I 4833 4864 D0 55 | ||
+ | 0132 I 4865 4896 D1 56 | ||
+ | 0133 I 4897 4928 D2 57 | ||
+ | 0134 I 4929 4960 D3 58 | ||
+ | 0135 I 4961 4992 D4 59 | ||
+ | 0136 I 4993 5024 D5 60 | ||
+ | 0137 I 5025 5056 D6 61 | ||
+ | 0138 I 5057 5088 DBA 62 | ||
+ | 0139 I 5089 5120 DCA 63 | ||
+ | 0140 I 5121 5152 DDA 64 | ||
+ | 0141 I 5153 5184 DEA 65 | ||
+ | 0142 I 5185 5216 DFA 66 | ||
+ | 0143 I 5217 5248 DGA 67 | ||
+ | 0144 I 5249 5280 DHA 68 | ||
+ | 0145 I 5281 5312 DIA 69 | ||
+ | 0146 I 5313 5344 DJA 70 | ||
+ | 0147 I 5345 5376 DKA 71 | ||
+ | 0148 I 5377 5408 DLA 72 | ||
+ | 0149 I 5409 5440 DMA 73 | ||
+ | 0150 I 5441 5472 DNA 74 | ||
+ | 0151 I 5473 5504 DOA 75 | ||
+ | 0152 I 5505 5536 DPA 76 | ||
+ | 0153 I 5537 5568 DQA 77 | ||
+ | 0154 I 5569 5600 DRA 78 | ||
+ | 0155 I 5601 5632 DSA 79 | ||
+ | 0156 I 5633 5664 DTA 80 | ||
+ | 0157 I 5665 5696 DUA 81 | ||
+ | 0158 I 5697 5728 DVA 82 | ||
+ | 0159 I 5729 5760 DWA 83 | ||
+ | 0160 I 5761 5792 DXA 84 | ||
+ | 0161 I 5793 5824 DYA 85 | ||
+ | 0162 I 5825 5856 DZA 86 | ||
+ | 0163 I 5857 5888 D0A 87 | ||
+ | 0164 I 5889 5920 D1A 88 | ||
+ | 0165 I 5921 5952 D2A 89 | ||
+ | 0166 I 5953 5984 D3A 90 | ||
+ | 0167 I 5985 6016 D4A 91 | ||
+ | 0168 I 6017 6048 D5A 92 | ||
+ | 0169 I 6049 6080 D6A 93 | ||
+ | IDISPF NS 02 | ||
+ | I 3 3 AID | ||
+ | I 4 83 ID0 | ||
+ | I 84 163 ID1 20 | ||
+ | I 164 243 ID2 21 | ||
+ | I 244 323 ID3 22 | ||
+ | I 324 403 ID4 23 | ||
+ | I 404 483 ID5 24 | ||
+ | I 484 563 ID6 25 | ||
+ | I 564 643 ID7 26 | ||
+ | I 644 723 ID8 27 | ||
+ | I 724 803 ID9 28 | ||
+ | |||
+ | |||
+ | /FREE | ||
+ | BASE = 4048; | ||
+ | |||
+ | IF ONCE = ' '; | ||
+ | EXSR @INITZ ; | ||
+ | ENDIF; | ||
+ | |||
+ | // START TAG | ||
+ | DOW @LOOP = @LOOP; | ||
+ | |||
+ | IF RTN = '3'; | ||
+ | |||
+ | IF *INU1; | ||
+ | KEYA = SCNKEY; | ||
+ | ENDIF; | ||
+ | IF *INU2; | ||
+ | RRNA = %DEC(%SUBST(SCNKEY:1:11):11:0); | ||
+ | ENDIF; | ||
+ | RTN = '0'; | ||
+ | AID = '1'; | ||
+ | ELSE; | ||
+ | RTN = '0'; | ||
+ | READ(E) DISPF; | ||
+ | ENDIF; | ||
+ | |||
+ | // CF3 EXIT | ||
+ | IF AID = X33; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // CF2 RETURN | ||
+ | IF AID = X32; | ||
+ | RTN = '1'; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // CF1 HEX A FIELD | ||
+ | IF AID = X31; | ||
+ | Y = %LOOKUPLE( CURLOC : B ); | ||
+ | IF Y > 0; | ||
+ | IF KY(Y) <= '1'; | ||
+ | EXSR @HXDSP; | ||
+ | REHEAD = '1'; | ||
+ | EXSR @PUTHED; | ||
+ | REHEAD = ' '; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | // CF20 MORE FIELDS | ||
+ | IF AID = XB8; | ||
+ | |||
+ | LVX = LVL + 1; | ||
+ | IF LV(LVX) <> *BLANK; | ||
+ | LVL = LVL +1 ; | ||
+ | |||
+ | LVW = LV; | ||
+ | SCNLV = TEXT500; | ||
+ | SCNLVL = %EDITC(LVL :'X'); | ||
+ | |||
+ | SCNKEY = *BLANKS; | ||
+ | IF *INU1; | ||
+ | SCNKEY = KEYA; | ||
+ | ENDIF; | ||
+ | IF *INU2; | ||
+ | SCNKEY = %EDITC(RRNA:'X'); | ||
+ | ENDIF; | ||
+ | |||
+ | RTN = '3'; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | // CF19 PREVIOUS FIELDS | ||
+ | IF AID = XB7; | ||
+ | |||
+ | LVX = LVL - 1; | ||
+ | IF LVX >= 0 ; | ||
+ | LVL = LVL - 1 ; | ||
+ | |||
+ | LVW = LV; | ||
+ | SCNLV = TEXT500; | ||
+ | SCNLVL = %EDITC(LVL :'X'); | ||
+ | |||
+ | SCNKEY = *BLANKS; | ||
+ | IF *INU1; | ||
+ | SCNKEY = KEYA; | ||
+ | ENDIF; | ||
+ | IF *INU2; | ||
+ | SCNKEY = %EDITC(RRNA:'X'); | ||
+ | ENDIF; | ||
+ | |||
+ | RTN = '3'; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | // 1 ENTER 4 ROLL DN 5 ROLL UP | ||
+ | // F6 = X36 F9 = X39 F11 = X3B | ||
+ | IF AID = '1'or AID = '4' or AID = '5' or | ||
+ | AID = X36 or AID = X39 or AID = X3B; | ||
+ | ELSE; | ||
+ | MX = 1; // INVALID KEY | ||
+ | EXSR @ERROR; | ||
+ | ENDIF; | ||
+ | |||
+ | // UPDATE MODE | ||
+ | IF UPDF = 'Y'; | ||
+ | UPDDONE = @FALSE; | ||
+ | // F6 | ||
+ | IF *INU1 AND AID = X36 AND | ||
+ | (LOP1 = X01 OR LOP1 = X03); | ||
+ | EXSR @UPD; | ||
+ | EXCEPT UPDATREC; | ||
+ | UPDDONE = @TRUE; | ||
+ | ENDIF; | ||
+ | |||
+ | IF *INU2 AND AID = X36 AND | ||
+ | (LOP2 = X01 OR LOP2 = X02); | ||
+ | EXSR @UPD; | ||
+ | EXCEPT UPDATREC; | ||
+ | UPDDONE = @TRUE; | ||
+ | ENDIF; | ||
+ | |||
+ | // F9 | ||
+ | IF AID = X39; | ||
+ | EXSR @UPD; | ||
+ | EXCEPT ADDREC; | ||
+ | UPDDONE = @TRUE; | ||
+ | ENDIF; | ||
+ | |||
+ | // F11 | ||
+ | IF *INU1 AND AID = X3B AND | ||
+ | (LOP1 = X01 OR LOP1 = X03); | ||
+ | EXCEPT DELREC; | ||
+ | UPDDONE = @TRUE; | ||
+ | ENDIF; | ||
+ | |||
+ | IF *INU2 AND AID = X3B AND | ||
+ | (LOP2 = X01 OR LOP2 = X02); | ||
+ | EXCEPT DELREC; | ||
+ | UPDDONE = @TRUE; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | IF RTN = '3' OR UPDDONE = @TRUE; | ||
+ | ELSE; | ||
+ | EXSR @PCKD; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // CONT1 GET A RECORD, KEY FROM DATA | ||
+ | EXSR @SETIN; | ||
+ | EXSR @GETF ; | ||
+ | EXSR @PUTF ; | ||
+ | EXSR @KEYIN; | ||
+ | |||
+ | ENDDO ; | ||
+ | |||
+ | *INLR = *ON; | ||
+ | |||
+ | // @@@@@@@ @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @INITZ; | ||
+ | ONCE = '1'; | ||
+ | KEYLNA = KEYLNG ; | ||
+ | EXSR @INIT ; | ||
+ | EXSR @GETFLD ; | ||
+ | EXSR @GETADD ; | ||
+ | EXSR @PUTHED ; | ||
+ | EXSR @KEYIN ; | ||
+ | INZ = '1'; | ||
+ | EXSR @PCKD ; | ||
+ | INZ = ' '; | ||
+ | ENDSR; | ||
+ | |||
+ | // @@@@@@@ @PCKD @@@@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | |||
+ | BEGSR @PCKD ; | ||
+ | |||
+ | // CONVERT KEY DATA | ||
+ | IF *INU1 ; | ||
+ | EXSR @CVTKEY; | ||
+ | ENDIF; | ||
+ | IF *INU2 ; | ||
+ | EXSR @CVTRRN; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | // @@@@@@@ @CVTKEY @@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | |||
+ | BEGSR @CVTKEY; | ||
+ | |||
+ | // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING | ||
+ | |||
+ | // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE | ||
+ | // THE MODIFIED DATA INTO THE COMPOSITE KEY | ||
+ | |||
+ | K1 = 0; | ||
+ | K2 = 0; | ||
+ | W = 1; | ||
+ | |||
+ | FOR Y = 1 TO NUMKEY ; | ||
+ | |||
+ | // MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS) | ||
+ | |||
+ | // GET SIZE OF FIELD IN BYTES | ||
+ | IF T(Y) = 'A'; // ALPHA DATA | ||
+ | K = ' '; | ||
+ | K1 = 1; | ||
+ | K2 = Q(Y); | ||
+ | ELSE; | ||
+ | K = '0'; | ||
+ | K1 = 1; | ||
+ | K2 = C(Y); | ||
+ | ENDIF; | ||
+ | |||
+ | // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT | ||
+ | IF INZ = '1' ; | ||
+ | KW = *BLANK; | ||
+ | EXSR @PCKMOV; | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | |||
+ | X = 1; | ||
+ | |||
+ | DOW @LOOP = @LOOP; | ||
+ | |||
+ | // NXTSBA | ||
+ | X = %LOOKUP(SBA : ID : X ); | ||
+ | IF X = 0; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // IS THIS THE FIELD? CHECK THE BUFFER ADDRESS | ||
+ | X = X +1; | ||
+ | IF B(Y) <> %SUBST(IDA : X :2); | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | |||
+ | // FOUND A MTD FOR THIS FIELD | ||
+ | X = X + 2; | ||
+ | |||
+ | // CHECK IF FIELD WAS CLEARED ONLY | ||
+ | IF ID(X) = SBA; | ||
+ | EXSR @PCKMOV; | ||
+ | LEAVE ; | ||
+ | ENDIF; | ||
+ | |||
+ | // IF FIELD HAS DECIMALS BUMP X | ||
+ | IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND | ||
+ | P(Y) > 0; | ||
+ | X = X + 1; | ||
+ | ENDIF; | ||
+ | |||
+ | // CHECK IF ONLY BLANKS RETURNED | ||
+ | IF %SUBST(IDA : X :K2) = *BLANKS; | ||
+ | EXSR @PCKMOV; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // EXTRACT THE DATA FROM THE INCOMING STRING | ||
+ | X1 = X; | ||
+ | FOR X2 = 1 TO K2 ; | ||
+ | |||
+ | IF ID(X1) < ' '; | ||
+ | // TRAP NULLS CAUSED BY FLD EXIT | ||
+ | EXSR @PCKMOV; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | K(X2) = ID(X1); | ||
+ | X1 = X1 +1; | ||
+ | ENDFOR; | ||
+ | |||
+ | // CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED | ||
+ | // INTO ARRAY KW | ||
+ | EXSR @PCKMOV; | ||
+ | LEAVE; | ||
+ | ENDDO; | ||
+ | |||
+ | ENDFOR; | ||
+ | |||
+ | // | ||
+ | KEYA = KW; | ||
+ | CLEAR KW; | ||
+ | ENDSR ; | ||
+ | |||
+ | // @@@@@@@ @CVTRRN @@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | |||
+ | BEGSR @CVTRRN; | ||
+ | |||
+ | // RRN | ||
+ | |||
+ | NUM11 = 0; | ||
+ | |||
+ | DOW @LOOP = @LOOP; // NOT REALLY A LOOP(SIMULATES GOTO) | ||
+ | |||
+ | // GET THE FIRST SBA | ||
+ | X = 1; | ||
+ | X = %LOOKUP(SBA : ID : X ); | ||
+ | IF X = 0; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD | ||
+ | X = X +1; | ||
+ | IF B(1) <> %SUBST(IDA : X :2); | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | |||
+ | // FOUND A MTD FOR RRN FIELD | ||
+ | X = X +2; | ||
+ | |||
+ | //CHECK IF FIELD WAS CLEARED ONLY | ||
+ | IF ID(X) = SBA; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // CHECK IF ONLY BLANKS RETURNED | ||
+ | IF %SUBST(IDA : X :11) = *BLANKS; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // WRK11 OVERLAYS NUM11 | ||
+ | WRK11 = %SUBST(IDA : X :11); | ||
+ | |||
+ | LEAVE; | ||
+ | ENDDO; | ||
+ | |||
+ | |||
+ | RRNA = NUM11; | ||
+ | IF RRNA < 0; | ||
+ | RRNA = 1; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | // @@@@@@@ @PCKMOV @@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | |||
+ | BEGSR @PCKMOV; | ||
+ | // | ||
+ | // CONVERT KEY DATA | ||
+ | // SET START POSN IN KEY USING OFFSET IN R | ||
+ | X1 = %LOOKUP(N(Y) : N ); | ||
+ | W = R(X1) + 1; | ||
+ | |||
+ | // ALPHA | ||
+ | IF T(Y) = 'A'; | ||
+ | X1 = 1; | ||
+ | FOR Z = W TO W + Q(Y); | ||
+ | %SUBST(KW : Z : 1) = K(X1); | ||
+ | X1 = X1 + 1; | ||
+ | ENDFOR; | ||
+ | ENDIF; | ||
+ | |||
+ | // NUMERIC FIELD | ||
+ | // RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS | ||
+ | IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B'); | ||
+ | NU = '0'; | ||
+ | |||
+ | Z1 = 60; | ||
+ | FOR Z = K2 DOWNTO K1; | ||
+ | |||
+ | IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$'; | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | |||
+ | IF K(Z) = ' ' ; | ||
+ | NU(Z1) = '0'; | ||
+ | ELSE; | ||
+ | NU(Z1) = K(Z); | ||
+ | ENDIF; | ||
+ | |||
+ | Z1 = Z1 -1; | ||
+ | ENDFOR; | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | // SIGNED FIELDS (END POSN = OFFSET + SIZE) | ||
+ | IF T(Y) = 'S'; | ||
+ | NUS = 0; | ||
+ | FOR VX = 1 TO 60; | ||
+ | NUSA = %TRIM(NUSA) + NU(VX); | ||
+ | ENDFOR; | ||
+ | %SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y)); | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | // PACKED FIELDS | ||
+ | IF T(Y) = 'P'; | ||
+ | NUSA= *BLANKS; | ||
+ | FOR VX = 1 TO 60; | ||
+ | NUSA = %TRIM(NUSA) + NU(VX); | ||
+ | ENDFOR; | ||
+ | NUP = %DEC(NUSA : 60 : 0); | ||
+ | |||
+ | %SUBST(KW : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y)); | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | // BINARY FIELDS | ||
+ | IF T(Y) = 'B'; | ||
+ | |||
+ | IF Q(Y) = 2 ; | ||
+ | BY2 = NU(1) + NU(2); | ||
+ | %SUBST(KW : W : 2) = BY2; | ||
+ | ENDIF; | ||
+ | |||
+ | IF Q(Y) = 4 ; | ||
+ | BY4 = NU(1) + NU(2) + NU(3) + NU(4); | ||
+ | %SUBST(KW : W : 4) = BY4; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | // @@@@@@@ SETIN @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @SETIN; | ||
+ | |||
+ | // SET the FFR indicators to get the Input buffer somewhat aligned with the | ||
+ | // actual data. RPG is somewhat tolerant to a difference between the Ispecs | ||
+ | // and the actual file size but it can fail on big differences. | ||
+ | // INCREMENT OF 32 BYTES | ||
+ | SZ(1) = BASE + 16; | ||
+ | SZ(2) = SZ(1) + 16; | ||
+ | |||
+ | *IN30 = *ON; | ||
+ | IF (RLEN > SZ(2)) ; | ||
+ | *IN31 = *ON; | ||
+ | ENDIF; | ||
+ | |||
+ | FOR X = 3 TO 64; | ||
+ | SZ(X) = SZ(X-1) + 32; | ||
+ | IF (RLEN > SZ(X)) ; | ||
+ | *IN(29+X) = *ON; | ||
+ | ENDIF; | ||
+ | ENDFOR; | ||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | //@@@@@@@@@@@@@@@@@ @GETF @@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @GETF; | ||
+ | // GET A DATA RECORD | ||
+ | IF (*INU1); | ||
+ | IF AID = '1' OR AID = X36 OR | ||
+ | AID = X39 OR AID = X3B ; | ||
+ | SETLL(E) KEYA INPUTK; | ||
+ | READ(E) INPUTK; | ||
+ | IF %EOF; | ||
+ | SETLL(E) KEYA INPUTK; | ||
+ | READP(E) INPUTK; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | IF AID = '4'; | ||
+ | READP(E) INPUTK; | ||
+ | ENDIF; | ||
+ | |||
+ | IF AID = '5'; | ||
+ | READ(E) INPUTK; | ||
+ | ENDIF; | ||
+ | |||
+ | IF %ERROR; | ||
+ | SETLL(E) KEYA INPUTK; | ||
+ | READ(E) INPUTK; | ||
+ | MX = 7; | ||
+ | EXSR @ERROR; | ||
+ | EXSR @PUTF ; | ||
+ | EXSR @KEYIN; | ||
+ | ENDIF; | ||
+ | |||
+ | KEYA = LKY; | ||
+ | |||
+ | |||
+ | CLEAR KW; | ||
+ | KW = LKY; | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | IF (*INU2); | ||
+ | IF AID = '1'; | ||
+ | CHAIN(E) RRNA INPUTR; | ||
+ | IF %ERROR; | ||
+ | SETLL(E) RRNA INPUTR; | ||
+ | READP(E) INPUTR; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | IF AID = X36; | ||
+ | CHAIN(E) RRNA INPUTR; | ||
+ | ENDIF; | ||
+ | |||
+ | IF AID = '4'; | ||
+ | READP(E) INPUTR; | ||
+ | ENDIF; | ||
+ | |||
+ | IF AID = '5' OR AID = X3B; | ||
+ | READ(E) INPUTR; | ||
+ | ENDIF; | ||
+ | |||
+ | IF AID = X39; | ||
+ | SETLL(E) *HIVAL INPUTR; | ||
+ | READP(E) INPUTR; | ||
+ | ENDIF; | ||
+ | |||
+ | IF %ERROR; | ||
+ | CHAIN 1 INPUTR; | ||
+ | MX = 7; | ||
+ | EXSR @ERROR; | ||
+ | EXSR @PUTF ; | ||
+ | EXSR @KEYIN; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | //@@@@@@@@@@@@@@@@@ @PUTF @@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @PUTF; | ||
+ | |||
+ | SELECT; | ||
+ | WHEN *INU1; | ||
+ | RRN = RN1; | ||
+ | WHEN *INU2; | ||
+ | RRN = RN2; | ||
+ | ENDSL; | ||
+ | // IF GOT RECORDS WRITE DATA TO THE DISPLAY | ||
+ | |||
+ | NEWRU = '1'; | ||
+ | WRTRRN = '1'; | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; // initialise Request Unit 255 bytes max | ||
+ | |||
+ | IF RRN > 0 ; | ||
+ | FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | ||
+ | |||
+ | IF NEWRU = '1'; | ||
+ | NEWRU = '0'; | ||
+ | RU = ESC + WTD + X20 + X00; | ||
+ | ENDIF; | ||
+ | |||
+ | IF WRTRRN = '1'; | ||
+ | WRTRRN = '0'; | ||
+ | RU = RU + SBA + RBA ; | ||
+ | RU = RU + %TRIM(%EDITC(RRN:'Z')); | ||
+ | ENDIF; | ||
+ | |||
+ | // BUFFER ADDRESS | ||
+ | RU = RU + SBA + B(XX); | ||
+ | |||
+ | // PROCESS ALPHA DATA TYPE | ||
+ | IF T(XX) = 'A' OR T(XX) = 'T' OR T(XX) = 'Z' OR | ||
+ | T(XX) = 'L'; | ||
+ | |||
+ | STRX = S(XX); | ||
+ | ENDX = E(XX); | ||
+ | |||
+ | IF V(XX) = 'Y'; //VARYING | ||
+ | VX = S(XX); | ||
+ | HX2 = D(VX) + D(VX+1); | ||
+ | STRX = S(XX) + 2 ; | ||
+ | ENDX = S(XX) + BIN; | ||
+ | ENDIF; | ||
+ | |||
+ | FOR Y = STRX TO ENDX ; | ||
+ | IF D(Y) >= ' '; | ||
+ | RU = RU + D(Y); | ||
+ | ELSE; | ||
+ | RU = RU + X1F ; //IF NOT DISPLAYABLE REPLACE WITH X'1F' | ||
+ | ENDIF; | ||
+ | ENDFOR; | ||
+ | ENDIF; | ||
+ | |||
+ | // PROCESS SIGNED DATA TYPE (not the RRN field) | ||
+ | IF T(XX) = 'S' and KY(XX) <> '3'; | ||
+ | NUSA = *ALL'0'; | ||
+ | WRV = *ALLX'00'; | ||
+ | CLEAR WRV; | ||
+ | FOR Y = S(XX) TO E(XX); | ||
+ | IF D(Y) >= XD0; | ||
+ | WRV = WRV + D(Y); | ||
+ | ENDIF; | ||
+ | ENDFOR; | ||
+ | EVAL NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV; | ||
+ | CLEAR WRU; | ||
+ | WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD); | ||
+ | IF P(XX) > 0; | ||
+ | RU = RU + | ||
+ | %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' + | ||
+ | %SUBST(WRU :61-P(XX)) ; | ||
+ | ELSE; | ||
+ | RU = RU + | ||
+ | %SUBST(WRU :61-C(XX)); | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // PROCESS SIGNED DATA TYPE (the RRN field) | ||
+ | IF T(XX) = 'S' and KY(XX) = '3'; | ||
+ | RRN = RN2; | ||
+ | RU = RU + %TRIM(%EDITC(RRN:'X')); | ||
+ | ENDIF; | ||
+ | |||
+ | // PROCESS PACKED DATA TYPE | ||
+ | IF T(XX) = 'P'; | ||
+ | NUPA = *ALLX'00'; | ||
+ | WRV = *ALLX'00'; | ||
+ | CLEAR WRV; | ||
+ | FOR Y = S(XX) TO E(XX); | ||
+ | WRV = WRV + D(Y); | ||
+ | ENDFOR; | ||
+ | |||
+ | IF %BITAND(D(E(XX)) :X0F) = X0F OR | ||
+ | %BITAND(D(E(XX)) :X0D) = X0D; | ||
+ | |||
+ | EVAL NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV; | ||
+ | CLEAR WRX; | ||
+ | WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD); | ||
+ | IF P(XX) > 0; | ||
+ | RU = RU + | ||
+ | %SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' + | ||
+ | %SUBST(WRX :64-P(XX)) ; | ||
+ | ELSE; | ||
+ | RU = RU + | ||
+ | %SUBST(WRX :64-C(XX)); | ||
+ | ENDIF; | ||
+ | ELSE; | ||
+ | // PACKED FIELD IN ERROR | ||
+ | RU = RU + X1F; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | // PROCESS BINARY DATA TYPE | ||
+ | IF T(XX) = 'B'; | ||
+ | |||
+ | ST = S(XX); | ||
+ | CLEAR NUSA; | ||
+ | IF Q(XX) = 2; | ||
+ | BY2 = D(ST) + D(ST+1); | ||
+ | NUS = BIN2; | ||
+ | ENDIF; | ||
+ | IF Q(XX) = 4; | ||
+ | BY4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3); | ||
+ | NUS = BIN4; | ||
+ | ENDIF; | ||
+ | |||
+ | WRU = %EDITW(NUS :WRSWRD); | ||
+ | IF P(XX) > 0; | ||
+ | RU = RU + | ||
+ | %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' + | ||
+ | %SUBST(WRU :61-P(XX)) ; | ||
+ | ELSE; | ||
+ | RU = RU + | ||
+ | %SUBST(WRU :61-C(XX)); | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // PROCESS FLOAT DATA TYPE | ||
+ | IF T(XX) = 'F'; | ||
+ | |||
+ | ST = S(XX); | ||
+ | |||
+ | IF Q(XX) = 4; | ||
+ | FL4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3); | ||
+ | FLT14 = %EDITFLT(FLT4); | ||
+ | RU = RU + FLT14; | ||
+ | ENDIF; | ||
+ | |||
+ | IF Q(XX) = 8; | ||
+ | FL8 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) + | ||
+ | D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7); | ||
+ | FLT23 = %EDITFLT(FLT8); | ||
+ | RU = RU + FLT23; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // SEND A REQUEST UNIT IF GOT ENOUGH DATA | ||
+ | |||
+ | IF %LEN(RU) + L(XX + 1) >= 200; | ||
+ | RU = RU + X20; | ||
+ | BIN = %LEN(RU); | ||
+ | OUTLEN = HX2; | ||
+ | INLEN = X000; | ||
+ | FNC = SND; | ||
+ | A = RU; | ||
+ | EXCEPT DATAO; | ||
+ | NEWRU = '1'; | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDFOR; | ||
+ | ENDIF; | ||
+ | |||
+ | IF %LEN(RU) > 5 AND %LEN(RU) < 250; | ||
+ | RU = RU + X20; | ||
+ | BIN = %LEN(RU); | ||
+ | OUTLEN = HX2; | ||
+ | INLEN = X000; | ||
+ | FNC = SND; | ||
+ | A = RU; | ||
+ | EXCEPT DATAO; | ||
+ | ENDIF; | ||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | // @@@@@@@@@@@@@@@ ROWINC @@@@@@@@@@@@@@@ | ||
+ | |||
+ | // INCREMENT THE ROW | ||
+ | BEGSR @ROWINC; | ||
+ | ROW = ROW + 2; | ||
+ | IF ROW > 20; | ||
+ | MX = 3; | ||
+ | ENDIF; | ||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | |||
+ | // @@@@@@@@@@@@@@@ GETFLD @@@@@@@@@@@@@@@ | ||
+ | |||
+ | // LOAD FIELD DESCRIPTION ARRAYS | ||
+ | BEGSR @GETFLD; | ||
+ | MX = 0; | ||
+ | X = 0; | ||
+ | |||
+ | IF (*INU2 = *ON); | ||
+ | // IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN | ||
+ | N(1) = 'RRN'; | ||
+ | T(1) = 'S' ; | ||
+ | C(1) = 11 ; | ||
+ | P(1) = 0 ; | ||
+ | S(1) = 0 ; | ||
+ | E(1) = 0 ; | ||
+ | L(1) = 12 ; | ||
+ | I(1) = X4F06 ; | ||
+ | KY(1)= '3' ; | ||
+ | X = 1 ; | ||
+ | ENDIF; | ||
+ | |||
+ | SCRST = *BLANK; | ||
+ | SCRSTN = *BLANK; | ||
+ | |||
+ | LVL = %DEC(SCNLVL : 5:0); | ||
+ | |||
+ | TEXT500 = SCNLV ; | ||
+ | LV = LVW; | ||
+ | |||
+ | IF LVL <> 0; | ||
+ | SCRST = LV(LVL); | ||
+ | ENDIF; | ||
+ | |||
+ | SETLL 1 QWHDRFFD ; | ||
+ | |||
+ | DOW @LOOP = @LOOP; | ||
+ | // REREAD TAG | ||
+ | READ QWHDRFFD; | ||
+ | IF %EOF; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // SELECT OR OMIT | ||
+ | IF ALL <> '1'; | ||
+ | IF ALL = 'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS | ||
+ | IF WHFIOB <> 'S'; | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | IF ALL = 'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS | ||
+ | IF WHFIOB = 'O'; | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | // FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS) | ||
+ | IF WHDFTL <> 0 ; | ||
+ | ELSE; | ||
+ | IF SCRST <> ' ' AND SCRSTN = ' '; | ||
+ | IF WHFLDE = SCRST; | ||
+ | SCRSTN = '1'; // FOUND THE START | ||
+ | ELSE; | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | X = X + 1; | ||
+ | // CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT | ||
+ | IF WHDFTL <> 0; | ||
+ | KY(X) = '1'; | ||
+ | WX = WHDFTL ; | ||
+ | KE(WX) = WHFLDE; | ||
+ | IF NUMKEY < WHDFTL; | ||
+ | NUMKEY = WHDFTL; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | N(X) = WHFLDE ; // NAME | ||
+ | T(X) = WHFLDT ; // TYPE | ||
+ | V(X) = WHVARL ; // VARYING | ||
+ | C(X) = WHFLDD ; // DEC DIGITS | ||
+ | P(X) = WHFLDP ; // DEC PREC | ||
+ | S(X) = WHFOBO ; // START | ||
+ | Q(X) = WHFLDB ; // BTYES | ||
+ | E(X) = WHFOBO + WHFLDB -1 ; // END | ||
+ | |||
+ | IF T(X) = 'F' ; // FLOAT | ||
+ | |||
+ | I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA | ||
+ | L(X) = 14; | ||
+ | IF Q(X) = 8; | ||
+ | L(X) = 23; | ||
+ | ENDIF; | ||
+ | |||
+ | ELSE; | ||
+ | IF WHFLDD <> 0 ; | ||
+ | IF WHFLDP <> 0 ; | ||
+ | L(X) = WHFLDD + 2 ; // LENGTH | ||
+ | ELSE; | ||
+ | L(X) = WHFLDD + 1 ; // LENGTH | ||
+ | ENDIF; | ||
+ | |||
+ | I(X) = FFN1 + FFN2; // SCRN FIELD FORMAT NUMERIC | ||
+ | |||
+ | ELSE; | ||
+ | L(X) = WHFLDB ; | ||
+ | I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDDO; | ||
+ | // NUMBER OF FIELDS | ||
+ | NUMFLD = X ; | ||
+ | |||
+ | // MAKE ROOM FOR KEYS | ||
+ | IF NUMKEY > 0 ; | ||
+ | X1 = NUMKEY + NUMFLD; | ||
+ | |||
+ | FOR X = NUMFLD DOWNTO 1; | ||
+ | KY(X1) = KY(X) ; | ||
+ | L(X1) = L(X) ; | ||
+ | I(X1) = I(X) ; | ||
+ | N(X1) = N(X) ; | ||
+ | T(X1) = T(X) ; | ||
+ | V(X1) = V(X) ; | ||
+ | C(X1) = C(X) ; | ||
+ | P(X1) = P(X) ; | ||
+ | S(X1) = S(X) ; | ||
+ | E(X1) = E(X) ; | ||
+ | Q(X1) = Q(X) ; | ||
+ | X1 = X1 - 1; | ||
+ | ENDFOR; | ||
+ | |||
+ | // PUT KEY FIELDS AT TOP | ||
+ | OFF = 0; | ||
+ | FOR X = 1 TO NUMKEY; | ||
+ | X1 = %LOOKUP(KE(X) : N : NUMKEY+1); | ||
+ | |||
+ | KY(X) = '2'; | ||
+ | L(X) = L(X1); | ||
+ | I(X) = I(X1); // FIELD FMT | ||
+ | SELECT; // INPUT ENABLE | ||
+ | WHEN I(X) = X6000; | ||
+ | I(X) = X4800; | ||
+ | WHEN I(X) = X6706; | ||
+ | I(X) = X4F06; | ||
+ | ENDSL; | ||
+ | N(X) = N(X1); | ||
+ | T(X) = T(X1); | ||
+ | V(X) = V(X1); | ||
+ | C(X) = C(X1); | ||
+ | P(X) = P(X1); | ||
+ | S(X) = S(X1); | ||
+ | E(X) = E(X1); | ||
+ | Q(X) = Q(X1); | ||
+ | R(X) = OFF; | ||
+ | OFF = OFF + Q(X1); | ||
+ | ENDFOR; | ||
+ | |||
+ | ENDIF; | ||
+ | // NUMBER OF FIELDS AND KEYS | ||
+ | NUMFKY = NUMFLD + NUMKEY; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | // @@@@@@@@@@@@@@@ GETADD @@@@@@@@@@@@@@@ | ||
+ | |||
+ | // LOAD FIELD BUFFER ADDRESSES | ||
+ | BEGSR @GETADD; | ||
+ | MX = 0; | ||
+ | X = 0; | ||
+ | ROW = 3; | ||
+ | COL = 1; | ||
+ | |||
+ | FOR X = 1 TO NUMFKY; | ||
+ | |||
+ | // IF FINISHED WITH THE KEY FIELDS | ||
+ | // INC ROW FOR 1ST DATA FIELD | ||
+ | IF KEYSOK = ' ' ; | ||
+ | IF KY(X) = ' ' OR KY(X) = '1'; | ||
+ | KEYSOK = '1' ; | ||
+ | ROW = ROW + 2; | ||
+ | COL = 1; | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | |||
+ | // SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE | ||
+ | LENDSC = %LEN(%TRIM(N(X))); | ||
+ | LENWRK = L(X); | ||
+ | IF LENDSC > L(X); | ||
+ | LENWRK = LENDSC; | ||
+ | ENDIF; | ||
+ | LENWRK = LENWRK + 2; | ||
+ | |||
+ | // TRAP FIELDS THAT OVERFLOW | ||
+ | ROW = ROW + XROW; | ||
+ | XROW = %DIV(LENWRK : 80); | ||
+ | |||
+ | IF (COL + LENWRK) > 78; | ||
+ | EXSR @ROWINC; | ||
+ | IF MX = 3; | ||
+ | X= X-1; | ||
+ | NUMFKY = X; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | COL = 1; | ||
+ | ENDIF; | ||
+ | |||
+ | // INC COL. FOR FIELD START | ||
+ | CLEAR B(X); | ||
+ | BIN = ROW; | ||
+ | B(X) = %TRIM(B(X)) + HX1; | ||
+ | BIN = COL + 1; | ||
+ | B(X) = %TRIM(B(X)) + HX1; | ||
+ | |||
+ | // INC COL. FOR NEXT FIELD | ||
+ | COL = COL + LENWRK; | ||
+ | IF COL > 78; | ||
+ | EXSR @ROWINC; | ||
+ | IF MX = 3; // NO ROOM FOR THE FIELD | ||
+ | X= X-1; | ||
+ | NUMFKY = X; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | COL = 1; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDFOR; | ||
+ | |||
+ | // FIELD LEVEL | ||
+ | LVX = LVL + 1; | ||
+ | LV(LVX) = N(X); | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | // @@@@@@@@@@@@@@@ PUTHED @@@@@@@@@@@@@@@ | ||
+ | |||
+ | // PUT FIELD HEADINGS | ||
+ | BEGSR @PUTHED; | ||
+ | |||
+ | |||
+ | NEWRU = '1'; | ||
+ | |||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; // initialise Request Unit 255 bytes max | ||
+ | FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | ||
+ | |||
+ | IF NEWRU = '1'; | ||
+ | NEWRU = '0'; | ||
+ | RU = ESC + WTD + X20 + X00; | ||
+ | ENDIF; | ||
+ | |||
+ | RU = RU + SBA; | ||
+ | BIN = 0; | ||
+ | // CONVERT DATA BUFADR TO HEADING BUFADR | ||
+ | HX1 = %SUBST(B(XX) :1:1); | ||
+ | BIN = BIN - 1; | ||
+ | RU = RU + HX1; | ||
+ | |||
+ | IF REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR | ||
+ | BIN = 0; | ||
+ | HX1 = %SUBST(B(XX) :2:1); | ||
+ | BIN = BIN -1 ; | ||
+ | RU = RU + HX1; | ||
+ | ELSE; | ||
+ | RU = RU + %SUBST(B(XX) :2); | ||
+ | ENDIF; | ||
+ | |||
+ | RU = RU + ATC ; | ||
+ | |||
+ | // LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS | ||
+ | LENDSC = %LEN(%TRIM(N(XX))); | ||
+ | IF T(XX) <> 'A' AND LENDSC < (L(XX) -1); | ||
+ | FOR Y = 1 TO (L(XX) -(LENDSC +1)); | ||
+ | RU = RU + ' '; | ||
+ | ENDFOR; | ||
+ | ENDIF; | ||
+ | |||
+ | RU = RU + %TRIM(N(XX)); | ||
+ | |||
+ | IF %LEN(RU) >= 200; | ||
+ | BIN = %LEN(RU); | ||
+ | OUTLEN = HX2; | ||
+ | INLEN = X000; | ||
+ | FNC = SND; | ||
+ | A = RU; | ||
+ | EXCEPT DATAO; | ||
+ | NEWRU = '1'; | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDFOR; | ||
+ | |||
+ | IF %LEN(RU) > 5 AND %LEN(RU) < 200; | ||
+ | BIN = %LEN(RU); | ||
+ | OUTLEN = HX2; | ||
+ | INLEN = X000; | ||
+ | FNC = SND; | ||
+ | A = RU; | ||
+ | EXCEPT DATAO; | ||
+ | ENDIF; | ||
+ | |||
+ | IF REHEAD <> '1'; | ||
+ | // FORMAT FIELDS | ||
+ | |||
+ | |||
+ | NEWRU = '1'; | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; // initialise Request Unit 255 bytes max | ||
+ | FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | ||
+ | |||
+ | IF NEWRU = '1'; | ||
+ | NEWRU = '0'; | ||
+ | RU = ESC + WTD + X20 + X00; | ||
+ | ENDIF; | ||
+ | |||
+ | RU = RU + SBA +B(XX)+SF + I(XX); | ||
+ | |||
+ | IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3'; | ||
+ | RU = RU + X25; | ||
+ | ELSE; | ||
+ | RU = RU + X26; | ||
+ | ENDIF; | ||
+ | |||
+ | BIN = L(XX); | ||
+ | RU = RU + HX2; | ||
+ | |||
+ | // LENGTH OF INPUT FIELDS | ||
+ | LENF = LENF + L(XX) + 3; | ||
+ | |||
+ | |||
+ | IF %LEN(RU) >= 200; | ||
+ | BIN = %LEN(RU); | ||
+ | OUTLEN = HX2; | ||
+ | INLEN = X000; | ||
+ | FNC = SND; | ||
+ | A = RU; | ||
+ | EXCEPT DATAO; | ||
+ | NEWRU = '1'; | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDFOR; | ||
+ | |||
+ | // PUT LAST R/U | ||
+ | IF %LEN(RU) > 5 AND %LEN(RU) < 200; | ||
+ | BIN = %LEN(RU); | ||
+ | OUTLEN = HX2; | ||
+ | INLEN = X000; | ||
+ | FNC = SND; | ||
+ | A = RU; | ||
+ | EXCEPT DATAO; | ||
+ | ENDIF; | ||
+ | |||
+ | //INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT | ||
+ | FOR XP = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) | ||
+ | HX2 = B(XP); | ||
+ | BIN = BIN + 1; | ||
+ | B(XP) = HX2; | ||
+ | ENDFOR; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | // @@@@@@@ INIT @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @INIT; | ||
+ | |||
+ | CLEAR KW; | ||
+ | |||
+ | // UPDATE | ||
+ | IF UPDF = 'Y'; | ||
+ | FFA1 = X40; | ||
+ | FFN1 = X47; | ||
+ | ELSE; | ||
+ | FFA1 = X60; | ||
+ | FFN1 = X67; | ||
+ | ENDIF; | ||
+ | |||
+ | SELECT; | ||
+ | WHEN *INU1 = '1'; | ||
+ | FILE = F1 ; | ||
+ | LIB = L1 ; | ||
+ | MBR = M1 ; | ||
+ | RCDL = R1 ; | ||
+ | ACCTP = A1 ; | ||
+ | WHEN *INU2 = '1'; | ||
+ | FILE = F2 ; | ||
+ | LIB = L2 ; | ||
+ | MBR = M2 ; | ||
+ | RCDL = R2 ; | ||
+ | ACCTP = A2 ; | ||
+ | ENDSL; | ||
+ | RLEN = RCDL ; | ||
+ | RLENTH = %EDITC(RLEN: 'X') ; | ||
+ | LENF = 0 ; | ||
+ | |||
+ | |||
+ | // Control commands and data are constructed into RUs Request UNITS | ||
+ | // Each RU is 256 bytes max size. | ||
+ | // Construct and send as many RUs as needed to format the display. | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; // initialise Request Unit 255 bytes max | ||
+ | RU = CLRWTD ; | ||
+ | //set up the screen headings | ||
+ | BIN = 1; // set ROW to 1 | ||
+ | RW = HX1; | ||
+ | BIN = 2; // set COL to 2 | ||
+ | CL = HX1; | ||
+ | RU = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE); | ||
+ | RU = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN : 'Z') ; | ||
+ | RU = RU + ' RRN ' ; | ||
+ | BIN = %len(RU) -4; | ||
+ | RBA = RW + HX1 ; // address of the RRN field | ||
+ | RU = RU + SBA + RBA + ' '; | ||
+ | |||
+ | // FUNCTION KEYS | ||
+ | BIN = 23; | ||
+ | RW = HX1; | ||
+ | BIN = 02; | ||
+ | CL = HX1; | ||
+ | IF UPDF = 'Y'; // UPDATE IS ON | ||
+ | RU = RU + SBA + RW + CL + %TRIM(CNS(2)); | ||
+ | ELSE; | ||
+ | RU = RU + SBA + RW + CL + %TRIM(CNS(1)); | ||
+ | ENDIF; | ||
+ | |||
+ | // THIS IS A SEND ONLY FUNCTION | ||
+ | FNC = SND; | ||
+ | CLEAR A; | ||
+ | A = RU; | ||
+ | BIN2 = %LEN(RU); | ||
+ | OUTLEN = BY2; | ||
+ | INLEN = x000; | ||
+ | |||
+ | EXCEPT DATAO; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | // @@@@@@@ KEYIN @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @KEYIN; | ||
+ | // ISSUE A READ FROM DISPLAY | ||
+ | FNC = SNR; | ||
+ | BIN2 = 8; | ||
+ | OUTLEN = BY2; | ||
+ | IPL = LENF + 34; | ||
+ | BIN2 = IPL; | ||
+ | INLEN = BY2; | ||
+ | |||
+ | // SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW | ||
+ | FOR X = 1 TO 9; | ||
+ | IF IPL > ( X*80 +3); | ||
+ | *IN(X+19) = *ON; | ||
+ | ENDIF; | ||
+ | ENDFOR; | ||
+ | |||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | RU = RDDSP; | ||
+ | A = RU; | ||
+ | |||
+ | EXCEPT DATAI; | ||
+ | ENDSR; | ||
+ | |||
+ | // @@@@@@@ ERROR @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @ERROR; | ||
+ | |||
+ | // SETUP PUT ERROR MESSAGE X'21' | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | |||
+ | FNC = SNR; | ||
+ | BIN = 42; | ||
+ | OUTLEN = HX2; | ||
+ | BIN = LENF + 34; | ||
+ | IPL = BIN; | ||
+ | INLEN = HX2; | ||
+ | |||
+ | FOR X = 1 TO 9; | ||
+ | IF IPL > (X * 80 +3) ; | ||
+ | *IN(X + 19) = *ON; // SETON FFR 20 - 29 FOR INPUT | ||
+ | ENDIF; | ||
+ | ENDFOR; | ||
+ | |||
+ | RU = ESC + WER + IC + B(1) + ATC + MSG(MX); | ||
+ | RU = RU + ESC + RDM + X40+ X00; | ||
+ | |||
+ | A = RU; | ||
+ | EXCEPT DATAI; | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | // @@@@@@@ HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @HXDSP; | ||
+ | |||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | Y = %LOOKUPLE( CURLOC : B ); | ||
+ | // | ||
+ | RU = ESC + WTD + X20 + X00 + SBA; | ||
+ | BIN = 0; | ||
+ | HX1 = %SUBST(B(Y) :1:1); | ||
+ | BIN = BIN - 1; | ||
+ | RU = RU + HX1; | ||
+ | RU = RU + %SUBST(B(Y) :2:1); | ||
+ | |||
+ | FOR X = S(Y) TO E(Y); | ||
+ | BIN = 0; | ||
+ | HX1 = D(X); | ||
+ | HX1 = %BITAND(HX1 : XF0); | ||
+ | Z = BIN / 16 + 1; | ||
+ | RU = RU + CRS(Z); | ||
+ | ENDFOR; | ||
+ | |||
+ | RU = RU + X20; | ||
+ | |||
+ | RU = RU + SBA + B(Y); | ||
+ | FOR X = S(Y) TO E(Y); | ||
+ | BIN = 0; | ||
+ | HX1 = D(X); | ||
+ | HX1 = %BITAND(HX1 : X0F); | ||
+ | Z = BIN + 1; | ||
+ | RU = RU + CRS(Z); | ||
+ | ENDFOR; | ||
+ | |||
+ | |||
+ | BIN = %LEN(RU); | ||
+ | OUTLEN = HX2; | ||
+ | INLEN = X000; | ||
+ | FNC = SND; | ||
+ | A = RU; | ||
+ | EXCEPT DATAO; | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | |||
+ | |||
+ | EXSR @KEYIN; | ||
+ | READ DISPF; | ||
+ | |||
+ | |||
+ | // CLEAR HEADINGS | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | |||
+ | RU = RU + ESC + WTD + X20 + X00 + SBA; | ||
+ | HX1 = %SUBST(B(Y) :1:1) ; | ||
+ | BIN = BIN - 1; | ||
+ | RU = RU + HX1 + %SUBST(B(Y):2:1); | ||
+ | FOR X = S(Y) TO E(Y); | ||
+ | RU = RU + ' '; | ||
+ | ENDFOR; | ||
+ | RU = RU + ' '; | ||
+ | |||
+ | BIN = %LEN(RU); | ||
+ | OUTLEN = HX2; | ||
+ | INLEN = X000; | ||
+ | FNC = SND; | ||
+ | A = RU; | ||
+ | EXCEPT DATAO; | ||
+ | RU = *ALLX'00'; | ||
+ | CLEAR RU; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | |||
+ | // @@@@@@@ UPD @@@@@@@@@@@@@@@@@@@@@@@@@ | ||
+ | BEGSR @UPD; | ||
+ | |||
+ | // CONVERT DATA FOR OUTPUT | ||
+ | |||
+ | // FOR EACH FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE | ||
+ | // THE MODIFIED DATA INTO THE OUTPUT ARRAY | ||
+ | K1 = 0; | ||
+ | K2 = 0; | ||
+ | W = 1; | ||
+ | CGKY = *BLANK; // KEY CHANGED | ||
+ | KW = KEYA; | ||
+ | |||
+ | FOR Y = 1 TO NUMFKY ; | ||
+ | |||
+ | IF KY(Y) > '1'; | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY | ||
+ | |||
+ | // GET SIZE OF FIELD IN BYTES | ||
+ | IF T(Y) = 'A'; // ALPHA DATA | ||
+ | K = ' '; | ||
+ | K1 = 1; | ||
+ | K2 = Q(Y); | ||
+ | ELSE; | ||
+ | K = '0'; | ||
+ | K1 = 1; | ||
+ | K2 = C(Y); | ||
+ | ENDIF; | ||
+ | |||
+ | X = 1; | ||
+ | |||
+ | DOW @LOOP = @LOOP; | ||
+ | |||
+ | // NXTSBA | ||
+ | X = %LOOKUP(SBA : ID : X ); | ||
+ | IF X = 0; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // IS THIS THE FIELD? CHECK THE BUFFER ADDRESS | ||
+ | X = X +1; | ||
+ | IF B(Y) <> %SUBST(IDA : X :2); | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // FOUND A MTD FOR THIS FIELD | ||
+ | |||
+ | |||
+ | // CHECK IF FIELD WAS CLEARED ONLY | ||
+ | DOW @LOOP = @LOOP; // not a loop | ||
+ | X = X + 2; | ||
+ | IF ID(X) = SBA; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // IF FIELD HAS DECIMALS BUMP X | ||
+ | IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND | ||
+ | P(Y) > 0; | ||
+ | X = X + 1; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // CHECK IF ONLY BLANKS RETURNED | ||
+ | IF %SUBST(IDA : X :K2) = *BLANKS; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // MOVE DATA TO WORK ARRAY K | ||
+ | X1 = X; | ||
+ | FOR X2 = 1 TO K2; | ||
+ | |||
+ | IF ID(X1) < ' '; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | K(X2) = ID(X1); | ||
+ | X1 = X1 + 1; | ||
+ | ENDFOR; | ||
+ | |||
+ | LEAVE; | ||
+ | ENDDO; | ||
+ | |||
+ | // * SET START POSN | ||
+ | W = S(Y); | ||
+ | |||
+ | // ALPHA | ||
+ | IF T(Y) = 'A' and V(XX) <> 'Y'; | ||
+ | FOR Z = K1 to K2; | ||
+ | D(W) = K(Z); | ||
+ | W = W + 1; | ||
+ | ENDFOR; | ||
+ | ENDIF; | ||
+ | |||
+ | IF T(Y) = 'A' and V(XX) = 'Y'; //VARYING | ||
+ | |||
+ | // the data start is in S(Y) | ||
+ | // the data is in array K | ||
+ | // get the length of the data cvt to bin and stik in pos 1 2 | ||
+ | // put the rest in pos 3 onwards | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | // NUMERIC FIELD | ||
+ | // RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS | ||
+ | IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B'); | ||
+ | NU = '0'; | ||
+ | |||
+ | Z1 = 60; | ||
+ | FOR Z = K2 DOWNTO K1; | ||
+ | |||
+ | IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$'; | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | |||
+ | IF K(Z) = ' ' ; | ||
+ | NU(Z1) = '0'; | ||
+ | ELSE; | ||
+ | NU(Z1) = K(Z); | ||
+ | ENDIF; | ||
+ | |||
+ | Z1 = Z1 -1; | ||
+ | ENDFOR; | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // SIGNED FIELDS (END POSN = OFFSET + SIZE) | ||
+ | IF T(Y) = 'S'; | ||
+ | NUSA= *BLANKS; | ||
+ | FOR VX = 1 TO 60; | ||
+ | NUSA = %TRIM(NUSA) + NU(VX); | ||
+ | ENDFOR; | ||
+ | %SUBST(DATA : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y)); | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // PACKED FIELDS | ||
+ | IF T(Y) = 'P'; | ||
+ | NUSA= *BLANKS; | ||
+ | FOR VX = 1 TO 60; | ||
+ | NUSA = %TRIM(NUSA) + NU(VX); | ||
+ | ENDFOR; | ||
+ | NUP = %DEC(NUSA : 60 : 0); | ||
+ | |||
+ | %SUBST(DATA : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y)); | ||
+ | ENDIF; | ||
+ | |||
+ | // BINARY FIELDS | ||
+ | IF T(Y) = 'B'; | ||
+ | |||
+ | NUSA= *BLANKS; | ||
+ | FOR VX = 1 TO 60; | ||
+ | NUSA = %TRIM(NUSA) + NU(VX); | ||
+ | ENDFOR; | ||
+ | NUC = NUS; | ||
+ | |||
+ | IF Q(Y) = 2 ; | ||
+ | DISBIN ( NUC : BAN2 : BAN4 : '2'); | ||
+ | %SUBST(DATA : W : 2) = BAN2; | ||
+ | ENDIF; | ||
+ | |||
+ | IF Q(Y) = 4 ; | ||
+ | DISBIN ( NUC : BAN2 : BAN4 : '4'); | ||
+ | %SUBST(DATA : W : 4) = BAN4; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDIF; | ||
+ | |||
+ | // UPDATE KEY IF NECESSARY | ||
+ | IF KY(Y) = '1'; | ||
+ | CGKY = '1'; | ||
+ | EXSR @PCKMOV; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | ENDDO; | ||
+ | ENDFOR; | ||
+ | |||
+ | |||
+ | IF CGKY = '1'; | ||
+ | KEYA = KW; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | |||
+ | /END-FREE | ||
+ | |||
+ | OINPUTK E U1 UPDATREC | ||
+ | O DA | ||
+ | O 30 DB | ||
+ | O 31 DC | ||
+ | O 32 DD | ||
+ | O 33 DE | ||
+ | O 34 DF | ||
+ | O 35 DG | ||
+ | O 36 DH | ||
+ | O 37 DI | ||
+ | O 38 DJ | ||
+ | O 39 DK | ||
+ | O 40 DL | ||
+ | O 41 DM | ||
+ | O 42 DN | ||
+ | O 43 DZ | ||
+ | O 44 DO | ||
+ | O 45 DP | ||
+ | O 46 DQ | ||
+ | O 47 DR | ||
+ | O 48 DS | ||
+ | O 49 DT | ||
+ | O 50 DU | ||
+ | O 51 DV | ||
+ | O 52 DW | ||
+ | O 53 DX | ||
+ | O 54 DY | ||
+ | O 55 D0 | ||
+ | O 56 D1 | ||
+ | O 57 D2 | ||
+ | O 58 D3 | ||
+ | O 59 D4 | ||
+ | O 60 D5 | ||
+ | O 61 D6 | ||
+ | O 62 DBA | ||
+ | O 63 DCA | ||
+ | O 64 DDA | ||
+ | O 65 DEA | ||
+ | O 66 DFA | ||
+ | O 67 DGA | ||
+ | O 68 DHA | ||
+ | O 69 DIA | ||
+ | O 70 DJA | ||
+ | O 71 DKA | ||
+ | O 72 DLA | ||
+ | O 73 DMA | ||
+ | O 74 DNA | ||
+ | O 75 DOA | ||
+ | O 76 DPA | ||
+ | O 77 DQA | ||
+ | O 78 DRA | ||
+ | O 79 DSA | ||
+ | O 80 DTA | ||
+ | O 81 DUA | ||
+ | O 82 DVA | ||
+ | O 83 DWA | ||
+ | O 84 DXA | ||
+ | O 85 DYA | ||
+ | O 86 DZA | ||
+ | O 87 D0A | ||
+ | O 88 D1A | ||
+ | O 89 D2A | ||
+ | O 90 D3A | ||
+ | O 91 D4A | ||
+ | O 92 D5A | ||
+ | O 93 D6A | ||
+ | OINPUTR E U2 UPDATREC | ||
+ | O DA | ||
+ | O 30 DB | ||
+ | O 31 DC | ||
+ | O 32 DD | ||
+ | O 33 DE | ||
+ | O 34 DF | ||
+ | O 35 DG | ||
+ | O 36 DH | ||
+ | O 37 DI | ||
+ | O 38 DJ | ||
+ | O 39 DK | ||
+ | O 40 DL | ||
+ | O 41 DM | ||
+ | O 42 DN | ||
+ | O 43 DZ | ||
+ | O 44 DO | ||
+ | O 45 DP | ||
+ | O 46 DQ | ||
+ | O 47 DR | ||
+ | O 48 DS | ||
+ | O 49 DT | ||
+ | O 50 DU | ||
+ | O 51 DV | ||
+ | O 52 DW | ||
+ | O 53 DX | ||
+ | O 54 DY | ||
+ | O 55 D0 | ||
+ | O 56 D1 | ||
+ | O 57 D2 | ||
+ | O 58 D3 | ||
+ | O 59 D4 | ||
+ | O 60 D5 | ||
+ | O 61 D6 | ||
+ | O 62 DBA | ||
+ | O 63 DCA | ||
+ | O 64 DDA | ||
+ | O 65 DEA | ||
+ | O 66 DFA | ||
+ | O 67 DGA | ||
+ | O 68 DHA | ||
+ | O 69 DIA | ||
+ | O 70 DJA | ||
+ | O 71 DKA | ||
+ | O 72 DLA | ||
+ | O 73 DMA | ||
+ | O 74 DNA | ||
+ | O 75 DOA | ||
+ | O 76 DPA | ||
+ | O 77 DQA | ||
+ | O 78 DRA | ||
+ | O 79 DSA | ||
+ | O 80 DTA | ||
+ | O 81 DUA | ||
+ | O 82 DVA | ||
+ | O 83 DWA | ||
+ | O 84 DXA | ||
+ | O 85 DYA | ||
+ | O 86 DZA | ||
+ | O 87 D0A | ||
+ | O 88 D1A | ||
+ | O 89 D2A | ||
+ | O 90 D3A | ||
+ | O 91 D4A | ||
+ | O 92 D5A | ||
+ | O 93 D6A | ||
+ | |||
+ | OINPUTK EADD U1 ADDREC | ||
+ | O DA | ||
+ | O 30 DB | ||
+ | O 31 DC | ||
+ | O 32 DD | ||
+ | O 33 DE | ||
+ | O 34 DF | ||
+ | O 35 DG | ||
+ | O 36 DH | ||
+ | O 37 DI | ||
+ | O 38 DJ | ||
+ | O 39 DK | ||
+ | O 40 DL | ||
+ | O 41 DM | ||
+ | O 42 DN | ||
+ | O 43 DZ | ||
+ | O 44 DO | ||
+ | O 45 DP | ||
+ | O 46 DQ | ||
+ | O 47 DR | ||
+ | O 48 DS | ||
+ | O 49 DT | ||
+ | O 50 DU | ||
+ | O 51 DV | ||
+ | O 52 DW | ||
+ | O 53 DX | ||
+ | O 54 DY | ||
+ | O 55 D0 | ||
+ | O 56 D1 | ||
+ | O 57 D2 | ||
+ | O 58 D3 | ||
+ | O 59 D4 | ||
+ | O 60 D5 | ||
+ | O 61 D6 | ||
+ | O 62 DBA | ||
+ | O 63 DCA | ||
+ | O 64 DDA | ||
+ | O 65 DEA | ||
+ | O 66 DFA | ||
+ | O 67 DGA | ||
+ | O 68 DHA | ||
+ | O 69 DIA | ||
+ | O 70 DJA | ||
+ | O 71 DKA | ||
+ | O 72 DLA | ||
+ | O 73 DMA | ||
+ | O 74 DNA | ||
+ | O 75 DOA | ||
+ | O 76 DPA | ||
+ | O 77 DQA | ||
+ | O 78 DRA | ||
+ | O 79 DSA | ||
+ | O 80 DTA | ||
+ | O 81 DUA | ||
+ | O 82 DVA | ||
+ | O 83 DWA | ||
+ | O 84 DXA | ||
+ | O 85 DYA | ||
+ | O 86 DZA | ||
+ | O 87 D0A | ||
+ | O 88 D1A | ||
+ | O 89 D2A | ||
+ | O 90 D3A | ||
+ | O 91 D4A | ||
+ | O 92 D5A | ||
+ | O 93 D6A | ||
+ | OINPUTR EADD U2 ADDREC | ||
+ | O DA | ||
+ | O 30 DB | ||
+ | O 31 DC | ||
+ | O 32 DD | ||
+ | O 33 DE | ||
+ | O 34 DF | ||
+ | O 35 DG | ||
+ | O 36 DH | ||
+ | O 37 DI | ||
+ | O 38 DJ | ||
+ | O 39 DK | ||
+ | O 40 DL | ||
+ | O 41 DM | ||
+ | O 42 DN | ||
+ | O 43 DZ | ||
+ | O 44 DO | ||
+ | O 45 DP | ||
+ | O 46 DQ | ||
+ | O 47 DR | ||
+ | O 48 DS | ||
+ | O 49 DT | ||
+ | O 50 DU | ||
+ | O 51 DV | ||
+ | O 52 DW | ||
+ | O 53 DX | ||
+ | O 54 DY | ||
+ | O 55 D0 | ||
+ | O 56 D1 | ||
+ | O 57 D2 | ||
+ | O 58 D3 | ||
+ | O 59 D4 | ||
+ | O 60 D5 | ||
+ | O 61 D6 | ||
+ | O 62 DBA | ||
+ | O 63 DCA | ||
+ | O 64 DDA | ||
+ | O 65 DEA | ||
+ | O 66 DFA | ||
+ | O 67 DGA | ||
+ | O 68 DHA | ||
+ | O 69 DIA | ||
+ | O 70 DJA | ||
+ | O 71 DKA | ||
+ | O 72 DLA | ||
+ | O 73 DMA | ||
+ | O 74 DNA | ||
+ | O 75 DOA | ||
+ | O 76 DPA | ||
+ | O 77 DQA | ||
+ | O 78 DRA | ||
+ | O 79 DSA | ||
+ | O 80 DTA | ||
+ | O 81 DUA | ||
+ | O 82 DVA | ||
+ | O 83 DWA | ||
+ | O 84 DXA | ||
+ | O 85 DYA | ||
+ | O 86 DZA | ||
+ | O 87 D0A | ||
+ | O 88 D1A | ||
+ | O 89 D2A | ||
+ | O 90 D3A | ||
+ | O 91 D4A | ||
+ | O 92 D5A | ||
+ | O 93 D6A | ||
+ | |||
+ | OINPUTK EDEL U1 DELREC | ||
+ | OINPUTR EDEL U2 DELREC | ||
+ | |||
+ | |||
+ | ODISPF E DATAO | ||
+ | O K3 'PUT' | ||
+ | O OUTLEN 2 | ||
+ | O INLEN | ||
+ | O FNC | ||
+ | O A | ||
+ | |||
+ | O E DATAI | ||
+ | O K3 'GET' | ||
+ | O OUTLEN 2 | ||
+ | O INLEN | ||
+ | O FNC | ||
+ | O A | ||
+ | ** | ||
+ | 0000 INVALID COMMAND KEY | ||
+ | 0001 - A FIELD IS TOO LONG | ||
+ | 0002 - TOO MANY FIELDS | ||
+ | 0003 - ALPHAS IN PACKED KEY | ||
+ | 0004 - MISSING ' IN PACKED KEY | ||
+ | 0005 - MISSING DATA IN PCKD KEY | ||
+ | 0006 - RECORD NOT FOUND | ||
+ | PRESS RESET TO CONTINUE | ||
+ | ** | ||
+ | F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld | ||
+ | F1-HEX F2-Return F3-Exit F6-Update F9-Add F11-Del F19-Prev_fld F20-More_fld | ||
+ | ** | ||
+ | 0123456789ABCDEF | ||
+ | |||
+ | |||
+ | </pre> | ||
[[#top]] | [[#top]] | ||
+ | |||
===DISPF DSPF === | ===DISPF DSPF === | ||
Line 41: | Line 12,412: | ||
== WRAPPER CODE == | == WRAPPER CODE == | ||
+ | |||
+ | ===DSPFL CMD === | ||
+ | |||
+ | <pre> | ||
+ | /* TO COMPILE */ | ||
+ | /* CRTCMD CMD(*CURLIB/DSPFL) PGM(*LIBL/DIS) SRCFILE(*LIBL/QCMDSRC) */ | ||
+ | /* SRCMBR(DSPFL) VLDCKR(DISV) */ | ||
+ | |||
+ | CMD PROMPT('Display file in field format') | ||
+ | |||
+ | PARM KWD(FILE) TYPE(QUAL1) MIN(1) MAX(1) + | ||
+ | PROMPT('File') | ||
+ | |||
+ | PARM KWD(MBR) TYPE(*NAME) DFT(*FIRST) + | ||
+ | SPCVAL((*FILE) (*FIRST)) MIN(0) MAX(1) + | ||
+ | PROMPT('Member') | ||
+ | |||
+ | PARM KWD(UPD ) TYPE(*CHAR) LEN(1) DFT(N) + | ||
+ | RSTD(*YES) VALUES('Y' 'N' 'y' 'n') + | ||
+ | PROMPT('Update data (Y/N)') | ||
+ | |||
+ | PARM KWD(RST ) TYPE(*CHAR) LEN(1) DFT(N) + | ||
+ | RSTD(*YES) VALUES('Y' 'N' 'y' 'n') + | ||
+ | PROMPT('Get DDS again.') | ||
+ | |||
+ | PARM KWD(REL ) TYPE(*CHAR) LEN(1) DFT(N) + | ||
+ | RSTD(*YES) VALUES('Y' 'N' 'y' 'n') + | ||
+ | PROMPT('Show Relations') | ||
+ | |||
+ | |||
+ | QUAL1: QUAL TYPE(*NAME) LEN(10) | ||
+ | QUAL TYPE(*NAME) LEN(10) DFT(*LIBL ) + | ||
+ | SPCVAL(*LIBL ) + | ||
+ | PROMPT('Library name') | ||
+ | |||
+ | |||
+ | </pre> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | ===DIS CL === | ||
+ | |||
+ | <pre> | ||
+ | |||
+ | /* Command processing program for DSPFF command */ | ||
+ | |||
+ | PGM (&FILIB &MBR &UPD &RST &REL) | ||
+ | |||
+ | DCL &FILIB *CHAR 20 | ||
+ | DCL &FILE *CHAR 10 | ||
+ | DCL &LIB *CHAR 10 | ||
+ | DCL &SFILE *CHAR 10 | ||
+ | DCL &SLIB *CHAR 10 | ||
+ | DCL &MBR *CHAR 10 | ||
+ | DCL &OPT *CHAR 10 | ||
+ | DCL &ALL *CHAR 1 | ||
+ | DCL &RTN *CHAR 1 | ||
+ | DCL &RMBR *CHAR 10 | ||
+ | |||
+ | DCL &QRY *LGL | ||
+ | DCL &UPD *LGL | ||
+ | DCL &REL *CHAR 1 | ||
+ | DCL &RST *CHAR 1 | ||
+ | |||
+ | DCL &RCDL *CHAR 5 | ||
+ | DCL &RCDLN *DEC (5 0) | ||
+ | DCL &ACCP *CHAR 1 | ||
+ | DCL &OVR *LGL VALUE('0') | ||
+ | DCL &FILEF *CHAR 10 | ||
+ | DCL &FILEK *CHAR 10 | ||
+ | DCL &ID *CHAR 7 | ||
+ | DCL &MF *CHAR 10 | ||
+ | DCL &ML *CHAR 10 | ||
+ | DCL &TYPE *CHAR 1 | ||
+ | DCL &PHY *CHAR 10 | ||
+ | DCL &PHYLIB *CHAR 10 | ||
+ | |||
+ | RMVLIBLE QTEMP | ||
+ | MONMSG CPF0000 | ||
+ | ADDLIBLE QTEMP *FIRST | ||
+ | MONMSG CPF0000 EXEC(GOTO END) | ||
+ | |||
+ | RESET: | ||
+ | CHGVAR &FILE &FILIB | ||
+ | CHGVAR &LIB (%SST(&FILIB 11 10)) | ||
+ | IF (&LIB *EQ ' ') (CHGVAR &LIB '*LIBL') | ||
+ | IF (&MBR *EQ '*FILE') (CHGVAR &MBR &FILE) | ||
+ | IF (&MBR *EQ '*FIRST') (DO) | ||
+ | RTVMBRD FILE(&LIB/&FILE) RTNMBR(&RMBR) | ||
+ | CHGVAR &MBR &RMBR | ||
+ | ENDDO | ||
+ | CHGVAR &FILEF ('FF'||(%SST(&FILE 1 8))) | ||
+ | CHGVAR &FILEK ('KF'||(%SST(&FILE 1 8))) | ||
+ | |||
+ | IF (&RST= 'Y') DO | ||
+ | DLTF &FILEF | ||
+ | MONMSG CPF0000 | ||
+ | DLTF &FILEK | ||
+ | MONMSG CPF0000 | ||
+ | ENDDO | ||
+ | |||
+ | |||
+ | CHKOBJ (QTEMP/&FILEF) *FILE | ||
+ | MONMSG CPF9801 EXEC(DO) | ||
+ | DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEF) | ||
+ | DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEK) | ||
+ | CHGVAR &RTN '2' | ||
+ | ENDDO | ||
+ | |||
+ | CHGPF QTEMP/&FILEF LVLCHK(*NO) | ||
+ | CHGPF QTEMP/&FILEK LVLCHK(*NO) | ||
+ | |||
+ | IF (&REL = 'Y' ) DO | ||
+ | CALL DISF (&FILEK &TYPE &PHY &PHYLIB) | ||
+ | IF (&TYPE *EQ 'P') DO | ||
+ | CHGVAR &PHY &FILE | ||
+ | CHGVAR &PHYLIB &LIB | ||
+ | ENDDO | ||
+ | CALL DIS3 (&PHY &PHYLIB &SFILE &SLIB) | ||
+ | IF (&SFILE *NE ' ') DO | ||
+ | IF ((&SFILE *NE &FILE) *OR (&SLIB *NE &LIB)) DO | ||
+ | CHGVAR &FILIB (&SFILE||&SLIB) | ||
+ | CHGVAR &REL '0' | ||
+ | RTVMBRD FILE(&SLIB/&SFILE) RTNMBR(&RMBR) | ||
+ | CHGVAR &MBR &RMBR | ||
+ | IF (&MBR *EQ &FILE) THEN(CHGVAR &MBR '*FILE ') | ||
+ | GOTO RESET | ||
+ | ENDDO | ||
+ | ENDDO | ||
+ | ENDDO | ||
+ | |||
+ | CALL DIS1 (&FILIB &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK) | ||
+ | |||
+ | RCLRSC | ||
+ | |||
+ | END: | ||
+ | CLOF OPNID(&FILE) | ||
+ | MONMSG CPF0000 | ||
+ | |||
+ | |||
+ | |||
+ | ENDPGM | ||
+ | |||
+ | </pre> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | ===DIS1 CL === | ||
+ | |||
+ | <pre> | ||
+ | /* CALLED BY DIS TO DRIVE SELECTION OF UDDS RPG PROGRAM */ | ||
+ | /* FILE DISPLAYER DRIVER */ | ||
+ | /* SHOWS A LIST OF FIELDS IN A FILE , ALLOWS SELECTION OF FIELDS */ | ||
+ | |||
+ | /* WHEN ALL THE FIELDS DONT FIT ON ONE SCREEN */ | ||
+ | /* THIS CONTAINS A LOOP SO THAT MORE FIELDS CAN BE DISPLAYED */ | ||
+ | |||
+ | |||
+ | PGM (&FILIB &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK) | ||
+ | |||
+ | DCL &FILIB *CHAR 20 | ||
+ | DCL &FILE *CHAR 10 | ||
+ | DCL &LIB *CHAR 10 | ||
+ | DCL &MBR *CHAR 10 | ||
+ | DCL &PRG *CHAR 10 | ||
+ | DCL &OPT *CHAR 10 | ||
+ | DCL &ALL *CHAR 1 | ||
+ | DCL &RTN *CHAR 1 | ||
+ | DCL &RMV *CHAR 1 | ||
+ | DCL &QRY *LGL | ||
+ | DCL &UPD *CHAR 1 | ||
+ | DCL &RST *LGL | ||
+ | DCL &KEYL *CHAR 4 | ||
+ | DCL &RCDL *CHAR 5 | ||
+ | DCL &RCDLN *DEC (5 0) | ||
+ | DCL &ACCP *CHAR 1 | ||
+ | DCL &OVR *LGL VALUE('0') | ||
+ | DCL &FILEF *CHAR 10 | ||
+ | DCL &FILEK *CHAR 10 | ||
+ | DCL &ID *CHAR 7 | ||
+ | DCL &MF *CHAR 10 | ||
+ | DCL &ML *CHAR 10 | ||
+ | DCL &SCNLV *CHAR 500 | ||
+ | DCL &SCNLVL *CHAR 5 | ||
+ | DCL &SCNKEY *CHAR 800 | ||
+ | DCL &JOB *CHAR 10 | ||
+ | DCL &MSG *CHAR 80 | ||
+ | DCLF DISPX | ||
+ | |||
+ | CHGVAR &PGMQ DIS | ||
+ | CHGVAR &SCNLVL '00000' | ||
+ | |||
+ | OVRDBF FFD QTEMP/&FILEF SECURE(*YES) | ||
+ | OVRDBF KF QTEMP/&FILEK SECURE(*YES) | ||
+ | |||
+ | |||
+ | RTN: | ||
+ | OVRDBF INPUT &LIB/&FILE SHARE(*NO) | ||
+ | CALL DISPY (&ALL &RTN &KEYL &ACCP &QRY &RCDL) | ||
+ | MONMSG MSGID(CPF5035 CPF5029 RNQ1299 RNX0000) EXEC(DO) | ||
+ | RTVJOBA JOB(&JOB) | ||
+ | SNDBRKMSG MSG('Cannot handle this file type. Possibly + | ||
+ | has NULL data field.') TOMSGQ(&job) + | ||
+ | MSGTYPE(*INQ) RPYMSGQ(&job) | ||
+ | |||
+ | goto end | ||
+ | ENDDO | ||
+ | |||
+ | DLTOVR INPUT | ||
+ | MONMSG CPF0000 | ||
+ | |||
+ | IF (&RTN *EQ '1') (GOTO END) | ||
+ | |||
+ | IF (&ACCP *EQ 'K') DO | ||
+ | CHGJOB SWS(10XXXXXX) | ||
+ | OVRDBF FILE(INPUTK) TOFILE(&LIB/&FILE) MBR(&MBR) + | ||
+ | SHARE(*YES) SEQONLY(*NO) SECURE(*YES) | ||
+ | IF (&QRY ) DO | ||
+ | REMSG: | ||
+ | |||
+ | REQRY: SNDRCVF RCDFMT(SLT) | ||
+ | IF (&IN01 *OR &IN02) GOTO BYQRY | ||
+ | CHGVAR &OPT '*INP' | ||
+ | IF (&UPD *EQ 'Y') (CHGVAR &OPT '*ALL') | ||
+ | OPNQRYF FILE((INPUTK)) OPTION(&OPT) QRYSLT(&QSLT) + | ||
+ | KEYFLD(*FILE) SEQONLY(*NO) | ||
+ | MONMSG CPF9899 EXEC(DO) | ||
+ | RCVMSG MSGTYPE(*ANY) | ||
+ | SNDF RCDFMT(SLTC) | ||
+ | GOTO REMSG | ||
+ | ENDDO | ||
+ | ENDDO | ||
+ | ENDDO | ||
+ | BYQRY: | ||
+ | IF (&ACCP *EQ 'A') DO | ||
+ | CHGJOB SWS(01XXXXXX) | ||
+ | OVRDBF FILE(INPUTR) TOFILE(&LIB/&FILE) MBR(&MBR) + | ||
+ | SHARE(*YES) SEQONLY(*NO) SECURE(*YES) | ||
+ | IF (&QRY ) DO | ||
+ | REMSGA: | ||
+ | |||
+ | REQRYA: SNDRCVF RCDFMT(SLT) | ||
+ | IF (&IN01 *OR &IN02) GOTO BYQRYA | ||
+ | CHGVAR &OPT '*INP' | ||
+ | IF (&UPD = 'Y') (CHGVAR &OPT '*ALL') | ||
+ | OPNQRYF FILE((INPUTR)) OPTION(&OPT) QRYSLT(&QSLT) + | ||
+ | KEYFLD(*FILE) SEQONLY(*NO) | ||
+ | MONMSG CPF9899 EXEC(DO) | ||
+ | RCVMSG MSGTYPE(*ANY) | ||
+ | SNDF RCDFMT(SLTC) | ||
+ | GOTO REMSGA | ||
+ | CHGVAR VAR(&IN20) VALUE('1') | ||
+ | SDAMSG: RCVMSG RMV(*NO) MSG(&MSG) | ||
+ | IF COND(&MSG ¬= ' ') THEN(DO) | ||
+ | SNDPGMMSG MSG(&MSG) | ||
+ | GOTO SDAMSG | ||
+ | ENDDO | ||
+ | SNDF RCDFMT(SLTC) | ||
+ | GOTO REMSGA | ||
+ | ENDDO | ||
+ | |||
+ | ENDDO | ||
+ | ENDDO | ||
+ | BYQRYA: | ||
+ | CHGVAR &RCDLN &RCDL | ||
+ | |||
+ | IF ( &UPD= 'Y') (DO) | ||
+ | IF ((&RCDLN *GT 0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DUSP ') | ||
+ | IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DUSP1') | ||
+ | IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DUSP2') | ||
+ | ENDDO | ||
+ | IF (&UPD *NE 'Y') (DO) | ||
+ | IF ((&RCDLN *GT 0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DISP ') | ||
+ | IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DISP1') | ||
+ | IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DISP2') | ||
+ | ENDDO | ||
+ | |||
+ | |||
+ | CALL &PRG (&ALL &RTN &KEYL &UPD &SCNLV &SCNLVL &SCNKEY) | ||
+ | |||
+ | IF (&QRY ) (DO) | ||
+ | IF (&ACCP *EQ 'K') DO | ||
+ | CLOF INPUTK | ||
+ | MONMSG CPF0000 | ||
+ | ENDDO | ||
+ | IF (&ACCP *EQ 'A') DO | ||
+ | CLOF INPUTR | ||
+ | MONMSG CPF0000 | ||
+ | ENDDO | ||
+ | ENDDO | ||
+ | |||
+ | IF (&RTN *EQ '3') DO | ||
+ | GOTO BYQRYA | ||
+ | ENDDO | ||
+ | |||
+ | IF (&RTN *EQ '1') DO | ||
+ | CHGVAR &RTN '0' | ||
+ | GOTO RTN | ||
+ | ENDDO | ||
+ | |||
+ | |||
+ | |||
+ | END: ENDPGM | ||
+ | |||
+ | </pre> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | ===DIS3 CL === | ||
+ | |||
+ | <pre> | ||
+ | |||
+ | /* CALL BY DIS TO SHOW FILE RELATIONS / ACCESS PATHS */ | ||
+ | |||
+ | PGM (&PHY &PHYLIB &SFILE &SLIB) | ||
+ | |||
+ | /* DISPLAY ACCESS PATHS */ | ||
+ | |||
+ | DCL &PHY *CHAR 10 | ||
+ | DCL &PHYLIB *CHAR 10 | ||
+ | DCL &SFILE *CHAR 10 | ||
+ | DCL &SLIB *CHAR 10 | ||
+ | |||
+ | |||
+ | DCLF QTEMP/DBR | ||
+ | |||
+ | /* CREATE WORK FILES */ | ||
+ | CALL DIS4 | ||
+ | |||
+ | DLTF QTEMP/DBR | ||
+ | MONMSG CPF0000 | ||
+ | |||
+ | DSPDBR FILE(&PHYLIB/&PHY) OUTPUT(*OUTFILE) + | ||
+ | OUTFILE(QTEMP/DBR) OUTMBR(*FIRST *REPLACE) | ||
+ | CHGPF QTEMP/DBR LVLCHK(*NO) | ||
+ | |||
+ | NEXT: RCVF | ||
+ | MONMSG CPF0000 EXEC(GOTO END) | ||
+ | IF (&WHREFI *NE ' ') DO | ||
+ | DSPFD FILE(&WHRELI/&WHREFI) TYPE(*ACCPTH) + | ||
+ | OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD) | ||
+ | CHGPF QTEMP/REL LVLCHK(*NO) | ||
+ | DSPFD FILE(&WHRELI/&WHREFI) TYPE(*SELECT) + | ||
+ | OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL) OUTMBR(*FIRST *ADD) | ||
+ | CHGPF QTEMP/SEL LVLCHK(*NO) | ||
+ | ENDDO | ||
+ | GOTO NEXT | ||
+ | |||
+ | END: | ||
+ | DSPFD FILE(&PHYLIB/&PHY ) TYPE(*ACCPTH) + | ||
+ | OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD) | ||
+ | CHGPF QTEMP/REL LVLCHK(*NO) | ||
+ | |||
+ | CHGVAR &SFILE ' ' | ||
+ | CHGVAR &SLIB ' ' | ||
+ | |||
+ | OVRDBF SEL QTEMP/SEL | ||
+ | OVRDBF REL QTEMP/REL | ||
+ | CALL DISPR (&SFILE &SLIB) | ||
+ | DLTOVR *ALL | ||
+ | |||
+ | ENDPGM | ||
+ | |||
+ | </pre> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | ===DIS4 CL === | ||
+ | |||
+ | <pre> | ||
+ | |||
+ | /* CALL BY DIS3 TO CREATE WORK FILES */ | ||
+ | |||
+ | PGM | ||
+ | |||
+ | DCL &LIB *CHAR 10 | ||
+ | DCL &SRCF *CHAR 10 | ||
+ | |||
+ | RTVDTAARA DTAARA(UDDSSRC *ALL) RTNVAR(&SRCF) | ||
+ | |||
+ | DLTF QTEMP/XXXXFILE | ||
+ | monmsg cpf0000 | ||
+ | CRTPF FILE(QTEMP/XXXXFILE) RCDLEN(80) OPTION(*NOLIST) | ||
+ | |||
+ | DSPFFD FILE(QTEMP/XXXXFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) | ||
+ | CLRPFM QTEMP/FFD | ||
+ | DLTF FILE(QTEMP/FFDL01) | ||
+ | MONMSG CPF0000 | ||
+ | |||
+ | RTVMBRD FILE(&SRCF) RTNLIB(&LIB) | ||
+ | CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) + | ||
+ | OPTION(*NOSRC *NOLIST) | ||
+ | |||
+ | DLTF FILE(QTEMP/REL) | ||
+ | MONMSG CPF0000 | ||
+ | DLTF FILE(QTEMP/SEL) | ||
+ | MONMSG CPF0000 | ||
+ | DLTF FILE(QTEMP/DBR) | ||
+ | MONMSG CPF0000 | ||
+ | |||
+ | DSPFD FILE(QTEMP/FFD) TYPE(*ACCPTH) + | ||
+ | OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD) | ||
+ | |||
+ | DSPFD FILE(QTEMP/FFDL01) TYPE(*SELECT) OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL) | ||
+ | CLRPFM FILE(QTEMP/REL) | ||
+ | CLRPFM FILE(QTEMP/SEL) | ||
+ | |||
+ | DLTF QTEMP/XXXXFILE | ||
+ | monmsg cpf0000 | ||
+ | |||
+ | |||
+ | ENDPGM | ||
+ | |||
+ | </pre> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | ===DISBIN CL === | ||
+ | |||
+ | <pre> | ||
+ | /* NUMERIC TO BINARY CONVERTER */ | ||
+ | |||
+ | |||
+ | PGM (&NUM &BIN2 &BIN4 &BINTYP ) | ||
+ | |||
+ | DCL VAR(&NUM) TYPE(*DEC) LEN(15 0) | ||
+ | DCL VAR(&BINTYP) TYPE(*CHAR) LEN(1) | ||
+ | DCL VAR(&BIN2) TYPE(*CHAR) LEN(2) | ||
+ | DCL VAR(&BIN4) TYPE(*CHAR) LEN(4) | ||
+ | |||
+ | IF (&BINTYP = '4') (CHGVAR %BIN(&BIN4) &NUM) | ||
+ | IF (&BINTYP = '2') (CHGVAR %BIN(&BIN2) &NUM) | ||
+ | ENDPGM | ||
+ | |||
+ | </pre> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | ===DISF CL === | ||
+ | |||
+ | <pre> | ||
+ | |||
+ | /* CHECK FILE TYPE */ | ||
+ | |||
+ | PGM (&DISF &TYPE &PHY &PHYLIB) | ||
+ | |||
+ | |||
+ | DCL &DISF *CHAR 10 | ||
+ | DCL &TYPE *CHAR 1 | ||
+ | DCL &PHY *CHAR 10 | ||
+ | DCL &PHYLIB *CHAR 10 | ||
+ | DCLF KF | ||
+ | |||
+ | OVRDBF FILE(KF) TOFILE(QTEMP/&DISF) | ||
+ | OPNDBF FILE(KF) OPTION(*INP) | ||
+ | RCVF | ||
+ | CHGVAR &TYPE &APFTYP | ||
+ | |||
+ | IF (&TYPE *EQ 'L') DO | ||
+ | CHGVAR &PHY &APBOF | ||
+ | CHGVAR &PHYLIB &APBOL | ||
+ | ENDDO | ||
+ | |||
+ | CLOF OPNID(KF) | ||
+ | ENDPGM | ||
+ | |||
+ | </pre> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | |||
+ | |||
+ | ===DISV CL === | ||
+ | |||
+ | <pre> | ||
+ | /* VALIDITY CHECKER FOR DSPFL COMMAND */ | ||
+ | |||
+ | |||
+ | PGM (&FILIB &MBR &UPD &RST &REL) | ||
+ | |||
+ | DCL &FILIB *CHAR 20 | ||
+ | DCL &FILE *CHAR 10 | ||
+ | DCL &LIB *CHAR 10 | ||
+ | DCL &MBR *CHAR 10 | ||
+ | DCL &UPD *CHAR 1 | ||
+ | DCL &RST *CHAR 1 | ||
+ | DCL &REL *CHAR 1 | ||
+ | DCL &OBJATR *CHAR 10 | ||
+ | DCL &AUT *CHAR 8 | ||
+ | |||
+ | DCL &MSGDTA *CHAR 40 | ||
+ | DCL &ERROR *LGL | ||
+ | |||
+ | CHGVAR &FILE &FILIB | ||
+ | CHGVAR &LIB (%SST(&FILIB 11 10)) | ||
+ | IF (&MBR *EQ '*FILE') (CHGVAR &MBR &FILE ) | ||
+ | |||
+ | CHGVAR &AUT '*READ ' | ||
+ | IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE') | ||
+ | |||
+ | CHKOBJ (&LIB/&FILE) OBJTYPE(*FILE) MBR(*NONE) + | ||
+ | AUT( &AUT ) | ||
+ | MONMSG (CPF9899 CPF9801 CPF9802 CPF9820 CPF9830) EXEC(DO) | ||
+ | /* CHGVAR (&MSGDTA) VALUE(' '||&FILE||&LIB) */ | ||
+ | /* SNDPGMMSG MSGID(USR0006) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) +*/ | ||
+ | /* MSGDTA(&MSGDTA) */ | ||
+ | SNDPGMMSG MSG('Not authorised to the file.') + | ||
+ | MSGTYPE(*DIAG) | ||
+ | CHGVAR (&ERROR) '1' | ||
+ | ENDDO | ||
+ | MONMSG (CPF9810) EXEC(DO) | ||
+ | CHGVAR (&MSGDTA) VALUE(' '||&LIB) | ||
+ | /* SNDPGMMSG MSGID(USR0008) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) +*/ | ||
+ | /* MSGDTA(&MSGDTA) */ | ||
+ | SNDPGMMSG MSG('Not authorised to the file.') + | ||
+ | MSGTYPE(*DIAG) | ||
+ | CHGVAR (&ERROR) '1' | ||
+ | ENDDO | ||
+ | |||
+ | |||
+ | IF (*NOT &ERROR) DO | ||
+ | |||
+ | RTVOBJD OBJ(&LIB/&FILE) OBJTYPE(*FILE) OBJATR(&OBJATR) | ||
+ | CHGVAR &AUT '*READ ' | ||
+ | IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE') | ||
+ | |||
+ | CHKOBJ OBJ(&LIB/&FILE) OBJTYPE(*FILE) MBR(&MBR) + | ||
+ | AUT(&AUT) | ||
+ | |||
+ | MONMSG (CPF9815 ) EXEC(DO) | ||
+ | /* CHGVAR (&MSGDTA) VALUE(' '||&MBR||&FILE||&LIB) */ | ||
+ | /* SNDPGMMSG MSGID(USR0007) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */ | ||
+ | /* MSGDTA(&MSGDTA) */ | ||
+ | SNDPGMMSG MSG('Not authorised to the file.') + | ||
+ | MSGTYPE(*DIAG) | ||
+ | CHGVAR (&ERROR) '1' | ||
+ | ENDDO | ||
+ | MONMSG (CPF0000 ) EXEC(DO) | ||
+ | /* SNDPGMMSG MSGID(USR0022) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */ | ||
+ | /* MSGDTA(&MSGDTA) */ | ||
+ | SNDPGMMSG MSG('Not authorised to the file.') + | ||
+ | MSGTYPE(*DIAG) | ||
+ | CHGVAR (&ERROR) '1' | ||
+ | ENDDO | ||
+ | ENDDO | ||
+ | |||
+ | IF (&ERROR) (SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE)) | ||
+ | |||
+ | |||
+ | |||
+ | ENDPGM | ||
+ | |||
+ | </pre> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | |||
===DISPR RPG === | ===DISPR RPG === | ||
<pre> | <pre> | ||
+ | H OPTIMIZE(*NONE) OPTION(*NODEBUGIO) | ||
+ | H DFTACTGRP(*NO) ACTGRP(*CALLER) | ||
+ | |||
+ | * FILE RELATIONS DISPLAYER | ||
+ | * REQUIRES FILES TO COMPILE | ||
+ | * | ||
+ | |||
+ | FREL IF E DISK | ||
+ | FSEL IF E DISK | ||
+ | FDISPRF CF E WORKSTN | ||
+ | F SFILE(S01:RS01) | ||
+ | F SFILE(S02:RS02) | ||
+ | F INFDS(SFINF) | ||
+ | * | ||
+ | |||
+ | * | ||
+ | DDISPR PR | ||
+ | D 10 | ||
+ | D 10 | ||
+ | DDISPR PI | ||
+ | D SFILE 10 | ||
+ | D SLIB 10 | ||
+ | |||
+ | // SCREEN LEVELS | ||
+ | D @SCN S 6 DIM(50) | ||
+ | D @NSCN S 6 | ||
+ | D @LV S 5 0 | ||
+ | D @ERR S LIKE(@TRUE) | ||
+ | D @FILE S 10A INZ('DISPY ') | ||
+ | D WRKSWS S 1 | ||
+ | D I S 4B 0 | ||
+ | |||
+ | |||
+ | D @TRUE S 1A INZ('1') | ||
+ | D @FALSE S 1A INZ('0') | ||
+ | D @OK S LIKE(@TRUE) | ||
+ | D @LOOP S LIKE(@TRUE) | ||
+ | |||
+ | // | ||
+ | D RS01 S 4S 0 | ||
+ | D RS02 S 4S 0 | ||
+ | // | ||
+ | // PARMS FOR SFL LOOPING | ||
+ | D SFC01 S LIKE(RS01) | ||
+ | D SFC02 S LIKE(RS01) | ||
+ | |||
+ | // Program Status | ||
+ | D SDS | ||
+ | D PGM 1 10 | ||
+ | D WSID 244 253 | ||
+ | D USER 254 263 | ||
+ | // | ||
+ | // | ||
+ | D SFINF DS | ||
+ | D RRRN 376 377B 0 | ||
+ | D SRN 378 379B 0 | ||
+ | |||
+ | // MESSAGE DATA | ||
+ | D @DTA1 DS 80 | ||
+ | D @DTA2 DS 500 | ||
+ | // | ||
+ | D MAIN PR | ||
+ | |||
+ | D @S01BLD PR | ||
+ | D @S01PRC PR | ||
+ | D @S01PRS PR | ||
+ | D @S02BLD PR | ||
+ | D @S02PRC PR | ||
+ | D | ||
+ | D @R9999 PR | ||
+ | |||
+ | D @OPADJ PR 2A | ||
+ | D OPT 2A | ||
+ | |||
+ | |||
+ | /FREE | ||
+ | *INLR = *ON; | ||
+ | MAIN(); | ||
+ | |||
+ | |||
+ | //--------------*INZSR-------------------------------// | ||
+ | BEGSR *INZSR; | ||
+ | |||
+ | // Set the TOP level (Exit if user backs up to here) | ||
+ | @LV = 1; | ||
+ | @SCN(@LV) = '*END '; | ||
+ | // Set the Initial Screen to display | ||
+ | @LV = @LV + 1; | ||
+ | @SCN(@LV) = 'S01BLD '; | ||
+ | |||
+ | ENDSR; | ||
+ | /END-FREE | ||
+ | //###################################################// | ||
+ | |||
+ | //************************************************************* | ||
+ | P MAIN B | ||
+ | |||
+ | D MAIN PI | ||
+ | |||
+ | D I S 4B 0 | ||
+ | |||
+ | /FREE | ||
+ | EXSR @INZSR; | ||
+ | // | ||
+ | // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY | ||
+ | DOW @LOOP = @LOOP; | ||
+ | // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY | ||
+ | @NSCN = @SCN(@LV); | ||
+ | SELECT; | ||
+ | // SELECT FIELDS FOR DISPLAY | ||
+ | |||
+ | // SFL TO SELECT THE FILE FIELDS | ||
+ | WHEN @NSCN = 'S01BLD'; | ||
+ | @S01BLD(); | ||
+ | WHEN @NSCN = 'S01PRC'; | ||
+ | @S01PRC(); | ||
+ | WHEN @NSCN = 'S01PRS'; | ||
+ | @S01PRS(); | ||
+ | WHEN @NSCN = 'S02BLD'; | ||
+ | @S02BLD(); | ||
+ | WHEN @NSCN = 'S02PRC'; | ||
+ | @S02PRC(); | ||
+ | OTHER; | ||
+ | // CATCH ALL (NEVER USED) | ||
+ | @R9999(); | ||
+ | LEAVE; | ||
+ | ENDSL; | ||
+ | |||
+ | // CF3 EXIT | ||
+ | IF *IN03 = *ON; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // CF12 PREVIOUS | ||
+ | IF *IN12 = *ON; | ||
+ | *IN12 = *OFF; | ||
+ | @LV = @LV -1; | ||
+ | @NSCN = @SCN(@LV); | ||
+ | ENDIF; | ||
+ | |||
+ | // Backed out to last level, Exit | ||
+ | IF @NSCN = '*END'; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDDO; | ||
+ | |||
+ | RETURN; | ||
+ | |||
+ | //--------------*INZSR-------------------------------// | ||
+ | BEGSR @INZSR; | ||
+ | @NSCN = *BLANK; | ||
+ | |||
+ | ENDSR; | ||
+ | //-ENDSR---*INZSR-------------------------------// | ||
+ | /END-FREE | ||
+ | |||
+ | P MAIN E | ||
+ | |||
+ | |||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | /space 3 | ||
+ | P @S01BLD B | ||
+ | |||
+ | D @S01BLD PI | ||
+ | |||
+ | D WFILE S LIKE(APFILE ) | ||
+ | D WLIB S LIKE(APLIB ) | ||
+ | |||
+ | // Build/Rebuild the subfile | ||
+ | |||
+ | /FREE | ||
+ | EXSR @INZSR; | ||
+ | |||
+ | EXSR BLD; | ||
+ | |||
+ | // SFL IS BUILT, PROCESS THE SFL CONTROL | ||
+ | @LV = @LV + 1; | ||
+ | @SCN(@LV) = 'S01PRC ' ; | ||
+ | RETURN ; | ||
+ | |||
+ | //-------------- BLD -------------------------------// | ||
+ | BEGSR BLD; | ||
+ | |||
+ | EXSR CLR; | ||
+ | |||
+ | |||
+ | SETLL 1 QWHFDACP; | ||
+ | |||
+ | DOW @LOOP = @LOOP; | ||
+ | READ QWHFDACP; | ||
+ | IF %EOF; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | EXSR MOV; | ||
+ | // | ||
+ | RS01 = RS01 + 1; | ||
+ | WRITE S01; | ||
+ | ENDDO; | ||
+ | |||
+ | |||
+ | // Position to TOP of subfile | ||
+ | SRS01 = 1; | ||
+ | SFC01 = RS01; | ||
+ | ENDSR; | ||
+ | |||
+ | //-------------- CLR -------------------------------// | ||
+ | BEGSR CLR; | ||
+ | |||
+ | *IN51 = *OFF; | ||
+ | *IN52 = *OFF; | ||
+ | *IN53 = *ON; | ||
+ | WRITE C01; | ||
+ | *IN53 = *OFF; | ||
+ | RS01 = 0 ; | ||
+ | SFC01 = 0 ; | ||
+ | S01FUNC = *BLANK; | ||
+ | ENDSR; | ||
+ | |||
+ | //-------------- MOV -------------------------------// | ||
+ | BEGSR MOV; | ||
+ | |||
+ | C01APBOF = APBOF ; | ||
+ | C01APBOL = APBOL ; | ||
+ | |||
+ | IF APBOF = *BLANK AND APBOL = *BLANK; | ||
+ | C01APBOF = APFILE; | ||
+ | C01APBOL = APLIB; | ||
+ | ENDIF; | ||
+ | |||
+ | // Load the subfile record | ||
+ | |||
+ | IF APFILE = WFILE AND | ||
+ | APLIB = WLIB ; | ||
+ | *IN56 = *ON ; | ||
+ | S01APFILE = *BLANK; | ||
+ | S01APLIB = *BLANK; | ||
+ | S01APACCP = *BLANK; | ||
+ | S01APUNIQ = *BLANK; | ||
+ | S01APSELO = *BLANK; | ||
+ | S01APFTYP = *BLANK; | ||
+ | S01APJOIN = *BLANK; | ||
+ | S01APKEYO = *BLANK; | ||
+ | S01APKSEQ = APKSEQ ; | ||
+ | S01APKSIN = APKSIN ; | ||
+ | S01APKEYF = APKEYF ; | ||
+ | ELSE ; | ||
+ | WFILE = APFILE; | ||
+ | WLIB = APLIB ; | ||
+ | *IN56 = *OFF; | ||
+ | S01APFILE = APFILE ; | ||
+ | S01APLIB = APLIB ; | ||
+ | S01APACCP = APACCP ; | ||
+ | S01APUNIQ = APUNIQ ; | ||
+ | S01APSELO = APSELO ; | ||
+ | S01APFTYP = APFTYP ; | ||
+ | S01APJOIN = APJOIN ; | ||
+ | S01APKEYO = APKEYO ; | ||
+ | S01APKSEQ = APKSEQ ; | ||
+ | S01APKSIN = APKSIN ; | ||
+ | S01APKEYF = APKEYF ; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | //--------------*INZSR-------------------------------// | ||
+ | BEGSR @INZSR; | ||
+ | @NSCN = *BLANK; | ||
+ | ENDSR; | ||
+ | /END-FREE | ||
+ | |||
+ | P @S01BLD E | ||
+ | |||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | |||
+ | /space 3 | ||
+ | P @S01PRC B | ||
+ | |||
+ | D @S01PRC PI | ||
+ | |||
+ | // | ||
+ | // | ||
+ | D WRKRC S 4S 0 | ||
+ | |||
+ | /FREE | ||
+ | EXSR @INZSR; | ||
+ | |||
+ | WRITE R01; | ||
+ | // | ||
+ | DOW @LOOP = @LOOP; | ||
+ | |||
+ | // | ||
+ | // Write SFL Control | ||
+ | IF SFC01 > 0; | ||
+ | *IN51 = *ON; | ||
+ | ENDIF; | ||
+ | *IN52 = *ON; | ||
+ | |||
+ | |||
+ | EXFMT C01; | ||
+ | // Setoff errors | ||
+ | *IN89 = *OFF; | ||
+ | // | ||
+ | // Exit and Previous Screen | ||
+ | IF *IN03 = *ON; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | IF *IN12 = *ON; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // Process the subfile | ||
+ | @LV = @LV + 1; | ||
+ | @SCN(@LV) = 'S01PRS'; | ||
+ | LEAVE; | ||
+ | |||
+ | ENDDO; | ||
+ | // | ||
+ | RETURN; | ||
+ | |||
+ | /space 3 | ||
+ | |||
+ | |||
+ | //--------------*INZSR-------------------------------// | ||
+ | BEGSR @INZSR; | ||
+ | @NSCN = *BLANK; | ||
+ | ENDSR; | ||
+ | /END-FREE | ||
+ | P @S01PRC E | ||
+ | |||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | /space 3 | ||
+ | P @S01PRS B | ||
+ | |||
+ | D @S01PRS PI | ||
+ | |||
+ | // | ||
+ | // | ||
+ | D WRKRC S 4S 0 | ||
+ | |||
+ | /FREE | ||
+ | |||
+ | EXSR @INZSR; | ||
+ | |||
+ | // Process the subfile | ||
+ | EXSR SFL; | ||
+ | RETURN; | ||
+ | |||
+ | //-------------- SFL -------------------------------// | ||
+ | BEGSR SFL; | ||
+ | // Process the subfile | ||
+ | |||
+ | FOR WRKRC = 1 TO SFC01 + 1 ; | ||
+ | CHAIN WRKRC S01; | ||
+ | IF NOT %FOUND; | ||
+ | // Finished with the subfile | ||
+ | @LV = @LV -1; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // GET SELECTED FILE | ||
+ | IF @OPADJ(S01FUNC) = ' X'; | ||
+ | SFILE = S01APFILE; | ||
+ | SLIB = S01APLIB ; | ||
+ | *IN03 = '1'; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | |||
+ | // SHOW SELECT RULES | ||
+ | IF @OPADJ(S01FUNC) = ' R'; | ||
+ | @LV = @LV + 1; | ||
+ | @SCN(@LV) = 'S02BLD '; | ||
+ | S01FUNC = ' '; | ||
+ | UPDATE S01; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDFOR; | ||
+ | |||
+ | ENDSR; | ||
+ | //---------------------------------------------------// | ||
+ | |||
+ | |||
+ | |||
+ | //--------------*INZSR-------------------------------// | ||
+ | BEGSR @INZSR; | ||
+ | @NSCN = *BLANK; | ||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | /END-FREE | ||
+ | P @S01PRS E | ||
+ | |||
+ | |||
+ | /space 3 | ||
+ | P @S02BLD B | ||
+ | |||
+ | D @S02BLD PI | ||
+ | |||
+ | // Build/Rebuild the subfile | ||
+ | /FREE | ||
+ | |||
+ | EXSR @INZSR; | ||
+ | |||
+ | C02APFILE = S01APFILE ; | ||
+ | C02APLIB = S01APLIB ; | ||
+ | |||
+ | EXSR BLD; | ||
+ | |||
+ | // SFL IS BUILT, PROCESS THE CONTROL | ||
+ | @LV = @LV + 1; | ||
+ | @SCN(@LV) = 'S02PRC '; | ||
+ | RETURN; | ||
+ | //-------------- BLD -------------------------------// | ||
+ | BEGSR BLD; | ||
+ | |||
+ | EXSR CLR; | ||
+ | |||
+ | |||
+ | SETLL 1 QWHFDSO ; | ||
+ | |||
+ | DOW @LOOP = @LOOP; | ||
+ | |||
+ | READ QWHFDSO ; | ||
+ | IF %EOF; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | If SOFILE = S01APFILE AND | ||
+ | SOLIB = S01APLIB ; | ||
+ | EXSR MOV; | ||
+ | |||
+ | // | ||
+ | RS02 = RS02 + 1; | ||
+ | WRITE S02; | ||
+ | ENDIF; | ||
+ | ENDDO; | ||
+ | |||
+ | // Position to TOP of subfile | ||
+ | SRS02 = 1; | ||
+ | SFC02 = RS02; | ||
+ | ENDSR; | ||
+ | |||
+ | //-------------- CLR -------------------------------// | ||
+ | BEGSR CLR; | ||
+ | *IN51 = *OFF; | ||
+ | *IN52 = *OFF; | ||
+ | *IN53 = *ON; | ||
+ | WRITE C02; | ||
+ | *IN53 = *OFF; | ||
+ | RS02 =0; | ||
+ | SFC02=0; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | //-------------- MOV -------------------------------// | ||
+ | BEGSR MOV; | ||
+ | // Load the subfile record | ||
+ | |||
+ | S02SOFLD = SOFLD ; | ||
+ | S02SORULE = SORULE ; | ||
+ | S02SOCOMP = SOCOMP ; | ||
+ | S02SOVALU = SOVALU ; | ||
+ | |||
+ | |||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | //--------------*INZSR-------------------------------// | ||
+ | BEGSR @INZSR; | ||
+ | @NSCN = *BLANK; | ||
+ | ENDSR; | ||
+ | |||
+ | /END-FREE | ||
+ | P @S02BLD E | ||
+ | |||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | /space 3 | ||
+ | P @S02PRC B | ||
+ | |||
+ | D @S02PRC PI | ||
+ | |||
+ | // | ||
+ | // | ||
+ | D WRKRC S 4S 0 | ||
+ | |||
+ | /FREE | ||
+ | |||
+ | EXSR @INZSR; | ||
+ | |||
+ | WRITE R02; | ||
+ | |||
+ | // | ||
+ | DOW @LOOP = @LOOP; | ||
+ | |||
+ | // | ||
+ | // Write SFL Control | ||
+ | IF SFC02 > 0; | ||
+ | *IN51 = *ON; | ||
+ | ENDIF; | ||
+ | *IN52 = *ON; | ||
+ | EXFMT C02; | ||
+ | // | ||
+ | // Setoff errors | ||
+ | *IN89 = *OFF; | ||
+ | // | ||
+ | // Exit and Previous Screen | ||
+ | |||
+ | @LV = @LV -2; | ||
+ | LEAVE; | ||
+ | |||
+ | |||
+ | // Process the subfile | ||
+ | |||
+ | ENDDO; | ||
+ | // | ||
+ | RETURN; | ||
+ | |||
+ | /space 3 | ||
+ | //--------------*INZSR-------------------------------// | ||
+ | BEGSR @INZSR; | ||
+ | |||
+ | @NSCN = *BLANK; | ||
+ | ENDSR; | ||
+ | /END-FREE | ||
+ | P @S02PRC E | ||
+ | |||
+ | |||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | |||
+ | P @R9999 B | ||
+ | // Invalid Panel | ||
+ | D @R9999 PI | ||
+ | |||
+ | P @R9999 E | ||
+ | |||
+ | |||
+ | /space 3 | ||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | P @OPADJ B | ||
+ | // RIGHT ADJ OPTION , zero suppress | ||
+ | |||
+ | D @OPADJ PI 2A | ||
+ | D OPT 2A | ||
+ | |||
+ | /FREE | ||
+ | EVALR OPT = %trimr(OPT); | ||
+ | If %SubSt(OPT:1:1) = '0'; | ||
+ | OPT = ' ' + %SubSt(OPT:2:1); | ||
+ | EndIf; | ||
+ | RETURN OPT; | ||
+ | /END-FREE | ||
+ | P @OPADJ E | ||
+ | |||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | |||
+ | </pre> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | ===DISPRF DSPF === | ||
+ | |||
+ | <pre> | ||
+ | |||
+ | A*%%TS SD 20101208 163705 KOLMANNF REL-V5R4M0 5722-WDS | ||
+ | A* | ||
+ | * REQUIRES FILES TO COMPILE | ||
+ | * CRTDUPOBJ OBJ(QAFDSELO) FROMLIB(QSYS) | ||
+ | * OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(SEL) | ||
+ | * CRTDUPOBJ OBJ(QAFDACCP) FROMLIB(QSYS) | ||
+ | * OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(ACC) | ||
+ | |||
+ | |||
+ | A*%%EC | ||
+ | A DSPSIZ(24 80 *DS3) | ||
+ | A PRINT | ||
+ | A CF03(03) | ||
+ | A CF12(12) | ||
+ | A R S01 SFL | ||
+ | A*%%TS SD 20101208 163705 KOLMANNF REL-V5R4M0 5722-WDS | ||
+ | A S01FUNC 2A I 4 3 | ||
+ | A 55 | ||
+ | AO 56 DSPATR(PR) | ||
+ | A S01APFILE R O 4 6REFFLD(QWHFDACP/APFILE QTEMP/REL) | ||
+ | A S01APLIB R O 4 17REFFLD(QWHFDACP/APLIB QTEMP/REL) | ||
+ | A S01APACCP R O 4 29REFFLD(QWHFDACP/APACCP QTEMP/REL) | ||
+ | A S01APUNIQ R O 4 33REFFLD(QWHFDACP/APUNIQ QTEMP/REL) | ||
+ | A S01APSELO R O 4 37REFFLD(QWHFDACP/APSELO QTEMP/REL) | ||
+ | A S01APFTYP R O 4 41REFFLD(QWHFDACP/APFTYP QTEMP/REL) | ||
+ | A S01APJOIN R O 4 45REFFLD(QWHFDACP/APJOIN QTEMP/REL) | ||
+ | A S01APKEYO R O 4 48REFFLD(QWHFDACP/APKEYO QTEMP/REL) | ||
+ | A S01APKSEQ R O 4 53REFFLD(QWHFDACP/APKSEQ QTEMP/REL) | ||
+ | A S01APKSIN R O 4 57REFFLD(QWHFDACP/APKSIN QTEMP/REL) | ||
+ | A S01APKEYF R O 4 61REFFLD(QWHFDACP/APKEYF QTEMP/REL) | ||
+ | A R C01 SFLCTL(S01) | ||
+ | A*%%TS SD 20101208 163705 KOLMANNF REL-V5R4M0 5722-WDS | ||
+ | A SFLSIZ(0019) | ||
+ | A SFLPAG(0018) | ||
+ | A OVERLAY | ||
+ | A 50 SFLEND | ||
+ | A 51 SFLDSP | ||
+ | A 52 SFLDSPCTL | ||
+ | A 53 SFLCLR | ||
+ | A SRS01 4S 0H SFLRCDNBR(CURSOR) | ||
+ | A* | ||
+ | A 1 18'FILE RELATIONS for ' | ||
+ | A C01APBOF R O 1 39REFFLD(QWHFDACP/APBOF QTEMP/REL) | ||
+ | A 1 51'Lib.' | ||
+ | A C01APBOL R O 1 56REFFLD(QWHFDACP/APBOL QTEMP/REL) | ||
+ | A 2 32'Uni SEL LIFO ASC Key' | ||
+ | A 3 6'File Library Acc Key OMT - | ||
+ | A TYP J FIFO DSC Sgn Key' | ||
+ | A R R01 | ||
+ | A 24 3'F3-Exit' | ||
+ | A 22 3'R - Display Select/Omit rules' | ||
+ | A 23 3'X - Select for display' | ||
+ | * | ||
+ | A R R02 | ||
+ | A 24 3'F3-Exit' | ||
+ | A R S02 SFL | ||
+ | A SFLNXTCHG | ||
+ | A S02SOFLD R O 4 4REFFLD(QWHFDSO/SOFLD QTEMP/SEL) | ||
+ | A S02SORULE R O 4 17REFFLD(QWHFDSO/SORULE QTEMP/SEL) | ||
+ | A S02SOCOMP R O 4 22REFFLD(QWHFDSO/SOCOMP QTEMP/SEL) | ||
+ | A S02SOVALU R O 4 28REFFLD(QWHFDSO/SOVALU QTEMP/SEL) | ||
+ | |||
+ | A R C02 SFLCTL(S02 ) | ||
+ | A OVERLAY | ||
+ | A 50 SFLEND | ||
+ | A 51 SFLDSP | ||
+ | A 52 SFLDSPCTL | ||
+ | A 53 SFLCLR | ||
+ | A SFLSIZ(0019) | ||
+ | A SFLPAG(0018) | ||
+ | A SRS02 4S 0H SFLRCDNBR(CURSOR) | ||
+ | A* | ||
+ | A 1 6'FILE SELECTS for ' | ||
+ | A C02APFILE R O 2 7REFFLD(QWHFDSO/SOFILE QTEMP/SEL) | ||
+ | A 2 20'Lib.' | ||
+ | A C02APLIB R O 2 25REFFLD(QWHFDSO/SOLIB QTEMP/SEL) | ||
+ | A 3 4'Field' | ||
+ | A 3 28'Select/Omit Value' | ||
+ | A 3 16'S/O' | ||
+ | A 3 21'COMP' | ||
+ | |||
+ | </pre> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | |||
+ | ===DISPY RPG === | ||
+ | |||
+ | <pre> | ||
+ | H OPTIMIZE(*NONE) OPTION(*NODEBUGIO) | ||
+ | H DFTACTGRP(*NO) ACTGRP(*CALLER) | ||
+ | |||
+ | //*************************************************************** | ||
+ | // | ||
+ | // PROGRAM ID : DISPY | ||
+ | // Description: DISPLAY A FILES FIELDS FOR SELECTION | ||
+ | |||
+ | // needs files KF FFD to compile use following commands | ||
+ | // DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KF) | ||
+ | // DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) | ||
+ | //*************************************************************** | ||
+ | // MODIFICATIONS: | ||
+ | // MOD SR DATE MODIFICATION SUMMARY | ||
+ | // | ||
+ | //*************************************************************** | ||
+ | // | ||
+ | FKF IF E DISK | ||
+ | FFFD UF E DISK | ||
+ | FINPUT IF F32766 2000AIDISK KEYLOC(1) | ||
+ | F INFDS(INFDS) | ||
+ | FDISPYF CF E WORKSTN | ||
+ | F SFILE(S01:RS01) | ||
+ | F INFDS(SFINF) | ||
+ | // | ||
+ | // | ||
+ | |||
+ | // SCREEN LEVELS | ||
+ | D @SCN S 6 DIM(50) | ||
+ | D @NSCN S 6 | ||
+ | D @LV S 5 0 | ||
+ | D @ERR S LIKE(@TRUE) | ||
+ | D @FILE S 10A INZ('DISPY ') | ||
+ | D WRKSWS S 1 | ||
+ | D I S 4B 0 | ||
+ | |||
+ | |||
+ | D @TRUE S 1A INZ('1') | ||
+ | D @FALSE S 1A INZ('0') | ||
+ | D @OK S LIKE(@TRUE) | ||
+ | D @LOOP S LIKE(@TRUE) | ||
+ | |||
+ | // | ||
+ | D RS01 S 4S 0 | ||
+ | // | ||
+ | // PARMS FOR SFL LOOPING | ||
+ | D SFC01 S LIKE(RS01) | ||
+ | |||
+ | // Program Status | ||
+ | D SDS | ||
+ | D PGM 1 10 | ||
+ | D WSID 244 253 | ||
+ | D USER 254 263 | ||
+ | // | ||
+ | // | ||
+ | D SFINF DS | ||
+ | D RRRN 376 377B 0 | ||
+ | D SRN 378 379B 0 | ||
+ | |||
+ | // | ||
+ | D FLD S 10 DIM(9000) | ||
+ | D KEY S 10 DIM(99) | ||
+ | |||
+ | D INFDS DS | ||
+ | D FILE 83 92 | ||
+ | D LIB 93 102 | ||
+ | D MBR 129 138 | ||
+ | D RCDL 125 126B 0 | ||
+ | D RCDS 156 159B 0 | ||
+ | D ACCTP 160 160 | ||
+ | |||
+ | D DS | ||
+ | D WHCOLD 1 60 | ||
+ | D WHCHD1 1 20 | ||
+ | D WHCHD2 21 40 | ||
+ | D WHCHD3 41 60 | ||
+ | |||
+ | D DS | ||
+ | D POSN 1 10 | ||
+ | D P1 1 10 DIM(10) | ||
+ | |||
+ | D POSNN 11 20 | ||
+ | D P2 11 20 DIM(10) | ||
+ | |||
+ | |||
+ | * | ||
+ | // MESSAGE DATA | ||
+ | D @DTA1 DS 80 | ||
+ | D @DTA2 DS 500 | ||
+ | // | ||
+ | D MAIN PR | ||
+ | |||
+ | D @S01BLD PR | ||
+ | D @S01PRC PR | ||
+ | D @S01PRS PR | ||
+ | D | ||
+ | D @R9999 PR | ||
+ | |||
+ | D @OPADJ PR 2A | ||
+ | D OPT 2A | ||
+ | |||
+ | * | ||
+ | DDISPY PR | ||
+ | D 1 | ||
+ | D 1 | ||
+ | D 4 | ||
+ | D 1 | ||
+ | D 1 | ||
+ | D 5 | ||
+ | DDISPY PI | ||
+ | D ALL 1 | ||
+ | D RTN 1 | ||
+ | D KEYLNG 4 | ||
+ | D ACCP 1 | ||
+ | D QRY 1 | ||
+ | D RCDLN 5 | ||
+ | * | ||
+ | D KEYLN S 4S 0 | ||
+ | D RCDLEN S 5S 0 | ||
+ | *------------------------------------------------------------------- | ||
+ | * QMHRTVM API (Retrieve Message text) | ||
+ | *------------------------------------------------------------------- | ||
+ | D RtvMsgTxt PR 1024 | ||
+ | D RMsgId 7 Const | ||
+ | D RMsgFle 10 Const | ||
+ | D RMsgLib 10 Const | ||
+ | D RMsgLvl 1 Const | ||
+ | |||
+ | D GETROWCOL PR | ||
+ | D 10A const | ||
+ | D 10A const | ||
+ | D 10A const | ||
+ | D 32A const | ||
+ | D 3P 0 | ||
+ | D 3P 0 | ||
+ | |||
+ | D SysDate PR 8S 0 | ||
+ | D SysTime PR 6S 0 | ||
+ | D DayOfWeek PR 10I 0 | ||
+ | D D value datfmt(*iso) | ||
+ | // Message file names | ||
+ | D cMsgLib C Const('*LIBL ') | ||
+ | D cMsgF1 C Const('MSGF1 ') | ||
+ | D cMsgF2 C Const('MSGF2 ') | ||
+ | D cMsgLvl1 C Const('1') | ||
+ | D cMsgLvl2 C Const('2') | ||
+ | |||
+ | * | ||
+ | IINPUT NS 01 | ||
+ | I 1 256 D | ||
+ | |||
+ | /FREE | ||
+ | *INLR = *ON; | ||
+ | MAIN(); | ||
+ | |||
+ | |||
+ | //--------------*INZSR-------------------------------// | ||
+ | BEGSR *INZSR; | ||
+ | |||
+ | // Set the TOP level (Exit if user backs up to here) | ||
+ | @LV = 1; | ||
+ | @SCN(@LV) = '*END '; | ||
+ | // Set the Initial Screen to display | ||
+ | @LV = @LV + 1; | ||
+ | @SCN(@LV) = 'S01BLD '; | ||
+ | |||
+ | // DUMMY I/O TO GET NUMBER OF RECORDS IN FILE | ||
+ | READ INPUT; | ||
+ | // SFL IS NOT LOADED | ||
+ | // READ THE LIST OF KEY FIELDS IN THE FILE SO THAT WE CAN LATER MARK THEM | ||
+ | ACCP = ACCTP; | ||
+ | |||
+ | I = 0; | ||
+ | |||
+ | DOW @LOOP = @LOOP; | ||
+ | READ QWHFDACP; | ||
+ | IF %EOF; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | I = I + 1; | ||
+ | KEY(I) = APKEYF; | ||
+ | ENDDO; | ||
+ | ENDSR; | ||
+ | /END-FREE | ||
+ | //###################################################// | ||
+ | |||
+ | //************************************************************* | ||
+ | P MAIN B | ||
+ | |||
+ | D MAIN PI | ||
+ | |||
+ | D I S 4B 0 | ||
+ | |||
+ | /FREE | ||
+ | EXSR @INZSR; | ||
+ | // | ||
+ | // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY | ||
+ | DOW @LOOP = @LOOP; | ||
+ | // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY | ||
+ | @NSCN = @SCN(@LV); | ||
+ | SELECT; | ||
+ | // SELECT FIELDS FOR DISPLAY | ||
+ | |||
+ | // SFL TO SELECT THE FILE FIELDS | ||
+ | WHEN @NSCN = 'S01BLD'; | ||
+ | @S01BLD(); | ||
+ | WHEN @NSCN = 'S01PRC'; | ||
+ | @S01PRC(); | ||
+ | WHEN @NSCN = 'S01PRS'; | ||
+ | @S01PRS(); | ||
+ | OTHER; | ||
+ | // CATCH ALL (NEVER USED) | ||
+ | @R9999(); | ||
+ | LEAVE; | ||
+ | ENDSL; | ||
+ | |||
+ | // CF3 EXIT | ||
+ | IF *IN03 = *ON; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // CF12 PREVIOUS | ||
+ | IF *IN12 = *ON; | ||
+ | *IN12 = *OFF; | ||
+ | @LV = @LV -1; | ||
+ | @NSCN = @SCN(@LV); | ||
+ | ENDIF; | ||
+ | |||
+ | // Backed out to last level, Exit | ||
+ | IF @NSCN = '*END'; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDDO; | ||
+ | |||
+ | KEYLNG = %EDITC(KEYLN:'X'); | ||
+ | RETURN; | ||
+ | |||
+ | //--------------*INZSR-------------------------------// | ||
+ | BEGSR @INZSR; | ||
+ | @NSCN = *BLANK; | ||
+ | RCDLEN = RCDL; | ||
+ | RCDLN = %CHAR(RCDLEN); | ||
+ | |||
+ | // CLEAR FIELD SELECTIONS | ||
+ | IF RTN = '2'; | ||
+ | SETLL 1 QWHDRFFD; | ||
+ | DOW @LOOP = @LOOP; | ||
+ | READ QWHDRFFD ; | ||
+ | IF %EOF; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | WHFIOB = ' '; | ||
+ | UPDATE QWHDRFFD; | ||
+ | ENDDO; | ||
+ | |||
+ | // SET FILE I/O TO FIRST RCD IN FILE | ||
+ | SETLL 1 QWHDRFFD; | ||
+ | RTN = '0'; | ||
+ | ELSE; | ||
+ | CHAIN 1 QWHDRFFD; | ||
+ | SETLL 1 QWHDRFFD; | ||
+ | ENDIF; | ||
+ | ENDSR; | ||
+ | //-ENDSR---*INZSR-------------------------------// | ||
+ | /END-FREE | ||
+ | |||
+ | P MAIN E | ||
+ | |||
+ | |||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | /space 3 | ||
+ | P @S01BLD B | ||
+ | |||
+ | D @S01BLD PI | ||
+ | |||
+ | D SZ DS 6 | ||
+ | D LEN1 1 1 | ||
+ | D LEN2 2 3 | ||
+ | D LEN3 1 3 | ||
+ | D COMA 4 4 | ||
+ | D DEC1 5 5 | ||
+ | D DEC2 5 6 | ||
+ | |||
+ | D DS | ||
+ | D K 1 3 0 | ||
+ | D KA 2 3 | ||
+ | |||
+ | // Build/Rebuild the subfile | ||
+ | |||
+ | /FREE | ||
+ | EXSR @INZSR; | ||
+ | |||
+ | EXSR BLD; | ||
+ | |||
+ | // SFL IS BUILT, PROCESS THE SFL CONTROL | ||
+ | @LV = @LV + 1; | ||
+ | @SCN(@LV) = 'S01PRC ' ; | ||
+ | RETURN ; | ||
+ | //-------------- BLD -------------------------------// | ||
+ | BEGSR BLD; | ||
+ | |||
+ | EXSR CLR; | ||
+ | |||
+ | DOW @LOOP = @LOOP; | ||
+ | |||
+ | READ QWHDRFFD; | ||
+ | IF %EOF; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | EXSR MOV; | ||
+ | |||
+ | // FLAG THE KEY FIELDS | ||
+ | K = %LOOKUP(WHFLDE :KEY); | ||
+ | WHDFTL = K ; | ||
+ | UPDATE QWHDRFFD; | ||
+ | |||
+ | RS01 = RS01 + 1; | ||
+ | WRITE S01; | ||
+ | ENDDO; | ||
+ | |||
+ | // Position to TOP of subfile | ||
+ | SRS01 = 1; | ||
+ | SFC01 = RS01; | ||
+ | ENDSR; | ||
+ | |||
+ | //-------------- CLR -------------------------------// | ||
+ | BEGSR CLR; | ||
+ | I = 0; | ||
+ | CLEAR FLD; | ||
+ | KEYLN = 0; | ||
+ | |||
+ | *IN51 = *OFF; | ||
+ | *IN52 = *OFF; | ||
+ | *IN53 = *ON; | ||
+ | WRITE C01; | ||
+ | *IN53 = *OFF; | ||
+ | RS01 = 0 ; | ||
+ | SFC01 = 0 ; | ||
+ | S01OPT= *BLANK; | ||
+ | ENDSR; | ||
+ | |||
+ | //-------------- MOV -------------------------------// | ||
+ | BEGSR MOV; | ||
+ | // Load the subfile record | ||
+ | |||
+ | |||
+ | S01OPT = WHFIOB ; | ||
+ | S01WHFLDB = WHFLDB; | ||
+ | S01WHFLDT = WHFLDT; | ||
+ | S01WHFLD = WHFLDE ; | ||
+ | S01SFLD = WHFLDE ; | ||
+ | S01FROM = WHFOBO; | ||
+ | S01TO = WHFLDB + WHFOBO -1 ; | ||
+ | |||
+ | // KEY FIELDS | ||
+ | S01KEYFLD = ' '; | ||
+ | K = %LOOKUP(WHFLDE :KEY); | ||
+ | IF K <> 0; | ||
+ | S01KEYFLD = KA; | ||
+ | IF K < 10; | ||
+ | %SUBST(S01KEYFLD:1:1) = 'K'; | ||
+ | ENDIF; | ||
+ | KEYLN = KEYLN + WHFLDB; | ||
+ | ENDIF; | ||
+ | // FORMAT THE FIELD LENGTH | ||
+ | S01SIZE = ' '; | ||
+ | SZ = ' '; | ||
+ | IF WHFLDD = 0; | ||
+ | LEN3 = %SUBST(%EDITC(WHFLDB:'Z'):3:3); | ||
+ | ELSE; | ||
+ | LEN2 = %EDITC(WHFLDD:'Z') ; | ||
+ | COMA = ','; | ||
+ | |||
+ | IF WHFLDP > 9; | ||
+ | DEC2 = %CHAR(WHFLDP); | ||
+ | ELSE; | ||
+ | DEC1 = %CHAR(WHFLDP); | ||
+ | ENDIF; | ||
+ | ENDIF; | ||
+ | IF LEN1 = '0'; | ||
+ | LEN1 = ' '; | ||
+ | ENDIF; | ||
+ | S01SIZE = SZ; | ||
+ | |||
+ | S01DESC = WHFTXT; | ||
+ | IF S01DESC= ' '; | ||
+ | S01DESC = WHCOLD ; | ||
+ | ENDIF; | ||
+ | |||
+ | I = I + 1; | ||
+ | FLD(I) = S01WHFLD; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | //--------------*INZSR-------------------------------// | ||
+ | BEGSR @INZSR; | ||
+ | @NSCN = *BLANK; | ||
+ | ENDSR; | ||
+ | /END-FREE | ||
+ | |||
+ | P @S01BLD E | ||
+ | |||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | |||
+ | /space 3 | ||
+ | P @S01PRC B | ||
+ | |||
+ | D @S01PRC PI | ||
+ | |||
+ | // | ||
+ | // | ||
+ | D WRKRC S 4S 0 | ||
+ | D C01CHK S LIKE(C01POSN) | ||
+ | |||
+ | /FREE | ||
+ | EXSR @INZSR; | ||
+ | |||
+ | WRITE R01; | ||
+ | |||
+ | // | ||
+ | DOW @LOOP = @LOOP; | ||
+ | |||
+ | // | ||
+ | // Write SFL Control | ||
+ | IF SFC01 > 0; | ||
+ | *IN51 = *ON; | ||
+ | ENDIF; | ||
+ | *IN52 = *ON; | ||
+ | EXFMT C01; | ||
+ | // Setoff errors | ||
+ | *IN89 = *OFF; | ||
+ | // | ||
+ | // Exit and Previous Screen | ||
+ | IF *IN03 = *ON; | ||
+ | RTN = '1'; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | IF *IN12 = *ON; | ||
+ | @LV = @LV -1; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // Set up for qry selection and exit | ||
+ | IF *IN06 = *ON; | ||
+ | *IN03 = *ON; | ||
+ | QRY = '1'; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // POSITION | ||
+ | IF C01POSN <> ' '; | ||
+ | EXSR POS; | ||
+ | ITER; | ||
+ | ENDIF; | ||
+ | |||
+ | // Process the subfile | ||
+ | @LV = @LV + 1; | ||
+ | @SCN(@LV) = 'S01PRS'; | ||
+ | LEAVE; | ||
+ | |||
+ | ENDDO; | ||
+ | // | ||
+ | RETURN; | ||
+ | |||
+ | /space 3 | ||
+ | |||
+ | //--------------POS -------------------------------// | ||
+ | BEGSR POS; | ||
+ | |||
+ | |||
+ | FOR WRKRC = 1 TO SFC01; | ||
+ | CHAIN WRKRC S01; | ||
+ | IF NOT %FOUND; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | C01CHK = %SUBST(S01WHFLD :1 : %LEN(%TRIM(C01POSN))); | ||
+ | IF (C01POSN = C01CHK ); | ||
+ | SRS01 = WRKRC; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | ENDFOR; | ||
+ | |||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | //--------------*INZSR-------------------------------// | ||
+ | BEGSR @INZSR; | ||
+ | @NSCN = *BLANK; | ||
+ | |||
+ | C01FILE = FILE; | ||
+ | C01LIB = LIB; | ||
+ | C01MBR = MBR; | ||
+ | C01RCDL = RCDL; | ||
+ | C01ACCTP = ACCTP; | ||
+ | C01WHTEXT = WHTEXT; | ||
+ | C01RCORDS = RCDS; | ||
+ | C01POSN = ' ' ; | ||
+ | C01WHNAME = WHNAME; | ||
+ | |||
+ | ENDSR; | ||
+ | /END-FREE | ||
+ | |||
+ | P @S01PRC E | ||
+ | |||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | /space 3 | ||
+ | P @S01PRS B | ||
+ | |||
+ | D @S01PRS PI | ||
+ | |||
+ | // | ||
+ | // | ||
+ | D WRKRC S 4S 0 | ||
+ | D FX S 5S 0 | ||
+ | |||
+ | /FREE | ||
+ | |||
+ | EXSR @INZSR; | ||
+ | |||
+ | // Process the subfile | ||
+ | EXSR SFL; | ||
+ | *IN03 = '1'; | ||
+ | RETURN; | ||
+ | |||
+ | //-------------- SFL -------------------------------// | ||
+ | BEGSR SFL; | ||
+ | // Process the subfile | ||
+ | |||
+ | FOR WRKRC = 1 TO SFC01+1; | ||
+ | CHAIN WRKRC S01; | ||
+ | IF NOT %FOUND; | ||
+ | // Finished with the subfile | ||
+ | // RETURN TO REBUILD LEVEL | ||
+ | @LV = @LV -2; | ||
+ | LEAVE; | ||
+ | ENDIF; | ||
+ | |||
+ | // RIGHT ADJUST OPTION | ||
+ | S01OPT = @OPADJ(S01OPT); | ||
+ | |||
+ | // UPDATE SELECTIONS | ||
+ | EXSR UPD; | ||
+ | |||
+ | ENDFOR; | ||
+ | |||
+ | ENDSR; | ||
+ | //---------------------------------------------------// | ||
+ | |||
+ | //--------------UPD ---------------------------------// | ||
+ | BEGSR UPD; | ||
+ | |||
+ | // UPDATE FIELD NAMES AND SELECT FLAG | ||
+ | FX = %LOOKUP(S01SFLD :FLD); | ||
+ | CHAIN FX QWHDRFFD; | ||
+ | WHFLDE = S01WHFLD; | ||
+ | |||
+ | IF @OPADJ(S01OPT) = ' S' OR | ||
+ | @OPADJ(S01OPT) = ' O'; | ||
+ | ALL = %TRIM(S01OPT); | ||
+ | WHFIOB = %TRIM(S01OPT); | ||
+ | ENDIF; | ||
+ | |||
+ | IF @OPADJ(S01OPT) = ' '; | ||
+ | WHFIOB = ' '; | ||
+ | ENDIF; | ||
+ | UPDATE QWHDRFFD; | ||
+ | |||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | //--------------*INZSR-------------------------------// | ||
+ | BEGSR @INZSR; | ||
+ | ALL = '1'; | ||
+ | @NSCN = *BLANK; | ||
+ | ENDSR; | ||
+ | |||
+ | |||
+ | /END-FREE | ||
+ | P @S01PRS E | ||
+ | |||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | |||
+ | P @R9999 B | ||
+ | // Invalid Panel | ||
+ | D @R9999 PI | ||
+ | |||
+ | P @R9999 E | ||
+ | |||
+ | |||
+ | /space 3 | ||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | P @OPADJ B | ||
+ | // RIGHT ADJ OPTION , zero suppress | ||
+ | |||
+ | D @OPADJ PI 2A | ||
+ | D OPT 2A | ||
+ | |||
+ | /FREE | ||
+ | EVALR OPT = %trimr(OPT); | ||
+ | If %SubSt(OPT:1:1) = '0'; | ||
+ | OPT = ' ' + %SubSt(OPT:2:1); | ||
+ | EndIf; | ||
+ | RETURN OPT; | ||
+ | /END-FREE | ||
+ | P @OPADJ E | ||
+ | |||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | P RtvMsgTxt B | ||
+ | //************************************************************************ | ||
+ | // API Call: QMHRTVM Retrieve Message text | ||
+ | //************************************************************************ | ||
+ | |||
+ | |||
+ | // USAGE | ||
+ | // MsgTxt = RtvMsgTxt('MSG0001':cMsgF3:cMsgLib:cMsgLvl1); | ||
+ | |||
+ | D RtvMsgTxt PI 1024 | ||
+ | D RMsgId 7 Const | ||
+ | D RMsgFle 10 Const | ||
+ | D RMsgLib 10 Const | ||
+ | D RMsgLvl 1 Const | ||
+ | |||
+ | // Retrieve Message Description API Prototype | ||
+ | D Get_Message PR ExtPgm('QMHRTVM') | ||
+ | D 4000 Options(*VarSize) | ||
+ | D 10I 0 Const | ||
+ | D 8 Const | ||
+ | D 7 | ||
+ | D 20 Const | ||
+ | D 32765 Options(*VarSize) | ||
+ | D 10I 0 Const | ||
+ | D 10 Const | ||
+ | D 10 Const | ||
+ | D 8192 Options(*VarSize) | ||
+ | D 10 | ||
+ | D 9B 0 | ||
+ | D 9B 0 | ||
+ | |||
+ | // Define Variables for QMHRTVM API call: | ||
+ | // -------------------------------------- | ||
+ | // Return variables | ||
+ | D MessageInfo DS 4000 | ||
+ | D Data 1 4000 | ||
+ | D OSMSG 65 68B 0 | ||
+ | D LMsgR 69 72B 0 | ||
+ | D LMsgA 73 76B 0 | ||
+ | D OSMSGH 77 80B 0 | ||
+ | D LMsgHR 81 84B 0 | ||
+ | D LMsgHA 85 88B 0 | ||
+ | |||
+ | // Required input variables | ||
+ | D MessageLen S 10I 0 | ||
+ | D MessageForm S 8 | ||
+ | D MessageIden S 7 | ||
+ | D MessageFile S 20 | ||
+ | D Replacement S 32765 | ||
+ | D ReplaceLen S 10I 0 | ||
+ | D ReplaceSub S 10 | ||
+ | D ReturnCtl S 10 | ||
+ | |||
+ | D RetrieveOpt S 10 | ||
+ | D ConvToCCSID S 9B 0 | ||
+ | D ReplDtaCCSID S 9B 0 | ||
+ | |||
+ | D Return_Text S 1024 | ||
+ | |||
+ | D ErrorCode DS Qualified | ||
+ | D BytesProv 4B 0 Inz(0) | ||
+ | D BytesAvail 8B 0 Inz(0) | ||
+ | D ExceptionId 7 | ||
+ | D Reserved 1 | ||
+ | D ExceptionDta 512 | ||
+ | /FREE | ||
+ | |||
+ | // Load API parameter fields | ||
+ | MessageInfo = *blanks; | ||
+ | MessageLen = 4000; | ||
+ | MessageForm = 'RTVM0300'; | ||
+ | MessageIden = RMsgId; | ||
+ | MessageFile = RMsgFle + RMsgLib; | ||
+ | Replacement = *blanks; | ||
+ | ReplaceLen = %Len(Replacement); | ||
+ | ReplaceSub = '*YES'; | ||
+ | ReturnCtl = '*YES'; | ||
+ | RetrieveOpt = '*MSGID'; | ||
+ | ConvToCCSID = 0; | ||
+ | ReplDtaCCSID = 0; | ||
+ | |||
+ | // Retrieve message description | ||
+ | Get_Message(MessageInfo : | ||
+ | MessageLen : | ||
+ | MessageForm : | ||
+ | MessageIden : | ||
+ | MessageFile : | ||
+ | Replacement : | ||
+ | ReplaceLen : | ||
+ | ReplaceSub : | ||
+ | ReturnCtl : | ||
+ | ErrorCode : | ||
+ | RetrieveOpt : | ||
+ | ConvToCCSID : | ||
+ | ReplDtaCCSID); | ||
+ | |||
+ | // Process Return variables | ||
+ | Return_Text = *blanks; | ||
+ | |||
+ | // If no errors, determine the correct portion of the message text | ||
+ | If ErrorCode.BytesProv = 0; | ||
+ | Select; | ||
+ | When RMsgLvl = '1'; | ||
+ | Return_Text = %Subst(data:OSMSG+1:LMsgA); // Msg Lvl 1 | ||
+ | When RMsgLvl = '2'; | ||
+ | Return_Text = %Subst(data:OSMSGH+1:LMsgHA); // Msg Lvl 2 | ||
+ | EndSl; | ||
+ | Else; | ||
+ | Return_Text = 'Get_Message failed.'; | ||
+ | EndIf; | ||
+ | |||
+ | // Return to calling point | ||
+ | Return Return_Text; | ||
+ | |||
+ | /END-FREE | ||
+ | P E | ||
+ | |||
+ | |||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | //###################################################// | ||
+ | P GETROWCOL B | ||
+ | * | ||
+ | * Retreive a DSPF FIELD Row and Col | ||
+ | * Used for Setting CSRLOC for cursor positioning | ||
+ | * USAGE | ||
+ | * GETROWCOL (FILE :'*LIBL' : FORMAT : FLDNAM : ROW : COL) | ||
+ | * | ||
+ | D GETROWCOL PR | ||
+ | D schFile 10A const | ||
+ | D schLib 10A const | ||
+ | D schFormat 10A const | ||
+ | D schString 32A const | ||
+ | D rtnROW 3P 0 | ||
+ | D RtnCOL 3P 0 | ||
+ | |||
+ | D GETROWCOL PI | ||
+ | D schFile 10A const | ||
+ | D schLib 10A const | ||
+ | D schFormat 10A const | ||
+ | D schString 32A const | ||
+ | D rtnROW 3P 0 | ||
+ | D RtnCOL 3P 0 | ||
+ | |||
+ | D QUSCRTUS PR ExtPgm('QUSCRTUS') | ||
+ | D UserSpace 20A CONST | ||
+ | D ExtAttrib 10A CONST | ||
+ | D InitialSize 10I 0 CONST | ||
+ | D InitialVal 1A CONST | ||
+ | D PublicAuth 10A CONST | ||
+ | D Text 50A CONST | ||
+ | D Replace 10A CONST options(*nopass) | ||
+ | D ErrorCode 32767A options(*varsize:*nopass) | ||
+ | |||
+ | D QUSPTRUS PR ExtPgm('QUSPTRUS') | ||
+ | D UserSpace 20A CONST | ||
+ | D Pointer * | ||
+ | |||
+ | D QUSDLTUS PR ExtPgm('QUSDLTUS') | ||
+ | D UserSpace 20A CONST | ||
+ | D ErrorCode 32767A options(*varsize) | ||
+ | |||
+ | D QUSLFLD PR ExtPgm('QUSLFLD') | ||
+ | D UsrSpc 20A const | ||
+ | D Format 8A const | ||
+ | D QualFile 20A const | ||
+ | D RcdFmt 10A const | ||
+ | D UseOvrd 1A const | ||
+ | D ErrorCode 32767A options(*nopass:*varsize) | ||
+ | |||
+ | D ErrorCode ds qualified | ||
+ | D BytesProv 10I 0 inz(0) | ||
+ | D BytesAvail 10I 0 inz(0) | ||
+ | |||
+ | D ListHeader ds based(p_ListHeader) | ||
+ | d ListOffset 10I 0 overlay(ListHeader:125) | ||
+ | d EntryCount 10I 0 overlay(ListHeader:133) | ||
+ | d EntrySize 10I 0 overlay(ListHeader:137) | ||
+ | |||
+ | D Field ds based(p_Field) | ||
+ | D qualified | ||
+ | D Name 10a | ||
+ | D FILLER 438a | ||
+ | d DspRow 10i 0 | ||
+ | d DspCol 10i 0 | ||
+ | |||
+ | D TEMPSPC C 'GETROWCOL QTEMP' | ||
+ | |||
+ | D x s 10I 0 | ||
+ | |||
+ | /free | ||
+ | |||
+ | rtnrow = 999; | ||
+ | rtnrow = 999; | ||
+ | // -------------------------------------------------- | ||
+ | // Delete the user space if it exists (ignore errors) | ||
+ | ErrorCode.BytesProv = %size(ErrorCode); | ||
+ | QUSDLTUS( TEMPSPC: ErrorCode ); | ||
+ | ErrorCode.BytesProv = 0; | ||
+ | |||
+ | // -------------------------------------------------- | ||
+ | // Create a new 128k user space | ||
+ | QUSCRTUS( TEMPSPC : 'SCHTEXT' : 128 * 1024 : x'00' | ||
+ | : '*EXCLUDE' : 'List of fields in file' : '*NO' | ||
+ | : ErrorCode ); | ||
+ | |||
+ | // -------------------------------------------------- | ||
+ | // Dump list of fields in file to user space | ||
+ | // Invaid data is ignored an 999 returned for row and col | ||
+ | monitor; | ||
+ | QUSLFLD( TEMPSPC : 'FLDL0100' : SchFile + SchLib | ||
+ | : SchFormat : *OFF : ErrorCode ); | ||
+ | on-Error; | ||
+ | RETURN; | ||
+ | EndMon; | ||
+ | // -------------------------------------------------- | ||
+ | // Get a pointer to the user space | ||
+ | QUSPTRUS( TEMPSPC: p_ListHeader ); | ||
+ | |||
+ | // -------------------------------------------------- | ||
+ | // Loop through all fields in space, to get the field we need | ||
+ | for x = 0 to (EntryCount - 1); | ||
+ | p_Field = p_ListHeader + ListOffset + (EntrySize * x); | ||
+ | |||
+ | if Field.Name = schString; | ||
+ | rtnRow = Field.DspRow; | ||
+ | rtnCol = Field.DspCol; | ||
+ | leave; | ||
+ | endif; | ||
+ | endfor; | ||
+ | |||
+ | // -------------------------------------------------- | ||
+ | // Delete temp user space & end | ||
+ | QUSDLTUS( TEMPSPC: ErrorCode ); | ||
+ | |||
+ | return; | ||
+ | |||
+ | /end-free | ||
+ | P E | ||
+ | |||
</pre> | </pre> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | ===DISPYF RPG === | ||
+ | |||
+ | <pre> | ||
+ | |||
+ | A*%%TS SD 20101203 131649 KOLMANNF REL-V5R4M0 5722-WDS | ||
+ | A* 90/01/08 12:52:36 REL-R01M02 5728-PW1 | ||
+ | A* 16:33:07 REL-R08M00 5714-UT1 | ||
+ | A*%%EC | ||
+ | A DSPSIZ(24 80 *DS3) | ||
+ | A REF(*LIBL/QADSPFFD) | ||
+ | A PRINT | ||
+ | A CA03(03 'End of job') | ||
+ | A CA12(12 'Previous') | ||
+ | A CA04(04 'Add FIELDS') | ||
+ | A CA05(05 'Attr changes') | ||
+ | A CF06(06 'Field Select') | ||
+ | A CA07(07 'Name changes') | ||
+ | A***** | ||
+ | A* 15:04:39 REL-R08M00 5714-UT1 | ||
+ | A R S01 SFL | ||
+ | A*%%TS SD 20101203 131649 KOLMANNF REL-V5R4M0 5722-WDS | ||
+ | A 40 SFLNXTCHG | ||
+ | A S01OPT 2A B 7 2 | ||
+ | A S01KEYFLD 2A O 7 5DSPATR(HI) | ||
+ | A S01WHFLD R B 7 8REFFLD(WHFLDI) | ||
+ | A 23 DSPATR(HI) | ||
+ | A N23 DSPATR(PR) | ||
+ | A S01WHFLDB R B 7 19REFFLD(WHFLDB) | ||
+ | A EDTCDE(Z) | ||
+ | A 25 DSPATR(HI) | ||
+ | A N25 DSPATR(PR) | ||
+ | A S01SIZE 6A O 7 25 | ||
+ | A S01FROM 4Y 0O 7 32EDTCDE(Z) | ||
+ | A S01TO 4Y 0O 7 37EDTCDE(Z) | ||
+ | A S01DESC 35A O 7 44 | ||
+ | A S01WHFLDT R B 7 42REFFLD(WHFLDT) | ||
+ | A 25 DSPATR(HI) | ||
+ | A N25 DSPATR(PR) | ||
+ | A S01SFLD R H REFFLD(WHFLDI) | ||
+ | A***** | ||
+ | A* | ||
+ | A R C01 SFLCTL(S01) | ||
+ | A*%%TS SD 20101203 131649 KOLMANNF REL-V5R4M0 5722-WDS | ||
+ | A SFLSIZ(0015) | ||
+ | A SFLPAG(0014) | ||
+ | A 88 CSRLOC(ROW01 COL01) | ||
+ | A OVERLAY | ||
+ | A TEXT('WORK WITH FIELDS') | ||
+ | A 51 SFLDSP | ||
+ | A 52 SFLDSPCTL | ||
+ | A 53 SFLCLR | ||
+ | A 99 SFLEND | ||
+ | A SRS01 4S 0H SFLRCDNBR(CURSOR) | ||
+ | A* | ||
+ | A 89 C01MSG 79 M | ||
+ | A ROW01 3S 0H | ||
+ | A COL01 3S 0H | ||
+ | A 1 3'File' | ||
+ | A C01FILE 10A O 1 8DSPATR(HI) | ||
+ | A 1 20'Lib' | ||
+ | A C01LIB 10A O 1 24DSPATR(HI) | ||
+ | A 1 37'Mbr' | ||
+ | A C01MBR 10A O 1 41DSPATR(HI) | ||
+ | A 1 53'Rcdlen' | ||
+ | A C01RCDL 4S 0O 1 60DSPATR(HI) | ||
+ | A 1 66'Access' | ||
+ | A C01ACCTP 1A O 1 73DSPATR(HI) | ||
+ | A 2 3'Text' | ||
+ | A C01WHTEXT R O 2 9REFFLD(WHTEXT) | ||
+ | A DSPATR(HI) | ||
+ | A 2 60'#Records' | ||
+ | A C01RCORDS 7Y 0O 2 69DSPATR(HI) | ||
+ | A EDTCDE(Z) | ||
+ | A C01POSN 10A I 3 7 | ||
+ | A 4 2'Select/Omit (S/O) fields for displ- | ||
+ | A ay.(Default *ALL)' | ||
+ | A 5 11'Use Select Or Omit,not Select with- | ||
+ | A Omit' | ||
+ | A 6 8'Name Bytes Size From To T- | ||
+ | A p Description' | ||
+ | A 4 54'Format' | ||
+ | A C01WHNAME R O 4 61REFFLD(QWHDRFFD/WHNAME) | ||
+ | A DSPATR(HI) | ||
+ | A R R01 | ||
+ | A 23 2'F3-Exit F6-Data Sel' | ||
+ | |||
+ | </pre> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | ===DISPX DSPF === | ||
+ | |||
+ | <pre> | ||
+ | A DSPSIZ(24 80 *DS3) | ||
+ | A PRINT | ||
+ | A CF02(02 'return') | ||
+ | A CF03(01 'exit') | ||
+ | A R SLT | ||
+ | A OVERLAY | ||
+ | A 1 2'Qryslt:' | ||
+ | A QSLT 1509A B 1 12CHECK(LC) | ||
+ | A 20 1'F2-Return ' | ||
+ | A R SLTR SFL | ||
+ | A SFLMSGRCD(21) | ||
+ | A MSGKEY SFLMSGKEY | ||
+ | A PGMQ SFLPGMQ | ||
+ | A R SLTC SFLCTL(SLTR ) | ||
+ | A OVERLAY | ||
+ | A SFLSIZ(50) SFLPAG(3) | ||
+ | A N20 SFLEND | ||
+ | A N20 SFLDSP | ||
+ | A N20 SFLDSPCTL | ||
+ | A N20 SFLINZ | ||
+ | A 20 SFLCLR | ||
+ | A PGMQ SFLPGMQ | ||
+ | |||
+ | </pre> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | ===FFDL01 LF === | ||
+ | |||
+ | <pre> | ||
+ | A R QWHDRFFD PFILE(FFD) | ||
+ | K WHFILE | ||
+ | |||
+ | </pre> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | |||
+ | === COMPILE CL === | ||
+ | |||
+ | <pre> | ||
+ | /* COMPILE OBJECTS */ | ||
+ | /* CRTBNDCL PGM(KOLMANN/COMPILE) SRCFILE(KOLMANN/UDDSSRC) */ | ||
+ | /* SRCMBR(COMPILE) OUTPUT(*NONE) REPLACE(*YES) */ | ||
+ | /* call compile ('KOLMANN' 'UDDSSRC') */ | ||
+ | PGM (&LIB &SRCF) | ||
+ | |||
+ | DCL &LIB *CHAR 10 | ||
+ | DCL &SRCF *CHAR 10 | ||
+ | |||
+ | CRTDTAARA DTAARA(&LIB/UDDSSRC) TYPE(*CHAR) LEN(10) + | ||
+ | VALUE(&SRCF) TEXT('SOURCE LIBRARY FOR UDDS PROGRAMS') | ||
+ | MONMSG CPF0000 | ||
+ | |||
+ | dltf qtemp/afile | ||
+ | monmsg cpf0000 | ||
+ | CRTPF FILE(QTEMP/AFILE) RCDLEN(80) OPTION(*NOLIST) | ||
+ | |||
+ | CRTDSPF FILE(&LIB/DISPF) SRCFILE(&LIB/&SRCF) + | ||
+ | SRCMBR(DISPF) OPTION(*NOLIST *NOSRC) + | ||
+ | REPLACE(*YES) | ||
+ | |||
+ | |||
+ | DSPFFD FILE(QTEMP/AFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) | ||
+ | DLTF FILE(QTEMP/FFDL01) | ||
+ | MONMSG CPF0000 | ||
+ | CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) + | ||
+ | OPTION(*NOSRC *NOLIST) | ||
+ | |||
+ | DSPFFD FILE(QTEMP/FFD) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFFFD) | ||
+ | DSPFD (QTEMP/FFD ) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KFFFD ) | ||
+ | OVRDBF FILE(KF) TOFILE(QTEMP/KFFFD) | ||
+ | CRTBNDCL PGM(&LIB/DISF) SRCFILE(&LIB/&SRCF) + | ||
+ | DBGVIEW(*SOURCE) SRCMBR(DISF) OUTPUT(*NONE) REPLACE(*YES) | ||
+ | CRTBNDCL PGM(&LIB/DISV) SRCFILE(&LIB/&SRCF) + | ||
+ | DBGVIEW(*SOURCE) SRCMBR(DISV) OUTPUT(*NONE) REPLACE(*YES) | ||
+ | |||
+ | CRTBNDRPG PGM(&LIB/DISPY) SRCFILE(&LIB/&SRCF) + | ||
+ | SRCMBR(DISPY) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES) | ||
+ | |||
+ | |||
+ | DLTF FILE(QTEMP/REL) | ||
+ | MONMSG CPF0000 | ||
+ | DLTF FILE(QTEMP/SEL) | ||
+ | MONMSG CPF0000 | ||
+ | DLTF FILE(QTEMP/DBR) | ||
+ | MONMSG CPF0000 | ||
+ | |||
+ | DSPFD FILE(QTEMP/FFD) TYPE(*ACCPTH) + | ||
+ | OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD) | ||
+ | DSPFD FILE(QTEMP/FFDL01) TYPE(*SELECT) OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL) | ||
+ | CRTDSPF FILE(&LIB/DISPRF) SRCFILE(&LIB/&SRCF) + | ||
+ | SRCMBR(DISPRF) OPTION(*NOLIST *NOSRC) + | ||
+ | REPLACE(*YES) | ||
+ | |||
+ | DSPDBR FILE(QTEMP/FFD) OUTPUT(*OUTFILE) + | ||
+ | OUTFILE(QTEMP/DBR) OUTMBR(*FIRST *REPLACE) | ||
+ | |||
+ | DLTF FILE(QTEMP/ACC) | ||
+ | MONMSG CPF0000 | ||
+ | DSPFD FILE(QTEMP/FFDL01) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/ACC) | ||
+ | |||
+ | CRTBNDRPG PGM(&LIB/DISP) SRCFILE(&LIB/&SRCF) + | ||
+ | SRCMBR(DISP) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES) | ||
+ | CRTBNDRPG PGM(&LIB/DISP1) SRCFILE(&LIB/&SRCF) + | ||
+ | SRCMBR(DISP1) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES) | ||
+ | CRTBNDRPG PGM(&LIB/DISP2) SRCFILE(&LIB/&SRCF) + | ||
+ | SRCMBR(DISP2) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES) | ||
+ | |||
+ | CRTBNDRPG PGM(&LIB/DUSP) SRCFILE(&LIB/&SRCF) + | ||
+ | SRCMBR(DUSP) DBGVIEW(*SOURCE) REPLACE(*YES) | ||
+ | CRTBNDRPG PGM(&LIB/DUSP1) SRCFILE(&LIB/&SRCF) + | ||
+ | SRCMBR(DUSP1) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES) | ||
+ | CRTBNDRPG PGM(&LIB/DUSP2) SRCFILE(&LIB/&SRCF) + | ||
+ | SRCMBR(DUSP2) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES) | ||
+ | |||
+ | CRTBNDCL PGM(&LIB/DIS) SRCFILE(&LIB/&SRCF) + | ||
+ | DBGVIEW(*SOURCE) SRCMBR(DIS) OUTPUT(*NONE) REPLACE(*YES) | ||
+ | CRTBNDCL PGM(&LIB/DIS3) SRCFILE(&LIB/&SRCF) + | ||
+ | DBGVIEW(*SOURCE) SRCMBR(DIS3) OUTPUT(*NONE) REPLACE(*YES) | ||
+ | CRTBNDCL PGM(&LIB/DIS4) SRCFILE(&LIB/&SRCF) + | ||
+ | DBGVIEW(*SOURCE) SRCMBR(DIS4) OUTPUT(*NONE) REPLACE(*YES) | ||
+ | CRTBNDCL PGM(&LIB/DISBIN) SRCFILE(&LIB/&SRCF) + | ||
+ | DBGVIEW(*SOURCE) SRCMBR(DISBIN) OUTPUT(*NONE) REPLACE(*YES) | ||
+ | |||
+ | CRTBNDRPG PGM(&LIB/DISPR) SRCFILE(&LIB/&SRCF) + | ||
+ | SRCMBR(DISPR) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES) | ||
+ | |||
+ | CRTCMD CMD(&LIB/DSPFL) PGM(*LIBL/DIS) SRCFILE(&LIB/&SRCF) + | ||
+ | SRCMBR(DSPFL) VLDCKR(DISV) | ||
+ | |||
+ | CRTDSPF FILE(&LIB/DISPX) SRCFILE(&LIB/&SRCF) + | ||
+ | SRCMBR(DISPX) OPTION(*NOLIST *NOSRC) + | ||
+ | REPLACE(*YES) | ||
+ | CRTBNDCL PGM(&LIB/DIS1) SRCFILE(&LIB/&SRCF) + | ||
+ | DBGVIEW(*SOURCE) SRCMBR(DIS1) OUTPUT(*NONE) REPLACE(*YES) | ||
+ | |||
+ | |||
+ | |||
+ | ENDPGM | ||
+ | |||
+ | |||
+ | </pre> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | === TESTPF PF === | ||
+ | |||
+ | <pre> | ||
+ | A R TESTR | ||
+ | A ACTIV 1A TEXT('Active flag (0 - inactive, 1') | ||
+ | A CMPNO 3P TEXT('Company number ') | ||
+ | A PLTNO 2P TEXT('Plant number ') | ||
+ | A PRDNO 15A TEXT('Product number ') | ||
+ | A OPBAL 13P 3 TEXT('Opening balance - this perio') | ||
+ | A SERVU 5S 2 TEXT('Service level based on units') | ||
+ | A QTY 5B 2 TEXT('QTY') | ||
+ | A QTYF 17F 4 FLTPCN(*DOUBLE) | ||
+ | A CCYYMMDD L TEXT('DATE') | ||
+ | A HHMMSS T TEXT('TIME') | ||
+ | A DATTIM Z TEXT('DATE TIME') | ||
+ | A VTEXT 100A VARLEN | ||
+ | A TEXT('VARIABLE TEXT') | ||
+ | A DESCP 30A TEXT('Product description or name ') | ||
+ | |||
+ | A K ACTIV | ||
+ | A K CMPNO | ||
+ | A K PRDNO | ||
+ | A K OPBAL | ||
+ | A K SERVU | ||
+ | |||
+ | </pre> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | === TESTPF1 PF === | ||
+ | |||
+ | <pre> | ||
+ | A R TESTR | ||
+ | A ACTIV 1A TEXT('Active flag (0 - inactive, 1') | ||
+ | A CMPNO 3P TEXT('Company number ') | ||
+ | A PLTNO 2P TEXT('Plant number ') | ||
+ | A PRDNO 15A TEXT('Product number ') | ||
+ | A OPBAL 13P 3 TEXT('Opening balance - this perio') | ||
+ | A SERVU 5S 2 TEXT('Service level based on units') | ||
+ | A QTY 5B 2 TEXT('QTY') | ||
+ | A QTYF 17F 4 FLTPCN(*DOUBLE) | ||
+ | A CCYYMMDD L TEXT('DATE') | ||
+ | A HHMMSS T TEXT('TIME') | ||
+ | A DATTIM Z TEXT('DATE TIME') | ||
+ | A VTEXT 100A VARLEN | ||
+ | A TEXT('VARIABLE TEXT') | ||
+ | A DESCP 30A TEXT('Product description or name ') | ||
+ | A TXT1 500A TEXT('TXT1 ') | ||
+ | A TXT2 500A TEXT('TXT2 ') | ||
+ | A TXT3 500A TEXT('TXT3 ') | ||
+ | A TXT4 500A TEXT('TXT4 ') | ||
+ | A K ACTIV | ||
+ | A K CMPNO | ||
+ | A K PRDNO | ||
+ | A K OPBAL | ||
+ | A K SERVU | ||
+ | |||
+ | </pre> | ||
+ | |||
+ | [[#top]] | ||
+ | |||
+ | === TESTPF2 PF === | ||
+ | |||
+ | <pre> | ||
+ | |||
+ | A R TESTR | ||
+ | A ACTIV 1A TEXT('Active flag (0 - inactive, 1') | ||
+ | A CMPNO 3P TEXT('Company number ') | ||
+ | A PLTNO 2P TEXT('Plant number ') | ||
+ | A PRDNO 15A TEXT('Product number ') | ||
+ | A OPBAL 13P 3 TEXT('Opening balance - this perio') | ||
+ | A SERVU 5S 2 TEXT('Service level based on units') | ||
+ | A QTY 5B 2 TEXT('QTY') | ||
+ | A QTYF 17F 4 FLTPCN(*DOUBLE) | ||
+ | A CCYYMMDD L TEXT('DATE') | ||
+ | A HHMMSS T TEXT('TIME') | ||
+ | A DATTIM Z TEXT('DATE TIME') | ||
+ | A VTEXT 100A VARLEN | ||
+ | A TEXT('VARIABLE TEXT') | ||
+ | A DESCP 30A TEXT('Product description or name ') | ||
+ | A TXT1 500A TEXT('TXT1 ') | ||
+ | A TXT2 500A TEXT('TXT2 ') | ||
+ | A TXT3 500A TEXT('TXT3 ') | ||
+ | A TXT4 500A TEXT('TXT4 ') | ||
+ | A TXT5 500A TEXT('TXT5 ') | ||
+ | A TXT6 500A TEXT('TXT6 ') | ||
+ | A TXT7 500A TEXT('TXT7 ') | ||
+ | A TXT8 500A TEXT('TXT8 ') | ||
+ | A K ACTIV | ||
+ | A K CMPNO | ||
+ | A K PRDNO | ||
+ | A K OPBAL | ||
+ | A K SERVU | ||
+ | |||
+ | |||
+ | </pre> | ||
+ | |||
+ | [[#top]] |
Latest revision as of 22:42, 7 December 2018
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) [1]
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. 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.
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
H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ H OPTION(*NODEBUGIO) H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP ) F* F* LIMITED TO MAXIMUM FILE LENGTH OF 2048 F* TEST F* REQUIRES FILE TO COMPILE F* 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 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 DDISP PR D 1 D 1 D 4 D 1 D 500 D 5 D 800 DDISP 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 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 /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
DISP1 RPG
H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ H OPTION(*NODEBUGIO) H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DISP ) F* F* LIMITED TO MAXIMUM FILE LENGTH OF 4080 F* TEST F* REQUIRES FILE TO COMPILE F* 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 79 DIM(2) CTDATA PERRCD(1) D CRS S 1 DIM(16) CTDATA PERRCD(16) D DS D D 1 4080 D DIM(4080) INCOMING DATA D DA 1 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 DDISP1 PR D 1 D 1 D 4 D 1 D 500 D 5 D 800 DDISP1 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 2048 DA I 2049 2064 DB 30 I 2065 2096 DC 31 I 2097 2128 DD 32 I 2129 2160 DE 33 I 2161 2192 DF 34 I 2193 2224 DG 35 I 2225 2256 DH 36 I 2257 2288 DI 37 I 2289 2320 DJ 38 I 2321 2352 DK 39 I 2353 2384 DL 40 I 2385 2416 DM 41 I 2417 2448 DN 42 I 2449 2480 DZ 43 I 2481 2512 DO 44 I 2513 2544 DP 45 I 2545 2576 DQ 46 I 2577 2608 DR 47 I 2609 2640 DS 48 I 2641 2672 DT 49 I 2673 2704 DU 50 I 2705 2736 DV 51 I 2737 2768 DW 52 I 2769 2800 DX 53 I 2801 2832 DY 54 I 2833 2864 D0 55 I 2865 2896 D1 56 I 2897 2928 D2 57 I 2929 2960 D3 58 I 2961 2992 D4 59 I 2993 3024 D5 60 I 3025 3056 D6 61 I 3057 3088 DBA 62 I 3089 3120 DCA 63 I 3121 3152 DDA 64 I 3153 3184 DEA 65 I 3185 3216 DFA 66 I 3217 3248 DGA 67 I 3249 3280 DHA 68 I 3281 3312 DIA 69 I 3313 3344 DJA 70 I 3345 3376 DKA 71 I 3377 3408 DLA 72 I 3409 3440 DMA 73 I 3441 3472 DNA 74 I 3473 3504 DOA 75 I 3505 3536 DPA 76 I 3537 3568 DQA 77 I 3569 3600 DRA 78 I 3601 3632 DSA 79 I 3633 3664 DTA 80 I 3665 3696 DUA 81 I 3697 3728 DVA 82 I 3729 3760 DWA 83 I 3761 3792 DXA 84 I 3793 3824 DYA 85 I 3825 3856 DZA 86 I 3857 3888 D0A 87 I 3889 3920 D1A 88 I 3921 3952 D2A 89 I 3953 3984 D3A 90 I 3985 4016 D4A 91 I 4017 4048 D5A 92 I 4049 4080 D6A 93 IINPUTR NS 01 I 1 2048 DA I 2049 2064 DB 30 I 2065 2096 DC 31 I 2097 2128 DD 32 I 2129 2160 DE 33 I 2161 2192 DF 34 I 2193 2224 DG 35 I 2225 2256 DH 36 I 2257 2288 DI 37 I 2289 2320 DJ 38 I 2321 2352 DK 39 I 2353 2384 DL 40 I 2385 2416 DM 41 I 2417 2448 DN 42 I 2449 2480 DZ 43 I 2481 2512 DO 44 I 2513 2544 DP 45 I 2545 2576 DQ 46 I 2577 2608 DR 47 I 2609 2640 DS 48 I 2641 2672 DT 49 I 2673 2704 DU 50 I 2705 2736 DV 51 I 2737 2768 DW 52 I 2769 2800 DX 53 I 2801 2832 DY 54 I 2833 2864 D0 55 I 2865 2896 D1 56 I 2897 2928 D2 57 I 2929 2960 D3 58 I 2961 2992 D4 59 I 2993 3024 D5 60 I 3025 3056 D6 61 I 3057 3088 DBA 62 I 3089 3120 DCA 63 I 3121 3152 DDA 64 I 3153 3184 DEA 65 I 3185 3216 DFA 66 I 3217 3248 DGA 67 I 3249 3280 DHA 68 I 3281 3312 DIA 69 I 3313 3344 DJA 70 I 3345 3376 DKA 71 I 3377 3408 DLA 72 I 3409 3440 DMA 73 I 3441 3472 DNA 74 I 3473 3504 DOA 75 I 3505 3536 DPA 76 I 3537 3568 DQA 77 I 3569 3600 DRA 78 I 3601 3632 DSA 79 I 3633 3664 DTA 80 I 3665 3696 DUA 81 I 3697 3728 DVA 82 I 3729 3760 DWA 83 I 3761 3792 DXA 84 I 3793 3824 DYA 85 I 3825 3856 DZA 86 I 3857 3888 D0A 87 I 3889 3920 D1A 88 I 3921 3952 D2A 89 I 3953 3984 D3A 90 I 3985 4016 D4A 91 I 4017 4048 D5A 92 I 4049 4080 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
DISP2 RPG
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
DUSP RPG
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
DUSP1 RPG
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' ATTR NUM D X00 C X'00' D X01 C X'01' D X02 C X'02' D X03 C X'03' D X0D C X'0D' D X0F C X'0F' D X000 C X'0000' D X1F C X'1F' D X20 C X'20' SCRN ATT NORMAL D X22 C X'22' SCRN ATTR HI D X25 C X'25' D X26 C X'26' D X31 C X'31' CMD 1 KEY D X32 C X'32' CMD 2 KEY D X33 C X'33' CMD 3 KEY D X36 C X'36' CMD 6 KEY D X37 C X'37' CMD 7 KEY D X38 C X'38' CMD 8 KEY D X39 C X'39' CMD 9 KEY D X3B C X'3B' CMD11 KEY D XB7 C X'B7' CMD19 KEY D XB8 C X'B8' CMD20 KEY D X40 C X'40' D X43 C X'43' D X47 C X'47' D X60 C X'60' D X67 C X'67' D X9F C X'9F' D XF0 C X'F0' D XD0 C X'D0' D X4000 C X'4000' D X4800 C X'4800' FF ALPHA D X4F06 C X'4F06' FF NUMERIC D X6000 C X'6000' FF ALPHA D X6706 C X'6706' FF NUMERIC D CLRWTD C X'044004112000' INCLUDES ESC CHARS D RDDSP C X'0411200804524000' READ FROM DISPLAY D FFA1 S 1 INZ(X'40') F.FMT 1 ALPH 60 BYP D FFA2 S 1 INZ(X'00') F.FMT 2 ALPH D FFN1 S 1 INZ(X'47') F.FMT 1 NUM 67 BYP D FFN2 S 1 INZ(X'06') F.FMT 2 NUM I*. IINPUTK NS 01 I 1 2048 DA I 2049 2064 DB 30 I 2065 2096 DC 31 I 2097 2128 DD 32 I 2129 2160 DE 33 I 2161 2192 DF 34 I 2193 2224 DG 35 I 2225 2256 DH 36 I 2257 2288 DI 37 I 2289 2320 DJ 38 I 2321 2352 DK 39 I 2353 2384 DL 40 I 2385 2416 DM 41 I 2417 2448 DN 42 I 2449 2480 DZ 43 I 2481 2512 DO 44 I 2513 2544 DP 45 I 2545 2576 DQ 46 I 2577 2608 DR 47 I 2609 2640 DS 48 I 2641 2672 DT 49 I 2673 2704 DU 50 I 2705 2736 DV 51 I 2737 2768 DW 52 I 2769 2800 DX 53 I 2801 2832 DY 54 I 2833 2864 D0 55 I 2865 2896 D1 56 I 2897 2928 D2 57 I 2929 2960 D3 58 I 2961 2992 D4 59 I 2993 3024 D5 60 I 3025 3056 D6 61 I 3057 3088 DBA 62 I 3089 3120 DCA 63 I 3121 3152 DDA 64 I 3153 3184 DEA 65 I 3185 3216 DFA 66 I 3217 3248 DGA 67 I 3249 3280 DHA 68 I 3281 3312 DIA 69 I 3313 3344 DJA 70 I 3345 3376 DKA 71 I 3377 3408 DLA 72 I 3409 3440 DMA 73 I 3441 3472 DNA 74 I 3473 3504 DOA 75 I 3505 3536 DPA 76 I 3537 3568 DQA 77 I 3569 3600 DRA 78 I 3601 3632 DSA 79 I 3633 3664 DTA 80 I 3665 3696 DUA 81 I 3697 3728 DVA 82 I 3729 3760 DWA 83 I 3761 3792 DXA 84 I 3793 3824 DYA 85 I 3825 3856 DZA 86 I 3857 3888 D0A 87 I 3889 3920 D1A 88 I 3921 3952 D2A 89 I 3953 3984 D3A 90 I 3985 4016 D4A 91 I 4017 4048 D5A 92 I 4049 4080 D6A 93 IINPUTR NS 01 I 1 2048 DA I 2049 2064 DB 30 I 2065 2096 DC 31 I 2097 2128 DD 32 I 2129 2160 DE 33 I 2161 2192 DF 34 I 2193 2224 DG 35 I 2225 2256 DH 36 I 2257 2288 DI 37 I 2289 2320 DJ 38 I 2321 2352 DK 39 I 2353 2384 DL 40 I 2385 2416 DM 41 I 2417 2448 DN 42 I 2449 2480 DZ 43 I 2481 2512 DO 44 I 2513 2544 DP 45 I 2545 2576 DQ 46 I 2577 2608 DR 47 I 2609 2640 DS 48 I 2641 2672 DT 49 I 2673 2704 DU 50 I 2705 2736 DV 51 I 2737 2768 DW 52 I 2769 2800 DX 53 I 2801 2832 DY 54 I 2833 2864 D0 55 I 2865 2896 D1 56 I 2897 2928 D2 57 I 2929 2960 D3 58 I 2961 2992 D4 59 I 2993 3024 D5 60 I 3025 3056 D6 61 I 3057 3088 DBA 62 I 3089 3120 DCA 63 I 3121 3152 DDA 64 I 3153 3184 DEA 65 I 3185 3216 DFA 66 I 3217 3248 DGA 67 I 3249 3280 DHA 68 I 3281 3312 DIA 69 I 3313 3344 DJA 70 I 3345 3376 DKA 71 I 3377 3408 DLA 72 I 3409 3440 DMA 73 I 3441 3472 DNA 74 I 3473 3504 DOA 75 I 3505 3536 DPA 76 I 3537 3568 DQA 77 I 3569 3600 DRA 78 I 3601 3632 DSA 79 I 3633 3664 DTA 80 I 3665 3696 DUA 81 I 3697 3728 DVA 82 I 3729 3760 DWA 83 I 3761 3792 DXA 84 I 3793 3824 DYA 85 I 3825 3856 DZA 86 I 3857 3888 D0A 87 I 3889 3920 D1A 88 I 3921 3952 D2A 89 I 3953 3984 D3A 90 I 3985 4016 D4A 91 I 4017 4048 D5A 92 I 4049 4080 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 = 2048; IF ONCE = ' '; EXSR @INITZ ; ENDIF; // START TAG DOW @LOOP = @LOOP; IF RTN = '3'; IF *INU1; KEYA = SCNKEY; ENDIF; IF *INU2; RRNA = %DEC(%SUBST(SCNKEY:1:11):11:0); ENDIF; RTN = '0'; AID = '1'; ELSE; RTN = '0'; READ(E) DISPF; ENDIF; // CF3 EXIT IF AID = X33; LEAVE; ENDIF; // CF2 RETURN IF AID = X32; RTN = '1'; LEAVE; ENDIF; // CF1 HEX A FIELD IF AID = X31; Y = %LOOKUPLE( CURLOC : B ); IF Y > 0; IF KY(Y) <= '1'; EXSR @HXDSP; REHEAD = '1'; EXSR @PUTHED; REHEAD = ' '; ENDIF; ENDIF; ENDIF; // CF20 MORE FIELDS IF AID = XB8; LVX = LVL + 1; IF LV(LVX) <> *BLANK; LVL = LVL +1 ; LVW = LV; SCNLV = TEXT500; SCNLVL = %EDITC(LVL :'X'); SCNKEY = *BLANKS; IF *INU1; SCNKEY = KEYA; ENDIF; IF *INU2; SCNKEY = %EDITC(RRNA:'X'); ENDIF; RTN = '3'; LEAVE; ENDIF; ENDIF; // CF19 PREVIOUS FIELDS IF AID = XB7; LVX = LVL - 1; IF LVX >= 0 ; LVL = LVL - 1 ; LVW = LV; SCNLV = TEXT500; SCNLVL = %EDITC(LVL :'X'); SCNKEY = *BLANKS; IF *INU1; SCNKEY = KEYA; ENDIF; IF *INU2; SCNKEY = %EDITC(RRNA:'X'); ENDIF; RTN = '3'; LEAVE; ENDIF; ENDIF; // 1 ENTER 4 ROLL DN 5 ROLL UP // F6 = X36 F9 = X39 F11 = X3B IF AID = '1'or AID = '4' or AID = '5' or AID = X36 or AID = X39 or AID = X3B; ELSE; MX = 1; // INVALID KEY EXSR @ERROR; ENDIF; // UPDATE MODE IF UPDF = 'Y'; UPDDONE = @FALSE; // F6 IF *INU1 AND AID = X36 AND (LOP1 = X01 OR LOP1 = X03); EXSR @UPD; EXCEPT UPDATREC; UPDDONE = @TRUE; ENDIF; IF *INU2 AND AID = X36 AND (LOP2 = X01 OR LOP2 = X02); EXSR @UPD; EXCEPT UPDATREC; UPDDONE = @TRUE; ENDIF; // F9 IF AID = X39; EXSR @UPD; EXCEPT ADDREC; UPDDONE = @TRUE; ENDIF; // F11 IF *INU1 AND AID = X3B AND (LOP1 = X01 OR LOP1 = X03); EXCEPT DELREC; UPDDONE = @TRUE; ENDIF; IF *INU2 AND AID = X3B AND (LOP2 = X01 OR LOP2 = X02); EXCEPT DELREC; UPDDONE = @TRUE; ENDIF; ENDIF; IF RTN = '3' OR UPDDONE = @TRUE; ELSE; EXSR @PCKD; ENDIF; // CONT1 GET A RECORD, KEY FROM DATA EXSR @SETIN; EXSR @GETF ; EXSR @PUTF ; EXSR @KEYIN; ENDDO ; *INLR = *ON; // @@@@@@@ @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @INITZ; ONCE = '1'; KEYLNA = KEYLNG ; EXSR @INIT ; EXSR @GETFLD ; EXSR @GETADD ; EXSR @PUTHED ; EXSR @KEYIN ; INZ = '1'; EXSR @PCKD ; INZ = ' '; ENDSR; // @@@@@@@ @PCKD @@@@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @PCKD ; // CONVERT KEY DATA IF *INU1 ; EXSR @CVTKEY; ENDIF; IF *INU2 ; EXSR @CVTRRN; ENDIF; ENDSR; // @@@@@@@ @CVTKEY @@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @CVTKEY; // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE // THE MODIFIED DATA INTO THE COMPOSITE KEY K1 = 0; K2 = 0; W = 1; FOR Y = 1 TO NUMKEY ; // MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS) // GET SIZE OF FIELD IN BYTES IF T(Y) = 'A'; // ALPHA DATA K = ' '; K1 = 1; K2 = Q(Y); ELSE; K = '0'; K1 = 1; K2 = C(Y); ENDIF; // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT IF INZ = '1' ; KW = *BLANK; EXSR @PCKMOV; ITER; ENDIF; X = 1; DOW @LOOP = @LOOP; // NXTSBA X = %LOOKUP(SBA : ID : X ); IF X = 0; LEAVE; ENDIF; // IS THIS THE FIELD? CHECK THE BUFFER ADDRESS X = X +1; IF B(Y) <> %SUBST(IDA : X :2); ITER; ENDIF; // FOUND A MTD FOR THIS FIELD X = X + 2; // CHECK IF FIELD WAS CLEARED ONLY IF ID(X) = SBA; EXSR @PCKMOV; LEAVE ; ENDIF; // IF FIELD HAS DECIMALS BUMP X IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND P(Y) > 0; X = X + 1; ENDIF; // CHECK IF ONLY BLANKS RETURNED IF %SUBST(IDA : X :K2) = *BLANKS; EXSR @PCKMOV; LEAVE; ENDIF; // EXTRACT THE DATA FROM THE INCOMING STRING X1 = X; FOR X2 = 1 TO K2 ; IF ID(X1) < ' '; // TRAP NULLS CAUSED BY FLD EXIT EXSR @PCKMOV; LEAVE; ENDIF; K(X2) = ID(X1); X1 = X1 +1; ENDFOR; // CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED // INTO ARRAY KW EXSR @PCKMOV; LEAVE; ENDDO; ENDFOR; // KEYA = KW; CLEAR KW; ENDSR ; // @@@@@@@ @CVTRRN @@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @CVTRRN; // RRN NUM11 = 0; DOW @LOOP = @LOOP; // NOT REALLY A LOOP(SIMULATES GOTO) // GET THE FIRST SBA X = 1; X = %LOOKUP(SBA : ID : X ); IF X = 0; LEAVE; ENDIF; // CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD X = X +1; IF B(1) <> %SUBST(IDA : X :2); ITER; ENDIF; // FOUND A MTD FOR RRN FIELD X = X +2; //CHECK IF FIELD WAS CLEARED ONLY IF ID(X) = SBA; LEAVE; ENDIF; // CHECK IF ONLY BLANKS RETURNED IF %SUBST(IDA : X :11) = *BLANKS; LEAVE; ENDIF; // WRK11 OVERLAYS NUM11 WRK11 = %SUBST(IDA : X :11); LEAVE; ENDDO; RRNA = NUM11; IF RRNA < 0; RRNA = 1; ENDIF; ENDSR; // @@@@@@@ @PCKMOV @@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @PCKMOV; // // CONVERT KEY DATA // SET START POSN IN KEY USING OFFSET IN R X1 = %LOOKUP(N(Y) : N ); W = R(X1) + 1; // ALPHA IF T(Y) = 'A'; X1 = 1; FOR Z = W TO W + Q(Y); %SUBST(KW : Z : 1) = K(X1); X1 = X1 + 1; ENDFOR; ENDIF; // NUMERIC FIELD // RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B'); NU = '0'; Z1 = 60; FOR Z = K2 DOWNTO K1; IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$'; ITER; ENDIF; IF K(Z) = ' ' ; NU(Z1) = '0'; ELSE; NU(Z1) = K(Z); ENDIF; Z1 = Z1 -1; ENDFOR; ENDIF; // SIGNED FIELDS (END POSN = OFFSET + SIZE) IF T(Y) = 'S'; NUS = 0; FOR VX = 1 TO 60; NUSA = %TRIM(NUSA) + NU(VX); ENDFOR; %SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y)); ENDIF; // PACKED FIELDS IF T(Y) = 'P'; NUSA= *BLANKS; FOR VX = 1 TO 60; NUSA = %TRIM(NUSA) + NU(VX); ENDFOR; NUP = %DEC(NUSA : 60 : 0); %SUBST(KW : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y)); ENDIF; // BINARY FIELDS IF T(Y) = 'B'; IF Q(Y) = 2 ; BY2 = NU(1) + NU(2); %SUBST(KW : W : 2) = BY2; ENDIF; IF Q(Y) = 4 ; BY4 = NU(1) + NU(2) + NU(3) + NU(4); %SUBST(KW : W : 4) = BY4; ENDIF; ENDIF; ENDSR; // @@@@@@@ SETIN @@@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @SETIN; // SET the FFR indicators to get the Input buffer somewhat aligned with the // actual data. RPG is somewhat tolerant to a difference between the Ispecs // and the actual file size but it can fail on big differences. // INCREMENT OF 32 BYTES SZ(1) = BASE + 16; SZ(2) = SZ(1) + 16; *IN30 = *ON; IF (RLEN > SZ(2)) ; *IN31 = *ON; ENDIF; FOR X = 3 TO 64; SZ(X) = SZ(X-1) + 32; IF (RLEN > SZ(X)) ; *IN(29+X) = *ON; ENDIF; ENDFOR; ENDSR; //@@@@@@@@@@@@@@@@@ @GETF @@@@@@@@@@@@@@@@@ BEGSR @GETF; // GET A DATA RECORD IF (*INU1); IF AID = '1' OR AID = X36 OR AID = X39 OR AID = X3B ; SETLL(E) KEYA INPUTK; READ(E) INPUTK; IF %EOF; SETLL(E) KEYA INPUTK; READP(E) INPUTK; ENDIF; ENDIF; IF AID = '4'; READP(E) INPUTK; ENDIF; IF AID = '5'; READ(E) INPUTK; ENDIF; IF %ERROR; SETLL(E) KEYA INPUTK; READ(E) INPUTK; MX = 7; EXSR @ERROR; EXSR @PUTF ; EXSR @KEYIN; ENDIF; KEYA = LKY; CLEAR KW; KW = LKY; ENDIF; IF (*INU2); IF AID = '1'; CHAIN(E) RRNA INPUTR; IF %ERROR; SETLL(E) RRNA INPUTR; READP(E) INPUTR; ENDIF; ENDIF; IF AID = X36; CHAIN(E) RRNA INPUTR; ENDIF; IF AID = '4'; READP(E) INPUTR; ENDIF; IF AID = '5' OR AID = X3B; READ(E) INPUTR; ENDIF; IF AID = X39; SETLL(E) *HIVAL INPUTR; READP(E) INPUTR; ENDIF; IF %ERROR; CHAIN 1 INPUTR; MX = 7; EXSR @ERROR; EXSR @PUTF ; EXSR @KEYIN; ENDIF; ENDIF; ENDSR; //@@@@@@@@@@@@@@@@@ @PUTF @@@@@@@@@@@@@@@@@ BEGSR @PUTF; SELECT; WHEN *INU1; RRN = RN1; WHEN *INU2; RRN = RN2; ENDSL; // IF GOT RECORDS WRITE DATA TO THE DISPLAY NEWRU = '1'; WRTRRN = '1'; RU = *ALLX'00'; CLEAR RU; // initialise Request Unit 255 bytes max IF RRN > 0 ; FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) IF NEWRU = '1'; NEWRU = '0'; RU = ESC + WTD + X20 + X00; ENDIF; IF WRTRRN = '1'; WRTRRN = '0'; RU = RU + SBA + RBA ; RU = RU + %TRIM(%EDITC(RRN:'Z')); ENDIF; // BUFFER ADDRESS RU = RU + SBA + B(XX); // PROCESS ALPHA DATA TYPE IF T(XX) = 'A' OR T(XX) = 'T' OR T(XX) = 'Z' OR T(XX) = 'L'; STRX = S(XX); ENDX = E(XX); IF V(XX) = 'Y'; //VARYING VX = S(XX); HX2 = D(VX) + D(VX+1); STRX = S(XX) + 2 ; ENDX = S(XX) + BIN; ENDIF; FOR Y = STRX TO ENDX ; IF D(Y) >= ' '; RU = RU + D(Y); ELSE; RU = RU + X1F ; //IF NOT DISPLAYABLE REPLACE WITH X'1F' ENDIF; ENDFOR; ENDIF; // PROCESS SIGNED DATA TYPE (not the RRN field) IF T(XX) = 'S' and KY(XX) <> '3'; NUSA = *ALL'0'; WRV = *ALLX'00'; CLEAR WRV; FOR Y = S(XX) TO E(XX); IF D(Y) >= XD0; WRV = WRV + D(Y); ENDIF; ENDFOR; EVAL NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV; CLEAR WRU; WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD); IF P(XX) > 0; RU = RU + %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' + %SUBST(WRU :61-P(XX)) ; ELSE; RU = RU + %SUBST(WRU :61-C(XX)); ENDIF; ENDIF; // PROCESS SIGNED DATA TYPE (the RRN field) IF T(XX) = 'S' and KY(XX) = '3'; RRN = RN2; RU = RU + %TRIM(%EDITC(RRN:'X')); ENDIF; // PROCESS PACKED DATA TYPE IF T(XX) = 'P'; NUPA = *ALLX'00'; WRV = *ALLX'00'; CLEAR WRV; FOR Y = S(XX) TO E(XX); WRV = WRV + D(Y); ENDFOR; IF %BITAND(D(E(XX)) :X0F) = X0F OR %BITAND(D(E(XX)) :X0D) = X0D; EVAL NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV; CLEAR WRX; WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD); IF P(XX) > 0; RU = RU + %SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' + %SUBST(WRX :64-P(XX)) ; ELSE; RU = RU + %SUBST(WRX :64-C(XX)); ENDIF; ELSE; // PACKED FIELD IN ERROR RU = RU + X1F; ENDIF; ENDIF; // PROCESS BINARY DATA TYPE IF T(XX) = 'B'; ST = S(XX); CLEAR NUSA; IF Q(XX) = 2; BY2 = D(ST) + D(ST+1); NUS = BIN2; ENDIF; IF Q(XX) = 4; BY4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3); NUS = BIN4; ENDIF; WRU = %EDITW(NUS :WRSWRD); IF P(XX) > 0; RU = RU + %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' + %SUBST(WRU :61-P(XX)) ; ELSE; RU = RU + %SUBST(WRU :61-C(XX)); ENDIF; ENDIF; // PROCESS FLOAT DATA TYPE IF T(XX) = 'F'; ST = S(XX); IF Q(XX) = 4; FL4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3); FLT14 = %EDITFLT(FLT4); RU = RU + FLT14; ENDIF; IF Q(XX) = 8; FL8 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) + D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7); FLT23 = %EDITFLT(FLT8); RU = RU + FLT23; ENDIF; ENDIF; // SEND A REQUEST UNIT IF GOT ENOUGH DATA IF %LEN(RU) + L(XX + 1) >= 200; RU = RU + X20; BIN = %LEN(RU); OUTLEN = HX2; INLEN = X000; FNC = SND; A = RU; EXCEPT DATAO; NEWRU = '1'; RU = *ALLX'00'; CLEAR RU; ENDIF; ENDFOR; ENDIF; IF %LEN(RU) > 5 AND %LEN(RU) < 250; RU = RU + X20; BIN = %LEN(RU); OUTLEN = HX2; INLEN = X000; FNC = SND; A = RU; EXCEPT DATAO; ENDIF; ENDSR; // @@@@@@@@@@@@@@@ ROWINC @@@@@@@@@@@@@@@ // INCREMENT THE ROW BEGSR @ROWINC; ROW = ROW + 2; IF ROW > 20; MX = 3; ENDIF; ENDSR; // @@@@@@@@@@@@@@@ GETFLD @@@@@@@@@@@@@@@ // LOAD FIELD DESCRIPTION ARRAYS BEGSR @GETFLD; MX = 0; X = 0; IF (*INU2 = *ON); // IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN N(1) = 'RRN'; T(1) = 'S' ; C(1) = 11 ; P(1) = 0 ; S(1) = 0 ; E(1) = 0 ; L(1) = 12 ; I(1) = X4F06 ; KY(1)= '3' ; X = 1 ; ENDIF; SCRST = *BLANK; SCRSTN = *BLANK; LVL = %DEC(SCNLVL : 5:0); TEXT500 = SCNLV ; LV = LVW; IF LVL <> 0; SCRST = LV(LVL); ENDIF; SETLL 1 QWHDRFFD ; DOW @LOOP = @LOOP; // REREAD TAG READ QWHDRFFD; IF %EOF; LEAVE; ENDIF; // SELECT OR OMIT IF ALL <> '1'; IF ALL = 'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS IF WHFIOB <> 'S'; ITER; ENDIF; ENDIF; IF ALL = 'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS IF WHFIOB = 'O'; ITER; ENDIF; ENDIF; ENDIF; // FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS) IF WHDFTL <> 0 ; ELSE; IF SCRST <> ' ' AND SCRSTN = ' '; IF WHFLDE = SCRST; SCRSTN = '1'; // FOUND THE START ELSE; ITER; ENDIF; ENDIF; ENDIF; X = X + 1; // CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT IF WHDFTL <> 0; KY(X) = '1'; WX = WHDFTL ; KE(WX) = WHFLDE; IF NUMKEY < WHDFTL; NUMKEY = WHDFTL; ENDIF; ENDIF; N(X) = WHFLDE ; // NAME T(X) = WHFLDT ; // TYPE V(X) = WHVARL ; // VARYING C(X) = WHFLDD ; // DEC DIGITS P(X) = WHFLDP ; // DEC PREC S(X) = WHFOBO ; // START Q(X) = WHFLDB ; // BTYES E(X) = WHFOBO + WHFLDB -1 ; // END IF T(X) = 'F' ; // FLOAT I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA L(X) = 14; IF Q(X) = 8; L(X) = 23; ENDIF; ELSE; IF WHFLDD <> 0 ; IF WHFLDP <> 0 ; L(X) = WHFLDD + 2 ; // LENGTH ELSE; L(X) = WHFLDD + 1 ; // LENGTH ENDIF; I(X) = FFN1 + FFN2; // SCRN FIELD FORMAT NUMERIC ELSE; L(X) = WHFLDB ; I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA ENDIF; ENDIF; ENDDO; // NUMBER OF FIELDS NUMFLD = X ; // MAKE ROOM FOR KEYS IF NUMKEY > 0 ; X1 = NUMKEY + NUMFLD; FOR X = NUMFLD DOWNTO 1; KY(X1) = KY(X) ; L(X1) = L(X) ; I(X1) = I(X) ; N(X1) = N(X) ; T(X1) = T(X) ; V(X1) = V(X) ; C(X1) = C(X) ; P(X1) = P(X) ; S(X1) = S(X) ; E(X1) = E(X) ; Q(X1) = Q(X) ; X1 = X1 - 1; ENDFOR; // PUT KEY FIELDS AT TOP OFF = 0; FOR X = 1 TO NUMKEY; X1 = %LOOKUP(KE(X) : N : NUMKEY+1); KY(X) = '2'; L(X) = L(X1); I(X) = I(X1); // FIELD FMT SELECT; // INPUT ENABLE WHEN I(X) = X6000; I(X) = X4800; WHEN I(X) = X6706; I(X) = X4F06; ENDSL; N(X) = N(X1); T(X) = T(X1); V(X) = V(X1); C(X) = C(X1); P(X) = P(X1); S(X) = S(X1); E(X) = E(X1); Q(X) = Q(X1); R(X) = OFF; OFF = OFF + Q(X1); ENDFOR; ENDIF; // NUMBER OF FIELDS AND KEYS NUMFKY = NUMFLD + NUMKEY; ENDSR; // @@@@@@@@@@@@@@@ GETADD @@@@@@@@@@@@@@@ // LOAD FIELD BUFFER ADDRESSES BEGSR @GETADD; MX = 0; X = 0; ROW = 3; COL = 1; FOR X = 1 TO NUMFKY; // IF FINISHED WITH THE KEY FIELDS // INC ROW FOR 1ST DATA FIELD IF KEYSOK = ' ' ; IF KY(X) = ' ' OR KY(X) = '1'; KEYSOK = '1' ; ROW = ROW + 2; COL = 1; ENDIF; ENDIF; // SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE LENDSC = %LEN(%TRIM(N(X))); LENWRK = L(X); IF LENDSC > L(X); LENWRK = LENDSC; ENDIF; LENWRK = LENWRK + 2; // TRAP FIELDS THAT OVERFLOW ROW = ROW + XROW; XROW = %DIV(LENWRK : 80); IF (COL + LENWRK) > 78; EXSR @ROWINC; IF MX = 3; X= X-1; NUMFKY = X; LEAVE; ENDIF; COL = 1; ENDIF; // INC COL. FOR FIELD START CLEAR B(X); BIN = ROW; B(X) = %TRIM(B(X)) + HX1; BIN = COL + 1; B(X) = %TRIM(B(X)) + HX1; // INC COL. FOR NEXT FIELD COL = COL + LENWRK; IF COL > 78; EXSR @ROWINC; IF MX = 3; // NO ROOM FOR THE FIELD X= X-1; NUMFKY = X; LEAVE; ENDIF; COL = 1; ENDIF; ENDFOR; // FIELD LEVEL LVX = LVL + 1; LV(LVX) = N(X); ENDSR; // @@@@@@@@@@@@@@@ PUTHED @@@@@@@@@@@@@@@ // PUT FIELD HEADINGS BEGSR @PUTHED; NEWRU = '1'; RU = *ALLX'00'; CLEAR RU; // initialise Request Unit 255 bytes max FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) IF NEWRU = '1'; NEWRU = '0'; RU = ESC + WTD + X20 + X00; ENDIF; RU = RU + SBA; BIN = 0; // CONVERT DATA BUFADR TO HEADING BUFADR HX1 = %SUBST(B(XX) :1:1); BIN = BIN - 1; RU = RU + HX1; IF REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR BIN = 0; HX1 = %SUBST(B(XX) :2:1); BIN = BIN -1 ; RU = RU + HX1; ELSE; RU = RU + %SUBST(B(XX) :2); ENDIF; RU = RU + ATC ; // LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS LENDSC = %LEN(%TRIM(N(XX))); IF T(XX) <> 'A' AND LENDSC < (L(XX) -1); FOR Y = 1 TO (L(XX) -(LENDSC +1)); RU = RU + ' '; ENDFOR; ENDIF; RU = RU + %TRIM(N(XX)); IF %LEN(RU) >= 200; BIN = %LEN(RU); OUTLEN = HX2; INLEN = X000; FNC = SND; A = RU; EXCEPT DATAO; NEWRU = '1'; RU = *ALLX'00'; CLEAR RU; ENDIF; ENDFOR; IF %LEN(RU) > 5 AND %LEN(RU) < 200; BIN = %LEN(RU); OUTLEN = HX2; INLEN = X000; FNC = SND; A = RU; EXCEPT DATAO; ENDIF; IF REHEAD <> '1'; // FORMAT FIELDS NEWRU = '1'; RU = *ALLX'00'; CLEAR RU; // initialise Request Unit 255 bytes max FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) IF NEWRU = '1'; NEWRU = '0'; RU = ESC + WTD + X20 + X00; ENDIF; RU = RU + SBA +B(XX)+SF + I(XX); IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3'; RU = RU + X25; ELSE; RU = RU + X26; ENDIF; BIN = L(XX); RU = RU + HX2; // LENGTH OF INPUT FIELDS LENF = LENF + L(XX) + 3; IF %LEN(RU) >= 200; BIN = %LEN(RU); OUTLEN = HX2; INLEN = X000; FNC = SND; A = RU; EXCEPT DATAO; NEWRU = '1'; RU = *ALLX'00'; CLEAR RU; ENDIF; ENDFOR; // PUT LAST R/U IF %LEN(RU) > 5 AND %LEN(RU) < 200; BIN = %LEN(RU); OUTLEN = HX2; INLEN = X000; FNC = SND; A = RU; EXCEPT DATAO; ENDIF; //INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT FOR XP = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) HX2 = B(XP); BIN = BIN + 1; B(XP) = HX2; ENDFOR; ENDIF; ENDSR; // @@@@@@@ INIT @@@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @INIT; CLEAR KW; // UPDATE IF UPDF = 'Y'; FFA1 = X40; FFN1 = X47; ELSE; FFA1 = X60; FFN1 = X67; ENDIF; SELECT; WHEN *INU1 = '1'; FILE = F1 ; LIB = L1 ; MBR = M1 ; RCDL = R1 ; ACCTP = A1 ; WHEN *INU2 = '1'; FILE = F2 ; LIB = L2 ; MBR = M2 ; RCDL = R2 ; ACCTP = A2 ; ENDSL; RLEN = RCDL ; RLENTH = %EDITC(RLEN: 'X') ; LENF = 0 ; // Control commands and data are constructed into RUs Request UNITS // Each RU is 256 bytes max size. // Construct and send as many RUs as needed to format the display. RU = *ALLX'00'; CLEAR RU; // initialise Request Unit 255 bytes max RU = CLRWTD ; //set up the screen headings BIN = 1; // set ROW to 1 RW = HX1; BIN = 2; // set COL to 2 CL = HX1; RU = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE); RU = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN : 'Z') ; RU = RU + ' RRN ' ; BIN = %len(RU) -4; RBA = RW + HX1 ; // address of the RRN field RU = RU + SBA + RBA + ' '; // FUNCTION KEYS BIN = 23; RW = HX1; BIN = 02; CL = HX1; IF UPDF = 'Y'; // UPDATE IS ON RU = RU + SBA + RW + CL + %TRIM(CNS(2)); ELSE; RU = RU + SBA + RW + CL + %TRIM(CNS(1)); ENDIF; // THIS IS A SEND ONLY FUNCTION FNC = SND; CLEAR A; A = RU; BIN2 = %LEN(RU); OUTLEN = BY2; INLEN = x000; EXCEPT DATAO; ENDSR; // @@@@@@@ KEYIN @@@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @KEYIN; // ISSUE A READ FROM DISPLAY FNC = SNR; BIN2 = 8; OUTLEN = BY2; IPL = LENF + 34; BIN2 = IPL; INLEN = BY2; // SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW FOR X = 1 TO 9; IF IPL > ( X*80 +3); *IN(X+19) = *ON; ENDIF; ENDFOR; RU = *ALLX'00'; CLEAR RU; RU = RDDSP; A = RU; EXCEPT DATAI; ENDSR; // @@@@@@@ ERROR @@@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @ERROR; // SETUP PUT ERROR MESSAGE X'21' RU = *ALLX'00'; CLEAR RU; FNC = SNR; BIN = 42; OUTLEN = HX2; BIN = LENF + 34; IPL = BIN; INLEN = HX2; FOR X = 1 TO 9; IF IPL > (X * 80 +3) ; *IN(X + 19) = *ON; // SETON FFR 20 - 29 FOR INPUT ENDIF; ENDFOR; RU = ESC + WER + IC + B(1) + ATC + MSG(MX); RU = RU + ESC + RDM + X40+ X00; A = RU; EXCEPT DATAI; RU = *ALLX'00'; CLEAR RU; ENDSR; // @@@@@@@ HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @HXDSP; RU = *ALLX'00'; CLEAR RU; Y = %LOOKUPLE( CURLOC : B ); // RU = ESC + WTD + X20 + X00 + SBA; BIN = 0; HX1 = %SUBST(B(Y) :1:1); BIN = BIN - 1; RU = RU + HX1; RU = RU + %SUBST(B(Y) :2:1); FOR X = S(Y) TO E(Y); BIN = 0; HX1 = D(X); HX1 = %BITAND(HX1 : XF0); Z = BIN / 16 + 1; RU = RU + CRS(Z); ENDFOR; RU = RU + X20; RU = RU + SBA + B(Y); FOR X = S(Y) TO E(Y); BIN = 0; HX1 = D(X); HX1 = %BITAND(HX1 : X0F); Z = BIN + 1; RU = RU + CRS(Z); ENDFOR; BIN = %LEN(RU); OUTLEN = HX2; INLEN = X000; FNC = SND; A = RU; EXCEPT DATAO; RU = *ALLX'00'; CLEAR RU; EXSR @KEYIN; READ DISPF; // CLEAR HEADINGS RU = *ALLX'00'; CLEAR RU; RU = RU + ESC + WTD + X20 + X00 + SBA; HX1 = %SUBST(B(Y) :1:1) ; BIN = BIN - 1; RU = RU + HX1 + %SUBST(B(Y):2:1); FOR X = S(Y) TO E(Y); RU = RU + ' '; ENDFOR; RU = RU + ' '; BIN = %LEN(RU); OUTLEN = HX2; INLEN = X000; FNC = SND; A = RU; EXCEPT DATAO; RU = *ALLX'00'; CLEAR RU; ENDSR; // @@@@@@@ UPD @@@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @UPD; // CONVERT DATA FOR OUTPUT // FOR EACH FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE // THE MODIFIED DATA INTO THE OUTPUT ARRAY K1 = 0; K2 = 0; W = 1; CGKY = *BLANK; // KEY CHANGED KW = KEYA; FOR Y = 1 TO NUMFKY ; IF KY(Y) > '1'; ITER; ENDIF; // MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY // GET SIZE OF FIELD IN BYTES IF T(Y) = 'A'; // ALPHA DATA K = ' '; K1 = 1; K2 = Q(Y); ELSE; K = '0'; K1 = 1; K2 = C(Y); ENDIF; X = 1; DOW @LOOP = @LOOP; // NXTSBA X = %LOOKUP(SBA : ID : X ); IF X = 0; LEAVE; ENDIF; // IS THIS THE FIELD? CHECK THE BUFFER ADDRESS X = X +1; IF B(Y) <> %SUBST(IDA : X :2); ITER; ENDIF; // FOUND A MTD FOR THIS FIELD // CHECK IF FIELD WAS CLEARED ONLY DOW @LOOP = @LOOP; // not a loop X = X + 2; IF ID(X) = SBA; LEAVE; ENDIF; // IF FIELD HAS DECIMALS BUMP X IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND P(Y) > 0; X = X + 1; ENDIF; // CHECK IF ONLY BLANKS RETURNED IF %SUBST(IDA : X :K2) = *BLANKS; LEAVE; ENDIF; // MOVE DATA TO WORK ARRAY K X1 = X; FOR X2 = 1 TO K2; IF ID(X1) < ' '; LEAVE; ENDIF; K(X2) = ID(X1); X1 = X1 + 1; ENDFOR; LEAVE; ENDDO; // * SET START POSN W = S(Y); // ALPHA IF T(Y) = 'A' and V(XX) <> 'Y'; FOR Z = K1 to K2; D(W) = K(Z); W = W + 1; ENDFOR; ENDIF; IF T(Y) = 'A' and V(XX) = 'Y'; //VARYING // the data start is in S(Y) // the data is in array K // get the length of the data cvt to bin and stik in pos 1 2 // put the rest in pos 3 onwards ENDIF; // NUMERIC FIELD // RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B'); NU = '0'; Z1 = 60; FOR Z = K2 DOWNTO K1; IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$'; ITER; ENDIF; IF K(Z) = ' ' ; NU(Z1) = '0'; ELSE; NU(Z1) = K(Z); ENDIF; Z1 = Z1 -1; ENDFOR; ENDIF; // SIGNED FIELDS (END POSN = OFFSET + SIZE) IF T(Y) = 'S'; NUSA= *BLANKS; FOR VX = 1 TO 60; NUSA = %TRIM(NUSA) + NU(VX); ENDFOR; %SUBST(DATA : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y)); ENDIF; // PACKED FIELDS IF T(Y) = 'P'; NUSA= *BLANKS; FOR VX = 1 TO 60; NUSA = %TRIM(NUSA) + NU(VX); ENDFOR; NUP = %DEC(NUSA : 60 : 0); %SUBST(DATA : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y)); ENDIF; // BINARY FIELDS IF T(Y) = 'B'; NUSA= *BLANKS; FOR VX = 1 TO 60; NUSA = %TRIM(NUSA) + NU(VX); ENDFOR; NUC = NUS; IF Q(Y) = 2 ; DISBIN ( NUC : BAN2 : BAN4 : '2'); %SUBST(DATA : W : 2) = BAN2; ENDIF; IF Q(Y) = 4 ; DISBIN ( NUC : BAN2 : BAN4 : '4'); %SUBST(DATA : W : 4) = BAN4; ENDIF; ENDIF; // UPDATE KEY IF NECESSARY IF KY(Y) = '1'; CGKY = '1'; EXSR @PCKMOV; ENDIF; ENDDO; ENDFOR; IF CGKY = '1'; KEYA = KW; ENDIF; ENDSR; /END-FREE OINPUTK E U1 UPDATREC O DA O 30 DB O 31 DC O 32 DD O 33 DE O 34 DF O 35 DG O 36 DH O 37 DI O 38 DJ O 39 DK O 40 DL O 41 DM O 42 DN O 43 DZ O 44 DO O 45 DP O 46 DQ O 47 DR O 48 DS O 49 DT O 50 DU O 51 DV O 52 DW O 53 DX O 54 DY O 55 D0 O 56 D1 O 57 D2 O 58 D3 O 59 D4 O 60 D5 O 61 D6 O 62 DBA O 63 DCA O 64 DDA O 65 DEA O 66 DFA O 67 DGA O 68 DHA O 69 DIA O 70 DJA O 71 DKA O 72 DLA O 73 DMA O 74 DNA O 75 DOA O 76 DPA O 77 DQA O 78 DRA O 79 DSA O 80 DTA O 81 DUA O 82 DVA O 83 DWA O 84 DXA O 85 DYA O 86 DZA O 87 D0A O 88 D1A O 89 D2A O 90 D3A O 91 D4A O 92 D5A O 93 D6A OINPUTR E U2 UPDATREC O DA O 30 DB O 31 DC O 32 DD O 33 DE O 34 DF O 35 DG O 36 DH O 37 DI O 38 DJ O 39 DK O 40 DL O 41 DM O 42 DN O 43 DZ O 44 DO O 45 DP O 46 DQ O 47 DR O 48 DS O 49 DT O 50 DU O 51 DV O 52 DW O 53 DX O 54 DY O 55 D0 O 56 D1 O 57 D2 O 58 D3 O 59 D4 O 60 D5 O 61 D6 O 62 DBA O 63 DCA O 64 DDA O 65 DEA O 66 DFA O 67 DGA O 68 DHA O 69 DIA O 70 DJA O 71 DKA O 72 DLA O 73 DMA O 74 DNA O 75 DOA O 76 DPA O 77 DQA O 78 DRA O 79 DSA O 80 DTA O 81 DUA O 82 DVA O 83 DWA O 84 DXA O 85 DYA O 86 DZA O 87 D0A O 88 D1A O 89 D2A O 90 D3A O 91 D4A O 92 D5A O 93 D6A OINPUTK EADD U1 ADDREC O DA O 30 DB O 31 DC O 32 DD O 33 DE O 34 DF O 35 DG O 36 DH O 37 DI O 38 DJ O 39 DK O 40 DL O 41 DM O 42 DN O 43 DZ O 44 DO O 45 DP O 46 DQ O 47 DR O 48 DS O 49 DT O 50 DU O 51 DV O 52 DW O 53 DX O 54 DY O 55 D0 O 56 D1 O 57 D2 O 58 D3 O 59 D4 O 60 D5 O 61 D6 O 62 DBA O 63 DCA O 64 DDA O 65 DEA O 66 DFA O 67 DGA O 68 DHA O 69 DIA O 70 DJA O 71 DKA O 72 DLA O 73 DMA O 74 DNA O 75 DOA O 76 DPA O 77 DQA O 78 DRA O 79 DSA O 80 DTA O 81 DUA O 82 DVA O 83 DWA O 84 DXA O 85 DYA O 86 DZA O 87 D0A O 88 D1A O 89 D2A O 90 D3A O 91 D4A O 92 D5A O 93 D6A OINPUTR EADD U2 ADDREC O DA O 30 DB O 31 DC O 32 DD O 33 DE O 34 DF O 35 DG O 36 DH O 37 DI O 38 DJ O 39 DK O 40 DL O 41 DM O 42 DN O 43 DZ O 44 DO O 45 DP O 46 DQ O 47 DR O 48 DS O 49 DT O 50 DU O 51 DV O 52 DW O 53 DX O 54 DY O 55 D0 O 56 D1 O 57 D2 O 58 D3 O 59 D4 O 60 D5 O 61 D6 O 62 DBA O 63 DCA O 64 DDA O 65 DEA O 66 DFA O 67 DGA O 68 DHA O 69 DIA O 70 DJA O 71 DKA O 72 DLA O 73 DMA O 74 DNA O 75 DOA O 76 DPA O 77 DQA O 78 DRA O 79 DSA O 80 DTA O 81 DUA O 82 DVA O 83 DWA O 84 DXA O 85 DYA O 86 DZA O 87 D0A O 88 D1A O 89 D2A O 90 D3A O 91 D4A O 92 D5A O 93 D6A OINPUTK EDEL U1 DELREC OINPUTR EDEL U2 DELREC ODISPF E DATAO O K3 'PUT' O OUTLEN 2 O INLEN O FNC O A O E DATAI O K3 'GET' O OUTLEN 2 O INLEN O FNC O A ** 0000 INVALID COMMAND KEY 0001 - A FIELD IS TOO LONG 0002 - TOO MANY FIELDS 0003 - ALPHAS IN PACKED KEY 0004 - MISSING ' IN PACKED KEY 0005 - MISSING DATA IN PCKD KEY 0006 - RECORD NOT FOUND PRESS RESET TO CONTINUE ** F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld F1-HEX F2-Return F3-Exit F6-Update F9-Add F11-Del F19-Prev_fld F20-More_fld ** 0123456789ABCDEF
DUSP2 RPG
H*eywords++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Comments+++++++++++ H OPTION(*NODEBUGIO) H DFTACTGRP(*NO) ACTGRP(*CALLER) DFTNAME(DUSP2 ) F* F* LIMITED TO MAXIMUM FILE LENGTH OF 6080 F* REQUIRES FILE QTEMP/FFD TO COMPILE F* use cmd DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) FFFD IF E DISK FDISPF CF F 803 WORKSTN F* F INFDS(INFDS) FINPUTK UF A F32766 800AIDISK KEYLOC(1) F EXTIND(*INU1) F INFDS(INFDK) FINPUTR UF A F32766 DISK EXTIND(*INU2) F INFDS(INFDR) D DISBIN PR extpgm('DISBIN') D NUM 15P 0 D BAN2 2 D BAN4 4 D BINTYP 1 CONST * D A S 255 WORK RU D RU S 255 varying D RW S 1 ROW 1 byte binary D CL S 1 COL 1 byte binary D FNC S 1 D OUTLEN S 2 D INLEN S 2 D IPL S 5 0 D ROW S 3 0 D XROW S 3 0 D COL S 3 0 D KEYSOK S 1 D LENDSC S 3 0 D LENWRK S 5 0 D STRX S 5 0 D ENDX S 5 0 D VX S 5 0 D X S 5 0 D X1 S 5 0 D X2 S 5 0 D XX S 5 0 D XP S 5 0 D MX S 5 0 D ONCE S 1 D RBA S 2 D LF S 5 0 D ST S 5 0 D Y S 5 0 D Z S 5 0 D OFF S 5 0 D CGKY S 1 D UPDDONE S 1 D SUPZ S 1 D NUMFLD S 5 0 D WX S 5 0 D NUMKEY S 5 0 D NUMFKY S 5 0 D SCRST S 10 D SCRSTN S 1 D KEYA S 800 D RRNA S 11 0 D RRN S 11 0 D REHEAD S 1 D NEWRU S 1 D WRTRRN S 1 D LVX S 5 0 D LVL S 5 0 D K1 S 5 0 D K2 S 5 0 D Z1 S 5 0 D W S 5 0 D WK2 S 2 D MSSG S 32 * D BASE S 5 0 D INZ S 1 D FILE S 10 D LIB S 10 D MBR S 10 D RCDL S 5 0 D ACCTP S 1 D RLEN S 5 0 D RLENTH S 5 D LENF S 5 0 D DS D TEXT500 500 D LVW 10 DIM(50) overlay(TEXT500:1) D TEXT800 S 800 D KW S 800 D DS D WRK11 1 11 D NUM11 1 11S 0 D DS D NUSA 1 60 D NUS 1 60S 0 D DS D NUPA 1 60 D NUP 29 60P 0 D NUC S 15P 0 D BAN2 S 2 DCL D BAN4 S 4 D WRU S 61 D WRX S 64 D WRXWRD C '0 - D -' D WRSWRD C '0 - D -' D WRV S 60 varying D FLT14 S 14 D FLT23 S 23 * SET FILE SIZE INCREMENTS (64 OF THEM) D SZ S 5 0 DIM(64) D S S 5 0 DIM(9000) START OF FLD D E S 5 0 DIM(9000) END OF FLD D Q S 5 0 DIM(9000) BYTES IN FIELD D L S 5 0 DIM(9000) LENGTH OF FLD D C S 3 0 DIM(9000) DEC DIGITS D P S 3 0 DIM(9000) DEC PRECISION D B S 2 DIM(9000) ASCEND BUFFER ADD D I S 2 DIM(9000) FLD FMT D N S 10 DIM(9000) FLD NAME D T S 1 DIM(9000) FLD TYPE D V S 1 DIM(9000) VARYING D KY S 1 DIM(9000) KEYED D KE S 10 DIM(128) KEY FLDS D R S 3 0 DIM(9000) KEY FLD START D K S 1 DIM(800) KEY D NA S 1 DIM(10) NAME WORK D NU S 1 DIM(60) NUM. WORK D LV S 10 DIM(50) SCREEN LEVELS D MSG S 32 DIM(8) CTDATA PERRCD(1) MESSAGES D CNS S 79 DIM(2) CTDATA PERRCD(1) D CRS S 1 DIM(16) CTDATA PERRCD(16) D DS D DATA 1 6080 D D 1 6080 D DIM(6080) INCOMING DATA D DA 1 4048 D DIM(4048) D DB 4049 4064 D DC 4065 4096 D DD 4097 4128 D DE 4129 4160 D DF 4161 4192 D DG 4193 4224 D DH 4225 4256 D DI 4257 4288 D DJ 4289 4320 D DK 4321 4352 D DL 4353 4384 D DM 4385 4416 D DN 4417 4448 D DZ 4449 4480 D DO 4481 4512 D DP 4513 4544 D DQ 4545 4576 D DR 4577 4608 D DS 4609 4640 D DT 4641 4672 D DU 4673 4704 D DV 4705 4736 D DW 4737 4768 D DX 4769 4800 D DY 4801 4832 D D0 4833 4864 D D1 4865 4896 D D2 4897 4928 D D3 4929 4960 D D4 4961 4992 D D5 4993 5024 D D6 5025 5056 D DBA 5057 5088 D DCA 5089 5120 D DDA 5121 5152 D DEA 5153 5184 D DFA 5185 5216 D DGA 5217 5248 D DHA 5249 5280 D DIA 5281 5312 D DJA 5313 5344 D DKA 5345 5376 D DLA 5377 5408 D DMA 5409 5440 D DNA 5441 5472 D DOA 5473 5504 D DPA 5505 5536 D DQA 5537 5568 D DRA 5569 5600 D DSA 5601 5632 D DTA 5633 5664 D DUA 5665 5696 D DVA 5697 5728 D DWA 5729 5760 D DXA 5761 5792 D DYA 5793 5824 D DZA 5825 5856 D D0A 5857 5888 D D1A 5889 5920 D D2A 5921 5952 D D3A 5953 5984 D D4A 5985 6016 D D5A 6017 6048 D D6A 6049 6080 D DS D ID 1 800 D DIM(800) INCOMING DATA D IDA 1 800 D ID0 1 80 D ID1 81 160 D ID2 161 240 D ID3 241 320 D ID4 321 400 D ID5 401 480 D ID6 481 560 D ID7 561 640 D ID8 641 720 D ID9 721 800 D DS D BIN 1 2B 0 D HX1 2 2 D HX2 1 2 D DS D PCK 1 1P 0 D PCK1 1 1 D DS D SGN 1 1S 0 D SGN1 1 1 D DS D BIN4 1 4B 0 D BY4 1 4 D DS D BIN2 1 2B 0 D BY2 1 2 D DS D FLT4 1 4F D FL4 1 4 D DS D FLT8 1 8F D FL8 1 8 D INFDK DS D F1 83 92 D L1 93 102 D M1 129 138 D R1 125 126B 0 D A1 160 160 D LOP1 260 260 D KEY_LEN 393 394I 0 Key length D RN1 397 400B 0 D LKY 401 1200 D INFDR DS D F2 83 92 D L2 93 102 D M2 129 138 D R2 125 126B 0 D A2 160 160 D LOP2 260 260 D RN2 397 400B 0 D* D INFDS DS D CURLOC 370 371 D DS D KEYLN 1 4S 0 D KEYLNA 1 4 DDUSP2 PR D 1 D 1 D 4 D 1 D 500 D 5 D 800 DDUSP2 PI D ALL 1 D RTN 1 D KEYLNG 4 D UPDF 1 D SCNLV 500 D SCNLVL 5 D SCNKEY 800 D @LOOP C '1' D @FALSE C '0' D @TRUE C '1' D SND C X'71' SEND TO DISP D SNR C X'73' SND/RCV D RED C X'42' READ D RDM C X'52' READ MTD D ESC C X'04' ESCAPE D CLR C X'40' CLEAR UNIT D CC1 C X'00' CNTRL CHAR D CC2 C X'08' CNTRL CHAR D SBA C X'11' SET BUFF ADR D IC C X'13' INSERT CURS D WTD C X'11' WRITE TO DSP D WER C X'21' WRITE ERROR D SF C X'1D' START FLD D ATC C X'20' ATTR CHAR D ATN C X'24' ATTR NUM D X00 C X'00' D X01 C X'01' D X02 C X'02' D X03 C X'03' D X0D C X'0D' D X0F C X'0F' D X000 C X'0000' D X1F C X'1F' D X20 C X'20' SCRN ATT NORMAL D X22 C X'22' SCRN ATTR HI D X25 C X'25' D X26 C X'26' D X31 C X'31' CMD 1 KEY D X32 C X'32' CMD 2 KEY D X33 C X'33' CMD 3 KEY D X36 C X'36' CMD 6 KEY D X37 C X'37' CMD 7 KEY D X38 C X'38' CMD 8 KEY D X39 C X'39' CMD 9 KEY D X3B C X'3B' CMD11 KEY D XB7 C X'B7' CMD19 KEY D XB8 C X'B8' CMD20 KEY D X40 C X'40' D X43 C X'43' D X47 C X'47' D X60 C X'60' D X67 C X'67' D X9F C X'9F' D XF0 C X'F0' D XD0 C X'D0' D X4000 C X'4000' D X4800 C X'4800' FF ALPHA D X4F06 C X'4F06' FF NUMERIC D X6000 C X'6000' FF ALPHA D X6706 C X'6706' FF NUMERIC D CLRWTD C X'044004112000' INCLUDES ESC CHARS D RDDSP C X'0411200804524000' READ FROM DISPLAY D FFA1 S 1 INZ(X'40') F.FMT 1 ALPH 60 BYP D FFA2 S 1 INZ(X'00') F.FMT 2 ALPH D FFN1 S 1 INZ(X'47') F.FMT 1 NUM 67 BYP D FFN2 S 1 INZ(X'06') F.FMT 2 NUM I*. 0038 IINPUTK NS 01 0039 I 1 4048 DA 0040 I 4049 4064 DB 30 0041 I 4065 4096 DC 31 0042 I 4097 4128 DD 32 0043 I 4129 4160 DE 33 0044 I 4161 4192 DF 34 0045 I 4193 4224 DG 35 0046 I 4225 4256 DH 36 0047 I 4257 4288 DI 37 0048 I 4289 4320 DJ 38 0049 I 4321 4352 DK 39 0050 I 4353 4384 DL 40 0051 I 4385 4416 DM 41 0052 I 4417 4448 DN 42 0053 I 4449 4480 DZ 43 0054 I 4481 4512 DO 44 0055 I 4513 4544 DP 45 0056 I 4545 4576 DQ 46 0057 I 4577 4608 DR 47 0058 I 4609 4640 DS 48 0059 I 4641 4672 DT 49 0060 I 4673 4704 DU 50 0061 I 4705 4736 DV 51 0062 I 4737 4768 DW 52 0063 I 4769 4800 DX 53 0064 I 4801 4832 DY 54 0065 I 4833 4864 D0 55 0066 I 4865 4896 D1 56 0067 I 4897 4928 D2 57 0068 I 4929 4960 D3 58 0069 I 4961 4992 D4 59 0070 I 4993 5024 D5 60 0071 I 5025 5056 D6 61 0072 I 5057 5088 DBA 62 0073 I 5089 5120 DCA 63 0074 I 5121 5152 DDA 64 0075 I 5153 5184 DEA 65 0076 I 5185 5216 DFA 66 0077 I 5217 5248 DGA 67 0078 I 5249 5280 DHA 68 0079 I 5281 5312 DIA 69 0080 I 5313 5344 DJA 70 0081 I 5345 5376 DKA 71 0082 I 5377 5408 DLA 72 0083 I 5409 5440 DMA 73 0084 I 5441 5472 DNA 74 0085 I 5473 5504 DOA 75 0086 I 5505 5536 DPA 76 0087 I 5537 5568 DQA 77 0088 I 5569 5600 DRA 78 0089 I 5601 5632 DSA 79 0090 I 5633 5664 DTA 80 0091 I 5665 5696 DUA 81 0092 I 5697 5728 DVA 82 0093 I 5729 5760 DWA 83 0094 I 5761 5792 DXA 84 0095 I 5793 5824 DYA 85 0096 I 5825 5856 DZA 86 0097 I 5857 5888 D0A 87 0098 I 5889 5920 D1A 88 0099 I 5921 5952 D2A 89 0100 I 5953 5984 D3A 90 0101 I 5985 6016 D4A 91 0102 I 6017 6048 D5A 92 0103 I 6049 6080 D6A 93 0104 IINPUTR NS 01 0105 I 1 4048 DA 0106 I 4049 4064 DB 30 0107 I 4065 4096 DC 31 0108 I 4097 4128 DD 32 0109 I 4129 4160 DE 33 0110 I 4161 4192 DF 34 0111 I 4193 4224 DG 35 0112 I 4225 4256 DH 36 0113 I 4257 4288 DI 37 0114 I 4289 4320 DJ 38 0115 I 4321 4352 DK 39 0116 I 4353 4384 DL 40 0117 I 4385 4416 DM 41 0118 I 4417 4448 DN 42 0119 I 4449 4480 DZ 43 0120 I 4481 4512 DO 44 0121 I 4513 4544 DP 45 0122 I 4545 4576 DQ 46 0123 I 4577 4608 DR 47 0124 I 4609 4640 DS 48 0125 I 4641 4672 DT 49 0126 I 4673 4704 DU 50 0127 I 4705 4736 DV 51 0128 I 4737 4768 DW 52 0129 I 4769 4800 DX 53 0130 I 4801 4832 DY 54 0131 I 4833 4864 D0 55 0132 I 4865 4896 D1 56 0133 I 4897 4928 D2 57 0134 I 4929 4960 D3 58 0135 I 4961 4992 D4 59 0136 I 4993 5024 D5 60 0137 I 5025 5056 D6 61 0138 I 5057 5088 DBA 62 0139 I 5089 5120 DCA 63 0140 I 5121 5152 DDA 64 0141 I 5153 5184 DEA 65 0142 I 5185 5216 DFA 66 0143 I 5217 5248 DGA 67 0144 I 5249 5280 DHA 68 0145 I 5281 5312 DIA 69 0146 I 5313 5344 DJA 70 0147 I 5345 5376 DKA 71 0148 I 5377 5408 DLA 72 0149 I 5409 5440 DMA 73 0150 I 5441 5472 DNA 74 0151 I 5473 5504 DOA 75 0152 I 5505 5536 DPA 76 0153 I 5537 5568 DQA 77 0154 I 5569 5600 DRA 78 0155 I 5601 5632 DSA 79 0156 I 5633 5664 DTA 80 0157 I 5665 5696 DUA 81 0158 I 5697 5728 DVA 82 0159 I 5729 5760 DWA 83 0160 I 5761 5792 DXA 84 0161 I 5793 5824 DYA 85 0162 I 5825 5856 DZA 86 0163 I 5857 5888 D0A 87 0164 I 5889 5920 D1A 88 0165 I 5921 5952 D2A 89 0166 I 5953 5984 D3A 90 0167 I 5985 6016 D4A 91 0168 I 6017 6048 D5A 92 0169 I 6049 6080 D6A 93 IDISPF NS 02 I 3 3 AID I 4 83 ID0 I 84 163 ID1 20 I 164 243 ID2 21 I 244 323 ID3 22 I 324 403 ID4 23 I 404 483 ID5 24 I 484 563 ID6 25 I 564 643 ID7 26 I 644 723 ID8 27 I 724 803 ID9 28 /FREE BASE = 4048; IF ONCE = ' '; EXSR @INITZ ; ENDIF; // START TAG DOW @LOOP = @LOOP; IF RTN = '3'; IF *INU1; KEYA = SCNKEY; ENDIF; IF *INU2; RRNA = %DEC(%SUBST(SCNKEY:1:11):11:0); ENDIF; RTN = '0'; AID = '1'; ELSE; RTN = '0'; READ(E) DISPF; ENDIF; // CF3 EXIT IF AID = X33; LEAVE; ENDIF; // CF2 RETURN IF AID = X32; RTN = '1'; LEAVE; ENDIF; // CF1 HEX A FIELD IF AID = X31; Y = %LOOKUPLE( CURLOC : B ); IF Y > 0; IF KY(Y) <= '1'; EXSR @HXDSP; REHEAD = '1'; EXSR @PUTHED; REHEAD = ' '; ENDIF; ENDIF; ENDIF; // CF20 MORE FIELDS IF AID = XB8; LVX = LVL + 1; IF LV(LVX) <> *BLANK; LVL = LVL +1 ; LVW = LV; SCNLV = TEXT500; SCNLVL = %EDITC(LVL :'X'); SCNKEY = *BLANKS; IF *INU1; SCNKEY = KEYA; ENDIF; IF *INU2; SCNKEY = %EDITC(RRNA:'X'); ENDIF; RTN = '3'; LEAVE; ENDIF; ENDIF; // CF19 PREVIOUS FIELDS IF AID = XB7; LVX = LVL - 1; IF LVX >= 0 ; LVL = LVL - 1 ; LVW = LV; SCNLV = TEXT500; SCNLVL = %EDITC(LVL :'X'); SCNKEY = *BLANKS; IF *INU1; SCNKEY = KEYA; ENDIF; IF *INU2; SCNKEY = %EDITC(RRNA:'X'); ENDIF; RTN = '3'; LEAVE; ENDIF; ENDIF; // 1 ENTER 4 ROLL DN 5 ROLL UP // F6 = X36 F9 = X39 F11 = X3B IF AID = '1'or AID = '4' or AID = '5' or AID = X36 or AID = X39 or AID = X3B; ELSE; MX = 1; // INVALID KEY EXSR @ERROR; ENDIF; // UPDATE MODE IF UPDF = 'Y'; UPDDONE = @FALSE; // F6 IF *INU1 AND AID = X36 AND (LOP1 = X01 OR LOP1 = X03); EXSR @UPD; EXCEPT UPDATREC; UPDDONE = @TRUE; ENDIF; IF *INU2 AND AID = X36 AND (LOP2 = X01 OR LOP2 = X02); EXSR @UPD; EXCEPT UPDATREC; UPDDONE = @TRUE; ENDIF; // F9 IF AID = X39; EXSR @UPD; EXCEPT ADDREC; UPDDONE = @TRUE; ENDIF; // F11 IF *INU1 AND AID = X3B AND (LOP1 = X01 OR LOP1 = X03); EXCEPT DELREC; UPDDONE = @TRUE; ENDIF; IF *INU2 AND AID = X3B AND (LOP2 = X01 OR LOP2 = X02); EXCEPT DELREC; UPDDONE = @TRUE; ENDIF; ENDIF; IF RTN = '3' OR UPDDONE = @TRUE; ELSE; EXSR @PCKD; ENDIF; // CONT1 GET A RECORD, KEY FROM DATA EXSR @SETIN; EXSR @GETF ; EXSR @PUTF ; EXSR @KEYIN; ENDDO ; *INLR = *ON; // @@@@@@@ @INITZ @@@@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @INITZ; ONCE = '1'; KEYLNA = KEYLNG ; EXSR @INIT ; EXSR @GETFLD ; EXSR @GETADD ; EXSR @PUTHED ; EXSR @KEYIN ; INZ = '1'; EXSR @PCKD ; INZ = ' '; ENDSR; // @@@@@@@ @PCKD @@@@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @PCKD ; // CONVERT KEY DATA IF *INU1 ; EXSR @CVTKEY; ENDIF; IF *INU2 ; EXSR @CVTRRN; ENDIF; ENDSR; // @@@@@@@ @CVTKEY @@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @CVTKEY; // EXTRACT THE KEY FIELD DATA FROM THE INCOMING STRING // FOR EACH KEY FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE // THE MODIFIED DATA INTO THE COMPOSITE KEY K1 = 0; K2 = 0; W = 1; FOR Y = 1 TO NUMKEY ; // MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY (KEY FIELDS) // GET SIZE OF FIELD IN BYTES IF T(Y) = 'A'; // ALPHA DATA K = ' '; K1 = 1; K2 = Q(Y); ELSE; K = '0'; K1 = 1; K2 = C(Y); ENDIF; // IF WHOLE KEY INIT WAS REQUESTED BYPASS THE EXTRACT IF INZ = '1' ; KW = *BLANK; EXSR @PCKMOV; ITER; ENDIF; X = 1; DOW @LOOP = @LOOP; // NXTSBA X = %LOOKUP(SBA : ID : X ); IF X = 0; LEAVE; ENDIF; // IS THIS THE FIELD? CHECK THE BUFFER ADDRESS X = X +1; IF B(Y) <> %SUBST(IDA : X :2); ITER; ENDIF; // FOUND A MTD FOR THIS FIELD X = X + 2; // CHECK IF FIELD WAS CLEARED ONLY IF ID(X) = SBA; EXSR @PCKMOV; LEAVE ; ENDIF; // IF FIELD HAS DECIMALS BUMP X IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND P(Y) > 0; X = X + 1; ENDIF; // CHECK IF ONLY BLANKS RETURNED IF %SUBST(IDA : X :K2) = *BLANKS; EXSR @PCKMOV; LEAVE; ENDIF; // EXTRACT THE DATA FROM THE INCOMING STRING X1 = X; FOR X2 = 1 TO K2 ; IF ID(X1) < ' '; // TRAP NULLS CAUSED BY FLD EXIT EXSR @PCKMOV; LEAVE; ENDIF; K(X2) = ID(X1); X1 = X1 +1; ENDFOR; // CONSTRUCT THE ACTUAL KEY WITH PACKED DATA IF REQUIRED // INTO ARRAY KW EXSR @PCKMOV; LEAVE; ENDDO; ENDFOR; // KEYA = KW; CLEAR KW; ENDSR ; // @@@@@@@ @CVTRRN @@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @CVTRRN; // RRN NUM11 = 0; DOW @LOOP = @LOOP; // NOT REALLY A LOOP(SIMULATES GOTO) // GET THE FIRST SBA X = 1; X = %LOOKUP(SBA : ID : X ); IF X = 0; LEAVE; ENDIF; // CHECK THE BUFFER ADDRESS MATCHES THE EXPECTED FIELD X = X +1; IF B(1) <> %SUBST(IDA : X :2); ITER; ENDIF; // FOUND A MTD FOR RRN FIELD X = X +2; //CHECK IF FIELD WAS CLEARED ONLY IF ID(X) = SBA; LEAVE; ENDIF; // CHECK IF ONLY BLANKS RETURNED IF %SUBST(IDA : X :11) = *BLANKS; LEAVE; ENDIF; // WRK11 OVERLAYS NUM11 WRK11 = %SUBST(IDA : X :11); LEAVE; ENDDO; RRNA = NUM11; IF RRNA < 0; RRNA = 1; ENDIF; ENDSR; // @@@@@@@ @PCKMOV @@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @PCKMOV; // // CONVERT KEY DATA // SET START POSN IN KEY USING OFFSET IN R X1 = %LOOKUP(N(Y) : N ); W = R(X1) + 1; // ALPHA IF T(Y) = 'A'; X1 = 1; FOR Z = W TO W + Q(Y); %SUBST(KW : Z : 1) = K(X1); X1 = X1 + 1; ENDFOR; ENDIF; // NUMERIC FIELD // RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B'); NU = '0'; Z1 = 60; FOR Z = K2 DOWNTO K1; IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$'; ITER; ENDIF; IF K(Z) = ' ' ; NU(Z1) = '0'; ELSE; NU(Z1) = K(Z); ENDIF; Z1 = Z1 -1; ENDFOR; ENDIF; // SIGNED FIELDS (END POSN = OFFSET + SIZE) IF T(Y) = 'S'; NUS = 0; FOR VX = 1 TO 60; NUSA = %TRIM(NUSA) + NU(VX); ENDFOR; %SUBST(KW : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y)); ENDIF; // PACKED FIELDS IF T(Y) = 'P'; NUSA= *BLANKS; FOR VX = 1 TO 60; NUSA = %TRIM(NUSA) + NU(VX); ENDFOR; NUP = %DEC(NUSA : 60 : 0); %SUBST(KW : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y)); ENDIF; // BINARY FIELDS IF T(Y) = 'B'; IF Q(Y) = 2 ; BY2 = NU(1) + NU(2); %SUBST(KW : W : 2) = BY2; ENDIF; IF Q(Y) = 4 ; BY4 = NU(1) + NU(2) + NU(3) + NU(4); %SUBST(KW : W : 4) = BY4; ENDIF; ENDIF; ENDSR; // @@@@@@@ SETIN @@@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @SETIN; // SET the FFR indicators to get the Input buffer somewhat aligned with the // actual data. RPG is somewhat tolerant to a difference between the Ispecs // and the actual file size but it can fail on big differences. // INCREMENT OF 32 BYTES SZ(1) = BASE + 16; SZ(2) = SZ(1) + 16; *IN30 = *ON; IF (RLEN > SZ(2)) ; *IN31 = *ON; ENDIF; FOR X = 3 TO 64; SZ(X) = SZ(X-1) + 32; IF (RLEN > SZ(X)) ; *IN(29+X) = *ON; ENDIF; ENDFOR; ENDSR; //@@@@@@@@@@@@@@@@@ @GETF @@@@@@@@@@@@@@@@@ BEGSR @GETF; // GET A DATA RECORD IF (*INU1); IF AID = '1' OR AID = X36 OR AID = X39 OR AID = X3B ; SETLL(E) KEYA INPUTK; READ(E) INPUTK; IF %EOF; SETLL(E) KEYA INPUTK; READP(E) INPUTK; ENDIF; ENDIF; IF AID = '4'; READP(E) INPUTK; ENDIF; IF AID = '5'; READ(E) INPUTK; ENDIF; IF %ERROR; SETLL(E) KEYA INPUTK; READ(E) INPUTK; MX = 7; EXSR @ERROR; EXSR @PUTF ; EXSR @KEYIN; ENDIF; KEYA = LKY; CLEAR KW; KW = LKY; ENDIF; IF (*INU2); IF AID = '1'; CHAIN(E) RRNA INPUTR; IF %ERROR; SETLL(E) RRNA INPUTR; READP(E) INPUTR; ENDIF; ENDIF; IF AID = X36; CHAIN(E) RRNA INPUTR; ENDIF; IF AID = '4'; READP(E) INPUTR; ENDIF; IF AID = '5' OR AID = X3B; READ(E) INPUTR; ENDIF; IF AID = X39; SETLL(E) *HIVAL INPUTR; READP(E) INPUTR; ENDIF; IF %ERROR; CHAIN 1 INPUTR; MX = 7; EXSR @ERROR; EXSR @PUTF ; EXSR @KEYIN; ENDIF; ENDIF; ENDSR; //@@@@@@@@@@@@@@@@@ @PUTF @@@@@@@@@@@@@@@@@ BEGSR @PUTF; SELECT; WHEN *INU1; RRN = RN1; WHEN *INU2; RRN = RN2; ENDSL; // IF GOT RECORDS WRITE DATA TO THE DISPLAY NEWRU = '1'; WRTRRN = '1'; RU = *ALLX'00'; CLEAR RU; // initialise Request Unit 255 bytes max IF RRN > 0 ; FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) IF NEWRU = '1'; NEWRU = '0'; RU = ESC + WTD + X20 + X00; ENDIF; IF WRTRRN = '1'; WRTRRN = '0'; RU = RU + SBA + RBA ; RU = RU + %TRIM(%EDITC(RRN:'Z')); ENDIF; // BUFFER ADDRESS RU = RU + SBA + B(XX); // PROCESS ALPHA DATA TYPE IF T(XX) = 'A' OR T(XX) = 'T' OR T(XX) = 'Z' OR T(XX) = 'L'; STRX = S(XX); ENDX = E(XX); IF V(XX) = 'Y'; //VARYING VX = S(XX); HX2 = D(VX) + D(VX+1); STRX = S(XX) + 2 ; ENDX = S(XX) + BIN; ENDIF; FOR Y = STRX TO ENDX ; IF D(Y) >= ' '; RU = RU + D(Y); ELSE; RU = RU + X1F ; //IF NOT DISPLAYABLE REPLACE WITH X'1F' ENDIF; ENDFOR; ENDIF; // PROCESS SIGNED DATA TYPE (not the RRN field) IF T(XX) = 'S' and KY(XX) <> '3'; NUSA = *ALL'0'; WRV = *ALLX'00'; CLEAR WRV; FOR Y = S(XX) TO E(XX); IF D(Y) >= XD0; WRV = WRV + D(Y); ENDIF; ENDFOR; EVAL NUSA = %SUBST(NUSA : 1 : 60 - %LEN(WRV)) + WRV; CLEAR WRU; WRU = %TRIM(WRU) + %EDITW(NUS :WRSWRD); IF P(XX) > 0; RU = RU + %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' + %SUBST(WRU :61-P(XX)) ; ELSE; RU = RU + %SUBST(WRU :61-C(XX)); ENDIF; ENDIF; // PROCESS SIGNED DATA TYPE (the RRN field) IF T(XX) = 'S' and KY(XX) = '3'; RRN = RN2; RU = RU + %TRIM(%EDITC(RRN:'X')); ENDIF; // PROCESS PACKED DATA TYPE IF T(XX) = 'P'; NUPA = *ALLX'00'; WRV = *ALLX'00'; CLEAR WRV; FOR Y = S(XX) TO E(XX); WRV = WRV + D(Y); ENDFOR; IF %BITAND(D(E(XX)) :X0F) = X0F OR %BITAND(D(E(XX)) :X0D) = X0D; EVAL NUPA = %SUBST(NUPA : 1 : 60 - %LEN(WRV)) + WRV; CLEAR WRX; WRX = %TRIM(WRX) + %EDITW(NUP :WRXWRD); IF P(XX) > 0; RU = RU + %SUBST(WRX :64-C(XX): C(XX)-P(XX)) + '.' + %SUBST(WRX :64-P(XX)) ; ELSE; RU = RU + %SUBST(WRX :64-C(XX)); ENDIF; ELSE; // PACKED FIELD IN ERROR RU = RU + X1F; ENDIF; ENDIF; // PROCESS BINARY DATA TYPE IF T(XX) = 'B'; ST = S(XX); CLEAR NUSA; IF Q(XX) = 2; BY2 = D(ST) + D(ST+1); NUS = BIN2; ENDIF; IF Q(XX) = 4; BY4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3); NUS = BIN4; ENDIF; WRU = %EDITW(NUS :WRSWRD); IF P(XX) > 0; RU = RU + %SUBST(WRU :61-C(XX): C(XX)-P(XX)) + '.' + %SUBST(WRU :61-P(XX)) ; ELSE; RU = RU + %SUBST(WRU :61-C(XX)); ENDIF; ENDIF; // PROCESS FLOAT DATA TYPE IF T(XX) = 'F'; ST = S(XX); IF Q(XX) = 4; FL4 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3); FLT14 = %EDITFLT(FLT4); RU = RU + FLT14; ENDIF; IF Q(XX) = 8; FL8 = D(ST) + D(ST+1)+ D(ST+2) + D(ST+3) + D(ST+4) + D(ST+5)+ D(ST+6) + D(ST+7); FLT23 = %EDITFLT(FLT8); RU = RU + FLT23; ENDIF; ENDIF; // SEND A REQUEST UNIT IF GOT ENOUGH DATA IF %LEN(RU) + L(XX + 1) >= 200; RU = RU + X20; BIN = %LEN(RU); OUTLEN = HX2; INLEN = X000; FNC = SND; A = RU; EXCEPT DATAO; NEWRU = '1'; RU = *ALLX'00'; CLEAR RU; ENDIF; ENDFOR; ENDIF; IF %LEN(RU) > 5 AND %LEN(RU) < 250; RU = RU + X20; BIN = %LEN(RU); OUTLEN = HX2; INLEN = X000; FNC = SND; A = RU; EXCEPT DATAO; ENDIF; ENDSR; // @@@@@@@@@@@@@@@ ROWINC @@@@@@@@@@@@@@@ // INCREMENT THE ROW BEGSR @ROWINC; ROW = ROW + 2; IF ROW > 20; MX = 3; ENDIF; ENDSR; // @@@@@@@@@@@@@@@ GETFLD @@@@@@@@@@@@@@@ // LOAD FIELD DESCRIPTION ARRAYS BEGSR @GETFLD; MX = 0; X = 0; IF (*INU2 = *ON); // IF NON KEYED ACCESS SET UP A FIELD TO SHOW THE RRN N(1) = 'RRN'; T(1) = 'S' ; C(1) = 11 ; P(1) = 0 ; S(1) = 0 ; E(1) = 0 ; L(1) = 12 ; I(1) = X4F06 ; KY(1)= '3' ; X = 1 ; ENDIF; SCRST = *BLANK; SCRSTN = *BLANK; LVL = %DEC(SCNLVL : 5:0); TEXT500 = SCNLV ; LV = LVW; IF LVL <> 0; SCRST = LV(LVL); ENDIF; SETLL 1 QWHDRFFD ; DOW @LOOP = @LOOP; // REREAD TAG READ QWHDRFFD; IF %EOF; LEAVE; ENDIF; // SELECT OR OMIT IF ALL <> '1'; IF ALL = 'S' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS IF WHFIOB <> 'S'; ITER; ENDIF; ENDIF; IF ALL = 'O' AND WHDFTL = 0; // USING WHDFTL FOR KEY FIELDS IF WHFIOB = 'O'; ITER; ENDIF; ENDIF; ENDIF; // FIND THE FIRST FIELD TO BE SHOWN (FOR MULTI PAGE FORMATS) IF WHDFTL <> 0 ; ELSE; IF SCRST <> ' ' AND SCRSTN = ' '; IF WHFLDE = SCRST; SCRSTN = '1'; // FOUND THE START ELSE; ITER; ENDIF; ENDIF; ENDIF; X = X + 1; // CHECK FOR KEY FIELDS,WILL BE USED TO PLACE THEM IN FRONT IF WHDFTL <> 0; KY(X) = '1'; WX = WHDFTL ; KE(WX) = WHFLDE; IF NUMKEY < WHDFTL; NUMKEY = WHDFTL; ENDIF; ENDIF; N(X) = WHFLDE ; // NAME T(X) = WHFLDT ; // TYPE V(X) = WHVARL ; // VARYING C(X) = WHFLDD ; // DEC DIGITS P(X) = WHFLDP ; // DEC PREC S(X) = WHFOBO ; // START Q(X) = WHFLDB ; // BTYES E(X) = WHFOBO + WHFLDB -1 ; // END IF T(X) = 'F' ; // FLOAT I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA L(X) = 14; IF Q(X) = 8; L(X) = 23; ENDIF; ELSE; IF WHFLDD <> 0 ; IF WHFLDP <> 0 ; L(X) = WHFLDD + 2 ; // LENGTH ELSE; L(X) = WHFLDD + 1 ; // LENGTH ENDIF; I(X) = FFN1 + FFN2; // SCRN FIELD FORMAT NUMERIC ELSE; L(X) = WHFLDB ; I(X) = FFA1 + FFA2; // SCRN FIELD FORMAT ALPHA ENDIF; ENDIF; ENDDO; // NUMBER OF FIELDS NUMFLD = X ; // MAKE ROOM FOR KEYS IF NUMKEY > 0 ; X1 = NUMKEY + NUMFLD; FOR X = NUMFLD DOWNTO 1; KY(X1) = KY(X) ; L(X1) = L(X) ; I(X1) = I(X) ; N(X1) = N(X) ; T(X1) = T(X) ; V(X1) = V(X) ; C(X1) = C(X) ; P(X1) = P(X) ; S(X1) = S(X) ; E(X1) = E(X) ; Q(X1) = Q(X) ; X1 = X1 - 1; ENDFOR; // PUT KEY FIELDS AT TOP OFF = 0; FOR X = 1 TO NUMKEY; X1 = %LOOKUP(KE(X) : N : NUMKEY+1); KY(X) = '2'; L(X) = L(X1); I(X) = I(X1); // FIELD FMT SELECT; // INPUT ENABLE WHEN I(X) = X6000; I(X) = X4800; WHEN I(X) = X6706; I(X) = X4F06; ENDSL; N(X) = N(X1); T(X) = T(X1); V(X) = V(X1); C(X) = C(X1); P(X) = P(X1); S(X) = S(X1); E(X) = E(X1); Q(X) = Q(X1); R(X) = OFF; OFF = OFF + Q(X1); ENDFOR; ENDIF; // NUMBER OF FIELDS AND KEYS NUMFKY = NUMFLD + NUMKEY; ENDSR; // @@@@@@@@@@@@@@@ GETADD @@@@@@@@@@@@@@@ // LOAD FIELD BUFFER ADDRESSES BEGSR @GETADD; MX = 0; X = 0; ROW = 3; COL = 1; FOR X = 1 TO NUMFKY; // IF FINISHED WITH THE KEY FIELDS // INC ROW FOR 1ST DATA FIELD IF KEYSOK = ' ' ; IF KY(X) = ' ' OR KY(X) = '1'; KEYSOK = '1' ; ROW = ROW + 2; COL = 1; ENDIF; ENDIF; // SET THE BUFFER ADD ON THE LARGER OF THE FIELD TEXT OR THE FIELD SIZE LENDSC = %LEN(%TRIM(N(X))); LENWRK = L(X); IF LENDSC > L(X); LENWRK = LENDSC; ENDIF; LENWRK = LENWRK + 2; // TRAP FIELDS THAT OVERFLOW ROW = ROW + XROW; XROW = %DIV(LENWRK : 80); IF (COL + LENWRK) > 78; EXSR @ROWINC; IF MX = 3; X= X-1; NUMFKY = X; LEAVE; ENDIF; COL = 1; ENDIF; // INC COL. FOR FIELD START CLEAR B(X); BIN = ROW; B(X) = %TRIM(B(X)) + HX1; BIN = COL + 1; B(X) = %TRIM(B(X)) + HX1; // INC COL. FOR NEXT FIELD COL = COL + LENWRK; IF COL > 78; EXSR @ROWINC; IF MX = 3; // NO ROOM FOR THE FIELD X= X-1; NUMFKY = X; LEAVE; ENDIF; COL = 1; ENDIF; ENDFOR; // FIELD LEVEL LVX = LVL + 1; LV(LVX) = N(X); ENDSR; // @@@@@@@@@@@@@@@ PUTHED @@@@@@@@@@@@@@@ // PUT FIELD HEADINGS BEGSR @PUTHED; NEWRU = '1'; RU = *ALLX'00'; CLEAR RU; // initialise Request Unit 255 bytes max FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) IF NEWRU = '1'; NEWRU = '0'; RU = ESC + WTD + X20 + X00; ENDIF; RU = RU + SBA; BIN = 0; // CONVERT DATA BUFADR TO HEADING BUFADR HX1 = %SUBST(B(XX) :1:1); BIN = BIN - 1; RU = RU + HX1; IF REHEAD = '1'; // ON REDISPLAY OVERRIDE THE ATTR BIN = 0; HX1 = %SUBST(B(XX) :2:1); BIN = BIN -1 ; RU = RU + HX1; ELSE; RU = RU + %SUBST(B(XX) :2); ENDIF; RU = RU + ATC ; // LONG NUMBER FIELDS ,RIGHT ADJUST THE FIELD HEADINGS LENDSC = %LEN(%TRIM(N(XX))); IF T(XX) <> 'A' AND LENDSC < (L(XX) -1); FOR Y = 1 TO (L(XX) -(LENDSC +1)); RU = RU + ' '; ENDFOR; ENDIF; RU = RU + %TRIM(N(XX)); IF %LEN(RU) >= 200; BIN = %LEN(RU); OUTLEN = HX2; INLEN = X000; FNC = SND; A = RU; EXCEPT DATAO; NEWRU = '1'; RU = *ALLX'00'; CLEAR RU; ENDIF; ENDFOR; IF %LEN(RU) > 5 AND %LEN(RU) < 200; BIN = %LEN(RU); OUTLEN = HX2; INLEN = X000; FNC = SND; A = RU; EXCEPT DATAO; ENDIF; IF REHEAD <> '1'; // FORMAT FIELDS NEWRU = '1'; RU = *ALLX'00'; CLEAR RU; // initialise Request Unit 255 bytes max FOR XX = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) IF NEWRU = '1'; NEWRU = '0'; RU = ESC + WTD + X20 + X00; ENDIF; RU = RU + SBA +B(XX)+SF + I(XX); IF KY(XX) = '1' OR KY(XX) = '2' OR KY(XX) = '3'; RU = RU + X25; ELSE; RU = RU + X26; ENDIF; BIN = L(XX); RU = RU + HX2; // LENGTH OF INPUT FIELDS LENF = LENF + L(XX) + 3; IF %LEN(RU) >= 200; BIN = %LEN(RU); OUTLEN = HX2; INLEN = X000; FNC = SND; A = RU; EXCEPT DATAO; NEWRU = '1'; RU = *ALLX'00'; CLEAR RU; ENDIF; ENDFOR; // PUT LAST R/U IF %LEN(RU) > 5 AND %LEN(RU) < 200; BIN = %LEN(RU); OUTLEN = HX2; INLEN = X000; FNC = SND; A = RU; EXCEPT DATAO; ENDIF; //INC BUFFER ADDRESS FOR ALL FIELDS FOR DATA PUT FOR XP = 1 TO NUMFKY; //NUMBER OF DATA ELEMENTS (FLD AND KEY) HX2 = B(XP); BIN = BIN + 1; B(XP) = HX2; ENDFOR; ENDIF; ENDSR; // @@@@@@@ INIT @@@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @INIT; CLEAR KW; // UPDATE IF UPDF = 'Y'; FFA1 = X40; FFN1 = X47; ELSE; FFA1 = X60; FFN1 = X67; ENDIF; SELECT; WHEN *INU1 = '1'; FILE = F1 ; LIB = L1 ; MBR = M1 ; RCDL = R1 ; ACCTP = A1 ; WHEN *INU2 = '1'; FILE = F2 ; LIB = L2 ; MBR = M2 ; RCDL = R2 ; ACCTP = A2 ; ENDSL; RLEN = RCDL ; RLENTH = %EDITC(RLEN: 'X') ; LENF = 0 ; // Control commands and data are constructed into RUs Request UNITS // Each RU is 256 bytes max size. // Construct and send as many RUs as needed to format the display. RU = *ALLX'00'; CLEAR RU; // initialise Request Unit 255 bytes max RU = CLRWTD ; //set up the screen headings BIN = 1; // set ROW to 1 RW = HX1; BIN = 2; // set COL to 2 CL = HX1; RU = RU + SBA + RW + CL + X22 + %TRIM(LIB) + '/' + %TRIM(FILE); RU = RU + ' Mbr ' + %TRIM(MBR) + ' Rcdl ' + %EDITC(RLEN : 'Z') ; RU = RU + ' RRN ' ; BIN = %len(RU) -4; RBA = RW + HX1 ; // address of the RRN field RU = RU + SBA + RBA + ' '; // FUNCTION KEYS BIN = 23; RW = HX1; BIN = 02; CL = HX1; IF UPDF = 'Y'; // UPDATE IS ON RU = RU + SBA + RW + CL + %TRIM(CNS(2)); ELSE; RU = RU + SBA + RW + CL + %TRIM(CNS(1)); ENDIF; // THIS IS A SEND ONLY FUNCTION FNC = SND; CLEAR A; A = RU; BIN2 = %LEN(RU); OUTLEN = BY2; INLEN = x000; EXCEPT DATAO; ENDSR; // @@@@@@@ KEYIN @@@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @KEYIN; // ISSUE A READ FROM DISPLAY FNC = SNR; BIN2 = 8; OUTLEN = BY2; IPL = LENF + 34; BIN2 = IPL; INLEN = BY2; // SET FRR INDICATORS TO CONTROL BUFFER OVERFLOW FOR X = 1 TO 9; IF IPL > ( X*80 +3); *IN(X+19) = *ON; ENDIF; ENDFOR; RU = *ALLX'00'; CLEAR RU; RU = RDDSP; A = RU; EXCEPT DATAI; ENDSR; // @@@@@@@ ERROR @@@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @ERROR; // SETUP PUT ERROR MESSAGE X'21' RU = *ALLX'00'; CLEAR RU; FNC = SNR; BIN = 42; OUTLEN = HX2; BIN = LENF + 34; IPL = BIN; INLEN = HX2; FOR X = 1 TO 9; IF IPL > (X * 80 +3) ; *IN(X + 19) = *ON; // SETON FFR 20 - 29 FOR INPUT ENDIF; ENDFOR; RU = ESC + WER + IC + B(1) + ATC + MSG(MX); RU = RU + ESC + RDM + X40+ X00; A = RU; EXCEPT DATAI; RU = *ALLX'00'; CLEAR RU; ENDSR; // @@@@@@@ HXDSP @@@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @HXDSP; RU = *ALLX'00'; CLEAR RU; Y = %LOOKUPLE( CURLOC : B ); // RU = ESC + WTD + X20 + X00 + SBA; BIN = 0; HX1 = %SUBST(B(Y) :1:1); BIN = BIN - 1; RU = RU + HX1; RU = RU + %SUBST(B(Y) :2:1); FOR X = S(Y) TO E(Y); BIN = 0; HX1 = D(X); HX1 = %BITAND(HX1 : XF0); Z = BIN / 16 + 1; RU = RU + CRS(Z); ENDFOR; RU = RU + X20; RU = RU + SBA + B(Y); FOR X = S(Y) TO E(Y); BIN = 0; HX1 = D(X); HX1 = %BITAND(HX1 : X0F); Z = BIN + 1; RU = RU + CRS(Z); ENDFOR; BIN = %LEN(RU); OUTLEN = HX2; INLEN = X000; FNC = SND; A = RU; EXCEPT DATAO; RU = *ALLX'00'; CLEAR RU; EXSR @KEYIN; READ DISPF; // CLEAR HEADINGS RU = *ALLX'00'; CLEAR RU; RU = RU + ESC + WTD + X20 + X00 + SBA; HX1 = %SUBST(B(Y) :1:1) ; BIN = BIN - 1; RU = RU + HX1 + %SUBST(B(Y):2:1); FOR X = S(Y) TO E(Y); RU = RU + ' '; ENDFOR; RU = RU + ' '; BIN = %LEN(RU); OUTLEN = HX2; INLEN = X000; FNC = SND; A = RU; EXCEPT DATAO; RU = *ALLX'00'; CLEAR RU; ENDSR; // @@@@@@@ UPD @@@@@@@@@@@@@@@@@@@@@@@@@ BEGSR @UPD; // CONVERT DATA FOR OUTPUT // FOR EACH FIELD, CHECK IF FIELD WAS MODIFIED, AND IF SO MOVE // THE MODIFIED DATA INTO THE OUTPUT ARRAY K1 = 0; K2 = 0; W = 1; CGKY = *BLANK; // KEY CHANGED KW = KEYA; FOR Y = 1 TO NUMFKY ; IF KY(Y) > '1'; ITER; ENDIF; // MOVE A KEY FIELDS DATA FROM ID ARRAY (SCREEN) TO K ARRAY // GET SIZE OF FIELD IN BYTES IF T(Y) = 'A'; // ALPHA DATA K = ' '; K1 = 1; K2 = Q(Y); ELSE; K = '0'; K1 = 1; K2 = C(Y); ENDIF; X = 1; DOW @LOOP = @LOOP; // NXTSBA X = %LOOKUP(SBA : ID : X ); IF X = 0; LEAVE; ENDIF; // IS THIS THE FIELD? CHECK THE BUFFER ADDRESS X = X +1; IF B(Y) <> %SUBST(IDA : X :2); ITER; ENDIF; // FOUND A MTD FOR THIS FIELD // CHECK IF FIELD WAS CLEARED ONLY DOW @LOOP = @LOOP; // not a loop X = X + 2; IF ID(X) = SBA; LEAVE; ENDIF; // IF FIELD HAS DECIMALS BUMP X IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B') AND P(Y) > 0; X = X + 1; ENDIF; // CHECK IF ONLY BLANKS RETURNED IF %SUBST(IDA : X :K2) = *BLANKS; LEAVE; ENDIF; // MOVE DATA TO WORK ARRAY K X1 = X; FOR X2 = 1 TO K2; IF ID(X1) < ' '; LEAVE; ENDIF; K(X2) = ID(X1); X1 = X1 + 1; ENDFOR; LEAVE; ENDDO; // * SET START POSN W = S(Y); // ALPHA IF T(Y) = 'A' and V(XX) <> 'Y'; FOR Z = K1 to K2; D(W) = K(Z); W = W + 1; ENDFOR; ENDIF; IF T(Y) = 'A' and V(XX) = 'Y'; //VARYING // the data start is in S(Y) // the data is in array K // get the length of the data cvt to bin and stik in pos 1 2 // put the rest in pos 3 onwards ENDIF; // NUMERIC FIELD // RIGHT ADJUST NUMERIC DATA ,STRIP - . ,CONVERT BLANKS IF (T(Y) = 'S' OR T(Y) = 'P' OR T(Y) = 'B'); NU = '0'; Z1 = 60; FOR Z = K2 DOWNTO K1; IF K(Z) = '.' OR K(Z) = '-' OR K(Z) = '$'; ITER; ENDIF; IF K(Z) = ' ' ; NU(Z1) = '0'; ELSE; NU(Z1) = K(Z); ENDIF; Z1 = Z1 -1; ENDFOR; ENDIF; // SIGNED FIELDS (END POSN = OFFSET + SIZE) IF T(Y) = 'S'; NUSA= *BLANKS; FOR VX = 1 TO 60; NUSA = %TRIM(NUSA) + NU(VX); ENDFOR; %SUBST(DATA : W : Q(Y)) = %SUBST(NUSA: 61 -Q(Y)); ENDIF; // PACKED FIELDS IF T(Y) = 'P'; NUSA= *BLANKS; FOR VX = 1 TO 60; NUSA = %TRIM(NUSA) + NU(VX); ENDFOR; NUP = %DEC(NUSA : 60 : 0); %SUBST(DATA : W : Q(Y)) = %SUBST(NUPA: 61 -Q(Y)); ENDIF; // BINARY FIELDS IF T(Y) = 'B'; NUSA= *BLANKS; FOR VX = 1 TO 60; NUSA = %TRIM(NUSA) + NU(VX); ENDFOR; NUC = NUS; IF Q(Y) = 2 ; DISBIN ( NUC : BAN2 : BAN4 : '2'); %SUBST(DATA : W : 2) = BAN2; ENDIF; IF Q(Y) = 4 ; DISBIN ( NUC : BAN2 : BAN4 : '4'); %SUBST(DATA : W : 4) = BAN4; ENDIF; ENDIF; // UPDATE KEY IF NECESSARY IF KY(Y) = '1'; CGKY = '1'; EXSR @PCKMOV; ENDIF; ENDDO; ENDFOR; IF CGKY = '1'; KEYA = KW; ENDIF; ENDSR; /END-FREE OINPUTK E U1 UPDATREC O DA O 30 DB O 31 DC O 32 DD O 33 DE O 34 DF O 35 DG O 36 DH O 37 DI O 38 DJ O 39 DK O 40 DL O 41 DM O 42 DN O 43 DZ O 44 DO O 45 DP O 46 DQ O 47 DR O 48 DS O 49 DT O 50 DU O 51 DV O 52 DW O 53 DX O 54 DY O 55 D0 O 56 D1 O 57 D2 O 58 D3 O 59 D4 O 60 D5 O 61 D6 O 62 DBA O 63 DCA O 64 DDA O 65 DEA O 66 DFA O 67 DGA O 68 DHA O 69 DIA O 70 DJA O 71 DKA O 72 DLA O 73 DMA O 74 DNA O 75 DOA O 76 DPA O 77 DQA O 78 DRA O 79 DSA O 80 DTA O 81 DUA O 82 DVA O 83 DWA O 84 DXA O 85 DYA O 86 DZA O 87 D0A O 88 D1A O 89 D2A O 90 D3A O 91 D4A O 92 D5A O 93 D6A OINPUTR E U2 UPDATREC O DA O 30 DB O 31 DC O 32 DD O 33 DE O 34 DF O 35 DG O 36 DH O 37 DI O 38 DJ O 39 DK O 40 DL O 41 DM O 42 DN O 43 DZ O 44 DO O 45 DP O 46 DQ O 47 DR O 48 DS O 49 DT O 50 DU O 51 DV O 52 DW O 53 DX O 54 DY O 55 D0 O 56 D1 O 57 D2 O 58 D3 O 59 D4 O 60 D5 O 61 D6 O 62 DBA O 63 DCA O 64 DDA O 65 DEA O 66 DFA O 67 DGA O 68 DHA O 69 DIA O 70 DJA O 71 DKA O 72 DLA O 73 DMA O 74 DNA O 75 DOA O 76 DPA O 77 DQA O 78 DRA O 79 DSA O 80 DTA O 81 DUA O 82 DVA O 83 DWA O 84 DXA O 85 DYA O 86 DZA O 87 D0A O 88 D1A O 89 D2A O 90 D3A O 91 D4A O 92 D5A O 93 D6A OINPUTK EADD U1 ADDREC O DA O 30 DB O 31 DC O 32 DD O 33 DE O 34 DF O 35 DG O 36 DH O 37 DI O 38 DJ O 39 DK O 40 DL O 41 DM O 42 DN O 43 DZ O 44 DO O 45 DP O 46 DQ O 47 DR O 48 DS O 49 DT O 50 DU O 51 DV O 52 DW O 53 DX O 54 DY O 55 D0 O 56 D1 O 57 D2 O 58 D3 O 59 D4 O 60 D5 O 61 D6 O 62 DBA O 63 DCA O 64 DDA O 65 DEA O 66 DFA O 67 DGA O 68 DHA O 69 DIA O 70 DJA O 71 DKA O 72 DLA O 73 DMA O 74 DNA O 75 DOA O 76 DPA O 77 DQA O 78 DRA O 79 DSA O 80 DTA O 81 DUA O 82 DVA O 83 DWA O 84 DXA O 85 DYA O 86 DZA O 87 D0A O 88 D1A O 89 D2A O 90 D3A O 91 D4A O 92 D5A O 93 D6A OINPUTR EADD U2 ADDREC O DA O 30 DB O 31 DC O 32 DD O 33 DE O 34 DF O 35 DG O 36 DH O 37 DI O 38 DJ O 39 DK O 40 DL O 41 DM O 42 DN O 43 DZ O 44 DO O 45 DP O 46 DQ O 47 DR O 48 DS O 49 DT O 50 DU O 51 DV O 52 DW O 53 DX O 54 DY O 55 D0 O 56 D1 O 57 D2 O 58 D3 O 59 D4 O 60 D5 O 61 D6 O 62 DBA O 63 DCA O 64 DDA O 65 DEA O 66 DFA O 67 DGA O 68 DHA O 69 DIA O 70 DJA O 71 DKA O 72 DLA O 73 DMA O 74 DNA O 75 DOA O 76 DPA O 77 DQA O 78 DRA O 79 DSA O 80 DTA O 81 DUA O 82 DVA O 83 DWA O 84 DXA O 85 DYA O 86 DZA O 87 D0A O 88 D1A O 89 D2A O 90 D3A O 91 D4A O 92 D5A O 93 D6A OINPUTK EDEL U1 DELREC OINPUTR EDEL U2 DELREC ODISPF E DATAO O K3 'PUT' O OUTLEN 2 O INLEN O FNC O A O E DATAI O K3 'GET' O OUTLEN 2 O INLEN O FNC O A ** 0000 INVALID COMMAND KEY 0001 - A FIELD IS TOO LONG 0002 - TOO MANY FIELDS 0003 - ALPHAS IN PACKED KEY 0004 - MISSING ' IN PACKED KEY 0005 - MISSING DATA IN PCKD KEY 0006 - RECORD NOT FOUND PRESS RESET TO CONTINUE ** F1-HEX F2-Return F3-Exit F19-Prev_fld F20-More_fld F1-HEX F2-Return F3-Exit F6-Update F9-Add F11-Del F19-Prev_fld F20-More_fld ** 0123456789ABCDEF
DISPF DSPF
A DSPSIZ(24 80 *DS3) A PRINT A OPENPRT A HELP A INDARA A R PUT USRDFN A R GET USRDFN A INVITE
WRAPPER CODE
DSPFL CMD
/* TO COMPILE */ /* CRTCMD CMD(*CURLIB/DSPFL) PGM(*LIBL/DIS) SRCFILE(*LIBL/QCMDSRC) */ /* SRCMBR(DSPFL) VLDCKR(DISV) */ CMD PROMPT('Display file in field format') PARM KWD(FILE) TYPE(QUAL1) MIN(1) MAX(1) + PROMPT('File') PARM KWD(MBR) TYPE(*NAME) DFT(*FIRST) + SPCVAL((*FILE) (*FIRST)) MIN(0) MAX(1) + PROMPT('Member') PARM KWD(UPD ) TYPE(*CHAR) LEN(1) DFT(N) + RSTD(*YES) VALUES('Y' 'N' 'y' 'n') + PROMPT('Update data (Y/N)') PARM KWD(RST ) TYPE(*CHAR) LEN(1) DFT(N) + RSTD(*YES) VALUES('Y' 'N' 'y' 'n') + PROMPT('Get DDS again.') PARM KWD(REL ) TYPE(*CHAR) LEN(1) DFT(N) + RSTD(*YES) VALUES('Y' 'N' 'y' 'n') + PROMPT('Show Relations') QUAL1: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL ) + SPCVAL(*LIBL ) + PROMPT('Library name')
DIS CL
/* Command processing program for DSPFF command */ PGM (&FILIB &MBR &UPD &RST &REL) DCL &FILIB *CHAR 20 DCL &FILE *CHAR 10 DCL &LIB *CHAR 10 DCL &SFILE *CHAR 10 DCL &SLIB *CHAR 10 DCL &MBR *CHAR 10 DCL &OPT *CHAR 10 DCL &ALL *CHAR 1 DCL &RTN *CHAR 1 DCL &RMBR *CHAR 10 DCL &QRY *LGL DCL &UPD *LGL DCL &REL *CHAR 1 DCL &RST *CHAR 1 DCL &RCDL *CHAR 5 DCL &RCDLN *DEC (5 0) DCL &ACCP *CHAR 1 DCL &OVR *LGL VALUE('0') DCL &FILEF *CHAR 10 DCL &FILEK *CHAR 10 DCL &ID *CHAR 7 DCL &MF *CHAR 10 DCL &ML *CHAR 10 DCL &TYPE *CHAR 1 DCL &PHY *CHAR 10 DCL &PHYLIB *CHAR 10 RMVLIBLE QTEMP MONMSG CPF0000 ADDLIBLE QTEMP *FIRST MONMSG CPF0000 EXEC(GOTO END) RESET: CHGVAR &FILE &FILIB CHGVAR &LIB (%SST(&FILIB 11 10)) IF (&LIB *EQ ' ') (CHGVAR &LIB '*LIBL') IF (&MBR *EQ '*FILE') (CHGVAR &MBR &FILE) IF (&MBR *EQ '*FIRST') (DO) RTVMBRD FILE(&LIB/&FILE) RTNMBR(&RMBR) CHGVAR &MBR &RMBR ENDDO CHGVAR &FILEF ('FF'||(%SST(&FILE 1 8))) CHGVAR &FILEK ('KF'||(%SST(&FILE 1 8))) IF (&RST= 'Y') DO DLTF &FILEF MONMSG CPF0000 DLTF &FILEK MONMSG CPF0000 ENDDO CHKOBJ (QTEMP/&FILEF) *FILE MONMSG CPF9801 EXEC(DO) DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEF) DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/&FILEK) CHGVAR &RTN '2' ENDDO CHGPF QTEMP/&FILEF LVLCHK(*NO) CHGPF QTEMP/&FILEK LVLCHK(*NO) IF (&REL = 'Y' ) DO CALL DISF (&FILEK &TYPE &PHY &PHYLIB) IF (&TYPE *EQ 'P') DO CHGVAR &PHY &FILE CHGVAR &PHYLIB &LIB ENDDO CALL DIS3 (&PHY &PHYLIB &SFILE &SLIB) IF (&SFILE *NE ' ') DO IF ((&SFILE *NE &FILE) *OR (&SLIB *NE &LIB)) DO CHGVAR &FILIB (&SFILE||&SLIB) CHGVAR &REL '0' RTVMBRD FILE(&SLIB/&SFILE) RTNMBR(&RMBR) CHGVAR &MBR &RMBR IF (&MBR *EQ &FILE) THEN(CHGVAR &MBR '*FILE ') GOTO RESET ENDDO ENDDO ENDDO CALL DIS1 (&FILIB &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK) RCLRSC END: CLOF OPNID(&FILE) MONMSG CPF0000 ENDPGM
DIS1 CL
/* CALLED BY DIS TO DRIVE SELECTION OF UDDS RPG PROGRAM */ /* FILE DISPLAYER DRIVER */ /* SHOWS A LIST OF FIELDS IN A FILE , ALLOWS SELECTION OF FIELDS */ /* WHEN ALL THE FIELDS DONT FIT ON ONE SCREEN */ /* THIS CONTAINS A LOOP SO THAT MORE FIELDS CAN BE DISPLAYED */ PGM (&FILIB &MBR &UPD &RST &RTN &FILE &LIB &FILEF &FILEK) DCL &FILIB *CHAR 20 DCL &FILE *CHAR 10 DCL &LIB *CHAR 10 DCL &MBR *CHAR 10 DCL &PRG *CHAR 10 DCL &OPT *CHAR 10 DCL &ALL *CHAR 1 DCL &RTN *CHAR 1 DCL &RMV *CHAR 1 DCL &QRY *LGL DCL &UPD *CHAR 1 DCL &RST *LGL DCL &KEYL *CHAR 4 DCL &RCDL *CHAR 5 DCL &RCDLN *DEC (5 0) DCL &ACCP *CHAR 1 DCL &OVR *LGL VALUE('0') DCL &FILEF *CHAR 10 DCL &FILEK *CHAR 10 DCL &ID *CHAR 7 DCL &MF *CHAR 10 DCL &ML *CHAR 10 DCL &SCNLV *CHAR 500 DCL &SCNLVL *CHAR 5 DCL &SCNKEY *CHAR 800 DCL &JOB *CHAR 10 DCL &MSG *CHAR 80 DCLF DISPX CHGVAR &PGMQ DIS CHGVAR &SCNLVL '00000' OVRDBF FFD QTEMP/&FILEF SECURE(*YES) OVRDBF KF QTEMP/&FILEK SECURE(*YES) RTN: OVRDBF INPUT &LIB/&FILE SHARE(*NO) CALL DISPY (&ALL &RTN &KEYL &ACCP &QRY &RCDL) MONMSG MSGID(CPF5035 CPF5029 RNQ1299 RNX0000) EXEC(DO) RTVJOBA JOB(&JOB) SNDBRKMSG MSG('Cannot handle this file type. Possibly + has NULL data field.') TOMSGQ(&job) + MSGTYPE(*INQ) RPYMSGQ(&job) goto end ENDDO DLTOVR INPUT MONMSG CPF0000 IF (&RTN *EQ '1') (GOTO END) IF (&ACCP *EQ 'K') DO CHGJOB SWS(10XXXXXX) OVRDBF FILE(INPUTK) TOFILE(&LIB/&FILE) MBR(&MBR) + SHARE(*YES) SEQONLY(*NO) SECURE(*YES) IF (&QRY ) DO REMSG: REQRY: SNDRCVF RCDFMT(SLT) IF (&IN01 *OR &IN02) GOTO BYQRY CHGVAR &OPT '*INP' IF (&UPD *EQ 'Y') (CHGVAR &OPT '*ALL') OPNQRYF FILE((INPUTK)) OPTION(&OPT) QRYSLT(&QSLT) + KEYFLD(*FILE) SEQONLY(*NO) MONMSG CPF9899 EXEC(DO) RCVMSG MSGTYPE(*ANY) SNDF RCDFMT(SLTC) GOTO REMSG ENDDO ENDDO ENDDO BYQRY: IF (&ACCP *EQ 'A') DO CHGJOB SWS(01XXXXXX) OVRDBF FILE(INPUTR) TOFILE(&LIB/&FILE) MBR(&MBR) + SHARE(*YES) SEQONLY(*NO) SECURE(*YES) IF (&QRY ) DO REMSGA: REQRYA: SNDRCVF RCDFMT(SLT) IF (&IN01 *OR &IN02) GOTO BYQRYA CHGVAR &OPT '*INP' IF (&UPD = 'Y') (CHGVAR &OPT '*ALL') OPNQRYF FILE((INPUTR)) OPTION(&OPT) QRYSLT(&QSLT) + KEYFLD(*FILE) SEQONLY(*NO) MONMSG CPF9899 EXEC(DO) RCVMSG MSGTYPE(*ANY) SNDF RCDFMT(SLTC) GOTO REMSGA CHGVAR VAR(&IN20) VALUE('1') SDAMSG: RCVMSG RMV(*NO) MSG(&MSG) IF COND(&MSG ¬= ' ') THEN(DO) SNDPGMMSG MSG(&MSG) GOTO SDAMSG ENDDO SNDF RCDFMT(SLTC) GOTO REMSGA ENDDO ENDDO ENDDO BYQRYA: CHGVAR &RCDLN &RCDL IF ( &UPD= 'Y') (DO) IF ((&RCDLN *GT 0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DUSP ') IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DUSP1') IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DUSP2') ENDDO IF (&UPD *NE 'Y') (DO) IF ((&RCDLN *GT 0) *AND (&RCDLN *LE 2048)) (CHGVAR &PRG 'DISP ') IF ((&RCDLN *GT 2048) *AND (&RCDLN *LE 4048)) (CHGVAR &PRG 'DISP1') IF ((&RCDLN *GT 4048) *AND (&RCDLN *LE 6080)) (CHGVAR &PRG 'DISP2') ENDDO CALL &PRG (&ALL &RTN &KEYL &UPD &SCNLV &SCNLVL &SCNKEY) IF (&QRY ) (DO) IF (&ACCP *EQ 'K') DO CLOF INPUTK MONMSG CPF0000 ENDDO IF (&ACCP *EQ 'A') DO CLOF INPUTR MONMSG CPF0000 ENDDO ENDDO IF (&RTN *EQ '3') DO GOTO BYQRYA ENDDO IF (&RTN *EQ '1') DO CHGVAR &RTN '0' GOTO RTN ENDDO END: ENDPGM
DIS3 CL
/* CALL BY DIS TO SHOW FILE RELATIONS / ACCESS PATHS */ PGM (&PHY &PHYLIB &SFILE &SLIB) /* DISPLAY ACCESS PATHS */ DCL &PHY *CHAR 10 DCL &PHYLIB *CHAR 10 DCL &SFILE *CHAR 10 DCL &SLIB *CHAR 10 DCLF QTEMP/DBR /* CREATE WORK FILES */ CALL DIS4 DLTF QTEMP/DBR MONMSG CPF0000 DSPDBR FILE(&PHYLIB/&PHY) OUTPUT(*OUTFILE) + OUTFILE(QTEMP/DBR) OUTMBR(*FIRST *REPLACE) CHGPF QTEMP/DBR LVLCHK(*NO) NEXT: RCVF MONMSG CPF0000 EXEC(GOTO END) IF (&WHREFI *NE ' ') DO DSPFD FILE(&WHRELI/&WHREFI) TYPE(*ACCPTH) + OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD) CHGPF QTEMP/REL LVLCHK(*NO) DSPFD FILE(&WHRELI/&WHREFI) TYPE(*SELECT) + OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL) OUTMBR(*FIRST *ADD) CHGPF QTEMP/SEL LVLCHK(*NO) ENDDO GOTO NEXT END: DSPFD FILE(&PHYLIB/&PHY ) TYPE(*ACCPTH) + OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD) CHGPF QTEMP/REL LVLCHK(*NO) CHGVAR &SFILE ' ' CHGVAR &SLIB ' ' OVRDBF SEL QTEMP/SEL OVRDBF REL QTEMP/REL CALL DISPR (&SFILE &SLIB) DLTOVR *ALL ENDPGM
DIS4 CL
/* CALL BY DIS3 TO CREATE WORK FILES */ PGM DCL &LIB *CHAR 10 DCL &SRCF *CHAR 10 RTVDTAARA DTAARA(UDDSSRC *ALL) RTNVAR(&SRCF) DLTF QTEMP/XXXXFILE monmsg cpf0000 CRTPF FILE(QTEMP/XXXXFILE) RCDLEN(80) OPTION(*NOLIST) DSPFFD FILE(QTEMP/XXXXFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) CLRPFM QTEMP/FFD DLTF FILE(QTEMP/FFDL01) MONMSG CPF0000 RTVMBRD FILE(&SRCF) RTNLIB(&LIB) CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) + OPTION(*NOSRC *NOLIST) DLTF FILE(QTEMP/REL) MONMSG CPF0000 DLTF FILE(QTEMP/SEL) MONMSG CPF0000 DLTF FILE(QTEMP/DBR) MONMSG CPF0000 DSPFD FILE(QTEMP/FFD) TYPE(*ACCPTH) + OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD) DSPFD FILE(QTEMP/FFDL01) TYPE(*SELECT) OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL) CLRPFM FILE(QTEMP/REL) CLRPFM FILE(QTEMP/SEL) DLTF QTEMP/XXXXFILE monmsg cpf0000 ENDPGM
DISBIN CL
/* NUMERIC TO BINARY CONVERTER */ PGM (&NUM &BIN2 &BIN4 &BINTYP ) DCL VAR(&NUM) TYPE(*DEC) LEN(15 0) DCL VAR(&BINTYP) TYPE(*CHAR) LEN(1) DCL VAR(&BIN2) TYPE(*CHAR) LEN(2) DCL VAR(&BIN4) TYPE(*CHAR) LEN(4) IF (&BINTYP = '4') (CHGVAR %BIN(&BIN4) &NUM) IF (&BINTYP = '2') (CHGVAR %BIN(&BIN2) &NUM) ENDPGM
DISF CL
/* CHECK FILE TYPE */ PGM (&DISF &TYPE &PHY &PHYLIB) DCL &DISF *CHAR 10 DCL &TYPE *CHAR 1 DCL &PHY *CHAR 10 DCL &PHYLIB *CHAR 10 DCLF KF OVRDBF FILE(KF) TOFILE(QTEMP/&DISF) OPNDBF FILE(KF) OPTION(*INP) RCVF CHGVAR &TYPE &APFTYP IF (&TYPE *EQ 'L') DO CHGVAR &PHY &APBOF CHGVAR &PHYLIB &APBOL ENDDO CLOF OPNID(KF) ENDPGM
DISV CL
/* VALIDITY CHECKER FOR DSPFL COMMAND */ PGM (&FILIB &MBR &UPD &RST &REL) DCL &FILIB *CHAR 20 DCL &FILE *CHAR 10 DCL &LIB *CHAR 10 DCL &MBR *CHAR 10 DCL &UPD *CHAR 1 DCL &RST *CHAR 1 DCL &REL *CHAR 1 DCL &OBJATR *CHAR 10 DCL &AUT *CHAR 8 DCL &MSGDTA *CHAR 40 DCL &ERROR *LGL CHGVAR &FILE &FILIB CHGVAR &LIB (%SST(&FILIB 11 10)) IF (&MBR *EQ '*FILE') (CHGVAR &MBR &FILE ) CHGVAR &AUT '*READ ' IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE') CHKOBJ (&LIB/&FILE) OBJTYPE(*FILE) MBR(*NONE) + AUT( &AUT ) MONMSG (CPF9899 CPF9801 CPF9802 CPF9820 CPF9830) EXEC(DO) /* CHGVAR (&MSGDTA) VALUE(' '||&FILE||&LIB) */ /* SNDPGMMSG MSGID(USR0006) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) +*/ /* MSGDTA(&MSGDTA) */ SNDPGMMSG MSG('Not authorised to the file.') + MSGTYPE(*DIAG) CHGVAR (&ERROR) '1' ENDDO MONMSG (CPF9810) EXEC(DO) CHGVAR (&MSGDTA) VALUE(' '||&LIB) /* SNDPGMMSG MSGID(USR0008) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) +*/ /* MSGDTA(&MSGDTA) */ SNDPGMMSG MSG('Not authorised to the file.') + MSGTYPE(*DIAG) CHGVAR (&ERROR) '1' ENDDO IF (*NOT &ERROR) DO RTVOBJD OBJ(&LIB/&FILE) OBJTYPE(*FILE) OBJATR(&OBJATR) CHGVAR &AUT '*READ ' IF ((&UPD *EQ 'Y') *OR (&UPD *EQ 'y')) (CHGVAR &AUT '*CHANGE') CHKOBJ OBJ(&LIB/&FILE) OBJTYPE(*FILE) MBR(&MBR) + AUT(&AUT) MONMSG (CPF9815 ) EXEC(DO) /* CHGVAR (&MSGDTA) VALUE(' '||&MBR||&FILE||&LIB) */ /* SNDPGMMSG MSGID(USR0007) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */ /* MSGDTA(&MSGDTA) */ SNDPGMMSG MSG('Not authorised to the file.') + MSGTYPE(*DIAG) CHGVAR (&ERROR) '1' ENDDO MONMSG (CPF0000 ) EXEC(DO) /* SNDPGMMSG MSGID(USR0022) MSGF(*LIBL/QUSERMSG) MSGTYPE(*DIAG) + */ /* MSGDTA(&MSGDTA) */ SNDPGMMSG MSG('Not authorised to the file.') + MSGTYPE(*DIAG) CHGVAR (&ERROR) '1' ENDDO ENDDO IF (&ERROR) (SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE)) ENDPGM
DISPR RPG
H OPTIMIZE(*NONE) OPTION(*NODEBUGIO) H DFTACTGRP(*NO) ACTGRP(*CALLER) * FILE RELATIONS DISPLAYER * REQUIRES FILES TO COMPILE * FREL IF E DISK FSEL IF E DISK FDISPRF CF E WORKSTN F SFILE(S01:RS01) F SFILE(S02:RS02) F INFDS(SFINF) * * DDISPR PR D 10 D 10 DDISPR PI D SFILE 10 D SLIB 10 // SCREEN LEVELS D @SCN S 6 DIM(50) D @NSCN S 6 D @LV S 5 0 D @ERR S LIKE(@TRUE) D @FILE S 10A INZ('DISPY ') D WRKSWS S 1 D I S 4B 0 D @TRUE S 1A INZ('1') D @FALSE S 1A INZ('0') D @OK S LIKE(@TRUE) D @LOOP S LIKE(@TRUE) // D RS01 S 4S 0 D RS02 S 4S 0 // // PARMS FOR SFL LOOPING D SFC01 S LIKE(RS01) D SFC02 S LIKE(RS01) // Program Status D SDS D PGM 1 10 D WSID 244 253 D USER 254 263 // // D SFINF DS D RRRN 376 377B 0 D SRN 378 379B 0 // MESSAGE DATA D @DTA1 DS 80 D @DTA2 DS 500 // D MAIN PR D @S01BLD PR D @S01PRC PR D @S01PRS PR D @S02BLD PR D @S02PRC PR D D @R9999 PR D @OPADJ PR 2A D OPT 2A /FREE *INLR = *ON; MAIN(); //--------------*INZSR-------------------------------// BEGSR *INZSR; // Set the TOP level (Exit if user backs up to here) @LV = 1; @SCN(@LV) = '*END '; // Set the Initial Screen to display @LV = @LV + 1; @SCN(@LV) = 'S01BLD '; ENDSR; /END-FREE //###################################################// //************************************************************* P MAIN B D MAIN PI D I S 4B 0 /FREE EXSR @INZSR; // // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY DOW @LOOP = @LOOP; // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY @NSCN = @SCN(@LV); SELECT; // SELECT FIELDS FOR DISPLAY // SFL TO SELECT THE FILE FIELDS WHEN @NSCN = 'S01BLD'; @S01BLD(); WHEN @NSCN = 'S01PRC'; @S01PRC(); WHEN @NSCN = 'S01PRS'; @S01PRS(); WHEN @NSCN = 'S02BLD'; @S02BLD(); WHEN @NSCN = 'S02PRC'; @S02PRC(); OTHER; // CATCH ALL (NEVER USED) @R9999(); LEAVE; ENDSL; // CF3 EXIT IF *IN03 = *ON; LEAVE; ENDIF; // CF12 PREVIOUS IF *IN12 = *ON; *IN12 = *OFF; @LV = @LV -1; @NSCN = @SCN(@LV); ENDIF; // Backed out to last level, Exit IF @NSCN = '*END'; LEAVE; ENDIF; ENDDO; RETURN; //--------------*INZSR-------------------------------// BEGSR @INZSR; @NSCN = *BLANK; ENDSR; //-ENDSR---*INZSR-------------------------------// /END-FREE P MAIN E //###################################################// //###################################################// //###################################################// /space 3 P @S01BLD B D @S01BLD PI D WFILE S LIKE(APFILE ) D WLIB S LIKE(APLIB ) // Build/Rebuild the subfile /FREE EXSR @INZSR; EXSR BLD; // SFL IS BUILT, PROCESS THE SFL CONTROL @LV = @LV + 1; @SCN(@LV) = 'S01PRC ' ; RETURN ; //-------------- BLD -------------------------------// BEGSR BLD; EXSR CLR; SETLL 1 QWHFDACP; DOW @LOOP = @LOOP; READ QWHFDACP; IF %EOF; LEAVE; ENDIF; EXSR MOV; // RS01 = RS01 + 1; WRITE S01; ENDDO; // Position to TOP of subfile SRS01 = 1; SFC01 = RS01; ENDSR; //-------------- CLR -------------------------------// BEGSR CLR; *IN51 = *OFF; *IN52 = *OFF; *IN53 = *ON; WRITE C01; *IN53 = *OFF; RS01 = 0 ; SFC01 = 0 ; S01FUNC = *BLANK; ENDSR; //-------------- MOV -------------------------------// BEGSR MOV; C01APBOF = APBOF ; C01APBOL = APBOL ; IF APBOF = *BLANK AND APBOL = *BLANK; C01APBOF = APFILE; C01APBOL = APLIB; ENDIF; // Load the subfile record IF APFILE = WFILE AND APLIB = WLIB ; *IN56 = *ON ; S01APFILE = *BLANK; S01APLIB = *BLANK; S01APACCP = *BLANK; S01APUNIQ = *BLANK; S01APSELO = *BLANK; S01APFTYP = *BLANK; S01APJOIN = *BLANK; S01APKEYO = *BLANK; S01APKSEQ = APKSEQ ; S01APKSIN = APKSIN ; S01APKEYF = APKEYF ; ELSE ; WFILE = APFILE; WLIB = APLIB ; *IN56 = *OFF; S01APFILE = APFILE ; S01APLIB = APLIB ; S01APACCP = APACCP ; S01APUNIQ = APUNIQ ; S01APSELO = APSELO ; S01APFTYP = APFTYP ; S01APJOIN = APJOIN ; S01APKEYO = APKEYO ; S01APKSEQ = APKSEQ ; S01APKSIN = APKSIN ; S01APKEYF = APKEYF ; ENDIF; ENDSR; //--------------*INZSR-------------------------------// BEGSR @INZSR; @NSCN = *BLANK; ENDSR; /END-FREE P @S01BLD E //###################################################// //###################################################// /space 3 P @S01PRC B D @S01PRC PI // // D WRKRC S 4S 0 /FREE EXSR @INZSR; WRITE R01; // DOW @LOOP = @LOOP; // // Write SFL Control IF SFC01 > 0; *IN51 = *ON; ENDIF; *IN52 = *ON; EXFMT C01; // Setoff errors *IN89 = *OFF; // // Exit and Previous Screen IF *IN03 = *ON; LEAVE; ENDIF; IF *IN12 = *ON; LEAVE; ENDIF; // Process the subfile @LV = @LV + 1; @SCN(@LV) = 'S01PRS'; LEAVE; ENDDO; // RETURN; /space 3 //--------------*INZSR-------------------------------// BEGSR @INZSR; @NSCN = *BLANK; ENDSR; /END-FREE P @S01PRC E //###################################################// //###################################################// //###################################################// /space 3 P @S01PRS B D @S01PRS PI // // D WRKRC S 4S 0 /FREE EXSR @INZSR; // Process the subfile EXSR SFL; RETURN; //-------------- SFL -------------------------------// BEGSR SFL; // Process the subfile FOR WRKRC = 1 TO SFC01 + 1 ; CHAIN WRKRC S01; IF NOT %FOUND; // Finished with the subfile @LV = @LV -1; LEAVE; ENDIF; // GET SELECTED FILE IF @OPADJ(S01FUNC) = ' X'; SFILE = S01APFILE; SLIB = S01APLIB ; *IN03 = '1'; LEAVE; ENDIF; // SHOW SELECT RULES IF @OPADJ(S01FUNC) = ' R'; @LV = @LV + 1; @SCN(@LV) = 'S02BLD '; S01FUNC = ' '; UPDATE S01; LEAVE; ENDIF; ENDFOR; ENDSR; //---------------------------------------------------// //--------------*INZSR-------------------------------// BEGSR @INZSR; @NSCN = *BLANK; ENDSR; /END-FREE P @S01PRS E /space 3 P @S02BLD B D @S02BLD PI // Build/Rebuild the subfile /FREE EXSR @INZSR; C02APFILE = S01APFILE ; C02APLIB = S01APLIB ; EXSR BLD; // SFL IS BUILT, PROCESS THE CONTROL @LV = @LV + 1; @SCN(@LV) = 'S02PRC '; RETURN; //-------------- BLD -------------------------------// BEGSR BLD; EXSR CLR; SETLL 1 QWHFDSO ; DOW @LOOP = @LOOP; READ QWHFDSO ; IF %EOF; LEAVE; ENDIF; If SOFILE = S01APFILE AND SOLIB = S01APLIB ; EXSR MOV; // RS02 = RS02 + 1; WRITE S02; ENDIF; ENDDO; // Position to TOP of subfile SRS02 = 1; SFC02 = RS02; ENDSR; //-------------- CLR -------------------------------// BEGSR CLR; *IN51 = *OFF; *IN52 = *OFF; *IN53 = *ON; WRITE C02; *IN53 = *OFF; RS02 =0; SFC02=0; ENDSR; //-------------- MOV -------------------------------// BEGSR MOV; // Load the subfile record S02SOFLD = SOFLD ; S02SORULE = SORULE ; S02SOCOMP = SOCOMP ; S02SOVALU = SOVALU ; ENDSR; //--------------*INZSR-------------------------------// BEGSR @INZSR; @NSCN = *BLANK; ENDSR; /END-FREE P @S02BLD E //###################################################// //###################################################// //###################################################// /space 3 P @S02PRC B D @S02PRC PI // // D WRKRC S 4S 0 /FREE EXSR @INZSR; WRITE R02; // DOW @LOOP = @LOOP; // // Write SFL Control IF SFC02 > 0; *IN51 = *ON; ENDIF; *IN52 = *ON; EXFMT C02; // // Setoff errors *IN89 = *OFF; // // Exit and Previous Screen @LV = @LV -2; LEAVE; // Process the subfile ENDDO; // RETURN; /space 3 //--------------*INZSR-------------------------------// BEGSR @INZSR; @NSCN = *BLANK; ENDSR; /END-FREE P @S02PRC E //###################################################// //###################################################// //###################################################// P @R9999 B // Invalid Panel D @R9999 PI P @R9999 E /space 3 //###################################################// //###################################################// //###################################################// P @OPADJ B // RIGHT ADJ OPTION , zero suppress D @OPADJ PI 2A D OPT 2A /FREE EVALR OPT = %trimr(OPT); If %SubSt(OPT:1:1) = '0'; OPT = ' ' + %SubSt(OPT:2:1); EndIf; RETURN OPT; /END-FREE P @OPADJ E //###################################################// //###################################################//
DISPRF DSPF
A*%%TS SD 20101208 163705 KOLMANNF REL-V5R4M0 5722-WDS A* * REQUIRES FILES TO COMPILE * CRTDUPOBJ OBJ(QAFDSELO) FROMLIB(QSYS) * OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(SEL) * CRTDUPOBJ OBJ(QAFDACCP) FROMLIB(QSYS) * OBJTYPE(*FILE) TOLIB(QTEMP) NEWOBJ(ACC) A*%%EC A DSPSIZ(24 80 *DS3) A PRINT A CF03(03) A CF12(12) A R S01 SFL A*%%TS SD 20101208 163705 KOLMANNF REL-V5R4M0 5722-WDS A S01FUNC 2A I 4 3 A 55 AO 56 DSPATR(PR) A S01APFILE R O 4 6REFFLD(QWHFDACP/APFILE QTEMP/REL) A S01APLIB R O 4 17REFFLD(QWHFDACP/APLIB QTEMP/REL) A S01APACCP R O 4 29REFFLD(QWHFDACP/APACCP QTEMP/REL) A S01APUNIQ R O 4 33REFFLD(QWHFDACP/APUNIQ QTEMP/REL) A S01APSELO R O 4 37REFFLD(QWHFDACP/APSELO QTEMP/REL) A S01APFTYP R O 4 41REFFLD(QWHFDACP/APFTYP QTEMP/REL) A S01APJOIN R O 4 45REFFLD(QWHFDACP/APJOIN QTEMP/REL) A S01APKEYO R O 4 48REFFLD(QWHFDACP/APKEYO QTEMP/REL) A S01APKSEQ R O 4 53REFFLD(QWHFDACP/APKSEQ QTEMP/REL) A S01APKSIN R O 4 57REFFLD(QWHFDACP/APKSIN QTEMP/REL) A S01APKEYF R O 4 61REFFLD(QWHFDACP/APKEYF QTEMP/REL) A R C01 SFLCTL(S01) A*%%TS SD 20101208 163705 KOLMANNF REL-V5R4M0 5722-WDS A SFLSIZ(0019) A SFLPAG(0018) A OVERLAY A 50 SFLEND A 51 SFLDSP A 52 SFLDSPCTL A 53 SFLCLR A SRS01 4S 0H SFLRCDNBR(CURSOR) A* A 1 18'FILE RELATIONS for ' A C01APBOF R O 1 39REFFLD(QWHFDACP/APBOF QTEMP/REL) A 1 51'Lib.' A C01APBOL R O 1 56REFFLD(QWHFDACP/APBOL QTEMP/REL) A 2 32'Uni SEL LIFO ASC Key' A 3 6'File Library Acc Key OMT - A TYP J FIFO DSC Sgn Key' A R R01 A 24 3'F3-Exit' A 22 3'R - Display Select/Omit rules' A 23 3'X - Select for display' * A R R02 A 24 3'F3-Exit' A R S02 SFL A SFLNXTCHG A S02SOFLD R O 4 4REFFLD(QWHFDSO/SOFLD QTEMP/SEL) A S02SORULE R O 4 17REFFLD(QWHFDSO/SORULE QTEMP/SEL) A S02SOCOMP R O 4 22REFFLD(QWHFDSO/SOCOMP QTEMP/SEL) A S02SOVALU R O 4 28REFFLD(QWHFDSO/SOVALU QTEMP/SEL) A R C02 SFLCTL(S02 ) A OVERLAY A 50 SFLEND A 51 SFLDSP A 52 SFLDSPCTL A 53 SFLCLR A SFLSIZ(0019) A SFLPAG(0018) A SRS02 4S 0H SFLRCDNBR(CURSOR) A* A 1 6'FILE SELECTS for ' A C02APFILE R O 2 7REFFLD(QWHFDSO/SOFILE QTEMP/SEL) A 2 20'Lib.' A C02APLIB R O 2 25REFFLD(QWHFDSO/SOLIB QTEMP/SEL) A 3 4'Field' A 3 28'Select/Omit Value' A 3 16'S/O' A 3 21'COMP'
DISPY RPG
H OPTIMIZE(*NONE) OPTION(*NODEBUGIO) H DFTACTGRP(*NO) ACTGRP(*CALLER) //*************************************************************** // // PROGRAM ID : DISPY // Description: DISPLAY A FILES FIELDS FOR SELECTION // needs files KF FFD to compile use following commands // DSPFD (&LIB/&FILE) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KF) // DSPFFD FILE(&LIB/&FILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) //*************************************************************** // MODIFICATIONS: // MOD SR DATE MODIFICATION SUMMARY // //*************************************************************** // FKF IF E DISK FFFD UF E DISK FINPUT IF F32766 2000AIDISK KEYLOC(1) F INFDS(INFDS) FDISPYF CF E WORKSTN F SFILE(S01:RS01) F INFDS(SFINF) // // // SCREEN LEVELS D @SCN S 6 DIM(50) D @NSCN S 6 D @LV S 5 0 D @ERR S LIKE(@TRUE) D @FILE S 10A INZ('DISPY ') D WRKSWS S 1 D I S 4B 0 D @TRUE S 1A INZ('1') D @FALSE S 1A INZ('0') D @OK S LIKE(@TRUE) D @LOOP S LIKE(@TRUE) // D RS01 S 4S 0 // // PARMS FOR SFL LOOPING D SFC01 S LIKE(RS01) // Program Status D SDS D PGM 1 10 D WSID 244 253 D USER 254 263 // // D SFINF DS D RRRN 376 377B 0 D SRN 378 379B 0 // D FLD S 10 DIM(9000) D KEY S 10 DIM(99) D INFDS DS D FILE 83 92 D LIB 93 102 D MBR 129 138 D RCDL 125 126B 0 D RCDS 156 159B 0 D ACCTP 160 160 D DS D WHCOLD 1 60 D WHCHD1 1 20 D WHCHD2 21 40 D WHCHD3 41 60 D DS D POSN 1 10 D P1 1 10 DIM(10) D POSNN 11 20 D P2 11 20 DIM(10) * // MESSAGE DATA D @DTA1 DS 80 D @DTA2 DS 500 // D MAIN PR D @S01BLD PR D @S01PRC PR D @S01PRS PR D D @R9999 PR D @OPADJ PR 2A D OPT 2A * DDISPY PR D 1 D 1 D 4 D 1 D 1 D 5 DDISPY PI D ALL 1 D RTN 1 D KEYLNG 4 D ACCP 1 D QRY 1 D RCDLN 5 * D KEYLN S 4S 0 D RCDLEN S 5S 0 *------------------------------------------------------------------- * QMHRTVM API (Retrieve Message text) *------------------------------------------------------------------- D RtvMsgTxt PR 1024 D RMsgId 7 Const D RMsgFle 10 Const D RMsgLib 10 Const D RMsgLvl 1 Const D GETROWCOL PR D 10A const D 10A const D 10A const D 32A const D 3P 0 D 3P 0 D SysDate PR 8S 0 D SysTime PR 6S 0 D DayOfWeek PR 10I 0 D D value datfmt(*iso) // Message file names D cMsgLib C Const('*LIBL ') D cMsgF1 C Const('MSGF1 ') D cMsgF2 C Const('MSGF2 ') D cMsgLvl1 C Const('1') D cMsgLvl2 C Const('2') * IINPUT NS 01 I 1 256 D /FREE *INLR = *ON; MAIN(); //--------------*INZSR-------------------------------// BEGSR *INZSR; // Set the TOP level (Exit if user backs up to here) @LV = 1; @SCN(@LV) = '*END '; // Set the Initial Screen to display @LV = @LV + 1; @SCN(@LV) = 'S01BLD '; // DUMMY I/O TO GET NUMBER OF RECORDS IN FILE READ INPUT; // SFL IS NOT LOADED // READ THE LIST OF KEY FIELDS IN THE FILE SO THAT WE CAN LATER MARK THEM ACCP = ACCTP; I = 0; DOW @LOOP = @LOOP; READ QWHFDACP; IF %EOF; LEAVE; ENDIF; I = I + 1; KEY(I) = APKEYF; ENDDO; ENDSR; /END-FREE //###################################################// //************************************************************* P MAIN B D MAIN PI D I S 4B 0 /FREE EXSR @INZSR; // // THIS IS THE CONTROLLING LOOP TO DRIVE THE NEXT PANEL TO DISPLAY DOW @LOOP = @LOOP; // GET THE SCREEN NAME FROM THE SCREEN STACK ARRAY @NSCN = @SCN(@LV); SELECT; // SELECT FIELDS FOR DISPLAY // SFL TO SELECT THE FILE FIELDS WHEN @NSCN = 'S01BLD'; @S01BLD(); WHEN @NSCN = 'S01PRC'; @S01PRC(); WHEN @NSCN = 'S01PRS'; @S01PRS(); OTHER; // CATCH ALL (NEVER USED) @R9999(); LEAVE; ENDSL; // CF3 EXIT IF *IN03 = *ON; LEAVE; ENDIF; // CF12 PREVIOUS IF *IN12 = *ON; *IN12 = *OFF; @LV = @LV -1; @NSCN = @SCN(@LV); ENDIF; // Backed out to last level, Exit IF @NSCN = '*END'; LEAVE; ENDIF; ENDDO; KEYLNG = %EDITC(KEYLN:'X'); RETURN; //--------------*INZSR-------------------------------// BEGSR @INZSR; @NSCN = *BLANK; RCDLEN = RCDL; RCDLN = %CHAR(RCDLEN); // CLEAR FIELD SELECTIONS IF RTN = '2'; SETLL 1 QWHDRFFD; DOW @LOOP = @LOOP; READ QWHDRFFD ; IF %EOF; LEAVE; ENDIF; WHFIOB = ' '; UPDATE QWHDRFFD; ENDDO; // SET FILE I/O TO FIRST RCD IN FILE SETLL 1 QWHDRFFD; RTN = '0'; ELSE; CHAIN 1 QWHDRFFD; SETLL 1 QWHDRFFD; ENDIF; ENDSR; //-ENDSR---*INZSR-------------------------------// /END-FREE P MAIN E //###################################################// //###################################################// //###################################################// /space 3 P @S01BLD B D @S01BLD PI D SZ DS 6 D LEN1 1 1 D LEN2 2 3 D LEN3 1 3 D COMA 4 4 D DEC1 5 5 D DEC2 5 6 D DS D K 1 3 0 D KA 2 3 // Build/Rebuild the subfile /FREE EXSR @INZSR; EXSR BLD; // SFL IS BUILT, PROCESS THE SFL CONTROL @LV = @LV + 1; @SCN(@LV) = 'S01PRC ' ; RETURN ; //-------------- BLD -------------------------------// BEGSR BLD; EXSR CLR; DOW @LOOP = @LOOP; READ QWHDRFFD; IF %EOF; LEAVE; ENDIF; EXSR MOV; // FLAG THE KEY FIELDS K = %LOOKUP(WHFLDE :KEY); WHDFTL = K ; UPDATE QWHDRFFD; RS01 = RS01 + 1; WRITE S01; ENDDO; // Position to TOP of subfile SRS01 = 1; SFC01 = RS01; ENDSR; //-------------- CLR -------------------------------// BEGSR CLR; I = 0; CLEAR FLD; KEYLN = 0; *IN51 = *OFF; *IN52 = *OFF; *IN53 = *ON; WRITE C01; *IN53 = *OFF; RS01 = 0 ; SFC01 = 0 ; S01OPT= *BLANK; ENDSR; //-------------- MOV -------------------------------// BEGSR MOV; // Load the subfile record S01OPT = WHFIOB ; S01WHFLDB = WHFLDB; S01WHFLDT = WHFLDT; S01WHFLD = WHFLDE ; S01SFLD = WHFLDE ; S01FROM = WHFOBO; S01TO = WHFLDB + WHFOBO -1 ; // KEY FIELDS S01KEYFLD = ' '; K = %LOOKUP(WHFLDE :KEY); IF K <> 0; S01KEYFLD = KA; IF K < 10; %SUBST(S01KEYFLD:1:1) = 'K'; ENDIF; KEYLN = KEYLN + WHFLDB; ENDIF; // FORMAT THE FIELD LENGTH S01SIZE = ' '; SZ = ' '; IF WHFLDD = 0; LEN3 = %SUBST(%EDITC(WHFLDB:'Z'):3:3); ELSE; LEN2 = %EDITC(WHFLDD:'Z') ; COMA = ','; IF WHFLDP > 9; DEC2 = %CHAR(WHFLDP); ELSE; DEC1 = %CHAR(WHFLDP); ENDIF; ENDIF; IF LEN1 = '0'; LEN1 = ' '; ENDIF; S01SIZE = SZ; S01DESC = WHFTXT; IF S01DESC= ' '; S01DESC = WHCOLD ; ENDIF; I = I + 1; FLD(I) = S01WHFLD; ENDSR; //--------------*INZSR-------------------------------// BEGSR @INZSR; @NSCN = *BLANK; ENDSR; /END-FREE P @S01BLD E //###################################################// //###################################################// /space 3 P @S01PRC B D @S01PRC PI // // D WRKRC S 4S 0 D C01CHK S LIKE(C01POSN) /FREE EXSR @INZSR; WRITE R01; // DOW @LOOP = @LOOP; // // Write SFL Control IF SFC01 > 0; *IN51 = *ON; ENDIF; *IN52 = *ON; EXFMT C01; // Setoff errors *IN89 = *OFF; // // Exit and Previous Screen IF *IN03 = *ON; RTN = '1'; LEAVE; ENDIF; IF *IN12 = *ON; @LV = @LV -1; LEAVE; ENDIF; // Set up for qry selection and exit IF *IN06 = *ON; *IN03 = *ON; QRY = '1'; LEAVE; ENDIF; // POSITION IF C01POSN <> ' '; EXSR POS; ITER; ENDIF; // Process the subfile @LV = @LV + 1; @SCN(@LV) = 'S01PRS'; LEAVE; ENDDO; // RETURN; /space 3 //--------------POS -------------------------------// BEGSR POS; FOR WRKRC = 1 TO SFC01; CHAIN WRKRC S01; IF NOT %FOUND; LEAVE; ENDIF; C01CHK = %SUBST(S01WHFLD :1 : %LEN(%TRIM(C01POSN))); IF (C01POSN = C01CHK ); SRS01 = WRKRC; LEAVE; ENDIF; ENDFOR; ENDSR; //--------------*INZSR-------------------------------// BEGSR @INZSR; @NSCN = *BLANK; C01FILE = FILE; C01LIB = LIB; C01MBR = MBR; C01RCDL = RCDL; C01ACCTP = ACCTP; C01WHTEXT = WHTEXT; C01RCORDS = RCDS; C01POSN = ' ' ; C01WHNAME = WHNAME; ENDSR; /END-FREE P @S01PRC E //###################################################// //###################################################// //###################################################// /space 3 P @S01PRS B D @S01PRS PI // // D WRKRC S 4S 0 D FX S 5S 0 /FREE EXSR @INZSR; // Process the subfile EXSR SFL; *IN03 = '1'; RETURN; //-------------- SFL -------------------------------// BEGSR SFL; // Process the subfile FOR WRKRC = 1 TO SFC01+1; CHAIN WRKRC S01; IF NOT %FOUND; // Finished with the subfile // RETURN TO REBUILD LEVEL @LV = @LV -2; LEAVE; ENDIF; // RIGHT ADJUST OPTION S01OPT = @OPADJ(S01OPT); // UPDATE SELECTIONS EXSR UPD; ENDFOR; ENDSR; //---------------------------------------------------// //--------------UPD ---------------------------------// BEGSR UPD; // UPDATE FIELD NAMES AND SELECT FLAG FX = %LOOKUP(S01SFLD :FLD); CHAIN FX QWHDRFFD; WHFLDE = S01WHFLD; IF @OPADJ(S01OPT) = ' S' OR @OPADJ(S01OPT) = ' O'; ALL = %TRIM(S01OPT); WHFIOB = %TRIM(S01OPT); ENDIF; IF @OPADJ(S01OPT) = ' '; WHFIOB = ' '; ENDIF; UPDATE QWHDRFFD; ENDSR; //--------------*INZSR-------------------------------// BEGSR @INZSR; ALL = '1'; @NSCN = *BLANK; ENDSR; /END-FREE P @S01PRS E //###################################################// //###################################################// //###################################################// P @R9999 B // Invalid Panel D @R9999 PI P @R9999 E /space 3 //###################################################// //###################################################// //###################################################// P @OPADJ B // RIGHT ADJ OPTION , zero suppress D @OPADJ PI 2A D OPT 2A /FREE EVALR OPT = %trimr(OPT); If %SubSt(OPT:1:1) = '0'; OPT = ' ' + %SubSt(OPT:2:1); EndIf; RETURN OPT; /END-FREE P @OPADJ E //###################################################// //###################################################// //###################################################// P RtvMsgTxt B //************************************************************************ // API Call: QMHRTVM Retrieve Message text //************************************************************************ // USAGE // MsgTxt = RtvMsgTxt('MSG0001':cMsgF3:cMsgLib:cMsgLvl1); D RtvMsgTxt PI 1024 D RMsgId 7 Const D RMsgFle 10 Const D RMsgLib 10 Const D RMsgLvl 1 Const // Retrieve Message Description API Prototype D Get_Message PR ExtPgm('QMHRTVM') D 4000 Options(*VarSize) D 10I 0 Const D 8 Const D 7 D 20 Const D 32765 Options(*VarSize) D 10I 0 Const D 10 Const D 10 Const D 8192 Options(*VarSize) D 10 D 9B 0 D 9B 0 // Define Variables for QMHRTVM API call: // -------------------------------------- // Return variables D MessageInfo DS 4000 D Data 1 4000 D OSMSG 65 68B 0 D LMsgR 69 72B 0 D LMsgA 73 76B 0 D OSMSGH 77 80B 0 D LMsgHR 81 84B 0 D LMsgHA 85 88B 0 // Required input variables D MessageLen S 10I 0 D MessageForm S 8 D MessageIden S 7 D MessageFile S 20 D Replacement S 32765 D ReplaceLen S 10I 0 D ReplaceSub S 10 D ReturnCtl S 10 D RetrieveOpt S 10 D ConvToCCSID S 9B 0 D ReplDtaCCSID S 9B 0 D Return_Text S 1024 D ErrorCode DS Qualified D BytesProv 4B 0 Inz(0) D BytesAvail 8B 0 Inz(0) D ExceptionId 7 D Reserved 1 D ExceptionDta 512 /FREE // Load API parameter fields MessageInfo = *blanks; MessageLen = 4000; MessageForm = 'RTVM0300'; MessageIden = RMsgId; MessageFile = RMsgFle + RMsgLib; Replacement = *blanks; ReplaceLen = %Len(Replacement); ReplaceSub = '*YES'; ReturnCtl = '*YES'; RetrieveOpt = '*MSGID'; ConvToCCSID = 0; ReplDtaCCSID = 0; // Retrieve message description Get_Message(MessageInfo : MessageLen : MessageForm : MessageIden : MessageFile : Replacement : ReplaceLen : ReplaceSub : ReturnCtl : ErrorCode : RetrieveOpt : ConvToCCSID : ReplDtaCCSID); // Process Return variables Return_Text = *blanks; // If no errors, determine the correct portion of the message text If ErrorCode.BytesProv = 0; Select; When RMsgLvl = '1'; Return_Text = %Subst(data:OSMSG+1:LMsgA); // Msg Lvl 1 When RMsgLvl = '2'; Return_Text = %Subst(data:OSMSGH+1:LMsgHA); // Msg Lvl 2 EndSl; Else; Return_Text = 'Get_Message failed.'; EndIf; // Return to calling point Return Return_Text; /END-FREE P E //###################################################// //###################################################// //###################################################// P GETROWCOL B * * Retreive a DSPF FIELD Row and Col * Used for Setting CSRLOC for cursor positioning * USAGE * GETROWCOL (FILE :'*LIBL' : FORMAT : FLDNAM : ROW : COL) * D GETROWCOL PR D schFile 10A const D schLib 10A const D schFormat 10A const D schString 32A const D rtnROW 3P 0 D RtnCOL 3P 0 D GETROWCOL PI D schFile 10A const D schLib 10A const D schFormat 10A const D schString 32A const D rtnROW 3P 0 D RtnCOL 3P 0 D QUSCRTUS PR ExtPgm('QUSCRTUS') D UserSpace 20A CONST D ExtAttrib 10A CONST D InitialSize 10I 0 CONST D InitialVal 1A CONST D PublicAuth 10A CONST D Text 50A CONST D Replace 10A CONST options(*nopass) D ErrorCode 32767A options(*varsize:*nopass) D QUSPTRUS PR ExtPgm('QUSPTRUS') D UserSpace 20A CONST D Pointer * D QUSDLTUS PR ExtPgm('QUSDLTUS') D UserSpace 20A CONST D ErrorCode 32767A options(*varsize) D QUSLFLD PR ExtPgm('QUSLFLD') D UsrSpc 20A const D Format 8A const D QualFile 20A const D RcdFmt 10A const D UseOvrd 1A const D ErrorCode 32767A options(*nopass:*varsize) D ErrorCode ds qualified D BytesProv 10I 0 inz(0) D BytesAvail 10I 0 inz(0) D ListHeader ds based(p_ListHeader) d ListOffset 10I 0 overlay(ListHeader:125) d EntryCount 10I 0 overlay(ListHeader:133) d EntrySize 10I 0 overlay(ListHeader:137) D Field ds based(p_Field) D qualified D Name 10a D FILLER 438a d DspRow 10i 0 d DspCol 10i 0 D TEMPSPC C 'GETROWCOL QTEMP' D x s 10I 0 /free rtnrow = 999; rtnrow = 999; // -------------------------------------------------- // Delete the user space if it exists (ignore errors) ErrorCode.BytesProv = %size(ErrorCode); QUSDLTUS( TEMPSPC: ErrorCode ); ErrorCode.BytesProv = 0; // -------------------------------------------------- // Create a new 128k user space QUSCRTUS( TEMPSPC : 'SCHTEXT' : 128 * 1024 : x'00' : '*EXCLUDE' : 'List of fields in file' : '*NO' : ErrorCode ); // -------------------------------------------------- // Dump list of fields in file to user space // Invaid data is ignored an 999 returned for row and col monitor; QUSLFLD( TEMPSPC : 'FLDL0100' : SchFile + SchLib : SchFormat : *OFF : ErrorCode ); on-Error; RETURN; EndMon; // -------------------------------------------------- // Get a pointer to the user space QUSPTRUS( TEMPSPC: p_ListHeader ); // -------------------------------------------------- // Loop through all fields in space, to get the field we need for x = 0 to (EntryCount - 1); p_Field = p_ListHeader + ListOffset + (EntrySize * x); if Field.Name = schString; rtnRow = Field.DspRow; rtnCol = Field.DspCol; leave; endif; endfor; // -------------------------------------------------- // Delete temp user space & end QUSDLTUS( TEMPSPC: ErrorCode ); return; /end-free P E
DISPYF RPG
A*%%TS SD 20101203 131649 KOLMANNF REL-V5R4M0 5722-WDS A* 90/01/08 12:52:36 REL-R01M02 5728-PW1 A* 16:33:07 REL-R08M00 5714-UT1 A*%%EC A DSPSIZ(24 80 *DS3) A REF(*LIBL/QADSPFFD) A PRINT A CA03(03 'End of job') A CA12(12 'Previous') A CA04(04 'Add FIELDS') A CA05(05 'Attr changes') A CF06(06 'Field Select') A CA07(07 'Name changes') A***** A* 15:04:39 REL-R08M00 5714-UT1 A R S01 SFL A*%%TS SD 20101203 131649 KOLMANNF REL-V5R4M0 5722-WDS A 40 SFLNXTCHG A S01OPT 2A B 7 2 A S01KEYFLD 2A O 7 5DSPATR(HI) A S01WHFLD R B 7 8REFFLD(WHFLDI) A 23 DSPATR(HI) A N23 DSPATR(PR) A S01WHFLDB R B 7 19REFFLD(WHFLDB) A EDTCDE(Z) A 25 DSPATR(HI) A N25 DSPATR(PR) A S01SIZE 6A O 7 25 A S01FROM 4Y 0O 7 32EDTCDE(Z) A S01TO 4Y 0O 7 37EDTCDE(Z) A S01DESC 35A O 7 44 A S01WHFLDT R B 7 42REFFLD(WHFLDT) A 25 DSPATR(HI) A N25 DSPATR(PR) A S01SFLD R H REFFLD(WHFLDI) A***** A* A R C01 SFLCTL(S01) A*%%TS SD 20101203 131649 KOLMANNF REL-V5R4M0 5722-WDS A SFLSIZ(0015) A SFLPAG(0014) A 88 CSRLOC(ROW01 COL01) A OVERLAY A TEXT('WORK WITH FIELDS') A 51 SFLDSP A 52 SFLDSPCTL A 53 SFLCLR A 99 SFLEND A SRS01 4S 0H SFLRCDNBR(CURSOR) A* A 89 C01MSG 79 M A ROW01 3S 0H A COL01 3S 0H A 1 3'File' A C01FILE 10A O 1 8DSPATR(HI) A 1 20'Lib' A C01LIB 10A O 1 24DSPATR(HI) A 1 37'Mbr' A C01MBR 10A O 1 41DSPATR(HI) A 1 53'Rcdlen' A C01RCDL 4S 0O 1 60DSPATR(HI) A 1 66'Access' A C01ACCTP 1A O 1 73DSPATR(HI) A 2 3'Text' A C01WHTEXT R O 2 9REFFLD(WHTEXT) A DSPATR(HI) A 2 60'#Records' A C01RCORDS 7Y 0O 2 69DSPATR(HI) A EDTCDE(Z) A C01POSN 10A I 3 7 A 4 2'Select/Omit (S/O) fields for displ- A ay.(Default *ALL)' A 5 11'Use Select Or Omit,not Select with- A Omit' A 6 8'Name Bytes Size From To T- A p Description' A 4 54'Format' A C01WHNAME R O 4 61REFFLD(QWHDRFFD/WHNAME) A DSPATR(HI) A R R01 A 23 2'F3-Exit F6-Data Sel'
DISPX DSPF
A DSPSIZ(24 80 *DS3) A PRINT A CF02(02 'return') A CF03(01 'exit') A R SLT A OVERLAY A 1 2'Qryslt:' A QSLT 1509A B 1 12CHECK(LC) A 20 1'F2-Return ' A R SLTR SFL A SFLMSGRCD(21) A MSGKEY SFLMSGKEY A PGMQ SFLPGMQ A R SLTC SFLCTL(SLTR ) A OVERLAY A SFLSIZ(50) SFLPAG(3) A N20 SFLEND A N20 SFLDSP A N20 SFLDSPCTL A N20 SFLINZ A 20 SFLCLR A PGMQ SFLPGMQ
FFDL01 LF
A R QWHDRFFD PFILE(FFD) K WHFILE
COMPILE CL
/* COMPILE OBJECTS */ /* CRTBNDCL PGM(KOLMANN/COMPILE) SRCFILE(KOLMANN/UDDSSRC) */ /* SRCMBR(COMPILE) OUTPUT(*NONE) REPLACE(*YES) */ /* call compile ('KOLMANN' 'UDDSSRC') */ PGM (&LIB &SRCF) DCL &LIB *CHAR 10 DCL &SRCF *CHAR 10 CRTDTAARA DTAARA(&LIB/UDDSSRC) TYPE(*CHAR) LEN(10) + VALUE(&SRCF) TEXT('SOURCE LIBRARY FOR UDDS PROGRAMS') MONMSG CPF0000 dltf qtemp/afile monmsg cpf0000 CRTPF FILE(QTEMP/AFILE) RCDLEN(80) OPTION(*NOLIST) CRTDSPF FILE(&LIB/DISPF) SRCFILE(&LIB/&SRCF) + SRCMBR(DISPF) OPTION(*NOLIST *NOSRC) + REPLACE(*YES) DSPFFD FILE(QTEMP/AFILE) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFD) DLTF FILE(QTEMP/FFDL01) MONMSG CPF0000 CRTLF FILE(QTEMP/FFDL01) SRCFILE(&LIB/&SRCF) SRCMBR(FFDL01) + OPTION(*NOSRC *NOLIST) DSPFFD FILE(QTEMP/FFD) OUTPUT(*OUTFILE) OUTFILE(QTEMP/FFFFD) DSPFD (QTEMP/FFD ) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/KFFFD ) OVRDBF FILE(KF) TOFILE(QTEMP/KFFFD) CRTBNDCL PGM(&LIB/DISF) SRCFILE(&LIB/&SRCF) + DBGVIEW(*SOURCE) SRCMBR(DISF) OUTPUT(*NONE) REPLACE(*YES) CRTBNDCL PGM(&LIB/DISV) SRCFILE(&LIB/&SRCF) + DBGVIEW(*SOURCE) SRCMBR(DISV) OUTPUT(*NONE) REPLACE(*YES) CRTBNDRPG PGM(&LIB/DISPY) SRCFILE(&LIB/&SRCF) + SRCMBR(DISPY) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES) DLTF FILE(QTEMP/REL) MONMSG CPF0000 DLTF FILE(QTEMP/SEL) MONMSG CPF0000 DLTF FILE(QTEMP/DBR) MONMSG CPF0000 DSPFD FILE(QTEMP/FFD) TYPE(*ACCPTH) + OUTPUT(*OUTFILE) OUTFILE(QTEMP/REL) OUTMBR(*FIRST *ADD) DSPFD FILE(QTEMP/FFDL01) TYPE(*SELECT) OUTPUT(*OUTFILE) OUTFILE(QTEMP/SEL) CRTDSPF FILE(&LIB/DISPRF) SRCFILE(&LIB/&SRCF) + SRCMBR(DISPRF) OPTION(*NOLIST *NOSRC) + REPLACE(*YES) DSPDBR FILE(QTEMP/FFD) OUTPUT(*OUTFILE) + OUTFILE(QTEMP/DBR) OUTMBR(*FIRST *REPLACE) DLTF FILE(QTEMP/ACC) MONMSG CPF0000 DSPFD FILE(QTEMP/FFDL01) TYPE(*ACCPTH) OUTPUT(*OUTFILE) OUTFILE(QTEMP/ACC) CRTBNDRPG PGM(&LIB/DISP) SRCFILE(&LIB/&SRCF) + SRCMBR(DISP) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES) CRTBNDRPG PGM(&LIB/DISP1) SRCFILE(&LIB/&SRCF) + SRCMBR(DISP1) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES) CRTBNDRPG PGM(&LIB/DISP2) SRCFILE(&LIB/&SRCF) + SRCMBR(DISP2) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES) CRTBNDRPG PGM(&LIB/DUSP) SRCFILE(&LIB/&SRCF) + SRCMBR(DUSP) DBGVIEW(*SOURCE) REPLACE(*YES) CRTBNDRPG PGM(&LIB/DUSP1) SRCFILE(&LIB/&SRCF) + SRCMBR(DUSP1) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES) CRTBNDRPG PGM(&LIB/DUSP2) SRCFILE(&LIB/&SRCF) + SRCMBR(DUSP2) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES) CRTBNDCL PGM(&LIB/DIS) SRCFILE(&LIB/&SRCF) + DBGVIEW(*SOURCE) SRCMBR(DIS) OUTPUT(*NONE) REPLACE(*YES) CRTBNDCL PGM(&LIB/DIS3) SRCFILE(&LIB/&SRCF) + DBGVIEW(*SOURCE) SRCMBR(DIS3) OUTPUT(*NONE) REPLACE(*YES) CRTBNDCL PGM(&LIB/DIS4) SRCFILE(&LIB/&SRCF) + DBGVIEW(*SOURCE) SRCMBR(DIS4) OUTPUT(*NONE) REPLACE(*YES) CRTBNDCL PGM(&LIB/DISBIN) SRCFILE(&LIB/&SRCF) + DBGVIEW(*SOURCE) SRCMBR(DISBIN) OUTPUT(*NONE) REPLACE(*YES) CRTBNDRPG PGM(&LIB/DISPR) SRCFILE(&LIB/&SRCF) + SRCMBR(DISPR) DBGVIEW(*SOURCE) OUTPUT(*NONE) REPLACE(*YES) CRTCMD CMD(&LIB/DSPFL) PGM(*LIBL/DIS) SRCFILE(&LIB/&SRCF) + SRCMBR(DSPFL) VLDCKR(DISV) CRTDSPF FILE(&LIB/DISPX) SRCFILE(&LIB/&SRCF) + SRCMBR(DISPX) OPTION(*NOLIST *NOSRC) + REPLACE(*YES) CRTBNDCL PGM(&LIB/DIS1) SRCFILE(&LIB/&SRCF) + DBGVIEW(*SOURCE) SRCMBR(DIS1) OUTPUT(*NONE) REPLACE(*YES) ENDPGM
TESTPF PF
A R TESTR A ACTIV 1A TEXT('Active flag (0 - inactive, 1') A CMPNO 3P TEXT('Company number ') A PLTNO 2P TEXT('Plant number ') A PRDNO 15A TEXT('Product number ') A OPBAL 13P 3 TEXT('Opening balance - this perio') A SERVU 5S 2 TEXT('Service level based on units') A QTY 5B 2 TEXT('QTY') A QTYF 17F 4 FLTPCN(*DOUBLE) A CCYYMMDD L TEXT('DATE') A HHMMSS T TEXT('TIME') A DATTIM Z TEXT('DATE TIME') A VTEXT 100A VARLEN A TEXT('VARIABLE TEXT') A DESCP 30A TEXT('Product description or name ') A K ACTIV A K CMPNO A K PRDNO A K OPBAL A K SERVU
TESTPF1 PF
A R TESTR A ACTIV 1A TEXT('Active flag (0 - inactive, 1') A CMPNO 3P TEXT('Company number ') A PLTNO 2P TEXT('Plant number ') A PRDNO 15A TEXT('Product number ') A OPBAL 13P 3 TEXT('Opening balance - this perio') A SERVU 5S 2 TEXT('Service level based on units') A QTY 5B 2 TEXT('QTY') A QTYF 17F 4 FLTPCN(*DOUBLE) A CCYYMMDD L TEXT('DATE') A HHMMSS T TEXT('TIME') A DATTIM Z TEXT('DATE TIME') A VTEXT 100A VARLEN A TEXT('VARIABLE TEXT') A DESCP 30A TEXT('Product description or name ') A TXT1 500A TEXT('TXT1 ') A TXT2 500A TEXT('TXT2 ') A TXT3 500A TEXT('TXT3 ') A TXT4 500A TEXT('TXT4 ') A K ACTIV A K CMPNO A K PRDNO A K OPBAL A K SERVU
TESTPF2 PF
A R TESTR A ACTIV 1A TEXT('Active flag (0 - inactive, 1') A CMPNO 3P TEXT('Company number ') A PLTNO 2P TEXT('Plant number ') A PRDNO 15A TEXT('Product number ') A OPBAL 13P 3 TEXT('Opening balance - this perio') A SERVU 5S 2 TEXT('Service level based on units') A QTY 5B 2 TEXT('QTY') A QTYF 17F 4 FLTPCN(*DOUBLE) A CCYYMMDD L TEXT('DATE') A HHMMSS T TEXT('TIME') A DATTIM Z TEXT('DATE TIME') A VTEXT 100A VARLEN A TEXT('VARIABLE TEXT') A DESCP 30A TEXT('Product description or name ') A TXT1 500A TEXT('TXT1 ') A TXT2 500A TEXT('TXT2 ') A TXT3 500A TEXT('TXT3 ') A TXT4 500A TEXT('TXT4 ') A TXT5 500A TEXT('TXT5 ') A TXT6 500A TEXT('TXT6 ') A TXT7 500A TEXT('TXT7 ') A TXT8 500A TEXT('TXT8 ') A K ACTIV A K CMPNO A K PRDNO A K OPBAL A K SERVU