//BCHJOB JOB(JREFIMP) JOBD(NERONI2/NERONI2) OUTQ(QPRINT) + ENDSEV(60) LOG(4 00 *SECLVL) MSGQ(*USRPRF) /* Open source scaricabile da www.neroni.it */ /* LA JOB DESCRIPTION "NERONI2/NERONI2" DEVE PREESISTERE. PUO' ESSERE */ /* IDENTICA A QBATCH E PUO' ESSERE SOSTITUITA DA QBATCH O SIMILE. */ /* From System: "S65D69DA" */ /* From Library: "NERONI2" */ /* Unload Time: 2015-06-15 15:56 */ /* To File : "JREFIMP" */ /* To Library : "NERONI2" */ /* To Text : "Reference Implode. Src" */ /********* INIZIO ISTRUZIONI *******************************************/ /* LE SUCCESSIVE ISTRUZIONI PERMETTONO DI RICARICARE I SORGENTI. */ /* 1) DA UN VIDEO COMANDI DELL'AS400 RICEVENTE */ /* CREARE UN FILE SORGENTE DI LUNGHEZZA RECORD 112: */ /* CRTSRCPF FILE(NERONI2/STRINGHE) RCDLEN(112) */ /* 2) SPOSTARE IL FILE "JREFIMP.txt" NELL'INDIRIZZARIO */ /* DI UN PC CONNESSO IN RETE CON L'AS400 RICEVENTE */ /* (AD ES.: "c:\"). */ /* 3) DAL VIDEO COMANDI DEL PC CHIAMARE FTP: */ /* ftp nomeas400 */ /* 4) DIGITARE UTENTE E PASSWORD. */ /* 5) ESEGUIRE IL COMANDO DI COPIA DA FILE PC A MEMBRO AS400: */ /* put "c:\JREFIMP.txt" "/qsys.lib/NERONI2.lib/stringhe.file/JREFIMP.mbr" */ /* 6) ABBANDONARE FTP: */ /* quit */ /* 7) DA UN VIDEO COMANDI DELL'AS400 RICEVENTE */ /* ESEGUIRE LA STRINGA COPIATA NEL MEMBRO SORGENTE: */ /* SBMDBJOB FILE(NERONI2/STRINGHE) MBR(JREFIMP) JOBQ(QBATCH) */ /* LE SUCCESSIVE ISTRUZIONI PERMETTONO DI CREARE L'UTILITY. */ /* 8) DA UN VIDEO COMANDI DELL'AS400 RICEVENTE */ /* ESEGUIRE LA STRINGA O LE STRINGHE SORGENTE DI TIPO SEU "CL" */ /* (IL CUI NOME TERMINA SEMPRE CON ".") */ /* PRESENTI NEL FILE RICARICATO "NERONI2/JREFIMP" */ /* FACENDO ATTENZIONE ALL'ORDINE DI ESECUZIONE INDICATO NEL */ /* MEMBRO FACOLTATIVO "A.LEGGIMI", AD ESEMPIO: */ /* SBMDBJOB FILE(NERONI2/JREFIMP) MBR(JREFIMP.) JOBQ(QBATCH) */ /********* FINE ISTRUZIONI *********************************************/ /* Crea la libreria. */ MKDIR DIR('/qsys.lib/NERONI2.lib') CHGLIB LIB(NERONI2) TEXT('Utility di Claudio Neroni') /* Imposta la lista librerie. */ CHGLIBL LIBL(QTEMP NERONI2 QGPL) /* Crea il file sorgente. */ DLTF FILE(NERONI2/JREFIMP) CRTSRCPF FILE(NERONI2/JREFIMP) RCDLEN(112) + TEXT('Reference Implode. Src') /* Copia il sorgente dalla stringa al membro del file sorgente. */ /* Modifica testo e tipo seu del sorgente caricato. */ CPYF FROMFILE(JREFIMP) TOFILE(NERONI2/JREFIMP) + TOMBR(JREFIMP) MBROPT(*REPLACE) SRCOPT(*SEQNBR) CHGPFM FILE(NERONI2/JREFIMP) MBR(JREFIMP) + SRCTYPE(CMD) + TEXT('Reference Implode. Cmd') /* Copia il sorgente dalla stringa al membro del file sorgente. */ /* Modifica testo e tipo seu del sorgente caricato. */ CPYF FROMFILE(JREFIMP.) TOFILE(NERONI2/JREFIMP) + TOMBR(JREFIMP.) MBROPT(*REPLACE) SRCOPT(*SEQNBR) CHGPFM FILE(NERONI2/JREFIMP) MBR(JREFIMP.) + SRCTYPE(CL) + TEXT('Reference Implode. CrtJs') /* Copia il sorgente dalla stringa al membro del file sorgente. */ /* Modifica testo e tipo seu del sorgente caricato. */ CPYF FROMFILE(JREFIMP1) TOFILE(NERONI2/JREFIMP) + TOMBR(JREFIMP1) MBROPT(*REPLACE) SRCOPT(*SEQNBR) CHGPFM FILE(NERONI2/JREFIMP) MBR(JREFIMP1) + SRCTYPE(CLLE) + TEXT('Reference Implode. Cpp') /* Copia il sorgente dalla stringa al membro del file sorgente. */ /* Modifica testo e tipo seu del sorgente caricato. */ CPYF FROMFILE(JREFIMP2) TOFILE(NERONI2/JREFIMP) + TOMBR(JREFIMP2) MBROPT(*REPLACE) SRCOPT(*SEQNBR) CHGPFM FILE(NERONI2/JREFIMP) MBR(JREFIMP2) + SRCTYPE(RPGLE) + TEXT('Reference Implode. Exe') /*---------------------------------------------------------------------*/ //DATA FILE(JREFIMP) FILETYPE(*SRC) ENDCHAR('//ENDSRC') /* Reference Implode. Cmd */ /* Claudio Neroni 15-04-2008 Creato. */ /* */ CMD PROMPT('Program reference Implode') PARM KWD(OBJ) TYPE(*NAME) MIN(1) PROMPT('Object + name') PARM KWD(OBJTYPE) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*PGM) VALUES(*PGM *DTAARA *FILE + *SRVPGM *ALL) PROMPT('Object type') PARM KWD(DEVELOP) TYPE(*CHAR) LEN(10) RSTD(*YES) + DFT(*ALL) VALUES(*ALL *PGM) + PROMPT('Development type') PARM KWD(TOLAST) TYPE(*CHAR) LEN(10) RSTD(*YES) + DFT(*NO) VALUES(*NO *YES) PROMPT('To last + elements only') PARM KWD(SEEN) TYPE(*CHAR) LEN(10) RSTD(*YES) + DFT(*YES) VALUES(*YES *NO) + PROMPT('Already seen') PARM KWD(PGMATR) TYPE(*CHAR) LEN(2) SPCVAL((BA) + (CB) (CL) (DF) (QR) (RP)) MAX(20) + PROMPT('Program attribute') PARM KWD(OBJATR) TYPE(*CHAR) LEN(10) + SPCVAL((PRTF) (DSPF) (PF) (LF) (RPG) + (CLP) (RPGLE) (CLLE) (BLANK) (BLANKF) + (TAPF)) MAX(50) PROMPT('Object attribute') PARM KWD(MAXLVL) TYPE(*DEC) LEN(3 0) DFT(100) + RANGE(1 100) PROMPT('Max level') PARM KWD(INPUT) TYPE(*LGL) RSTD(*YES) DFT(*YES) + SPCVAL((*YES '1') (*NO '0')) + PROMPT('Input use') PARM KWD(OUTPUT) TYPE(*LGL) RSTD(*YES) DFT(*YES) + SPCVAL((*YES '1') (*NO '0')) + PROMPT('Output use') PARM KWD(UPDATE) TYPE(*LGL) RSTD(*YES) DFT(*YES) + SPCVAL((*YES '1') (*NO '0')) + PROMPT('Update use') PARM KWD(UNKNOWN) TYPE(*LGL) RSTD(*YES) DFT(*YES) + SPCVAL((*YES '1') (*NO '0')) + PROMPT('Unknown use') PARM KWD(DBREL) TYPE(*LGL) RSTD(*YES) DFT(*YES) + SPCVAL((*YES '1') (*NO '0')) + PROMPT('Database relation use') PARM KWD(NOUSE) TYPE(*LGL) RSTD(*YES) DFT(*YES) + SPCVAL((*YES '1') (*NO '0')) PROMPT('No use') PARM KWD(DTALIB) TYPE(*NAME) LEN(10) DFT(REFALL) + SPCVAL((REFALL)) PROMPT('Data library') //ENDSRC /*---------------------------------------------------------------------*/ //DATA FILE(JREFIMP.) FILETYPE(*SRC) ENDCHAR('//ENDSRC') //BCHJOB JOB(JREFIMP.) JOBD(NERONI2/NERONI2) OUTQ(QPRINTS) + ENDSEV(60) LOG(4 00 *SECLVL) MSGQ(*USRPRF) /* Claudio Neroni 26/04/2008 Creato. */ /* JREFIMP */ /* Reference Implode. */ /* Prerequisiti: JRSNMSG */ /* Prerequisiti: Creazione data base eseguito con la stringa JREFDB */ /* Imposta la lista librerie. */ CHGLIBL LIBL(QTEMP QGPL) ADDLIBLE LIB(NERONI2) POSITION(*AFTER QTEMP) /* Cancella gli oggetti preesistenti. */ DLTCMD CMD(NERONI2/JREFIMP) DLTPNLGRP PNLGRP(NERONI2/JREFIMPP) DLTPGM PGM(NERONI2/JREFIMP1) DLTPGM PGM(NERONI2/JREFIMP2) /* Crea gli oggetti. */ CRTBNDCL PGM(NERONI2/JREFIMP1) SRCFILE(JREFIMP) DBGVIEW(*LIST) CRTBNDRPG PGM(NERONI2/JREFIMP2) SRCFILE(JREFIMP) DBGVIEW(*LIST) CRTPNLGRP PNLGRP(NERONI2/JREFIMPP) SRCFILE(JREFIMP) CRTCMD CMD(NERONI2/JREFIMP) PGM(JREFIMP1) SRCFILE(JREFIMP) + HLPPNLGRP(JREFIMPP) HLPID(CMD) PRDLIB(NERONI2) //ENDBCHJOB //ENDSRC /*---------------------------------------------------------------------*/ //DATA FILE(JREFIMP1) FILETYPE(*SRC) ENDCHAR('//ENDSRC') /* Reference Implode. Cpp */ /* Claudio Neroni 15/04/2008 Creato. */ /* */ PGM PARM(&OBJ &OBJTYPE &SVIL &TOLAST &SEEN + &PGMATR &OBJATR &MAXLVL &INPUT &OUTPUT + &UPDATE &UNKNOWN &DBREL &NOUSE &DTALIB) /* Riceve Nome dell'oggetto da implodere. */ DCL VAR(&OBJ) TYPE(*CHAR) LEN(10) /* Riceve Tipo dell'oggetto da implodere. */ DCL VAR(&OBJTYPE) TYPE(*CHAR) LEN(8) /* Riceve Tipo di sviluppo da eseguire. */ DCL VAR(&SVIL) TYPE(*CHAR) LEN(10) /* Riceve To last elements only. */ DCL VAR(&TOLAST) TYPE(*CHAR) LEN(10) /* Riceve Already seen. */ DCL VAR(&SEEN) TYPE(*CHAR) LEN(10) /* Riceve Param Attributi programma da considerare 2bin + 20el*2char. */ DCL VAR(&PGMATR) TYPE(*CHAR) LEN(42) /* Riceve Param Attributi oggetto da considerare 2bin + 50el*10char. */ DCL VAR(&OBJATR) TYPE(*CHAR) LEN(502) /* Riceve Nome sistema. */ DCL VAR(&SYSNAME) TYPE(*CHAR) LEN(8) /* Riceve Massimo livello. */ DCL VAR(&MAXLVL) TYPE(*DEC) LEN(3 0) /* Riceve Uso Input. */ DCL VAR(&INPUT) TYPE(*LGL) /* Riceve Uso Output. */ DCL VAR(&OUTPUT) TYPE(*LGL) /* Riceve Uso Update. */ DCL VAR(&UPDATE) TYPE(*LGL) /* Riceve Uso Sconosciuto. */ DCL VAR(&UNKNOWN) TYPE(*LGL) /* Riceve Uso Relazione di database. */ DCL VAR(&DBREL) TYPE(*LGL) /* Riceve Uso Nessuno. */ DCL VAR(&NOUSE) TYPE(*LGL) /* Riceve Nome della libreria dei dati di servizio. */ DCL VAR(&DTALIB) TYPE(*CHAR) LEN(10) /* Prenotazione del CPF0001. */ DCL VAR(&CPF0001) TYPE(*LGL) /* Intercetta gli errori. */ MONMSG MSGID(CPF0000 MCH0000 CEE0000) EXEC(GOTO + CMDLBL(ERRORE)) /* Recupera Nome sistema. */ RTVNETA SYSNAME(&SYSNAME) /* Reindirizza i file di servizio alla libreria dei dati di servizio. */ OVRDBF FILE(JREFDBFF2) TOFILE(&DTALIB/JREFDBFF2) OVRDBF FILE(JREFDBFD1) TOFILE(&DTALIB/JREFDBFD1) /* Reindirizza la stampa. */ OVRPRTF FILE(QSYSPRT) USRDTA(&OBJ) SPLFNAME(JREFIMP) /* Esegue lo sviluppo. */ CALL PGM(JREFIMP2) PARM(&OBJ &OBJTYPE &SVIL + &TOLAST &SEEN &PGMATR &OBJATR &SYSNAME + &MAXLVL &INPUT &OUTPUT &UPDATE &UNKNOWN + &DBREL &NOUSE &DTALIB) DLTOVR FILE(*ALL) /* Visualizza la stampa. */ DSPSPLF FILE(JREFIMP) SPLNBR(*LAST) /* Label di esecuzione delle attivitā finali. */ RCLRSC: /* Riacquisisce le risorse. */ RCLRSC MONMSG MSGID(CPF0000 MCH0000) /* Se richiesto, rilascia il CPF0001. */ IF COND(&CPF0001) THEN(DO) SNDPGMMSG MSGID(CPF0001) MSGF(QCPFMSG) MSGDTA(JREFIMP) + MSGTYPE(*ESCAPE) MONMSG MSGID(CPF0000 MCH0000) ENDDO /* Ritorna. */ RETURN /* Label di errore. */ ERRORE: /* Restituisce i messaggi al chiamante, */ /* trasformando eventuali escape in diagnostici. */ JRSNMSG MONMSG MSGID(CPF0000 MCH0000) /* Label di prenotazione del CPF0001. */ CPF0001: /* Prenota il CPF0001. */ CHGVAR VAR(&CPF0001) VALUE('1') MONMSG MSGID(CPF0000 MCH0000) /* Salta alle attivitā finali. */ GOTO CMDLBL(RCLRSC) ENDPGM //ENDSRC /*---------------------------------------------------------------------*/ //DATA FILE(JREFIMP2) FILETYPE(*SRC) ENDCHAR('//ENDSRC') *EXP **/TITLE Reference Explode. Exe *IMP /TITLE Reference Implode. Exe * Claudio Neroni 14-04-2008 Creato. * Per ottenere la versione IMPLODE, * asteriscare le specifice "*EXP" e * disasteriscare le specifice "*IMP". *--------------------------------------------------------------------------------------------- * Definito un ambiente come un insieme di librerie di dati * e delle librerie dei relativi programmi: * 1) Riceve il Display Program Reference di tutti i programmi * di un ambiente. * 2) Riceve il Display Object Description di tutti gli oggetti * dello stesso ambiente. * 3) Riceve il nome di un programma da esplodere in tutti i programmi * e in tutti gli oggetti chiamati. * 4) Riceve il tipo di sviluppo da eseguire. * *ALL=Elenca tutti gli oggetti * *PGM=Elenca solo i programmi * Restituisce una lista contenente l'esplosione richiesta. *--------------------------------------------------------------------------------------------- H decedit('0,') datfmt(*dmy/) datedit(*dmy/) *--------------------------------------------------------------------------------------------- * File di emissione di DSPPGMREF ristrutturato. *EXP F**jrefdbff1 if e k disk *IMP Fjrefdbff2 if e k disk * File di emissione di DSPOBJD. Fjrefdbfd1 if e k disk * Stampa. Fqsysprt o f 132 printer oflind(*inof) *--------------------------------------------------------------------------------------------- * Scaletta di annidamento. D sca s 11 dim(max) ctdata perrcd(1) * Decodifica uso. D usg s 2 0 dim(17) ctdata perrcd(1) D usgd s 4 dim(17) alt(usg) *--------------------------------------------------------------------------------------------- * Numero massimo di programmi in lista di chiamata. D max c 100 * Lista di chiamata. D lds ds D l 36 dim(max) * Chiamante + Tipo dell'oggetto chiamante. D lpa 18 overlay(l:1) * Chiamante. D lpan 10 overlay(l:1) * Tipo dell'oggetto chiamante. D lpat 8 overlay(l:11) * Chiamato + Tipo dell'oggetto chiamato. D lfi 18 overlay(l:19) * Chiamato. D lfin 10 overlay(l:19) * Tipo dell'oggetto chiamato. D lfit 8 overlay(l:29) * Chiamato + Tipo. Search word. D reffiw s like(lfi) *--------------------------------------------------------------------------------------------- * Programmi giā sviluppati. D lpags s 18 dim(10000) * Indice di riempimento dei Programmi giā sviluppati. D ip s 7 0 D ip0 s like(ip) D ips s like(ip) *--------------------------------------------------------------------------------------------- * Numero massimo di elementi Attributo programma. D maxqa c 20 * Spezza la simple list del parametro Attributo programma. D pppgmatr ds D qan 1 2b 0 D qa 2 dim(maxqa) * Numero massimo di elementi Attributo oggetto. D maxoa c 50 * Spezza la simple list del parametro Attributo oggetto. D ppobjatr ds D oan 1 2b 0 D oa 10 dim(maxoa) *--------------------------------------------------------------------------------------------- * Doppioni dei parametri. D qax s like(qa) dim(maxqa) D oax s like(oa) dim(maxoa) *--------------------------------------------------------------------------------------------- * Comando di chiamata. D cmd ds D cmdel 130 dim(10) *--------------------------------------------------------------------------------------------- * Trattini. D tra s 132 inz(*all'-') *--------------------------------------------------------------------------------------------- * Campi della riga di emissione. D out e ds extname(jrefdbfw) inz * Campi della riga di emissione. Precedente. D outpre e ds extname(jrefdbfw) prefix(pre) inz * Campi della riga di emissione. Stampa. D outprt e ds extname(jrefdbfw) prefix(prt) inz * Accorcia i campi per la stampa. D prtoutfitz 7 overlay(prtoutfit) D prtoutfiaz 6 overlay(prtoutfia) D prtoutpatz 7 overlay(prtoutpat) D prtoutpaaz 6 overlay(prtoutpaa) * Campi della riga di emissione. Ultimo stampato. D outult e ds extname(jrefdbfw) prefix(ult) inz D outulz e ds extname(jrefdbfw) prefix(ulz) inz *--------------------------------------------------------------------------------------------- *IMP * Rovescia padre e figlio per sfruttare il programma senza altre modifiche. *IMP Iref *IMP I REFPAN REFFIN *IMP I REFPAT REFFIT *IMP I REFPAA REFFIA *IMP I REFPAL REFFIL *IMP I REFPAX REFFIX *IMP I REFFIN REFPAN *IMP I REFFIT REFPAT *IMP I REFFIA REFPAA *IMP I REFFIL REFPAL *IMP I REFFIX REFPAX *IMP *--------------------------------------------------------------------------------------------- * Predispone chiusura. C seton lr * Scambia parametri. C *entry plist * Riceve Nome dell'oggetto da esplodere. C parm pppan 10 * Riceve Tipo dell'oggetto da esplodere. C parm pppat 8 * Riceve Sviluppo. * *ALL=Elenca tutti gli oggetti * *PGM=Elenca solo i programmi C parm ppsvil 10 * Riceve To last elements only. * *NO =Elenca tutti gli oggetti * *YES=Elenca solo gli oggetti senza ulteriori componenti. C parm pptola 10 * Riceve Already seen. * *YES=Elenca anche le righe segnate con G=Giā viste. * *NO =Non elenca le righe segnate con G=Giā viste. C parm ppseen 10 * Riceve Attributo programma. C parm pppgmatr * Riceve Attributo oggetto. * Blank =Elenca tutti gli oggetti * NonBlank=Elenca solo gli oggetti con l'attributo richiesto. C parm ppobjatr * Riceve Nome del sistema. C parm ppsnam 8 * Riceve Massimo livello. C parm ppmaxl 3 0 * Riceve Uso Input. C parm ppinput 1 * Riceve Uso Output. C parm ppoutput 1 * Riceve Uso Update. C parm ppupdate 1 * Riceve Uso Sconosciuto. C parm ppunknown 1 * Riceve Uso Relazione di database. C parm ppdbrel 1 * Riceve Uso Nessuno. C parm ppnouse 1 * Riceve Libreria dati. C parm ppdtali 10 * Trascrive i parametri a numero di elementi variabili nei doppioni. C clear qax C *like define qan px C do qan px B01 C movel(p) qa(px) qax(px) 01 C enddo E01 C clear oax C do oan px B01 C movel(p) oa(px) oax(px) 01 C enddo E01 * Compone il comando ricevuto per stamparlo. C clear cmd *EXP C** eval cmd='JREFEXP OBJ(' + *IMP C eval cmd='JREFIMP OBJ(' + C %trim(pppan ) + C ') OBJTYPE(' + C %trim(pppat ) + C ') DEVELOP(' + C %trim(ppsvil) + C ') TOLAST(' + C %trim(pptola) + C ') SEEN(' + C %trim(ppseen) + C ') PGMATR(' C do qan px B01 C if px=1 B02 C eval cmd= %trim(cmd) + 02 C %trim(qax(px)) 02 C else X02 C eval cmd= %trim(cmd) + 02 C ' ' + 02 C %trim(qax(px)) 02 C endif E02 C enddo E01 C eval cmd= %trim(cmd) + C ') OBJATR(' C do oan px B01 C if px=1 B02 C eval cmd= %trim(cmd) + 02 C %trim(oax(px)) 02 C else X02 C eval cmd= %trim(cmd) + 02 C ' ' + 02 C %trim(oax(px)) 02 C endif E02 C enddo E01 C eval cmd= %trim(cmd) + C ') MAXLVL(' + C %trim(%editc(ppmaxl:'Z')) + C ')' * Uso. C if ppinput = *off B01 C eval cmd= %trim(cmd) + ' INPUT(*NO)' 01 C endif E01 C if ppoutput = *off B01 C eval cmd= %trim(cmd) + ' OUTPUT(*NO)' 01 C endif E01 C if ppupdate = *off B01 C eval cmd= %trim(cmd) + ' UPDATE(*NO)' 01 C endif E01 C if ppunknown = *off B01 C eval cmd= %trim(cmd) + ' UNKNOWN(*NO)' 01 C endif E01 C if ppdbrel = *off B01 C eval cmd= %trim(cmd) + ' DBREL(*NO)' 01 C endif E01 C if ppnouse = *off B01 C eval cmd= %trim(cmd) + ' NOUSE(*NO)' 01 C endif E01 * Libreria dati. C eval cmd= %trim(cmd) + C ' DTALIB(' + C %trim(ppdtali) + C ')' * Stampa l'intestazione della prima pagina. C except int1 C do 10 ix 3 0 B01 C if cmdel(ix)<>*blank B02 C except int2 02 C endif E02 C enddo E01 C except int3 * Chiave di ricerca degli oggetti chiamati da un programma. C k1a klist * Usante. C kfld lpan(xx) * Tipo usante. C kfld lpat(xx) * Chiave di riposizionamento. C k1b klist * Usante. C kfld lpan(xx) * Tipo usante. C kfld lpat(xx) * Usato. C kfld lfin(xx) * Tipo usato. C kfld lfit(xx) * Pulisce la lista di chiamata. C clear lpan C clear lpat C clear lfin C clear lfit * STAMPA LA PRIMA RIGA. INIZIO * Assume il programma richiesto nella prima emissione. C clear xx C clear refpan C clear refpat C movel(p) pppan reffin C movel(p) pppat reffit * Decodifica il programma richiesto. C kd1 klist C kfld pppan C kfld pppat C kd1 chain jrefdbfd1 C if %found B01 C movel(p) odobat reffia 01 C movel(p) odobtx reffix 01 C else X01 C movel(p) *all'?' reffia 01 C movel(p) *all'?' reffix 01 C endif E01 * Emette il dettaglio del programma di partenza. C exsr outsave * Trascrive la riga ricevuta nei campi di stampa. C movel(p) out outprt * Emette la riga scelta. C exsr outprint * Trascrive la riga ricevuta nei campi precedenti. C movel(p) out outpre * STAMPA LA PRIMA RIGA. FINE * Annota il programma di partenza nella prima posizione lista. C z-add 1 xx 3 0 C movel(p) pppan lpan(1) C movel(p) pppat lpat(1) C clear lfin(1) C clear lfit(1) * Si posiziona all'inizio degli oggetti usati dal pgm di partenza. C k1a setll ref * Balla sulla lista di chiamata. C do *hival B01 * Se l'indice č zero, abbandona. C if xx<=*zero B02 C leave 02 C endif E02 * Legge il prossimo oggetto usato dal prgm corrente. C k1a reade ref 01 * Se gli oggetti chiamati sono finiti. C if %eof B02 * Pulisce la posizione corrente della lista di chiamata. C clear lpan(xx) 02 C clear lpat(xx) 02 C clear lfin(xx) 02 C clear lfit(xx) 02 * Arretra l'indice corrente sulla lista di chiamata. C eval xx=xx-1 02 * Se l'indice č zero, abbandona. C if xx<=*zero B03 C leave 03 C endif E03 * Si riposiziona oltre l'ultima lettura per l'indice corrente. C k1b setgt ref 02 * Ricicla. C iter 02 * Se gli oggetti chiamati sono finiti. C endif E02 * Chiave di scavalco gruppo. C k1s klist 01 * Usante. C kfld refpan 01 * Tipo usante. C kfld refpat 01 * Usato. C kfld reffin 01 * Tipo usato. C kfld reffit 01 * Scavalca il gruppo di record uguali all'ultimo letto. C k1s setgt ref 01 * Legge l'ultimo record del gruppo. C k1s readpe ref h2 01 C h2 return 01 * Assume recursioni assenti. C setoff 5153 01 * Compone Chiamato + Tipo. C eval reffiw = reffin + reffit 01 * Annota la recursione se l'usato corrente č presente in lista usanti. C reffiw lookup lfi 51 01 * Se sono giā stati sviluppati programmi. C if ip < ip0 B02 * Se il pgm č giā stato sviluppato, annota recursione. C eval ips = ip 02 C reffiw lookup lpags(ips) 53 02 * Se sono giā stati sviluppati programmi. C endif E02 * Trascrive l'usato corrente nella lista di chiamata. C eval lpan(xx)=refpan 01 C eval lpat(xx)=refpat 01 C eval lfin(xx)=reffin 01 C eval lfit(xx)=reffit 01 * Annota il pgm nell'elenco dei pgm giā sviluppati. C if 1=1 B02 * Assume scrittura in elenco necessaria. C setoff 50 02 * Se sono giā stati sviluppati programmi * e il pgm č giā annotato, toglie consenso. C if ip < ip0 B03 C eval ips = ip 03 C reffiw lookup lpags(ips) 50 03 C endif E03 * Se scrittura in elenco necessaria, * annota il pgm nell'elenco dei pgm giā sviluppati. C if not *in50 B03 C sub 1 ip 03 C eval lpags(ip)=reffiw 03 C endif E03 * Annota il pgm nell'elenco dei pgm giā sviluppati. C endif E02 * Se lo sviluppo č tutti e l'usato corrente č valorizzato, * o se lo sviluppo č pgm e l'usato corrente č pgm. C if ppsvil='*ALL' B02 C and lfin(xx)<>*blank 02 C or ppsvil='*PGM' 02 C and lfit(xx)='*PGM' 02 * Se l'usato corrente č diverso dall'ultimo emesso. C if refpan <> preoutpan B03 C or refpat <> preoutpat 03 C or reffin <> preoutfin 03 C or reffit <> preoutfit 03 * Costruisce un attributo oggetto di comodo per la ricerca. C eval reffiaw = reffia 03 C *like define reffia reffiaw 03 C if reffia = *blank B04 C eval reffiaw = 'BLANK' 04 C if reffit = '*FILE' B05 C and %lookup('BLANKF':oax:1:oan) > *zero 05 C eval reffiaw = 'BLANKF' 05 C endif E05 C endif E04 * Se l'attributo oggetto corrente soddisfa la richiesta. C if oan = *zero B04 C or oan > *zero 04 C and %lookup(reffiaw:oax:1:oan) 04 C > *zero 04 * Se l'attributo programma corrente soddisfa la richiesta. C if qan = *zero B05 C or qan > *zero 05 C and %lookup(%subst(refpaa:1:2):qax:1:qan) 05 C > *zero 05 * Decodifica uso. C z-add 1 ux 3 0 05 C refuso lookup usg(ux) 50 05 C n50 movel *all'?' refusod 05 C 50 movel(p) usgd(ux) refusod 05 C *like define usgd refusod 05 * Se l'uso corrente soddisfa la richiesta. C if %subst(refusod:1:1) = 'I' B06 C and ppinput = *on 06 C or %subst(refusod:2:1) = 'O' 06 C and ppoutput = *on 06 C or %subst(refusod:3:1) = 'U' 06 C and ppupdate = *on 06 C or %subst(refusod:4:1) = '?' 06 C and ppunknown = *on 06 C or %subst(refusod:1:3) = 'dbr' 06 C and ppdbrel = *on 06 C or %subst(refusod:1:4) = '....' 06 C and ppnouse = *on 06 * LA RIGA E' DA STAMPARE. INIZIO * Trascrive i dati della riga in una struttura dati. C exsr outsave 06 * Se richieste materie prime e se non aumenta livello. C if pptola = '*YES' B07 C and outian <= preoutian 07 * Trascrive la riga precedente nei campi di stampa. C movel(p) outpre outprt 07 * Emette la riga scelta. C exsr outprint 07 * Se richieste materie prime e se non aumenta livello. C endif E07 * Se non richieste materie prime. C if pptola <> '*YES' B07 * Trascrive la riga ricevuta nei campi di stampa. C movel(p) out outprt 07 * Emette la riga scelta. C exsr outprint 07 * Se non richieste materie prime. C endif E07 * Trascrive la riga ricevuta nei campi precedenti. C movel(p) out outpre 06 * LA RIGA E' DA STAMPARE. FINE * Se l'uso corrente soddisfa la richiesta. C endif E06 * Se l'attributo programma corrente soddisfa la richiesta. C endif E05 * Se l'attributo oggetto corrente soddisfa la richiesta. C endif E04 * Se l'usato corrente č diverso dall'ultimo emesso. C endif E03 * Se corre recursione. C if *in51 B03 * Pulisce l'elemento corrente dalla lista di chiamata. C clear lpan(xx) 03 C clear lpat(xx) 03 C clear lfin(xx) 03 C clear lfit(xx) 03 * Arretra l'indice corrente sulla lista di chiamata. C eval xx=xx-1 03 * Se l'indice č zero, abbandona. C if xx<=*zero B04 C leave 04 C endif E04 * Si riposiziona oltre l'ultima lettura per l'indice corrente. C k1b setgt ref 03 * Ricicla. C iter 03 * Se corre recursione. C endif E03 * Se lo sviluppo č tutti e l'usato corrente č valorizzato, * o se lo sviluppo č pgm e l'usato corrente č pgm. C endif E02 * Se l'elemento corrente non č giā sviluppato * e se l'indice corrente č minore del massimo. C if not *in53 B02 C and xx < ppmaxl 02 * Incrementa l'indice corrente sulla lista di chiamata. C eval xx=xx+1 02 * Annota il programma nella posizione corrente della lista. C eval lpan(xx)=reffin 02 C eval lpat(xx)=reffit 02 C clear lfin(xx) 02 C clear lfit(xx) 02 * Si posiziona all'inizio degli oggetti usati dal pgm corrente. C k1a setll ref 02 * Se l'elemento corrente non č giā sviluppato * e se l'indice corrente č minore o uguale al massimo. C endif E02 * Balla sulla lista di chiamata. C enddo E01 * Stampa fine. C except eop *--------------------------------------------------------------------------------------------- * Trascrive i dati della riga in una struttura dati. C outsave begsr * Pulisce i dati della riga. C clear out * Numera la riga. C add 1 cnt * Riempie i campi della iga. C 51 movel(p) 'F' outrcs C 53 movel(p) 'G' outgia C z-add cnt outcnt C z-add xx outian C if xx = *zero B01 C movel(p) '0' outiand 01 C else X01 C movel(p) sca(xx) outiand 01 C endif E01 C movel(p) refpan outpan C movel(p) refpat outpat C movel(p) refpaa outpaa C movel(p) reffin outfin C movel(p) reffit outfit C movel(p) reffia outfia C z-add refuso outuso C movel(p) refusod outusod C movel(p) reffix outfix C endsr *--------------------------------------------------------------------------------------------- * Stampa la riga. C outprint begsr * Se sono richieste anche le righe giā viste * o se la riga non č giā vista. C if ppseen = '*YES' B01 C or prtoutgia = *blank 01 * Salva i dati ricevuti in un comodo. C movel(p) outprt outulz 01 * Se non corre la prima riga, * annota usante e tipo usante uguale a precedente. C if prtoutcnt <> 1 B02 C and prtoutpan = ultoutpan 02 C and prtoutpat = ultoutpat 02 C and prtoutpaa = ultoutpaa 02 C movel(p) '"' prtoutpan 02 C movel(p) '"' prtoutpat 02 C movel(p) '"' prtoutpaa 02 C endif E02 * Se overflow, stampa l'intestazione delle pagine * successive alla prima. C if *inof B02 C except int1 02 C except int3 02 C endif E02 * Stampa la riga. C except outrow 01 * Salva i dati ricevuti nell'ultimo stampato. C movel(p) outulz outult 01 * Se sono richieste anche le righe giā viste * o se la riga non č giā vista. C endif E01 C endsr *--------------------------------------------------------------------------------------------- * Inizializza. C *inzsr begsr * Annota il numero di elementi dei pgm giā sviluppati. C eval ip0=%elem(lpags)+1 C eval ip =ip0 * Azzera il contatore righe. C clear cnt 6 0 * Time. C time time 6 0 C endsr *--------------------------------------------------------------------------------------------- * Intestazione. Oqsysprt e int1 2 1 O e int2 1 O cmdel(ix) O e int3 1 O 97 'SysName:' O ppsnam +1 O *date y 120 O time +2 '0 : : ' O e int3 1 O 'Re' O 8 'Row' O 10 'L' O 'evel' *EXP O** 22 'F' *EXP O** 'ather' *IMP O 22 'S' *IMP O 'on' O 33 'T' O 'ype' O 41 'A' O 'ttrib' *EXP O** 48 'S' *EXP O** 'on' *IMP O 48 'F' *IMP O 'ather' O 59 'T' O 'ype' O 67 'A' O 'ttrib' O 74 'U' O 'sag' O 79 'T' O 'ext' O e int3 1 O tra * Dettaglio esplosione ritardato. O e outrow 1 O prtoutrcs O prtoutgia O prtoutcnt 3 O prtoutiand +1 O prtoutpan +1 O prtoutpatz +1 O prtoutpaaz +1 O prtoutfin +1 O prtoutfitz +1 O prtoutfiaz +1 O prtoutusod +1 O prtoutfix +1 O********************** prtoutian +1 * Fine stampa. O e eop 1 O '*** End of print ***' *--------------------------------------------------------------------------------------------- ** Scaletta di annidamento. 1 .2 ..3 ...4 ....5 .....6 ......7 .......8 ........9 ........10 11 12 .13 ..14 ...15 ....16 .....17 ......18 .......19 ........20 21 22 .23 ..24 ...25 ....26 .....27 ......28 .......29 ........20 31 32 .33 ..34 ...35 ....36 .....37 ......38 .......39 ........40 41 42 .43 ..44 ...45 ....46 .....47 ......48 .......49 ........50 51 52 .53 ..54 ...55 ....56 .....57 ......58 .......59 ........60 61 62 .63 ..64 ...65 ....66 .....67 ......68 .......69 ........70 71 72 .73 ..74 ...75 ....76 .....77 ......78 .......79 ........80 81 82 .83 ..84 ...85 ....86 .....87 ......88 .......89 ........90 91 92 .93 ..94 ...95 ....96 .....97 ......98 .......99 .......100 ** Decodifica uso. 00.... 01I... 02.O.. 03IO.. 04..U. 05I.U. 06.OU. 07IOU. 08...? 09I..? 10.O.? 11IO.? 12..U? 13I.U? 14.OU? 15IOU? 90dbr //ENDSRC //ENDBCHJOB