/*% NOCOMMENT REXX */ /* Morten Boegh http://www.rxs.se */ RX_VERSION = '2022-10-26' /* 2003-06-19: RX_EXPLIST er input til RXSPGM. RXSPGM tilføjer fundne variable i enden af RX_EXPLIST (indebærer at uservariable kommer til at stå til sidst i RX_EXPLIST, hvor de hidtil har stået først) 2003-06-20 rx_maxlvl forsøgt for at få imbed til at undgå at køre derudaf ved iteration 2003-06-23 I batch giver steppet nu den anførte RC! 2003-08-22 )TEXT )ENDTEXT lagt ind 2003-08-27 Eksekvering af macroer: DCB tages fra edit-screen 2003-09-17 SQL varchar > 255 char: kræver opdeling af value 2004-01-21 STRIP,T i sql: foranstillede blanke bevares 2004-01-24 Fejlmeld invalide vars som står i explist 2004-01-24 PROMPT-vindue placeres random på skærmen 2004-01-24 LOOP.._WORD rettet så nedarvning af word.x virker 2004-01-31 LOOP.._WORD rettet tilbage 2004-04-22 TBDISPL + panel programmeret om 2004-06-24 Problemet med skift af db2-system: DISCONNECT indført i forbindelse med iteration ved F3 i prompt 2004-06-28 Ved IMBED restore's prim input efter imbed - ellers vil SKRIV_UD_DIR i main begynde at udskrive linier fra imbed'ed source 2004-10-15 ROWID og BLOB processes 2004-10-15 Håndtering af db2-values ændret 2004-11-04 MAKE_GLOBAL tilføjet i bunden 2004-11-18 MEMBER NOT FOUND giver nu en notrigger exception 2004-11-18 DROP af uservariable ved iteration udføres ikke.... gav massive problemer i visse situationer.. 2004-11-19 NOTRIGGER kodning indlagt vedr. func='mbr' 2004-11-26 PROMPTSOURCE 'U' overspringer opdatering af tabel 2004-11-30 NAMESPACE: nulstil skal ikke udføres i sidste loop 2004-12-03 EDIT_SCREEN: Skal genskabes ved iteration i prompt 2004-12-18 Brug af ( og ) i parmspace gjort til variabel (og XML bruger fremover {} som parantes-tegn) 2004-12-30 Som macro kan nu anføres CC CC for range 2005-01-05 I sek input kan COBOL kun være type hvis=sidste qualifier 2005-01-12 WORD. nedarves ikke. WORD. dannes kun hvis i source Ej heller UNIT. 2005-01-14 DCL optimeret / omprogrammeret 2005-01-25 ';' sidst i SQL accepteres (dvs fjernes) 2005-03-02 INTO i SQL fejlmeldes 2005-05-22 )text blok understøtter address 2005-06-07 XML ændret vedr. attributter DROPQUEUE og MAKE_GLOBAL uden CALL in='ikke-eksisterende-dsn' medfører )notrigger 2005-06-15 xml attributter gøres global 2005-06-22 LRECL 4004 i uddata hvis uddata bredere end inddata 2005-06-23 SORTED_DESC indført 2005-07-15 WORD. og UNIT. nedarves, dog ikke i )IMBED -jf 2005-01-12 2005-08-15 WORD. og UNIT. nedarves, også i )IMBED 2005-09-08 //RXSPGM DD * kan i batch bruges til at anføre RXSPGM 2005-09-13 OUTFUNC='SUB' STDOUT FÅR LRECL = 80 2005-11-17 Host-vars displayes ved SQL-fejl 2005-11-20 MQ-indlagt 2005-12-05 RXSDO program med lrecl 8004 i ind og ud 2006-01-09 Syntaxfejl giver rc=8 i batch 2006-01-20 //"PROMPT" til parm i JCL (evt //PRMT000) 2006-01-30 //PARM"prompt" i JCL er også en mulighed 2006-02-01 VIA RX_OUTFUNC_DONE: leave iteration hvis uddata ej vist 2006-02-07 INTO i SQL fejlmeldes ikke 2006-02-15 Hvis OUTFILE ikke er allokeret i batch, allokeres den 2006-02-20 MQDRAIN(KEY) isf. MQGET(KEY) 2006-02-28 MQGET og MQPUT: max 3000000 byte 2006-04-10 MQSYST -> MQ i en fejlmeddelelse 2006-01-01 MQ: PUTDATE mfl nye variable 2006-06-27 HOSTVARS som er null erstattes med NULL i SQL (brug af null-indikator vedr hostvars helt forladt) 2006-07-07: hvis cobol num ikke numerisk læses hele sek_input 2006-07-10: Hvis OUT indeholder COBOL i navn, dannes med cob-lin-num 2006-07-13: Hvis OUT indeholder COBOL i navn: SLETTET IGEN 2006-08-11: XML: Hvis input bredere end 8000, så deles op 2006-08-24: promptsource = 'p': programmeret værdi kun første gang 2006-08-28: Nu nedarves unit. og word korrekt 2006-09-01: Fejl vedr opsætning af prompt - fejl i ISPF? / rettet 2006-09-14: promptsource: U: første gang program øvrige user P: altid program 2006-10-09 NUMERIC DIGITS 15 2007-01-04 LISTVARS aktiveres også i batch og som macro 2007-01-17 SYNTAXFEJL giver kun SAY i batch 2007-01-25 Hvis ZERRMSG ikke er defineret 2007-01-29 RXSLIB istedet for ISPRLIB. RXSIN udgår 2007-02-02 SQL_DONE rettet: der kvitteres nu korrekt for commit 2007-02-15 zwinttl ikke global, zedlmsg zedsmsg ej i listvars 2007-03-01 LRECL 32756 i uddata hvis uddata bredere end inddata 2007-03-06 Fejlmeld invalid host-variabel navn 2007-03-21 Håndter XML-værdier på 500.000 byte 2007-04-27 NAMESPACE_1 og NAMESPACE_2 kan anføres ved NAMESPACE som værdier for '(' og ')' 2007-06-13 workstation connect (WSCON + FILEXFER etc) 2007-06-20 ISPF error uden message: RC skrives på skærmen 2007-07-09 wscon: hvis skrevet individ er over 8004, deles op 2007-08-09 SQL: Ved CALL (af stored proc) sker ingen analyse af hostvars inden kaldet udføres Indebærer at '?' ikke betegner null ved CALLs 2007-08-16 execio skal give rc > 4 før der er et problem 2007-08-28 alloc_do gjort ens i batch og forgrund aht. pcxfer - uholdbart: flere samtidige batch vil så kollidere CODEPAGE og CHARSET i wscon aht batch - anføres i default 2007-09-18 strip fjernet i indlæsning af sek_input 2007-09-21 alloc_do rettet. filexfer allokerer specielt således at allokering i batch og macro er forskellig 2007-09-27 LMPUT: NOBSCAN option tilføjet: undgå STRIP ved skrivning 2007-09-28 udskriv_sub rettet så PC-filer skrives først 2007-10-03 rettet i betingelser for at danne cobol-uddata (igen) 2007-10-04 Ved PC uddata reageres kun på outfunc='binary' 2007-10-23 Fejl i allokering af fil til PC kommunikation 2007-12-18 exit 8 -> exit 16 2007-12-19 STRIP,T af læste alfafelter fra db2 udelades 2008-01-11 INFILE tilføjet som input 2008-01-28 Fejlmeldning af quoute i 'out' Blank linie i namespace terminerer ikke række 2008-01-30 Fejlmelding af qoute i 'in' 2008-02-01 I batch gives RC=4 hvis en uddatafil er trunkeret 2008-07-01 SQL kald "SET .." anses ikke som opdaterende aht. meddelelse om COMMIT ok 2008-07-10 Bedre fejlmeddelelse ved SQL ROLLBACK 2008-08-19 Hvis uddata COBOL og hvis dannet med linienumre så dannes ikke linienumre en gang til! 2008-08-20 Læsning og skrivning fra UNIX 2008-08-21 COBOL nedarves ikke hvis årsagen er at out er .COBOL 2008-08-25 Ved cc-cc vises korrekt linnr ved SYNTAXFEJL 2008-08-28 outfunc i batch - kaldes nu fra andet sted i RXS 2008-09-09 rc 16 ved sqlfejl (i stedet for 8) 2008-09-22 ALLOC_OUTFILE: ny section som håndterer alloc af outfile UDSKRIV_RX_OUT_SUB ændret meget 2008-10-01 Fejlmeld hvis macro ikke kaldes som macro 2008-10-09: rx_pvar.0 indlagt i tbdispl: ej bladring i vinduer 2008-10-27: unix bør køre open+f_control_cvt+read+close etc? 2008-10-27: fejlmeld sorted ved max 256 byte sortkrit 2008-10-29: Pgm inline i jcl: drop linienumre 2009-02-02: UNIX: check for manglende read/write access 2009-02-20: Hvis ej cobol og ej submit: vb 32756 i rxs.data etc - rullet tilbage igen 2009-03-03: UNIX: skrevet om til brug af RXSDO. + address unix 2009-05-15: OUTFUNC: 'BINARY' FUNC='UTF8' '>ASCII' der supporteres op til ca 3 MB 2009-06-08: >UTF8 rettet vedr. lange strenge. FILEDATA(BINARY) browse af unix-hfs-filer 2009-12-14 OUTFUNC-DONE opsættes ved browse i unix 2010-01-22 Læsning af individer i UNIX: deles nu op i Rexx 2010-01-28 Hvis ej cobol eller sub: lrecl = 256 eller 32756 2010-02-05 Fejl i læsning af unix-'15'x-records Fejl i skrivning af flere unixfiler i samme uow 2010-02-09 Afbrydelse hvis uddata ikke kan allokeres 2010-02-11 UNIX-skriv: ej browse i uddata hvis outfunc='binary' 2010-02-16 Uddata lrecl er 80, 256, 4096 eller 32756 2010-02-25 Binær søgning i GETQUEUE og QUEUEVAR 2010-03-15 panel attr ¤ og ½ erstattet med [ og ] aht ascii (i panel rxs og clist rxs) 2010-03-21 ebcdic_codepage ascii_codepage ebcdic_charset 2010-03-26 listvars fejler - håndteres nu 2010-04-06 Panel hedder nu RXSPAN. +Default codepage håndtering 2010-05-25 ZEDLMSG skrives (SAY) i batch eksekvering 2010-05-28 Område 'UNIX write' rettet: linieskift adderes her, ikke i RXSDO. Ingen linieskift efter sidste linie. Hvis opdeling i write, nu max 8000 byte 2010-07-12 CHANGE funktion indført 2010-07-30 ADDRESS="XXX" er standard måden at addressere på 2010-07-30 RX_DEFAU_LGD er fjernet 2010-07-30 address fungerer ens i )text og )action 2010-08-27 Forkert db2 system giver liste over systemer: SKAFSSID() 2010-09-14 Fejl hvis record dannes som 256 byte: blev trunkeret 2010-10-21 outfile: omsættes til versaler 2010-10-21 address sættes til default i imbed start 2010-12-03 edit / view på dannede PC-filer via WSFN 2010-12-10 CLOB håndteres nu muligvis korrekt i SQL 2011-01-17 ulige antal quotes i SQL fejlmeldes 2011-02-02 UNIX cmds opsamles i blok og eksekveres samlet pr blok 2011-02-03 EXIT 20 i batch (JCL) giver nu korrekt rc=20 i steppet 2011-02-04 address unix: fejl skrives nu på skærmen + afbryd 2011-02-04 namespace: ej fejlmeld in mangler 2011-03-17 FUTF8 rettet - hjælpefil tilføjet 2011-03-17 FUTF8 rettet - hjælpefil fjernet 2011-04-29 sqllimit udgår 2011-06-09 Timestamp tilgår 2011-06-09 xmit til PC: linielængde nul erstattes af én blank 2011-06-09 READLIM i stedet for mqlimit 2011-06-17 READLIM medfører RC=2 i execio. Ignoreres nu 2011-08-24 Der allokeres 5 5 CYLINDERS 2011-10-03 address=xxx: uddata til skærm skrives til stdout 2012-10-04 )interface 2012-10-11 addressed cmd hvis rc > 7 så fejlhåndtering 2012-10-17 pathmode i unix-alloc (execute access til user og gruppe, read access til andre) 2012-10-31 addressed cmd hvis rc > 12 så fejlhåndtering 2013-05-24 General orders: OUTFILE annullerer OUT 2013-06-06 read_member tilføjet - hermed kan læses loadlib's 2013-06-28 lmfree af read_member ved fejl i eksekvering 2013-07-03 Længde for DB2 BLOB/CLOB sættes vilkårligt til 100000 Hvilket ikke forhindrer at hele feltet læses; det er den længde der opsættes i open_sql der er vilkårlig 2013-08-09 Sorter ud over 256 byte via SORT (begrænsning her: max 4.000 byte i sortkrit) 2013-08-28 ISPF sort returkode > 0 fejlmeldes 2013-08-30 Hvis 'infile' angivet er 'func' ok 2013-09-01 generisk datasetnavn (*) + list members uden func 2013-09-12 DROP RX_TRIGLGD. ved iteration i prompt 2013-09-16 Display af explist rettet (2 første pos ikke vist) 2013-10-08 )& er continuation af )action 2013-10-17 outfunc='sub' medfører exit i prompt-sekvens 2013-10-17 SET_HALT 'Alt galt' medfører stop i prompt eller i rxs i batch stoppes med RC = 16. SET_MESSAGE tilføjet 2013-10-18 PROMPT: popup placeres nu vandret udfra RX_LVL 2013-11-11: +1 i sqllgth for at få evt fortegn med i længden 2013-12-03 General orders: OUTFILE annullerer OUT - rettet 2013-12-18 )& og !!: Der forlanges ikke ',' i forrige linie 2014-01-02 Dan member-liste: nu med stats(yes) 2014-01-02 Sort af tal større end 2147483647: skift til alfa-sort 2014-01-21 Læs member LMMLIST ændret til interpret aht. stats(yes) 2014-02-09 Fejl i )INTERFACE: 'SEK_INPUT.' kø kunne blive smadret 2014-03-24 )INTERFACE rettet: hvis ej aktiv edit, ingen skriv Hvis over 32.500 byte: browse istedet for edit 2014-04-10 Comments i SQL: Efter '--' (ej i quote) ignoreres 2014-04-11 Fejlmeld i list-dataset (dvs '*' i in-navn) 2014-05-08 flytning af alm filer til PC: max 32000 bytes pr record (grænsen var tidligere 8005 byte) Hvis flere bytes, foldes. 2014-07-09 SQLTYPE = 409 er BLOB og får nu opsat længde 2014-07-28 Rettelsen 2014-05-08 rullet tilbage. Der foldes nu ved længde 8005. Svarende til grænsen i WSCON. 2014-09-10 Fejlmeld FUNC hvis der dannes member-liste 2014-09-25 translate inden test af ændret DB2-system 2014-09-29 outfunc='sub' fejlmeldes for intern queue 2014-10-14 readlim også i interne køer (fejlmeld readlim i UNIX) 2014-10-20 strip i fejlmeld vedr. parmspace. 2014-11-06 max 1 arg til dropqueue og til interface 2014-11-26 numeric digits 30 i forbindelse med SQL (aht select af lange numeriske felter) 2015-01-14 quotes inde i PC-fil-navne accepteres. )notrigger også ved læs PC: uanset fejlens type går man i notrigger hvis læsning mislykkes 2015-02-02 outfunc='sub' fejlmeldes ikke alligevel for intern queue 2015-02-10 Manglende )endaction i batch kunne skyldes "/ *"i col 1 2015-04-01 INVALID VALUE FOR OUT: flere regler 2015-06-17 Muligt loop i EVT_SQL_MQ_TERMINER rettet 2015-06-17 Ingen COMMIT hvis SQL-kald uden ændringer 2015-07-01 Rettelsen 2015-06-17 rettet 2015-07-07 READLIM også i UNIX læsning 2015-07-07 Foranstillet nul i hostvars: Advarsel 2015-07-15 UNIX-directory læses. unit.2 = DIR/FIL giver hint om hvad den enkelte directory indgang er Ved læsning af generisk fil eller po-dataset giver unit.2 = DIR/FIL/MEM hint om hvad den læste enhed er 2015-07-15 READFRST: Den record som læsning starter i 2015-08-10 Standard uddata: der allokeres CYLS 10 100 2015-08-14 Foranstillet nul i hostvar: sættes automatisk i qoute 2015-08-24 Skrivning i dataset/member med RECFM=U fungerer 2015-09-23 Rettelse af ISPF panel fejl: længde af description lig 65, så fejler ISPF med forkert antal ZVARS 2015-10-23 Ved ekskver som macro: Kun outfile='rxs' skrives på skærm. Øvrigt uddata behandles som normalt 2015-11-03 I Batch: VERSION udskrives kun én gang i //SYSTSPRT 2015-11-30 Skriv member: ZLNORC sættes max til 65535 2015-12-22: læs member: lmmlist tilføjet for at få stats ud 2016-02-03 Restore af hostvars / foranstillet nul problemet Nye variable: RX_GEM_HOSTVAR. RX_GEM_HOSTVAL. 2016-02-12 check parantes balance i namespace 2016-03-03 Tekst vedr tomme linier til PC udskrives kun en gang 2016-03-11 GET_SQLNO tildeler et cursor-nr til SQL-brug (problemet med kun sql-kald i de første 100 blokke) 2016-04-19 DISCONNECT rc>0: kun display ved fejl 2016-05-30 SORTED: alfanumerisk sort ved input over 16 tegn 2016-06-07 Hvis RC < 0 ved interpret af orders: fejlmeddelelse )INTERFACE også hvis køen har unit.1 og unit.2 2016-08-17 SQL: Der sættes kun nyt SQLVL for select-kald og for øvrige SQL-kald med host-variable Message om alfa sort rettet 2016-09-23 Mulighed for at kalde RXS som: RXS c.rxslib(yrsa) 2016-10-19 Initialisering af RX_PANEX manglede i batch Det accepteres at der mangler prompt-variable i batch hvis PROMPTALL='N' 2017-02-03 Hostvars som starter med '0' Hvis de rummer blanke, så pil ikke (SQL-fortolkning) 2017-02-16 INSQL = er ny mulighed som general order 2017-05-08 Konvertering af tegnsæt: Performance-optimering (Hvis alle records under 6000 byte, konverteres som fil) 2017-06-05 Unix-uddata: Edit er default (Browse håndterer ikke linieskift i dag) 2017-06-09 Kontrol på at dsn i 'in' eksisterer, var gledet ud 2017-06-19 Unix-uddata: rettet til at edit er ufravigelig (med mindre NOP anført) dog i batch NOP 2017-07-18 RX_INDSN: initialisering flyttet Skrivning af PDSE-member: bedre fejlmeddelelse 2017-07-24 Continuation af generelle ordrer med )+ (aht skeletons) 2017-09-26 INSQL: FUNC fejlmeldes 2017-09-29 send tso-message ved fejl i batch 2017-10-03 Ændret udskrift ved batch-fejl 2017-10-27 Sanering af logik ved udskrift af fejl 2017-11-15 PC kommunikation og )interface kolliderer: fejlmeldes 2018-04-03 read_member: ISPF-læs af member kun ved load-bib eller hvis zluser mv variabler efterspørges i programmet - ellers bruges normal execio (som er hurtigere) 2018-10-11 Bedre fejlmeddelelse hvis outfunc fejler 2018-11-19 Outfunc='sub' fejlmeldes hvis ikke permanent output 2018-12-19 Rettelse i listvars ('quoted unit.x') 2019-02-22 Interface Hvis RETURN i edit/browse så: break 2019-02-26 Foranmarkeret comment (-- ) fjernes i SQL 2019-07-09 FUNC='DCL': )NOTRIGGER åbnet 2019-07-22 strict (<< og >>) test ved binær søgning i rent numerisk pipe (dvs. ren 'byte' sammenlign) 2019-08-19 Sorter unix-directory (READDIR leverer ikke sorteret) 2020-01-23 Outfunc='sub' fejlmeldes IKKE - giver problemer hvis der ligger flere action blokke inde i det der submittes 2020-08-21 XML kan bruge INFILE i batch 2020-11-06 Send XML til fortolkning: Helt blanke linier ignoreres Der sættes ikke længere blank efter hver linie Samtidigt er rettet i RXSDO (COBOL) 2021-04-09 Set_halt message skal altid sejre (COND fjernet) 2021-07-27 Diverse fejlmeddelelser uddybet med hints 2021-07-28 SQL support fra Common Expression (WITH...) 2021-10-11 Message lgd rettet til 50 ved fejl i input-dsn 2021-10-19 Håndter imbed i batch med pre-screening 2021-11-01 Ved macro uddata med number off: sæt 'cobol' hvis DSN slutter med COBOL, ellers: number on: 'data' 2021-11-12 Ved læsning af non-exist kø: rettet fejlmeddelelse 2021-11-25 fejlmeddelelse på change fjernet 2022-02-16 Lang ZWINTTL bliver sat med mess COND, dvs skygger ikke for opsætning af andre mess, fx ved set_halt 2022-05-19 Hostvar som starter med '0' og slutter med '%': Sæt ej i quotes (pga problemer med at % betegner heltalsdivision) 2022-10-26 UNIX fil wiew supporteret Al WSCONN (PC access) fjernet */ /* Dictionary: RX_EXPLIST Liste over globale variable RX_SOU. Her ligger rxs-programmet efter fase 2 i fortolkning RX_SOURCE Trigger delen af RX_SOU (eller hele RX_SOU) RX_NOSOURCE Ved trigger/notrigger: notrigger delen af RX_SOU RX_TRIGLGD Ved trigger/notrigger: længde af trigger del af RX_SOU RX_NOTRIG '1' Notrigger er kodet. '0' Notrigger ikke kodet RX_LVL Aktuelt level: index for RX_SOU og RX_stack RX_KALDTYP tsocmd / batch / macro RXSPARM input-parameter, styrer test-udskrifter RX_LVL_GEM. Forrige level RX_T Linienummer på sidst eksekverede linie RX_IMBED_MBR Aktuelt imbed-member (i sidste eksekvering) RX_GLB. Compound indeholder alle interne køer. RX_GLB.SQ1_STEMIX indeholder antal i kø SQ1 RX_GLB.SQ1_1.x indeholder værdi x i kø SQ1 RX_GLB.SQ1_2.x indeholder værdi-2 x i kø SQ1 RX_OUT. Compound indeholdende det totale output RX_OUT.RX_DISP indeholder output pr fil RX_OUTFUNC. Stem indeholdende værdien af OUTFUNC for alle ud-linie RX_KX Index for Rx_out: hvilken linie der aktuelt skrives RX_COMMENT Vedr. fjernelse af rene kommentarlinier RX_ER_AKTIVT SW for hvorvidt der overhovedet sker noget RX_ORDERS. Compound: Indholdet af linien efter )ACTION RX_DEFAU Nogle få default værdier som opsættes i hver blok RX_OUT_LIST Liste over alle værdier af OUT RX_DISP Displacement i ovenstående en en given værdi af OUT RX_SQL_DONE Switch som indikerer max kompleksitet i SQL-status: ' ' Ingen kontakt med SQL eller disconnect sket 'A' SQL DSNREXX added 'B' SQL connect sket '1' der har været udført SQL SELECT kald '2' ikke-SELECT kald udført (overtrumfer '1') '3' Fejl fundet, ikke-SELECT kald har været udført RX_SQL_KALDTYPE 'S' select-kald 'U' opdaterende kald RX_TRACE Indeholder første del af parm hvis denne starter med '?'. Indeholder strengen 'MACOUT' hvis rxs kaldes RXS !navn for at ekskvere en RXS med macro-output. RX_SQLLIN Et sql-kald hvor host-variable er omsat til '?' RX_HOSTVAR. Stem med navne på alle host-variable i et sql-kald RX_HOSTVARS kommasepareret liste med navne på host-variable - vedr sql-kald. RX_PARMSPACE_LIST liste over fundne variable i et parmspace RX_PROMPT_LEAVE '1': Der er trykket F3 i panel uden NOTRIGGER-kode RX_PROMPT_OK_LVL Det level hvor der sidst blev vist panel som blev processet uden F3 -1: Resultat blev vist i en ok terminering - Der har været vist panel ok RX_PROMPT_GEM_LVL Værdi af RX_PROMPT_OK_LVL i sidste gennemløb RX_MAXLVL Det højeste lvl (der spoles tilbage hertil ved iteration). Da variablen ikke er global vil den indeholde max-lvl efter primær input. RX_IS_TEXT 0: Dette er )ACTION blok 1: Dette er )TEXT blok RX_MQ_DONE Switch som indikerer max kompleksitet i MQ access: ' ' Ingen kontakt med MQ '1' MQCONN sket ok '2' MQPUT sket ok (dvs MQCMIT ønskes) '3' Fejl fundet, MQCMIT ønskes ikke (rollback) RXIRECF 'V' eller 'B' input record-format RX_Q_SORT '-' : ingen QUEUEVAR fundet endnu eller køen rettet navn: først QUEUEVAR fundet, handler om kø: navn tilstand er at køen er sorteret op RX_Q_ANT antal QUEUVAR-opeartioner på køen (lokal variabel) RX_UNIX_STRING en opsamling af blokkens UNIX-commands RX_INTERFACE.xx 1: Der er editeret aktivt i sidste INTERFACE session RX_SQLNO Nummer på den aktuelle SQL-cursor RX_SQLNO. Stem med numre på anvendte SQL-cursors RX_INDSN Datasetnavn hvis RXS kaldes som RXS c.rxslib(yrsa) */ /* ----------- default values ------------------------------------ */ SQL = 'TDB2' /* default DB2-system */ MQ = 'MQTC' /* default MQ queue-manager */ ALLOC_CLAS = 'UNIT' /* UNIT STORCLAS DATACLAS MGMTCLAS VOL */ ALLOC_TOKEN = 'STOR' /* name of unit, class or vol */ EBCDIC_CODEPAGE = 'DEFAULT' /* mainframe (EBCDIC) codepage 285=usa */ EBCDIC_CHARSET = 'DEFAULT' /* mainframe charset */ ASCII_CODEPAGE = 'DEFAULT' /* ASCII (PC) codepage 437=usa */ EBCDIC_CODEPAGE = '0277' /* CSC-specific */ EBCDIC_CHARSET = '0281' /* CSC-specific */ ASCII_CODEPAGE = '0865' /* CSC-specific */ IF LEFT(MVSVAR('SYSNAME'),2) = 'A1' THEN DO /* CSC-specific */ SQL = 'PDB2' /* CSC-specific */ MQ = 'MQPC' /* CSC-specific */ END /* CSC-specific */ /* ----------- default values ------------------------------------ */ RXMCURS = '' RXMFIRST = 1 ADDRESS ISPEXEC "CONTROL ERRORS RETURN" ADDRESS ISREDIT "MACRO NOPROCESS (RXSPARM)" RX_INDSN = '' /* 2017-07-18 initialisering flyttet hertil */ IF RC > 0 THEN DO /* ikke macro */ ADDRESS ISPEXEC "VGET (ZENVIR, ZPF03)" IF RIGHT(ZENVIR,3) = 'TSO' THEN DO RX_KALDTYP = 'TSOCMD' END ELSE DO RX_KALDTYP = 'BATCH' END PARSE ARG RXINMEMB RXSPARM IF POS('(',RXINMEMB) > 0 THEN DO /* find dsn 2016-09-23 */ RX_GEM_TYPE = POS("'",RXINMEMB) RX_INDSN = WORD(TRANSLATE(RXINMEMB,' ',"'()"),1) IF RX_GEM_TYPE = 0 THEN RX_INDSN = SYSVAR('SYSUID')"."RX_INDSN RXINMEMB = WORD(TRANSLATE(RXINMEMB,' ',"'()"),2) END RXIRECL = '-' RXIRECF = '-' END ELSE DO /* macro */ ADDRESS ISPEXEC "VGET ZPF03" ADDRESS ISREDIT "PROCESS DEST RANGE C" RX_LRC = RC SELECT WHEN RX_LRC = 0 THEN DO /* A/B og c/cc anført: */ "(RXMCURS) = LINENUM .ZDEST" "(RXMFIRST) = LINENUM .ZFRANGE " "(RXMLAST) = LINENUM .ZLRANGE " END WHEN RX_LRC = 4 THEN DO /* A/B anført: */ "(RXMCURS) = LINENUM .ZDEST" RXMFIRST = 0 RXMLAST = 0 END WHEN RX_LRC = 20 THEN DO /* A/B anført i tomt dataset: */ "(RXMCURS) = LINENUM .ZDEST" RXMFIRST = 0 RXMLAST = 0 END WHEN RX_LRC = 8 THEN DO /* c / cc anført: */ "(RXMFIRST) = LINENUM .ZFRANGE " "(RXMLAST) = LINENUM .ZLRANGE " END WHEN RX_LRC = 16 THEN DO IF SYMBOL('ZERRMSG') <> 'LIT' THEN DO /* 2007-01-25 */ ADDRESS ISPEXEC "SETMSG MSG("ZERRMSG")" END EXIT 8 END OTHERWISE DO RXMFIRST = 1 "(RXMLAST) = LINENUM .ZLAST" END END RX_KALDTYP = 'MACRO' RXINMEMB = "" "(RXINMEMB) = MEMBER" "(RXIRECL) = LRECL" IF DATATYPE(RXIRECL) <> 'NUM' THEN DO say 'Temporary error reading input. Try RXS again' CALL EXIT_I_UTIDE 16 /* 2015-06-17 */ END RXIRECL = RXIRECL * 1 /* fjern foranstillede nuller */ "(RXIRECF) = RECFM" /* F eller V */ "RESET" END RXENDTXT = 'END' IF ZPF03 = 'END' THEN RXENDTXT = 'F3' RX_TRACE = "" IF LENGTH(RXSPARM) > 0 THEN DO IF LEFT(RXSPARM,1) = '?' ! LEFT(RXSPARM,1) = '!' THEN DO RX_TRACE = TRANSLATE(WORD(RXSPARM,1)) IF LENGTH(RXSPARM) > LENGTH(RX_TRACE) THEN DO RXSPARM = STRIP(SUBSTR(RXSPARM,LENGTH(RX_TRACE)+1)) END ELSE DO RXSPARM = "" END END IF RX_KALDTYP = 'MACRO' THEN DO IF LEFT(RX_TRACE,1) = '!' THEN DO RX_KALDTYP = 'TSOCMD' RXINMEMB = SUBSTR(RX_TRACE,2) RX_TRACE = 'MACOUT' END END END NUMERIC DIGITS 15 RX_UNIT_VOL = ALLOC_CLAS"("ALLOC_TOKEN")" IF ALLOC_CLAS = "VOLUME" THEN DO RX_UNIT_VOL = "UNIT(SYSDA) VOLUME("ALLOC_TOKEN")" END RX_GSQL = "" RX_GMQ = "" RXSPARM = TRANSLATE(RXSPARM) SIGNAL ON SYNTAX NAME SYNTAXFEJL_REXX /* SIGNAL ON ERROR NAME SYNTAXFEJL_REXX */ SIGNAL ON NOVALUE NAME EJVALUE RX_EXPLIST = 'RX_KX RX_OUT. RX_SOU. RX_KALDTYP RX_SQL_DONE', 'SQL RX_GSQL RX_ORDERS. RX_DEFAU RX_GLB. RX_TRACE', 'RXSPARM LVL_GEM. RX_T RX_OUT_LIST PROMPT RX_TRIGLGD. RX_UNIT_VOL', 'RX_OUTFUNC. RXINMEMB RX_PROMPT_LEAVE RX_PROMPT_OK_LVL', 'RX_PROMPT_GEM_LVL MBR RXENDTXT RX_EXPLIST_BASIS_LGTH PRIM_INPUT.', 'RXMLAST RXMFIRST RXMCURS RX_MQ_DONE MQ RX_MQHANDLE READLIM RX_GMQ', 'EBCDIC_CODEPAGE EBCDIC_CHARSET ASCII_CODEPAGE RX_Q_SORT', 'RX_INTERFACE. READFRST RX_SQLNO RX_SQLNO. RX_INDSN ' /*afslut m blank*/ RX_EXPLIST_BASIS_LGTH = LENGTH(RX_EXPLIST) PROMPT = "" /* eksternt kendte variable: */ RC = 0 RX_OUT_LIST = " " /* skal være to blanke */ RX_SQL_DONE = "" RX_MQ_DONE = "" RX_MQHANDLE = "" RX_Q_SORT = '-' /* bruger-opsatte defaults: */ RX_DEFAU ="IN='-';FUNC='WORD';PROMPT='';IMBED='-';CAPS='ON';ADDRESS='-'" RX_DEFAU = RX_DEFAU";READLIM = 3000000" /* max number of records read */ RX_DEFAU = RX_DEFAU";READFRST= 1" INTERPRET RX_DEFAU OUT = '-' OUTFUNC = 'EDIT' OUTFILE = 'RXS' /* defaults slut */ RX_KX = 0 RX_LVL = 1 RX_SOU. = "" LVL_GEM. = "" RX_T = 0 RX_IMBED_MBR = "-" /* variabel bruges kun til udskrift af fejl */ RX_ER_AKTIVT = "" ZEDSMSG = "" ZEDLMSG = "" MBR = '-' UNIT.1 = '' UNIT.2 = '' RX_PROMPT_GEM_LVL = 0 RX_GENNEMLOEB_OK = 0 /* hvorvidt hele RXS har været kørt mindst 1 gang*/ RX_OUTFUNC_DONE = "" /* hvorvidt outfunc har været kørt <> NOP */ RX_SQLNO = 0 RX_SQLNO. = '' RX_VOID = ALLOC_DO('RXSINP') RX_VOID = ALLOC_DO('RXSOUTP') CALL GET_PRIM_INPUT rx_err = 0 /* håndter imbed i batch 2021-10-19 */ if rx_kaldtyp = 'BATCH' then do /* håndter imbed i batch 2021-10-19 */ call oploes_imbed_i_input /* håndter imbed i batch 2021-10-19 */ end CALL PROCES_PRIM_INPUT IF RX_TRIG_FOUND <> 0 THEN DO RX_FMESS = "Numbers of )TRIGGER and )NOTRIGGER are not equal" RX_T = PRIM_INPUT.0 CALL SYNTAXFEJL END IF RX_COMMENT <> '0' THEN DO RX_FMESS = "Missing */ somewhere in coding above" RX_T = PRIM_INPUT.0 CALL SYNTAXFEJL END IF RX_TRACE = '?TRACE' THEN DO CALL UDSKRIV_RX_SOU END IF RX_SOU.1 > "" THEN DO RX_GEM_OUT = '' DO FOREVER RX_PROMPT_LEAVE = 0 RX_PROMPT_OK_LVL = 0 ADDRESS STDOUT /* ********** her startes udrulning !!! ********** */ INTERPRET RX_SOU.1 /* her startes udrulning <<<<<<<<<<<<< */ /* ********** her startes udrulning !!! ********** */ IF RX_PROMPT_LEAVE = 0 THEN DO /* hvis ingen panel-F3 tryk */ CALL EVT_SQL_MQ_TERMINERING CALL UDSKRIV_RX_OUT RX_GENNEMLOEB_OK = 1 IF RX_PROMPT_OK_LVL > 0 THEN RX_PROMPT_OK_LVL = -1 /* IF TRANSLATE(OUTFUNC) = 'NOP' ! RX_KX = 0 THEN LEAVE */ SELECT WHEN ZEDSMSG <> '' THEN NOP /* 2007-02-02 */ WHEN RX_KALDTYP='TSOCMD' ! OUTFUNC<>'EDIT' THEN DO ZEDSMSG = "RXS "RXINMEMB" ok" END WHEN RX_ER_AKTIVT <> '1' THEN ZEDSMSG = "Ok, no active RXS-cmds" OTHERWISE ZEDSMSG = "Ok, RXS completed" END CALL ISPF_MESS_COND IF RX_OUTFUNC_DONE = "" THEN LEAVE /*2006-02-01: uddata ej vist*/ END IF RX_PROMPT_OK_LVL = 0 THEN LEAVE do rx_z = rx_maxlvl + 1 to 999 /* 20/06-03 aht imbed + iteration */ if rx_sou.rx_z = "" then leave lvl_gem.rx_z = "" /* levels som er tilføjet efter */ rx_sou.rx_z = "" /* fortolkning af prim input, fjernes */ rx_orders.rx_z = "" drop rx_triglgd.rx_z /* 2013-09-12 iter*/ end DROP RX_OUT. /*iter*/ DROP RX_GLB. /*iter*/ RX_OUT_LIST = " " /*iter*/ RX_OUTFUNC. = '' /*iter*/ RX_GEM_OUT = '' /*iter*/ RX_GSQL = "" /*iter*/ RX_GMQ = "" /*iter*/ RX_PROMPT_GEM_LVL = RX_PROMPT_OK_LVL /*iter*/ OUT = '-' /*iter*/ OUTFILE = 'RXS' /*iter*/ ZWINTTL = '' /*iter*/ IF RX_SQL_DONE <> '' THEN DO RX_SQL_DONE = 'A' /* 17/2-02 iter*/ ADDRESS DSNREXX "DISCONNECT" /* 24/6-04 */ END CALL EVT_SQL_MQ_TERMINERING /* 21/2-02 iter*/ /* 2004-12-03: Ved iteration i macro må input genfindes: */ IF RX_TRACE = 'MACOUT' THEN CALL EDIT_SCREEN_ER_INPUT END IF RX_GENNEMLOEB_OK <> 1 THEN DO ZEDSMSG = "Ok, RXS interrupted" ZEDLMSG = "RXS interrupted by END command" CALL ISPF_MESS CALL EXIT_I_UTIDE 4 END END IF RX_TRACE = '?TRACE' THEN DO SAY 'variables found:' SUBSTR(RX_EXPLIST,RX_EXPLIST_BASIS_LGTH) END EXIT /* exit main er her */ ALLOC_DO: /* allokering af file yrsa danner dsn rxs.yrsa */ ARG RX_FILE RX_DSN RX_LGD /*allokering af interne RXS work-dataset */ IF RX_LGD = '' THEN RX_LGD = 8008 IF RX_DSN = '-' THEN RX_DSN = '' ADDRESS TSO IF RX_KALDTYP = 'BATCH' & RX_DSN = '' THEN DO "ALLOC FI("RX_FILE") NEW UNIT(VIO) LRECL("RX_LGD") RECFM(V B)" , "SPACE(10 100) CYLINDERS DSORG(PS) REUSE" END ELSE DO IF RX_DSN = '' THEN RX_DSN = 'RXS.'RX_FILE IF LISTDSI(RX_FILE 'FILE') > 4 THEN DO IF SYSDSN(RX_DSN) <> 'OK' THEN DO "ALLOC DA("RX_DSN") NEW UNIT(VIO) LRECL("RX_LGD") RECFM(V B)" , "SPACE(10 100) CYLINDERS DSORG(PS)" END "ALLOC DA("RX_DSN") FI("RX_FILE") REUSE " END END RETURN 0 GET_PRIM_INPUT: SELECT WHEN RX_TRACE = 'MACOUT' THEN DO /* kald en macro */ CALL EDIT_SCREEN_ER_INPUT CALL GET_PRIM_INPUT_BATCH_TSO RXIRECL = RX_G_RXIRECL RXIRECF = RX_G_RXIRECF RX_PRIMTYPE = RX_G_PRIMTYPE END WHEN RX_KALDTYP ^= 'MACRO' THEN DO /* batch/tso */ CALL GET_PRIM_INPUT_BATCH_TSO END OTHERWISE DO /* udførelse som macro */ CALL GET_PRIM_INPUT_MACRO END END RETURN EDIT_SCREEN_ER_INPUT: CALL GET_PRIM_INPUT_MACRO RX_G_RXIRECL = RXIRECL /*2003-08-27: Brug DCB mv fra edit-sceen */ RX_G_RXIRECF = RXIRECF RX_G_PRIMTYPE = RX_PRIMTYPE OUT = 'EDIT_SCREEN' DO RX_X = 1 TO PRIM_INPUT.0 CALL RX_PUTQUEUE PRIM_INPUT.RX_X END OUT = '-' RETURN GET_PRIM_INPUT_BATCH_TSO: IF RXINMEMB = '?TRACE' THEN DO RX_TRACE = '?TRACE' RXINMEMB = '' END IF RX_KALDTYP = 'BATCH' & RXINMEMB = "" THEN DO /* inline batch */ ADDRESS TSO "EXECIO * DISKR RXSPGM (STEM PRIM_INPUT. OPEN FINIS)" /* btc */ IF RC > 0 THEN DO /* btc */ RX_FMESS = , /* btc */ "RXS: RXS called in batch without membername", /* btc */ "//RXSPGM missing in JCL " /* btc */ CALL SYNTAXFEJL /* btc */ END /* btc */ RX_SW = 1 DO RX_I = 1 TO PRIM_INPUT.0 /* 2008-10-29 linnr col 73-80? */ IF LENGTH(STRIP(PRIM_INPUT.RX_I,'T')) < 80 THEN RX_SW = 0 END DO RX_I = 1 TO PRIM_INPUT.0 /* 2005-02-16 format skal være V */ IF RX_SW = 1 THEN PRIM_INPUT.RX_I = LEFT(PRIM_INPUT.RX_I,72) PRIM_INPUT.RX_I = STRIP(PRIM_INPUT.RX_I,'T') END RX_PRIMTYPE = 'DATA' RXIRECF = 'F' RXIRECL = 80 RETURN END ADDRESS ISPEXEC RX_LIB='RXSLIB' /* IF SYMBOL('RX_INDSN') <> 'LIT' THEN DO 2016-09-23 */ IF RX_INDSN <> '' THEN DO /* 2017-07-18 */ "LMINIT DATAID(RXSIN) DATASET('"RX_INDSN"') ORG(INDORG) ENQ(SHR)" IF RC > 0 THEN CALL ISPF_GETMSG END ELSE DO "LMINIT DATAID(RXSIN) DDNAME("RX_LIB") ORG(INDORG) ENQ(SHR)" IF RC > 0 THEN DO IF RX_KALDTYP = 'BATCH' THEN DO RX_FMESS = "File //"RX_LIB" not allocated in JCL -RC:"RC END IF RX_KALDTYP = 'TSOCMD' THEN DO RX_FMESS = "File "RX_LIB" not allocated to ISPF-session - RC:"RC END CALL SYNTAXFEJL END END "LMOPEN DATAID(&RXSIN) LRECL(RXIRECL) RECFM(RXIRECF)" RXIRECF = LEFT(RXIRECF,1) IF RXINMEMB = "" THEN DO RX_FMESS = "RXS called as exec without member name" RX_FMESS2 = , "Indicate a member in file "RX_LIB" containing actual RXS coding" CALL SYNTAXFEJL END RXIRECL = RXIRECL * 1 /* fjern foranstillede nuller */ "LMMFIND DATAID(&RXSIN) MEMBER(&RXINMEMB)" IF RC > 0 THEN DO IF LENGTH(RXINMEMB) > 8 THEN DO RX_FMESS ="'"RXINMEMB"' is not valid. Indicate a valid member name" CALL SYNTAXFEJL END IF RX_INDSN = '' THEN DO RX_FMESS ="Member '"RXINMEMB"' not found in file "RX_LIB"" END ELSE DO RX_FMESS ="Member '"RXINMEMB"' not found in '"RX_INDSN"'" END CALL SYNTAXFEJL END RXLINN = 0 LMGETRC = 0 DO WHILE LMGETRC = 0 "LMGET DATAID(&RXSIN) MODE(INVAR) DATALOC(RXSININD) DATALEN(RXACTLGD) MAXLEN(&RXIRECL)" LMGETRC = RC IF LMGETRC = 0 THEN DO RXLINN = RXLINN + 1 PRIM_INPUT.RXLINN = RXSININD END END PRIM_INPUT.0 = RXLINN "LMCLOSE DATAID(&RXSIN)" "LMFREE DATAID(&RXSIN)" CALL COBOL_LIN_INPUT RETURN GET_PRIM_INPUT_MACRO: ADDRESS ISREDIT /* Hvis vi kører som macro, fortsættes her */ RX_PRIMTYPE = 'DATA' "(NUMON,NUMTYP) = NUMBER" IF WORD(NUMON,1) = 'ON' & WORD(NUMTYP,2) = 'COBOL' THEN DO IF RX_TRACE <> 'MACOUT' THEN DO /* kørt som !macro dannes aldrig */ RX_PRIMTYPE = 'COBOL' /* COBOL numre 2005-01-06 */ END END "(RXDSN) = DATASET" /* 2021-11-01 */ if word(numon,1) = 'OFF' & right(rxdsn,5) = 'COBOL', & rx_trace ='MACOUT' then do rx_primtype = 'COBOL' /* 2021-11-01 cobol uden number: sæt til */ end RXLINN = RXMLAST + 0 /*konvertering til tal uden foranstillet nul*/ RXMFIRST = RXMFIRST + 0 /* do */ RX_ULIN = RXMLAST - RXMFIRST + 1 IF RXMLAST = 0 THEN RX_ULIN = 0 PRIM_INPUT.0 = RX_ULIN IF PRIM_INPUT.0 = 0 THEN RETURN DO FOREVER IF RXLINN < RXMFIRST THEN DO LMGETRC = 4 LEAVE END "(INDIVID) = LINE &RXLINN" LMGETRC = RC PRIM_INPUT.RX_ULIN = STRIP(INDIVID,'T') IF RXIRECL = 80 THEN DO IF DATATYPE(SUBSTR(PRIM_INPUT.RX_ULIN,73,8)) = 'NUM' THEN DO PRIM_INPUT.RX_ULIN = LEFT(PRIM_INPUT.RX_ULIN,72) /*num on 72 80*/ END END RXLINN = RXLINN - 1 RX_ULIN = RX_ULIN - 1 END RETURN COBOL_LIN_INPUT: /* fjern cobol linienumre */ RX_PRIMTYPE = 'COBOL' DO RXX = 1 TO PRIM_INPUT.0 IF DATATYPE(LEFT(PRIM_INPUT.RXX,6)) ^= 'NUM' THEN DO RX_PRIMTYPE = 'DATA' LEAVE END IF DATATYPE(LEFT(PRIM_INPUT.RXX,1)) ^= 'NUM' THEN DO RX_PRIMTYPE = 'DATA' LEAVE END IF DATATYPE(SUBSTR(PRIM_INPUT.RXX,6,1)) ^= 'NUM' THEN DO RX_PRIMTYPE = 'DATA' LEAVE END IF DATATYPE(SUBSTR(PRIM_INPUT.RXX,7,1)) = 'NUM' THEN DO RX_PRIMTYPE = 'DATA' LEAVE END IF DATATYPE(SUBSTR(PRIM_INPUT.RXX,73,8)) = 'NUM' THEN DO PRIM_INPUT.RXX = LEFT(PRIM_INPUT.RXX,72) /* number on col 72-80 */ LEAVE END END IF RX_PRIMTYPE = 'COBOL' THEN DO DO RXX = 1 TO PRIM_INPUT.0 PRIM_INPUT.RXX = RIGHT(PRIM_INPUT.RXX,LENGTH(PRIM_INPUT.RXX) - 6) END END DO RXX = PRIM_INPUT.0 TO 1 BY -1 PRIM_INPUT.RXX = STRIP(PRIM_INPUT.RXX,'T') END RETURN PROCES_PRIM_INPUT: ADDRESS TSO , "EXECIO "PRIM_INPUT.0" DISKW RXSINP (STEM PRIM_INPUT. OPEN FINIS)" ADDRESS ISPEXEC "SELECT PGM(RXSDO) PARM(P "RX_EXPLIST")" IF RC > 0 THEN DO SAY "Instalation error? Attempt to call loadmodule RXSDO fails" CALL ISPF_GETMSG('') END ADDRESS TSO "EXECIO * DISKR RXSOUTP (STEM MODIF_INPUT. OPEN FINIS)" IF RX_TRACE = '?TRACE' THEN DO ADDRESS ISPEXEC "LMINIT DATAID(RXSOUTP) DDNAME(RXSOUTP) ORG(INDORG) ENQ(SHR)" "BROWSE DATAID(&RXSOUTP)" END RX_GEM_ORDERS = '' DO RX_I = MODIF_INPUT.0 TO 1 BY -1 /* 2013-10-08 */ IF LEFT(MODIF_INPUT.RX_I,1) = ')' THEN DO RX_MOD_INP_UPPER = TRANSLATE(MODIF_INPUT.RX_I) RX_WORD_1 = WORD(RX_MOD_INP_UPPER,1) SELECT WHEN RX_WORD_1 = ')&' ! RX_WORD_1 = ')+' THEN DO /*2017-07-24 */ rx_go = STRIP(SUBSTR(MODIF_INPUT.RX_I,4)) select when right(rx_go,1) = ',' then do RX_GEM_ORDERS = left(rx_go,length(rx_go) - 1)" "rx_gem_orders end when left(strip(rx_gem_orders),2) = '!!' then do RX_GEM_ORDERS = rx_go" "rx_gem_orders /* uden ';' */ end /* 2013-12-18 */ otherwise do RX_GEM_ORDERS = RX_GO";"RX_GEM_ORDERS end end MODIF_INPUT.RX_I = ')NOP' END WHEN RX_MOD_INP_UPPER = ')ACTION' , ! RX_MOD_INP_UPPER = ')TEXT' , ! RX_MOD_INP_UPPER = ')IMBED' , ! RX_MOD_INP_UPPER = ')INTERFACE' THEN DO MODIF_INPUT.RX_I = MODIF_INPUT.RX_I" "STRIP(RX_GEM_ORDERS) RX_GEM_ORDERS = '' END WHEN RX_WORD_1 = ')ACTION' , ! RX_WORD_1 = ')TEXT' , ! RX_WORD_1 = ')IMBED' , ! RX_WORD_1 = ')INTERFACE' THEN DO if left(strip(rx_gem_orders),2) = '!!' then do MODIF_INPUT.RX_I = MODIF_INPUT.RX_I""STRIP(RX_GEM_ORDERS) end /* 2013-12-18 */ else do MODIF_INPUT.RX_I = MODIF_INPUT.RX_I";"STRIP(RX_GEM_ORDERS) end RX_GEM_ORDERS = '' /* 2013-10-17: cont. i )action linie: */ IF POS(')& ', MODIF_INPUT.RX_I) > 0 THEN DO MODIF_INPUT.RX_I = CHANGE(')& ', ' ',MODIF_INPUT.RX_I) END IF POS(')+ ', MODIF_INPUT.RX_I) > 0 THEN DO /* 2017-07-24 */ MODIF_INPUT.RX_I = CHANGE(')+ ', ' ',MODIF_INPUT.RX_I) END END OTHERWISE NOP END END END RX_COMMENT = 0 RX_TRIG_FOUND = 0 DO RX_I = 1 TO MODIF_INPUT.0 MODIF_INPUT_AKT = STRIP(MODIF_INPUT.RX_I) MODIF_INPUT_AKT_V = TRANSLATE(MODIF_INPUT_AKT) RX_WORD_1 = WORD(MODIF_INPUT_AKT_V,1) IF RX_WORD_1 = ')INTERFACE' THEN DO MODIF_INPUT.RX_I = , SUBSTR(STRIP(MODIF_INPUT_AKT),11)";CALL INTERFACE_DO;" RX_WORD_1 = 'dummy' END SELECT WHEN ^(LEFT(RX_WORD_1,1) = ')' & LENGTH(RX_WORD_1) > 3) THEN DO RX_SOU.RX_LVL = RX_SOU.RX_LVL!!MODIF_INPUT.RX_I END WHEN RX_WORD_1 = ')ENDACTION' THEN CALL FORR_LVL WHEN RX_WORD_1 = ')ENDTEXT' THEN CALL FORR_LVL WHEN RX_WORD_1 = ')DEFAULT' THEN DO RX_DEFAU = RX_DEFAU";"STRIP(SUBSTR(MODIF_INPUT_AKT,10)) RX_SOU.RX_LVL = RX_SOU.RX_LVL, "RX_T="RX_I";INTERPRET RX_DEFAU;" END WHEN RX_WORD_1 = ')ACTION' THEN DO RX_ER_AKTIVT = '1' CALL NYT_LVL RX_ORDERS.RX_LVL = SUBSTR(STRIP(MODIF_INPUT_AKT),9) RX_ORDERS.RX_LVL = 'RX_T='RX_I';'RX_ORDERS.RX_LVL';RX_IS_TEXT=0' IF POS('OUTFILE',TRANSLATE(RX_ORDERS.RX_LVL)) > 0 THEN DO RX_ORDERS.RX_LVL = "OUT='-';"RX_ORDERS.RX_LVL /* 2013-05-24 */ END /*2013-05-24 SLUT*/ RX_SOU.RX_G_LVL = RX_SOU.RX_G_LVL, 'IF RX_PROMPT_LEAVE=0 THEN RX_VOID = SCAN_DO('RX_LVL');' END WHEN RX_WORD_1 = ')TEXT' THEN DO RX_ER_AKTIVT = '1' CALL NYT_LVL RX_ORDERS.RX_LVL = SUBSTR(STRIP(MODIF_INPUT_AKT),6) RX_ORDERS.RX_LVL = 'RX_T='RX_I';'RX_ORDERS.RX_LVL';RX_IS_TEXT=1' IF POS('OUTFILE',TRANSLATE(RX_ORDERS.RX_LVL)) > 0 THEN DO RX_ORDERS.RX_LVL = "OUT='-';"RX_ORDERS.RX_LVL /* 2013-05-24 */ END /*2013-05-24 SLUT*/ RX_SOU.RX_G_LVL = RX_SOU.RX_G_LVL, 'IF RX_PROMPT_LEAVE=0 THEN RX_VOID = SCAN_DO('RX_LVL');' END WHEN RX_WORD_1 = ')TRIGGER' THEN DO IF LENGTH(RX_SOU.RX_LVL) > 0 THEN DO RX_FMESS = "No coding lines allowed between )ACTION and )TRIGGER" RX_T = RX_I CALL SYNTAXFEJL END RX_SOU.RX_LVL = RX_SOU.RX_LVL'/*)TRIGGER*/;' RX_TRIG_FOUND = RX_TRIG_FOUND + 1 END WHEN RX_WORD_1 = ')NOTRIGGER' THEN DO IF RX_TRIG_FOUND = 0 THEN DO RX_FMESS = ")NOTRIGGER found before )TRIGGER or without )TRIGGER" RX_T = RX_I CALL SYNTAXFEJL END RX_TRIG_FOUND = RX_TRIG_FOUND - 1 RX_TRIGLGD.RX_LVL = LENGTH(RX_SOU.RX_LVL) RX_SOU.RX_LVL = RX_SOU.RX_LVL'/*)NOTRIGGER*/;' END WHEN RX_WORD_1 = ')IMBED' THEN DO RX_ER_AKTIVT = '1' RX_SOU.RX_LVL = RX_SOU.RX_LVL'CALL HOUSEKEEP_VED_SKIFT_LVL;' CALL NYT_LVL RX_ORDERS.RX_LVL = SUBSTR(STRIP(MODIF_INPUT_AKT),7) RX_ORDERS.RX_LVL = 'RX_T='RX_I';'RX_ORDERS.RX_LVL RX_SOU.RX_G_LVL = , RX_SOU.RX_G_LVL, RX_ORDERS.RX_LVL';', 'IF RX_PROMPT_LEAVE=0 THEN ', 'RX_VOID = IMBED_DO('RX_LVL' FUNC IN MBR', 'IMBED OUT","OUTFUNC","OUTFILE","UNIT.1","UNIT.2);' CALL FORR_LVL END WHEN RX_WORD_1 = ')NOP' THEN NOP WHEN RX_WORD_1 = ')ERR' THEN DO IF WORD(MODIF_INPUT_AKT_V,2) = '*RXS1*' THEN DO CALL RXS1 RX_KALDTYP RXIRECL RXIRECF RXINMEMB RXSPARM /*rxs1*/ EXIT /*rxs1*/ RX_FMESS = "Unknown RXS block-delimiter" CALL SYNTAXFEJL END ELSE DO RX_T = WORD(MODIF_INPUT_AKT_V,2) RX_FMESS = SUBSTR(MODIF_INPUT_AKT,WORDINDEX(MODIF_INPUT_AKT,3)) IF RX_KALDTYP = 'BATCH' THEN DO IF LEFT(RX_FMESS, 9) = 'Missing )' THEN DO /* 2015-02-10 */ RX_FMESS = RX_FMESS" (Might be due to '/*' in col 1)", "(...'The evil sysin-terminator' in JCL)" END END CALL SYNTAXFEJL END END WHEN RX_WORD_1 = ')EXP' THEN DO RX_EXPLIST = SUBSTR(MODIF_INPUT_AKT_V,6) IF LENGTH(RX_EXPLIST) > RX_EXPLIST_BASIS_LGTH THEN DO RX_EXPLL = SUBSTR(RX_EXPLIST, RX_EXPLIST_BASIS_LGTH) DO RX_II = 1 TO 999 /* 24/1-2004 fejlmeld invalide vars */ IF WORD(RX_EXPLL,RX_II) = '' THEN LEAVE IF SYMBOL(WORD(RX_EXPLL,RX_II)) = 'BAD' THEN DO RX_FMESS = "INVALID VARIABLE NAME FOUND:", WORD(RX_EXPLL,RX_II) RX_EXPLIST = LEFT(RX_EXPLIST, RX_EXPLIST_BASIS_LGTH) CALL SYNTAXFEJL END END END END OTHERWISE NOP END /* select */ END /* do loop */ RETURN NYT_LVL: RX_G_LVL = RX_LVL /* gem dette lvl (1) */ RX_Z = 2 /* find næste ledige */ DO FOREVER IF LVL_GEM.RX_Z = "" THEN DO RX_LVL = RX_Z rx_maxlvl = rx_lvl /* 20/06-2003 gem højeste lvl */ LEAVE END RX_Z = RX_Z + 1 END LVL_GEM.RX_LVL = RX_G_LVL /* gem dette lvl (2) */ RETURN FORR_LVL: IF RX_LVL = 1 THEN DO RX_FMESS = "Number of )ENDACTION exceeds number of )ACTION" RX_T = RX_I CALL SYNTAXFEJL END RX_LVL = LVL_GEM.RX_LVL RETURN SCAN_DO: ARG X_LVL RX_VOID = LOOP_PRIM_MED_SEK(X_LVL , RX_IMBED_MBR IMBED OUT','OUTFUNC','OUTFILE','UNIT.1','UNIT.2) RETURN 0 IMBED_DO: PROCEDURE EXPOSE (RX_EXPLIST) PARSE ARG RX_LVL FUNC IN MBR IMBED, OUT"," OUTFUNC","OUTFILE','UNIT.1","UNIT.2 ADDRESS = '-' /* 2010-10-21 */ IF RX_TRACE='?TRACE' THEN CALL DISPLAY_IMBED_PARMS RX_IMBED_MBR = IMBED /* indlaes imbed-input i prim_input.: */ IF IMBED = "-" THEN DO RX_FMESS = "Variable IMBED must be given a value for )IMBED" CALL SYNTAXFEJL END RX_G_INMEMB = RXINMEMB RXINMEMB = IMBED CALL GET_PRIM_INPUT_BATCH_TSO /* imbed genbruger det i første omgang fastlagte lvl hvergang den */ /* udføres. derfor blankes rx_sou: */ RX_SOU.RX_LVL = "" IF SYMBOL('RX_GEM_OUT') = 'LIT' THEN RX_GEM_OUT = "" CALL PROCES_PRIM_INPUT IF RX_TRACE = '?TRACE' THEN CALL UDSKRIV_RX_SOU INTERPRET RX_SOU.RX_LVL RXINMEMB = RX_G_INMEMB CALL GET_PRIM_INPUT /* 2004-06-28: restore input aht skriv_dir_ud */ RETURN 0 LOOP_PRIM_MED_SEK: PROCEDURE EXPOSE (RX_EXPLIST) PARSE ARG RX_LVL , RX_IMBED_MBR IMBED OUT','OUTFUNC','OUTFILE','UNIT.1','UNIT.2 INTERPRET RX_DEFAU IF RX_TRACE='?TRACE' THEN DO SAY 'SOURCE: ' RX_LVL '-->' RX_SOU.RX_LVL END IF LENGTH(UNIT.1) > 0 THEN DO DO RX_X = 1 TO 999 WORD.RX_X = WORD(UNIT.1,RX_X) /* word. og unit. nedarves */ IF WORD.RX_X = "" THEN LEAVE END END ADDRESS STDOUT RC = 0 RX_PROMPT_LEAVE = 0 INTERPRET RX_ORDERS.RX_LVL IF RC > 11 THEN DO RX_FMESS = 'Syntax error in addressed command in general orders, RC='RC CALL SYNTAXFEJL END IF RC < 0 THEN DO /* 2016-06-07 fx manglende '=' ... */ RX_FMESS = 'Syntax error in general orders, RC='RC CALL SYNTAXFEJL END IF SYMBOL('INSQL') <> 'LIT' THEN DO /* læs INSQL 2017-02-16 */ IF FUNC <> 'WORD' THEN DO /* 2017-09-26 */ RX_FMESS = "FUNC is not valid when using INSQL" CALL SYNTAXFEJL END IN = INSQL FUNC = 'SQL' END IF POS('\',OUT) > 0 THEN DO /* PC WRITE */ RX_FMESS = "Writing to PC or local area network is not supported" CALL SYNTAXFEJL END IF POS('/',OUT) > 0 THEN OUT = TRANSLATE(OUT,'?',' ') IF OUT='' THEN OUT='-' /* hvis OUT blankes, skiftes til STDOUT */ FUNC = TRANSLATE(FUNC) IF RX_IS_TEXT = 1 THEN DO IF FUNC <> 'WORD' THEN DO RX_FMESS = "FUNC is not valid as general order for )TEXT" CALL SYNTAXFEJL END IF IN <> '-' THEN DO RX_FMESS = "IN is not valid as general order for )TEXT" CALL SYNTAXFEJL END END IF SYMBOL('RX_GEM_OUT') = 'LIT' THEN RX_GEM_OUT = "" IF RX_TRACE='?TRACE' THEN CALL DISPLAY_SCAN_PARMS RX_NOTRIG = 0 /* trigger-notrigger start */ IF SYMBOL('RX_TRIGLGD.'RX_LVL) = 'VAR' THEN DO RX_SOURCE = LEFT(RX_SOU.RX_LVL,RX_TRIGLGD.RX_LVL) RX_NOSOURCE = SUBSTR(RX_SOU.RX_LVL,RX_TRIGLGD.RX_LVL + 1) RX_NOTRIG = 1 END /* trigger-notrigger slut */ ELSE DO RX_SOURCE = RX_SOU.RX_LVL END /* denne connect kun for at fejlmelde evt. skift i qmgr: */ IF TRANSLATE(OUTFUNC) = 'MQPUT' THEN CALL MQ_CONNECT IF FUNC = 'BINARY' & (POS('\',IN) = 0 & POS('/',IN) = 0) THEN DO RX_FMESS = "FUNC='BINARY' not valid in this context" IN CALL SYNTAXFEJL END IF POS('\',IN) = 0 THEN DO /* 2015-01-14 dog ikke for PC-fil: */ IF POS('"',IN) > 0 ! POS("'",IN) > 0 THEN DO /* 2008-01-30 */ RX_FMESS = "Value for 'in' contains quote: " IN CALL SYNTAXFEJL END END SELECT WHEN FUNC='WORD' THEN CALL LOOP_PRIM_SEK_WORD WHEN FUNC='BINARY' THEN CALL LOOP_PRIM_SEK_WORD WHEN FUNC='SQL' THEN CALL LOOP_PRIM_SEK_SQL WHEN FUNC='PROMPT' THEN CALL LOOP_PRIM_SEK_PROMPT WHEN FUNC='DCL' THEN CALL LOOP_PRIM_SEK_DCL WHEN FUNC='NAMESPACE' THEN CALL LOOP_PRIM_SEK_NAMESPACE WHEN FUNC='MBR' THEN CALL LOOP_PRIM_SEK_MBR /* CSC-specific */ WHEN FUNC='SORTED' THEN CALL LOOP_PRIM_SEK_WORD WHEN FUNC='SORTED_DESC' THEN CALL LOOP_PRIM_SEK_WORD WHEN FUNC='MQBROWSE' THEN CALL LOOP_PRIM_SEK_WORD WHEN FUNC='MQDRAIN' THEN CALL LOOP_PRIM_SEK_WORD WHEN FUNC='MQDRAINKEY' THEN CALL LOOP_PRIM_SEK_WORD WHEN FUNC='XML' THEN CALL LOOP_PRIM_SEK_XML WHEN FUNC=' '' THEN CALL DO_EXEC_UNIX_CMD END RETURN 0 LOOP_PRIM_SEK_WORD: CONT = "," IF LEFT(FUNC,2) = 'MQ' THEN DO IF IN = '-' THEN DO RX_FMESS = "IN must indicate MQ queuename" RX_FMESS2 = "MQ queuename must be stated in general order 'in'" CALL SYNTAXFEJL END IN = TRANSLATE(IN) CALL MQ_CONNECT SELECT WHEN FUNC = 'MQDRAIN' THEN DO RX_MQ_DONE = 2 /* MQCMIT NØDVENDIG */ ADDRESS ISPEXEC , "SELECT PGM(RXSDO) PARM(Q MQGET "IN RX_MQHANDLE READLIM")" END WHEN FUNC = 'MQDRAINKEY' THEN DO RX_MQ_DONE = 2 /* MQCMIT NØDVENDIG */ RX_TEMP.1 = MQ_MESSID ADDRESS TSO "EXECIO 1 DISKW RXSINP (STEM RX_TEMP. OPEN FINIS)" ADDRESS ISPEXEC "SELECT PGM(RXSDO) PARM(Q MQGETKEY "IN RX_MQHANDLE")" END OTHERWISE DO /* mqbrowse */ ADDRESS ISPEXEC, "SELECT PGM(RXSDO) PARM(Q MQBRW "IN RX_MQHANDLE READLIM")" END END RX_RC = RC IF RX_NOTRIG = 1 THEN DO /* NOTRIGGER ANFØRT */ IF RX_RC = 2085 THEN DO /* ukendt navn på MQ-kø */ CONT = " " ADDRESS STDOUT INTERPRET RX_NOSOURCE RETURN END END ADDRESS TSO "EXECIO * DISKR RXSOUTP (STEM SEK_INPUT. OPEN FINIS)" IF RX_RC > 100 THEN DO RX_B = SEK_INPUT.0 INTERPRET SEK_INPUT.RX_B RX_T = 1 /* placer fejlmeddelelse i top */ CALL SYNTAXFEJL END IF SEK_INPUT.0 >= READLIM THEN DO ZEDSMSG = '' ZEDLMSG = 'MQ reading limited by READLIM =', READLIM' - not all messages read? (more may exist).', 'Func is: ' FUNC'. MQ queue is: ' IN '('mq')' ADDRESS ISPEXEC "SETMSG MSG(ISRZ000)" END END ELSE DO CALL INDLAES_SEK END IF IN = '-' & FUNC <> 'WORD' & SYMBOL('INFILE') = 'LIT' THEN DO RX_FMESS = "FUNC stated for block not using input" RX_FMESS2 = "FUNC manipulates input. But block has no input" CALL SYNTAXFEJL END IF LEFT(FUNC,6) = 'SORTED' THEN DO RX_SORTTYP = 'N' RX_ASC_DESC = 'A' RX_LANGSORT = 'N' IF FUNC = 'SORTED_DESC' THEN RX_ASC_DESC = 'D' ADDRESS ISPEXEC "CONTROL ERRORS RETURN" "TBCREATE RXSORTT NAMES(RXUNIT1 RXUNIT2) NOWRITE SHARE" IF RC > 8 THEN CALL ISPF_GETMSG('TBEND RXSORTT') RX_LANGSORT_2 = 'N' DO RX_B = 1 TO SEK_INPUT.0 RXUNIT1 = SEK_INPUT.RX_B IF RX_SORTTYP = 'N' THEN DO IF DATATYPE(RXUNIT1) = 'CHAR' THEN RX_SORTTYP = 'C' IF DATATYPE(RXUNIT1) = 'NUM' & RXUNIT1 > 2147483647 THEN DO SAY "*** RXS Note: alphanumeric sort is done:", "numeric larger than 2147483647 is found. IN is '"IN"'." RX_SORTTYP = 'C' END /* 2016-08-17: & i betingelse nedenfor: */ IF LENGTH(RXUNIT1) > 16 & RX_SORTTYP = 'N' THEN DO SAY "*** RXS Note: alphanumeric sort is done:", "numeric input, but length of unit.1 is greater than 16 byte" RX_SORTTYP = 'C' /* 2016-05-30 */ END END IF LENGTH(RXUNIT1) > 256 THEN DO RX_LANGSORT = 'J' END IF LENGTH(RXUNIT1) > 4000 THEN DO RX_LANGSORT = 'L' END IF LENGTH(RXUNIT1) > 32756 THEN DO /* 2014-01-02 */ RX_FMESS = "Records (UNIT.1) longer than 32756 byte", "cannot be sorted" CALL SYNTAXFEJL END IF SYMBOL('SEK_INPUT_2.'RX_B) = 'VAR' THEN DO IF LENGTH(SEK_INPUT_2.RX_B) > 0 THEN DO RXUNIT2 = SEK_INPUT_2.RX_B RX_LANGSORT_2 = 'J' END END ELSE DO RXUNIT2 = "" END IF RX_LANGSORT = 'N' THEN DO "TBADD RXSORTT" END END IF RX_TRACE = '?TRACE' THEN DO say 'sorted: sorttyp: ' rx_sorttyp 'langsort: ' rx_langsort end IF RX_LANGSORT = 'N' THEN DO "TBSORT RXSORTT FIELDS(RXUNIT1 "RX_SORTTYP" "RX_ASC_DESC")" IF RC > 0 THEN CALL ISPF_GETMSG('TBEND RXSORTT') /* 2013-08-28 */ "TBTOP RXSORTT" DO RX_B = 1 TO SEK_INPUT.0 "TBSKIP RXSORTT" SEK_INPUT.RX_B = RXUNIT1 SEK_INPUT_2.RX_B = RXUNIT2 END "TBEND RXSORTT" END ELSE DO /* SORTER UD OVER 256 BYTE */ IF RX_LANGSORT_2 = 'J' THEN DO RX_FMESS = "Cannot sort '"in"'. UNIT.1 longer than 256 byte", "and UNIT.2 is present" CALL SYNTAXFEJL END IF RX_LANGSORT = 'L' THEN DO SAY 'RXS: Note: "'in'" Record longer than 4000 bytes processed' SAY ' Only first 4000 byte determine sequence' SAY ' Using alphanumeric sort on first 4000 bytes' END ALLOC_DO("SORTIN - 32756") ALLOC_DO("SORTOUT - 32756") ALLOC_DO("SYSIN") ALLOC_DO("SYSOUT") ADDRESS TSO "EXECIO * DISKW SORTIN (STEM SEK_INPUT. OPEN FINIS)" RX_HOVSA.1 = LEFT(" SORT FIELDS=(4,4000,CH,"RX_ASC_DESC")",80) "EXECIO 1 DISKW SYSIN (STEM RX_HOVSA. OPEN FINIS)" ADDRESS ISPEXEC "SELECT PGM(SORT)" IF RC > 0 THEN DO IF RX_KALDTYP = 'BATCH' THEN DO ADDRESS TSO "EXECIO * DISKR SYSOUT (STEM SEK_INPUT. OPEN FINIS)" DO RX_I = 1 TO SEK_INPUT.0 SAY SEK.INPUT.RX_I END END ELSE DO ZEDSMSG = 'SORT ended in error' ADDRESS ISPEXEC "SETMSG MSG(ISRZ000)" "LMINIT DATAID(RXSOUTP) DDNAME(SYSOUT) ORG(INDORG) ENQ(SHR)" "BROWSE DATAID(&RXSOUTP)" END RX_FMESS = "SORT ended in error" CALL SYNTAXFEJL END ADDRESS TSO "EXECIO * DISKR SORTOUT (STEM SEK_INPUT. OPEN FINIS)" "FREE FI(SORTIN)" "FREE FI(SORTOUT)" "FREE FI(SYSIN)" "FREE FI(SYSOUT)" END ADDRESS STDOUT END IF FUNC = ' 0 THEN RX_WRD = 1 DO RX_B = 1 TO SEK_INPUT.0 WORD. = "" IF RX_B = SEK_INPUT.0 THEN CONT = " " IF LEFT(FUNC,2) = 'MQ' THEN DO /* mqbrowse - mqdrain */ MQ_BACKOUT = SUBSTR(SEK_INPUT.RX_B,3,4) MQ_MESSID = SUBSTR(SEK_INPUT.RX_B,8,24) MQ_PUTDATE = SUBSTR(SEK_INPUT.RX_B,33,8) MQ_PUTTIME = SUBSTR(SEK_INPUT.RX_B,42,8) MQ_APPLNAME = SUBSTR(SEK_INPUT.RX_B,51,28) MQ_APPLTYPE = SUBSTR(SEK_INPUT.RX_B,80,11) UNIT.1 = '' DO FOREVER /* konkatener hvis over 7900 byte: */ UNIT.1 = UNIT.1!!SUBSTR(SEK_INPUT.RX_B,92) IF LEFT(SEK_INPUT.RX_B,1) = ' ' THEN LEAVE RX_B = RX_B + 1 IF RX_B = SEK_INPUT.0 THEN CONT = " " END END ELSE DO UNIT.1 = SEK_INPUT.RX_B END IF SYMBOL('SEK_INPUT_2.'RX_B) = 'VAR' THEN DO UNIT.2 = SEK_INPUT_2.RX_B END ELSE DO UNIT.2 = "" END IF RX_WRD = 1 THEN DO DO RX_X=1 TO 99999 WORD.RX_X = WORD(UNIT.1,RX_X) IF WORD.RX_X = "" THEN LEAVE END END INTERPRET RX_SOURCE END IF RX_NOTRIG = 1 THEN DO IF SEK_INPUT.0 = 0 THEN INTERPRET RX_NOSOURCE END RETURN LOOP_PRIM_SEK_SQL: NUMERIC DIGITS 30 /* 2014-11-26 */ IF RX_SQL_DONE = '' THEN CALL RXSSPUFI_OPEN_OPEN CALL RXSSPUFI_OPEN IF RX_SQL_KALDTYPE = 'S' THEN DO CALL RXSSPUFI_FETCH DO RX_IC = 1 TO 10000000 IF SQLCODE <> 0 THEN LEAVE INTERPRET RX_STMT SQLVALUES = RX_SQLROW CALL RXSSPUFI_FETCH IF SQLCODE = 0 THEN DO CONT = ',' END ELSE DO CONT = ' ' END INTERPRET RX_SOURCE END CALL RXSSPUFI_CLOSE IF RX_NOTRIG = 1 THEN DO IF RX_FETCH_ANT = 0 THEN INTERPRET RX_NOSOURCE END END IF RX_SQL_KALDTYPE <> 'S' THEN DO /* ikke select-kald */ SQLVALUES = '' IF SQLCODE = 0 THEN DO CONT = ' ' INTERPRET RX_SOURCE END IF SQLCODE > 0 THEN DO IF RX_NOTRIG = 1 THEN INTERPRET RX_NOSOURCE END END NUMERIC DIGITS 15 /* 2014-11-26 */ RETURN LOOP_PRIM_SEK_PROMPT: CALL DISPLAY_PROMPT_PANEL IF RX_PROMPT_LEAVE = 0 THEN DO IF RX_NOTRIG = 0 THEN INTERPRET RX_SOU.RX_LVL IF RX_NOTRIG = 1 THEN DO IF RX_PANEX = 'X' THEN DO INTERPRET RX_NOSOURCE END ELSE DO INTERPRET RX_SOURCE END END END RETURN DISPLAY_PROMPT_PANEL: RX_LDESC = 1 RX_LVAR = 1 IF IN = '-' THEN DO RX_FMESS = "FUNC=PROMPT :IN must be specified" CALL SYNTAXFEJL END CALL INDLAES_SEK DO RX_B = 1 TO SEK_INPUT.0 RX_PVAR.RX_B = STRIP(SEK_INPUT.RX_B) /* 2008-08-19 ej 'T' */ IF LENGTH(RX_PVAR.RX_B) > RX_LVAR THEN RX_LVAR = LENGTH(RX_PVAR.RX_B) IF SYMBOL(RX_PVAR.RX_B) = 'BAD' THEN DO IF POS(',',RX_PVAR.RX_B) > 0 THEN DO RX_FMESS =, 'PROMPT: input has to be an action-block or active coding, not', 'a text-block. Variable: 'RX_PVAR.RX_B' is not a variable' END ELSE DO RX_FMESS = "PROMPT: Variable: "RX_PVAR.RX_B "... is not a", "variable. PROMPT uses a list of variables and descriptions", "like: 'HUGO', 'Set a value for hugo'" END CALL SYNTAXFEJL END RX_VOID = PUT_I_EXPLIST(RX_PVAR.RX_B) IF SEK_INPUT_2.RX_B > "" THEN DO RX_DESC.RX_B = SEK_INPUT_2.RX_B IF LENGTH(RX_DESC.RX_B) > RX_LDESC THEN RX_LDESC = LENGTH(RX_DESC.RX_B) END ELSE DO RX_DESC.RX_B = "" END END RX_PVAR.0 = SEK_INPUT.0 IF RX_B = 1 THEN DO RX_FMESS = 'PROMPT: IN='IN' - this queue is empty' CALL SYNTAXFEJL END IF SYMBOL('CAPS') = 'LIT' THEN CAPS = "ON" IF SYMBOL('PROMPTLGTH') = 'LIT' THEN PROMPTLGTH = 42 IF SYMBOL('PROMPTSOURCE') = 'LIT' THEN PROMPTSOURCE = 'U' IF SYMBOL('RXRAKANT') = 'LIT' THEN RXRAKANT = 0 IF SYMBOL('PROMPTALL') = 'LIT' THEN PROMPTALL = 'Y' IF PROMPT = "" THEN PROMPT = 'PROMPT' /* isf 0000 2006-01-20 */ PROMPT = STRIP(PROMPT) /* 2007-01-29 */ IF LENGTH(PROMPT) > 6 THEN DO RX_FMESS = "RXS: PROMPT='"PROMPT"' is longer than 6 characters" CALL SYNTAXFEJL END RX_PANEX = ' ' /* flyttet 2016-10-19 */ IF RX_KALDTYP = 'BATCH' THEN DO /* batch */ PROMPT = TRANSLATE(PROMPT) /* btc */ RX_PRSVAR. = "" /* btc */ RX_PRMT_SW = 0 /* btc */ ADDRESS TSO "EXECIO * DISKR "PROMPT" (STEM RX_PRSVAR. OPEN FINIS)" IF RC > 0 THEN DO IF PROMPT = 'PROMPT' THEN DO /* btc */ ADDRESS TSO "EXECIO * DISKR PARM0000 (STEM RX_PRSVAR. OPEN FINIS)" END /* btc */ ELSE DO /* btc */ IF LENGTH(PROMPT) < 5 THEN DO ADDRESS TSO "EXECIO * DISKR PARM"PROMPT" (STEM RX_PRSVAR. OPEN FINIS)" END /* btc */ END /* btc */ END /* btc */ IF RC > 0 THEN DO /* btc */ RX_FMESS = "RXS: 'PROMPT' used. //"PROMPT" missing in JCL" CALL SYNTAXFEJL /* btc */ END /* btc */ SAY "RXS: Values assigned by //"PROMPT" in JCL: ------" /* btc */ NAMESPACE_1 = '(' /* btc */ NAMESPACE_2 = ')' /* btc */ DO RX_P = 1 TO RX_PVAR.0 /* 2016-10-19 initialiser btc */ RX_PROMPT_SOURCE = RX_PVAR.RX_P" = ''" /* btc */ INTERPRET RX_PROMPT_SOURCE /* btc */ END /* btc */ DO RX_P=1 TO RX_PRSVAR.0 /* btc */ RX_PROMPT_SOURCE = PARMSPACE(STRIP(LEFT(RX_PRSVAR.RX_P,72))) SAY RX_PROMPT_SOURCE /* btc */ INTERPRET RX_PROMPT_SOURCE /* btc */ END /* 2016-10-19 promptall tilføjet: btc */ IF RX_PRSVAR.0 < RX_PVAR.0 THEN DO /* btc */ IF TRANSLATE(PROMPTALL) = 'Y' THEN DO /* btc */ RX_FMESS = "RXS: //"PROMPT" in JCL must ", /* batch */ "contain "RX_PVAR.0" values. Only "RX_PRSVAR.0" found" /* batch */ CALL SYNTAXFEJL /* batch */ END /* batch */ END /* batch */ SAY "RXS: End of list of values --------------------" /* batch */ RETURN /* batch */ END /* end batch */ RXCTAB = "RX"PROMPT ADDRESS ISPEXEC "CONTROL ERRORS RETURN" DO FOREVER /* table dan: */ "TBSTATS &RXCTAB ROWCURR(RXRAKANT) STATUS1(CTST1) STATUS2(CTST2)" IF SYMBOL('RXRAKANT') = 'LIT' ! RXRAKANT = 0 THEN DO IF PROMPTLGTH = 0 THEN DO RX_FMESS = "PROMPTLGTH=0 but user has not responded to this", "prompt '"PROMPT"' earlier in this tso-session" CALL SYNTAXFEJL END PRSVAR = "" "TBEND &RXCTAB" "TBCREATE &RXCTAB KEYS(PRVAR) NAMES(PRSVAR PRDESC) NOWRITE" IF RC > 0 THEN CALL ISPF_GETMSG("TBEND "RXCTAB) DO RX_DS = 1 TO RX_PVAR.0 IF RX_PVAR.RX_DS > "" THEN DO PRVAR = RX_PVAR.RX_DS PRDESC = RX_DESC.RX_DS PRSVAR = '' IF SYMBOL(PRVAR) <> 'LIT' THEN DO /* 2006-08-24 */ RX_INTERPRET = 'PRSVAR = 'PRVAR INTERPRET RX_INTERPRET END END "TBADD &RXCTAB" IF RC = 8 THEN DO RX_FMESS = "Variable-name '"PRVAR"' is duplicate in prompt" CALL SYNTAXFEJL END END END ELSE DO "TBOPEN &RXCTAB" "TBTOP &RXCTAB" "TBSKIP &RXCTAB" DO RX_DS = 1 TO RX_PVAR.0 IF PRVAR = RX_PVAR.RX_DS & RXRAKANT = RX_PVAR.0 &, (PRDESC = RX_DESC.RX_DS ! PROMPTLGTH = 0) THEN DO "TBSKIP &RXCTAB" ITERATE END "TBEND &RXCTAB" /* skifte i beskrivelse/navn: drop tabellen */ "TBDELETE &RXCTAB" PRSVAR = "" RXRAKANT = 0 LEAVE END END IF RXRAKANT = 0 THEN ITERATE LEAVE END IF POS(TRANSLATE(PROMPTSOURCE), ' PUI') = 0 THEN DO RX_FMESS = "Invalid value for PROMPTSOURCE: "PROMPTSOURCE CALL SYNTAXFEJL END IF TRANSLATE(PROMPTSOURCE) <> 'U' THEN DO /* 2004-11-26 */ "TBTOP &RXCTAB" "TBSKIP &RXCTAB" DO RX_DS = 1 TO RX_PVAR.0 /* opsæt evt. default værdier */ IF SYMBOL(PRVAR) ^= 'LIT' THEN DO /* default opsat i RXS pgm */ IF PRSVAR = '' ! TRANSLATE(PROMPTSOURCE) = 'P' THEN DO RX_INTERPRET = 'PRSVAR = ' PRVAR INTERPRET RX_INTERPRET "TBMOD &RXCTAB" END END IF TRANSLATE(PROMPTSOURCE) = 'I' THEN DO PRSVAR = '' "TBMOD &RXCTAB" END "TBSKIP &RXCTAB" END END "TBTOP &RXCTAB" "TBSKIP &RXCTAB" DO FOREVER /* RXTAB_VIS */ IF SYMBOL('RXINMEMB') = 'LIT' THEN RXINMEMB = "" IF SYMBOL('ZWINTTL') = 'LIT' THEN ZWINTTL = "" IF ZWINTTL = "" THEN ZWINTTL = RXINMEMB 'Enter values' IF PROMPTLGTH > 0 THEN DO IF RX_PROMPT_GEM_LVL > RX_LVL THEN DO PROMPTLGTH = 0 RX_PROMPT_OK_LVL = RX_LVL END END IF PROMPTLGTH > 0 THEN DO /* ved PROMPTLGTH 0 vises panelet ikke */ RX_ADDPOP = 0 /* lokal variabel */ IF RX_LDESC + RX_LVAR = 64 THEN RX_LDESC = RX_LDESC + 1 RX_LLGTH = RX_LVAR + RX_LDESC + PROMPTLGTH /* ovenståede: */ SELECT /* sær fejl i ISPF */ WHEN RX_LLGTH < 77 THEN DO /* 2006-09-01 */ if rx_ldesc = 65 then rx_ldesc = 66 /* 2015-09-23 sær fejl */ RXMOD1 = 'OMIT' /* alt én linie */ RXMOD2 = 'OMIT' RXMOD3 = , ';'LEFT('Z',RX_LDESC)']'LEFT('Z',RX_LVAR)'['LEFT('Z',PROMPTLGTH)'+' IF RX_LLGTH < 62 & RX_PVAR.0 < 20 THEN RX_ADDPOP = 1 END /* 2008-10-09: rx_pvar.0 indlagt heromkring */ WHEN RX_LVAR + PROMPTLGTH < 74 THEN DO RXMOD1 = 'OMIT' /* to linier: desc / var prompt */ RXMOD2 = ';Z' RXMOD3 = ' ]'LEFT('Z',RX_LVAR)'['LEFT('Z',PROMPTLGTH)'+' IF RX_LVAR + PROMPTLGTH < 62 & RX_LDESC < 62 THEN RX_ADDPOP = 1 IF RX_PVAR.0 > 9 THEN RX_ADDPOP = 0 END WHEN PROMPTLGTH > 75 THEN DO IF PROMPTLGTH > 153 - RX_LVAR THEN PROMPTLGTH = 153 - RX_LVAR RXMOD1 = ';Z' /* 3 linier */ RXMOD2 = ' ]'LEFT('Z',RX_LVAR)'[Z' RXMOD3 = RIGHT('+',PROMPTLGTH - 73 + RX_LVAR) END WHEN RX_LVAR + RX_LDESC < 75 THEN DO RXMOD1 = 'OMIT' /* 2 linier: desc var / prompt */ RXMOD2 = ';'LEFT('Z',RX_LDESC)']'LEFT('Z',RX_LVAR) RXMOD3 = LEFT(' ['LEFT('Z',PROMPTLGTH)'+',80) IF PROMPTLGTH < 62 & RX_LVAR 0 RX_LDESC < 62 THEN RX_ADDPOP = 1 IF RX_PVAR.0 > 9 THEN RX_ADDPOP = 0 END OTHERWISE DO RXMOD1 = ';Z' RXMOD2 = ' ]Z' RXMOD3 = LEFT(' ['LEFT('Z',PROMPTLGTH)'+',80) END END IF RXRAKANT > 20 THEN RX_ADDPOP = 0 IF LENGTH(ZWINTTL) > 65 THEN DO ZEDLMSG = ZWINTTL ZWINTTL = '' "SETMSG MSG(ISRZ000) COND" /* 2022-02-16 COND tilføjet */ END IF RX_ADDPOP = 1 THEN DO /* "ADDPOP ROW(2) COLUMN("RANDOM(2,12)")" HOVSA */ RX_COL = RX_LVL IF RX_COL > 12 THEN RX_COL = 12 "ADDPOP ROW(2) COLUMN("RX_COL")" PROMPTMS = '' END ELSE DO PROMPTMS = ZWINTTL END RXF3TXT = 'exit' IF RX_PROMPT_OK_LVL > 0 THEN RXF3TXT = 'previous' IF RX_NOTRIG = 1 THEN RXF3TXT = 'alternate' "TBDISPL &RXCTAB PANEL(RXSPAN) POSITION(CRP) CURSOR(PRSVAR)" IF RC > 8 THEN DO SAY "Installation error? Panel 'RXSPAN' fails" CALL ISPF_GETMSG('REMPOP') END IF RC = 8 THEN DO /* der er trykket f3 */ RX_PANEX = 'X' IF RX_ADDPOP = 1 THEN "REMPOP" SELECT WHEN RX_NOTRIG = 1 THEN DO RX_PROMPT_OK_LVL = 0 RETURN END OTHERWISE DO IF RX_LVL <= RX_PROMPT_OK_LVL THEN RX_PROMPT_OK_LVL = 0 IF RX_PROMPT_OK_LVL = -1 THEN RX_PROMPT_OK_LVL = 0 RX_PROMPT_LEAVE = 1 RETURN END END END DO WHILE RC < 8 /* opdater med indtastninger på skærm: */ IF ZTDSELS > 0 THEN DO DO FOREVER "TBPUT &RXCTAB" IF ZTDSELS = 1 THEN LEAVE "TBDISPL &RXCTAB" END END IF ZCMD <> '' THEN RXEXECUT = 0 IF RXEXECUT THEN LEAVE "TBDISPL &RXCTAB PANEL(RXSPAN)" END IF RC > 8 THEN DO "SETMSG MSG("ZERRMSG")" "TBEND &RXCTAB" IF RX_ADDPOP = 1 THEN "REMPOP" CALL EXIT_I_UTIDE 0 END IF RX_ADDPOP = 1 THEN "REMPOP" "TBTOP &RXCTAB" "TBSKIP &RXCTAB" DO FOREVER IF RC > 0 THEN LEAVE IF PRSVAR = "" & TRANSLATE(PROMPTALL) = 'Y' THEN DO IF RX_PANEX = 'X' THEN DO CALL EXIT_I_UTIDE 0 END ZEDSMSG = "Enter value" ZEDLMSG = "This variable must be assigned a value" CALL ISPF_MESS LEAVE END "TBSKIP &RXCTAB" IF RC > 0 THEN LEAVE END IF PRSVAR = "" & TRANSLATE(PROMPTALL) = 'Y' THEN ITERATE END /* DVS TILBAGE TIL RXTAB_VIS */ "TBTOP &RXCTAB" "TBSKIP &RXCTAB" DO FOREVER IF RC > 0 THEN LEAVE RX_PROMPT_SOURCE = PRVAR ' = "'PRSVAR'"' INTERPRET RX_PROMPT_SOURCE "TBSKIP &RXCTAB" IF RC > 0 THEN LEAVE END ZEDSMSG = "" ZEDLMSG = "" LEAVE END IF PROMPTLGTH > 0 & , RX_PROMPT_OK_LVL < RX_LVL THEN RX_PROMPT_OK_LVL = RX_LVL RETURN INDLAES_SEK: IF SYMBOL('GL_DSN') = 'LIT' THEN GL_DSN = "-" IF SYMBOL('GL_MBR') = 'LIT' THEN GL_MBR = "-" IF IN = '-' THEN DO IF SYMBOL('INFILE') <> 'LIT' THEN DO /* læs INFILE */ IF RX_KALDTYP = 'BATCH' THEN DO ADDRESS TSO, "EXECIO "READLIM" DISKR "INFILE READFRST" (STEM SEK_INPUT. OPEN FINIS)" IF RC > 2 THEN DO RX_FMESS = 'Batch reading INFILE: 'INFILE 'RC is' RC CALL SYNTAXFEJL END IF SEK_INPUT.0 >= READLIM THEN DO SAY 'Reading limited by READLIM='READLIM' - when reading from' IN END RETURN END ELSE DO IN = SYSVAR('SYSUID')'.'INFILE'.DATA' END END ELSE DO SEK_INPUT.0 = 1 /* simulerer tomt input */ SEK_INPUT.1 = "" RETURN END END SELECT WHEN POS('\',IN) > 0 THEN DO /* PC read */ RX_FMESS = "Reading from PC or local area network is not supported" CALL SYNTAXFEJL END WHEN POS('/',IN) > 0 THEN DO /* læs UNIX fil */ CALL SYSCALLS 'ON' /* connect til unix */ ADDRESS SYSCALL /* connect til unix */ "READDIR (IN) RX_DIR. RX_DIR_2." IF ERRNOJR = 0 THEN DO /* er directory */ RX_II = 0 /* 2015-07-17 læs UNIX directory: */ ADDRESS ISPEXEC "CONTROL ERRORS RETURN" /* 2019-08-19 Sorter UNIX directory */ "TBCREATE RXSORTQ NAMES(RXUNIT1 RXUNIT2) NOWRITE SHARE" DO RX_I = 1 TO RX_DIR.0 IF LEFT(RX_DIR.RX_I,1) <> '4B'X THEN DO RXUNIT1 = RX_DIR.RX_I RXUNIT2 = '' IF RX_DIR_2.RX_I.ST_TYPE = 3 THEN RXUNIT2 = 'FIL' IF RX_DIR_2.RX_I.ST_TYPE = 1 THEN RXUNIT2 = 'DIR' "TBADD RXSORTQ" RX_II = RX_II + 1 END END "TBSORT RXSORTQ FIELDS(RXUNIT1 B A)" "TBTOP RXSORTQ" DO RX_I = 1 TO RX_II "TBSKIP RXSORTQ" SEK_INPUT.RX_I = RXUNIT1 SEK_INPUT_2.RX_I = RXUNIT2 END SEK_INPUT.0 = RX_II "TBEND RXSORTQ" ADDRESS STDOUT /* 2019-08-19 Sorter SLUT */ END ELSE DO IF ERRNOJR = '55E0071' THEN DO /* this is not a directory */ "OPEN "IN O_RDONLY /* check af læse-adgang */ RX_FD = RETVAL /* find fil-nummer */ IF ERRNOJR <> 0 THEN DO RXSWA = REVERSE(IN) RX_I = POS('/',RXSWA) RXDI = REVERSE(SUBSTR(RXSWA,RX_I)) RXFI = REVERSE(LEFT(RXSWA,RX_I - 1)) IF ERRNOJR = '55E0072' THEN DO IF RX_NOTRIG = 1 THEN DO SEK_INPUT.0 = 0 END ELSE DO CALL SYNTAXFEJL "UNIX: The file "RXFI" is not found in directory" RXD I END END ELSE DO W_ERRNOJR = ERRNOJR "STRERROR" ERRNO ERRNOJR "XX_ERR." CALL SYNTAXFEJL 'UNIX: 'W_ERRNOJR XX_ERR.SE_ERRNO '. Directory is: 'RXDI END END "CLOSE" RX_FD ADDRESS TSO "ALLOC FI(RXSINP) PATH('"IN"') PATHOPTS(ORDONLY) REUSE", "FILEDATA(BINARY) pathmode(sirwxu,sirwxg,siroth)" ADDRESS ISPEXEC "SELECT PGM(RXSDO) PARM(C NOCONV 0 0)" IF RC > 0 THEN DO SAY "Instalation error? Attempt to call loadmodule RXSDO fails" END ADDRESS TSO , "EXECIO "READLIM" DISKR RXSOUTP "READFRST" (STEM SEK_INPUT. OPEN FINIS)" IF SEK_INPUT.0 >= READLIM THEN DO SAY 'Reading limited by READLIM='READLIM' - when reading from' IN SAY 8008 * READLIM 'byte is read' END RX_STRNG = '' DO RX_I = 1 TO SEK_INPUT.0 RX_STRNG = RX_STRNG""SEK_INPUT.RX_I END IF FUNC = 'BINARY' THEN DO /* aflever i én streng 2010-01-22 */ SEK_INPUT.1 = RX_STRNG SEK_INPUT.0 = 1 SEK_INPUT_2.1 = '' END ELSE DO /* del op jvf. x15 */ RX_STRT = 0 RX_GLSTRT = 1 DO RX_I = 1 TO 9999999 SEK_INPUT_2.RX_I = '' RX_STRT = POS('15'X,RX_STRNG,RX_GLSTRT) IF RX_STRT = 0 THEN DO /* 2010-02-05 */ SEK_INPUT.RX_I = SUBSTR(RX_STRNG,RX_GLSTRT) IF SEK_INPUT.RX_I <> '' THEN RX_I = RX_I + 1 LEAVE END SEK_INPUT.RX_I = SUBSTR(RX_STRNG,RX_GLSTRT,RX_STRT - RX_GLSTRT) RX_GLSTRT = RX_STRT + 1 END SEK_INPUT.0 = RX_I - 1 END RX_VOID = ALLOC_DO('RXSINP') /* genskab normal allokering */ END ELSE DO IF RX_NOTRIG = 1 THEN DO SEK_INPUT.0 = 0 END ELSE DO W_ERRNOJR = ERRNOJR "STRERROR" ERRNO ERRNOJR "XX_ERR." CALL SYNTAXFEJL 'UNIX: 'W_ERRNOJR XX_ERR.SE_ERRNO END END END END WHEN POS('.',IN) = 0 THEN DO /* læs af intern kø */ IF SYMBOL(IN) = 'BAD' THEN DO RX_FMESS = "Bad syntax in IN: "IN RX_FMESS2 = 'Enter a datasetname or a valid REXX variable name' CALL SYNTAXFEJL END IF SYMBOL('RX_GLB.'IN'_STEMIX') = 'LIT', ! VALUE('RX_GLB.'IN'_STEMIX') = 0 THEN DO IF RX_NOTRIG = 1 THEN DO /* )NOTRIGGER anført */ SEK_INPUT.0 = 0 RETURN END RX_FMESS = 'IN = "'IN'": Queue "'IN'" is empty (void)' IF TRANSLATE(IN) = 'EDIT_SCREEN' THEN DO /* 2008-10-01 */ RX_FMESS = "Must be called as macro from edit: ==> RXS !"RXINMEMB END CALL SYNTAXFEJL END SEK_INPUT.0 = VALUE('RX_GLB.'IN'_STEMIX') IF SEK_INPUT.0 > READLIM THEN DO SEK_INPUT.0 = READLIM SAY 'Reading limited by READLIM='READLIM' - when reading from' IN END DO RXX = 1 TO SEK_INPUT.0 SEK_INPUT.RXX = VALUE('RX_GLB.'IN'_1.'RXX) IF SYMBOL('RX_GLB.'IN'_2.'RXX) = 'VAR' THEN DO SEK_INPUT_2.RXX = VALUE('RX_GLB.'IN'_2.'RXX) END ELSE SEK_INPUT_2.RXX = "" END GL_DSN = IN RETURN END WHEN POS('*',IN) > 0 & POS('(',IN) = 0 THEN DO /* generisk dsn-liste */ RXX = 0 ADDRESS ISPEXEC "LMDINIT LISTID(RXDSLI) LEVEL("IN")" IF RC > 0 THEN CALL ISPF_GETMSG /* 2014-04-11 */ DO FOREVER "LMDLIST LISTID("RXDSLI") OPTION(LIST) DATASET(RXDSVAR) STATS(NO)" IF RC > 0 THEN DO IF RXX = 0 THEN DO /* notrigger situation */ ADDRESS STDOUT SEK_INPUT.0 = 0 RETURN END LEAVE END RXX = RXX + 1 SEK_INPUT.RXX = STRIP(RXDSVAR) SEK_INPUT_2.RXX = 'FIL' /* 2015-07-17 */ END SEK_INPUT.0 = RXX "LMDFREE LISTID("RXDSLI")" ADDRESS STDOUT END OTHERWISE DO /* standard læs af sekventiel fil */ IF IN = GL_DSN & IN <> '-' THEN DO RETURN END GL_DSN = IN SEK_INPUT.0 = 0 IF SYMBOL('IN') = 'LIT' THEN IN = "-" ADDRESS TSO IF IN = "-" & LISTDSI('RXSEKINP' 'FILE') = 0 THEN DO END ELSE DO IF IN = "-" THEN DO RX_FMESS = "Variable IN not assigned a value" CALL SYNTAXFEJL END RXSEKINP = "'"IN"'" RX_RC = LISTDSI(RXSEKINP) IF SYSDSORG = 'PO' THEN DO IF POS('(',IN) = 0 THEN DO /* list members */ RX_SSX = SYSDSN(RXSEKINP) /* 2017-06-09: Kontroller dsn */ IF RX_SSX = 'DATASET NOT FOUND' & RX_NOTRIG = 1 THEN DO SEK_INPUT.0 = 0 /* åbn notrigger vejen 2005-06-07 */ RETURN END IF RX_SSX ^= 'OK' THEN DO ZEDSMSG = "" /* 2021-10-12 rettet til 50: */ ZEDLMSG = "IN = "RXSEKINP": "STRIP(LEFT(RX_SSX,50)) RX_IMBED_MBR = '-' CALL ISPF_MESS CALL EXIT_I_UTIDE 8 END /* 2017-06-09: Kontroller dsn SLUT */ IF FUNC <> 'WORD' THEN DO /* 2014-09-10 */ RX_FMESS = "FUNC="FUNC" is invalid when listing members", "(missing member-name in IN ?)" CALL SYNTAXFEJL END RXX = 0 ADDRESS ISPEXEC "LMINIT DATAID(RXSSEK) DATASET('"IN"') ORG(DSORG) ENQ(SHR)" "LMOPEN DATAID(&RXSSEK)" RXMBR = ' ' RX_LMMCNT = 0 /* CSC-specific */ DO FOREVER /* CSC-specific */ "LMMLIST DATAID(&RXSSEK) MEMBER(RXMBR) STATS(YES)" /* CSC-specific */ IF RC >= 4 THEN LEAVE /* CSC-specific */ RX_LMMCNT = RX_LMMCNT + 1 /* CSC-specific */ END /* CSC-specific */ "LMMLIST DATAID(&RXSSEK) MEMBER(RXMBR) STATS(YES) OPTION(FREE)" /* CSC-specific */ RXMBR = "" /* CSC-specific */ RX_LMMCNT_1 = 0 /* CSC-specific */ DO FOREVER /* CSC-specific */ ADDRESS ISPEXEC /* CSC-specific */ "LMMLIST DATAID(&RXSSEK) MEMBER(RXMBR) STATS(YES)" /* CSC-specific */ IF RC >= 4 THEN LEAVE /* CSC-specific */ UNIT.1 = STRIP(RXMBR) /* CSC-specific */ WORD. = '' /* CSC-specific */ WORD.1 = UNIT.1 /* CSC-specific */ UNIT.2 = 'MEM' /* 2015-07-17 */ RX_NOTRIG = 0 /* undgå notrigger-sitation/SEK_INPUT.0 = 0 */ RX_LMMCNT_1 = RX_LMMCNT_1 + 1 /* CSC-specific */ IF RX_LMMCNT_1 = RX_LMMCNT THEN CONT = " " /* CSC-specific */ ADDRESS STDOUT /* CSC-specific */ INTERPRET RX_SOURCE END /* CSC-specific */ ADDRESS ISPEXEC /* CSC-specific */ "LMMLIST DATAID(&RXSSEK) MEMBER(RXMBR) STATS(NO) OPTION(FREE)" "LMCLOSE DATAID(&RXSSEK)" "LMFREE DATAID(&RXSSEK)" ADDRESS STDOUT RETURN END END RX_SSX = SYSDSN(RXSEKINP) IF RX_SSX = 'MEMBER NOT FOUND' & RX_NOTRIG = 1 THEN DO SEK_INPUT.0 = 0 /* åbn notrigger vejen 2004-11-18 */ RETURN END IF RX_SSX = 'DATASET NOT FOUND' & RX_NOTRIG = 1 THEN DO SEK_INPUT.0 = 0 /* åbn notrigger vejen 2005-06-07 */ RETURN END IF RX_SSX ^= 'OK' THEN DO ZEDSMSG = "" /* 2021-10-12 rettet til 50: */ ZEDLMSG = "IN = "RXSEKINP": "STRIP(LEFT(RX_SSX,50)) RX_IMBED_MBR = '-' CALL ISPF_MESS CALL EXIT_I_UTIDE 8 END "ALLOC FI(RXSEKINP) SHR REUSE DA("RXSEKINP")" END /* 2018-04-03: */ if pos('(',in) > 0, /* hvis load eller ZLvars, brug ISPF læs: */ & (SYSRECFM = 'U' ! POS('ZL',TRANSLATE(RX_SOURCE)) > 0) then do call read_member end else do "EXECIO "READLIM" DISKR RXSEKINP "READFRST" (STEM SEK_INPUT. OPEN FINIS)" IF RC = 20 THEN DO RX_FMESS = 'Dataset 'IN' has invalid blocksize?' CALL SYNTAXFEJL end END IF SEK_INPUT.0 >= READLIM THEN DO SAY 'Reading limited by READLIM='READLIM' - when reading from' IN END "FREE FI(RXSEKINP)" END /* (??) */ END IF POS('\',IN) > 0 ! POS('/',IN) > 0 ! POS('*',IN) > 0 THEN DO RX_SEKTYPE = 'DATA' RX_NUM_72 = '' END ELSE DO RX_P = POS('(',RXSEKINP)/* 2005-01-05 kun COBOL hvis sidste quali */ IF RX_P = 0 THEN RX_P = LENGTH(RXSEKINP) - 1 RX_SEKTYPE = TRANSLATE(SUBSTR(RXSEKINP, RX_P - 5, 5)) IF RX_SEKTYPE <> 'COBOL' THEN RX_SEKTYPE = 'DATA' RX_NUM_72 = 'N' IF RX_SEKTYPE = 'DATA' THEN DO IF SEK_INPUT.0 > 0 THEN DO IF LENGTH(SEK_INPUT.1) = 80 THEN DO RX_NUM_72 = 'J' DO RXX = 1 TO SEK_INPUT.0 IF DATATYPE(RIGHT(SEK_INPUT.RXX,8,'[')) <> 'NUM' THEN DO RX_NUM_72 = 'N' LEAVE END END END END END END IF RX_SEKTYPE = 'COBOL' THEN DO DO RXX = 1 TO SEK_INPUT.0 IF DATATYPE(LEFT(SEK_INPUT.RXX, 6)) <> 'NUM' THEN DO IF LEFT(SEK_INPUT.RXX, 6) <> '' THEN RX_SEKTYPE = 'DATA' END END IF RX_SEKTYPE = 'COBOL' THEN DO DO RXX = 1 TO SEK_INPUT.0 SEK_INPUT.RXX = RIGHT(SEK_INPUT.RXX,LENGTH(SEK_INPUT.RXX) - 6) SEK_INPUT.RXX = STRIP(SEK_INPUT.RXX,'T') END END END ELSE DO DO RXX = 1 TO SEK_INPUT.0 IF RX_NUM_72 = 'J' THEN SEK_INPUT.RXX = LEFT(SEK_INPUT.RXX,72) END END RETURN HOUSEKEEP_VED_SKIFT_LVL: /* variable som indgår i arg i call af action og imbed skal findes: */ INTERPRET RX_DEFAU ADDRESS STDOUT RC = 0 RETURN PUT_I_EXPLIST: PROCEDURE EXPOSE RX_EXPLIST ARG VAR IF POS(" "VAR" ",RX_EXPLIST" ") = 0 THEN DO IF SYMBOL(VAR) <> 'BAD' THEN DO IF VAR = 'RESULT' ! LEFT(VAR,3) = 'RX_' THEN DO RX_FMESS = 'Variablename 'VAR' is no good. Use another name' CALL SYNTAXFEJL END IF POS(" "VAR" "," ", " FUNC IN OUT OUTFUNC OUTFILE WORD. UNIT. CONT IMBED ") = 0 THEN DO RX_EXPLIST = RX_EXPLIST" "VAR RETURN 1 END END END RETURN 0 SKRIV_UD: PARSE ARG RX_G , RX_GG IF CHCK_ADDRESS(RX_G) THEN DO IF OUT <> RX_GEM_OUT THEN CALL SKRIV_UD_HOUSEKEEP RX_KX = RX_OUT.RX_DISPL.0 /* ant skrevne til denne fil indtil nu */ IF RX_SKRIV_T_QUEUE = 1 THEN DO /*hvis skriv til queue*/ CALL RX_PUTQUEUE RX_G , RX_GG END ELSE DO /* hvis skriv til dsname */ RX_KX = RX_KX + 1 RX_OUT.RX_DISPL.RX_KX = RX_G /* her skrives ! */ END RX_OUT.RX_DISPL.0 = RX_KX /* antal skrevne til denne fil */ END RETURN SKRIV_UD_DIR: /* dvs udskriv dead code i input der direkte skal ud */ IF CHCK_ADDRESS(PRIM_INPUT.RX_T) THEN DO IF OUT = '-' THEN DO IF POS('OUT',RX_DEFAU) > 0 THEN DO INTERPRET RX_DEFAU /* opsæt out */ END END IF OUT <> RX_GEM_OUT THEN CALL SKRIV_UD_HOUSEKEEP IF RX_SKRIV_T_QUEUE = 1 THEN DO /*hvis skriv til queue*/ CALL RX_PUTQUEUE PRIM_INPUT.RX_T END ELSE DO /* hvis skriv til dsname */ RX_KX = RX_OUT.RX_DISPL.0 RX_KX = RX_KX + 1 RX_OUT.RX_DISPL.0 = RX_KX RX_OUT.RX_DISPL.RX_KX = PRIM_INPUT.RX_T RX_OUTFUNC.RX_DISPL = OUTFUNC END END RETURN CHCK_ADDRESS: PARSE ARG RX_G IF ADDRESS <> '-' THEN DO INTERPRET "ADDRESS "ADDRESS /*2010-07-30 general order address */ END SELECT WHEN ADDRESS() = 'STDOUT' THEN RETURN 1 WHEN ADDRESS() = 'UNIX' THEN DO /* exekver unix + vis result */ IF SYMBOL('RX_UNIX_STRING') = 'LIT' THEN RX_UNIX_STRING = '' RX_UNIX_STRING = RX_UNIX_STRING""RX_G";" RETURN 0 END OTHERWISE DO /* exekver andre address'ed cmds */ address tso "subcom "address() if rc > 0 then do RX_FMESS = "#Addressed environment" ADDRESS() "not avaialable" CALL SYNTAXFEJL end RX_VOID = OUTTRAP('RX_OUTTRAP.') /* fang skærmuddata */ RX_G /* udfør linien som kommando */ DO RX_II = 1 TO RX_OUTTRAP.0 IF OUT <> RX_GEM_OUT THEN CALL SKRIV_UD_HOUSEKEEP RX_KX = RX_OUT.RX_DISPL.0 /* ant skriv til denne fil*/ IF RX_SKRIV_T_QUEUE = 1 THEN DO /*hvis skriv til queue*/ CALL RX_PUTQUEUE RX_OUTTRAP.RX_II END ELSE DO /* hvis skriv til dsname */ RX_KX = RX_KX + 1 RX_OUT.RX_DISPL.RX_KX = RX_OUTTRAP.RX_II /* her skrives ! */ END RX_OUT.RX_DISPL.0 = RX_KX /* antal skrevne til denne fil */ END RX_VOID = OUTTRAP('OFF') IF RC > 12 ! RC < 0 THEN DO /* 2012-10-31: 11 rettet til 12 */ IF RX_KALDTYP = 'BATCH' THEN SAY 'RXS command in error is:' RX_G do rx_II = 1 to rx_outtrap.0 /* 2012-10-11 */ say rx_outtrap.rx_ii /* skriv opsamlede mess på skærm */ end RX_FMESS = '#Error in command addressing' ADDRESS()':' IF ADDRESS() = 'ISPEXEC' ! ADDRESS() = 'ISREDIT' THEN DO RX_MILJ = ADDRESS() CALL ISPF_GETMSG END CALL SYNTAXFEJL END RETURN 0 END END RETURN 1 SKRIV_UD_HOUSEKEEP: RX_GEM_OUT = OUT IF LEFT(OUT,1) = '-' THEN OUT = '-'!!translate(OUTFILE) /*2010-10-21*/ IF POS('\',OUT) = 0 & POS('/',OUT) = 0 THEN DO /* 2015-04-01 */ IF WORD(translate(OUT,' ','+-*!'),2) > "" THEN DO RX_FMESS = "Invalid value for OUT: "OUT CALL SYNTAXFEJL END END IF POS(" "OUT" ",RX_OUT_LIST) = 0 THEN DO RX_OUT_LIST = RX_OUT_LIST" "OUT" " /* append dsname til liste */ RX_DISPL = POS(" "OUT" ",RX_OUT_LIST) RX_OUT.RX_DISPL.0 = 0 END RX_DISPL = POS(" "OUT" ",RX_OUT_LIST) RX_SKRIV_T_QUEUE = '' IF LEFT(OUT,1) <> '-' & POS('.',OUT) = 0, & POS('\',OUT) = 0 & POS('/',OUT) = 0 THEN DO RX_SKRIV_T_QUEUE = 1 END RX_OUTFUNC.RX_DISPL = OUTFUNC /* Fjernet 2020-01-23 if rx_skriv_t_queue = 1 &, translate(outfunc) = 'SUB' then do /* 2018-11-19 */ RX_FMESS = "OUTFUNC = 'SUB' requires permanent output (a file", "must be created (use OUTFILE= ), which is then submitted by RXS)" CALL SYNTAXFEJL end */ RETURN UDSKRIV_RX_OUT: DO RX_KX = 1 TO 9999 /* behandl PC skrivning først - for at fange */ OUT = WORD(RX_OUT_LIST,RX_KX) /* eventuelle skrivefejl her først */ IF OUT = "" THEN LEAVE /* 2007-09-28 */ IF POS('\',OUT) = 0 & POS('/',OUT) = 0 THEN ITERATE RX_DISPL = POS(" "OUT" ",RX_OUT_LIST) RX_MX = RX_OUT.RX_DISPL.0 OUTFUNC = RX_OUTFUNC.RX_DISPL CALL UDSKRIV_RX_OUT_SUB END DO RX_KX = 1 TO 9999 /* behandl mainframe skrivning */ OUT = WORD(RX_OUT_LIST,RX_KX) IF OUT = "" THEN LEAVE IF LEFT(OUT,1) <> '-' & POS('.',OUT) = 0 THEN ITERATE IF POS('\',OUT) > 0 ! POS('/',OUT) > 0 THEN ITERATE RX_DISPL = POS(" "OUT" ",RX_OUT_LIST) RX_MX = RX_OUT.RX_DISPL.0 IF RX_PRIMTYPE <> 'COBOL' & LEFT(OUT,1) <> '-' THEN DO RX_P = POS('(',OUT) /* 2006-07-10 */ IF RX_P = 0 THEN RX_P = LENGTH(OUT) - 1 IF TRANSLATE(SUBSTR(OUT, RX_P - 5, 5)) = 'COBOL' THEN DO DO RX_U = 1 TO RX_MX IF DATATYPE(LEFT(RX_OUT.RX_DISPL.RX_U,6)) <> 'NUM' &, LEFT(RX_OUT.RX_DISPL.RX_U,6) <> ' ' THEN RX_PRIMTYPE = 'COBOLtmp' IF LEFT(RX_OUT.RX_DISPL.RX_U,1) = ' ' THEN RX_PRIMTYPE = 'COBOLtmp' END /* foranstående tilføjet 2007-10-03 */ END /* COBOLtmp indført 2008-08-21 */ END IF LEFT(RX_PRIMTYPE,5) = 'COBOL' THEN DO RX_SW = '' /* 5 linier tilføjet 2008-08-19 */ DO RX_U = 1 TO RX_MX IF DATATYPE(LEFT(RX_OUT.RX_DISPL.RX_U,6)) <> 'NUM' THEN RX_SW = 1 END IF RX_SW = 1 THEN DO DO RX_U = 1 TO RX_MX RX_OUT.RX_DISPL.RX_U = RIGHT('00000'RX_U,6)""RX_OUT.RX_DISPL.RX_U END END END IF RX_PRIMTYPE = 'COBOLtmp' THEN RX_PRIMTYPE = 'DATA' OUTFUNC = RX_OUTFUNC.RX_DISPL SELECT WHEN ZEDSMSG > '' THEN NOP WHEN RX_KALDTYP='TSOCMD' ! RX_TRACE='MACOUT' ! OUTFUNC='NOP' THEN, ZEDSMSG = "RXS ok" WHEN WORD(RX_OUT_LIST,RX_KX + 1) = "" & RX_KALDTYP <> 'TSOCMD' THEN, ZEDSMSG = RXINMEMB "Ok. "RXENDTXT": return" OTHERWISE ZEDSMSG = "Ok. Press "RXENDTXT": Continue" END IF ZEDLMSG = '' THEN CALL ZEDLMSG_VERSION CALL ISPF_MESS_COND CALL UDSKRIV_RX_OUT_SUB ZEDSMSG = '' END RETURN UDSKRIV_RX_OUT_SUB: IF TRANSLATE(OUTFUNC) = 'MQPUT' THEN DO /* MQ */ IF LEFT(OUT,1) = '-' THEN DO RX_T = 1 /* message i top */ RX_FMESS = "'out' must be MQSeries queuename when outfunc='MQPUT'" CALL SYNTAXFEJL END CALL MQ_CONNECT RX_EXU = 0 DO RX_EX = 1 TO RX_MX RX_OUTXX = RX_OUT.RX_DISPL.RX_EX DO WHILE LENGTH(RX_OUTXX) > 3900 RX_EXU = RX_EXU + 1 RX_OUTX.RX_EXU = "C"LEFT(RX_OUTXX,3900) RX_OUTXX = SUBSTR(RX_OUTXX, 3901) END RX_EXU = RX_EXU + 1 RX_OUTX.RX_EXU = " "RX_OUTXX END RX_OUTX.0 = RX_EXU ADDRESS TSO "EXECIO "RX_EXU" DISKW RXSINP (STEM RX_OUTX. OPEN FINIS)" RX_MQ_DONE = 2 /* MQCMIT NØDVENDIG */ ADDRESS ISPEXEC , "SELECT PGM(RXSDO) PARM(Q MQPUT "TRANSLATE(OUT)" "RX_MQHANDLE")" IF RC > 100 THEN DO ADDRESS TSO "EXECIO * DISKR RXSOUTP (STEM SEK_INPUT. OPEN FINIS)" INTERPRET SEK_INPUT.1 RX_T = 1 /* placer fejlmeddelelse i top */ CALL SYNTAXFEJL END CALL EVT_SQL_MQ_TERMINERING /* ekstra kald efter udskriv af mq */ RETURN END /* MQ slut */ IF POS('\',OUT) > 0 THEN DO /* 2007-06-13 WSCON PC write */ RX_FMESS = "Writing to PC or local area network is not supported" CALL SYNTAXFEJL END /* WSCONN slut */ IF POS('/',OUT) > 0 THEN DO /* UNIX write */ OUT = TRANSLATE(OUT,' ','?') /* genskab evt. blanke */ CALL SYSCALLS 'ON' ADDRESS SYSCALL "READDIR (OUT) RX_DIR." IF ERRNOJR = 0 THEN , CALL SYNTAXFEJL "UNIX: This is a directory, not a file:" IN RXSWA = REVERSE(OUT) /* find directory del */ RX_I = POS('/',RXSWA) RXDI = REVERSE(SUBSTR(RXSWA,RX_I)) IF ERRNOJR <> '55E0071' & ERRNOJR <> '55E0072' THEN DO IF ERRNOJR = '594003D' THEN DO /* file or directory not found */ CALL SYNTAXFEJL 'No such directory: 'RXDI END W_ERRNOJR = ERRNOJR "STRERROR" ERRNO ERRNOJR "RX_ERR." CALL SYNTAXFEJL , 'UNIX:'W_ERRNOJR RX_ERR.SE_ERRNO '. Directory is: 'RXDI END "OPEN "OUT O_CREAT+O_WRONLY 775 /* check af skrive-adgang */ RX_FD = RETVAL /* find fil-nummer */ IF ERRNOJR <> 0 THEN DO IF ERRNOJR = '5B450002' THEN DO CALL SYNTAXFEJL , 'UNIX: Permission to write: Denied. Directory is: 'RXDI END W_ERRNOJR = ERRNOJR "STRERROR" ERRNO ERRNOJR "XX_ERR." CALL SYNTAXFEJL , 'UNIX: 'W_ERRNOJR XX_ERR.SE_ERRNO '. Directory is: 'RXDI END "CLOSE" RX_FD RX_OUTT = TRANSLATE(OUTFUNC) IF RX_OUTT <> '' , & POS(RX_OUTT,'EDIT NOP BROWSE VIEW BINARY') = 0 THEN DO CALL SYNTAXFEJL , 'UNIX: OUTFUNC: "'OUTFUNC'" not valid when writing to UNIX' END RX_EXX = 0 DO RX_EX = 1 TO RX_MX /* hvis uddata er større end lrecl*/ DO FOREVER RX_EXX = RX_EXX + 1 IF LENGTH(RX_OUT.RX_DISPL.RX_EX) < 8001 THEN DO RX_OUTX.RX_EXX = RX_OUT.RX_DISPL.RX_EX LEAVE END ELSE DO RX_OUTX.RX_EXX = LEFT(RX_OUT.RX_DISPL.RX_EX,8000) RX_OUT.RX_DISPL.RX_EX = SUBSTR(RX_OUT.RX_DISPL.RX_EX,8001) END END IF RX_OUTT <> 'BINARY' & RX_EX < RX_MX THEN DO RX_OUTX.RX_EXX = RX_OUTX.RX_EXX!!'15'X /* tilføj newline */ END /* dog ikke efter sidste linie */ END ADDRESS TSO "EXECIO "RX_EXX" DISKW RXSINP (STEM RX_OUTX. OPEN FINIS)" "ALLOC FI(RXSOUTP) PATH('"OUT"') REUSE pathopts(owronly,otrunc)", "FILEDATA(BINARY) pathmode(sirwxu,sirwxg,siroth)" ADDRESS ISPEXEC "SELECT PGM(RXSDO) PARM(C NOCONV 0 0)" IF RC > 0 THEN , SAY "Installation error: Call to loadmodule RXSDO fails" IF RX_KALDTYP <> 'BATCH' THEN DO SELECT WHEN RX_OUTT = 'VIEW' THEN DO /* 2022-10-26 */ ADDRESS ISPEXEC "VIEW FILE(OUT) MACRO(RESET)" END WHEN RX_OUTT = 'BROWSE' THEN DO /* 2022-10-26 */ ADDRESS ISPEXEC "VIEW FILE(OUT) MACRO(RESET)" end WHEN RX_OUTT = 'NOP' THEN NOP OTHERWISE DO ADDRESS ISPEXEC "EDIT FILE(OUT) MACRO(RESET)" END END END RX_OUTFUNC_DONE = 1 RETURN END /* UNIX write slut */ ADDRESS TSO /* skriv mainframe ds: */ IF LEFT(OUT,1) = "-" THEN DO /* uddata til OUTFILE */ RX_FILE = SUBSTR(OUT,2) IF LENGTH(RX_FILE) > 8 THEN DO RX_FMESS = "OUTFILE ("RX_FILE") is too long, max 8 characters" CALL SYNTAXFEJL END SELECT WHEN RX_KALDTYP = 'BATCH' THEN DO /* batch */ DO RX_EX = 1 TO RX_MX RX_OUTX.RX_EX = RX_OUT.RX_DISPL.RX_EX END RX_OUTX.0 = RX_MX "EXECIO "RX_MX" DISKW "RX_FILE" (STEM RX_OUTX. OPEN FINIS)" IF RC = 0 THEN RETURN IF RC = 1 THEN DO SAY ' ' SAY "WARNING: File //"TRANSLATE(RX_FILE)": truncate during write" SAY ' ' ZISPFRC = 4 /* medfører at ISPSTART giver denne RC */ ADDRESS ISPEXEC "VPUT (ZISPFRC) SHARED" RETURN END IF RC > 4 THEN DO /* 2007-08-16 */ RX_OUT = TRANSLATE(RX_FILE"."RX_PRIMTYPE) SAY "File //"TRANSLATE(RX_FILE)" not found in JCL. " SAY "RXS: Datset "RX_OUT" is now allocated and used,", "error message above is overruled" CALL ALLOC_OUTFILE ZISPFRC = 4 /* medfører at ISPSTART giver denne RC */ ADDRESS ISPEXEC "VPUT (ZISPFRC) SHARED" END END WHEN RX_TRACE = 'MACOUT' & RXMCURS <> "" & RX_FILE = 'RXS' THEN DO ADDRESS ISREDIT /* 2015-10-23 rx_file tilføjet ovenfor */ "LINE_AFTER &RXMCURS = NOTELINE 'RXS "RXINMEMB RXSPARM" - end'" DO RX_X = RX_MX TO 1 BY -1 /*hvis rx_x hedder rx_kx så svipser det*/ RXLDATA = RX_OUT.RX_DISPL.RX_X "LINE_AFTER &RXMCURS = (RXLDATA)" END "LINE_AFTER &RXMCURS = NOTELINE 'RXS "RXINMEMB RXSPARM" - start'" ADDRESS TSO RETURN /* macro ud */ END OTHERWISE DO CALL ALLOC_OUTFILE END END /* select */ END ELSE DO /* out er udfyldt: */ RX_OUT = "'"OUT"'" IF POS('(',OUT) > 0 THEN DO RX_OUT = "'"LEFT(OUT,POS('(',OUT) - 1)"'" END IF SYSDSN(RX_OUT) <> 'OK' THEN DO ZEDSMSG = "" ZEDLMSG = "Dataset " RX_OUT": "SYSDSN(RX_OUT) CALL ISPF_MESS CALL EXIT_I_UTIDE 8 END RX_OUT = "'"OUT"'" RX_VOID = LISTDSI(RX_OUT) RX_LRECL = SYSLRECL END /* out var udfyldt */ ADDRESS ISPEXEC IF LEFT(OUT,1) = "-" THEN SYSDSORG = 'PS' /* 2008-08-21 */ IF SYSDSORG = 'PO' THEN DO IF POS('(',RX_OUT) = 0 THEN DO ZEDSMSG = "" ZEDLMSG = RX_OUT" is partitioned, indicate member as dsn(mbr)" CALL ISPF_MESS CALL EXIT_I_UTIDE 8 END RX_XOUTDSN = LEFT(RX_OUT,POS('(',RX_OUT) - 1)"'" RX_XOUTMBR = SUBSTR(RX_OUT,POS('(',RX_OUT) + 1) RX_XOUTMBR = LEFT(RX_XOUTMBR,LENGTH(RX_XOUTMBR) - 2) RX_OUT = RX_XOUTDSN ZLCDATE = DATE('O') ZLMDATE = ZLCDATE ZLMTIME = LEFT(TIME('N'),5) ZLUSER = 'RXS' ZLCNORC = RX_MX if zlcnorc > 65535 then zlcnorc = 65535 /* 2015-11-30 */ ZLINORC = ZLCNORC "LMINIT DATAID(RXSDID) DATASET("RX_OUT") ORG(DSORG) ENQ(SHRW)" RX_LRC = RC END /* po-behandling */ ELSE DO RX_XOUTMBR = "" "LMINIT DATAID(RXSDID) DATASET("RX_OUT") ORG(DSORG) ENQ(EXCLU)" RX_LRC = RC END IF RX_LRC > 0 THEN DO RX_FMESS = 'Invalid dataset name - or dataset in use: ' RX_OUT CALL SYNTAXFEJL END "LMOPEN DATAID(&RXSDID) LRECL(RXLLGD)" , "RECFM(RXRFM) ORG(RXORG) OPTION(OUTPUT)" IF RC > 0 THEN CALL ISPF_GETMSG("LMFREE DATAID("RXSDID")") DO RX_I = 1 TO RX_MX RXARGU = RX_OUT.RX_DISPL.RX_I /* denne stem skrives */ call skriv_rxargu_til_mainframe END IF SYSDSORG = 'PO' THEN DO "CONTROL ERRORS RETURN" "LMMREP DATAID(&RXSDID) MEMBER("RX_XOUTMBR") STATS(YES)" RX_RC = RC IF RX_RC > 8 THEN DO /*RC=8: mbr added*/ IF RX_RC = 14 THEN DO /*RC=14 intet output dannet*/ "LMMDEL DATAID(&RXSDID) MEMBER("RX_XOUTMBR")" /*fjern gl. mbr*/ END ELSE DO ZEDSMSG = "OUT out of space?" 2015-11-30 ZEDLMSG = OUT": Write failed, ISPF LMMREP rc =" RX_RC CALL ISPF_MESS "LMCLOSE DATAID(&RXSDID)" "LMFREE DATAID(&RXSDID)" CALL EXIT_I_UTIDE 8 END END END /* po-behandling */ "LMCLOSE DATAID(&RXSDID)" "LMFREE DATAID(&RXSDID)" CALL EKSEKVER_OUTFUNC RETURN ALLOC_OUTFILE: IF RX_PRIMTYPE = 'COBOL' ! TRANSLATE(OUTFUNC) = 'SUB' THEN DO RXIRECL = 80 RXIRECF = 'F' END ELSE DO RX_MAX_LG = 0 DO RX_II = 1 TO RX_MX RX_LG = LENGTH(RX_OUT.RX_DISPL.RX_II) IF RX_LG > RX_MAX_LG THEN RX_MAX_LG = RX_LG END RXIRECL = 256 IF RX_MAX_LG > 252 THEN RXIRECL = 4096 IF RX_MAX_LG > 4092 THEN RXIRECL = 32756 RXIRECF = 'V' END RX_OUT = TRANSLATE(RX_FILE"."RX_PRIMTYPE) IF LISTDSI(RX_OUT) = 0 THEN DO IF SYSRECFM <> RXIRECF"B" ! SYSLRECL <> RXIRECL THEN DO "DELETE "RX_OUT IF RC > 4 THEN DO RX_FMESS = 'Output dsn' RX_OUT 'not allocated. Dataset in use?' CALL SYNTAXFEJL END END END IF LISTDSI(RX_OUT) > 0 THEN DO "ALLOC DA("RX_OUT") NEW REUSE "RX_UNIT_VOL" " , "LRECL("RXIRECL") RECFM("RXIRECF" B) SPACE(10 100) CYL DSORG(PS)" "FREE DA("RX_OUT")" END RX_LRECL = RXIRECL RETURN skriv_rxargu_til_mainframe: IF LEFT(SYSRECFM,1) = 'F' THEN DO RXLGD = RX_LRECL END ELSE DO RXLGD = LENGTH(RXARGU) IF LEFT(SYSRECFM,1) <> 'U' THEN DO /* 2015-08-24 */ IF RXLGD > RX_LRECL THEN DO RXLGD = RX_LRECL RXARGU = LEFT(RXARGU,RXLGD)/*LMPUT fejer hvis arg meget lang*/ END END IF RXLGD = 0 THEN RXLGD = 1 END "LMPUT DATAID(&RXSDID) MODE(INVAR) DATALOC(RXARGU)", "DATALEN(&RXLGD) NOBSCAN" /* 2007-09-27: nobscan */ IF RC > 0 THEN DO RX_RC = RC /* 2016-10-24 flyttet */ IF RC > 18 THEN DO "LMCLOSE DATAID(&RXSDID)" "LMFREE DATAID(&RXSDID)" /* 2017-07-18 bedre fejlmedd: */ SAY "Writing '"RX_OUT"' fails, ISPF LMPUT: RC " RX_RC CALL EXIT_I_UTIDE RX_RC /* 2013-08-14 RETTET FRA RC=8 */ END SAY "Writing '"RX_OUT"' fails, ISPF LMPUT: RC " RX_RC END return EKSEKVER_OUTFUNC: OUTFUNC = TRANSLATE(OUTFUNC) SELECT WHEN OUTFUNC = 'BINARY' THEN DO IF POS('\',OUT) = 0 THEN DO RX_FMESS = "OUTFUNC='BINARY' not valid in this context" CALL SYNTAXFEJL END END WHEN OUTFUNC = 'EDIT' ! OUTFUNC = 'BROWSE' ! OUTFUNC = 'VIEW' THEN DO IF RX_KALDTYP <> 'BATCH' THEN DO ADDRESS ISPEXEC SELECT WHEN OUTFUNC = 'EDIT' THEN RX_EMAC = 'MACRO(RESET)' WHEN OUTFUNC = 'VIEW' THEN RX_EMAC = 'MACRO(RESET)' OTHERWISE RX_EMAC = "" END IF RX_XOUTMBR = "" THEN DO RX_DS = RX_OUT END ELSE DO RX_DS = SUBSTR(LEFT(RX_OUT,LENGTH(RX_OUT) - 1),2) RX_DS ="'"RX_DS"("RX_XOUTMBR")'" END ""OUTFUNC" DATASET("RX_DS") "RX_EMAC RX_RC = RC IF RX_RC > 4 THEN DO ZEDSMSG = '' ZEDLMSG = "Output unaccessible,", /* 2018-10-11 */ OUTFUNC" on "RX_DS" failed, RC:" RX_RC CALL ISPF_MESS END END END WHEN OUTFUNC = 'SUB' THEN DO IF RX_XOUTMBR = "" THEN DO ADDRESS TSO "SUB "RX_OUT END ELSE DO RX_OUT = SUBSTR(LEFT(RX_OUT,LENGTH(RX_OUT) - 1),2) ADDRESS TSO "SUB '"RX_OUT"("RX_XOUTMBR")' " RX_RC = RC END END WHEN OUTFUNC = 'NOP' THEN NOP OTHERWISE DO IF OUTFUNC > "" THEN DO IF LEFT(OUTFUNC,8) = 'ISPEXEC ' THEN DO ADDRESS ISPEXEC SUBSTR(OUTFUNC,8) END ELSE DO ADDRESS ISPEXEC "SELECT CMD("OUTFUNC")" END IF RC = 0 THEN DO ZEDSMSG = WORD(OUTFUNC,1)" ok" ZEDLMSG = "OUTFUNC: '"OUTFUNC"' ok" CALL ISPF_MESS_COND END if rc > 15 then do RX_FMESS2 = "The outfunc is invalid" CALL ISPF_GETMSG('') end END END END /* 2013-10-17: 'sub' tilføjet i næste linie: */ IF OUTFUNC <> 'NOP' & OUTFUNC <> 'SUB' THEN RX_OUTFUNC_DONE = 1 RETURN RX_PUTQUEUE: if pos('"',out) > 0 ! pos("'",out) > 0 then do RX_FMESS = "Value for 'out' contains quote: " OUT CALL SYNTAXFEJL end PARSE ARG WORDX, WORDXX RX_ST_LI = , "IF SYMBOL('RX_GLB."OUT"_1.1') = 'LIT' THEN RX_GLB."OUT"_STEMIX=0", ";RX_GLB."OUT"_STEMIX = RX_GLB."OUT"_STEMIX + 1", ";RX_CNT = RX_GLB."OUT"_STEMIX", ";RX_GLB."OUT"_1.RX_CNT = WORDX ", ";RX_GLB."OUT"_1.0 = RX_CNT" IF SYMBOL('WORDXX') <> 'LIT' THEN DO RX_ST_LI = RX_ST_LI";RX_GLB."OUT"_2.RX_CNT = WORDXX " INTERPRET RX_ST_LI END DROP WORDXX IF OUT = RX_Q_SORT THEN RX_Q_SORT = '-' RETURN LOOP_PRIM_SEK_XML: CONT = "," CALL INDLAES_SEK IF IN = '-' THEN DO IF SYMBOL('INFILE') = 'LIT' THEN DO /*2020-08-28 */ RX_FMESS = "FUNC='XML': No input found - 'IN' or 'INFILE'", "has no value" CALL SYNTAXFEJL END END IF RX_NOTRIG = 1 THEN DO IF SEK_INPUT.0 = 0 THEN DO INTERPRET RX_NOSOURCE RETURN END END IF LENGTH(SEK_INPUT.1) = 0 THEN DO RX_FMESS = "FUNC='XML': Input is empty" CALL SYNTAXFEJL END rx_ii = 0 /* lange strenge til XML: */ do rx_i = 1 to sek_input.0 do while length(sek_input.rx_i) > 7000 rx_ii = rx_ii + 1 rx_mod_inp.rx_ii = left(sek_input.rx_i,7999) sek_input.rx_i = substr(sek_input.rx_i,8000) end if sek_input.rx_i = '' then iterate /* 2020-11-06 ej blank linie */ rx_ii = rx_ii + 1 rx_mod_inp.rx_ii = sek_input.rx_i /* 2020-11-06 blank efter væk */ end ADDRESS TSO , "EXECIO "RX_II" DISKW RXSINP (STEM RX_MOD_INP. OPEN FINIS)" IF RX_TRACE = '?TRACE' THEN DO ADDRESS ISPEXEC, "LMINIT DATAID(RXSINP) DDNAME(RXSINP) ORG(INDORG) ENQ(SHR)" ADDRESS ISPEXEC "BROWSE DATAID(&RXSINP)" END ADDRESS ISPEXEC "SELECT PGM(RXSDO) PARM(X --)" IF RC > 0 THEN DO SAY "Instalation error? Attempt to call loadmodule RXSDO fails" CALL ISPF_GETMSG('') END RX_FMESS = '' ADDRESS TSO "EXECIO * DISKR RXSOUTP (STEM MODIF_INPUT. OPEN FINIS)" IF RX_TRACE = '?TRACE' THEN DO ADDRESS ISPEXEC, "LMINIT DATAID(RXSOUTP) DDNAME(RXSOUTP) ORG(INDORG) ENQ(SHR)" ADDRESS ISPEXEC "BROWSE DATAID(&RXSOUTP)" END DO RX_B = 1 TO MODIF_INPUT.0 /* 2007-03-21 konkatener fortsat linie */ /* alle fortsatte linier starter med blank...: (?) */ IF LEFT(MODIF_INPUT.RX_B,1) = ' ' THEN DO MODIF_INPUT.RX_C = MODIF_INPUT.RX_C""MODIF_INPUT.RX_B MODIF_INPUT.RX_B = '' END ELSE RX_C = RX_B END RX_C = MODIF_INPUT.0 DO RX_B = MODIF_INPUT.0 TO 1 BY -1 IF MODIF_INPUT.RX_B = '' THEN DO RX_C = RX_B END ELSE LEAVE END /* 2007-03-21 slut */ MODIF_INPUT.0 = RX_C DO RX_B = 1 TO MODIF_INPUT.0 IF MODIF_INPUT.RX_B <> '' THEN DO IF RX_B = MODIF_INPUT.0 THEN CONT = " " SPACEROW = STRIP(MODIF_INPUT.RX_B) NAMESPACE_1 = '{' NAMESPACE_2 = '}' INTERPRET PARMSPACE(MODIF_INPUT.RX_B) IF RX_FMESS > '' THEN CALL SYNTAXFEJL DO RX_II = 1 TO XML_ATTRIB_CNT RX_VOID = PUT_I_EXPLIST(XML_ATTRIB.RX_II) /* make global */ END INTERPRET RX_SOURCE END END RETURN /* s q l f u n k t i o n e r */ RXSSPUFI_OPEN_OPEN: /* udføres max een gang pr rxs-eksekvering */ IF RX_SQL_DONE = '' THEN DO RX_SQL_DONE = 'A' ADDRESS TSO "SUBCOM DSNREXX" /* Er DSNREXX tilgængelig ? */ IF RC > 0 THEN DO RX_RC = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* tilføj*/ IF RX_RC > 0 THEN SAY 'RXSUBCOM ADD fails' RC /* 2005-01-10 */ END END RETURN RXSSPUFI_OPEN: RX_FETCH_ANT = 0 RX_GEM_HOSTVAR. = '' ADDRESS TSO CALL INDLAES_SEK IF IN = '-' THEN DO RX_FMESS = "FUNC=SQL': No input found - 'IN' has no value" CALL SYNTAXFEJL END IF SEK_INPUT.0 = 0 THEN DO RX_FMESS = "SQL: No input found - input source "IN" is empty" CALL SYNTAXFEJL END RX_SQLSTMT = "" /* erstat hostvars med '?' og dan liste over */ RX_HOSTVARS = "" /* hostvars : */ RX_HOSTVAR. = "" RX_Z = 0 /* er her tæller for host-var-nummer */ IF TRANSLATE(WORD(SEK_INPUT.1,1)) = 'CALL' THEN DO /* 2007-08-09 */ DO RX_I = 1 TO SEK_INPUT.0 /* Ved call analyseres hostvars ikke */ RX_SQLSTMT = RX_SQLSTMT" "STRIP(SEK_INPUT.RX_I) END END ELSE DO DO RX_I = 1 TO SEK_INPUT.0 RX_QUOT1 = 1 RX_QUOT2 = 1 RX_QUOT3 = 1 RX_QUOT4 = 1 RX_SQLLIN = SEK_INPUT.RX_I DO FOREVER RX_QUOT1 = POS("'",RX_SQLLIN) IF RX_QUOT1 = 0 THEN LEAVE RX_QUOT2 = POS("'",RX_SQLLIN,RX_QUOT1 + 1) IF RX_QUOT2 = 0 THEN DO RX_FMESS = "SQL: Line in SQL contains an uneven number of quotes" CALL SYNTAXFEJL END RX_QUOT3 = POS("'",RX_SQLLIN,RX_QUOT2 + 1) IF RX_QUOT3 = 0 THEN LEAVE RX_QUOT4 = POS("'",RX_SQLLIN,RX_QUOT3 + 1) IF RX_QUOT4 = 0 THEN DO RX_FMESS = "SQL: Line in SQL contains an uneven number of quotes" CALL SYNTAXFEJL END LEAVE END /* 2021-03-19 : comment fjernes: */ IF RX_QUOT2 = 0 THEN RX_QUOT2 = 1 /* 2014-04-10 comments */ RX_POS_C = POS('--',RX_SQLLIN,RX_QUOT2) /* fjernes */ IF RX_POS_C > 0 THEN DO IF ^ (RX_QUOT1 < RX_POS_C & RX_QUOT2 > RX_POS_C) THEN DO RX_SQLLIN = LEFT(RX_SQLLIN,RX_POS_C - 1) END END /* 2019-02-26 : comment fjernes: */ IF LEFT(STRIP(RX_SQLLIN),2) = '--' THEN RX_SQLLIN = '' RX_STRT = 1 DO FOREVER RX_SEMIC = POS(':',RX_SQLLIN,RX_STRT) RX_STRT = RX_SEMIC + 1 IF RX_SEMIC > 0 THEN DO IF RX_SEMIC > RX_QUOT1 & RX_SEMIC < RX_QUOT2 THEN ITERATE IF RX_SEMIC > RX_QUOT3 & RX_SEMIC < RX_QUOT4 THEN ITERATE RX_BLANK = POS(' ',RX_SQLLIN,RX_SEMIC + 2) /* hvis blank */ RX_KOMMA = POS(',',RX_SQLLIN,RX_SEMIC) /*..efter ':' */ RX_PARAN = POS(')',RX_SQLLIN,RX_SEMIC) RX_LIGHE = POS('=',RX_SQLLIN,RX_SEMIC) RX_MINDR = POS('<',RX_SQLLIN,RX_SEMIC) RX_STORR = POS('>',RX_SQLLIN,RX_SEMIC) IF RX_BLANK = 0 THEN RX_BLANK = LENGTH(RX_SQLLIN) + 1 IF RX_KOMMA <> 0 & RX_KOMMA < RX_BLANK THEN RX_BLANK = RX_KOMMA IF RX_PARAN <> 0 & RX_PARAN < RX_BLANK THEN RX_BLANK = RX_PARAN IF RX_LIGHE <> 0 & RX_LIGHE < RX_BLANK THEN RX_BLANK = RX_LIGHE IF RX_MINDR <> 0 & RX_MINDR < RX_BLANK THEN RX_BLANK = RX_MINDR IF RX_STORR <> 0 & RX_STORR < RX_BLANK THEN RX_BLANK = RX_STORR RX_Z = RX_Z + 1 RX_HOSTVAR.RX_Z = , STRIP(SUBSTR(RX_SQLLIN,RX_SEMIC+1,RX_BLANK-RX_SEMIC-1)) IF SYMBOL(RX_HOSTVAR.RX_Z) <> 'VAR' THEN DO /* 2007-03-06 */ RX_FMESS = "SQL: The hostvar "RX_HOSTVAR.RX_Z" is not", "a variable. Hostvars in SQL are like :hugo - that is colon", "followed by a valid REXX variable" CALL SYNTAXFEJL END IF VALUE(RX_HOSTVAR.RX_Z) = '?' , ! VALUE(RX_HOSTVAR.RX_Z) = "'?'" THEN DO /* 2006-06-27 */ RX_SQLLIN = , LEFT(RX_SQLLIN,RX_SEMIC-1)" NULL "SUBSTR(RX_SQLLIN,RX_BLANK) END ELSE DO IF RX_HOSTVARS > "" THEN RX_HOSTVARS = RX_HOSTVARS"," RX_HOSTVARS = , RX_HOSTVARS" :"RX_HOSTVAR.RX_Z RX_SQLLIN = , LEFT(RX_SQLLIN,RX_SEMIC-1)" ? "SUBSTR(RX_SQLLIN,RX_BLANK) END ITERATE END LEAVE END RX_SQLSTMT = RX_SQLSTMT" "STRIP(RX_SQLLIN) END END IF RIGHT(RX_SQLSTMT,1) = ';' THEN RX_SQLSTMT = , SUBSTR(RX_SQLSTMT,1,LENGTH(RX_SQLSTMT) - 1) IF POS(' INTO ',RX_SQLSTMT) > 0 THEN DO IF POS('SELECT ',RX_SQLSTMT) > 0 THEN DO IF POS('SELECT ',RX_SQLSTMT) < POS(' INTO ',RX_SQLSTMT) THEN DO RX_FMESS = "SQL: 'INTO' not valid in SELECT. Omit the 'INTO' clause" CALL SYNTAXFEJL END END END IF RX_TRACE = '?TRACE' THEN say '***Til SQL: 'rx_sqlstmt ADDRESS DSNREXX IF RX_GSQL <> '' & translate(RX_GSQL) <> translate(SQL) THEN DO RX_FMESS = "SQL: SQL (DB2-system) cannot change from "RX_GSQL" to "SQL CALL SYNTAXFEJL END IF RX_SQL_DONE = 'A' THEN DO "CONNECT "SQL IF SYMBOL('SQLCODE') = 'LIT' THEN DO RX_FMESS = "SQL: CONNECT to "SQL" fails" CALL SYNTAXFEJL END IF SQLCODE <> 0 THEN CALL SQLFEJL "EXECSQL SET CURRENT PACKAGESET='DSNREXCS'" /* CS */ RX_SQL_DONE = 'B' /* ----------2016-02-03------------------- */ RX_GSQL = SQL /* Hostvar starter med 0: sæt i quote: */ END /* (uanset om alfa eller numerisk hostvar) */ DO RX_I = 1 TO RX_Z /* --------------------------------------- */ IF LEFT(VALUE(RX_HOSTVAR.RX_I),1) = '0' &, LENGTH(VALUE(RX_HOSTVAR.RX_I)) > 1 &, /* 2015-08-14 */ POS(' ',VALUE(RX_HOSTVAR.RX_I)) = 0 &, /* 2017-02-03 */ POS('%',VALUE(RX_HOSTVAR.RX_I)) = 0 THEN DO /* 2022-05-19 */ RX_GEM_HOSTVAR.RX_I = RX_HOSTVAR.RX_I RX_GEM_HOSTVAL.RX_I = VALUE(RX_HOSTVAR.RX_I) rx_quo = "'" RX_STMT = , RX_HOSTVAR.RX_I' = "'rx_quo'"'VALUE(RX_HOSTVAR.RX_I)'"'rx_quo'"' INTERPRET RX_STMT END END RX_SQ = TRANSLATE(WORD(RX_SQLSTMT,1)) RX_SQQ = TRANSLATE(WORD(RX_SQLSTMT,2)) /* 2021-07-28 WITH tilføjet */ IF RX_SQ = 'SELECT' ! RX_SQ = '(SELECT' ! RX_SQQ = 'SELECT' !, RX_SQ = 'WITH' ! RX_SQ = '(WITH' ! RX_SQQ = 'WITH' THEN DO IF RX_SQL_DONE <> '2' THEN RX_SQL_DONE = '1' /* 2007-02-02 */ RX_SQL_KALDTYPE = 'S' DO RX_I = 1 TO RX_Z /* Antal host-felter */ IF SYMBOL(RX_HOSTVAR.RX_I) = 'BAD' THEN DO RX_FMESS= "DB2 host variable name is not valid in REXX:'", !! RX_HOSTVAR.RX_I"'" IF RX_HOSTVAR.RX_I = ' ' THEN HX_FMESS= , "Space is used as host variable name in this SQL-call" CALL SYNTAXFEJL END IF VALUE(RX_HOSTVAR.RX_I) = '?' , ! VALUE(RX_HOSTVAR.RX_I) = "'?'" THEN DO /*aktuel value null */ RX_FMESS = "NULL-value for host-variable not valid in select-call" CALL SYNTAXFEJL END END RX_SQLVL = GET_SQLNO(RX_LVL) /* 2016-08-17 flyttet hertil */ IF RX_SQLVL > 99 THEN DO RX_FMESS= , "More than 99 SQL actions in this RXS program" CALL SYNTAXFEJL END "EXECSQL DECLARE C"RX_SQLVL" CURSOR FOR S"RX_SQLVL "EXECSQL PREPARE S"RX_SQLVL" INTO :OUTSQLDA FROM :RX_SQLSTMT" IF SQLCODE <> 0 THEN CALL SQLFEJL IF RX_HOSTVARS = '' THEN DO "EXECSQL OPEN C"RX_SQLVL END ELSE DO "EXECSQL OPEN C"RX_SQLVL" USING "RX_HOSTVARS END IF SQLCODE <> 0 THEN CALL SQLFEJL DO RX_I = 1 TO RX_Z /* restore variabel som har fået quote */ IF RX_GEM_HOSTVAR.RX_I <> '' THEN DO /* 2016-02-03 */ RX_GEM_HOSTVAR.RX_I = RX_HOSTVAR.RX_I RX_GEM_HOSTVAL.RX_I = VALUE(RX_HOSTVAR.RX_I) RX_STMT = , RX_GEM_HOSTVAR.RX_I' = ' RX_GEM_HOSTVAL.RX_I INTERPRET RX_STMT END END SQLNAMES = '' SQLTYPES = '' SQLLENGTHS = '' DO RX_I = 1 TO OUTSQLDA.SQLD /* Antal fundne felter */ RX_NVN = OUTSQLDA.RX_I.SQLNAME IF RX_NVN = "" THEN RX_NVN = "SQL_NVN"RX_I RX_VOID = PUT_I_EXPLIST(RX_NVN) SQLNAMES = SQLNAMES" "RX_NVN SELECT WHEN OUTSQLDA.RX_I.SQLTYPE = 484 ! , OUTSQLDA.RX_I.SQLTYPE = 485 THEN DO /* packed */ RX_LGD.RX_I = OUTSQLDA.RX_I.SQLLEN.SQLPRECISION + , OUTSQLDA.RX_I.SQLLEN.SQLSCALE + 1 /* 2013-11-11: +1 ovenfor for at få evt fortegn med i længden */ IF OUTSQLDA.RX_I.SQLLEN.SQLSCALE > 0 THEN DO RX_LGD.RX_I = RX_LGD.RX_I + 2 END RX_TYPE.RX_I = 'N' END WHEN OUTSQLDA.RX_I.SQLTYPE = 496 !, OUTSQLDA.RX_I.SQLTYPE = 497 THEN DO /* integer fullword */ RX_TYPE.RX_I = 'N' RX_LGD.RX_I = 10 END WHEN OUTSQLDA.RX_I.SQLTYPE = 500 !, OUTSQLDA.RX_I.SQLTYPE = 501 THEN DO /* integer halfword */ RX_TYPE.RX_I = 'N' RX_LGD.RX_I = 5 END WHEN OUTSQLDA.RX_I.SQLTYPE = 904 THEN DO RX_LGD.RX_I = 1000 /*ROWID type i DB2 (arbitrær længde??) */ RX_TYPE.RX_I = 'A' END WHEN OUTSQLDA.RX_I.SQLTYPE = 404 !, /* BLOB */ OUTSQLDA.RX_I.SQLTYPE = 405 !, OUTSQLDA.RX_I.SQLTYPE = 408 !, OUTSQLDA.RX_I.SQLTYPE = 409 THEN DO /* CLOB */ RX_LGD.RX_I = 100000 /* BLOB/CLOB i DB2 (vilkårlig lgd) */ RX_TYPE.RX_I = 'A' /* men faktisk felt får faktisk lgd */ END WHEN OUTSQLDA.RX_I.SQLTYPE > 479 THEN DO /* numeric */ RX_LGD.RX_I = 15 RX_TYPE.RX_I = 'N' END OTHERWISE DO /* alfa mv */ RX_LGD.RX_I = OUTSQLDA.RX_I.SQLLEN RX_TYPE.RX_I = 'A' END END SQLLENGTHS = SQLLENGTHS""RX_LGD.RX_I" " SQLTYPES = SQLTYPES""RX_TYPE.RX_I" " END END ELSE DO /* ikke-select kald: */ RX_SQL_KALDTYPE = 'U' /* 2008-07-01 'SET' er ej update: */ IF RX_SQ <> 'SET' THEN RX_SQL_DONE = '2' IF RX_HOSTVARS = '' THEN DO "EXECSQL "RX_SQLSTMT IF SQLCODE < 0 THEN CALL SQLFEJL END ELSE DO RX_SQLVL = GET_SQLNO(RX_LVL) /* 2016-08-17 også flyttet hertil */ "EXECSQL PREPARE S"RX_SQLVL" FROM :RX_SQLSTMT" IF SQLCODE < 0 THEN CALL SQLFEJL "EXECSQL EXECUTE S"RX_SQLVL" USING "RX_HOSTVARS IF SQLCODE < 0 THEN CALL SQLFEJL END END IF RX_TRACE = '?TRACE' THEN DO SAY RX_SQLSTMT SAY '-----' SAY RX_HOSTVARS END RETURN RXSSPUFI_FETCH: RX_SQLVL = GET_SQLNO(RX_LVL) ADDRESS DSNREXX SQLNULLS = '' RX_SQLROW = '' IF RX_SQL_DONE <> '2' THEN RX_SQL_DONE = '1' /* 2007-02-02 */ RX_STMT = "" "EXECSQL FETCH C"RX_SQLVL" USING DESCRIPTOR :OUTSQLDA" IF SQLCODE < 0 THEN CALL SQLFEJL IF SQLCODE = 0 THEN DO RX_FETCH_ANT = RX_FETCH_ANT + 1 DO RX_I = 1 TO OUTSQLDA.SQLD /* Antal fundne felter */ SQLNULLS = SQLNULLS""OUTSQLDA.RX_I.SQLIND" " IF OUTSQLDA.RX_I.SQLIND = -1 THEN DO RX_VAL = '?' /* null value */ END ELSE DO RX_VAL = OUTSQLDA.RX_I.SQLDATA END /* num-felter slutter på '.' hvis heltal: ... */ IF RX_TYPE.RX_I = 'N' THEN DO IF RIGHT(RX_VAL,1) = '.' THEN DO RX_VAL = LEFT(RX_VAL,LENGTH(RX_VAL) - 1) /* formodenligt fejl */ END /* i rexx interface! */ END RX_NVN = OUTSQLDA.RX_I.SQLNAME IF RX_NVN = "" THEN RX_NVN = "SQL_NVN"RX_I IF RX_TYPE.RX_I = 'A' THEN DO /* rettet 2004-10-15: */ RX_INTET = "RX_VAL_"RX_NVN" = RX_VAL" INTERPRET RX_INTET RX_SQLROW = RX_SQLROW""LEFT(RX_VAL,RX_LGD.RX_I)" " RX_STMT = RX_STMT""RX_NVN" = RX_VAL_"RX_NVN";" END ELSE DO /* for at rumme fortegn: +1 nedenfor 2013-11-11 */ RX_SQLROW = RX_SQLROW""RIGHT(RX_VAL,RX_LGD.RX_I)" " RX_VALX = STRIP(RX_VAL) IF RX_VALX = '?' THEN RX_VALX = "'?'" RX_STMT = RX_STMT""RX_NVN" = "RX_VALX";" END END END RETURN RXSSPUFI_CLOSE: RX_SQLVL = GET_SQLNO(RX_LVL) ADDRESS DSNREXX "EXECSQL CLOSE C"RX_SQLVL RETURN GET_SQLNO: /* find nummer på rexxsql-cursor på dette level */ ARG RX_IX IF RX_SQLNO.RX_IX = '' THEN DO RX_SQLNO = RX_SQLNO + 1 RX_SQLNO.RX_IX = RX_SQLNO END RETURN RX_SQLNO.RX_IX EVT_SQL_MQ_TERMINERING: /* ved exit fra RXS, også exit i utide */ IF SYMBOL('RX_SQL_DONE') <> 'LIT' THEN DO IF RX_SQL_DONE <> '' THEN DO ADDRESS DSNREXX SELECT WHEN RX_SQL_DONE = 2 THEN DO ZEDSMSG = 'SQL commit' ZEDLMSG = 'SQL changes are committed. ' "EXECSQL COMMIT" IF SQLCODE <> 0 THEN DO say 'RXS: sql commit fails, sqlcode: ' SQLCODE CALL SQL_TERMINERING_ER_FEJLET END END WHEN RX_SQL_DONE = 3 THEN DO ZEDSMSG = '' IF SYMBOL('ZEDLMSG') = 'LIT' THEN ZEDLMSG = '' ZEDLMSG = 'SQL rollback: 'ZEDLMSG "EXECSQL ROLLBACK" IF SQLCODE <> 0 THEN DO say 'RXS: sql rollback fails, sqlcode: ' SQLCODE CALL SQL_TERMINERING_ER_FEJLET END END WHEN RX_SQL_DONE = 1 THEN DO /* "EXECSQL COMMIT" commit uden changes */ /* IF SQLCODE <> 0 THEN say 'sql commit fails, sqlcode: 'SQLCODE */ NOP /* 2015-06-17: ovenstående fjernet */ END OTHERWISE NOP END IF RX_SQL_DONE <> 'A' THEN DO /* tidligere blank, endnu tidl '1' */ "DISCONNECT" if rc <> 0 then do say 'RXS: sql disconnect fails, due to iterative call of DB2' say 'RXS: Probably ok' end /* IF SQLCODE <> 0 THEN DO */ /* SAY 'RXS: sql disconnect fails, sqlcode: ' SQLCODE */ /* CALL SQL_TERMINERING_ER_FEJLET 2016-04-19 fjernet */ /* END */ END ADDRESS TSO RX_RC = RXSUBCOM('DELETE','DSNREXX','DSNREXX') /* Fjern dsnrexx */ RX_SQL_DONE = '' END END /* EVT_MQ_TERMINERING: */ IF SYMBOL('RX_MQ_DONE') <> 'LIT' THEN DO IF DATATYPE(RX_MQHANDLE) = 'NUM' THEN DO IF RX_MQ_DONE = 2 THEN DO ADDRESS ISPEXEC "SELECT PGM(RXSDO) PARM(Q MQCMIT "RX_MQHANDLE")" IF RC > 100 THEN DO ADDRESS TSO "EXECIO * DISKR RXSOUTP (STEM RX_TEMP. OPEN FINIS)" SAY RX_TEMP.1 END ZEDSMSG = "MQ commit" ZEDLMSG = ZEDSMSG"; MQ changes are committed." END IF RX_MQ_DONE <> '' THEN DO ADDRESS ISPEXEC "SELECT PGM(RXSDO) PARM(Q MQDISC "RX_MQHANDLE")" IF RC > 100 THEN DO ADDRESS TSO "EXECIO * DISKR RXSOUTP (STEM RX_TEMP. OPEN FINIS)" SAY RX_TEMP.1 END IF RX_MQ_DONE = '3' THEN DO ZEDSMSG = "MQ rollback" ZEDLMSG = ZEDLMSG" MQ changes are rolled back." END-IF RX_MQ_DONE = '' END END END IF SYMBOL('ZEDLMSG') <> 'LIT' THEN DO IF LEFT(ZEDLMSG,2) = 'MQ' ! LEFT(ZEDLMSG,2) = 'SQ' THEN CALL ISPF_MESS END RETURN SQL_TERMINERING_ER_FEJLET: /* 2015-06-17 */ CALL SQLFEJL_GET_DSNTIAR SAY tiar_msg ZISPFRC = 16 /* medfører at ISPSTART giver denne RC */ ADDRESS ISPEXEC "VPUT (ZISPFRC) SHARED" EXIT 16 MQ_CONNECT: MQ = TRANSLATE(MQ) IF RX_MQ_DONE = '' THEN DO RX_MQ_DONE = 1 RX_GMQ = MQ ADDRESS ISPEXEC "SELECT PGM(RXSDO) PARM(Q MQCONN "TRANSLATE(MQ)")" RX_RC = RC IF RC > 0 & RC < 100 THEN DO SAY "Instalation error? Attempt to call loadmodule RXSMQ fails" CALL ISPF_GETMSG('') END ADDRESS TSO "EXECIO * DISKR RXSOUTP (STEM RX_TEMP. OPEN FINIS)" INTERPRET RX_TEMP.1 /* skaf MQHANDLE */ IF RX_RC > 0 THEN DO RX_T = 1 /* placer fejlmeddelelse i top */ CALL SYNTAXFEJL END END ELSE DO IF RX_GMQ <> '' & RX_GMQ <> MQ THEN DO RX_FMESS = "MQ: MQ (MQ-system) cannot change from "RX_GMQ" to "MQ CALL SYNTAXFEJL END END RETURN USER_RETURN: ARG ARGU IF RX_PROMPT_OK_LVL = 0 THEN DO CALL EXIT_I_UTIDE ARGU END ELSE DO IF RX_SQL_DONE = 1 THEN CALL RXSSPUFI_CLOSE /* SQL SELECT UDFØRT */ RX_PROMPT_LEAVE = 1 RX_PROMPT_OK_LVL = -1 /* der hoppes til første panel */ IF RX_SQL_DONE = 2 THEN RX_SQL_DONE = 3 /* ingen commit */ IF RX_MQ_DONE = 2 THEN RX_MQ_DONE = 1 /* ingen commit */ CALL EVT_SQL_MQ_TERMINERING END RETURN USER_EXIT: ARG RX_ARG IF DATATYPE(RX_ARG) <> 'NUM' THEN RX_ARG = 0 ZEDSMSG = "" ZEDLMSG = "Terminated by programmed exit, RC="RX_ARG CALL ISPF_MESS_COND CALL EXIT_I_UTIDE RX_ARG RETURN EXIT_I_UTIDE: /* arg er den ønskede rc */ ARG RX_ARG IF RX_ARG = '' THEN RX_ARG = 0 IF SYMBOL('RX_SQL_DONE') <> 'LIT' THEN DO IF RX_SQL_DONE = 2 THEN RX_SQL_DONE = 3 /* ingen commit */ END IF SYMBOL('RX_MQ_DONE') <> 'LIT' THEN DO IF RX_MQ_DONE = 2 THEN RX_MQ_DONE = 1 /* ingen commit */ END CALL EVT_SQL_MQ_TERMINERING IF RX_KALDTYP = 'BATCH' THEN DO ZISPFRC = RX_ARG /* medfører at ISPSTART giver denne RC */ ADDRESS ISPEXEC "VPUT (ZISPFRC) SHARED" IF RX_ARG > 15 THEN DO /* 2017-09-29 */ ADDRESS TSO "SEND ", "'Error in RXS. See //SYSTSPRT in STEP: '", "USER("sysvar('sysuid')")" ADDRESS TSO "SEND ", "'------------------------------------- '", "USER("sysvar('sysuid')")" END EXIT RX_ARG /* 2006-01-01: hvis batch, expose returkode */ END IF SYMBOL('ZEDSMSG') <> 'LIT' THEN DO IF ZEDSMSG <> '' THEN ADDRESS ISPEXEC "SETMSG MSG(ISRZ000)" END EXIT /* RX_ARG 2005-02-01 hvis ikke batch, altid RC=0 */ SQLFEJL: RX_TSTOUT.1 = , 'RXS: Error was encountered using the DB2-system, SQL =' SQL RX_TSTOUT.2 = ' ' IF SQLCODE = -924 & WORDPOS(SQL,SKAFSSID()) = 0 THEN DO RX_TSTOUT.2 = 'Wrong system. DB2 systems on this installation:', SKAFSSID() END CALL SQLFEJL_GET_DSNTIAR lin. = '' do i = 0 to 9 lin.i = substr(tiar_msg,1 + i * 80,80) if lin.i = '' then leave end msgtext = '' do i = 0 to 9 if substr(lin.i,1,4) = 'DSNT' & msgtext <> '' then leave msgtext = msgtext' 'space(substr(lin.i,10)) end RX_TSTOUT.3 = "--Message: ----------------------------" RX_II = 4 RX_I = 1 OUTMSG = "" IF RX_SQL_DONE = 2 THEN RX_SQL_DONE = 3 /* ingen commit */ IF RX_MQ_DONE = 2 THEN RX_MQ_DONE = 3 /* ingen commit */ CALL EVT_SQL_MQ_TERMINERING DO FOREVER MSGWRD = WORD(MSGTEXT,RX_I) OUTMSG = OUTMSG" "MSGWRD IF LENGTH(OUTMSG) > 65 THEN DO RX_TSTOUT.RX_II = OUTMSG RX_II = RX_II + 1 OUTMSG = "" END IF MSGWRD = "" THEN DO RX_TSTOUT.RX_II = OUTMSG RX_II = RX_II + 1 LEAVE END RX_I = RX_I + 1 END RX_TSTOUT.RX_II = "--Sqlstate: ---------------------------" RX_II = RX_II + 1 RX_TSTOUT.RX_II = "sqlstate: "SQLSTATE RX_II = RX_II + 1 RX_TSTOUT.RX_II = "sqlerrp: "SQLERRP RX_II = RX_II + 1 RX_TSTOUT.RX_II = "--SQL statement: ----------------------" RX_II = RX_II + 1 DO RX_I = 1 TO SEK_INPUT.0 RX_TSTOUT.RX_II = SEK_INPUT.RX_I RX_II = RX_II + 1 END IF RX_HOSTVAR.1 <> '' THEN DO RX_TSTOUT.RX_II = "--Host variables: ('?' meaning null) --" RX_II = RX_II + 1 DO RX_I = 1 TO 9999 IF RX_HOSTVAR.RX_I = '' THEN LEAVE RX_TSTOUT.RX_II = RX_HOSTVAR.RX_I"="VALUE(RX_HOSTVAR.RX_I) RX_II = RX_II + 1 END END RX_TSTOUT.0 = RX_II - 1 ADDRESS ISPEXEC ZEDSMSG = 'SQL: error found' CALL ISPF_MESS CALL VIEW_RX_TSTOUT ADDRESS ISPEXEC "SETMSG MSG(ISRZ000)" CALL FREE_LM CALL EXIT_I_UTIDE 16 RETURN SQLFEJL_GET_DSNTIAR: sqlca = 'SQLCA 'x2c(00000088)x2c(d2x(sqlcode,8)) sqlca = sqlca!!x2c(d2x(length(sqlerrmc),4))!!left(sqlerrmc,70) sqlca = sqlca!!left(sqlerrp,8)!!x2c(d2x(sqlerrd.1,8)) sqlca = sqlca!!x2c(d2x(sqlerrd.2,8))!!x2c(d2x(sqlerrd.3,8)) sqlca = sqlca!!x2c(d2x(sqlerrd.4,8))!!x2c(d2x(sqlerrd.5,8)) sqlca = sqlca!!x2c(d2x(sqlerrd.6,8))!!left(sqlwarn.0,1) sqlca = sqlca!!left(sqlwarn.1,1)!!left(sqlwarn.2,1) sqlca = sqlca!!left(sqlwarn.3,1)!!left(sqlwarn.4,1) sqlca = sqlca!!left(sqlwarn.5,1)!!left(sqlwarn.6,1) sqlca = sqlca!!left(sqlwarn.7,1)!!left(sqlwarn.8,1) sqlca = sqlca!!left(sqlwarn.9,1)!!left(sqlwarn.10,1)!!left(sqlstate,5) tiar_msg = x2c(0190)copies(' ',400) text_len = x2c(00000050) address attchpgm 'dsntiar sqlca tiar_msg text_len' tiar_msg = substr(tiar_msg,4) /* Strip off længdefelt */ RETURN UDSKRIV_RX_SOU: RX_M = 0 DO RX_X = 1 TO 99 IF RX_SOU.RX_X = "" THEN ITERATE SOU = RX_SOU.RX_X RX_M = RX_M + 1 RX_TSTOUT.RX_M = '--------LEVEL = ' RX_X '-------orders:-------' RX_M = RX_M + 1 IF RX_X > 1 THEN DO RX_TSTOUT.RX_M = RX_ORDERS.RX_X RX_M = RX_M + 1 END RX_TSTOUT.RX_M = '--------LEVEL = ' RX_X '-------source:-------' RX_GZ = 1 DO FOREVER RX_Z = POS(';',SOU,RX_GZ) IF RX_Z = 0 THEN LEAVE LGD = RX_Z + 1 - RX_GZ RX_M = RX_M + 1 RX_TSTOUT.RX_M = SUBSTR(SOU,RX_GZ,LGD) RX_GZ = RX_Z + 1 END END RX_TSTOUT.0 = RX_M ZEDSMSG = 'Press 'RXENDTXT' to continue' CALL ISPF_MESS CALL VIEW_RX_TSTOUT SAY 'variables found in source:' , SUBSTR(RX_EXPLIST,RX_EXPLIST_BASIS_LGTH) RETURN VIEW_RX_TSTOUT: IF RX_KALDTYP = 'BATCH' THEN DO DO RX_I = 1 TO RX_TSTOUT.0 SAY RX_TSTOUT.RX_I END RETURN END ADDRESS TSO IF LISTDSI('RXS.TESTOUT') ^= 0 THEN DO "ALLOC DA(RXS.TESTOUT) NEW REUSE "RX_UNIT_VOL" ", "LRECL(250) RECFM(F B) SPACE(1 1) CYL DSORG(PS)" END "ALLOC DA(RXS.TESTOUT) FI(RXTEST) OLD REUSE" IF RC > 0 THEN DO ADDRESS ISPEXEC ZEDSMSG = "Dataset in use?" ZEDLMSG ="Dataset RXS.TESTOUT could not be allocated as old, RC=" RC CALL ISPF_MESS CALL EXIT_I_UTIDE END "EXECIO * DISKW RXTEST (STEM RX_TSTOUT. OPEN FINIS)" "FREE FI(RXTEST)" ADDRESS ISPEXEC "BROWSE DATASET(RXS.TESTOUT)" RETURN RX_Q: /* kaldes fra load rxsdo */ ARG RX_OUT CALL DROPQUEUE RX_OUT RETURN DROPQUEUE: ARG RX_OUT IF WORD(RX_OUT,2) <> '' THEN DO RX_FMESS = "Only one arg for dropqueue: the queuename" CALL SYNTAXFEJL END RX_ST_LI = , "IF SYMBOL('RX_GLB."RX_OUT"_1.1') = 'LIT' THEN RX_GLB."RX_OUT"_STEMIX=0" INTERPRET RX_ST_LI RX_ST_LI = "RX_GLB."RX_OUT"_STEMIX = 0" INTERPRET RX_ST_LI IF RX_OUT = RX_Q_SORT THEN RX_Q_SORT = '-' RETURN QUEUEVAR: PARSE ARG RX_QUEUEY, RX_WORDY rx_this = 'Q' return queuequeue(RX_QUEUEY, RX_WORDY) GETQUEUE: PARSE ARG RX_QUEUEY, RX_WORDY rx_this = 'G' return queuequeue(RX_QUEUEY, RX_WORDY) QUEUEQUEUE: PARSE ARG RX_QUEUEY, RX_WORDY if rx_this = 'Q' then RX_BLIND = 0 if rx_this = 'G' then RX_BLIND = "" IF WORD(RX_QUEUEY,2) <> '' ! RX_WORDY = "" THEN DO if rx_this = 'Q' then RX_BLIND = "QUEUEVAR" if rx_this = 'G' then RX_BLIND = "GETQUEUE" RX_FMESS = , RX_BLIND "uses two args: queuename and arg separated by comma" CALL SYNTAXFEJL END IF SYMBOL('RX_Q_ANT') = 'LIT' THEN RX_Q_ANT = 0 IF RX_Q_SORT <> RX_QUEUEY THEN DO RX_Q_SORT = RX_QUEUEY RX_Q_ANT = 0 END IF RX_Q_SORT = RX_QUEUEY THEN RX_Q_ANT = RX_Q_ANT + 1 IF SYMBOL('RX_GLB.'RX_QUEUEY'_STEMIX') = 'LIT' THEN RETURN RX_BLIND IF VALUE('RX_GLB.'RX_QUEUEY'_STEMIX') = 0 THEN RETURN RX_BLIND IF RX_Q_ANT = 3 THEN DO RX_Q_SORT = RX_QUEUEY ADDRESS ISPEXEC "CONTROL ERRORS RETURN" "TBCREATE RXSORTQ NAMES(RXUNIT1 RXUNIT2) NOWRITE SHARE" RX_IS_NUM = 1 RX_III = VALUE("RX_GLB."RX_QUEUEY'_1.0') DO RX_II=1 TO RX_III RXUNIT1 = VALUE("RX_GLB."RX_QUEUEY"_1."RX_II) IF LENGTH(RXUNIT1) > 256 THEN DO RX_Q_SORT = '-' RX_Q_ANT = 0 LEAVE END IF DATATYPE(RXUNIT1) <> 'NUM' THEN RX_IS_NUM = 0 IF SYMBOL("RX_GLB."RX_QUEUEY"_2."RX_II) = 'VAR' THEN DO RXUNIT2 = VALUE("RX_GLB."RX_QUEUEY"_2."RX_II) END ELSE DO RXUNIT2 = "" END "TBADD RXSORTQ" END IF RX_Q_SORT <> '-'THEN DO "TBSORT RXSORTQ FIELDS(RXUNIT1 B A)" /* binær sort */ "TBTOP RXSORTQ" DO RX_II = 1 TO RX_III "TBSKIP RXSORTQ" RX_ELM.RX_II = RXUNIT1 RX_ELM2.RX_II = RXUNIT2 END END "TBEND RXSORTQ" ADDRESS STDOUT END IF RX_Q_ANT >= 3 THEN DO /* ...binær søgning */ RX_III = VALUE("RX_GLB."RX_QUEUEY'_1.0') RX_MAXI = RX_III + 1 RX_MINI = 1 do forever RX_NY = RX_MINI + trunc((RX_MAXI - RX_MINI) / 2) IF RX_IS_NUM = 1 THEN DO select when RX_NY = RX_MINI then leave /* stop: evt fundet */ when RX_WORDY << RX_ELM.RX_NY then RX_MAXI = RX_NY when RX_WORDY >> RX_ELM.RX_NY then RX_MINI = RX_NY otherwise leave /* 2019-07-22: 'strict' ulighed ovenfor */ end END ELSE DO select when RX_NY = RX_MINI then leave /* stop: evt fundet */ when RX_WORDY < RX_ELM.RX_NY then RX_MAXI = RX_NY when RX_WORDY > RX_ELM.RX_NY then RX_MINI = RX_NY otherwise leave /* 2019-07-22: ej 'strict' ulighed ovenfor */ end END end if RX_WORDY = RX_ELM.RX_NY then do if rx_this = 'Q' then return 1 if rx_this = 'G' then return RX_ELM2.RX_NY end END ELSE DO /* alm søgning */ RX_III = VALUE("RX_GLB."RX_QUEUEY'_1.0') DO RX_II=1 TO RX_III IF VALUE("RX_GLB."RX_QUEUEY'_1.'RX_II) = RX_WORDY THEN DO if rx_this = 'Q' then return 1 if rx_this = 'G' then return VALUE("RX_GLB."RX_QUEUEY"_2."RX_II) end END END RETURN RX_BLIND /* e r r o r h a n d l i n g : */ ISPF_GETMSG: /* arg er en ispf-cmd som ønskes udført inden exit */ ARG RX_ISPFCMD /* fx en eller anden form for close */ IF SYMBOL('ZERRMSG') <> 'LIT' THEN DO ADDRESS ISPEXEC "GETMSG MSG("ZERRMSG") LONGMSG(RXFMESS)" RX_FMESS = RXFMESS END ELSE DO /* 2007-06-20: */ RX_FMESS = 'Command set return code RC='RC' without ispf message' END IF RX_ISPFCMD > '' THEN ADDRESS ISPEXEC RX_ISPFCMD CALL SYNTAXFEJL RETURN SYNTAXFEJL_REXX: IF SYMBOL('RX_T') = 'LIT' THEN RX_T = 0 IF RX_T = 0 THEN DO SAY '*** Installation error or internal RXS error:' SAY '*** Line ' SIGL ' in RXS in error:' SOURCELINE(SIGL) SAY '*** 'ERRORTEXT(RC) END IF SYMBOL('RX_TRACE') = 'LIT' THEN RX_TRACE = "" IF RX_TRACE = '?TRACE' THEN DO SAY 'Error triggered from line' SIGL 'in REXX program RXS' IF SYMBOL('RX_STMT') <> 'LIT' THEN say RX_STMT END RX_FMESS = ERRORTEXT(RC) condition('D') RX_MILJ = 'REXX' CALL SYNTAXFEJL RETURN EJVALUE: RX_MILJ = 'REXX' RX_FMESS = "Variable not initialized: "CONDITION('D') IF RX_TRACE = '?TRACE' ! LEFT(CONDITION('D'),3) = 'RX_' THEN DO RX_FMESS = RX_FMESS, '***Error triggered from line' SIGL SOURCELINE(SIGL) , 'in REXX program RXS' END CALL SYNTAXFEJL RETURN SYNTAXFEJL: /* rx_fmess og evt rx_fmess2 er input */ PARSE ARG RX_ARG /* kan evt. kaldes med rx_fmess som arg */ IF RX_ARG > '' THEN DO RX_FMESS = RX_ARG RX_FMESS2 = '' END IF SYMBOL('RX_MILJ') = 'LIT' THEN RX_MILJ = 'RXS' IF SYMBOL('RX_T') = 'LIT' THEN RX_T = 1 IF SYMBOL('RX_J') = 'LIT' THEN RX_J = 1 IF SYMBOL('IN_NAMESPACE') = 'LIT' THEN IN_NAMESPACE = "" IF SYMBOL('RX_IMBED_MBR') = 'LIT' THEN RX_IMBED_MBR = "-" IF SYMBOL('RX_KALDTYP') = 'LIT' THEN RX_KALDTYP = 'TSOCMD' IF SYMBOL('RXINMEMB') = 'LIT' THEN RXINMEMB = "" IF SYMBOL('RX_TRACE') = 'LIT' THEN RX_TRACE = "" IF SYMBOL('RX_FMESS2') = 'LIT' THEN RX_FMESS2 = "" IF SYMBOL('RXMFIRST') = 'LIT' THEN RXMFIRST = 0 /*2008-08-25*/ RX_T = RX_T + RXMFIRST - 1 /*2008-08-25*/ ZEDSMSG= "" RX_WHTKST = '' IF RXINMEMB = '' THEN RXINMEMB = 'the inline program' IF RX_T > 0 THEN RX_WHTKST = " Error in line "RX_T" in "RXINMEMB IF LENGTH(RX_FMESS2) > 0 THEN DO ZEDLMSG= RX_MILJ""RX_WHTKST": "RX_FMESS ". " RX_FMESS2 END ELSE DO ZEDLMSG= RX_MILJ""RX_WHTKST": "RX_FMESS END IF IN_NAMESPACE = 1 THEN DO ZEDLMSG= , RX_MILJ" Error in NAMESPACE-input block line no."RX_J":"RX_FMESS END SELECT /* 2017-10-27 */ WHEN RX_IMBED_MBR ^= '-' THEN DO IF RX_KALDTYP = 'MACRO' THEN CALL LISTVARS CALL FEJL_I_IMBEDDED END WHEN RX_KALDTYP = 'BATCH' THEN DO /* 2017-10-03 */ say " " SAY RX_MILJ""RX_WHTKST": " say " "RX_FMESS" "RX_FMESS2 say " " END WHEN RX_KALDTYP = 'MACRO' THEN DO /* macro <===== */ ZEDSMSG = RX_MILJ' error found' ADDRESS ISREDIT IF RX_T > 1 THEN RX_T = RX_T - 1 "L "RX_T /* hvis fejlen er knyttet til linie i pgm: */ IF RC = 0 & LENGTH(RX_FMESS) < 59 THEN DO IF SYMBOL('ZERRLM') ^= 'LIT' & LEFT(RX_FMESS,1) = '#' THEN DO ZEDSMSG = "" ZEDLMSG = ZERRSM ': ' ZERRLM' .' END /* 2001-12-05: forudsætter fmess ikke indeholder enkeltquote */ IF SYMBOL('RX_FMESS2') ^= 'LIT' THEN DO IF LENGTH(RX_FMESS2) > 0 THEN DO RX_FMESS2 = LEFT(RX_FMESS2,58) RXXMESS = RX_MILJ" "RX_FMESS2":" "LINE_AFTER "RX_T" = MSGLINE (RXXMESS)" END END RX_FMESS = LEFT(RX_FMESS,58) RX_BLWTKST = "error:" IF RX_T > 1 THEN RX_BLWTKST = "error below:" RXXMESS = strip(RX_MILJ" "RX_BLWTKST" "RX_FMESS) "LINE_AFTER "RX_T" = MSGLINE (RXXMESS)" IF RC > 0 THEN ZEDSMSG = "" IF IN_NAMESPACE = 1 THEN DO "LINE_AFTER "RX_T" = MSGLINE 'Error in NAMESPACE-input ", "in block at line no "RX_J":'" END END ELSE DO /* 2017-11-08 */ ZEDSMSG = '' ADDRESS ISPEXEC "SETMSG MSG(ISRZ000)" END END OTHERWISE DO ZEDLMSG = " Error executing RXSLIB-member "RXINMEMB": "ZEDLMSG IF LEFT(RXINMEMB,1) = '!' THEN DO ZEDLMSG = "Outside EDIT, macros cannot execute. Remove '!'" END CALL LISTVARS ADDRESS ISPEXEC "SETMSG MSG(ISRZ000)" END END /* SELECT */ IF RX_IMBED_MBR = '-' THEN CALL LISTVARS /* vis globale variable */ CALL FREE_LM CALL EXIT_I_UTIDE 16 /* 2007-12-18 exit 8 -> exit 16 */ RETURN FEJL_I_IMBEDDED: ZEDLMSG = ZEDLMSG" The error is found in )IMBEDded source", "'"RX_IMBED_MBR"'." IF RX_KALDTYP = 'BATCH' THEN DO say " " say "Error in )IMBEDded source:" SAY RX_MILJ""RX_WHTKST": " say " "RX_FMESS" "RX_FMESS2 say " " END ELSE DO ADDRESS ISPEXEC "SETMSG MSG(ISRZ000)" RX_LIB='RXSLIB' "LMINIT DATAID(RXSIN) DDNAME("RX_LIB") ORG(INDORG) ENQ(SHR)" "BROWSE DATAID(&RXSIN) MEMBER("RX_IMBED_MBR")" "LMCLOSE DATAID(&RXSIN)" "LMFREE DATAID(&RXSIN)" END RETURN FREE_LM: ADDRESS ISPEXEC IF SYMBOL('RXSDID') <> 'LIT' THEN DO "LMCLOSE DATAID(&RXSDID)" "LMFREE DATAID(&RXSDID)" END IF SYMBOL('RXSIN') <> 'LIT' THEN DO "LMCLOSE DATAID(&RXSIN)" "LMFREE DATAID(&RXSIN)" END IF SYMBOL('RXDAID') <> 'LIT' THEN DO "LMCLOSE DATAID("RXDAID")" "LMFREE DATAID("RXDAID")" END RETURN ISPF_MESS: ADDRESS ISPEXEC "SETMSG MSG(ISRZ000)" IF RX_KALDTYP = 'BATCH' THEN DO /* batch */ SAY "Status at Termination: " ZEDSMSG /* batch */ SAY " " ZEDLMSG /* batch */ END /* batch */ RETURN ISPF_MESS_COND: ADDRESS ISPEXEC "SETMSG MSG(ISRZ000) COND" /* kun hvis pend mess ikke udestår */ IF RX_KALDTYP = 'BATCH' THEN DO IF ZEDLMSG <> '' THEN DO SAY ' ' SAY ZEDLMSG SAY ' ' ZEDLMSG = '' /* 2015-11-03 */ END END RETURN LISTVARS: /* vis alle tilføjede variable i explist: */ RX_TXT = 'Global variables: ' if symbol('rx_explist_basis_lgth') = 'LIT' then return IF LENGTH(RX_EXPLIST) > RX_EXPLIST_BASIS_LGTH THEN DO RX_LIST = SUBSTR(RX_EXPLIST,RX_EXPLIST_BASIS_LGTH) DO RX_I = 1 TO 200 RX_W = WORD(RX_LIST,RX_I) IF RX_W = '' THEN LEAVE IF SYMBOL(RX_W) = 'LIT' THEN ITERATE IF RX_W = 'ZEDLMSG' THEN ITERATE IF RX_W = 'ZEDSMSG' THEN ITERATE IF DATATYPE(VALUE(RX_W)) = 'NUM' THEN DO RX_TX = RX_W"="VALUE(RX_W) END ELSE DO RX_TX = RX_W"='"VALUE(RX_W)"'" END IF LENGTH(RX_TX) + LENGTH(RX_TXT) < 72 THEN DO RX_TXT = RX_TXT""RX_TX";" END ELSE DO CALL LISTVARS_SUB RX_TXT = RX_TX";" END END IF LENGTH(RX_TXT) > 18 THEN DO RXXMESS = LEFT(RX_TXT,71) CALL LISTVARS_SUB END IF SYMBOL('UNIT.1') <> 'LIT' THEN DO /* 2018-12-19: quoted */ IF UNIT.1 <> '' THEN DO RXXMESS = " UNIT.1='"UNIT.1"'" ADDRESS ISREDIT "LINE_BEFORE "RX_T+1" = NOTELINE (RXXMESS)" END END IF SYMBOL('UNIT.2') <> 'LIT' THEN DO /* 2018-12-19: quoted */ IF UNIT.2 <> '' THEN DO RXXMESS = " UNIT.2='"UNIT.2"'" ADDRESS ISREDIT "LINE_BEFORE "RX_T+1" = NOTELINE (RXXMESS)" END END END RETURN LISTVARS_SUB: RXXMESS = LEFT(RX_TXT,71) SELECT WHEN RX_KALDTYP = 'BATCH' THEN SAY RXXMESS WHEN RX_IMBED_MBR ^= '-' THEN ZEDLMSG = ZEDLMSG '-' RXXMESS WHEN RX_KALDTYP = 'MACRO' THEN DO ADDRESS ISREDIT "LINE_BEFORE "RX_T+1" = NOTELINE (RXXMESS)" END OTHERWISE ZEDLMSG = ZEDLMSG '-' RXXMESS END RETURN DISPLAY_SCAN_PARMS: RX_DISPX = LEFT(" ",RX_LVL) SAY RX_DISPX"***********************************" SAY RX_DISPX"Line no: "RX_T" Entry in action-block" SAY RX_DISPX"Using FUNC : "FUNC SAY RX_DISPX"Using IN : "IN SAY RX_DISPX"Using OUT : "OUT SAY RX_DISPX"Using OUTFUNC :"OUTFUNC SAY RX_DISPX"ADDRESS : "ADDRESS() SAY , RX_DISPX"ORDERS : "SUBSTR(RX_ORDERS.RX_LVL,POS(';',RX_ORDERS.RX_LVL)+1) SAY RX_DISPX"***********************************" RETURN DISPLAY_IMBED_PARMS: SAY "***********************************" SAY "Line no: "RX_T" Entry in IMBED Using IMBED:" IMBED" Lvl: "RX_LVL RETURN LOOP_PRIM_SEK_NAMESPACE: CALL INDLAES_SEK IF IN = '-' THEN DO IF SYMBOL('INFILE') = 'LIT' THEN DO RX_FMESS = "FUNC='NAMESPACE': No input found - 'IN' has no value" CALL SYNTAXFEJL END END IF DATATYPE(SEK_INPUT.0) ^= 'NUM' THEN SEK_INPUT.0 = 0 IF SYMBOL('NAMESPACE_1') = 'LIT' THEN DO /* 2007-04-27 */ NAMESPACE_1 = '(' NAMESPACE_2 = ')' END RX_SEK_INPUT_MAX = '' /* namespace input i een lang streng */ DO RX_J = 1 TO SEK_INPUT.0 IF POS('/*',SEK_INPUT.RX_J) = 1 THEN DO IF POS('*/',SEK_INPUT.RX_J) - LENGTH(SEK_INPUT.RX_J) = -1 THEN DO SEK_INPUT.RX_J = '' END END RX_SEK_INPUT_MAX = RX_SEK_INPUT_MAX' 'SEK_INPUT.RX_J END RX_SEK_INPUT_MAX = RX_SEK_INPUT_MAX' ;' RX_START = 1 RX_LGD = LENGTH(RX_SEK_INPUT_MAX) CONT = ',' RX_J = 1 DO FOREVER /* find hver enkelt trigger unit: */ RX_SLUT = POS(';',RX_SEK_INPUT_MAX,RX_START + 1) /* hvis der står ';' inde i parantes: */ DO WHILE LASTPOS(NAMESPACE_1,RX_SEK_INPUT_MAX,RX_SLUT) > , LASTPOS(NAMESPACE_2,RX_SEK_INPUT_MAX,RX_SLUT) RX_STARTX = RX_SLUT RX_SLUT = POS(';',RX_SEK_INPUT_MAX,RX_STARTX + 1) END IF RX_SLUT = 0 THEN RX_SLUT = RX_LGD SEK_NAMESPACE.RX_J = , SUBSTR(RX_SEK_INPUT_MAX,RX_START + 1,RX_SLUT - RX_START - 1) IF SEK_NAMESPACE.RX_J > '' THEN RX_J = RX_J + 1 RX_START = RX_SLUT IF RX_START = RX_LGD THEN LEAVE END SEK_NAMESPACE.0 = RX_J - 1 IF SEK_NAMESPACE.0 = 0 THEN DO /* notrigger situation: */ CONT = ' ' IF RX_NOTRIG = 1 THEN INTERPRET RX_NOSOURCE RETURN END CONT = ',' RX_VARXX_GEM = '' RX_VARXX = '' DO RX_J = 1 TO SEK_NAMESPACE.0 IF RX_J = SEK_NAMESPACE.0 THEN CONT = ' ' SPACEROW = STRIP(SEK_NAMESPACE.RX_J';') RX_SEK_INPUT_AKT = PARMSPACE(SEK_NAMESPACE.RX_J) DO RX_I = 1 TO 999 /* put i explist og klargør nulstil */ RX_VARX = WORD(RX_PARMSPACE_LIST,RX_I) IF RX_VARX = '' THEN LEAVE IF RX_VARX <> WORD(RX_VARXX_GEM,RX_I) THEN DO RX_VARXX = RX_VARXX""RX_VARX" = '';" END END IN_NAMESPACE = 1 SEK_INPUT_ER_RELEVANT = 'J' INTERPRET RX_SEK_INPUT_AKT IN_NAMESPACE = '' INTERPRET RX_SOURCE IF CONT = ',' THEN DO INTERPRET RX_VARXX /* nulstil variabel inden næste gennemløb */ END /* dog ikke i sidste gennemløb */ RX_VARXX_GEM = RX_PARMSPACE_LIST END RETURN PARMSPACE: PARSE ARG RX_IND IF RX_IND = "" THEN DO RETURN RX_IND END rx_ixx = 1 /* 2016-02-12 check parantes balance i namespace */ rx_pst = 1 do forever rx_ixx = POS(NAMESPACE_1,RX_IND,rx_ixx) if rx_ixx = 0 then leave rx_ixx = rx_ixx + 1 rx_pst = rx_pst + 1 end rx_ixx = 1 rx_psl = 1 do forever rx_ixx = POS(NAMESPACE_2,RX_IND,rx_ixx) if rx_ixx = 0 then leave rx_ixx = rx_ixx + 1 rx_psl = rx_psl + 1 end if rx_pst > rx_psl then do RX_FMESS = 'Too many starting parantheses' RX_FMESS2 = 'in assignment ' strip(RX_IND) CALL SYNTAXFEJL end if rx_pst < rx_psl then do RX_FMESS = 'Too many ending parantheses' RX_FMESS2 = 'in assignment ' strip(RX_IND) CALL SYNTAXFEJL end RX_PRMSP_VARLGD = 0 RX_IND_OPR = RX_IND RX_X = POS('/*',RX_IND) /* Fjern kommentarblok */ IF RX_X > 0 THEN DO RX_Y = POS('*/',RX_IND) IF RX_Y > 0 & RX_X < RX_Y THEN DO RX_IND = LEFT(RX_IND,RX_X - 1)!!, SUBSTR(RX_IND,RX_Y+2,LENGTH(RX_IND)) END END RX_UD = "" RX_PARMSPACE_LIST = "" /* liste over fundne variable */ RX_I_PARA = 0 RX_U_PARA = 0 RX_I_MRK = 0 RX_IMX = LENGTH(RX_IND) DO RX_I = 1 TO RX_IMX RX_CHR = SUBSTR(RX_IND,RX_I,1) SELECT WHEN RX_CHR = NAMESPACE_1 THEN DO /* NAMESPACE_1 er normalt '(' */ RX_I_PARA = RX_I_PARA + 1 /* NAMESPACE_2 er normalt ')' */ IF RX_I_PARA - RX_U_PARA = 1 THEN DO IF RX_I_MRK = 0 THEN DO RX_FMESS = 'variable name missing in front of paranthesis' RX_FMESS2 = 'in assignment ' strip(RX_IND_OPR) CALL SYNTAXFEJL END RX_UD = RX_UD!!'="' RX_PARMSPACE_LIST = RX_PARMSPACE_LIST!!' ' RX_PRMSP_VARLGD = 1 /* længde af variabel */ END ELSE DO RX_UD = RX_UD""RX_CHR END END WHEN RX_CHR = NAMESPACE_2 THEN DO RX_U_PARA = RX_U_PARA + 1 IF RX_I_PARA - RX_U_PARA = 0 THEN DO RX_UD = RX_UD!!'";' RX_I_MRK = 0 RX_PRMSP_VARLGD = 0 /* længde af variabel */ END ELSE DO RX_UD = RX_UD""RX_CHR END END WHEN RX_CHR = '"' THEN DO /* 2003-01-17 */ RX_QQ = '"' RX_QQ = "'"RX_QQ"'" RX_UD = RX_UD'"!!'RX_QQ'!!"' END OTHERWISE DO RX_UD = RX_UD""RX_CHR IF RX_PRMSP_VARLGD > 0 THEN DO RX_PRMSP_VARLGD = RX_PRMSP_VARLGD + 1 IF RX_PRMSP_VARLGD > 230 THEN DO /*max 250 i var.længde REXX*/ RX_UD = RX_UD'"!!"' RX_PRMSP_VARLGD = 1 END END IF RX_I_PARA = RX_U_PARA THEN DO IF RX_CHR > '' THEN DO RX_PARMSPACE_LIST = RX_PARMSPACE_LIST""RX_CHR END END IF RX_CHR <> " " THEN DO RX_I_MRK = RX_I_MRK + 1 END ELSE DO IF RX_I_MRK > 0 THEN DO IF RX_I_PARA = RX_U_PARA THEN DO RX_FMESS = 'NAMESPACE variablename contains spaces' RX_FMESS2 = 'in assignment ' strip(RX_IND_OPR) CALL SYNTAXFEJL END END END END END END IF RX_I_PARA <> RX_U_PARA THEN DO RX_FMESS = 'Paranthesis not terminated correctly' RX_FMESS2 = 'in assignment ' strip(RX_IND_OPR) /* 2014-10-20 */ CALL SYNTAXFEJL END IF RX_I_PARA = 0 THEN DO RX_FMESS = 'at least one paranthesis must exist' RX_FMESS2 = 'in assignment ' strip(RX_IND_OPR) /* 2014-10-20 */ CALL SYNTAXFEJL END RETURN RX_UD LOOP_PRIM_SEK_MBR: /* CSC-specific */ IF IN = '-' THEN DO /* CSC-specific */ RX_FMESS = "For FUNC='MBR' IN must be stated (name of PO-dataset)" /* CSC-specific */ CALL SYNTAXFEJL /* CSC-specific */ END /* CSC-specific */ RX_SEKIN = "'"IN"'" /* CSC-specific */ IF SYSDSN(RX_SEKIN) ^= 'OK' THEN DO /* CSC-specific */ RX_FMESS = STRIP(LEFT(SYSDSN(RX_SEKIN),22)) ': ' RX_SEKIN /* CSC-specific */ CALL SYNTAXFEJL /* CSC-specific */ END /* CSC-specific */ RX_RC = LISTDSI(RX_SEKIN) /* CSC-specific */ IF SYSDSORG <> 'PO' THEN DO /* CSC-specific */ RX_FMESS = "IN: "IN" must be partitioned" /* CSC-specific */ CALL SYNTAXFEJL /* CSC-specific */ END /* CSC-specific */ CONT = "," /* CSC-specific */ ADDRESS ISPEXEC /* CSC-specific */ "LMINIT DATAID(RXSSEK) DATASET('"IN"') ORG(DSORG) ENQ(SHR)" /* CSC-specific */ IF RC > 0 THEN DO /* CSC-specific */ RX_FMESS = "file " IN " not allocated as DATAID, rc: "RC /* CSC-specific */ CALL SYNTAXFEJL /* CSC-specific */ END /* CSC-specific */ "LMOPEN DATAID(&RXSSEK) LRECL(RXSRECL) RECFM(RXSRECF)" /* CSC-specific */ RXMBR = "" /* CSC-specific */ RX_LMMCNT = 0 /* CSC-specific */ DO FOREVER /* CSC-specific */ "LMMLIST DATAID(&RXSSEK) MEMBER(RXMBR) STATS(YES)" /* CSC-specific */ IF RC >= 4 THEN LEAVE /* CSC-specific */ RX_LMMCNT = RX_LMMCNT + 1 /* CSC-specific */ END /* CSC-specific */ "LMMLIST DATAID(&RXSSEK) MEMBER(RXMBR) STATS(YES) OPTION(FREE)" /* CSC-specific */ RXMBR = "" /* CSC-specific */ RX_LMMCNT_1 = 0 /* CSC-specific */ DO FOREVER /* CSC-specific */ ADDRESS ISPEXEC /* CSC-specific */ "LMMLIST DATAID(&RXSSEK) MEMBER(RXMBR) STATS(YES)" /* CSC-specific */ IF RC = 4 THEN DO /* notrigger situation: 2004-11-19 */ /* CSC-specific */ CONT = " " /* CSC-specific */ IF RX_NOTRIG = 1 THEN DO /* CSC-specific */ ADDRESS STDOUT /* CSC-specific */ INTERPRET RX_NOSOURCE /* CSC-specific */ END /* CSC-specific */ RETURN /* CSC-specific */ END /* CSC-specific */ IF RC >= 4 THEN LEAVE /* CSC-specific */ MBR = STRIP(RXMBR) /* CSC-specific */ RX_LMMCNT_1 = RX_LMMCNT_1 + 1 /* CSC-specific */ IF RX_LMMCNT_1 = RX_LMMCNT THEN CONT = " " /* CSC-specific */ ADDRESS STDOUT /* CSC-specific */ INTERPRET RX_SOU.RX_LVL /* CSC-specific */ END /* CSC-specific */ ADDRESS ISPEXEC /* CSC-specific */ "LMMLIST DATAID(&RXSSEK) MEMBER(RXMBR) STATS(YES) OPTION(FREE)" /* CSC-specific */ "LMCLOSE DATAID(&RXSSEK)" /* CSC-specific */ "LMFREE DATAID(&RXSSEK)" /* CSC-specific */ RETURN /* CSC-specific */ LOOP_PRIM_SEK_DCL: CALL INDLAES_SEK RX_DCLSW = 0 IF RX_NOTRIG = 1 THEN DO /* NOTRIGGER ANFØRT */ IF SEK_INPUT.0 = 0 THEN INTERPRET RX_NOSOURCE /* 2019-07-09 */ END DO RXBB = 1 TO SEK_INPUT.0 RX_INP = STRIP(SEK_INPUT.RXBB) IF LEFT(RX_INP,2) = ") " THEN LEAVE IF LEFT(RX_INP,2) = "( " THEN DO RX_DCLSW = 1 RX_INP = SUBSTR(RX_INP,2) END IF RX_DCLSW = 1 THEN DO DATATYPE = WORD(RX_INP,2) IF POS("(",DATATYPE) > 0 THEN DO DATATYPE = SUBSTR(DATATYPE,1,POS("(",DATATYPE)-1) END IF POS(",",DATATYPE) > 0 THEN DO DATATYPE = SUBSTR(DATATYPE,1,POS(",",DATATYPE)-1) END DATANAME = STRIP(WORD(RX_INP,1)) DATACNAME = TRANSLATE(DATANAME,"-","_") NULLS = 0 IF POS("NOT NULL",RX_INP) = 0 THEN NULLS = 1 PARSE VALUE SUBSTR(RX_INP,31) WITH W1 '(' LENGTH ')' W2 IF LENGTH(LENGTH) > 0 THEN DO PARSE VALUE LENGTH WITH W1 ',' DECIMALS IF LENGTH(W1) > 0 THEN LENGTH = STRIP(W1,'B'," ") ELSE LENGTH = STRIP(LENGTH,'B'," ") END ELSE DO DECIMALS = "" LENGTH = 0 IF DATATYPE = 'TIMESTAMP' THEN LENGTH = 26 IF DATATYPE = 'DATE' THEN LENGTH = 10 IF DATATYPE = 'SMALLINT' THEN LENGTH = 4 END IF DECIMALS = "" THEN DECIMALS = 0 IF LENGTH = "" THEN LENGTH = 0 CONT = " " IF RIGHT(RX_INP,1) = "," THEN CONT = "," INTERPRET RX_SOURCE /* 2019-07-09 */ END END IF SYMBOL('DATANAME') = 'LIT' THEN DO RX_FMESS = "FUNC='DCL': Input is not a valid dcl-area.", "It is not confirming to Db2-syntax. RXS cannot interpret this." CALL SYNTAXFEJL END RETURN MAKE_GLOBAL: ARG RX_ARGU RX_VOID = PUT_I_EXPLIST(RX_ARGU) RETURN RX_GLB: /* make_global i kald genereret af RXSDO */ ARG RX_ARGU RX_VOID = PUT_I_EXPLIST(RX_ARGU) RETURN FROMISPF: ARG RX_ARGU IF LEFT(RX_ARGU,1) = "'" THEN DO RX_ARGU = SUBSTR(RX_ARGU,2,LENGTH(RX_ARGU)-2) END ELSE DO RX_ARGU = SYSVAR('SYSUID')"."RX_ARGU END RETURN RX_ARGU SHOW_EXPLIST: SAY RX_EXPLIST RETURN FUNC_KONVERT: /* til fra ascii, utf8 2008-05-15: et individ ad */ ARG RX_KONVTYP /* gangen */ RX_IS_LONG = 0 DO RX_I = 1 TO SEK_INPUT.0 IF LENGTH(SEK_INPUT.RX_I) > 6000 THEN RX_IS_LONG = 1 END IF RX_IS_LONG = 1 THEN DO /* 2017-05-08 optimering: */ DO RX_I = 1 TO SEK_INPUT.0 /* hvis filen ikke er bred */ RX_II = 0 /* konverteres i ét hug */ DO FOREVER RX_II = RX_II + 1 IF LENGTH(SEK_INPUT.RX_I) > 6000 THEN DO RX_STEM1.RX_II = LEFT(SEK_INPUT.RX_I,6000) SEK_INPUT.RX_I = SUBSTR(SEK_INPUT.RX_I,6001) END ELSE DO RX_STEM1.RX_II = SEK_INPUT.RX_I LEAVE END END SEK_INPUT.RX_I = '' ADDRESS TSO , "EXECIO "RX_II" DISKW RXSINP (STEM RX_STEM1. OPEN FINIS)" CALL SUB_FUNC_KONVERT DO RX_II = 1 TO RX_STEM2.0 SEK_INPUT.RX_I = SEK_INPUT.RX_I""RX_STEM2.RX_II END END END ELSE DO /* 2017-05-08 konverter i ét hug */ ADDRESS TSO , "EXECIO "SEK_INPUT.0" DISKW RXSINP (STEM SEK_INPUT. OPEN FINIS)" CALL SUB_FUNC_KONVERT DO RX_II = 1 TO RX_STEM2.0 SEK_INPUT.RX_II = RX_STEM2.RX_II END END RETURN 0 SUB_FUNC_KONVERT: /* her konverteres max 6000 byte ad gangen */ IF RX_TRACE = '?TRACE' THEN DO ADDRESS ISPEXEC, "LMINIT DATAID(RXSINP) DDNAME(RXSINP) ORG(INDORG) ENQ(SHR)" ADDRESS ISPEXEC "BROWSE DATAID(&RXSINP)" END IF EBCDIC_CODEPAGE = 'DEFAULT' THEN EBCDIC_CODEPAGE = 285 IF ASCII_CODEPAGE = 'DEFAULT' THEN ASCII_CODEPAGE = 437 ADDRESS ISPEXEC "SELECT PGM(RXSDO)", "PARM(C "RX_KONVTYP" "ASCII_CODEPAGE" "EBCDIC_CODEPAGE")" IF RC > 0 THEN DO SAY "Instalation error? Attempt to call loadmodule RXSDO fails" CALL ISPF_GETMSG('') END RX_FMESS = '' ADDRESS TSO "EXECIO * DISKR RXSOUTP (STEM RX_STEM2. OPEN FINIS)" IF RX_TRACE = '?TRACE' THEN DO ADDRESS ISPEXEC, "LMINIT DATAID(RXSOUTP) DDNAME(RXSOUTP) ORG(INDORG) ENQ(SHR)" ADDRESS ISPEXEC "BROWSE DATAID(&RXSOUTP)" END RETURN ZEDLMSG_VERSION: IF SYMBOL('RX_VERS_DONE') = 'LIT' THEN DO /* 2015-11-03 */ RX_VOID = ALLOC_DO('RXSOUTP') ADDRESS ISPEXEC "SELECT PGM(RXSDO) PARM(V)" ADDRESS TSO "EXECIO * DISKR RXSOUTP (STEM MODIF_INPUT. OPEN FINIS)" ZEDLMSG = "RXS version: "RX_VERSION". RXSDO version: "MODIF_INPUT.1"." RX_VERS_DONE = 1 END RETURN CHANGE: PROCEDURE EXPOSE (RX_EXPLIST) PARSE ARG STRENG, NYSTRENG, LINIE, HVOR /*IF LENGTH(LINIE) = 0 THEN DO */ /* RX_FMESS = "CHANGE requiere at least 3 args:", */ /* "change('oldval', 'newval', string).", */ /* "Optional fourth argument is 'last', 'first' or 'all')" */ /* CALL SYNTAXFEJL */ /*END 2021-11-25: tom streng bør håndteres ok */ I1 = 1 HVOR = TRANSLATE(LEFT(HVOR,1)) DO FOREVER I1 = POS(TRANSLATE(STRENG), TRANSLATE(LINIE), I1) IF I1 = 0 THEN LEAVE IF HVOR = 'L' THEN I1 = LASTPOS(TRANSLATE(STRENG),TRANSLATE(LINIE)) I2 = I1 + LENGTH(STRENG) LINIE = LEFT(LINIE,I1 - 1)""NYSTRENG""SUBSTR(LINIE,I2) IF HVOR = 'F' THEN LEAVE IF HVOR = 'L' THEN LEAVE I1 = I1 + LENGTH(NYSTRENG) END RETURN LINIE SKAFSSID: Procedure /* find db2 systemer på denne installation */ ssid_list = '' numeric digits 12 cvt = c2x(storage(10,4)) /* CVT adresse */ cvtjesct = d2x(x2d(cvt)+296) /* Pointer til cvtjesct */ jesct = c2x(storage(cvtjesct,4)) /* JESCT adresse */ jesssct = d2x(x2d(jesct)+24) /* Pointer til jesssct */ sscvt = c2x(storage(jesssct,4)) /* SSCVT adresse */ do while sscvt <> 0 ssctsnam = d2x(x2d(sscvt)+8) /* Pointer til ssctsnam */ erly = d2x(x2d(sscvt)+20) /* Pointer til erly */ erlyad = c2x(storage(erly,4)) /* ERLY adresse */ erlyeyec = substr(storage(erlyad,8),5,4) if erlyeyec = 'ERLY' then do erlymodn = substr(storage(erlyad,92),85,8) if erlymodn = 'DSN3EPX ' then do erlyscom = d2x(x2d(erlyad)+56) /* Pointer til erlyscom */ if c2d(storage(erlyscom,4)) <> 0 then do /* Aktiv */ ssid_list = ssid_list' 'storage(ssctsnam,4) end end end ssctscta = d2x((x2d(sscvt))+4) /* Pointer til next sscvt */ sscvt = c2x(storage(ssctscta,4)) end numeric digits 15 return strip(ssid_list) DO_EXEC_UNIX_CMD: /* eksekver opsamlede unix-cmds fra blokken: */ CALL ALLOC_DO "STDOUT" CALL ALLOC_DO "STDERR" ADDRESS TSO "BPXBATCH SH" RX_UNIX_STRING /* exekver unix */ ADDRESS TSO "EXECIO * DISKR STDOUT (STEM RXSTDOUT. OPEN FINIS)" ADDRESS TSO "EXECIO * DISKR STDERR (STEM RXSTDERR. OPEN FINIS)" RX_FMESS = '' DO RX_I = 1 TO RXSTDERR.0 /* fejl */ RX_FMESS = RX_FMESS""RXSTDERR.RX_I END IF RX_FMESS <> '' THEN DO RX_FMESS = '#Addressing UNIX: 'RX_FMESS CALL SYNTAXFEJL END DO RX_I = 1 TO RXSTDOUT.0 /* output fra unix cmds */ IF RXSTDOUT.RX_I <> '/etc/profile script executed' THEN DO IF OUT <> RX_GEM_OUT THEN CALL SKRIV_UD_HOUSEKEEP RX_KX = RX_OUT.RX_DISPL.0 IF RX_SKRIV_T_QUEUE = 1 THEN DO /*hvis skriv til queue*/ CALL RX_PUTQUEUE RXSTDOUT.RX_I END ELSE DO /* hvis skriv til dsname */ RX_KX = RX_KX + 1 RX_OUT.RX_DISPL.RX_KX = RXSTDOUT.RX_I /* her skrives ! */ END RX_OUT.RX_DISPL.0 = RX_KX /* antal skrevne til denne fil */ END END RX_UNIX_STRING = '' RETURN TIMESTAMP: PROCEDURE RX_D = DATE('S') RX_S = TIME('L') RX_STMP = LEFT(RX_D,4)"-"SUBSTR(RX_D,5,2)"-"SUBSTR(RX_D,7,2)"-", !! LEFT(RX_S,2)"."SUBSTR(RX_S,4,2)"."SUBSTR(RX_S,7,2)".", !! SUBSTR(RX_S,10) RETURN RX_STMP INTERFACE_DO: IF RX_KALDTYP = 'BATCH' THEN DO RETURN END IF SYMBOL(IN) = 'BAD' THEN DO RX_FMESS = "Bad syntax in IN: "IN RX_FMESS2 = 'Enter a valid REXX name, naming a RXS queue' CALL SYNTAXFEJL END IF POS('.',IN) > 0 ! POS('\',IN) > 0 ! POS('/',IN) > 0 THEN DO RX_FMESS = "Interface cannot use: "IN RX_FMESS2 = 'Interface works only on internal RXS queues' CALL SYNTAXFEJL END RX_queue_is_with_unit_2 = 0 IF SYMBOL('RX_GLB.'IN'_STEMIX') = 'LIT', ! VALUE('RX_GLB.'IN'_STEMIX') = 0 THEN DO RXINTF_INPUT.0 = 0 END ELSE DO RXINTF_INPUT. = '' RXINTF_INPUT.0 = VALUE('RX_GLB.'IN'_STEMIX') DO RXX = 1 TO RXINTF_INPUT.0 RXINTF_INPUT.RXX = VALUE('RX_GLB.'IN'_1.'RXX) IF SYMBOL('RX_GLB.'IN'_2.'RXX) = 'VAR' THEN DO IF VALUE('RX_GLB.'IN'_2.'RXX) <> '' THEN DO RX_queue_is_with_unit_2 = 1 END END END if RX_queue_is_with_unit_2 = 1 then do DO RXX = 1 TO RXINTF_INPUT.0 RXINTF_INPUT.RXX = RXINTF_INPUT.RXX"!!", !! VALUE('RX_GLB.'IN'_2.'RXX) END END END RX_VOID = ALLOC_DO('INTERFAC - 32500') /* 2014-03-21 lgde tilføjet */ ADDRESS TSO "EXECIO" RXINTF_INPUT.0, "DISKW INTERFAC (STEM RXINTF_INPUT. OPEN FINIS)" RX_RC = RC ADDRESS ISPEXEC, "LMINIT DATAID(INTERFAC) DDNAME(INTERFAC) ORG(INDORG) ENQ(SHR)" RX_VAR = 'RX_INTERFACE.'IN' = 0' RX_INTERFACE.0 = 1 /* 2017-11-15 */ IF RX_RC = 0 THEN DO ZEDLMSG = 'This is the internal RXS queue', '"'IN'". Continue RXS: Press END / F3'., 'Break the dialogue: Enter RETURN' ZEDSMSG = '' CALL ISPF_MESS_COND if RX_queue_is_with_unit_2 = 0 then do ADDRESS ISPEXEC "EDIT DATAID(&INTERFAC)" IF RC = 0 THEN DO /* der er opdateret i edit-session */ RX_VAR = 'RX_INTERFACE.'IN' = 1' /* 2014-03-21 kun hvis opdat:*/ ADDRESS TSO "EXECIO * DISKR INTERFAC (STEM RXINTF_INPUT. OPEN FINIS)" RX_GEM_OUT = OUT OUT = IN CALL DROPQUEUE OUT DO RXX = 1 TO RXINTF_INPUT.0 CALL RX_PUTQUEUE RXINTF_INPUT.RXX END OUT = RX_GEM_OUT END end ELSE DO /* 2016-06-07 Hvis køen har unit.1 og unit.2 */ ADDRESS ISPEXEC "BROWSE DATAID(&INTERFAC)" END END ELSE DO /* hvis kø har records længere end 32500 */ ADDRESS ISPEXEC "BROWSE DATAID(&INTERFAC)" END INTERPRET RX_VAR ADDRESS ISPEXEC "LMFREE DATAID(&INTERFAC)" /* 2017-11-15 */ /* CSC-specific */ address ispexec "vget (zverb)" /* 2019-02-22 */ if zverb = 'RETURN' then do RX_FMESS = "RETURN was pressed in 'interface'", "display. Exit is done" CALL SYNTAXFEJL end RETURN INTERFACE: /* forespørgsel på om der er editeret i givet interface */ ARG RX_Q IF RX_Q = '' THEN DO RX_FMESS = "Please state queue: INTERFACE('queue')" CALL SYNTAXFEJL RX_FMESS END IF WORD(RX_Q,2) <> '' THEN DO RX_FMESS = "Only one arg for interface: the queuename" CALL SYNTAXFEJL END IF SYMBOL('RX_INTERFACE.RX_Q') = 'LIT' THEN RX_INTERFACE.RX_Q = 0 RETURN RX_INTERFACE.RX_Q READ_MEMBER: /* denne logik for også at kunne læse load-biblioteker */ rx_in = translate(in,' ','()') rx_mbr = word(rx_in,2) rx_dsn = "'"word(rx_in,1)"'" address tso "alloc dd(rxpds) da("rx_dsn") shr reuse" address ispexec /* 2015-12-22: lmmlist tilføjet for at få stats ud */ "lminit dataid(rxdaid) ddname(rxpds) enq(shr)" "lmopen dataid("rxdaid") option(input)" "lmmlist dataid("rxdaid") pattern("rx_mbr") stats(yes)" "lmmfind dataid("rxdaid") member("rx_mbr")" getrc = 0 rx_i = 0 RX_II = 0 do while getrc = 0 "lmget dataid("rxdaid") dataloc(rxbuff) mode(invar)" , "datalen(rxblen) maxlen(32760)" getrc = rc if getrc = 0 then do RX_II = RX_II + 1 IF RX_II < READFRST THEN ITERATE rx_i = rx_i + 1 sek_input.rx_i = rxbuff if rx_i = readlim then leave end end sek_input.0 = rx_i "lmclose dataid("rxdaid")" "lmfree dataid("rxdaid")" address tso "free dd(rxpds)" RETURN SET_HALT: /* hold paneldisplay med meddelelse; stop RXS med meddelelse */ PARSE ARG ZEDLMSG IF ZEDLMSG = '' THEN call syntaxfejl 'SET_HALT: the message is missing' IF LENGTH(ZEDLMSG) <= 24 THEN DO ZEDSMSG = ZEDLMSG ZEDLMSG = '' END ELSE DO /* 2019-07-11 */ ZEDSMSG = '' END CALL ISPF_MESS /* 2021-04-09: set_halt message skal altid sejre */ IF RX_PROMPT_OK_LVL = 0 THEN DO CALL EXIT_I_UTIDE 16 end RX_PANEX = 'X' RX_PROMPT_LEAVE = '1' RETURN 0 SET_MESSAGE: /* vis message i næste panel */ PARSE ARG ZEDLMSG IF LENGTH(ZEDLMSG) <= 24 THEN DO ZEDSMSG = ZEDLMSG ZEDLMSG = '' END ELSE DO /* 2019-07-11 */ ZEDSMSG = '' END CALL ISPF_MESS_COND RETURN ' ' /* Håndter imbed i batch 2021-10-19 start */ oploes_imbed_i_input: ix_ud = 0 do rx_i = 1 to prim_input.0 call find_imbed_eller_skriv_ud(prim_input.rx_i) end if rx_err = 0 then do /* hvis fejl fortsættes med oprindeligt pgm */ do rx_i = 1 to ix_ud /* det modificerede program skrives tilbage:*/ prim_input.rx_i = rx_expand_pgm.rx_i end prim_input.0 = ix_ud end return find_imbed_eller_skriv_ud: procedure expose rx_inddata rx_ud rx_err, rx_expand_pgm. ix_ud parse arg rx_inddata word1 = word(rx_inddata,1) rx_quot = pos('"',rx_inddata) if rx_quot = 0 then rx_quot = pos("'",rx_inddata) if translate(word1) = ')IMBED' & rx_quot > 0 then do interpret substr(strip(rx_inddata),7) /* læs 'imbed' */ mbr1 = imbed call laes_imbed_mbr end else do call dan_expand_ud(rx_inddata) end return dan_expand_ud: parse arg individ ix_ud = ix_ud + 1 say right(ix_ud,4) individ rx_expand_pgm.ix_ud = individ return laes_imbed_mbr: call dan_expand_ud(")NOP * )IMBED "mbr1" *************...START: ") address ispexec "lminit dataid(rxsin) ddname(rxslib) org(indorg) enq(shr)" if rc > 4 then rx_err = 1 "lmopen dataid(&rxsin) lrecl(rxirecl) recfm(rxirecf)" if rc > 4 then rx_err = 1 "lmmfind dataid(&rxsin) member(&mbr1)" if rc > 4 then rx_err = 1 do while rc = 0 "lmget dataid(&rxsin) mode(invar) dataloc(rxsinind)", "datalen(rxactlgd) maxlen(&rxirecl)" if rc = 0 then do call find_imbed_eller_skriv_ud(rxsinind) end end "lmclose dataid(&rxsin)" "lmfree dataid(&rxsin)" call dan_expand_ud(")NOP * IMBED "mbr1" **************...END") return /* Håndter imbed i batch 2021-10-19 SLUT */