*--------------------------------------------------------------------* * DON'T KNOW WHO WROTE THIS ORIGINALLY * * FULL SCREEN VTOC ZAPPER. * *--------------------------------------------------------------------* *********************************************************************** * MODIFIED BY K.M. (SAM) BASS (SBASS,SJB,KBASS,KMB) * *********************************************************************** $ATH$ EQU ??? AUTHORIZATION SVC .*-------------------------------------------------------------------* .* ZAPDSCB2 * .* THIS ONE USES UCBLOOKUP. FOR MVS/ESA 4.3 AND BELOW * .*-------------------------------------------------------------------* MACRO &MSGNAME MSSG &DATA,&REPLN,&PREFIX=YES LCLC &FN LCLA &FL AIF (T'&DATA NE 'O').IN0100 MNOTE 8,'DATA NOT SUPPLIED IN ''MSSG'' GENERATION, EXPANSION T$ ERMINATED' MEXIT .IN0100 ANOP AIF (T'&MSGNAME EQ 'O').IN0200 &FN SETC '&MSGNAME' AGO .IN0300 .IN0200 MNOTE 4,'MAP NAME NOT SPECIFIED, DEFAULT NAME GENERATED' &FN SETC 'MSSG&SYSNDX' GENERATE DEFAULT NAME .IN0300 ANOP AIF ('&DATA'(1,1) EQ '''').IN0400 FIRST CHAR A (')? MNOTE 8,'CHARACTER STRING MUST BEGIN AND END WITH A QUOTE - EX$ PANSION TERMINATED' MEXIT .IN0400 ANOP AIF (T'&REPLN EQ 'O').IN0500 IS REPLY LENGTH SUPPLIED? AIF (T'&REPLN EQ 'N').IN0500 IS REPLY LENGTH NUMERIC? MNOTE 8,'''REPLY LENGTH'' VALUE IS NOT NUMERIC - EXPANSION TER$ MINATED' MEXIT .IN0500 ANOP &FN DS 0H ALIGN ON HALFWORD &FL SETA K'&DATA-2 DEFAULT TO LENGTH OF LITERAL &FL SETA (((&FL+1)/2)*2) ROUND TO HALF WORD LENGTH AIF ('&PREFIX' NE 'YES').IN0550 BYPASS AL2 IF NOT DESIRED DC AL2(&FL) LENGTH OF TEXT - ROUNDED TO 2 .IN0550 ANOP AIF (T'&REPLN EQ 'O').IN0600 IS REPLY LENGTH SUPPLIED? DC AL2(&REPLN) LENGTH OF REPLY EXPECTED .IN0600 ANOP DC CL&FL&DATA MEND MACRO $KEYS GBLB &KEYDEF AIF (&KEYDEF).MEX2 &KEYDEF SETB 1 PFKEY01 EQU X'F1' EQUATE FOR PFKEY01 PFKEY02 EQU X'F2' EQUATE FOR PFKEY02 PFKEY03 EQU X'F3' EQUATE FOR PFKEY03 PFKEY04 EQU X'F4' EQUATE FOR PFKEY04 PFKEY05 EQU X'F5' EQUATE FOR PFKEY05 PFKEY06 EQU X'F6' EQUATE FOR PFKEY06 PFKEY07 EQU X'F7' EQUATE FOR PFKEY07 PFKEY08 EQU X'F8' EQUATE FOR PFKEY08 PFKEY09 EQU X'F9' EQUATE FOR PFKEY09 PFKEY10 EQU X'7A' EQUATE FOR PFKEY10 PFKEY11 EQU X'7B' EQUATE FOR PFKEY11 PFKEY12 EQU X'7C' EQUATE FOR PFKEY12 SPACE PFKEY13 EQU X'C1' EQUATE FOR PFKEY13 PFKEY14 EQU X'C2' EQUATE FOR PFKEY14 PFKEY15 EQU X'C3' EQUATE FOR PFKEY15 PFKEY16 EQU X'C4' EQUATE FOR PFKEY16 PFKEY17 EQU X'C5' EQUATE FOR PFKEY17 PFKEY18 EQU X'C6' EQUATE FOR PFKEY18 PFKEY19 EQU X'C7' EQUATE FOR PFKEY19 PFKEY20 EQU X'C8' EQUATE FOR PFKEY20 PFKEY21 EQU X'C9' EQUATE FOR PFKEY21 PFKEY22 EQU X'4A' EQUATE FOR PFKEY22 PFKEY23 EQU X'4B' EQUATE FOR PFKEY23 PFKEY24 EQU X'4C' EQUATE FOR PFKEY24 SPACE PA1KEY EQU X'6C' EQUATE FOR PA1KEY PA2KEY EQU X'6E' EQUATE FOR PA2KEY PA3KEY EQU X'6B' EQUATE FOR PA3KEY CLEAR EQU X'6D' EQUATE FOR CLEAR ENTER EQU X'7D' EQUATE FOR ENTER .MEX2 ANOP MEND MACRO &FLDNAME $FLD &OPTN=2,&LENGTH=,&POS=,&LOC=,&FILL=, $ &ATR=(SKIP),&INITIAL=,&TYPE=,&EQU=,&VALUES=, $ &MODEL='3276-2',&OPERATN=,&BUFFTAB=NO GBLA &TLEN ALGREBRAIC WORK FIELD * GBLA &ARG 3270 ATTRIBUTE CHAR RESOLUTION * GBLA &MTYPE TYPE REQUEST * GBLA &CURSOR CURSOR POSITION * GBLA &OPT PROCESS OPTION INDICATOR * GBLA &PREVPOS PREVIOUS POSITION * GBLA &LINES NUMBER OF LINES PER PAGE * GBLA &COLS NUMBER OF COLUMNS PER LINE * GBLC &MOD1 TYPE OF CRT BEING USED 32XX * GBLC &MOD2 MODEL OF CRT BEING USED -N * GBLA &SCRSIZE TOTAL AREA OF SCREEN * GBLA &GLENGTH FIELD LENGTH * GBLA &EPOS FIELD ENDING POSITION * GBLA &NLOC CURRENT FIELD LOCATION * GBLA &PLOC PREVIOUS (NEXT) LOCATION * GBLB &MAP FIRST TIME CONDITION SWITCH * GBLB &DEFAULT INITIAL = USER DEFAULT DATA * GBLB &DATAIND DATA FIELD INDICATOR * GBLB &PEN ATR = DET * GBLB &KEYED ATR = UNPROT * GBLB &IC ATR = IC * GBLB &NUMERIC NUMERIC FIELD INDICATOR GBLB &SEQ FIELDS OUT OF SEQUENCE IND * GBLB &SKIP 1 IF ATR = SKIP, 0 ALL OTHERS * GBLB &PROT 1 IF ATR = PROT, 0 ALL OTHERS * .* GBLC &DEVICE DIVICE TYPE INDICATOR * GBLC &FN FIELD NAME * GBLC &ATRC 3270 ATTRIBUTE CHARACTER * LCLA &REQ REPLY REQUIRED INDICATOR * LCLA &FPOS FIELD POSITION * LCLA &FLAG FIELD DESCRIPTOR FLAG * LCLC &FILLCHR FILLER USED INSTEAD OF INITIAL * GBLC &GFILL TYPE=INIT SPECIFICATION OF FILL * LCLC &OPER TYPE OF READ/WRITE OPERATION * LCLB &ABORT ABORT INDICATOR * LCLB &X(10),&XON LCLA &COUNT,&INDEX,&HIGH,&A,&B,&C LCLA &Y(10) LCLA &XAXIS X AXIS BUFFER ADDRESS * LCLA &YAXIS Y AXIS BUFFER ADDRESS * LCLC &XCHAR X AXIS CHARACTER * LCLC &YCHAR Y AXIS CHARACTER * GBLC &ADDRCHR ADDRESS CHARACTER STRING * GBLB &DOCSW DOCUMENTATION PRINT SWITCH * GBLC &MAPNAME NAME OF THIS $FLD MAP * .************************ BUFFER TABLE ENTRIES ************************ GBLB &BUFFTB BUFFER ADDRESS TABLE REQUESTED * .* TO CHANGE NUMBER OF ENTRIES, CHANGE THE SUBSCRIPT VALUE * .* HERE AND THE SETA VALUE FOR &ENTS * GBLA &ENTLEN(256) BUFFER ENTRY LENGTH - 1 * GBLA &ENTVCN(256) NUMBER OF VALUES PER ENTRY * GBLC &ENTOFF(256) BUFFER ENTRY OFFSET * GBLC &ENTRBA(256) BUFFER ENTRY RBA * GBLC &ENTVAL(768) BUFFER ENTRY VALUES 3/ENTRY * GBLA &ENTMAX MAXIMUM BUFFER ENTRIES * GBLA &ENTS NUMBER OF BUFFER ENTRIES * GBLA &VALCNT NUMBER OF TOTAL 'VALUES' ENTRIES LCLA &LSTCNT NUMBER OF ENTRIES PROCESSED * LCLA &TCNT1 WORK COUNTER * LCLC &FNM NAME TO BE USED ON DS * .********************************************************************** .* * ANALYZE OPERANDS * * .********************************************************************** AIF (&MAP).IN0100 FIRST TIME THRU ??? @ AIF (T'&TYPE EQ 'O').ERR140 MUST SUPPLY TYPE * AIF ('&TYPE' EQ 'INIT').IN0005 MUST SUPPLY INIT FIRST * .ERR140 MNOTE 4,'''INIT'' MUST BE SPECIFIED FOR FIRST INVOCATION OF TH$ IS MACRO' ERROR IF NOT * .IN0005 ANOP HERE AFTER MNOTE * &MAP SETB 1 SET ON FIRST TIME THRU @ .* CHANGE THIS SETA IF CHANGING MAXIMUM SUBSCRIPT VALUE * &ENTMAX SETA 256 MAXIMUM BUFFER ENTRIES @ &VALCNT SETA 0 RESET VALUE COUNTER @ &MTYPE SETA 0 RESET MAY INDICATOR * &PREVPOS SETA 0 RESET PREVIOUS POS INDICATOR * &SKIP SETB 1 INITIALIZE SKIP INDICATOR * &PLOC SETA 1 INITIALIZE LOCATION COUNTER * &ADDRCHR SETC 'Z40C1C2C3C4C5C6C7C8C94A4B4C4D4E4F50D1D2D3D4D5D6D7D8D95A$ 5B5C5D5E5F6061E2E3E4E5E6E7E8E96A6B6C6D6E6FF0F1F2F3F4F5F6$ F7F8F97A7B7C7D7E7F' .* THE Z AT THE BEGINNING OF THE TABLE IS TO OFFSET THE * .* MULTIPLICATION BY 2. THE OFFSET INTO THE TABLE IS BASED ON * .* AN INITIAL VALUE OF ONE (1) NOT ZERO (0). * .********************************************************************** .MOD000 ANOP HERE TO VERIFY CTR * AIF (T'&MODEL EQ 'O').ERR160 WAS MODEL SUPPLIED * AIF (K'&MODEL LT 6).ERR160 IS ALL OF IT THERE * AIF ('&MODEL'(1,1) EQ '''').MOD010 IS IT WITHIN QUOTES * &MOD1 SETC '&MODEL'(1,4) SET UP CRT TYPE * &MOD2 SETC '&MODEL'(6,1) SET UP CRT MODEL * AGO .MOD020 BYPASS FOLLOWING * .MOD010 ANOP HERE TO PROCESS QUOTES * &MOD1 SETC '&MODEL'(2,4) SET UP CRT TYPE * &MOD2 SETC '&MODEL'(7,1) SET UP CRT MODEL * .MOD020 AIF (&MOD1 EQ 3275 OR &MOD1 EQ 3277).MOD030 * AIF (&MOD1 EQ 3276 OR &MOD1 EQ 3278).MOD040 * .ERR180 MNOTE 8,'MODEL=&MODEL NOT ACCEPTABLE TO THIS MACRO' * MEXIT .MOD030 ANOP HERE FOR 3275'S * AIF (&MOD2 EQ 2).MOD050 LARGE SCREEN * AIF (&MOD2 NE 1).ERR180 NOT SMALL SCREEN * &LINES SETA 12 SET ROWS * &COLS SETA 40 SET COLUMNS * AGO .MOD090 BYPASS FOLLOWING CODE * .MOD050 ANOP HERE FOR 3277'S * &LINES SETA 24 SET ROWS * &COLS SETA 80 SET COLUMNS * AGO .MOD090 BYPASS FOLLOWING CODE * .MOD040 ANOP HERE FOR NEW DEVICES * &COLS SETA 80 ALL HAVE 80 COLUMNS * AIF (&MOD2 EQ 1).MOD060 SMALL SCREEN CRT * AIF (&MOD2 EQ 2).MOD070 LARGE SCREEN CRT * AIF (&MOD2 EQ 3).MOD080 BIG SCREEN CRT * AIF (&MOD2 NE 4).ERR180 BIGGIE SCREEN CRT * &LINES SETA 43 SET ROWS * AGO .MOD090 BYPASS FOLLOWING CODE * .MOD060 ANOP HERE FOR ROWS * &LINES SETA 12 SET ROWS * AGO .MOD090 BYPASS FOLLOWING CODE * .MOD070 ANOP HERE FOR ROWS * &LINES SETA 24 SET ROWS * AGO .MOD090 BYPASS FOLLOWING CODE * .MOD080 ANOP HERE FOR ROWS * &LINES SETA 32 SET ROWS * .MOD090 ANOP HERE WHEN ROWS & COLS DEFINED * &SCRSIZE SETA &COLS*&LINES DEFINE MAXIMUM SCREENSIZE * AIF (T'&OPTN EQ 'O').IN0010 IS OPTION GIVEN ??? * &OPT SETA &OPTN YES, SAVE VALUE * .********************************************************************** AGO .IN0020 CONTINUE * .IN0010 ANOP SUBSTITUTE OPTION VALUE * &OPT SETA 2 DOCUMENTATION ONLY * .********************************************************************** .IN0020 ANOP TEST IF DOCUMENTATION REQ. * AIF (T'&FILL EQ 'O').IN0030 IS OPTION GIVEN ??? * &GFILL SETC '&FILL' SET FILL CHARACTER .IN0030 ANOP *********************************************************************** MNOTE *,' OPTIONS IN EFFECT----------- ' MNOTE *,' ' MNOTE *,' ROWS........ &LINES ' MNOTE *,' COLUMNS..... &COLS ' MNOTE *,' CHARACTERS.. &SCRSIZE ' *********************************************************************** SPACE AIF (&DOCSW).IN0050 HAS DOCUMENTATION PRINTED ONCE? * &DOCSW SETB 1 SET DOCUMEMTATION PRINTED FLAG * *********************************************************************** * MAP GENERATION PARAMETERS, THEIR USE AND DEFAULTS * * * * INITIAL ENTRY (MUST BE GIVEN TO SET VARIOUS OPTIONS) * * * * MAP OPTN=1,MODEL='32XX-N',TYPE=INIT,BUFFTAB=XXX * * * * MODEL TO SPECIFY THE TERMINAL TYPE (AND SCREEN SIZE), * * THE DEFAULT IS SET TO 24 ROWS, AND 80 COLUMNS PER * * ROW. MAXIMUM IS 43 BY 80. THE ACCEPTABLE VALUES * * AND THEIR GENERATED SCREEN SIZES ARE AS FOLLOWS: * * * * MODEL ROWS COLS CHARS MODEL ROWS COLS CHARS * * 3276-1 12 80 960 * * 3275-1 12 40 480 3276-2 24 80 1920 * * 3275-2 24 80 1920 3276-3 32 80 2560 * * 3276-4 43 80 3440 * * * * 3278-1 12 80 960 * * 3277-1 12 40 480 3278-2 24 80 1920 * * 3277-2 24 80 1920 3278-3 32 80 2560 * * 3278-4 43 80 3440 * * * * OPTN THIS PARAMETER IS USED TO SET ONE OF THE * * FOLLOWING OPTIONS....... * * * * OPTN=1 - DOCUMENTATION GENERATION. * * OPTN=2 - DOCUMENTATION & DATA DECLARATION. * * * * NOTE: (TYPE=INIT AND MODEL=32NN-N MUST BE SPECIFIED TO * * PREVENT MNOTE ERRORS FOR DOCUMENTATION ONLY.) * * * * OPERATN THIS PRAMETER IS USED TO SPECIFY THE TYPE OF * * OPERATION TO BE USED. THE ACCEPTABLE VALUES ARE: * * * * READ - FULL BUFFER READ * * READMOD - READ MODIFIED FIELDS ONLY * * * * WRITE - WRITE / WITHOUT ERASE OPERATION * * WRITERAS - WRITE / ERASE ALL FIELDS * * WRITERUP - WRITE / ERASE UNPROTECTED FIELDS ONLY * * * *********************************************************************** EJECT *********************************************************************** * BUFFTAB=XXX THIS ENTRY MAY BE USED TO GENERATE A TABLE * * OF ALL USER MODIFIABLE ENTRIES IN THIS MAP. THIS TABLE* * CONTAINS AN ENTRY FOR EACH OF THE FOLLOWING: * * * * BUFFER ADDRESS - THE BUFFER ADDRESS OF AS GENERATED BY THIS * * MAP. NOTE: ONLY MODIFIABLE FIELDS ARE * * PROCESSED. * * OFFSET - THE OFFSET OF THIS FIELD FROM THE BEGINNING * * OF THIS FIELD MAP. * * LENGTH - THE LENGTH OF THIS FIELD, LESS ONE BYTE. * * * * THE VALID OPTIONS AND WHEN THE ARE USED ARE AS FOLLOWS: * * * * NO - USED WITH 'TYPE=INIT' TO BYPASS TABLE GENERATION. * * THIS IS THE DEFAULT VALUE. * * YES - USED WITH 'TYPE=INIT' TO REQUEST TABLE GENERATION. * * * * ADDITIONALLY, YOU MAY SPECIFY PARAMETERS TO BE * * INCLUDED IN THE GENERATION OF THIS TABLE. THEY MAY BE PASSED * * VIA THE PARAMETER 'VALUES'. AN EXAMPLE OF HOW THIS PARAMETER * * IS USED IS DISPLAYED BELOW. NOTE: TWO RESTRICTIONS EXIST. * * THEY ARE: 1) A MAXIMUM OF THREE ENTRIES ARE ALLOWED PER $FLD * * SPECIFICATION, AND 2) THIS VALUE IS ALLOWABLE ONLY ON FIELDS * * THAT ARE FLAGGED AS MODIFIABLE BY THE USER. ALSO, YOU ARE * * RESPONSIBLE FOR MAINTAINING ALIGNMENT. THE BASIC TABLE IS SIX* * (6) BYTES LONG AND IS INITIATED ON A FULLWORD BOUNDARY. * * * * FSTART $FLD TYPE=INIT,BUFFTAB=YES * * FIELD1 $FLD POS=(10,30),INITIAL='.....',ATR=IC, * * VALUES=(X'01',X'4E',A(PARAM)) * * FTABLE $FLD TYPE=FINAL * * * * THIS WOULD GENERATE A BUFFER ADDRESS TABLE AS FOLLOWS: * * * *FTABLE DS 0F * * DC XL2'4B6E' BUFF ADDR OF CURRENT ENTRY * * DC AL2(FIELD1-FSTART) OFFSET TO CURRENT ENTRY * * DC AL2(4) LENGTH OF CURRENT ENTRY - 1 * * DC X'01' VALUES PARAMETER * * DC X'4E' VALUES PARAMETER * * DC A(PARAM) VALUES PARAMETER * * * * NOTE: THIS TABLE IS A MULTIPLE OF 4 BYTES. (USER CONTROLLED) * *********************************************************************** EJECT *********************************************************************** * * * FIELD LAYOUT ENTRIES (ONE PER FIELD) * * * * $FLD POS=(10,1),ATR=(SKIP),INITIAL='A',LOC=NNN,TYPE=REQ * * LENGTH=1 * * * * POS TO SPECIFY ROW AND COLUMN NUMBERS. TRY NOT TO * * USE ROW 24, IT IS USED BY THE SYSTEM. * * * * ATR THIS PARAMETER IS USED TO DEFINE THE DATA FIELD * * ATTRIBUTE CHARACTERISTICS. * * * * ATR=(SKIP) PROTECTED FIELD * ATR=(BRT) HIGH INTENSITY FIELD* * ATR=(PROT) PROTECTED FIELD * ATR=(DRK) NON-DISPLAY FIELD * * ATR=(UNPR) MODIFIABLE FIELD * ATR=(MDT) MODIFIED DATA TAG ON* * ATR=(NUM) NUMERIC DATA ONLY * ATR=(IC) INSERT CURSOR * * ATR=(DET) LIGHT PEN DETECTALBE * ATR=(NORM) NORMAL INTENSITY * * * * DO NOT USE THE FOLLOWING COMBINATIONS....... * * ATR=(SKIP,UNPR) ATR=(DRK,NORM) * * ATR=(PROT,UNPR) ATR=(SKIP,IC) * * ATR=(DET,DRK) ATR=(PROT,IC) * * ATR=(BRT,DRK) ATR=(PROT,NUM) * * ATR=(BRT,NORM) * * * * LENGTH TO SPECIFY LENGTH OF FIELD WHEN 'INITIAL' IS * * NOT GIVEN. DO NOT USE WHEN INITIAL VALUE IS * * GIVEN. * * INITIAL USED TO DECLARE CONSTANT SCREEN DATA. THIS * * SHOULD ALWAYS BE USED TO SHOW THE TYPE OF DATA * * TO BE DISPLAYED. * * LOC THIS PARAMETER IS USED TO DEFINE THE RELATIVE * * LOCATION OF THE DATA FIELD WITHIN THE USER AREA. * * DO NOT SPECIFY ON ANY OTHER THAN INPUT DATA. * * TYPE TYPE=INIT IS REQUIRED FIRST TIME THRU TO SET UP * * INITIAL VALUES AND DOCUMENTATION PRINT. * * TYPE=FINAL IS NEEDED TO TERMINATE THE CURRENT * * MAP AND TO INSERT ANY CURSOR SPECIFIED. * * * * FTABLE $FLD TYPE=FINAL,EQU=XXXXXX * * * * TYPE=FINAL CAUSES THE INSERT CURSOR STRING TO BE PLACED * * AT THE END OF THE FIELD DEFINITION. THIS POSITION* * IS REQUIRED FOR TCAM. * * EQU=XXXXX WILL GENERATE AN EQU, WITH XXXXX AS THE NAME, * * WITH THE LENGTH OF THIS DISPLAY AS THE VALUE. * * * * * *********************************************************************** EJECT .IN0050 ANOP AIF (&OPT EQ 1).MAPXIT EXIT IF DOCUMENTATION ONLY * AIF (&OPT EQ 2).IN0055 CONTINUE IF VALID OPTION * MNOTE 4,'INVALID OPTION SPECIFIED, OPTION=2 ASSUMED' .IN0055 ANOP AIF ('&BUFFTAB'(1,1) EQ 'N').IN0057 BUFFER TABLE REQ? AIF ('&BUFFTAB'(1,1) NE 'Y').ERR200 IF NOT, ERROR &BUFFTB SETB 1 YES, INDICATE SO &ENTS SETA 0 RESET ENTRY COUNT .IN0057 ANOP .* &FLDNAME CSECT * AIF (T'&FLDNAME EQ 'O').IN0060 &FN SETC '&FLDNAME' GENERATE DEFAULT NAME AGO .IN0065 .IN0060 ANOP AIF (NOT &BUFFTB).IN0065 BYPASS IF BUFFTAB NOT REQUESTED MNOTE 4,'MAP NAME REQUIRED WITH ''BUFFTAB'' OPTION, DEFAULT NA$ ME GENERATED' &FN SETC 'FLD&SYSNDX' GENERATE DEFAULT NAME .IN0065 ANOP &FN DS 0F * &FPOS SETA 4 &MAPNAME SETC '&FN' SAVE MAP NAME AIF (T'&OPERATN EQ 'O').MAPXIT IF OMITTED, BYPASS REST * AIF ('&OPERATN'(1,4) EQ 'READ').IN0080 GO TO READ * AIF ('&OPERATN'(1,5) EQ 'WRITE').IN0070 CHECK TYPE * MNOTE 8,'TYPE OF OPERATION SPECIFIED IS UNACCEPTABLE' MEXIT .IN0070 ANOP AIF ('&OPERATN'(5,4) EQ 'ERAS').IN0072 ERASE WRITE * AIF ('&OPERATN'(5,4) EQ 'ERUN').IN0074 ERASE UNPROT * &OPER SETC 'F1' DEFAULT TO NORMAL WRITE * AGO .IN0090 GO GEN CHAR STRING * .IN0072 ANOP &OPER SETC 'F5' DEFAULT TO WRITE ERASE * AGO .IN0090 GO GEN CHAR STRING * .IN0074 ANOP &OPER SETC '6F' DEFAULT TO ERASE UNPROT * AGO .IN0090 GO GEN CHAR STRING * .IN0080 ANOP HERE FOR READ OPERATIONS * AIF ('&OPERATN'(5,3) EQ 'MOD').IN0082 READ MODIFY * &OPER SETC 'F2' DEFAULT TO NORMAL READ * AGO .IN0090 GO GEN CHAR STRING * .IN0082 ANOP HERE FOR READ MODIFIED * &OPER SETC 'F6' DEFAULT TO READ MODIFIED * .IN0090 ANOP DC XL3'27&OPER.C1' * AGO .MAPXIT EXIT ON FIRST TIME THRU * .********************************************************************** .IN0100 ANOP BYPASS AFTER FIRST TIME THRU * AIF (&MTYPE EQ 2).ERR010 ERROR IF PREV. ENTRY FINAL @ AIF (T'&TYPE EQ 'O').IN0110 IS THIS FINAL ENTRY ??? @ AIF ('&TYPE' NE 'FINAL').ERR150 REPLY REQUIRED ??? * &MTYPE SETA 2 YES, SET INDICATOR @ AGO .FI0000 GO PROCESS FINAL ENTRY @ .IN0110 ANOP SET UP FIELD NAME @ .********************************************************************** .* ANALYZE SPECIFICATION OF LENGTH/INITIAL OPERAND * .********************************************************************** AIF (T'&LENGTH EQ 'O').LG0010 LENGTH NOT GIVEN 5 &GLENGTH SETA &LENGTH SET FIELD LENGTH @ AGO .LG0030 BYPASS LENGTH SUBSTITUTION @ .LG0010 ANOP USE LENGTH OF DEFAULT VALUE @ AIF (T'&INITIAL EQ 'O').LG0020 IF NOT GIVEN DEFAULT TO ONE 5 AIF ('&INITIAL'(1,1) NE '''').ERR070 YES, FIRST CHAR A (') ? &GLENGTH SETA K'&INITIAL-2 DEFAULT TO LENGTH OF LITERAL @ &DEFAULT SETB 1 YES, SET DEFAULT GLOBAL @ AGO .LG0030 END OF LENGTH GENERATION 5 .LG0020 ANOP LENGTH DEFAULT SETUP 5 &GLENGTH SETA 1 DEFAULT TO LENGTH OF ONE @ .LG0030 ANOP VALIDATE LENGTH VALUE ASSIGNED 5 .* AIF (&GLENGTH GT 256).ERR020 TOO LONG DELETED BY LGN 7906* AIF (&GLENGTH LT 1).ERR020 NOT LONG ENOUGH @ .********************************************************************** .* ANALYZE SPECIFICATION OF FILL OPERAND * .********************************************************************** AIF (T'&FILL NE 'O').FILL10 IS OPTION GIVEN ??? * &FILLCHR SETC '&GFILL' SET FILL CHARACTER AGO .FILL20 .FILL10 ANOP &FILLCHR SETC '&FILL' SET FILL CHARACTER .FILL20 ANOP .PO0000 ANOP END OF FIELD LENGTH PARAMETER @ .********************************************************************** .* ANALYZE SPECIFICATION OF POS OPERAND * .********************************************************************** AIF (T'&POS EQ 'O').ERR030 IS POS = NULL ? @ &FPOS SETA &POS(1) @ AIF (N'&POS LT 2).PO0020 ACTUAL POSITIONS SPECIFIED ??? @ AIF (&POS(1) LT 1 OR &POS(1) GT &LINES).ERR030 LINE VALID ? AIF (&POS(2) LT 1 OR &POS(2) GT &COLS).ERR030 YES, COL ? &FPOS SETA (((&POS(1)-1)*(&COLS))+(&POS(2)-1)) YES, CONVERT IT @ AGO .PO0030 @ .PO0020 ANOP @ AIF (&FPOS-&EPOS GT 0).PO0030 WILL FIELD OVERLAP? * MNOTE 4,'POSITION ADJUSTED TO PREVENT FIELD OVERLAY' * &FPOS SETA &EPOS+1 PREVIOUS ENDING POS + ONE * AGO .PO0040 BYPASS FOLLOWING CODE * .PO0030 ANOP AIF (&SKIP).PO0040 WAS PREV FIELD ATR = SKIP ??? AIF (&FPOS-&EPOS EQ 1).PO0040 IF ONLY ONE BYTE -- * DC X'1D7C' CAUSE SKIP FROM LAST FIELD * .PO0040 ANOP GAP FIELD GENERATION RETURN PT &EPOS SETA (&FPOS+&GLENGTH) CALCULATE ENDING POSITION * AIF (&SCRSIZE LT &EPOS).ERR080 OUTSIDE OF PAGE ? * .PO0060 ANOP NO, END OF POSITION OPERAND @ AIF (&FPOS GE &PREVPOS).PO0070 ARE FIELDS IN SEQUENCE ? @ &SEQ SETB 1 NO, SET OUT OF SEQUENCE IND @ AGO .ERR170 THEN TERMINATE THIS EXPANSION @ .PO0070 ANOP YES, BYPASS OUT OF SEQ IND @ &PREVPOS SETA &FPOS SET NEW PREVIOUS POSITION @ .AT0000 ANOP END OF POSITION AND SEQUENCE CHECK @ .********************************************************************** .* ANALYZE SPECIFICATION OF ATR OPERAND * .********************************************************************** &ATRC SETC '40' INITIALIZE 3270 ATTRIBUTE CHAR @ &SKIP SETB 0 RESET SKIP OPTION @ &PROT SETB 0 RESET PROT OPTION @ &INDEX SETA 1 &HIGH SETA 10 &IC SETB 0 &ARG SETA 0 AIF (T'&ATR EQ 'O').AT0040 .AT0010 ANOP &COUNT SETA &COUNT+1 AIF (&COUNT GT &HIGH).ERR100 AIF ('&ATR(&INDEX)'(1,2) EQ '**SKIPROUNPNUMDETBRTDRKMDTIC NO* R'(3*&COUNT,2)).AT0030 AGO .AT0010 .AT0020 ANOP AIF (&INDEX EQ N'&ATR).AT0050 &INDEX SETA &INDEX+1 &COUNT SETA 0 AGO .AT0010 .* .* SET X MATRIX FOR CHARACTER DISPLACEMENT. .* .AT0030 ANOP &XON SETB 1 &X(&COUNT) SETB 1 &Y(&COUNT) SETA &INDEX AGO .AT0020 .AT0040 ANOP &X(1) SETB 1 &XON SETB 1 .* .* ANALYZE THE MATRIX .* .AT0050 ANOP AIF (&XON).AT0060 &X(1) SETB 1 .AT0060 ANOP .* .* OUTPUT ANALYSIS. .* &A SETA 1 SKIP &B SETA 3 UNPROTECTED AIF (&X(1) AND &X(3)).ERR110 SKIP/UNPROTECTED ??? &A SETA 2 PROTECT AIF (&X(2) AND &X(3)).ERR110 PROTECTED/UNPROTECTED &A SETA 5 SELECTER PEN DETECTABLE &B SETA 7 DARK (NON-DETECTABLE) AIF (&X(5) AND &X(7)).ERR110 DETECTABLE/DARK ??? &A SETA 6 BRIGHT AIF (&X(6) AND &X(7)).ERR110 BRIGHT/DARK ??? &B SETA 10 NORMAL AIF (&X(6) AND &X(10)).ERR110 BRIGHT/NORMAL ??? &A SETA 7 DARK AIF (&X(7) AND &X(10)).ERR110 DARK/NORMAL ??? AIF (&X(1) AND &X(9)).ERR120 SKIP/IC ??? AIF (&X(2) AND &X(9)).ERR120 PROT/IC ??? AIF (&X(2) AND &X(4)).ERR130 PROT/NUM ??? .* .* SET ATTRIBUTE BITS .* .AT0070 ANOP &NUMERIC SETB (&X(4)) SET NUMERIC FIELD INDICATOR &X(2) SETB (&X(1) OR &X(2)) PROT IF SKIP. &X(4) SETB (&X(1) OR &X(4)) NUM IF SKIP &X(5) SETB (&X(7) OR (&X(5) AND NOT &X(6))) SET IF DARK OR LGHT PEN &X(6) SETB (&X(7) OR &X(6)) BRT IF DARK. &IC SETB (&X(9)) IC IF REQUESTED &ARG SETA (32*&X(2)+16*&X(4)+4*&X(5)+8*&X(6)+&X(8)) &KEYED SETB (&X(3)) FLAG AS KEYABLE IF UNPROTECTED. &PROT SETB (&X(2) OR &X(1)) SET TO ONE IF ATR = PROT OR SKIP &SKIP SETB (&X(1)) SET TO ONE IF ATR = SKIP AGO .AT0100 .AT0090 ANOP &X(&C) SETB 0 CLEAR &C SETA &C+1 DOWN AIF (&C LT 11).AT0090 X TABLE. AGO .AT0070 .AT0100 ANOP END OF ATR ANALYSIS AIF (T'&FLDNAME EQ 'O').AT0110 FIELD NAME OMITTED @ &FN SETC '&FLDNAME'(1,8) USE FIRST 8 CHAR FOR NAME @ &DATAIND SETB ('&FN' NE '') INDICATE DATA ITEM (LABEL) @ AGO .AT0120 BYPASS NEXT TEST @ .AT0110 ANOP FIELD NAME BYPASS @ AIF ((NOT &BUFFTB) OR (&SKIP) OR (&PROT)).AT0120 MNOTE 4,'MAP NAME REQUIRED WITH ''BUFFTAB'' OPTION, DEFAULT NA$ ME GENERATED' AIF (NOT &SKIP).AT0110 &FN SETC 'FLD&SYSNDX' GENERATE DEFAULT NAME .AT0120 ANOP .********************************************************************** .* CONVERT THE BINARY ATR TO A VALID 3270 TRANSMITTABLE CHAR * .********************************************************************** &ATRC SETC '&ADDRCHR'((&ARG+1)*2,2) SELECT ATTRIBUTE CHARACTER * .DE0000 ANOP END OF ATTRIBUTE CONVERSION @ .********************************************************************** .* DATA DECLARATION GENERATION * .********************************************************************** .LO0000 ANOP END OF JUSTIFY PARAMETER @ .********************************************************************** .* SET CURRENT OUTPUT FIELD LOCATION COUNTER * .********************************************************************** AIF (NOT &DATAIND).LO0020 BYPASS FOR NON DATA FIELDS * AIF (T'&LOC EQ 'O').LO0010 LOCATION NOT GIVEN, USE DEFAULT &NLOC SETA &LOC SET CURRENT LOCATION COUNTER * &PLOC SETA (&NLOC+(&GLENGTH)) SET NEXT TO CUR PLUS LENGTH * AGO .LO0020 CONTINUE * .LO0010 ANOP DEFAULT TO CURRENT COUNT * &NLOC SETA &PLOC USE PREVIOUS COUNT * &PLOC SETA (&NLOC+(&GLENGTH)) SET NEXT TO CUR PLUS LENGTH * .LO0020 ANOP END OF LOCATION COUNT SETUP * AGO .GN0010 GO TO FIELD GENERATION @ .GN0000 ANOP FIELD GENERATION @ .********************************************************************** .* GENERATE SKIP (END OF LINE) FIELD ENTRY * &XAXIS SETA (&EPOS/64+1) &YAXIS SETA (&EPOS-(&XAXIS-1)*64+1) &XCHAR SETC '&ADDRCHR'(&XAXIS*2,2) &YCHAR SETC '&ADDRCHR'(&YAXIS*2,2) .********************************************************************** DC XL1'11' FIELD DESCRIPTOR FLAG BYTE @ DC X'&XCHAR&YCHAR' FIELD POSITION * DC CL1'0' FIELD ATTRIBUTE @ *---------------------------------------------------------------------* AGO .PO0030 .GN0010 ANOP FIELD GENERATION @ .********************************************************************** .* GENERATE FIELD ENTRY * &XAXIS SETA (&FPOS/64+1) &YAXIS SETA (&FPOS-(&XAXIS-1)*64+1) &XCHAR SETC '&ADDRCHR'(&XAXIS*2,2) &YCHAR SETC '&ADDRCHR'(&YAXIS*2,2) .********************************************************************** DC XL1'11' START BUFFER ADDRESS CHARACTER * DC X'&XCHAR&YCHAR' FIELD POSITION * DC XL1'1D' START FIELD CHARACTER * DC XL1'&ATRC' FIELD ATTRIBUTE * AIF (NOT &DEFAULT).GN0050 IS INITIAL = DEFAULT DATA ? @ &FN DC CL&GLENGTH.&INITIAL AGO .GN0060 GO TO NEXT OPTION * .GN0050 ANOP INITIAL = DEFAULT DATA BYPASS @ &FN DS 0CL&GLENGTH DC &GLENGTH.XL1'&FILLCHR.' .GN0060 ANOP INITIAL = DEFAULT DATA BYPASS @ *********************************************************************** AIF (((NOT &KEYED) AND (&CURSOR NE 0)) OR (NOT &IC)).GN0070 &CURSOR SETA &FPOS+1 UPDATE CURSOR POSITION @ .GN0070 ANOP END OF FIELD GENERATION @ AIF (((NOT &BUFFTB) AND (NOT &KEYED)) OR (&PROT)).MAPXIT &FPOS SETA &FPOS+1 BUMP TO ACTUAL FIELD &XAXIS SETA (&FPOS/64+1) &YAXIS SETA (&FPOS-(&XAXIS-1)*64+1) &XCHAR SETC '&ADDRCHR'(&XAXIS*2,2) &YCHAR SETC '&ADDRCHR'(&YAXIS*2,2) &ENTS SETA &ENTS+1 BUMP ENTRY COUNT &ENTRBA(&ENTS) SETC '&XCHAR&YCHAR' SET RBA &ENTLEN(&ENTS) SETA &GLENGTH-1 SET LENGTH-1 &ENTOFF(&ENTS) SETC '&FN-&MAPNAME' DEFINE OFFSET FOR ADCON &ENTVCN(&ENTS) SETA 0 INSURE UNUSED IS ZERO AIF (T'&VALUES EQ 'O').MAPXIT .GN0080 ANOP AIF (&ENTVCN(&ENTS) EQ 3).MAPXIT &ENTVCN(&ENTS) SETA &ENTVCN(&ENTS)+1 BUMP COUNTER &VALCNT SETA &VALCNT+1 BUMP COUNTER &ENTVAL(&VALCNT) SETC '&VALUES(&ENTVCN(&ENTS))' MOVE PARAMETER AIF (&ENTVCN(&ENTS) LT N'&VALUES).GN0080 .MAPXIT ANOP END OF FIELD GENERATION @ &FN SETC '' INITIALIZE FLDNAME GLOBAL @ &DEFAULT SETB 0 INITIALIZE DEFAULT DATA GLOBAL @ &DATAIND SETB 0 INITIALIZE DATA (FIELD) INDICATOR @ &PEN SETB 0 INITIALIZE PEN DETECTABLE GLOBL @ &IC SETB 0 INITIALIZE INSERT CURSOR GLOBAL @ &KEYED SETB 0 INIT UNPROTECTED FIELD GLOBAL @ &NUMERIC SETB 0 INITIALIZE NUMERIC FIELD GLOBAL @ MEXIT EXIT MACRO @ .********************************************************************** .*** GENERATE FINAL DSECT AND ADDRESS TABLES *** .********************************************************************** .FI0000 ANOP FINAL ENTRIES @ AIF ((&SKIP) OR (&PROT)).FI0010 WAS PREV FIELD ATR = SKIP * &EPOS SETA &EPOS+1 BUMP BY ONE TO MISS PREV FIELD * &XAXIS SETA (&EPOS/64+1) &YAXIS SETA (&EPOS-(&XAXIS-1)*64+1) &XCHAR SETC '&ADDRCHR'(&XAXIS*2,2) &YCHAR SETC '&ADDRCHR'(&YAXIS*2,2) DC XL1'11' FIELD DESCRIPTOR FLAG BYTE @ DC X'&XCHAR&YCHAR' FIELD POSITION * DC XL1'1D' START FIELD INDICATOR * DC XL1'F0' FIELD ATTRIBUTE *********************************************************************** .FI0010 ANOP * &MAP SETB 0 SET OFF AFTER FINAL @ .********************************************************************** AIF (NOT &CURSOR).FI0020 NO CURSOR! * SET CURSOR POSITION * &XAXIS SETA (&CURSOR/64+1) &YAXIS SETA (&CURSOR-(&XAXIS-1)*64+1) &XCHAR SETC '&ADDRCHR'(&XAXIS*2,2) &YCHAR SETC '&ADDRCHR'(&YAXIS*2,2) &FN SETC '' AIF (T'&FLDNAME EQ 'O').CR0000 WAS NAME SPECIFIED? &FN SETC '&MAPNAME'(1,5) SET DEFAULT VALUE &FNM SETC 'CSR' SET DEFAULT VALUE &FN SETC '&FN&FNM' SET DEFAULT VALUE .CR0000 ANOP DC XL1'11' START BUFFER ADDRESS CHARACTER * &FN DC X'&XCHAR&YCHAR' FIELD POSITION * DC XL1'13' INSERT CURSOR INDICATOR * &CURSOR SETA 0 RESET CURSOR POSITION * *********************************************************************** .FI0020 ANOP AIF (T'&EQU EQ 'O').FI0040 &FN SETC '&EQU' &FN EQU *-&MAPNAME .FI0040 ANOP AIF ((NOT &BUFFTB) OR (NOT &ENTS)).MEXIT .********************************************************************** AIF (T'&FLDNAME NE 'O').FI0100 WAS NAME SPECIFIED? &FN SETC '&MAPNAME'(1,4) SET DEFAULT VALUE &FN SETC '&FN&SYSNDX' SET DEFAULT VALUE AGO .FI0110 GO PROCESS NEXT ONE .FI0100 ANOP &FN SETC '&FLDNAME' USE NAME SPECIFIED INSTEAD .FI0110 ANOP EJECT *********************************************************************** * THIS TABLE IS GENERATED FOR THE USER WHEN A MAP OF ALL * * MODIFIABLE ENTRIES IN A '$FLD' LIST IS REQUIRED. THIS MAP * * CONTAINS THE FOLLOWING ENTRIES: * * * * XL2(....) THE BUFFER ADDRESS OF THIS FIELD * * AL2(..) THE OFFSET INTO THE MAP, OF THIS FIELD * * AL2(..) THE LENGTH-1 OF THIS FIELD * * * *********************************************************************** CNOP 2,4 ALIGN ON HALFWORD BOUND DC H'&ENTS' TOTAL NUMBER OF ENTRIES &FN DS 0F LISTING OF BUFFER ADDRESS TABLE .FI0120 ANOP &LSTCNT SETA &LSTCNT+1 BUMP ENTRY LSTCNT AIF ((&LSTCNT GT &ENTS) OR (&LSTCNT GT &ENTMAX)).FIEXIT DC XL2'&ENTRBA(&LSTCNT)' BUFF ADDR OF CURRENT ENTRY DC AL2(&ENTOFF(&LSTCNT)) OFFSET OF CURRENT ENTRY DC H'&ENTLEN(&LSTCNT)' LENGTH OF CURRENT ENTRY - 1 AIF (&ENTVCN(&LSTCNT) EQ 0).FI0120 .FI0130 ANOP &TCNT1 SETA &TCNT1+1 DC &ENTVAL(&TCNT1) VALUES PARAMETER AIF (&TCNT1 LT &ENTVCN(&LSTCNT)).FI0130 AGO .FI0120 GO PROCESS NEXT ONE .FIEXIT ANOP &TCNT1 SETA (K'&FLDNAME) AIF (&TCNT1 LE 6).FIEX01 &TCNT1 SETA 6 .FIEX01 ANOP &FILLCHR SETC '&FN' &FN SETC '&FILLCHR'(1,&TCNT1) &FNM SETC 'EL' &FN SETC '&FN&FNM' &FN EQU ((*-&FILLCHR)/&ENTS) LENGTH OF EACH ENTRY DC X'FFFF' END OF TABLE SPACE &ENTS SETA 0 RESET ENTRY COUNT *********************************************************************** .MEXIT ANOP HERE TO EXIT MACRO * MEXIT EXIT MACRO @ .********************************************************************** .* * MNOTE STATEMENTS * * .********************************************************************** .ERR010 ANOP TYPE IN ERROR @ MNOTE 12,'TYPE = FINAL IS PREVIOUSLY SPECIFIED,' @ AGO .MAPXIT TERMINATE @ MEXIT MACRO EXIT @ .ERR020 ANOP LENGTH OPERAND ERROR ENTRY @ MNOTE 12,'INVALID LENGTH OPERAND IS SPECIFIED,' @ MNOTE *,'MACRO REQUEST IS IGNORED,' @ MNOTE *,'VALID LENGTH OPERAND IS REQUIRED.' &ABORT SETB 1 TURN ON ABORT INDICATOR @ AGO .MAPXIT TERMINATE GENERATION @ .ERR030 ANOP POS OPERAND ERROR ENTRY @ MNOTE 12,'INVALID POS OPERAND IS SPECIFIED,' @ .ERR055 ANOP POS OPERAND MNOTE ENTRY @ MNOTE *,'MACRO REQUEST IS IGNORED,' @ MNOTE *,'VALID POS OPERAND IS REQUIRED WITH MAP MACRO.' @ &ABORT SETB 1 TURN ON ABORT INDICATOR @ AGO .AT0000 GO TO POS OPERAND COMPLETION @ .ERR070 ANOP INITIAL OPERAND ERROR ENTRY @ MNOTE 8,'INVALID INITIAL OPERAND IS SPECIFIED,' @ MNOTE *,'DEFAULT DATA MUST BE ENCLOSED IN QUOTES,' @ MNOTE *,'INITIAL OPERAND IS IGNORED.' @ AGO .LG0020 GO TO INITIAL OPERAND BYPASS @ .ERR080 ANOP FIELD SPECIFICATION ERROR ENTRY @ MNOTE 8,'FIELD IS DEFINED OUTSIDE OF THE SIZE OPERAND' @ MNOTE *,'MACRO REQUEST IS IGNORED.' @ &ABORT SETB 1 TURN ON ABORT INDICATOR @ AGO .PO0020 GO TO PAGE SIZE BYPASS @ .ERR100 ANOP ATR PARAMETER ERROR ENTRY MNOTE 4,'INVALID ATTRIBUTE PARAMETER IS SPECIFIED,' MNOTE *,'ATR = &ATR(&INDEX) IS IGNORED.' AGO .AT0020 GO TO CHECK INDEX .ERR110 ANOP INCOMPATIBLE ATR OP ERROR &A SETA &Y(&A) SET PARAMETER INDEX VALUE &B SETA &Y(&B) SET PARAMETER INDEX VALUE MNOTE 4,'&ATR(&A) AND &ATR(&B) ARE INCOMPATIBLE PARAMETERS,' MNOTE *,'ATR = &ATR(&A) IS IGNORED,' MNOTE *,'ATR = &ATR(&B) IS IGNORED,' MNOTE *,'ATR = SKIP IS ASSUMED BY DEFAULT.' &X(1) SETB 1 SKIP DEFAULT. &C SETA 2 SET C FOR CLEARING X TABLE. AGO .AT0090 .ERR120 ANOP ATR = IC ERROR ENTRY MNOTE *,'ATR = IC IS REQUESTED FOR PROTECTED FIELD' AGO .AT0070 .ERR130 ANOP ATR = PROT AND NUM ERROR MNOTE *,'ATR = PROT AND NUM ALSO IMPLIES THE SKIP PARAMETER' AGO .AT0070 .ERR150 ANOP HERE FOR ERROR * MNOTE 8,'INVALID TYPE SPECIFIED' * .ERR160 ANOP HERE FOR ERROR * MNOTE 8,'MODEL OPERAND IS REQUIRED && MINIMUM LENGTH IS 6' * MEXIT .ERR170 ANOP HERE FOR ERROR * MNOTE 16,'SEQUENCE ERROR ENCOUNTERED, EXPANSION TERMINATED' * MEXIT .ERR200 ANOP HERE FOR ERROR * MNOTE 8,'INVALIB ''BUFFTAB'' SPECIFICATION' * MEXIT .ERR190 ANOP HERE FOR ERROR * MNOTE 8,'MAP NAME REQUIRED WITH ''BUFFTAB'' OPTION' * MEXIT MEND DSCBZAP TITLE 'THIS PROGRAM WILL ALLOW THE USER THE ABILITY TO MODIFY A DSCB' DSCBZAP CSECT SAVE (14,12),,DSCBZAP.&SYSDATE..&SYSTIME. LR R11,R15 LOAD PGM'S BASE REG USING DSCBZAP,R11 LA R14,SAVEAREA A(MY SAVEAREA) ST R14,8(,R13) UPDATE FORWARD POINTER ST R13,4(,R14) UPDATE BACKWARD POINTER LR R13,R14 AND LOAD MY SAVEAREA BASE USING SAVEAREA,R13,R12 AND DEFINE SAME TO ASSEMBLER LA R12,2048(,R13) COMPUTE SECOND LA R12,2048(,R12) BASE REG ADDRESS LR R2,R1 SAVE CPPL ADDRESS LA R1,=C'AUTH' SVC $ATH$ SPACE *********************************************************************** * LOCATE THE USER'S ASCB AND SAVE THE USERID * *********************************************************************** L R15,PSAAOLD-PSA(00) A(PSA ASCB) L R15,ASCBASXB-ASCB(R15) A(ASXB) L R15,ASXBSENV-ASXB(R15) A(ASCB) MVC USERID,ACEEUSER-ACEE(R15) COPY THE USERID MVC DEFCSRAD,DSCBPCSR SAVE INITIAL CURSOR BUFF ADDR SPACE *********************************************************************** * INITIATE FULL SCREEN PROCESSING * *********************************************************************** STFSMODE ON,INITIAL=YES INITIATE FULL SCREEN PROCESSING EJECT *********************************************************************** * SETUP THE CVAF HEADER AND BUFFER LISTS * *********************************************************************** XC CVAFBUF(BFLHLN+BFLELN),CVAFBUF RESET BUFFER HEADER OI BFLHFL,BFLHDSCB INDICATE READ DSCB'S MVI BFLHNOE,1 NUMBER OF BUFFER LIST ENTRIES LA R15,DS1FMTID A(DSCB DATA AREA) ST R15,BFLEBUF AND UPDATE BUFFER LIST MVI BFLELTH,LDSCB-44 LENGTH OF DATA AREA (DSCB-44) SPACE *********************************************************************** * COPY THE DATA SET NAME FROM THE COMMAND BUFFER TO THE DATA * * SET NAME FIELD ON THE PANEL ADDING THE USER ID, IF NECESSARY * *********************************************************************** L R2,CPPLCBUF-CPPL(R2) LOAD COMMAND BUFFER ADDRESS SLR R3,R3 CLEAR WORK REGISTER SLR R4,R4 CLEAR WORK REGISTER ICM R3,B'0011',0(R2) LENGTH OF COMMAND BUFFER ICM R4,B'0011',2(R2) OFFSET TO FIRST OPERAND SR R3,R4 COMPUTE LENGTH OF OPERAND SPACE SH R3,=H'04' AND DECREMENT FOR LENGTH FLD BP *+4+4+4 DATA SET NAME SUPPLIED? LA R15,DSNAMEER NO, ADDRESS ERROR MESSAGE B PROCEMSG GO PROCESS ERROR MESSAGE SPACE CH R3,=H'46' LENGTH GREATER THAN MAX? BNH *+4+4+4 NO, BYPASS DEFAULT LA R15,DSNLNGER PROVIDE FOR ERROR MSG B PROCEMSG YES, GENERATE ERROR MESSAGE SPACE STH R3,LDSNAME SAVE LENGTH OF DSNAME BCTR R3,00 DECREMENT FOR EXECUTE LA R4,4(R2,R4) ADDRESS DATA SET NAME EX R3,EXOCINPT CONVERT TO UPPER CASE EJECT MVC PDSNAME,ALLZEROS MOVE IN ALL BLANKS MVC DS1DSNAM,ALLBLANK MOVE IN ALL BLANKS LA R15,PDSNAME A(PANEL DSNAME) LA R14,DS1DSNAM A(DSCB DSNAME) CLI 0(R4),C'''' DOES DSN BEGIN WITH A QUOTE BNE NOQUOTES NO, DO NOT PROCESS QUOTES EX R3,EXMVCPDS MOVE DSN INTO PANEL LA R4,1(,R4) YES, BYPASS FIRST QUOTE BCTR R3,00 DECREMENT FOR FIRST QUOTE STH R3,LDSNAME SAVE NEW LENGTH OF DSNAME BCTR R3,00 DECREMENT FOR LAST QUOTE EX R3,EXMVCDS1 MOVE DSN INTO DSCB B DSNMOVED SPACE EXMVCPDS OC 0(0,R15),0(R4) MOVE IN DATA SET NAME EXMVCDS1 OC 0(0,R14),0(R4) MOVE IN DATA SET NAME PDSUSERI MVC 0(0,R15),USERIDI MOVE IN USERID DS1USERI MVC 0(0,R14),USERIDI MOVE IN USERID EXOCINPT OC 0(0,R4),ALLBLANK EXECUTED OC SPACE NOQUOTES DS 0H SLR R1,R1 CLEAR WORK REG IC R1,USERIDL AL2(LENGTH OF USERID) SPACE LA R5,2(,R1) USERID + DELIMITER + BCTR OFFSET AR R5,R3 + LENGTH OF DSNAME STH R5,LDSNAME SAVE COMPUTED LENGTH OF DSNAME CH R5,=H'46' IS DSNAME GT FIELD LENGTH? BNH *+4+4+4 NO, CONTINUE PROCESSING LA R15,DSNLNGER YES, PROVIDE FOR ERROR MSG B PROCEMSG AND DISPLAY SAME SPACE BCTR R1,0 DECREMENT FOR EXECUTE MVI 0(R15),C'''' MOVE IN A QUOTE LA R15,1(,R15) AND ADJUST FOR SAME EX R1,DS1USERI MOVE USERID TO DSNAME EX R1,PDSUSERI MOVE USERID TO DSNAME LA R14,1(R1,R14) AND ADJUST FOR SAME LA R15,1(R1,R15) AND ADJUST FOR SAME MVI 0(R14),C'.' MOVE IN A DELIMITER MVI 0(R15),C'.' MOVE IN A DELIMITER LA R14,1(,R14) AND ADJUST FOR SAME LA R15,1(,R15) AND ADJUST FOR SAME EX R3,EXMVCPDS MOVE DSN INTO PANEL EX R3,EXMVCDS1 MOVE DSN INTO DSCB LA R15,1(R3,R15) AND ADJUST FOR SAME MVI 0(R15),C'''' MOVE IN A QUOTE DSNMOVED DS 0H EJECT *********************************************************************** * LOCATE THE DATA SET CATALOG ENTRY * *********************************************************************** LOCATELP DS 0H LOCATE LOOP XC LOCWORK(256),LOCWORK CLEAR FIRST HALF OF WORK XC LOCWORK+256(256),LOCWORK+256 CLEAR LAST HALF OF WORK MVC PVOLSER,ALLZEROS CLEAR VOLSER FIELD LOCATE DSNLOC LOCATE DATA SET LTR R15,R15 WAS DATA SET FOUND? BZ *+4+4+4 YES, BYPASS ERROR MESAGE LA R15,DSNLOCER NO, ADDRESS ERROR MESSAGE B PROCEMSG GO PROCESS ERROR MESSAGE MVC PVOLSER,LOCWORK+6 SAVE VOL SER SPACE *********************************************************************** * USING THE UCB LOOKUP PROCESS, LOCATE THE UCB ASSOCIATED WITH * * THE VOLUME SERIAL NUMBER RETRIEVED FORM THE LOCATE PROCESS. * *********************************************************************** UCBLKPLP DS 0H UCB LOOKUP LOOP XC UCBWORKA,UCBWORKA CLEAR FOR FIRST TIME THRU UCBLOOP DS 0H REQUEST UCB FROM SCAN ROUTINE L R15,CVTPTR A(CVT) L R15,CVTUCBSC-CVT(,R15) A(UCB SCAN ROUTINE) LA R1,UCBPARM A(UCB SCAN ROUTINE PARAMS) BASR R14,R15 CALL UCB SCAN ROUTINE LTR R15,R15 UCB ADDR RETURNED? BZ CHECKUCB YES, PROCESS THIS ONE SPACE LA R15,UCBERMSG A(VOL SER MISSING ERROR MESSAGE) B PROCEMSG GO PROCESS ERROR MESSAGE SPACE USING UCBOB,15 CHECKUCB DS 0H CHECK FOR MATCHING VOLSER L R15,UCBADDR A(UCB ADDRESS) CLC PVOLSER,UCBVOLI MATCHING VOLSER? BNE UCBLOOP NO, BUMP TO NEXT UCB SPACE OI MISCFLAG,NSHARED DEFAULT TO NON-SHARED DASD TM UCBTBYT2,UCBRR IS IT ACTUALLY SHARED? BZ *+4+4 NO, BYPASS RESET NI MISCFLAG,255-NSHARED YES, RESET NON-SHARED FLAG DROP 15 EJECT *********************************************************************** * DETERMINE WHAT TYPE OF ENQ TO USE. SYSTEM OR SYSTEMS * *********************************************************************** LA R1,MODELENQ A('SYSTEM' ENQ LIST) TM MISCFLAG,NSHARED IS DASD DEVICE SHARED? BO *+4+4 NO, USED DEFAULT ADDRESS LA R1,MODESENQ A('SYSTEMS' ENQ LIST) LA R2,DS1DSNAM A(RNAME FOR ENQ) LH R3,LDSNAME LOAD LENGTH OF DSNAME SPACE *********************************************************************** * DETERMINE IF THE DATA SET IS AVAILABLE. * *********************************************************************** NI MISCFLAG,255-ENQUEUE RESET ENQUEUE BIT ENQ (,(R2),,(R3),),MF=(E,(1)) SPACE LTR R15,R15 IS RESOURCE AVAILABLE? BZ *+4+4 YES, PROCESS DATA SET OI MISCFLAG,ENQUEUE NO, INDICATE SAME *********************************************************************** * READ THE DSCB INTO STORAGE * *********************************************************************** L R2,UCBADDR LOAD UCB ADDRESS CVAFDIR ACCESS=READ,UCB=(R2),MF=(E,CVAFREQ),BRANCH=(YES,PGM), $ BUFLIST=CVAFBUF LTR R15,R15 WAS READ SUCCESSFUL? BZ CREATDTE YES, PROCESS DSCB B CVAFPROC NO, PROCESSER ERROR RETURN EJECT *********************************************************************** * COPY DATE FIELDS INTO THE PANEL * *********************************************************************** CREATDTE SLR R15,R15 CLEAR WORK REG IC R15,DS1CREDT INSERT YEAR CVD R15,DWORD AND CONVERT TO DECIMAL OI DWORD+7,15 INSURE PRINTABLE SIGN UNPK PCREDT(2),DWORD AND MOVE TO TARGET FIELD ICM R15,B'0011',DS1CREDT+1 INSERT DAY OF YEAR CVD R15,DWORD AND CONVERT TO DECIMAL OI DWORD+7,15 INSURE PRINTABLE SIGN UNPK PCREDT+2(3),DWORD AND MOVE TO TARGET FIELD SPACE REFDATE SLR R15,R15 CLEAR WORK REG IC R15,DS1REFD INSERT YEAR CVD R15,DWORD AND CONVERT TO DECIMAL OI DWORD+7,15 INSURE PRINTABLE SIGN UNPK PREFD(2),DWORD AND MOVE TO TARGET FIELD ICM R15,B'0011',DS1REFD+1 INSERT DAY OF YEAR CVD R15,DWORD AND CONVERT TO DECIMAL OI DWORD+7,15 INSURE PRINTABLE SIGN UNPK PREFD+2(3),DWORD AND MOVE TO TARGET FIELD SPACE EXPIRDAT SLR R15,R15 CLEAR WORK REG IC R15,DS1EXPDT INSERT YEAR CVD R15,DWORD AND CONVERT TO DECIMAL OI DWORD+7,15 INSURE PRINTABLE SIGN UNPK PEXPDT(2),DWORD AND MOVE TO TARGET FIELD ICM R15,B'0011',DS1EXPDT+1 INSERT DAY OF YEAR CVD R15,DWORD AND CONVERT TO DECIMAL OI DWORD+7,15 INSURE PRINTABLE SIGN UNPK PEXPDT+2(3),DWORD AND MOVE TO TARGET FIELD EJECT *********************************************************************** * COPY DSORG INTO PANEL * *********************************************************************** MVC PDSORG,ALLZEROS CLEAR FIELD TM DS1DSORG,DS1DSGIS INDEXED SEQUENTIAL? BZ *+4+6+4 NO, TEST NEXT TYPE MVC PDSORG(2),=C'IS' YES, INDICATE SAME B TESTUNMV AND GO TEST UNMOVEABLE BIT TM DS1DSORG,DS1DSGPS PHYSICAL SEQUENTIAL? BZ *+4+6+4 NO, TEST NEXT TYPE MVC PDSORG(2),=C'PS' YES, INDICATE SAME B TESTUNMV AND GO TEST UNMOVEABLE BIT TM DS1DSORG,DS1DSGDA DIRECT ORGANIZATION? BZ *+4+6+4 NO, TEST NEXT TYPE MVC PDSORG(2),=C'DA' YES, INDICATE SAME B TESTUNMV AND GO TEST UNMOVEABLE BIT TM DS1DSORG,DS1DSGPO PARTITIONED ORGANIZATION? BZ *+4+6+4 NO, TEST NEXT TYPE MVC PDSORG(2),=C'PO' YES, INDICATE SAME B TESTUNMV AND GO TEST UNMOVEABLE BIT TM DS1DSORG+1,DS1ORGAM VSAM? BZ TESTUNMV NO, TEST NEXT TYPE MVC PDSORG(2),=C'AM' YES, INDICATE SAME TESTUNMV DS 0H TM DS1DSORG,DS1DSGU UNMOVEABLE DATA SET? BZ *+4+4 NO, BYPASS MOVE MVI PDSORG+2,C'U' YES, INDICATE SAME EJECT *********************************************************************** * COPY RECFM TO PANEL * *********************************************************************** MVC PRECFM,ALLZEROS CLEAR FIELD TM DS1RECFM,DS1RECFU UNDEFINED LENGTH RECORDS? BNO *+4+4+4 NO, CHECK NEXT TYPE MVI PRECFM,C'U' YES,INDICATE SAME B PROCLREC GO PROCESS LRECL TM DS1RECFM,DS1RECFF FIXED LENGTH RECORDS? BZ *+4+4+4 NO, CHECK NEXT TYPE MVI PRECFM,C'F' YES,INDICATE SAME B CHCKBLCK GO CHECK FOR BLOCKED TM DS1RECFM,DS1RECFV VARIABLE LENGTH RECORDS? BZ CHCKBLCK NO MVI PRECFM,C'V' YES,INDICATE SAME B CHCKBLCK GO CHECK FOR BLOCKED CHCKBLCK DS 0H LA R14,PRECFM+1 LOAD TARGET ADDRESS TM DS1RECFM,DS1RECFB BLOCKED RECORDS? BZ *+4+4+4 NO, CHECK SPANNED/STANDARD MVI 0(R14),C'B' YES, INDICATE SAME LA R14,1(,R14) AND BUMP TARGET ADDRESS TM DS1RECFM,DS1RECFS SPANNED/STANDARD? BZ *+4+4+4 NO, PROCESS PRINT CC MVI 0(R14),C'S' YES, INDICATE SAME LA R14,1(,R14) AND BUMP TARGET ADDRESS TM DS1RECFM,DS1RECFA ANSI CONTROL CHARS? BZ *+4+4+4+4 NO, PROCESS PRINT CC MVI 0(R14),C'A' YES, INDICATE SAME LA R14,1(,R14) AND BUMP TARGET ADDRESS B PROCLREC TM DS1RECFM,DS1RECMC MACHINE CONTROL CHARS? BZ *+4+4 NO, PROCESS LRECL MVI 0(R14),C'M' YES, INDICATE SAME EJECT *********************************************************************** * COPY LRECL, BLOCKSIZE, KEY LENGTH AND RKP TO PANEL * *********************************************************************** PROCLREC DS 0H SLR R15,R15 CLEAR WORK REGISTER ICM R15,B'0011',DS1LRECL LOAD THE LRECL CVD R15,DWORD AND CONVERT TO DECIMAL OI DWORD+7,15 INSURE PROPER SIGN UNPK PLRECL,DWORD AND MOVE TO TARGET SPACE ICM R15,B'0011',DS1BLKL LOAD THE BLOCK SIZE CVD R15,DWORD AND CONVERT TO DECIMAL OI DWORD+7,15 INSURE PROPER SIGN UNPK PBLKL,DWORD AND MOVE TO TARGET FIELD SPACE SLR R15,R15 CLEAR WORK REGISTER IC R15,DS1KEYL LOAD THE KEY LENGTH CVD R15,DWORD AND CONVERT TO DECIMAL OI DWORD+7,15 INSURE PROPER SIGN UNPK PKEYL,DWORD AND MOVE TO TARGET FIELD SPACE ICM R15,B'0011',DS1RKP LOAD THE RELATIVE KEY POSITION CVD R15,DWORD AND CONVERT TO DECIMAL OI DWORD+7,15 INSURE PROPER SIGN UNPK PRKP,DWORD AND MOVE TO TARGET FIELD SPACE *********************************************************************** * COPY LAST USED TRACK AND BLOCK INTO PANEL * *********************************************************************** ICM R15,B'1110',DS1LSTAR LOAD LSTAR INTO REG LA R1,6 BYTES TO PROCESS LA R2,PLSTAR A(TARGET FIELD) LSTARLP DS 0H SLR R14,R14 CLEAR WORK REG SLDL R14,4 SHIFT 4 BITS INTO REG14 STC R14,0(R2) AND SAVE INTO TARGET LA R2,1(,R2) BUMP TARGET ADDRESS BCT R1,LSTARLP LOOP FOR NEXT FOUR BITS TR PLSTAR,TRTAB TRANSLATE INTO PRINTABLE CHARS EJECT *********************************************************************** * COPY TRACK BALANCE INTO PANEL * *********************************************************************** ICM R15,B'1100',DS1TRBAL LOAD LSTAR INTO REG LA R1,4 BYTES TO PROCESS LA R2,PTRBAL A(TARGET FIELD) LTRBAL DS 0H SLR R14,R14 CLEAR WORK REG SLDL R14,4 SHIFT 4 BITS INTO REG14 STC R14,0(R2) AND SAVE INTO TARGET LA R2,1(,R2) BUMP TARGET ADDRESS BCT R1,LTRBAL LOOP FOR NEXT FOUR BITS TR PTRBAL,TRTAB TRANSLATE INTO PRINTABLE CHARS SPACE *********************************************************************** * COPY DATA SET INDICATORS INTO PANEL * *********************************************************************** ICM R15,B'1000',DS1DSIND LOAD DS INDICATORS LA R1,2 BYTES TO PROCESS LA R2,PDSIND A(TARGET FIELD) LDSIND DS 0H SLR R14,R14 CLEAR WORK REG SLDL R14,4 SHIFT 4 BITS INTO REG14 STC R14,0(R2) AND SAVE INTO TARGET LA R2,1(,R2) BUMP TARGET ADDRESS BCT R1,LDSIND LOOP FOR NEXT FOUR BITS TR PDSIND,TRTAB TRANSLATE INTO PRINTABLE CHARS EJECT *********************************************************************** * COPY SECONDARY ALLOCATION INFO INTO PANEL * *********************************************************************** TM DS1SCAL1,DS1CYL IS IT CYLINDER ALLOCATION? BNO *+4+4+4 NO, CHECK NEXT TYPE MVI PSCAL1,C'C' YES, INDICATE SAME B SCALLAMT PROCESS SECONDARY AMOUNT TM DS1SCAL1,DS1TRK IS IT TRACK ALLOCATION? BNO *+4+4+4 NO, CHECK NEXT TYPE MVI PSCAL1,C'T' YES, INDICATE SAME B SCALLAMT PROCESS SECONDARY AMOUNT TM DS1SCAL1,DS1AVR IS IT BLOCK ALLOCATION? BNO *+4+4+4 NO, CHECK NEXT TYPE MVI PSCAL1,C'B' YES, INDICATE SAME B SCALLAMT PROCESS SECONDARY AMOUNT TM DS1SCAL1,DS1AVRND IS IT BLOCK ROUND ALLOC? BNO *+4+4+4 NO, CHECK NEXT TYPE MVI PSCAL1,C'R' YES, INDICATE SAME B SCALLAMT PROCESS SECONDARY AMOUNT TM DS1SCAL1,255 IS IT ABSOLUTE ALLOCATION? BNZ SCALLAMT NO, PROCESS SECONDARY AMOUNT MVI PSCAL1,C'A' YES, INDICATE SAME SPACE SCALLAMT DS 0H SLR R15,R15 CLEAR WORK REG ICM R15,B'0111',DS1SCAL3 INSERT SECONDARY AMOUNT CVD R15,DWORD AND CONVERT TO DECIMAL OI DWORD+7,15 INSURE PROPER SIGN UNPK PSCAL3,DWORD AND COPY INTO TARGET AREA TM MISCFLAG,ENQUEUE IS DATA SET AVAILABLE? BZ TPUTPANL YES, PROCESS IT LA R15,ENQERMSG NO, INFORM TERMINAL OPER SPACE *********************************************************************** * COPY ERROR MESSAGE ONTO PANEL - R15 ADDRESSES THE ERROR MSG * *********************************************************************** PROCEMSG DS 0H POS, MOVE MESSAGE TO PANEL MVC PERRMSG,ALLBLANK CLEAR TARGET FIELD LA R14,PERRMSG A(TARGET FOR ERROR MESSAGE) LA R2,L'PERRMSG LENGTH OF SAME LH R1,0(R15) LOAD LENGTH OF MESSAGE TO DISPLY CR R1,R2 GREATER THAN MAXIMUM? BNH *+4+2 NO, CONTINUE LR R1,R2 YES, LOAD MAXIMUM LENGTH SR R2,R1 COMPUTE REMAINDER BNP *+4+4 BYPASS NEXT TWO INSTRS IF NEG SRL R2,1 DIVIDE BY TWO LA R14,0(R2,R14) CENTER ERROR MESSAGE BCTR R1,00 DECREMENT FOR EXECUTE EX R1,MVCERMSG MOVE ERROR MESSAGE EJECT *********************************************************************** * DISPLAY PANEL * *********************************************************************** TPUTPANL DS 0H LA R0,LPDSCBL A(LENGTH OF PANEL) LA R1,DSCBPANL A(DSCB PANEL) TPUT (1),(0),FULLSCR WRITE PANEL TO TERMINAL SPACE *********************************************************************** * RETRIEVE USER'S INPUT * *********************************************************************** XC INPUT(256),INPUT CLEAR FIRST HALF OF WORK XC INPUT+256(256),INPUT+256 CLEAR LAST HALF OF WORK LA R0,L'INPUT A(LENGTH OF INPUT AREA) LA R1,INPUT A(INPUT AREA) TGET (1),(0),ASIS GET INPUT FROM TERMINAL SPACE CLI INPUT,PA2KEY REDISPLAY REQUESTED? BE TPUTPANL YES, REDISPLAY SPACE CLI INPUT,PFKEY03 TERMINATION REQUESTED? BE ENDDSNS YES, TERMINATE EXECUTION CLI INPUT,PFKEY15 TERMINATION REQUESTED? BE ENDDSNS YES, TERMINATE EXECUTION SPACE MVC DSCBPCSR,DEFCSRAD RESET IC TO DEFAULT CUSOR ADDR MVC PERRMSG,ALLBLANK CLEAR ERROR MESSAGE LR R5,R1 SAVE LENGTH OF TGET DATA LA R4,INPUT PRELOAD DATA ADDRESS NI MISCFLAG,NSHARED+ENQUEUE RESET ALL BUT REQ'D BITS EJECT *********************************************************************** * PROCESS INPUT KEYED IN BY USER * * INPUT REGS: * * REG 04 CONTAINS THE CURRENT ADDR OF BUFFER INPUT * * REG 05 CONTAINS THE REMAINING LENGTH OF BUFFER INPUT * * OUTPUT REGS: * * REG 00 CONTAINS THE ACTUAL LENGTH OF KEYED INPUT DATA * * REG 01 CONTAINS THE ADDRESS OF KEYED INPUT DATA * * REG 02 CONTAINS THE LENGTH -1 OF KEYED INPUT DATA * * REG 04 CONTAINS THE CURRENT ADDR OF BUFFER INPUT * * REG 05 CONTAINS THE REMAINING LENGTH OF BUFFER INPUT * * REG 06 CONTAINS THE ADDR OF THE MATCHING BUFFTAB ENTRY * * REG 07 CONTAINS THE LENGTH OF A BUFFTAB ENTRY * *********************************************************************** SPACE 2 *********************************************************************** * LOCATE NEXT INPUT FIELD, LENGTH AND MATCHING TABLE ENTRY * *********************************************************************** INPUT000 DS 0H HERE TO PROCESS INPUT DATA LA R6,PDSCBL-2 A(HALFWORD COUNT OF ENTRIES) LA R7,PDSCBLEL A(ENTRY LENGTH) LA R15,TABLE000 A(INPUT DEPROCESSOR) BASR R14,R15 PROCESS INPUT DATA B INPUT200 ALL DATA PROCESSED SPACE LTR R6,R6 MATCHING ENTRY? BNZ INPUT100 YES, PROCESS IT * POSSIBLE ERROR AT THIS POINT WHAT TO DO, WHAT TO DO? B INPUT000 NO BUFFTAB ENTRY, PROCESS NEXT SPACE *********************************************************************** * RESET ATTRIBUTE BYTE TO NORMAL INTENSITY, UNPROTECTED * *********************************************************************** INPUT100 DS 0H HERE TO PROCESS INPUT DATA LH R15,2(,R6) LOAD FIELD OFFSET LA R15,DSCBPANL(R15) AND ADDRESS FIELD BCTR R15,00 BACK UP TO THE ATTRIBUTE NI 0(R15),64 AND OFF HIGHLIGHT ATTRIBUTE SPACE *********************************************************************** * LOAD A(ROUTINE) TO PROCESS DATA AND BASR. (IF NOT ERASE INPUT) * *********************************************************************** LTR R0,R0 ERASE EOF INPUT FIELD? BNP INPUT000 YES, GET NEXT FIELD EX R2,INPUTOC INSURE UPPER CASE LH R15,6(,R6) Y(OFFSET INTO ROUTINE TBL) SLL R15,2 MULTIPLY BY 4 L R15,TABTABLE(R15) A(ROUTINE TO DEPROCESS INPUT) BASR R14,R15 AND CALL SAME B INPUT000 SPACE 2 INPUTOC OC 0(0,R1),ALLBLANK CONVERT TO UPPER CASE EJECT *********************************************************************** * TEST FOR MODIFIED FILED(S) AND PROCESS ACCORDINGLY * *********************************************************************** INPUT200 DS 0H HERE AFTER END-OF-INPUT TM MISCFLAG,IPTDSNAM+IPTVOL EITHER FIELDS MODIFIED? BZ INPUT300 NO, CHECK FOR MODIFIED DSCB BAS R10,RSETATTR YES, RESET ALL ATTRIBUTES BAS R10,CVAFRLSE YES, RELEASE CVAF BUFFERS TM MISCFLAG,IPTVOL VOLUME SERIAL MODIFIED? BO UCBLKPLP YES, GO LOOKUP UCB TM MISCFLAG,IPTDSNAM DSNAME MODIFIED? BO LOCATELP YES, GO LOCATED DATA SET INPUT300 DS 0H TM MISCFLAG,IPTERROR WAS THERE AN ERROR? BO TPUTPANL GO DISPLAY A MESSAGE TM MISCFLAG,DSCBMOD WAS THE DSCB MODIFIED? LA R15,WHATTODO NO, PROMPT TERM OP FOR INPUT BZ PROCEMSG GO DISPLAY A MESSAGE *********************************************************************** * REWEITE THE DSCB INTO THE VTOC * *********************************************************************** CVAFDIR ACCESS=WRITE,MF=(E,CVAFREQ),BRANCH=(YES,PGM) LTR R15,R15 WAS WRITE SUCCESSFUL? BNZ CVAFPROC NO, GO LOAD IN ERROR MESSAGE LA R15,DSCBMSG1 YES, ADDRESS SUCCESSFUL MSG B PROCEMSG REDISPLAY PANEL EJECT ENDDSNS DS 0H *********************************************************************** * TERMINATE FULL SCREEN PROCESSING * *********************************************************************** STLINENO LINE=1 SET NEXT LINE TO 1 SPACE STFSMODE OFF RESET FROM FULL SCREEN PROCESS SPACE *********************************************************************** * RELEASE CVAF BUFFERS * *********************************************************************** BAS R10,CVAFRLSE RELEASE CVAF BUFFERS SPACE *********************************************************************** * TERMINATE PROGRAM * *********************************************************************** L R13,4(,R13) RESTORE BACKWARD POINTER RETURN (14,12),T,RC=0 SPACE MVCERMSG MVC 0(0,R14),2(R15) EXECUTED MOVE EJECT *********************************************************************** * THIS ROUTINE WILL PROCESS A MODIFIED DATA SET NAME. * * NOTE: IF A DATA SET NAME IS ENTERED BY THE USER, ALL REMAINING * * INPUT, EXCEPT FOR VOLSER, WILL BE IGNORED. * *********************************************************************** IDSNAME DS 0H OI MISCFLAG,IPTDSNAM INDICATE DSN HAS BEEN INPUT MVC PDSNAME,ALLZEROS MOVE IN ALL BLANKS MVC DS1DSNAM,ALLBLANK MOVE IN ALL BLANKS LA R10,PDSNAME A(PANEL DSNAME) LA R9,DS1DSNAM A(DSCB DSNAME) CLI 0(R1),C'''' DOES DSN BEGIN WITH A QUOTE BNE IDSN100 NO, DO NOT PROCESS QUOTES EX R2,IDSNMVC2 MOVE DSN INTO PANEL LA R1,1(,R1) YES, BYPASS FIRST QUOTE BCTR R2,00 DECREMENT FOR FIRST QUOTE STH R2,LDSNAME SAVE NEW LENGTH OF DSNAME BCTR R2,00 DECREMENT FOR LAST QUOTE EX R2,IDSNMVC3 MOVE DSN INTO DSCB BR R14 IDSNMVC2 MVC 0(0,R10),0(R1) MOVE IN DATA SET NAME IDSNMVC3 MVC 0(0,R9),0(R1) MOVE IN DATA SET NAME IDSNMVC4 MVC 0(0,R10),USERIDI MOVE IN USERID IDSNMVC5 MVC 0(0,R9),USERIDI MOVE IN USERID SPACE IDSN100 DS 0H SLR R8,R8 CLEAR WORK REG IC R8,USERIDL AL1(LENGTH OF USERID) SPACE LA R15,1(,R8) USERID + DELIMITER AR R15,R0 + LENGTH OF DSNAME STH R15,LDSNAME SAVE COMPUTED LENGTH OF DSNAME CH R15,=H'46' IS DSNAME GT FIELD LENGTH? LA R15,DSNLNGER PROVIDE FOR ERROR MSG BH FLDERROR YES, GENERATE ERROR MESSAGE SPACE BCTR R8,0 DECREMENT FOR EXECUTE MVI 0(R10),C'''' MOVE IN A QUOTE LA R10,1(,R10) AND ADJUST FOR SAME EX R8,IDSNMVC5 MOVE USERID TO DSNAME EX R8,IDSNMVC4 MOVE USERID TO DSNAME LA R9,1(R8,R9) AND ADJUST FOR SAME LA R10,1(R8,R10) AND ADJUST FOR SAME MVI 0(R9),C'.' MOVE IN A DELIMITER MVI 0(R10),C'.' MOVE IN A DELIMITER LA R9,1(,R9) AND ADJUST FOR SAME LA R10,1(,R10) AND ADJUST FOR SAME EX R2,IDSNMVC2 MOVE DSN INTO PANEL EX R2,IDSNMVC3 MOVE DSN INTO DSCB LA R10,1(R2,R10) AND ADJUST FOR SAME MVI 0(R10),C'''' MOVE IN A QUOTE BR R14 EJECT *********************************************************************** * THIS ROUTINE WILL PROCESS A VOLUME SERIAL NUMBER. * * NOTE: IF A VOLUME SERIAL IS ENTERED BY THE USER, ALL REMAINING * * INPUT, EXCEPT FOR DATA SET NAME, WILL BE IGNORED. * *********************************************************************** IVOLSER DS 0H OI MISCFLAG,IPTVOL INDICATE VOLSER ENTERED MVC PVOLSER,ALLZEROS CLEAR TARGET FIELD EX R2,IVOLMVC AND MOVE IN VOLSER BR R14 IVOLMVC MVC PVOLSER(0),0(R1) EXECUTED MVC SPACE *********************************************************************** * THIS ROUTINE WILL PROCESS A MODIFIED CREATION DATE. * *********************************************************************** ICREDT DS 0H MVC PCREDT,ALLZEROS CLEAR TARGET FIELD EX R2,ICREMVC1 MOVE DATA TO PANEL EX R2,NUMBRTRT TEST FOR VALID NUMERICS LA R15,NUMBERER A(NUMERIC TEST ERROR) BNZ FLDERROR IF NOT, REDISPLAY SCREEN CH R0,=H'5' CORRECT LENGTH? LA R15,LNGTHER1 A(FIELD LENGTH ERROR) BNE FLDERROR NO, REDISPLAY SCREEN PACK DWORD,0(2,R1) PACK YEAR CVB R15,DWORD CONVERT TO BINARY STC R15,DS1CREDT AND SAVE IN TARGET FIELD PACK DWORD,2(3,R1) PACK YEAR CVB R15,DWORD CONVERT TO BINARY STCM R15,B'0011',DS1CREDT+1 AND SAVE IN TARGET FIELD OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED EX R2,NUMBPACK PACK CREATION DATE UNPK PCREDT,DWORD AND UNPACK INTO FIELD BR R14 RETURN TO CALLER ICREMVC1 MVC PCREDT(0),0(R1) EXECUTED MVC EJECT *********************************************************************** * THIS ROUTINE WILL PROCESS A MODIFIED REFERENCE DATE. * *********************************************************************** IREFD DS 0H MVC PREFD,ALLZEROS CLEAR TARGET FIELD EX R2,IREFMVC1 MOVE DATA TO PANEL EX R2,NUMBRTRT TEST FOR VALID NUMERICS LA R15,NUMBERER A(NUMERIC TEST ERROR) BNZ FLDERROR IF NOT, REDISPLAY SCREEN CH R0,=H'5' CORRECT LENGTH? LA R15,LNGTHER1 A(FIELD LENGTH ERROR) BNE FLDERROR NO, REDISPLAY SCREEN PACK DWORD,0(2,R1) PACK YEAR CVB R15,DWORD CONVERT TO BINARY STC R15,DS1REFD AND SAVE IN TARGET FIELD PACK DWORD,2(3,R1) PACK YEAR CVB R15,DWORD CONVERT TO BINARY STCM R15,B'0011',DS1REFD+1 AND SAVE IN TARGET FIELD OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED EX R2,NUMBPACK PACK REFERENCE DATE UNPK PREFD,DWORD AND UNPACK INTO FIELD BR R14 RETURN TO CALLER IREFMVC1 MVC PREFD(0),0(R1) EXECUTED MVC SPACE *********************************************************************** * THIS ROUTINE WILL PROCESS A MODIFIED EXPIRATION DATE. * *********************************************************************** IEXPDT DS 0H MVC PEXPDT,ALLZEROS CLEAR TARGET FIELD EX R2,IEXPMVC1 MOVE DATA TO PANEL EX R2,NUMBRTRT TEST FOR VALID NUMERICS LA R15,NUMBERER A(NUMERIC TEST ERROR) BNZ FLDERROR IF NOT, REDISPLAY SCREEN CH R0,=H'5' CORRECT LENGTH? LA R15,LNGTHER1 A(FIELD LENGTH ERROR) BNE FLDERROR NO, REDISPLAY SCREEN PACK DWORD,0(2,R1) PACK YEAR CVB R15,DWORD CONVERT TO BINARY STC R15,DS1EXPDT AND SAVE IN TARGET FIELD PACK DWORD,2(3,R1) PACK YEAR CVB R15,DWORD CONVERT TO BINARY STCM R15,B'0011',DS1EXPDT+1 AND SAVE IN TARGET FIELD OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED EX R2,NUMBPACK PACK EXPIRATION DATE UNPK PEXPDT,DWORD AND UNPACK INTO FIELD BR R14 RETURN TO CALLER IEXPMVC1 MVC PEXPDT(0),0(R1) EXECUTED MVC EJECT *********************************************************************** * THIS ROUTINE WILL PROCESS A MODIFIED DATA SET ORGINAZATION. * *********************************************************************** IDSORG DS 0H MVC PDSORG,ALLZEROS CLEAR TARGET FIELD EX R2,IDSOMVC1 MOVE INTO PANEL CH R0,=H'2' CORRECT LENGTH? LA R15,LNGTHER1 A(FIELD LENGTH ERROR) BL FLDERROR NO, REDISPLAY SCREEN LA R8,DSORGTAB A(DSORG TABLE) LA R9,DSORGCNT A(ENTRY COUNT OF SAME) IDSORG00 DS 0H CLC 0(2,R8),0(R1) COMPARE TABLE ENTRY TO INPUT BE IDSORG10 IF EQUAL, PROCESS LA R8,DSORGLNG(,R8) BUMP TO NEXT ENTRY BCT R9,IDSORG00 AND GO CHECK THAT ONE LA R15,DSORGER1 A(DSORG ERROR MESSAGE) B FLDERROR IDSORG10 DS 0H XC FWORD,FWORD CLEAR WORK AREA CH R0,=H'3' WAS UNMOVABLE SPECIFIED? BNE IDSORG20 NO, BYPASS IT THEN CLI 2(R1),64 IS THIS A BLANK BE IDSORG20 YES, NOT UNMOVEABLE CLI 2(R1),C'U' IS IT UNMOVEABLE? LA R15,DSORGER1 NO, INDICATE BAD DSORG BNE FLDERROR AND REDISPLAY SCREEN OI FWORD,DS1DSGU INDICATE UNMOVEABLE IDSORG20 DS 0H XC DS1DSORG,DS1DSORG CLEAR DSORG FIELD OC DS1DSORG,2(R8) MOVE IN NEW DSORG OC DS1DSORG,FWORD AND ADD 'U', IF SUPPLIED OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED BR R14 IDSOMVC1 MVC PDSORG(0),0(R1) EXECUTED MOVE EJECT *********************************************************************** * THIS ROUTINE WILL PROCESS A MODIFIED RECORDING FORMAT. * *********************************************************************** IRECFM DS 0H MVC PRECFM,ALLZEROS CLEAR TARGET FIELD EX R2,IRECMVC1 MOVE TO PANEL LR R10,R0 A(COUNT OF CHARS IN INPUT) XC FWORD,FWORD CLEAR WORK FIELD IRECFM00 DS 0H LA R8,RECFMTAB A(RECFM TABLE) LA R9,RECFMCNT A(ENTRY COUNT OF SAME) IRECFM05 DS 0H CLI 0(R1),64 IS THIS A BLANK? BE IRECFM25 YES, BYPASS IT THEN SPACE IRECFM10 DS 0H CLC 0(1,R8),0(R1) MATCHING ENTRY? BE IRECFM20 YES, PROCESS LA R8,RECFMLNG(,R8) NO, BUMP TO NEXT ENTRY BCT R9,IRECFM10 AND GO PROCESS IT LA R15,RECFMER1 A(INVALID RECFM INPUT) B FLDERROR AND GO PROCESS ERROR IRECFM20 DS 0H OC FWORD(1),1(R8) SAVE THIS BIT IRECFM25 DS 0H LA R1,1(,R1) BUMP TO NEXT BYTE BCT R10,IRECFM00 PROCESS NEXT BYTE OF INPUT SPACE LA R15,RECFMER1 PRELOAD INVALID RECFM INPUT MSG TM FWORD,DS1RECFU WAS UNDEFINED SPECIFID? BNO IRECFM30 NO, BYPASS NEXT TEST TM FWORD,255-DS1RECFU-DS1RECFA-DS1RECMC ANY OTHERS? BNZ FLDERROR YES, ERRONOUS INPUT IRECFM30 DS 0H OC FWORD(1),FWORD TEST FOR ANY INPUT BZ FLDERROR IF ZERO, INDICATE ERROR SPACE XC DS1RECFM,DS1RECFM RESET RECORDING FORMAT OC DS1RECFM,FWORD AND SET NEW VALUE OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED BR R14 RETURN TO CALLER IRECMVC1 MVC PRECFM(0),0(R1) EXECUTED MVC EJECT *********************************************************************** * THIS ROUTINE WILL PROCESS A MODIFIED LOGICAL RECORD LENGTH. * *********************************************************************** ILRECL DS 0H MVC PLRECL,ALLZEROS CLEAR TARGET FIELD EX R2,ILREMVC1 MOVE DATA TO PANEL EX R2,NUMBRTRT TEST FOR VALID NUMERICS LA R15,NUMBERER A(NUMERIC TEST ERROR) BNZ FLDERROR IF NOT, REDISPLAY SCREEN EX R2,NUMBPACK PACK LRECL UNPK PLRECL,DWORD AND UNPACK INTO FIELD CVB R15,DWORD CONVERT TO BINARY STCM R15,B'0011',DS1LRECL AND UPDATE DSCB OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED BR R14 RETURN TO CALLER ILREMVC1 MVC PLRECL(0),0(R1) EXECUTED MVC SPACE *********************************************************************** * THIS ROUTINE WILL PROCESS A MODIFIED BLOCK SIZE. * *********************************************************************** IBLKL DS 0H MVC PBLKL,ALLZEROS CLEAR TARGET FIELD EX R2,IBLKMVC1 MOVE DATA TO PANEL EX R2,NUMBRTRT TEST FOR VALID NUMERICS LA R15,NUMBERER A(NUMERIC TEST ERROR) BNZ FLDERROR IF NOT, REDISPLAY SCREEN EX R2,NUMBPACK PACK BLKL UNPK PBLKL,DWORD AND UNPACK INTO FIELD CVB R15,DWORD CONVERT TO BINARY STCM R15,B'0011',DS1BLKL AND UPDATE DSCB OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED BR R14 RETURN TO CALLER IBLKMVC1 MVC PBLKL(0),0(R1) EXECUTED MVC EJECT *********************************************************************** * THIS ROUTINE WILL PROCESS A MODIFIED KEY LENGTH. * *********************************************************************** IKEYL DS 0H MVC PKEYL,ALLZEROS CLEAR TARGET FIELD EX R2,IKEYMVC1 MOVE DATA TO PANEL EX R2,NUMBRTRT TEST FOR VALID NUMERICS LA R15,NUMBERER A(NUMERIC TEST ERROR) BNZ FLDERROR IF NOT, REDISPLAY SCREEN EX R2,NUMBPACK PACK KEYL UNPK PKEYL,DWORD AND UNPACK INTO FIELD CVB R15,DWORD CONVERT TO BINARY STC R15,DS1KEYL AND UPDATE DSCB OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED BR R14 RETURN TO CALLER IKEYMVC1 MVC PKEYL(0),0(R1) EXECUTED MVC SPACE *********************************************************************** * THIS ROUTINE WILL PROCESS A MODIFIED RELATIVE KEY POSITION. * *********************************************************************** IRKP DS 0H MVC PRKP,ALLZEROS CLEAR TARGET FIELD EX R2,IRKPMVC1 MOVE DATA TO PANEL EX R2,NUMBRTRT TEST FOR VALID NUMERICS LA R15,NUMBERER A(NUMERIC TEST ERROR) BNZ FLDERROR IF NOT, REDISPLAY SCREEN EX R2,NUMBPACK PACK RKP UNPK PRKP,DWORD AND UNPACK INTO FIELD CVB R15,DWORD CONVERT TO BINARY STCM R15,B'0011',DS1RKP AND UPDATE DSCB OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED BR R14 RETURN TO CALLER IRKPMVC1 MVC PRKP(0),0(R1) EXECUTED MVC EJECT *********************************************************************** * THIS ROUTINE WILL PROCESS A MODIFIED LSTAR. * *********************************************************************** ILSTAR DS 0H MVC PLSTAR,ALLZEROS CLERA TARGET FIELD EX R2,ILSTMVC1 MOVE SAME TO PANEL EX R2,NUMHXTRT TEST FOR VALID HEX DIGITS LA R15,HEXER IF INVALID, LOAD ERROR MSG BNZ FLDERROR AND INFORM USER BAS R10,CONV2HEX CONVERT TO HEXIDECIMAL STCM R3,B'0111',DS1LSTAR UPDATE DSCB OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED BR R14 RETURN TO CALLER ILSTMVC1 MVC PLSTAR(0),0(R1) EXECUTED MOVE SPACE *********************************************************************** * THIS ROUTINE WILL PROCESS A MODIFIED TRACK BALANCE. * *********************************************************************** ITRBAL DS 0H MVC PTRBAL,ALLZEROS CLERA TARGET FIELD EX R2,ITRBMVC1 MOVE SAME TO PANEL EX R2,NUMBRTRT TEST FOR VALID NUMERICS LA R15,NUMBERER IF INVALID, LOAD ERROR MSG BNZ FLDERROR AND INFORM USER EX R2,NUMBPACK PACK RKP UNPK PTRBAL,DWORD AND UNPACK INTO FIELD CVB R15,DWORD CONVERT TO BINARY STCM R3,B'0011',DS1TRBAL UPDATE DSCB OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED BR R14 RETURN TO CALLER ITRBMVC1 MVC PTRBAL(0),0(R1) EXECUTED MOVE SPACE *********************************************************************** * THIS ROUTINE WILL PROCESS A MODIFIED DSIND. * *********************************************************************** IDSIND DS 0H MVC PDSIND,ALLZEROS CLERA TARGET FIELD EX R2,IDSIMVC1 MOVE SAME TO PANEL EX R2,NUMHXTRT TEST FOR VALID HEX DIGITS LA R15,HEXER IF INVALID, LOAD ERROR MSG BNZ FLDERROR AND INFORM USER BAS R10,CONV2HEX CONVERT TO HEXIDECIMAL STC R3,DS1DSIND UPDATE DSCB OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED BR R14 RETURN TO CALLER IDSIMVC1 MVC PDSIND(0),0(R1) EXECUTED MOVE EJECT *********************************************************************** * THIS ROUTINE WILL PROCESS A SECONDARY ALLOC TYPE. * *********************************************************************** ISCALL1 DS 0H MVC PSCAL1,ALLZEROS CLEAR TARGET FIELD EX R2,ISCAMVC1 MOVE TO PANEL LA R8,SCAL1TAB A(TABLE OC ACCEPTABLE VALUES) LA R9,SCAL1CNT A(COUNT OF SAME) ISCALL00 DS 0H CLC 0(1,R8),0(R1) ENTRIES EQUAL?? BE ISCALL10 IF EQUAL, PROCESS LA R8,SCAL1LNG(,R8) NO, BUMP TO NEXT ENTRY BCT R9,ISCALL00 PROCESS THIS ENTRY LA R15,SCALLER A(ADDRESS ERROR MESSABE) B FLDERROR ISCALL10 DS 0H XC DS1SCAL1,DS1SCAL1 CLEAR ALLOCATION TYPE OC DS1SCAL1,1(R8) AND MOVE IN NEW TYPE OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED BR R14 RETURN TO CALLER ISCAMVC1 MVC PSCAL1(0),0(R1) EXECUTED MVC SPACE *********************************************************************** * THIS ROUTINE WILL PROCESS A SECONDARY ALLOC AMOUNT. * *********************************************************************** ISCALL3 DS 0H MVC PSCAL3,ALLZEROS CLEAR TARGET FIELD EX R2,ISCAMVC2 MOVE DATA TO PANEL EX R2,NUMBRTRT TEST FOR VALID NUMERICS LA R15,NUMBERER A(NUMERIC TEST ERROR) BNZ FLDERROR IF NOT, REDISPLAY SCREEN EX R2,NUMBPACK PACK SCALL3 UNPK PSCAL3,DWORD AND UNPACK INTO FIELD CVB R15,DWORD CONVERT TO BINARY STCM R15,B'0111',DS1SCAL3 AND UPDATE DSCB OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED BR R14 RETURN TO CALLER ISCAMVC2 MVC PSCAL3(0),0(R1) EXECUTED MVC EJECT *********************************************************************** * CHAR TO HEX CONVERSION ROUTINE * *********************************************************************** CONV2HEX DS 0H LR R8,R1 LOAD ADDRESS OF SOURCE VALUE LR R9,R0 LOAD LOOP COUNTER SLR R3,R3 CLEAR TARGET REGISTER LOOP2BIN DS 0H SLL R3,4 MAKE ROOM FOR NEXT NIBBLE SLR R15,R15 CLEAR WORK REG IC R15,0(0,R8) INSERT A BYTE N R15,=F'15' TURN OFF ALL BUT LAST NIBBLE TM 0(R8),240 IS IT NUMERIC BO *+4+4 YES, BYPASS ADD HALFWORD AH R15,=H'9' ADD 9 IF NOT A NUMBER OR R3,R15 STORE IN RESULT LA R8,1(0,R8) NEXT TARGET BYTE BCT R9,LOOP2BIN PROCEED THROUGH FULLWORD BR R10 RETURN TO CALLER SPACE *********************************************************************** * FIELD ERROR PROCESSING ROUTINE * * ON INPUT: R15 = A(ERROR MESSAGE AREA) * * ALL OTHER REGISTERS ARE THE SAME AS UPON INPUT TO A * * FIELD DE-PROCESSING ROUTINE. * *********************************************************************** FLDERROR DS 0H TM MISCFLAG,IPTERROR MORE THAN ONE ERROR? BO FLDERR10 YES, BYPASS MESSAGE MOVE OI MISCFLAG,IPTERROR NO, SET ERROR FLAG MVC DSCBPCSR,0(R6) ALTER THE IC BUFF ADDR MVC PERRMSG,ALLBLANK CLEAR TARGET FIELD LA R10,PERRMSG A(TARGET FOR ERROR MESSAGE) LA R8,L'PERRMSG LENGTH OF SAME LH R9,0(R15) LOAD LENGTH OF MESSAGE TO DISPLY CR R9,R8 GREATER THAN MAXIMUM? BNH *+4+2 NO, CONTINUE LR R9,R8 YES, LOAD MAXIMUM LENGTH SR R8,R9 COMPUTE REMAINDER BNP *+4+4 BYPASS NEXT TWO INSTRS IF NEG SRL R8,1 DIVIDE BY TWO LA R10,0(R8,R10) CENTER ERROR MESSAGE BCTR R9,00 DECREMENT FOR EXECUTE EX R9,FLDMVC1 MOVE ERROR MESSAGE SPACE FLDERR10 DS 0H LH R8,02(,R6) LOAD OFFSET TO FIELD LA R8,DSCBPANL(R8) AND ADDRESS ACTUAL FIELD BCTR R8,00 BACK UP TO ATTRIBUTE BYTE OI 0(R8),X'89' TURN ON HIGH-INTENS + MDT BR R14 RETURN TO MAINLINE TITLE ' TABLE000 -- PROCESS TGET INPUT BUFFER' PUSH USING DROP R11 DROP PREVIOUS BASE REGISTER *********************************************************************** * * * THIS ROUTINE WILL PROCESS THE INPUT FROM AN 'ASIS' TGET * * AGAINST A TABLE OF SBA'S. THE OUTPUT IS THE ADDRESS AND LENGTH * * OF THE INPUT FIELD AND THE ADDRESS OF THE ENTRY IN THE SBA * * TABLE WITH THE MATCHING SBA. * * NOTE: IF, BY CHANCE, A FIELD IS FOUND IN THE INPUT STREAM * * THAT DOES NOT HAVE A MATCHING TABLE ENTRY, REG 06 IS RETURNED * * EMPTY, BUT THE FIELD ADDRESS AND LENGTHS ARE RETURNED TO THE USER.* * * * INPUT REGISTERS * * R4 - NEXT BYTE TO PROCESS * * R5 - REMAINING LENGTH OF DATA * * R6 - BUFFTAB LIST (FROM $FLD GENERATION) * * R7 - LENGTH OF EACH BUFFER TABLE ENTRY * * * * OUTPUT REGISTERS * * R0 - ACTUAL LENGTH OF INPUT/ZERO IF 'ERASE EOF' OF FIELD * * R1 - ADDRESS OF FIELD IN INPUT * * R2 - LENGTH - 1 OF FIELD IN INPUT * * R4 - NEXT BYTE TO PROCESS * * R5 - REMAINING LENGTH OF DATA * * R6 - MATCHING BUFFTAB ENTRY OR ZERO * * R7 - LENGTH OF EACH BUFFER TABLE ENTRY * * * *********************************************************************** SPACE TABLE000 DS 0H HERE TO PROCESS TGET INPUT USING TABLE000,R15 LTR R5,R5 ANY THING LEFT TO CHECK? BZ TABLE050 NO, RETURN TO CALLER SPACE TABLE025 DS 0H CHECK FOR SBA IN INPUT CLI 0(R4),X'11' A START FIELD CHARACTER? BE TABLE100 YES, GO PROCESS INPUT FIELD LA R4,1(,R4) NO, BUMP AROUND BCT R5,TABLE025 GO TEST NEXT BYTE TABLE050 DS 0H RETURN TO USER WITH NOTHING SLR R6,R6 INDICATE NO DATA TO PROCESS BR R14 RETURN TO CALLER SPACE TABLE100 DS 0H LA R4,1(,R4) BUMP AROUND SBA BCT R5,*+4+4 DECREMENT AND BRANCH AROUND B TABLE050 THIS INSTR IF NOT ZERO LH R2,0(R6) LOAD NUMBER OF ENTRIES IN TABLE LA R6,2(,R6) BUMP TO START OF TABLE EJECT TABLE200 DS 0H CLC 0(2,R4),0(R6) COMPARE SBA TO TABLE ENTRY BE TABLE300 BRANCH OUT IF FOUND LA R6,0(R7,R6) BUMP TO NEXT TABLE ENTRY BCT R2,TABLE200 GO CHECK NEXT ENTRY SLR R6,R6 INDICATE NO MATCH SPACE TABLE300 DS 0H A MATCHING TABLE ENTRY (MAYBE) LA R4,2(R4) BUMP TO DATA ADDRESS BCTR R5,00 AND DECREMENT SAME BCT R5,*+4+4 DECREMENT AND BRANCH AROUND B TABLE050 THIS INSTR IF NOT ZERO LR R1,R4 SAVE STARTING ADDRESS SPACE TABLE400 DS 0H FIND END OF FIELD CLI 0(R4),X'11' LOOK FOR NEXT FIELD START BE TABLE500 AND BRENCH OUT IF FOUND LA R4,1(,R4) BUMP ANOTHER BYTE BCT R5,TABLE400 AND GO CHECK THIS ONE SPACE TABLE500 DS 0H HERE AT END OF DATA OR NEXT SBA LR R2,R4 PREPARE FOR LENGTH COMPUTATION SR R2,R1 AND COMPUTE ACTUAL LENGTH LR R0,R2 LOAD IT INTO RETURN REG BCTR R2,00 DECREMENT FOR EXECUTE(S) B 4(,R14) RETURN TO CALLER POP USING SPACE FLDMVC1 MVC 0(0,R10),2(R15) EXECUTED MOVE NUMBRTRT TRT 0(0,R1),NUMTAB EXECUTED TRT NUMHXTRT TRT 0(0,R1),NUMHEXTB EXECUTED TRANSLATE AND TEST NUMBPACK PACK DWORD,0(0,R1) EXECUTED PACK INSTRUCTION TITLE ' CVAFPROC -- GENERATE CVAF ERROR MESSAGE' *********************************************************************** * ROUTINE TO PROCESS ERROR RETURN FROM CVAF * *********************************************************************** CVAFPROC DS 0H USING CVAFMAP,R3 LA R3,CVAFREQ * CLI CVSTAT,00 ERROR GENERATED? * BE R14 NO, BYPASS MSG CVAFP010 DS 0H SLL R15,16 SHIFT RC TO HIGH ORDER 2 BYTES LA R1,4 AND LOAD COUNT OF ENTRIES LA R2,CVAFRC A(TARGET AREA) SPACE CVAFP020 DS 0H SLR R14,R14 CLEAR WORK REG SLDL R14,4 SHIFT HALF A BYTE INTO REG STC R14,0(,R2) SAVE THIS HALF BYTE LA R2,1(,R2) BUMP TO NEXT TARGET ADDRESS BCT R1,CVAFP020 AND PROCESS THAT ONE TR CVAFRC,TRTAB TRANSLATE TO PRINTABLE CHARS SPACE LA R1,CVAFREQ SLR R15,R15 CLEAR WORK REG IC R15,CVSTAT AND LOAD STATUS BYTE CVD R15,DWORD CONVERT TO DECIMAL OI DWORD+7,15 INSURE PRINTABLE SIGN UNPK CVAFST,DWORD MOVE TO OUTPUT LINE SPACE MVC CVAFTYPE,=CL5'READ ' DEFAULT TO READ CLI CVFCTN,CVDIRD WAS IT A READ? BE CVAFP030 YES, BYPASS WRITE MVC CVAFTYPE,=CL5'WRITE' NO, INDICATE IT WAS A WRITE SPACE CVAFP030 DS 0H LA R15,CVAFERR GET ADDRESS OF MESSAGE B PROCEMSG RETURN TO CALLER TITLE ' RSETATTR -- RESET ALL MODIFIABLE FIELD ATTRIBUTES' *********************************************************************** * ROUTINE TO RESET ALL MODIFIABLE FIELD ATTRIBUTES * *********************************************************************** RSETATTR DS 0H LA R1,PDSCBL-2 A(H'ENTRIES IN TABLE') LH R2,0(R1) H'ENTRIES IN TABLE' LA R3,PDSCBLEL A(ENTRY LENGTH) LA R1,2(,R1) A(TABLE PROPER) LA R4,DSCBPANL A(PANEL) RSET0000 DS 0H LOOP THROUGH TABLE LH R5,2(,R1) LOAD FIELD OFFSET BCTR R5,00 DECREMENT BACK TO ATTRIBUTE AR R5,R4 ADD PANEL BASE NI 0(R5),64 RESET TO MODIFIABLE, NORM INTENS LA R1,0(R3,R1) BUMP TO NEXT ENTRY BCT R2,RSET0000 AND GO PROCESS SAME BR R10 RETURN TO CALLER SPACE 2 *********************************************************************** * RELEASE CVAF BUFFERS * *********************************************************************** CVAFRLSE DS 0H CVAFDIR ACCESS=RLSE,BUFLIST=0,IXRCDS=NOKEEP,BRANCH=(YES,PGM), $ IOAREA=NOKEEP,MF=(E,CVAFREQ) BR R10 RETURN TO CALLER SPACE PRINT DATA DC 64S(*) PRINT NODATA TITLE 'WORKING STORAGE AND CONSTANTS' SAVEAREA DS 18F DWORD DS D FWORD DS F ALLBLANK DC 256C' ' ALLZEROS DC 256X'00' DSNLOC CAMLST NAME,DS1DSNAM,,LOCWORK DS 0D LOCWORK DS XL512 LOCATE WORK AREA UCBWORKA EQU LOCWORK,100 INPUT EQU LOCWORK,512 LDSNAME DS H LENGTH OF DS1DSNAM DEFCSRAD DS XL2 DEFAULT CURSOR BUFF ADDR SPACE UCBPARM DC A(UCBWORKA) DC A(UCBDEVCL) DC A(X'80000000'+UCBADDR) UCBADDR DC A(0) UCBDEVCL DC X'20' DASD DEVICE CLASS SYSDSN DC CL8'SYSDSN' QNAME FOR ENQ SPACE MODELENQ ENQ (SYSDSN,,E,,SYSTEM),RET=TEST,MF=L SPACE MODESENQ ENQ (SYSDSN,,E,,SYSTEMS),RET=TEST,MF=L SPACE USERID DS 0CL9 USERIDL DS X USERIDI DS CL8 EJECT LTORG SPACE PRINT NOGEN DSNLOCER MSSG 'DATA SET NAME NOT CATALOGED - RESPECIFY' ENQERMSG MSSG 'DATA SET IS IN USE BY OTHER(S) - MODIFY THIS DSCB WITH $ CAUTION' DSNAMEER MSSG 'DATA SET NAME NOT SPECIFIED AT CP INVOCATION - RESPECIF$ Y' DSNLNGER MSSG 'LENGTH OF DSNAME AND USERID GREATER THAN FIELD LENGTH -$ RESPECIFY' UCBERMSG MSSG 'VOLUME SERIAL REQUESTED NOT ONLINE - RESPECIFY DSN OR V$ OL' DSORGER1 MSSG 'INVALID DATASET ORGINIZATION - RESPECIFY - PO/PS/DA/IS/$ AM (U) ALLOWED' RECFMER1 MSSG 'INVALID RECORDING FORMAT - RESPECIFY - F/V/U/B/S/A/M' NUMBERER MSSG 'INVALID DATA, FIELD MUST BE ALL NUMERIC' HEXER MSSG 'INVALID DATA, FIELD MUST BE ALL HEXIDECIMAL CHARACTERS' LNGTHER1 MSSG 'INVALID DATA, DATA LENGTH MUST MATCH INPUT FIELD LENGTH$ ' SCALLER MSSG 'SECONDARY ALLOCATION TYPE INVALID - RESPECIFY - C/T/B/R$ /U' WHATTODO MSSG 'TO TERMINATE, ONE MUST DEPRESS EITHER PFK3 OR PFK15' DSCBMSG1 MSSG 'DSCB HAS BEEN SUCCESSFULLY REWRITTEN' SPACE CVAFERR DC AL2(CVAFERRE-*-2) LENGTH OF ERROR MESSAGE DC C'ERROR RETURN FORM CVAF DURING ' CVAFTYPE DC CL5' ' DC C', RETURN CODE=' CVAFRC DC XL4'00' DC C', STATUS=' CVAFST DC CL3' ' CVAFERRE EQU * END OF ERROR MESSAGE PRINT GEN EJECT MISCFLAG DC B'00000000' NSHARED EQU B'10000000' INDICATES UCB NOT SHARED IPTDSNAM EQU B'01000000' DATA SET NAME HAS CHANGED IPTVOL EQU B'00100000' VOLSER PROVIDED BY TERMINAL OPR IPTERROR EQU B'00010000' INPUT ERROR HAS BEEN ENCOUNTERED DSCBMOD EQU B'00001000' DSCB HAS BEEN MODIFIED ENQUEUE EQU B'00000100' DATA SET IS IN USE * EQU B'00000010' UNUSED AT PRESENT * EQU B'00000001' UNUSED AT PRESENT SPACE TRTAB DC CL16'0123456789ABCDEF' TRANSLATE TABLE SPACE NUMTAB DC 256X'FF' VALID NUMERIC TABLE ORG NUMTAB+C'0' ORG BACK TO NUMERALS DC X'00000000000000000000' ORG , RESET LOCATION COUNTER SPACE NUMHEXTB DC 256X'FF' VALID NUMERIC TABLE ORG NUMHEXTB+C'0' ORG BACK TO NUMERALS DC X'00000000000000000000' ORG NUMHEXTB+C'A' ORG BACK TO HEX CHARS DC X'000000000000' ORG , RESET LOCATION COUNTER SPACE DSORGTAB DS 0CL20 DATASET ORGINAZATION TABLE DC CL2'IS',AL1(DS1DSGIS,00000000) DSORGLNG EQU *-DSORGTAB LENGTH OF ONE ENTRY DC CL2'PS',AL1(DS1DSGPS,00000000) DC CL2'DA',AL1(DS1DSGDA,00000000) DC CL2'PO',AL1(DS1DSGPO,00000000) DC CL2'AM',AL1(00000000,DS1ORGAM) DSORGCNT EQU (*-DSORGTAB)/DSORGLNG COUNT OF ENTRIES SPACE RECFMTAB DS 0CL14 DATASET RECFM TABLE DC CL1'F',AL1(DS1RECFF) RECFMLNG EQU *-RECFMTAB LENGTH OF ONE ENTRY DC CL1'V',AL1(DS1RECFV) DC CL1'U',AL1(DS1RECFU) DC CL1'B',AL1(DS1RECFB) DC CL1'S',AL1(DS1RECFS) DC CL1'A',AL1(DS1RECFA) DC CL1'M',AL1(DS1RECMC) RECFMCNT EQU (*-RECFMTAB)/RECFMLNG COUNT OF ENTRIES SPACE SCAL1TAB DS 0CL14 SECONDARY ALLOCATION TYPE TABLE DC CL1'C',AL1(DS1CYL) CYLINDER BOUNDARY SCAL1LNG EQU *-SCAL1TAB LENGTH OF ONE ENTRY DC CL1'T',AL1(DS1TRK) TRACK BOUNDARY DC CL1'B',AL1(DS1AVR) AVR BLOCK DC CL1'R',AL1(DS1AVRND) AVG BLOCK AND ROUND DC CL1'A',AL1(DS1DSABS) ABSOLUTE TRACK SCAL1CNT EQU (*-SCAL1TAB)/SCAL1LNG COUNT OF ENTRIES EJECT TABTABLE DS 0F DC A(IDSNAME) DC A(IVOLSER) DC A(ICREDT) DC A(IREFD) DC A(IEXPDT) DC A(IDSORG) DC A(IRECFM) DC A(ILRECL) DC A(IBLKL) DC A(IKEYL) DC A(IRKP) DC A(ILSTAR) DC A(ITRBAL) DC A(IDSIND) DC A(ISCALL1) DC A(X'80000000'+ISCALL3) SPACE 2 CVAFREQ CVAFDIR DSN=DS1DSNAM,BUFLIST=CVAFBUF,IOAREA=KEEP, $ IXRCDS=KEEP,MF=L EJECT CVAFBUF ICVAFBFL DSECT=NO EJECT DSCB DS 0F IECSDSL1 (1) MAP OUT DSCB FORMAT 1 LDSCB EQU *-DSCB TITLE ' -- DSCB FIELD(S) MAP FOR A MODEL 2' DSCBPANL $FLD TYPE=INIT,MODEL='3278-2',BUFFTAB=YES,OPERATN=WRITERAS, $ FILL=00 $FLD POS=(01,20),ATR=SKIP, $ INITIAL='DATA SET CONTROL BLOCK MODIFICATION PANEL' $FLD POS=(04,18),ATR=SKIP, $ INITIAL='DATA SET NAME' PDSNAME $FLD POS=(04,32),ATR=(IC,UNPR), $ VALUES=(Y(00)),LENGTH=46 EJECT $FLD POS=(06,18),ATR=SKIP, $ INITIAL='VOLUME SERIAL' PVOLSER $FLD POS=(06,32),ATR=UNPR, $ VALUES=(Y(01)),LENGTH=6 $FLD POS=(08,18),ATR=SKIP, $ INITIAL='CREATION DATE' PCREDT $FLD POS=(08,32),ATR=UNPR, $ VALUES=(Y(02)),LENGTH=5 EJECT $FLD POS=(09,17),ATR=SKIP, $ INITIAL='REFERANCE DATE' PREFD $FLD POS=(09,32),ATR=UNPR, $ VALUES=(Y(03)),LENGTH=5 $FLD POS=(10,16),ATR=SKIP, $ INITIAL='EXPIRATION DATA' PEXPDT $FLD POS=(10,32),ATR=UNPR, $ VALUES=(Y(04)),LENGTH=5 EJECT $FLD POS=(12,10),ATR=SKIP, $ INITIAL='DATA SET ORGINIZATION' PDSORG $FLD POS=(12,32),ATR=UNPR, $ VALUES=(Y(05)),LENGTH=3 $FLD POS=(13,18),ATR=SKIP, $ INITIAL='RECORD FORMAT' PRECFM $FLD POS=(13,32),ATR=UNPR, $ VALUES=(Y(06)),LENGTH=4 EJECT $FLD POS=(14,10),ATR=SKIP, $ INITIAL='LOGICAL RECORD LENGTH' PLRECL $FLD POS=(14,32),ATR=UNPR, $ VALUES=(Y(07)),LENGTH=5 $FLD POS=(15,12),ATR=SKIP, $ INITIAL='PHYSICAL BLOCK SIZE' PBLKL $FLD POS=(15,32),ATR=UNPR, $ VALUES=(Y(08)),LENGTH=5 EJECT $FLD POS=(16,21),ATR=SKIP, $ INITIAL='KEY LENGTH' PKEYL $FLD POS=(16,32),ATR=UNPR, $ VALUES=(Y(09)),LENGTH=3 $FLD POS=(17,10),ATR=SKIP, $ INITIAL='RELATIVE KEY POSITION' PRKP $FLD POS=(17,32),ATR=UNPR, $ VALUES=(Y(10)),LENGTH=3 EJECT $FLD POS=(19,06),ATR=SKIP, $ INITIAL='LAST USED TRACK AND BLOCK' PLSTAR $FLD POS=(19,32),ATR=UNPR, $ VALUES=(Y(11)),LENGTH=6 $FLD POS=(19,40),ATR=(SKIP,BRT), $ INITIAL='<=== HEXADECIMAL' $FLD POS=(20,01),ATR=SKIP, $ INITIAL='BYTES REMAINING ON LAST TRACK' PTRBAL $FLD POS=(20,32),ATR=UNPR, $ VALUES=(Y(12)),LENGTH=4 EJECT $FLD POS=(22,12),ATR=SKIP, $ INITIAL='DATA SET INDICATORS' PDSIND $FLD POS=(22,32),ATR=UNPR, $ VALUES=(Y(13)),LENGTH=2 $FLD POS=(22,40),ATR=(SKIP,BRT), $ INITIAL='<=== HEXADECIMAL' $FLD POS=(23,11),ATR=SKIP, $ INITIAL='SECONDARY ALLOCATION' PSCAL1 $FLD POS=(23,32),ATR=UNPR, $ VALUES=(Y(14)),LENGTH=1 EJECT PSCAL3 $FLD POS=(23,34),ATR=UNPR, $ VALUES=(Y(15)),LENGTH=5 PERRMSG $FLD POS=(24,02),ATR=(SKIP,BRT), $ INITIAL=' $ ' PDSCBL $FLD TYPE=FINAL,BUFFTAB=PDSCBL,EQU=LPDSCBL LPDSCB EQU (((*-DSCBPANL+7)/8)*8) LENGTH OF DCT PANEL EJECT CVAFMAP ICVAFPL DSECT=YES,LABELS=YES EJECT IKJCPPL CPPL PARAMETER LIST PRINT NOGEN CVT LIST=YES,DSECT=YES IEFUCBOB LIST=YES IHAPSA IHAACEE IHAASCB IHAASXB PRINT GEN EJECT YREGS , EJECT $KEYS END