*--------------------------------------------------------------------* 00000107 * DON'T KNOW WHO WROTE THIS ORIGINALLY * 00000207 * FULL SCREEN VTOC ZAPPER. * 00000307 *--------------------------------------------------------------------* 00000407 *********************************************************************** 00000507 * MODIFIED BY K.M. (SAM) BASS (SBASS,SJB,KBASS,KMB) * 00000607 *********************************************************************** 00000707 $ATH$ EQU ??? AUTHORIZATION SVC 00000807 *--------------------------------------------------------------------* 00000901 * MSSG MACRO * 00001001 *--------------------------------------------------------------------* 00001101 MACRO 00001201 &MSGNAME MSSG &DATA,&REPLN,&PREFIX=YES 00001301 LCLC &FN 00001401 LCLA &FL 00001501 AIF (T'&DATA NE 'O').IN0100 00001601 MNOTE 8,'DATA NOT SUPPLIED IN ''MSSG'' GENERATION, EXPANSION T$00001701 ERMINATED' 00001801 MEXIT 00001901 .IN0100 ANOP 00002001 AIF (T'&MSGNAME EQ 'O').IN0200 00002101 &FN SETC '&MSGNAME' 00002201 AGO .IN0300 00002301 .IN0200 MNOTE 4,'MAP NAME NOT SPECIFIED, DEFAULT NAME GENERATED' 00002401 &FN SETC 'MSSG&SYSNDX' GENERATE DEFAULT NAME 00002501 .IN0300 ANOP 00002601 AIF ('&DATA'(1,1) EQ '''').IN0400 FIRST CHAR A (')? 00002701 MNOTE 8,'CHARACTER STRING MUST BEGIN AND END WITH A QUOTE - EX$00002801 PANSION TERMINATED' 00002901 MEXIT 00003001 .IN0400 ANOP 00003101 AIF (T'&REPLN EQ 'O').IN0500 IS REPLY LENGTH SUPPLIED? 00003201 AIF (T'&REPLN EQ 'N').IN0500 IS REPLY LENGTH NUMERIC? 00003301 MNOTE 8,'''REPLY LENGTH'' VALUE IS NOT NUMERIC - EXPANSION TER$00003401 MINATED' 00003501 MEXIT 00003601 .IN0500 ANOP 00003701 &FN DS 0H ALIGN ON HALFWORD 00003801 &FL SETA K'&DATA-2 DEFAULT TO LENGTH OF LITERAL 00003901 &FL SETA (((&FL+1)/2)*2) ROUND TO HALF WORD LENGTH 00004001 AIF ('&PREFIX' NE 'YES').IN0550 BYPASS AL2 IF NOT DESIRED 00004101 DC AL2(&FL) LENGTH OF TEXT - ROUNDED TO 2 00004201 .IN0550 ANOP 00004301 AIF (T'&REPLN EQ 'O').IN0600 IS REPLY LENGTH SUPPLIED? 00004401 DC AL2(&REPLN) LENGTH OF REPLY EXPECTED 00004501 .IN0600 ANOP 00004601 DC CL&FL&DATA 00004701 MEND 00004801 *--------------------------------------------------------------------* 00004901 * $KEYS MACRO * 00005001 *--------------------------------------------------------------------* 00005101 MACRO 00005201 $KEYS 00005301 GBLB &KEYDEF 00005401 AIF (&KEYDEF).MEX2 00005501 &KEYDEF SETB 1 00005601 PFKEY01 EQU X'F1' EQUATE FOR PFKEY01 00005701 PFKEY02 EQU X'F2' EQUATE FOR PFKEY02 00005801 PFKEY03 EQU X'F3' EQUATE FOR PFKEY03 00005901 PFKEY04 EQU X'F4' EQUATE FOR PFKEY04 00006001 PFKEY05 EQU X'F5' EQUATE FOR PFKEY05 00006101 PFKEY06 EQU X'F6' EQUATE FOR PFKEY06 00006201 PFKEY07 EQU X'F7' EQUATE FOR PFKEY07 00006301 PFKEY08 EQU X'F8' EQUATE FOR PFKEY08 00006401 PFKEY09 EQU X'F9' EQUATE FOR PFKEY09 00006501 PFKEY10 EQU X'7A' EQUATE FOR PFKEY10 00006601 PFKEY11 EQU X'7B' EQUATE FOR PFKEY11 00006701 PFKEY12 EQU X'7C' EQUATE FOR PFKEY12 00006801 SPACE 00006901 PFKEY13 EQU X'C1' EQUATE FOR PFKEY13 00007001 PFKEY14 EQU X'C2' EQUATE FOR PFKEY14 00007101 PFKEY15 EQU X'C3' EQUATE FOR PFKEY15 00007201 PFKEY16 EQU X'C4' EQUATE FOR PFKEY16 00007301 PFKEY17 EQU X'C5' EQUATE FOR PFKEY17 00007401 PFKEY18 EQU X'C6' EQUATE FOR PFKEY18 00007501 PFKEY19 EQU X'C7' EQUATE FOR PFKEY19 00007601 PFKEY20 EQU X'C8' EQUATE FOR PFKEY20 00007701 PFKEY21 EQU X'C9' EQUATE FOR PFKEY21 00007801 PFKEY22 EQU X'4A' EQUATE FOR PFKEY22 00007901 PFKEY23 EQU X'4B' EQUATE FOR PFKEY23 00008001 PFKEY24 EQU X'4C' EQUATE FOR PFKEY24 00008101 SPACE 00008201 PA1KEY EQU X'6C' EQUATE FOR PA1KEY 00008301 PA2KEY EQU X'6E' EQUATE FOR PA2KEY 00008401 PA3KEY EQU X'6B' EQUATE FOR PA3KEY 00008501 CLEAR EQU X'6D' EQUATE FOR CLEAR 00008601 ENTER EQU X'7D' EQUATE FOR ENTER 00008701 .MEX2 ANOP 00008801 MEND 00008901 *--------------------------------------------------------------------* 00009001 * $FLD MACRO * 00009101 *--------------------------------------------------------------------* 00009201 MACRO 00009301 .* 00009401 .* KMB CHANGED &ENTS AND &CURSOR AIFS TO NOT USE TRUE/FALSE 00009501 .* 00009601 &FLDNAME $FLD &OPTN=2,&LENGTH=,&POS=,&LOC=,&FILL=, $00009701 &ATR=(SKIP),&INITIAL=,&TYPE=,&EQU=,&VALUES=, $00009801 &MODEL='3276-2',&OPERATN=,&BUFFTAB=NO 00009901 GBLA &TLEN ALGREBRAIC WORK FIELD * 00010001 GBLA &ARG 3270 ATTRIBUTE CHAR RESOLUTION * 00010101 GBLA &MTYPE TYPE REQUEST * 00010201 GBLA &CURSOR CURSOR POSITION * 00010301 GBLA &OPT PROCESS OPTION INDICATOR * 00010401 GBLA &PREVPOS PREVIOUS POSITION * 00010501 GBLA &LINES NUMBER OF LINES PER PAGE * 00010601 GBLA &COLS NUMBER OF COLUMNS PER LINE * 00010701 GBLC &MOD1 TYPE OF CRT BEING USED 32XX * 00010801 GBLC &MOD2 MODEL OF CRT BEING USED -N * 00010901 GBLA &SCRSIZE TOTAL AREA OF SCREEN * 00011001 GBLA &GLENGTH FIELD LENGTH * 00011101 GBLA &EPOS FIELD ENDING POSITION * 00011201 GBLA &NLOC CURRENT FIELD LOCATION * 00011301 GBLA &PLOC PREVIOUS (NEXT) LOCATION * 00011401 GBLB &MAP FIRST TIME CONDITION SWITCH * 00011501 GBLB &DEFAULT INITIAL = USER DEFAULT DATA * 00011601 GBLB &DATAIND DATA FIELD INDICATOR * 00011701 GBLB &PEN ATR = DET * 00011801 GBLB &KEYED ATR = UNPROT * 00011901 GBLB &IC ATR = IC * 00012001 GBLB &NUMERIC NUMERIC FIELD INDICATOR 00012101 GBLB &SEQ FIELDS OUT OF SEQUENCE IND * 00012201 GBLB &SKIP 1 IF ATR = SKIP, 0 ALL OTHERS * 00012301 GBLB &PROT 1 IF ATR = PROT, 0 ALL OTHERS * 00012401 .* GBLC &DEVICE DIVICE TYPE INDICATOR * 00012501 GBLC &FN FIELD NAME * 00012601 GBLC &ATRC 3270 ATTRIBUTE CHARACTER * 00012701 LCLA &REQ REPLY REQUIRED INDICATOR * 00012801 LCLA &FPOS FIELD POSITION * 00012901 LCLA &FLAG FIELD DESCRIPTOR FLAG * 00013001 LCLC &FILLCHR FILLER USED INSTEAD OF INITIAL * 00013101 GBLC &GFILL TYPE=INIT SPECIFICATION OF FILL * 00013201 LCLC &OPER TYPE OF READ/WRITE OPERATION * 00013301 LCLB &ABORT ABORT INDICATOR * 00013401 LCLB &X(10),&XON 00013501 LCLA &COUNT,&INDEX,&HIGH,&A,&B,&C 00013601 LCLA &Y(10) 00013701 LCLA &XAXIS X AXIS BUFFER ADDRESS * 00013801 LCLA &YAXIS Y AXIS BUFFER ADDRESS * 00013901 LCLC &XCHAR X AXIS CHARACTER * 00014001 LCLC &YCHAR Y AXIS CHARACTER * 00014101 GBLC &ADDRCHR ADDRESS CHARACTER STRING * 00014201 GBLB &DOCSW DOCUMENTATION PRINT SWITCH * 00014301 GBLC &MAPNAME NAME OF THIS $FLD MAP * 00014401 .************************ BUFFER TABLE ENTRIES ************************ 00014501 GBLB &BUFFTB BUFFER ADDRESS TABLE REQUESTED * 00014601 .* TO CHANGE NUMBER OF ENTRIES, CHANGE THE SUBSCRIPT VALUE * 00014701 .* HERE AND THE SETA VALUE FOR &ENTS * 00014801 GBLA &ENTLEN(256) BUFFER ENTRY LENGTH - 1 * 00014901 GBLA &ENTVCN(256) NUMBER OF VALUES PER ENTRY * 00015001 GBLC &ENTOFF(256) BUFFER ENTRY OFFSET * 00015101 GBLC &ENTRBA(256) BUFFER ENTRY RBA * 00015201 GBLC &ENTVAL(768) BUFFER ENTRY VALUES 3/ENTRY * 00015301 GBLA &ENTMAX MAXIMUM BUFFER ENTRIES * 00015401 GBLA &ENTS NUMBER OF BUFFER ENTRIES * 00015501 GBLA &VALCNT NUMBER OF TOTAL 'VALUES' ENTRIES 00015601 LCLA &LSTCNT NUMBER OF ENTRIES PROCESSED * 00015701 LCLA &TCNT1 WORK COUNTER * 00015801 LCLC &FNM NAME TO BE USED ON DS * 00015901 .********************************************************************** 00016001 .* * ANALYZE OPERANDS * * 00016101 .********************************************************************** 00016201 AIF (&MAP).IN0100 FIRST TIME THRU ??? @ 00016301 AIF (T'&TYPE EQ 'O').ERR140 MUST SUPPLY TYPE * 00016401 AIF ('&TYPE' EQ 'INIT').IN0005 MUST SUPPLY INIT FIRST * 00016501 .ERR140 MNOTE 4,'''INIT'' MUST BE SPECIFIED FOR FIRST INVOCATION OF TH$00016601 IS MACRO' ERROR IF NOT * 00016701 .IN0005 ANOP HERE AFTER MNOTE * 00016801 &MAP SETB 1 SET ON FIRST TIME THRU @ 00016901 .* CHANGE THIS SETA IF CHANGING MAXIMUM SUBSCRIPT VALUE * 00017001 &ENTMAX SETA 256 MAXIMUM BUFFER ENTRIES @ 00017101 &VALCNT SETA 0 RESET VALUE COUNTER @ 00017201 &MTYPE SETA 0 RESET MAY INDICATOR * 00017301 &PREVPOS SETA 0 RESET PREVIOUS POS INDICATOR * 00017401 &SKIP SETB 1 INITIALIZE SKIP INDICATOR * 00017501 &PLOC SETA 1 INITIALIZE LOCATION COUNTER * 00017601 &ADDRCHR SETC 'Z40C1C2C3C4C5C6C7C8C94A4B4C4D4E4F50D1D2D3D4D5D6D7D8D95A$00017701 5B5C5D5E5F6061E2E3E4E5E6E7E8E96A6B6C6D6E6FF0F1F2F3F4F5F6$00017801 F7F8F97A7B7C7D7E7F' 00017901 .* THE Z AT THE BEGINNING OF THE TABLE IS TO OFFSET THE * 00018001 .* MULTIPLICATION BY 2. THE OFFSET INTO THE TABLE IS BASED ON * 00018101 .* AN INITIAL VALUE OF ONE (1) NOT ZERO (0). * 00018201 .********************************************************************** 00018301 .MOD000 ANOP HERE TO VERIFY CTR * 00018401 AIF (T'&MODEL EQ 'O').ERR160 WAS MODEL SUPPLIED * 00018501 AIF (K'&MODEL LT 6).ERR160 IS ALL OF IT THERE * 00018601 AIF ('&MODEL'(1,1) EQ '''').MOD010 IS IT WITHIN QUOTES * 00018701 &MOD1 SETC '&MODEL'(1,4) SET UP CRT TYPE * 00018801 &MOD2 SETC '&MODEL'(6,1) SET UP CRT MODEL * 00018901 AGO .MOD020 BYPASS FOLLOWING * 00019001 .MOD010 ANOP HERE TO PROCESS QUOTES * 00019101 &MOD1 SETC '&MODEL'(2,4) SET UP CRT TYPE * 00019201 &MOD2 SETC '&MODEL'(7,1) SET UP CRT MODEL * 00019301 .MOD020 AIF (&MOD1 EQ 3275 OR &MOD1 EQ 3277).MOD030 * 00019401 AIF (&MOD1 EQ 3276 OR &MOD1 EQ 3278).MOD040 * 00019501 .ERR180 MNOTE 8,'MODEL=&MODEL NOT ACCEPTABLE TO THIS MACRO' * 00019601 MEXIT 00019701 .MOD030 ANOP HERE FOR 3275'S * 00019801 AIF (&MOD2 EQ 2).MOD050 LARGE SCREEN * 00019901 AIF (&MOD2 NE 1).ERR180 NOT SMALL SCREEN * 00020001 &LINES SETA 12 SET ROWS * 00020101 &COLS SETA 40 SET COLUMNS * 00020201 AGO .MOD090 BYPASS FOLLOWING CODE * 00020301 .MOD050 ANOP HERE FOR 3277'S * 00020401 &LINES SETA 24 SET ROWS * 00020501 &COLS SETA 80 SET COLUMNS * 00020601 AGO .MOD090 BYPASS FOLLOWING CODE * 00020701 .MOD040 ANOP HERE FOR NEW DEVICES * 00020801 &COLS SETA 80 ALL HAVE 80 COLUMNS * 00020901 AIF (&MOD2 EQ 1).MOD060 SMALL SCREEN CRT * 00021001 AIF (&MOD2 EQ 2).MOD070 LARGE SCREEN CRT * 00021101 AIF (&MOD2 EQ 3).MOD080 BIG SCREEN CRT * 00021201 AIF (&MOD2 NE 4).ERR180 BIGGIE SCREEN CRT * 00021301 &LINES SETA 43 SET ROWS * 00021401 AGO .MOD090 BYPASS FOLLOWING CODE * 00021501 .MOD060 ANOP HERE FOR ROWS * 00021601 &LINES SETA 12 SET ROWS * 00021701 AGO .MOD090 BYPASS FOLLOWING CODE * 00021801 .MOD070 ANOP HERE FOR ROWS * 00021901 &LINES SETA 24 SET ROWS * 00022001 AGO .MOD090 BYPASS FOLLOWING CODE * 00022101 .MOD080 ANOP HERE FOR ROWS * 00022201 &LINES SETA 32 SET ROWS * 00022301 .MOD090 ANOP HERE WHEN ROWS & COLS DEFINED * 00022401 &SCRSIZE SETA &COLS*&LINES DEFINE MAXIMUM SCREENSIZE * 00022501 AIF (T'&OPTN EQ 'O').IN0010 IS OPTION GIVEN ??? * 00022601 &OPT SETA &OPTN YES, SAVE VALUE * 00022701 .********************************************************************** 00022801 AGO .IN0020 CONTINUE * 00022901 .IN0010 ANOP SUBSTITUTE OPTION VALUE * 00023001 &OPT SETA 2 DOCUMENTATION ONLY * 00023101 .********************************************************************** 00023201 .IN0020 ANOP TEST IF DOCUMENTATION REQ. * 00023301 AIF (T'&FILL EQ 'O').IN0030 IS OPTION GIVEN ??? * 00023401 &GFILL SETC '&FILL' SET FILL CHARACTER 00023501 .IN0030 ANOP 00023601 *********************************************************************** 00023701 MNOTE *,' OPTIONS IN EFFECT----------- ' 00023801 MNOTE *,' ' 00023901 MNOTE *,' ROWS........ &LINES ' 00024001 MNOTE *,' COLUMNS..... &COLS ' 00024101 MNOTE *,' CHARACTERS.. &SCRSIZE ' 00024201 *********************************************************************** 00024301 SPACE 00024401 AIF (&DOCSW).IN0050 HAS DOCUMENTATION PRINTED ONCE? * 00024501 &DOCSW SETB 1 SET DOCUMEMTATION PRINTED FLAG * 00024601 *********************************************************************** 00024701 * MAP GENERATION PARAMETERS, THEIR USE AND DEFAULTS * 00024801 * * 00024901 * INITIAL ENTRY (MUST BE GIVEN TO SET VARIOUS OPTIONS) * 00025001 * * 00025101 * MAP OPTN=1,MODEL='32XX-N',TYPE=INIT,BUFFTAB=XXX * 00025201 * * 00025301 * MODEL TO SPECIFY THE TERMINAL TYPE (AND SCREEN SIZE), * 00025401 * THE DEFAULT IS SET TO 24 ROWS, AND 80 COLUMNS PER * 00025501 * ROW. MAXIMUM IS 43 BY 80. THE ACCEPTABLE VALUES * 00025601 * AND THEIR GENERATED SCREEN SIZES ARE AS FOLLOWS: * 00025701 * * 00025801 * MODEL ROWS COLS CHARS MODEL ROWS COLS CHARS * 00025901 * 3276-1 12 80 960 * 00026001 * 3275-1 12 40 480 3276-2 24 80 1920 * 00026101 * 3275-2 24 80 1920 3276-3 32 80 2560 * 00026201 * 3276-4 43 80 3440 * 00026301 * * 00026401 * 3278-1 12 80 960 * 00026501 * 3277-1 12 40 480 3278-2 24 80 1920 * 00026601 * 3277-2 24 80 1920 3278-3 32 80 2560 * 00026701 * 3278-4 43 80 3440 * 00026801 * * 00026901 * OPTN THIS PARAMETER IS USED TO SET ONE OF THE * 00027001 * FOLLOWING OPTIONS....... * 00027101 * * 00027201 * OPTN=1 - DOCUMENTATION GENERATION. * 00027301 * OPTN=2 - DOCUMENTATION & DATA DECLARATION. * 00027401 * * 00027501 * NOTE: (TYPE=INIT AND MODEL=32NN-N MUST BE SPECIFIED TO * 00027601 * PREVENT MNOTE ERRORS FOR DOCUMENTATION ONLY.) * 00027701 * * 00027801 * OPERATN THIS PRAMETER IS USED TO SPECIFY THE TYPE OF * 00027901 * OPERATION TO BE USED. THE ACCEPTABLE VALUES ARE: * 00028001 * * 00028101 * READ - FULL BUFFER READ * 00028201 * READMOD - READ MODIFIED FIELDS ONLY * 00028301 * * 00028401 * WRITE - WRITE / WITHOUT ERASE OPERATION * 00028501 * WRITERAS - WRITE / ERASE ALL FIELDS * 00028601 * WRITERUP - WRITE / ERASE UNPROTECTED FIELDS ONLY * 00028701 * * 00028801 *********************************************************************** 00028901 EJECT 00029001 *********************************************************************** 00029101 * BUFFTAB=XXX THIS ENTRY MAY BE USED TO GENERATE A TABLE * 00029201 * OF ALL USER MODIFIABLE ENTRIES IN THIS MAP. THIS TABLE* 00029301 * CONTAINS AN ENTRY FOR EACH OF THE FOLLOWING: * 00029401 * * 00029501 * BUFFER ADDRESS - THE BUFFER ADDRESS OF AS GENERATED BY THIS * 00029601 * MAP. NOTE: ONLY MODIFIABLE FIELDS ARE * 00029701 * PROCESSED. * 00029801 * OFFSET - THE OFFSET OF THIS FIELD FROM THE BEGINNING * 00029901 * OF THIS FIELD MAP. * 00030001 * LENGTH - THE LENGTH OF THIS FIELD, LESS ONE BYTE. * 00030101 * * 00030201 * THE VALID OPTIONS AND WHEN THE ARE USED ARE AS FOLLOWS: * 00030301 * * 00030401 * NO - USED WITH 'TYPE=INIT' TO BYPASS TABLE GENERATION. * 00030501 * THIS IS THE DEFAULT VALUE. * 00030601 * YES - USED WITH 'TYPE=INIT' TO REQUEST TABLE GENERATION. * 00030701 * * 00030801 * ADDITIONALLY, YOU MAY SPECIFY PARAMETERS TO BE * 00030901 * INCLUDED IN THE GENERATION OF THIS TABLE. THEY MAY BE PASSED * 00031001 * VIA THE PARAMETER 'VALUES'. AN EXAMPLE OF HOW THIS PARAMETER * 00031101 * IS USED IS DISPLAYED BELOW. NOTE: TWO RESTRICTIONS EXIST. * 00031201 * THEY ARE: 1) A MAXIMUM OF THREE ENTRIES ARE ALLOWED PER $FLD * 00031301 * SPECIFICATION, AND 2) THIS VALUE IS ALLOWABLE ONLY ON FIELDS * 00031401 * THAT ARE FLAGGED AS MODIFIABLE BY THE USER. ALSO, YOU ARE * 00031501 * RESPONSIBLE FOR MAINTAINING ALIGNMENT. THE BASIC TABLE IS SIX* 00031601 * (6) BYTES LONG AND IS INITIATED ON A FULLWORD BOUNDARY. * 00031701 * * 00031801 * FSTART $FLD TYPE=INIT,BUFFTAB=YES * 00031901 * FIELD1 $FLD POS=(10,30),INITIAL='.....',ATR=IC, * 00032001 * VALUES=(X'01',X'4E',A(PARAM)) * 00032101 * FTABLE $FLD TYPE=FINAL * 00032201 * * 00032301 * THIS WOULD GENERATE A BUFFER ADDRESS TABLE AS FOLLOWS: * 00032401 * * 00032501 *FTABLE DS 0F * 00032601 * DC XL2'4B6E' BUFF ADDR OF CURRENT ENTRY * 00032701 * DC AL2(FIELD1-FSTART) OFFSET TO CURRENT ENTRY * 00032801 * DC AL2(4) LENGTH OF CURRENT ENTRY - 1 * 00032901 * DC X'01' VALUES PARAMETER * 00033001 * DC X'4E' VALUES PARAMETER * 00033101 * DC A(PARAM) VALUES PARAMETER * 00033201 * * 00033301 * NOTE: THIS TABLE IS A MULTIPLE OF 4 BYTES. (USER CONTROLLED) * 00033401 *********************************************************************** 00033501 EJECT 00033601 *********************************************************************** 00033701 * * 00033801 * FIELD LAYOUT ENTRIES (ONE PER FIELD) * 00033901 * * 00034001 * $FLD POS=(10,1),ATR=(SKIP),INITIAL='A',LOC=NNN,TYPE=REQ * 00034101 * LENGTH=1 * 00034201 * * 00034301 * POS TO SPECIFY ROW AND COLUMN NUMBERS. TRY NOT TO * 00034401 * USE ROW 24, IT IS USED BY THE SYSTEM. * 00034501 * * 00034601 * ATR THIS PARAMETER IS USED TO DEFINE THE DATA FIELD * 00034701 * ATTRIBUTE CHARACTERISTICS. * 00034801 * * 00034901 * ATR=(SKIP) PROTECTED FIELD * ATR=(BRT) HIGH INTENSITY FIELD* 00035001 * ATR=(PROT) PROTECTED FIELD * ATR=(DRK) NON-DISPLAY FIELD * 00035101 * ATR=(UNPR) MODIFIABLE FIELD * ATR=(MDT) MODIFIED DATA TAG ON* 00035201 * ATR=(NUM) NUMERIC DATA ONLY * ATR=(IC) INSERT CURSOR * 00035301 * ATR=(DET) LIGHT PEN DETECTALBE * ATR=(NORM) NORMAL INTENSITY * 00035401 * * 00035501 * DO NOT USE THE FOLLOWING COMBINATIONS....... * 00035601 * ATR=(SKIP,UNPR) ATR=(DRK,NORM) * 00035701 * ATR=(PROT,UNPR) ATR=(SKIP,IC) * 00035801 * ATR=(DET,DRK) ATR=(PROT,IC) * 00035901 * ATR=(BRT,DRK) ATR=(PROT,NUM) * 00036001 * ATR=(BRT,NORM) * 00036101 * * 00036201 * LENGTH TO SPECIFY LENGTH OF FIELD WHEN 'INITIAL' IS * 00036301 * NOT GIVEN. DO NOT USE WHEN INITIAL VALUE IS * 00036401 * GIVEN. * 00036501 * INITIAL USED TO DECLARE CONSTANT SCREEN DATA. THIS * 00036601 * SHOULD ALWAYS BE USED TO SHOW THE TYPE OF DATA * 00036701 * TO BE DISPLAYED. * 00036801 * LOC THIS PARAMETER IS USED TO DEFINE THE RELATIVE * 00036901 * LOCATION OF THE DATA FIELD WITHIN THE USER AREA. * 00037001 * DO NOT SPECIFY ON ANY OTHER THAN INPUT DATA. * 00037101 * TYPE TYPE=INIT IS REQUIRED FIRST TIME THRU TO SET UP * 00037201 * INITIAL VALUES AND DOCUMENTATION PRINT. * 00037301 * TYPE=FINAL IS NEEDED TO TERMINATE THE CURRENT * 00037401 * MAP AND TO INSERT ANY CURSOR SPECIFIED. * 00037501 * * 00037601 * FTABLE $FLD TYPE=FINAL,EQU=XXXXXX * 00037701 * * 00037801 * TYPE=FINAL CAUSES THE INSERT CURSOR STRING TO BE PLACED * 00037901 * AT THE END OF THE FIELD DEFINITION. THIS POSITION* 00038001 * IS REQUIRED FOR TCAM. * 00038101 * EQU=XXXXX WILL GENERATE AN EQU, WITH XXXXX AS THE NAME, * 00038201 * WITH THE LENGTH OF THIS DISPLAY AS THE VALUE. * 00038301 * * 00038401 * * 00038501 *********************************************************************** 00038601 EJECT 00038701 .IN0050 ANOP 00038801 AIF (&OPT EQ 1).MAPXIT EXIT IF DOCUMENTATION ONLY * 00038901 AIF (&OPT EQ 2).IN0055 CONTINUE IF VALID OPTION * 00039001 MNOTE 4,'INVALID OPTION SPECIFIED, OPTION=2 ASSUMED' 00039101 .IN0055 ANOP 00039201 AIF ('&BUFFTAB'(1,1) EQ 'N').IN0057 BUFFER TABLE REQ? 00039301 AIF ('&BUFFTAB'(1,1) NE 'Y').ERR200 IF NOT, ERROR 00039401 &BUFFTB SETB 1 YES, INDICATE SO 00039501 &ENTS SETA 0 RESET ENTRY COUNT 00039601 .IN0057 ANOP 00039701 .* &FLDNAME CSECT * 00039801 AIF (T'&FLDNAME EQ 'O').IN0060 00039901 &FN SETC '&FLDNAME' GENERATE DEFAULT NAME 00040001 AGO .IN0065 00040101 .IN0060 ANOP 00040201 AIF (NOT &BUFFTB).IN0065 BYPASS IF BUFFTAB NOT REQUESTED 00040301 MNOTE 4,'MAP NAME REQUIRED WITH ''BUFFTAB'' OPTION, DEFAULT NA$00040401 ME GENERATED' 00040501 &FN SETC 'FLD&SYSNDX' GENERATE DEFAULT NAME 00040601 .IN0065 ANOP 00040701 &FN DS 0F * 00040801 &FPOS SETA 4 00040901 &MAPNAME SETC '&FN' SAVE MAP NAME 00041001 AIF (T'&OPERATN EQ 'O').MAPXIT IF OMITTED, BYPASS REST * 00041101 AIF ('&OPERATN'(1,4) EQ 'READ').IN0080 GO TO READ * 00041201 AIF ('&OPERATN'(1,5) EQ 'WRITE').IN0070 CHECK TYPE * 00041301 MNOTE 8,'TYPE OF OPERATION SPECIFIED IS UNACCEPTABLE' 00041401 MEXIT 00041501 .IN0070 ANOP 00041601 AIF ('&OPERATN'(5,4) EQ 'ERAS').IN0072 ERASE WRITE * 00041701 AIF ('&OPERATN'(5,4) EQ 'ERUN').IN0074 ERASE UNPROT * 00041801 &OPER SETC 'F1' DEFAULT TO NORMAL WRITE * 00041901 AGO .IN0090 GO GEN CHAR STRING * 00042001 .IN0072 ANOP 00042101 &OPER SETC 'F5' DEFAULT TO WRITE ERASE * 00042201 AGO .IN0090 GO GEN CHAR STRING * 00042301 .IN0074 ANOP 00042401 &OPER SETC '6F' DEFAULT TO ERASE UNPROT * 00042501 AGO .IN0090 GO GEN CHAR STRING * 00042601 .IN0080 ANOP HERE FOR READ OPERATIONS * 00042701 AIF ('&OPERATN'(5,3) EQ 'MOD').IN0082 READ MODIFY * 00042801 &OPER SETC 'F2' DEFAULT TO NORMAL READ * 00042901 AGO .IN0090 GO GEN CHAR STRING * 00043001 .IN0082 ANOP HERE FOR READ MODIFIED * 00043101 &OPER SETC 'F6' DEFAULT TO READ MODIFIED * 00043201 .IN0090 ANOP 00043301 DC XL3'27&OPER.C1' * 00043401 AGO .MAPXIT EXIT ON FIRST TIME THRU * 00043501 .********************************************************************** 00043601 .IN0100 ANOP BYPASS AFTER FIRST TIME THRU * 00043701 AIF (&MTYPE EQ 2).ERR010 ERROR IF PREV. ENTRY FINAL @ 00043801 AIF (T'&TYPE EQ 'O').IN0110 IS THIS FINAL ENTRY ??? @ 00043901 AIF ('&TYPE' NE 'FINAL').ERR150 REPLY REQUIRED ??? * 00044001 &MTYPE SETA 2 YES, SET INDICATOR @ 00044101 AGO .FI0000 GO PROCESS FINAL ENTRY @ 00044201 .IN0110 ANOP SET UP FIELD NAME @ 00044301 .********************************************************************** 00044401 .* ANALYZE SPECIFICATION OF LENGTH/INITIAL OPERAND * 00044501 .********************************************************************** 00044601 AIF (T'&LENGTH EQ 'O').LG0010 LENGTH NOT GIVEN 5 00044701 &GLENGTH SETA &LENGTH SET FIELD LENGTH @ 00044801 AGO .LG0030 BYPASS LENGTH SUBSTITUTION @ 00044901 .LG0010 ANOP USE LENGTH OF DEFAULT VALUE @ 00045001 AIF (T'&INITIAL EQ 'O').LG0020 IF NOT GIVEN DEFAULT TO ONE 5 00045101 AIF ('&INITIAL'(1,1) NE '''').ERR070 YES, FIRST CHAR A (') ? 00045201 &GLENGTH SETA K'&INITIAL-2 DEFAULT TO LENGTH OF LITERAL @ 00045301 &DEFAULT SETB 1 YES, SET DEFAULT GLOBAL @ 00045401 AGO .LG0030 END OF LENGTH GENERATION 5 00045501 .LG0020 ANOP LENGTH DEFAULT SETUP 5 00045601 &GLENGTH SETA 1 DEFAULT TO LENGTH OF ONE @ 00045701 .LG0030 ANOP VALIDATE LENGTH VALUE ASSIGNED 5 00045801 .* AIF (&GLENGTH GT 256).ERR020 TOO LONG DELETED BY LGN 7906* 00045901 AIF (&GLENGTH LT 1).ERR020 NOT LONG ENOUGH @ 00046001 .********************************************************************** 00046101 .* ANALYZE SPECIFICATION OF FILL OPERAND * 00046201 .********************************************************************** 00046301 AIF (T'&FILL NE 'O').FILL10 IS OPTION GIVEN ??? * 00046401 &FILLCHR SETC '&GFILL' SET FILL CHARACTER 00046501 AGO .FILL20 00046601 .FILL10 ANOP 00046701 &FILLCHR SETC '&FILL' SET FILL CHARACTER 00046801 .FILL20 ANOP 00046901 .PO0000 ANOP END OF FIELD LENGTH PARAMETER @ 00047001 .********************************************************************** 00047101 .* ANALYZE SPECIFICATION OF POS OPERAND * 00047201 .********************************************************************** 00047301 AIF (T'&POS EQ 'O').ERR030 IS POS = NULL ? @ 00047401 &FPOS SETA &POS(1) @ 00047501 AIF (N'&POS LT 2).PO0020 ACTUAL POSITIONS SPECIFIED ??? @ 00047601 AIF (&POS(1) LT 1 OR &POS(1) GT &LINES).ERR030 LINE VALID ? 00047701 AIF (&POS(2) LT 1 OR &POS(2) GT &COLS).ERR030 YES, COL ? 00047801 &FPOS SETA (((&POS(1)-1)*(&COLS))+(&POS(2)-1)) YES, CONVERT IT @ 00047901 AGO .PO0030 @ 00048001 .PO0020 ANOP @ 00048101 AIF (&FPOS-&EPOS GT 0).PO0030 WILL FIELD OVERLAP? * 00048201 MNOTE 4,'POSITION ADJUSTED TO PREVENT FIELD OVERLAY' * 00048301 &FPOS SETA &EPOS+1 PREVIOUS ENDING POS + ONE * 00048401 AGO .PO0040 BYPASS FOLLOWING CODE * 00048501 .PO0030 ANOP 00048601 AIF (&SKIP).PO0040 WAS PREV FIELD ATR = SKIP ??? 00048701 AIF (&FPOS-&EPOS EQ 1).PO0040 IF ONLY ONE BYTE -- * 00048801 DC X'1D7C' CAUSE SKIP FROM LAST FIELD * 00048901 .PO0040 ANOP GAP FIELD GENERATION RETURN PT 00049001 &EPOS SETA (&FPOS+&GLENGTH) CALCULATE ENDING POSITION * 00049101 AIF (&SCRSIZE LT &EPOS).ERR080 OUTSIDE OF PAGE ? * 00049201 .PO0060 ANOP NO, END OF POSITION OPERAND @ 00049301 AIF (&FPOS GE &PREVPOS).PO0070 ARE FIELDS IN SEQUENCE ? @ 00049401 &SEQ SETB 1 NO, SET OUT OF SEQUENCE IND @ 00049501 AGO .ERR170 THEN TERMINATE THIS EXPANSION @ 00049601 .PO0070 ANOP YES, BYPASS OUT OF SEQ IND @ 00049701 &PREVPOS SETA &FPOS SET NEW PREVIOUS POSITION @ 00049801 .AT0000 ANOP END OF POSITION AND SEQUENCE CHECK @ 00049901 .********************************************************************** 00050001 .* ANALYZE SPECIFICATION OF ATR OPERAND * 00050101 .********************************************************************** 00050201 &ATRC SETC '40' INITIALIZE 3270 ATTRIBUTE CHAR @ 00050301 &SKIP SETB 0 RESET SKIP OPTION @ 00050401 &PROT SETB 0 RESET PROT OPTION @ 00050501 &INDEX SETA 1 00050601 &HIGH SETA 10 00050701 &IC SETB 0 00050801 &ARG SETA 0 00050901 AIF (T'&ATR EQ 'O').AT0040 00051001 .AT0010 ANOP 00051101 &COUNT SETA &COUNT+1 00051201 AIF (&COUNT GT &HIGH).ERR100 00051301 AIF ('&ATR(&INDEX)'(1,2) EQ '**SKIPROUNPNUMDETBRTDRKMDTIC NO*00051401 R'(3*&COUNT,2)).AT0030 00051501 AGO .AT0010 00051601 .AT0020 ANOP 00051701 AIF (&INDEX EQ N'&ATR).AT0050 00051801 &INDEX SETA &INDEX+1 00051901 &COUNT SETA 0 00052001 AGO .AT0010 00052101 .* 00052201 .* SET X MATRIX FOR CHARACTER DISPLACEMENT. 00052301 .* 00052401 .AT0030 ANOP 00052501 &XON SETB 1 00052601 &X(&COUNT) SETB 1 00052701 &Y(&COUNT) SETA &INDEX 00052801 AGO .AT0020 00052901 .AT0040 ANOP 00053001 &X(1) SETB 1 00053101 &XON SETB 1 00053201 .* 00053301 .* ANALYZE THE MATRIX 00053401 .* 00053501 .AT0050 ANOP 00053601 AIF (&XON).AT0060 00053701 &X(1) SETB 1 00053801 .AT0060 ANOP 00053901 .* 00054001 .* OUTPUT ANALYSIS. 00054101 .* 00054201 &A SETA 1 SKIP 00054301 &B SETA 3 UNPROTECTED 00054401 AIF (&X(1) AND &X(3)).ERR110 SKIP/UNPROTECTED ??? 00054501 &A SETA 2 PROTECT 00054601 AIF (&X(2) AND &X(3)).ERR110 PROTECTED/UNPROTECTED 00054701 &A SETA 5 SELECTER PEN DETECTABLE 00054801 &B SETA 7 DARK (NON-DETECTABLE) 00054901 AIF (&X(5) AND &X(7)).ERR110 DETECTABLE/DARK ??? 00055001 &A SETA 6 BRIGHT 00055101 AIF (&X(6) AND &X(7)).ERR110 BRIGHT/DARK ??? 00055201 &B SETA 10 NORMAL 00055301 AIF (&X(6) AND &X(10)).ERR110 BRIGHT/NORMAL ??? 00055401 &A SETA 7 DARK 00055501 AIF (&X(7) AND &X(10)).ERR110 DARK/NORMAL ??? 00055601 AIF (&X(1) AND &X(9)).ERR120 SKIP/IC ??? 00055701 AIF (&X(2) AND &X(9)).ERR120 PROT/IC ??? 00055801 AIF (&X(2) AND &X(4)).ERR130 PROT/NUM ??? 00055901 .* 00056001 .* SET ATTRIBUTE BITS 00056101 .* 00056201 .AT0070 ANOP 00056301 &NUMERIC SETB (&X(4)) SET NUMERIC FIELD INDICATOR 00056401 &X(2) SETB (&X(1) OR &X(2)) PROT IF SKIP. 00056501 &X(4) SETB (&X(1) OR &X(4)) NUM IF SKIP 00056601 &X(5) SETB (&X(7) OR (&X(5) AND NOT &X(6))) SET IF DARK OR LGHT PEN 00056701 &X(6) SETB (&X(7) OR &X(6)) BRT IF DARK. 00056801 &IC SETB (&X(9)) IC IF REQUESTED 00056901 &ARG SETA (32*&X(2)+16*&X(4)+4*&X(5)+8*&X(6)+&X(8)) 00057001 &KEYED SETB (&X(3)) FLAG AS KEYABLE IF UNPROTECTED. 00057101 &PROT SETB (&X(2) OR &X(1)) SET TO ONE IF ATR = PROT OR SKIP 00057201 &SKIP SETB (&X(1)) SET TO ONE IF ATR = SKIP 00057301 AGO .AT0100 00057401 .AT0090 ANOP 00057501 &X(&C) SETB 0 CLEAR 00057601 &C SETA &C+1 DOWN 00057701 AIF (&C LT 11).AT0090 X TABLE. 00057801 AGO .AT0070 00057901 .AT0100 ANOP END OF ATR ANALYSIS 00058001 AIF (T'&FLDNAME EQ 'O').AT0110 FIELD NAME OMITTED @ 00058101 &FN SETC '&FLDNAME'(1,8) USE FIRST 8 CHAR FOR NAME @ 00058201 &DATAIND SETB ('&FN' NE '') INDICATE DATA ITEM (LABEL) @ 00058301 AGO .AT0120 BYPASS NEXT TEST @ 00058401 .AT0110 ANOP FIELD NAME BYPASS @ 00058501 AIF ((NOT &BUFFTB) OR (&SKIP) OR (&PROT)).AT0120 00058601 MNOTE 4,'MAP NAME REQUIRED WITH ''BUFFTAB'' OPTION, DEFAULT NA$00058701 ME GENERATED' 00058801 AIF (NOT &SKIP).AT0110 00058901 &FN SETC 'FLD&SYSNDX' GENERATE DEFAULT NAME 00059001 .AT0120 ANOP 00059101 .********************************************************************** 00059201 .* CONVERT THE BINARY ATR TO A VALID 3270 TRANSMITTABLE CHAR * 00059301 .********************************************************************** 00059401 &ATRC SETC '&ADDRCHR'((&ARG+1)*2,2) SELECT ATTRIBUTE CHARACTER * 00059501 .DE0000 ANOP END OF ATTRIBUTE CONVERSION @ 00059601 .********************************************************************** 00059701 .* DATA DECLARATION GENERATION * 00059801 .********************************************************************** 00059901 .LO0000 ANOP END OF JUSTIFY PARAMETER @ 00060001 .********************************************************************** 00060101 .* SET CURRENT OUTPUT FIELD LOCATION COUNTER * 00060201 .********************************************************************** 00060301 AIF (NOT &DATAIND).LO0020 BYPASS FOR NON DATA FIELDS * 00060401 AIF (T'&LOC EQ 'O').LO0010 LOCATION NOT GIVEN, USE DEFAULT 00060501 &NLOC SETA &LOC SET CURRENT LOCATION COUNTER * 00060601 &PLOC SETA (&NLOC+(&GLENGTH)) SET NEXT TO CUR PLUS LENGTH * 00060701 AGO .LO0020 CONTINUE * 00060801 .LO0010 ANOP DEFAULT TO CURRENT COUNT * 00060901 &NLOC SETA &PLOC USE PREVIOUS COUNT * 00061001 &PLOC SETA (&NLOC+(&GLENGTH)) SET NEXT TO CUR PLUS LENGTH * 00061101 .LO0020 ANOP END OF LOCATION COUNT SETUP * 00061201 AGO .GN0010 GO TO FIELD GENERATION @ 00061301 .GN0000 ANOP FIELD GENERATION @ 00061401 .********************************************************************** 00061501 .* GENERATE SKIP (END OF LINE) FIELD ENTRY * 00061601 &XAXIS SETA (&EPOS/64+1) 00061701 &YAXIS SETA (&EPOS-(&XAXIS-1)*64+1) 00061801 &XCHAR SETC '&ADDRCHR'(&XAXIS*2,2) 00061901 &YCHAR SETC '&ADDRCHR'(&YAXIS*2,2) 00062001 .********************************************************************** 00062101 DC XL1'11' FIELD DESCRIPTOR FLAG BYTE @ 00062201 DC X'&XCHAR&YCHAR' FIELD POSITION * 00062301 DC CL1'0' FIELD ATTRIBUTE @ 00062401 *---------------------------------------------------------------------* 00062501 AGO .PO0030 00062601 .GN0010 ANOP FIELD GENERATION @ 00062701 .********************************************************************** 00062801 .* GENERATE FIELD ENTRY * 00062901 &XAXIS SETA (&FPOS/64+1) 00063001 &YAXIS SETA (&FPOS-(&XAXIS-1)*64+1) 00063101 &XCHAR SETC '&ADDRCHR'(&XAXIS*2,2) 00063201 &YCHAR SETC '&ADDRCHR'(&YAXIS*2,2) 00063301 .********************************************************************** 00063401 DC XL1'11' START BUFFER ADDRESS CHARACTER * 00063501 DC X'&XCHAR&YCHAR' FIELD POSITION * 00063601 DC XL1'1D' START FIELD CHARACTER * 00063701 DC XL1'&ATRC' FIELD ATTRIBUTE * 00063801 AIF (NOT &DEFAULT).GN0050 IS INITIAL = DEFAULT DATA ? @ 00063901 &FN DC CL&GLENGTH.&INITIAL 00064001 AGO .GN0060 GO TO NEXT OPTION * 00064101 .GN0050 ANOP INITIAL = DEFAULT DATA BYPASS @ 00064201 &FN DS 0CL&GLENGTH 00064301 DC &GLENGTH.XL1'&FILLCHR.' 00064401 .GN0060 ANOP INITIAL = DEFAULT DATA BYPASS @ 00064501 *********************************************************************** 00064601 AIF (((NOT &KEYED) AND (&CURSOR NE 0)) OR (NOT &IC)).GN0070 00064701 &CURSOR SETA &FPOS+1 UPDATE CURSOR POSITION @ 00064801 .GN0070 ANOP END OF FIELD GENERATION @ 00064901 AIF (((NOT &BUFFTB) AND (NOT &KEYED)) OR (&PROT)).MAPXIT 00065001 &FPOS SETA &FPOS+1 BUMP TO ACTUAL FIELD 00065101 &XAXIS SETA (&FPOS/64+1) 00065201 &YAXIS SETA (&FPOS-(&XAXIS-1)*64+1) 00065301 &XCHAR SETC '&ADDRCHR'(&XAXIS*2,2) 00065401 &YCHAR SETC '&ADDRCHR'(&YAXIS*2,2) 00065501 &ENTS SETA &ENTS+1 BUMP ENTRY COUNT 00065601 &ENTRBA(&ENTS) SETC '&XCHAR&YCHAR' SET RBA 00065701 &ENTLEN(&ENTS) SETA &GLENGTH-1 SET LENGTH-1 00065801 &ENTOFF(&ENTS) SETC '&FN-&MAPNAME' DEFINE OFFSET FOR ADCON 00065901 &ENTVCN(&ENTS) SETA 0 INSURE UNUSED IS ZERO 00066001 AIF (T'&VALUES EQ 'O').MAPXIT 00066101 .GN0080 ANOP 00066201 AIF (&ENTVCN(&ENTS) EQ 3).MAPXIT 00066301 &ENTVCN(&ENTS) SETA &ENTVCN(&ENTS)+1 BUMP COUNTER 00066401 &VALCNT SETA &VALCNT+1 BUMP COUNTER 00066501 &ENTVAL(&VALCNT) SETC '&VALUES(&ENTVCN(&ENTS))' MOVE PARAMETER 00066601 AIF (&ENTVCN(&ENTS) LT N'&VALUES).GN0080 00066701 .MAPXIT ANOP END OF FIELD GENERATION @ 00066801 &FN SETC '' INITIALIZE FLDNAME GLOBAL @ 00066901 &DEFAULT SETB 0 INITIALIZE DEFAULT DATA GLOBAL @ 00067001 &DATAIND SETB 0 INITIALIZE DATA (FIELD) INDICATOR @ 00067101 &PEN SETB 0 INITIALIZE PEN DETECTABLE GLOBL @ 00067201 &IC SETB 0 INITIALIZE INSERT CURSOR GLOBAL @ 00067301 &KEYED SETB 0 INIT UNPROTECTED FIELD GLOBAL @ 00067401 &NUMERIC SETB 0 INITIALIZE NUMERIC FIELD GLOBAL @ 00067501 MEXIT EXIT MACRO @ 00067601 .********************************************************************** 00067701 .*** GENERATE FINAL DSECT AND ADDRESS TABLES *** 00067801 .********************************************************************** 00067901 .FI0000 ANOP FINAL ENTRIES @ 00068001 AIF ((&SKIP) OR (&PROT)).FI0010 WAS PREV FIELD ATR = SKIP * 00068101 &EPOS SETA &EPOS+1 BUMP BY ONE TO MISS PREV FIELD * 00068201 &XAXIS SETA (&EPOS/64+1) 00068301 &YAXIS SETA (&EPOS-(&XAXIS-1)*64+1) 00068401 &XCHAR SETC '&ADDRCHR'(&XAXIS*2,2) 00068501 &YCHAR SETC '&ADDRCHR'(&YAXIS*2,2) 00068601 DC XL1'11' FIELD DESCRIPTOR FLAG BYTE @ 00068701 DC X'&XCHAR&YCHAR' FIELD POSITION * 00068801 DC XL1'1D' START FIELD INDICATOR * 00068901 DC XL1'F0' FIELD ATTRIBUTE 00069001 *********************************************************************** 00069101 .FI0010 ANOP * 00069201 &MAP SETB 0 SET OFF AFTER FINAL @ 00069301 .********************************************************************** 00069401 AIF (&CURSOR EQ 0).FI0020 NO CURSOR! KMB 00069501 * SET CURSOR POSITION * 00069601 &XAXIS SETA (&CURSOR/64+1) 00069701 &YAXIS SETA (&CURSOR-(&XAXIS-1)*64+1) 00069801 &XCHAR SETC '&ADDRCHR'(&XAXIS*2,2) 00069901 &YCHAR SETC '&ADDRCHR'(&YAXIS*2,2) 00070001 &FN SETC '' 00070101 AIF (T'&FLDNAME EQ 'O').CR0000 WAS NAME SPECIFIED? 00070201 &FN SETC '&MAPNAME'(1,5) SET DEFAULT VALUE 00070301 &FNM SETC 'CSR' SET DEFAULT VALUE 00070401 &FN SETC '&FN&FNM' SET DEFAULT VALUE 00070501 .CR0000 ANOP 00070601 DC XL1'11' START BUFFER ADDRESS CHARACTER * 00070701 &FN DC X'&XCHAR&YCHAR' FIELD POSITION * 00070801 DC XL1'13' INSERT CURSOR INDICATOR * 00070901 &CURSOR SETA 0 RESET CURSOR POSITION * 00071001 *********************************************************************** 00071101 .FI0020 ANOP 00071201 AIF (T'&EQU EQ 'O').FI0040 00071301 &FN SETC '&EQU' 00071401 &FN EQU *-&MAPNAME 00071501 .FI0040 ANOP 00071601 AIF ((NOT &BUFFTB) OR (&ENTS EQ 0)).MEXIT KMB 00071701 .********************************************************************** 00071801 AIF (T'&FLDNAME NE 'O').FI0100 WAS NAME SPECIFIED? 00071901 &FN SETC '&MAPNAME'(1,4) SET DEFAULT VALUE 00072001 &FN SETC '&FN&SYSNDX' SET DEFAULT VALUE 00072101 AGO .FI0110 GO PROCESS NEXT ONE 00072201 .FI0100 ANOP 00072301 &FN SETC '&FLDNAME' USE NAME SPECIFIED INSTEAD 00072401 .FI0110 ANOP 00072501 EJECT 00072601 *********************************************************************** 00072701 * THIS TABLE IS GENERATED FOR THE USER WHEN A MAP OF ALL * 00072801 * MODIFIABLE ENTRIES IN A '$FLD' LIST IS REQUIRED. THIS MAP * 00072901 * CONTAINS THE FOLLOWING ENTRIES: * 00073001 * * 00073101 * XL2(....) THE BUFFER ADDRESS OF THIS FIELD * 00073201 * AL2(..) THE OFFSET INTO THE MAP, OF THIS FIELD * 00073301 * AL2(..) THE LENGTH-1 OF THIS FIELD * 00073401 * * 00073501 *********************************************************************** 00073601 CNOP 2,4 ALIGN ON HALFWORD BOUND 00073701 DC H'&ENTS' TOTAL NUMBER OF ENTRIES 00073801 &FN DS 0F LISTING OF BUFFER ADDRESS TABLE 00073901 .FI0120 ANOP 00074001 &LSTCNT SETA &LSTCNT+1 BUMP ENTRY LSTCNT 00074101 AIF ((&LSTCNT GT &ENTS) OR (&LSTCNT GT &ENTMAX)).FIEXIT 00074201 DC XL2'&ENTRBA(&LSTCNT)' BUFF ADDR OF CURRENT ENTRY 00074301 DC AL2(&ENTOFF(&LSTCNT)) OFFSET OF CURRENT ENTRY 00074401 DC H'&ENTLEN(&LSTCNT)' LENGTH OF CURRENT ENTRY - 1 00074501 AIF (&ENTVCN(&LSTCNT) EQ 0).FI0120 00074601 .FI0130 ANOP 00074701 &TCNT1 SETA &TCNT1+1 00074801 DC &ENTVAL(&TCNT1) VALUES PARAMETER 00074901 AIF (&TCNT1 LT &ENTVCN(&LSTCNT)).FI0130 00075001 AGO .FI0120 GO PROCESS NEXT ONE 00075101 .FIEXIT ANOP 00075201 MNOTE *,'BEG-FIEXIT' 00075301 &TCNT1 SETA (K'&FLDNAME) 00075401 AIF (&TCNT1 LE 6).FIEX01 00075501 &TCNT1 SETA 6 00075601 .FIEX01 ANOP 00075701 &FILLCHR SETC '&FN' 00075801 &FN SETC '&FILLCHR'(1,&TCNT1) 00075901 &FNM SETC 'EL' 00076001 &FN SETC '&FN&FNM' 00076101 &FN EQU ((*-&FILLCHR)/&ENTS) LENGTH OF EACH ENTRY 00076201 DC X'FFFF' END OF TABLE 00076301 SPACE 00076401 &ENTS SETA 0 RESET ENTRY COUNT 00076501 *********************************************************************** 00076601 .MEXIT ANOP HERE TO EXIT MACRO * 00076701 MEXIT EXIT MACRO @ 00076801 .********************************************************************** 00076901 .* * MNOTE STATEMENTS * * 00077001 .********************************************************************** 00077101 .ERR010 ANOP TYPE IN ERROR @ 00077201 MNOTE 12,'TYPE = FINAL IS PREVIOUSLY SPECIFIED,' @ 00077301 AGO .MAPXIT TERMINATE @ 00077401 MEXIT MACRO EXIT @ 00077501 .ERR020 ANOP LENGTH OPERAND ERROR ENTRY @ 00077601 MNOTE 12,'INVALID LENGTH OPERAND IS SPECIFIED,' @ 00077701 MNOTE *,'MACRO REQUEST IS IGNORED,' @ 00077801 MNOTE *,'VALID LENGTH OPERAND IS REQUIRED.' 00077901 &ABORT SETB 1 TURN ON ABORT INDICATOR @ 00078001 AGO .MAPXIT TERMINATE GENERATION @ 00078101 .ERR030 ANOP POS OPERAND ERROR ENTRY @ 00078201 MNOTE 12,'INVALID POS OPERAND IS SPECIFIED,' @ 00078301 .ERR055 ANOP POS OPERAND MNOTE ENTRY @ 00078401 MNOTE *,'MACRO REQUEST IS IGNORED,' @ 00078501 MNOTE *,'VALID POS OPERAND IS REQUIRED WITH MAP MACRO.' @ 00078601 &ABORT SETB 1 TURN ON ABORT INDICATOR @ 00078701 AGO .AT0000 GO TO POS OPERAND COMPLETION @ 00078801 .ERR070 ANOP INITIAL OPERAND ERROR ENTRY @ 00078901 MNOTE 8,'INVALID INITIAL OPERAND IS SPECIFIED,' @ 00079001 MNOTE *,'DEFAULT DATA MUST BE ENCLOSED IN QUOTES,' @ 00079101 MNOTE *,'INITIAL OPERAND IS IGNORED.' @ 00079201 AGO .LG0020 GO TO INITIAL OPERAND BYPASS @ 00079301 .ERR080 ANOP FIELD SPECIFICATION ERROR ENTRY @ 00079401 MNOTE 8,'FIELD IS DEFINED OUTSIDE OF THE SIZE OPERAND' @ 00079501 MNOTE *,'MACRO REQUEST IS IGNORED.' @ 00079601 &ABORT SETB 1 TURN ON ABORT INDICATOR @ 00079701 AGO .PO0020 GO TO PAGE SIZE BYPASS @ 00079801 .ERR100 ANOP ATR PARAMETER ERROR ENTRY 00079901 MNOTE 4,'INVALID ATTRIBUTE PARAMETER IS SPECIFIED,' 00080001 MNOTE *,'ATR = &ATR(&INDEX) IS IGNORED.' 00080101 AGO .AT0020 GO TO CHECK INDEX 00080201 .ERR110 ANOP INCOMPATIBLE ATR OP ERROR 00080301 &A SETA &Y(&A) SET PARAMETER INDEX VALUE 00080401 &B SETA &Y(&B) SET PARAMETER INDEX VALUE 00080501 MNOTE 4,'&ATR(&A) AND &ATR(&B) ARE INCOMPATIBLE PARAMETERS,' 00080601 MNOTE *,'ATR = &ATR(&A) IS IGNORED,' 00080701 MNOTE *,'ATR = &ATR(&B) IS IGNORED,' 00080801 MNOTE *,'ATR = SKIP IS ASSUMED BY DEFAULT.' 00080901 &X(1) SETB 1 SKIP DEFAULT. 00081001 &C SETA 2 SET C FOR CLEARING X TABLE. 00081101 AGO .AT0090 00081201 .ERR120 ANOP ATR = IC ERROR ENTRY 00081301 MNOTE *,'ATR = IC IS REQUESTED FOR PROTECTED FIELD' 00081401 AGO .AT0070 00081501 .ERR130 ANOP ATR = PROT AND NUM ERROR 00081601 MNOTE *,'ATR = PROT AND NUM ALSO IMPLIES THE SKIP PARAMETER' 00081701 AGO .AT0070 00081801 .ERR150 ANOP HERE FOR ERROR * 00081901 MNOTE 8,'INVALID TYPE SPECIFIED' * 00082001 .ERR160 ANOP HERE FOR ERROR * 00082101 MNOTE 8,'MODEL OPERAND IS REQUIRED && MINIMUM LENGTH IS 6' * 00082201 MEXIT 00082301 .ERR170 ANOP HERE FOR ERROR * 00082401 MNOTE 16,'SEQUENCE ERROR ENCOUNTERED, EXPANSION TERMINATED' * 00082501 MEXIT 00082601 .ERR200 ANOP HERE FOR ERROR * 00082701 MNOTE 8,'INVALIB ''BUFFTAB'' SPECIFICATION' * 00082801 MEXIT 00082901 .ERR190 ANOP HERE FOR ERROR * 00083001 MNOTE 8,'MAP NAME REQUIRED WITH ''BUFFTAB'' OPTION' * 00083101 MEXIT 00083201 MEND 00083301 *--------------------------------------------------------------------* 00083401 * $AUTHON MACRO * 00083501 *--------------------------------------------------------------------* 00083601 MACRO 00083700 &L $AUTHON 00083800 &L LA R1,=C'AUTH' 00083900 SVC $ATH$ 00084007 MEND 00084100 *--------------------------------------------------------------------* 00084201 * $AUTHOFF MACRO * 00084301 *--------------------------------------------------------------------* 00084401 MACRO 00084500 &L $AUTHOFF 00084600 &L LA R1,=C'NONE' 00084700 SVC $ATH$ 00084807 MEND 00084900 ZAPDSCB TITLE 'THIS PROGRAM WILL ALLOW THE USER THE ABILITY TO MODIFY A00085000 DSCB' 00085100 *--------------------------------------------------------------------* 00085200 * DON'T KNOW WHO WROTE THIS ORIGINALLY * 00085300 * FULL SCREEN VTOC ZAPPER. * 00085400 * * 00085500 *--------------------------------------------------------------------* 00085600 * CHANGE LOG: * 00085700 * SAM BASS (KBASS) * 00085800 * BMC SOFTWARE INC * 00085900 * MCLANE CO. INC. * 00086000 * * 00086100 * KBASS ONLY ALLOW GROUP OF SYS1 TO DO THIS * 00086200 * 21DEC94 KBASS ADD OPTCD DISPLAY * 00086300 * 30OCT95 KBASS USE UCBLOOK MACRO TO SUPPORT DYNAMIC DASD * 00086400 *--------------------------------------------------------------------* 00086500 ZAPDSCB AMODE 31 00086602 ZAPDSCB RMODE 24 00086702 ZAPDSCB CSECT 00087000 SAVE (14,12),,ZAPDSCB.&SYSDATE..&SYSTIME. 00090000 LR R11,R15 LOAD PGM'S BASE REG 00100000 USING ZAPDSCB,R11 00110000 LA R14,SAVEAREA A(MY SAVEAREA) 00120000 ST R14,8(,R13) UPDATE FORWARD POINTER 00130000 ST R13,4(,R14) UPDATE BACKWARD POINTER 00140000 LR R13,R14 AND LOAD MY SAVEAREA BASE 00150000 USING SAVEAREA,R13,R12 AND DEFINE SAME TO ASSEMBLER 00160000 LA R12,2048(,R13) COMPUTE SECOND 00170000 LA R12,2048(,R12) BASE REG ADDRESS 00180000 LR R2,R1 SAVE CPPL ADDRESS 00190000 $AUTHON 00200000 *********************************************************************** 00220000 * INITIALIZE * 00230000 *********************************************************************** 00240000 MVC UCBTOKEN,ALLZEROS 30OCT95 00250000 MVC UCBADDR,ALLZEROS 30OCT95 00260000 SPACE 00270000 *********************************************************************** 00280000 * LOCATE THE USER'S ASCB AND SAVE THE USERID * 00290000 *********************************************************************** 00300000 L R15,PSAAOLD-PSA(00) A(PSA ASCB) KBASS 00310003 L R15,ASCBASXB-ASCB(R15) A(ASXB) KBASS 00320003 L R15,ASXBSENV-ASXB(R15) A(ASCB) KBASS 00330003 CLC =C'SYS1',ACEEGRPN-ACEE(R15) COPY THE USERID KBASS 00340003 BNE BADBOY KBASS 00340103 MVC USERID,ACEEUSER-ACEE(R15) COPY THE USERID KBASS 00341003 MVC DEFCSRAD,DSCBPCSR SAVE INITIAL CURSOR BUFF ADDR 00350000 SPACE 00360000 *********************************************************************** 00370000 * INITIATE FULL SCREEN PROCESSING * 00380000 *********************************************************************** 00390000 STFSMODE ON,INITIAL=YES INITIATE FULL SCREEN PROCESSING 00400000 EJECT 00410000 *********************************************************************** 00420000 * SETUP THE CVAF HEADER AND BUFFER LISTS * 00430000 *********************************************************************** 00440000 XC CVAFBUF(BFLHLN+BFLELN),CVAFBUF RESET BUFFER HEADER 00450000 OI BFLHFL,BFLHDSCB INDICATE READ DSCB'S 00460000 MVI BFLHNOE,1 NUMBER OF BUFFER LIST ENTRIES 00470000 LA R15,DS1FMTID A(DSCB DATA AREA) 00480000 ST R15,BFLEBUF AND UPDATE BUFFER LIST 00490000 MVI BFLELTH,LDSCB-44 LENGTH OF DATA AREA (DSCB-44) 00500000 SPACE 00510000 *********************************************************************** 00520000 * COPY THE DATA SET NAME FROM THE COMMAND BUFFER TO THE DATA * 00530000 * SET NAME FIELD ON THE PANEL ADDING THE USER ID, IF NECESSARY * 00540000 *********************************************************************** 00550000 L R2,CPPLCBUF-CPPL(R2) LOAD COMMAND BUFFER ADDRESS 00560000 SLR R3,R3 CLEAR WORK REGISTER 00570000 SLR R4,R4 CLEAR WORK REGISTER 00580000 ICM R3,B'0011',0(R2) LENGTH OF COMMAND BUFFER 00590000 ICM R4,B'0011',2(R2) OFFSET TO FIRST OPERAND 00600000 SR R3,R4 COMPUTE LENGTH OF OPERAND 00610000 SPACE 00620000 SH R3,=H'04' AND DECREMENT FOR LENGTH FLD 00630000 BP CPPL010 DATA SET NAME SUPPLIED? 00640000 LA R15,DSNAMEER NO, ADDRESS ERROR MESSAGE 00650000 B PROCEMSG GO PROCESS ERROR MESSAGE 00660000 SPACE 00670000 CPPL010 DS 0H 00680000 CH R3,=H'46' LENGTH GREATER THAN MAX? 00690000 BNH CPPL020 NO, BYPASS DEFAULT 00700000 LA R15,DSNLNGER PROVIDE FOR ERROR MSG 00710000 B PROCEMSG YES, GENERATE ERROR MESSAGE 00720000 SPACE 00730000 CPPL020 DS 0H 00740000 STH R3,LDSNAME SAVE LENGTH OF DSNAME 00750000 BCTR R3,00 DECREMENT FOR EXECUTE 00760000 LA R4,4(R2,R4) ADDRESS DATA SET NAME 00770000 EX R3,EXOCINPT CONVERT TO UPPER CASE 00780000 EJECT 00790000 MVC PDSNAME,ALLZEROS MOVE IN ALL BLANKS 00800000 MVC DS1DSNAM,ALLBLANK MOVE IN ALL BLANKS 00810000 LA R15,PDSNAME A(PANEL DSNAME) 00820000 LA R14,DS1DSNAM A(DSCB DSNAME) 00830000 CLI 0(R4),C'''' DOES DSN BEGIN WITH A QUOTE 00840000 BNE NOQUOTES NO, DO NOT PROCESS QUOTES 00850000 EX R3,EXMVCPDS MOVE DSN INTO PANEL 00860000 LA R4,1(,R4) YES, BYPASS FIRST QUOTE 00870000 BCTR R3,00 DECREMENT FOR FIRST QUOTE 00880000 STH R3,LDSNAME SAVE NEW LENGTH OF DSNAME 00890000 BCTR R3,00 DECREMENT FOR LAST QUOTE 00900000 EX R3,EXMVCDS1 MOVE DSN INTO DSCB 00910000 B DSNMOVED 00920000 SPACE 00930000 EXMVCPDS OC 0(0,R15),0(R4) MOVE IN DATA SET NAME 00940000 EXMVCDS1 OC 0(0,R14),0(R4) MOVE IN DATA SET NAME 00950000 PDSUSERI MVC 0(0,R15),USERIDI MOVE IN USERID 00960000 DS1USERI MVC 0(0,R14),USERIDI MOVE IN USERID 00970000 EXOCINPT OC 0(0,R4),ALLBLANK EXECUTED OC 00980000 SPACE 00990000 NOQUOTES DS 0H 01000000 SLR R1,R1 CLEAR WORK REG 01010000 IC R1,USERIDL AL2(LENGTH OF USERID) 01020000 SPACE 01030000 LA R5,2(,R1) USERID + DELIMITER + BCTR OFFSET 01040000 AR R5,R3 + LENGTH OF DSNAME 01050000 STH R5,LDSNAME SAVE COMPUTED LENGTH OF DSNAME 01060000 CH R5,=H'46' IS DSNAME GT FIELD LENGTH? 01070000 BNH DSN010 NO, CONTINUE PROCESSING 01080000 LA R15,DSNLNGER YES, PROVIDE FOR ERROR MSG 01090000 B PROCEMSG AND DISPLAY SAME 01100000 SPACE 01110000 DSN010 DS 0H 01120000 BCTR R1,0 DECREMENT FOR EXECUTE 01130000 MVI 0(R15),C'''' MOVE IN A QUOTE 01140000 LA R15,1(,R15) AND ADJUST FOR SAME 01150000 EX R1,DS1USERI MOVE USERID TO DSNAME 01160000 EX R1,PDSUSERI MOVE USERID TO DSNAME 01170000 LA R14,1(R1,R14) AND ADJUST FOR SAME 01180000 LA R15,1(R1,R15) AND ADJUST FOR SAME 01190000 MVI 0(R14),C'.' MOVE IN A DELIMITER 01200000 MVI 0(R15),C'.' MOVE IN A DELIMITER 01210000 LA R14,1(,R14) AND ADJUST FOR SAME 01220000 LA R15,1(,R15) AND ADJUST FOR SAME 01230000 EX R3,EXMVCPDS MOVE DSN INTO PANEL 01240000 EX R3,EXMVCDS1 MOVE DSN INTO DSCB 01250000 LA R15,1(R3,R15) AND ADJUST FOR SAME 01260000 MVI 0(R15),C'''' MOVE IN A QUOTE 01270000 DSNMOVED DS 0H 01280000 EJECT 01290000 *********************************************************************** 01300000 * LOCATE THE DATA SET CATALOG ENTRY * 01310000 *********************************************************************** 01320000 LOCATELP DS 0H LOCATE LOOP 01330000 MVC LOCWORK(256),ALLZEROS CLEAR FIRST HALF OF WORK 01340000 XC LOCWORK+256(256),ALLZEROS CLEAR LAST HALF OF WORK 01350000 MVC PVOLSER,ALLZEROS CLEAR VOLSER FIELD 01360000 LOCATE DSNLOC LOCATE DATA SET 01370000 LTR R15,R15 WAS DATA SET FOUND? 01380000 BZ LOC010 YES, BYPASS ERROR MESAGE 01390000 LA R15,DSNLOCER NO, ADDRESS ERROR MESSAGE 01400000 B PROCEMSG GO PROCESS ERROR MESSAGE 01410000 LOC010 DS 0H 01420000 MVC PVOLSER,LOCWORK+6 SAVE VOL SER 01430000 SPACE 01440000 *********************************************************************** 01450000 * USING THE UCB LOOKUP PROCESS, LOCATE THE UCB ASSOCIATED WITH * 01460000 * THE VOLUME SERIAL NUMBER RETRIEVED FORM THE LOCATE PROCESS. * 01470000 *********************************************************************** 01480000 UCBLKPLP DS 0H UCB LOOKUP LOOP 01490000 OC UCBTOKEN,UCBTOKEN 30OCT95 01500000 BZ UCBPIN10 30OCT95 01510000 MODESET MODE=SUP 30OCT95 01520000 UCBPIN UNPIN,PTOKEN=UCBTOKEN, 30OCT95X01530000 MF=(E,XUCBPIN) 30OCT95 01540000 MVC UCBTOKEN,ALLZEROS 30OCT95 01550000 MVC UCBADDR,ALLZEROS 30OCT95 01560000 MODESET MODE=PROB 30OCT95 01570000 UCBPIN10 DS 0H 30OCT95 01580000 MODESET MODE=SUP 30OCT95 01590000 UCBLOOK VOLSER=PVOLSER,UCBPTR=UCBADDR, 30OCT95X01600000 PIN, 30OCT95X01610000 PTOKEN=UCBTOKEN, 30OCT95X01620000 TEXT==CL58'ZAPDSCB IN PROGESS', 30OCT95X01630000 DYNAMIC=YES,RANGE=ALL,LOC=ANY, 30OCT95X01640002 MF=(E,XUCBLOOK) 30OCT95 01650000 LR R5,R15 UCB ADDR RETURNED? 30OCT95 01660000 MODESET MODE=PROB 30OCT95 01670000 LTR R15,R5 UCB ADDR RETURNED? 30OCT95 01680000 BZ CHECKUCB NO, ERROR 30OCT95 01690000 SPACE 1 30OCT95 01700000 UCBMSG DS 0H 30OCT95 01710000 LA R15,UCBERMSG A(VOL SER MISSING ERROR MESSAGE) 01720000 B PROCEMSG GO PROCESS ERROR MESSAGE 01730000 SPACE 01740000 USING UCBOB,15 01750000 CHECKUCB DS 0H CHECK FOR MATCHING VOLSER 01760000 L R15,UCBADDR A(UCB ADDRESS) 30OCT95 01770000 CLC PVOLSER,UCBVOLI MATCHING VOLSER? 01780000 BNE UCBMSG NO, ERROR 30OCT95 01790000 SPACE 01800000 OI MISCFLAG,NSHARED DEFAULT TO NON-SHARED DASD 01810000 TM UCBTBYT2,UCBRR IS IT ACTUALLY SHARED? 01820000 BZ UCB010 NO, BYPASS RESET 01830000 NI MISCFLAG,255-NSHARED YES, RESET NON-SHARED FLAG 01840000 UCB010 DS 0H 01850000 DROP 15 01860000 EJECT 01870000 *********************************************************************** 01880000 * DETERMINE WHAT TYPE OF ENQ TO USE. SYSTEM OR SYSTEMS * 01890000 *********************************************************************** 01900000 LA R1,MODELENQ A('SYSTEM' ENQ LIST) 01910000 TM MISCFLAG,NSHARED IS DASD DEVICE SHARED? 01920000 BO ENQ010 NO, USED DEFAULT ADDRESS 01930000 LA R1,MODESENQ A('SYSTEMS' ENQ LIST) 01940000 ENQ010 DS 0H 01950000 LA R2,DS1DSNAM A(RNAME FOR ENQ) 01960000 LH R3,LDSNAME LOAD LENGTH OF DSNAME 01970000 SPACE 01980000 *********************************************************************** 01990000 * DETERMINE IF THE DATA SET IS AVAILABLE. * 02000000 *********************************************************************** 02010000 NI MISCFLAG,255-ENQUEUE RESET ENQUEUE BIT 02020000 ENQ (,(R2),,(R3),),MF=(E,(1)) 02030000 SPACE 02040000 LTR R15,R15 IS RESOURCE AVAILABLE? 02050000 BZ ENQ020 YES, PROCESS DATA SET 02060000 OI MISCFLAG,ENQUEUE NO, INDICATE SAME 02070000 ENQ020 DS 0H 02080000 *********************************************************************** 02090000 * READ THE DSCB INTO STORAGE * 02100000 *********************************************************************** 02110000 L R2,UCBADDR LOAD UCB ADDRESS 02120000 CVAFDIR ACCESS=READ,UCB=(R2),MF=(E,CVAFREQ),BRANCH=(YES,PGM), $02130000 BUFLIST=CVAFBUF 02140000 LTR R15,R15 WAS READ SUCCESSFUL? 02150000 BZ CREATDTE YES, PROCESS DSCB 02160000 B CVAFPROC NO, PROCESSER ERROR RETURN 02170000 EJECT 02180000 *********************************************************************** 02190000 * COPY DATE FIELDS INTO THE PANEL * 02200000 *********************************************************************** 02210000 CREATDTE SLR R15,R15 CLEAR WORK REG 02220000 IC R15,DS1CREDT INSERT YEAR 02230000 CVD R15,DWORD AND CONVERT TO DECIMAL 02240005 LTR R15,R15 Y2K HAS IT BEEN INITIALIZED MCLANE 02240106 BNP CREDT01 Y2K NOPE 02240206 AP DWORD,=P'1900' Y2K MCLANE 02241005 CREDT01 DS 0H Y2K MCLANE 02242006 OI DWORD+7,15 INSURE PRINTABLE SIGN 02250005 UNPK PCREDT(4),DWORD+5(3) Y2K AND MOVE TO TARGET FIELDMCLANE 02260005 ICM R15,B'0011',DS1CREDT+1 INSERT DAY OF YEAR 02270000 CVD R15,DWORD AND CONVERT TO DECIMAL 02280000 OI DWORD+7,15 INSURE PRINTABLE SIGN 02290000 UNPK PCREDT+4(3),DWORD Y2K AND MOVE TO TARGET MCLANE 02300005 SPACE 02310000 REFDATE SLR R15,R15 CLEAR WORK REG 02320000 IC R15,DS1REFD INSERT YEAR 02330000 CVD R15,DWORD AND CONVERT TO DECIMAL 02340000 LTR R15,R15 Y2K HAS IT BEEN INITIALIZED MCLANE 02350005 BNP REFDT01 Y2K NOPE 02351005 AP DWORD,=P'1900' Y2K MCLANE 02351105 REFDT01 DS 0H Y2K MCLANE 02351205 OI DWORD+7,15 INSURE PRINTABLE SIGN 02352005 UNPK PREFD(4),DWORD+5(3) Y2K AND MOVE TO TARGET FIELD 02360005 ICM R15,B'0011',DS1REFD+1 INSERT DAY OF YEAR 02370000 CVD R15,DWORD AND CONVERT TO DECIMAL 02380000 OI DWORD+7,15 INSURE PRINTABLE SIGN 02390000 UNPK PREFD+4(3),DWORD Y2K AND MOVE TO TARGET MCLANE 02400005 SPACE 02410000 EXPIRDAT SLR R15,R15 CLEAR WORK REG 02420000 IC R15,DS1EXPDT INSERT YEAR 02430000 CVD R15,DWORD AND CONVERT TO DECIMAL 02440000 LTR R15,R15 Y2K HAS IT BEEN INITIALIZED MCLANE 02440105 BNP EXPIR01 Y2K NOPE 02440205 AP DWORD,=P'1900' Y2K MCLANE 02441005 EXPIR01 DS 0H Y2K MCLANE 02442005 OI DWORD+7,15 INSURE PRINTABLE SIGN 02450000 UNPK PEXPDT(4),DWORD+5(3) 72K AND MOVE TO TARGET MCLANE 02460005 ICM R15,B'0011',DS1EXPDT+1 INSERT DAY OF YEAR 02470000 CVD R15,DWORD AND CONVERT TO DECIMAL 02480000 OI DWORD+7,15 INSURE PRINTABLE SIGN 02490000 UNPK PEXPDT+4(3),DWORD Y2K AND MOVE TO TARGET MCLANE 02500005 EJECT 02510000 *********************************************************************** 02520000 * COPY DSORG INTO PANEL * 02530000 *********************************************************************** 02540000 MVC PDSORG,ALLZEROS CLEAR FIELD 02550000 TM DS1DSORG,DS1DSGIS INDEXED SEQUENTIAL? 02560000 BZ DSORG010 NO, TEST NEXT TYPE 02570000 MVC PDSORG(2),=C'IS' YES, INDICATE SAME 02580000 B TESTUNMV AND GO TEST UNMOVEABLE BIT 02590000 DSORG010 TM DS1DSORG,DS1DSGPS PHYSICAL SEQUENTIAL? 02600000 BZ DSORG020 NO, TEST NEXT TYPE 02610000 MVC PDSORG(2),=C'PS' YES, INDICATE SAME 02620000 B TESTUNMV AND GO TEST UNMOVEABLE BIT 02630000 DSORG020 TM DS1DSORG,DS1DSGDA DIRECT ORGANIZATION? 02640000 BZ DSORG030 NO, TEST NEXT TYPE 02650000 MVC PDSORG(2),=C'DA' YES, INDICATE SAME 02660000 B TESTUNMV AND GO TEST UNMOVEABLE BIT 02670000 DSORG030 TM DS1DSORG,DS1DSGPO PARTITIONED ORGANIZATION? 02680000 BZ DSORG040 NO, TEST NEXT TYPE 02690000 MVC PDSORG(2),=C'PO' YES, INDICATE SAME 02700000 B TESTUNMV AND GO TEST UNMOVEABLE BIT 02710000 DSORG040 TM DS1DSORG+1,DS1ORGAM VSAM? 02720000 BZ TESTUNMV NO, TEST NEXT TYPE 02730000 MVC PDSORG(2),=C'AM' YES, INDICATE SAME 02740000 TESTUNMV DS 0H 02750000 TM DS1DSORG,DS1DSGU UNMOVEABLE DATA SET? 02760000 BZ DSORG060 NO, BYPASS MOVE 02770000 MVI PDSORG+2,C'U' YES, INDICATE SAME 02780000 DSORG060 DS 0H 02790000 EJECT 02800000 *********************************************************************** 02810000 * COPY RECFM TO PANEL * 02820000 *********************************************************************** 02830000 MVC PRECFM,ALLZEROS CLEAR FIELD 02840000 TM DS1RECFM,DS1RECFU UNDEFINED LENGTH RECORDS? 02850000 BNO RECFM010 NO, CHECK NEXT TYPE 02860000 MVI PRECFM,C'U' YES,INDICATE SAME 02870000 B PROCLREC GO PROCESS LRECL 02880000 RECFM010 TM DS1RECFM,DS1RECFF FIXED LENGTH RECORDS? 02890000 BZ RECFM020 NO, CHECK NEXT TYPE 02900000 MVI PRECFM,C'F' YES,INDICATE SAME 02910000 B CHCKBLCK GO CHECK FOR BLOCKED 02920000 RECFM020 TM DS1RECFM,DS1RECFV VARIABLE LENGTH RECORDS? 02930000 BZ CHCKBLCK NO 02940000 MVI PRECFM,C'V' YES,INDICATE SAME 02950000 B CHCKBLCK GO CHECK FOR BLOCKED 02960000 CHCKBLCK DS 0H 02970000 LA R14,PRECFM+1 LOAD TARGET ADDRESS 02980000 TM DS1RECFM,DS1RECFB BLOCKED RECORDS? 02990000 BZ RECFM030 NO, CHECK SPANNED/STANDARD 03000000 MVI 0(R14),C'B' YES, INDICATE SAME 03010000 LA R14,1(,R14) AND BUMP TARGET ADDRESS 03020000 RECFM030 TM DS1RECFM,DS1RECFS SPANNED/STANDARD? 03030000 BZ RECFM040 NO, PROCESS PRINT CC 03040000 MVI 0(R14),C'S' YES, INDICATE SAME 03050000 LA R14,1(,R14) AND BUMP TARGET ADDRESS 03060000 RECFM040 TM DS1RECFM,DS1RECFA ANSI CONTROL CHARS? 03070000 BZ RECFM050 NO, PROCESS PRINT CC 03080000 MVI 0(R14),C'A' YES, INDICATE SAME 03090000 LA R14,1(,R14) AND BUMP TARGET ADDRESS 03100000 B PROCLREC 03110000 RECFM050 TM DS1RECFM,DS1RECMC MACHINE CONTROL CHARS? 03120000 BZ RECFM060 NO, PROCESS LRECL 03130000 MVI 0(R14),C'M' YES, INDICATE SAME 03140000 RECFM060 DS 0H 03150000 EJECT 03160000 *********************************************************************** 03170000 * COPY LRECL, BLOCKSIZE, KEY LENGTH AND RKP TO PANEL * 03180000 *********************************************************************** 03190000 PROCLREC DS 0H 03200000 SLR R15,R15 CLEAR WORK REGISTER 03210000 ICM R15,B'0011',DS1LRECL LOAD THE LRECL 03220000 CVD R15,DWORD AND CONVERT TO DECIMAL 03230000 OI DWORD+7,15 INSURE PROPER SIGN 03240000 UNPK PLRECL,DWORD AND MOVE TO TARGET 03250000 SPACE 03260000 ICM R15,B'0011',DS1BLKL LOAD THE BLOCK SIZE 03270000 CVD R15,DWORD AND CONVERT TO DECIMAL 03280000 OI DWORD+7,15 INSURE PROPER SIGN 03290000 UNPK PBLKL,DWORD AND MOVE TO TARGET FIELD 03300000 SPACE 03310000 SLR R15,R15 CLEAR WORK REGISTER 03320000 IC R15,DS1KEYL LOAD THE KEY LENGTH 03330000 CVD R15,DWORD AND CONVERT TO DECIMAL 03340000 OI DWORD+7,15 INSURE PROPER SIGN 03350000 UNPK PKEYL,DWORD AND MOVE TO TARGET FIELD 03360000 SPACE 03370000 ICM R15,B'0011',DS1RKP LOAD THE RELATIVE KEY POSITION 03380000 CVD R15,DWORD AND CONVERT TO DECIMAL 03390000 OI DWORD+7,15 INSURE PROPER SIGN 03400000 UNPK PRKP,DWORD AND MOVE TO TARGET FIELD 03410000 SPACE 03420000 *********************************************************************** 03430000 * COPY LAST USED TRACK AND BLOCK INTO PANEL * 03440000 *********************************************************************** 03450000 ICM R15,B'1110',DS1LSTAR LOAD LSTAR INTO REG 03460000 LA R1,6 BYTES TO PROCESS 03470000 LA R2,PLSTAR A(TARGET FIELD) 03480000 LSTARLP DS 0H 03490000 SLR R14,R14 CLEAR WORK REG 03500000 SLDL R14,4 SHIFT 4 BITS INTO REG14 03510000 STC R14,0(R2) AND SAVE INTO TARGET 03520000 LA R2,1(,R2) BUMP TARGET ADDRESS 03530000 BCT R1,LSTARLP LOOP FOR NEXT FOUR BITS 03540000 TR PLSTAR,TRTAB TRANSLATE INTO PRINTABLE CHARS 03550000 EJECT 03560000 *********************************************************************** 03570000 * COPY TRACK BALANCE INTO PANEL * 03580000 *********************************************************************** 03590000 ICM R15,B'1100',DS1TRBAL LOAD LSTAR INTO REG 03600000 LA R1,4 BYTES TO PROCESS 03610000 LA R2,PTRBAL A(TARGET FIELD) 03620000 LTRBAL DS 0H 03630000 SLR R14,R14 CLEAR WORK REG 03640000 SLDL R14,4 SHIFT 4 BITS INTO REG14 03650000 STC R14,0(R2) AND SAVE INTO TARGET 03660000 LA R2,1(,R2) BUMP TARGET ADDRESS 03670000 BCT R1,LTRBAL LOOP FOR NEXT FOUR BITS 03680000 TR PTRBAL,TRTAB TRANSLATE INTO PRINTABLE CHARS 03690000 SPACE 03700000 *********************************************************************** 03710000 * COPY SMS INDICATORS INTO PANEL * 03720000 *********************************************************************** 03730000 ICM R15,B'1000',DS1SMSFG LOAD SMS INDICATORS 03740000 LA R1,2 BYTES TO PROCESS 03750000 LA R2,PSMSIND A(TARGET FIELD) 03760000 LSMSIND DS 0H 03770000 SLR R14,R14 CLEAR WORK REG 03780000 SLDL R14,4 SHIFT 4 BITS INTO REG14 03790000 STC R14,0(R2) AND SAVE INTO TARGET 03800000 LA R2,1(,R2) BUMP TARGET ADDRESS 03810000 BCT R1,LSMSIND LOOP FOR NEXT FOUR BITS 03820000 TR PSMSIND,TRTAB TRANSLATE INTO PRINTABLE CHARS 03830000 SPACE 03840000 *********************************************************************** 03850000 * COPY DATA SET INDICATORS INTO PANEL * 03860000 *********************************************************************** 03870000 ICM R15,B'1000',DS1DSIND LOAD DS INDICATORS 03880000 LA R1,2 BYTES TO PROCESS 03890000 LA R2,PDSIND A(TARGET FIELD) 03900000 LDSIND DS 0H 03910000 SLR R14,R14 CLEAR WORK REG 03920000 SLDL R14,4 SHIFT 4 BITS INTO REG14 03930000 STC R14,0(R2) AND SAVE INTO TARGET 03940000 LA R2,1(,R2) BUMP TARGET ADDRESS 03950000 BCT R1,LDSIND LOOP FOR NEXT FOUR BITS 03960000 TR PDSIND,TRTAB TRANSLATE INTO PRINTABLE CHARS 03970000 SPACE 03980000 *********************************************************************** 03990000 * COPY OPTCD INDICATORS INTO PANEL * 04000000 *********************************************************************** 04010000 ICM R15,B'1000',DS1OPTCD LOAD OPTCD 04020000 LA R1,2 BYTES TO PROCESS 04030000 LA R2,OPTCDE A(TARGET FIELD) 04040000 LOPTCD DS 0H 04050000 SLR R14,R14 CLEAR WORK REG 04060000 SLDL R14,4 SHIFT 4 BITS INTO REG14 04070000 STC R14,0(R2) AND SAVE INTO TARGET 04080000 LA R2,1(,R2) BUMP TARGET ADDRESS 04090000 BCT R1,LOPTCD LOOP FOR NEXT FOUR BITS 04100000 TR OPTCDE,TRTAB TRANSLATE INTO PRINTABLE CHARS 04110000 EJECT 04120000 *********************************************************************** 04130000 * COPY SECONDARY ALLOCATION INFO INTO PANEL * 04140000 *********************************************************************** 04150000 TM DS1SCAL1,DS1CYL IS IT CYLINDER ALLOCATION? 04160000 BNO SEC0010 NO, CHECK NEXT TYPE 04170000 MVI PSCAL1,C'C' YES, INDICATE SAME 04180000 B SCALLAMT PROCESS SECONDARY AMOUNT 04190000 SEC0010 TM DS1SCAL1,DS1TRK IS IT TRACK ALLOCATION? 04200000 BNO SEC0020 NO, CHECK NEXT TYPE 04210000 MVI PSCAL1,C'T' YES, INDICATE SAME 04220000 B SCALLAMT PROCESS SECONDARY AMOUNT 04230000 SEC0020 TM DS1SCAL1,DS1AVR IS IT BLOCK ALLOCATION? 04240000 BNO SEC0030 NO, CHECK NEXT TYPE 04250000 MVI PSCAL1,C'B' YES, INDICATE SAME 04260000 B SCALLAMT PROCESS SECONDARY AMOUNT 04270000 SEC0030 TM DS1SCAL1,DS1AVRND IS IT BLOCK ROUND ALLOC? 04280000 BNO SEC0040 NO, CHECK NEXT TYPE 04290000 MVI PSCAL1,C'R' YES, INDICATE SAME 04300000 B SCALLAMT PROCESS SECONDARY AMOUNT 04310000 SEC0040 TM DS1SCAL1,255 IS IT ABSOLUTE ALLOCATION? 04320000 BNZ SCALLAMT NO, PROCESS SECONDARY AMOUNT 04330000 MVI PSCAL1,C'A' YES, INDICATE SAME 04340000 SPACE 04350000 SCALLAMT DS 0H 04360000 SLR R15,R15 CLEAR WORK REG 04370000 ICM R15,B'0111',DS1SCAL3 INSERT SECONDARY AMOUNT 04380000 CVD R15,DWORD AND CONVERT TO DECIMAL 04390000 OI DWORD+7,15 INSURE PROPER SIGN 04400000 UNPK PSCAL3,DWORD AND COPY INTO TARGET AREA 04410000 TM MISCFLAG,ENQUEUE IS DATA SET AVAILABLE? 04420000 BZ TPUTPANL YES, PROCESS IT 04430000 LA R15,ENQERMSG NO, INFORM TERMINAL OPER 04440000 SPACE 04450000 *********************************************************************** 04460000 * COPY ERROR MESSAGE ONTO PANEL - R15 ADDRESSES THE ERROR MSG * 04470000 *********************************************************************** 04480000 PROCEMSG DS 0H POS, MOVE MESSAGE TO PANEL 04490000 MVC PERRMSG,ALLBLANK CLEAR TARGET FIELD 04500000 LA R14,PERRMSG A(TARGET FOR ERROR MESSAGE) 04510000 LA R2,L'PERRMSG LENGTH OF SAME 04520000 LH R1,0(R15) LOAD LENGTH OF MESSAGE TO DISPLY 04530000 CR R1,R2 GREATER THAN MAXIMUM? 04540000 BNH MSG010 NO, CONTINUE 04550000 LR R1,R2 YES, LOAD MAXIMUM LENGTH 04560000 MSG010 DS 0H 04570000 SR R2,R1 COMPUTE REMAINDER 04580000 BNP MSG020 BYPASS NEXT TWO INSTRS IF NEG 04590000 SRL R2,1 DIVIDE BY TWO 04600000 LA R14,0(R2,R14) CENTER ERROR MESSAGE 04610000 MSG020 DS 0H 04620000 BCTR R1,00 DECREMENT FOR EXECUTE 04630000 EX R1,MVCERMSG MOVE ERROR MESSAGE 04640000 EJECT 04650000 *********************************************************************** 04660000 * DISPLAY PANEL * 04670000 *********************************************************************** 04680000 TPUTPANL DS 0H 04690000 LA R0,LPDSCBL A(LENGTH OF PANEL) 04700000 LA R1,DSCBPANL A(DSCB PANEL) 04710000 TPUT (1),(0),FULLSCR WRITE PANEL TO TERMINAL 04720000 SPACE 04730000 *********************************************************************** 04740000 * RETRIEVE USER'S INPUT * 04750000 *********************************************************************** 04760000 XC INPUT(256),INPUT CLEAR FIRST HALF OF WORK 04770000 XC INPUT+256(256),INPUT+256 CLEAR LAST HALF OF WORK 04780000 LA R0,L'INPUT A(LENGTH OF INPUT AREA) 04790000 LA R1,INPUT A(INPUT AREA) 04800000 TGET (1),(0),ASIS GET INPUT FROM TERMINAL 04810000 SPACE 04820000 CLI INPUT,PA2KEY REDISPLAY REQUESTED? 04830000 BE TPUTPANL YES, REDISPLAY 04840000 SPACE 04850000 CLI INPUT,PFKEY03 TERMINATION REQUESTED? 04860000 BE ENDDSNS YES, TERMINATE EXECUTION 04870000 CLI INPUT,PFKEY15 TERMINATION REQUESTED? 04880000 BE ENDDSNS YES, TERMINATE EXECUTION 04890000 SPACE 04900000 MVC DSCBPCSR,DEFCSRAD RESET IC TO DEFAULT CUSOR ADDR 04910000 MVC PERRMSG,ALLBLANK CLEAR ERROR MESSAGE 04920000 LR R5,R1 SAVE LENGTH OF TGET DATA 04930000 LA R4,INPUT PRELOAD DATA ADDRESS 04940000 NI MISCFLAG,NSHARED+ENQUEUE RESET ALL BUT REQ'D BITS 04950000 EJECT 04960000 *********************************************************************** 04970000 * PROCESS INPUT KEYED IN BY USER * 04980000 * INPUT REGS: * 04990000 * REG 04 CONTAINS THE CURRENT ADDR OF BUFFER INPUT * 05000000 * REG 05 CONTAINS THE REMAINING LENGTH OF BUFFER INPUT * 05010000 * OUTPUT REGS: * 05020000 * REG 00 CONTAINS THE ACTUAL LENGTH OF KEYED INPUT DATA * 05030000 * REG 01 CONTAINS THE ADDRESS OF KEYED INPUT DATA * 05040000 * REG 02 CONTAINS THE LENGTH -1 OF KEYED INPUT DATA * 05050000 * REG 04 CONTAINS THE CURRENT ADDR OF BUFFER INPUT * 05060000 * REG 05 CONTAINS THE REMAINING LENGTH OF BUFFER INPUT * 05070000 * REG 06 CONTAINS THE ADDR OF THE MATCHING BUFFTAB ENTRY * 05080000 * REG 07 CONTAINS THE LENGTH OF A BUFFTAB ENTRY * 05090000 *********************************************************************** 05100000 SPACE 2 05110000 *********************************************************************** 05120000 * LOCATE NEXT INPUT FIELD, LENGTH AND MATCHING TABLE ENTRY * 05130000 *********************************************************************** 05140000 INPUT000 DS 0H HERE TO PROCESS INPUT DATA 05150000 LA R6,PDSCBL-2 A(HALFWORD COUNT OF ENTRIES) 05160000 LA R7,PDSCBLEL A(ENTRY LENGTH) 05170000 LA R15,TABLE000 A(INPUT DEPROCESSOR) 05180000 BASR R14,R15 PROCESS INPUT DATA 05190000 B INPUT200 ALL DATA PROCESSED 05200000 SPACE 05210000 LTR R6,R6 MATCHING ENTRY? 05220000 BNZ INPUT100 YES, PROCESS IT 05230000 * POSSIBLE ERROR AT THIS POINT WHAT TO DO, WHAT TO DO? 05240000 B INPUT000 NO BUFFTAB ENTRY, PROCESS NEXT 05250000 SPACE 05260000 *********************************************************************** 05270000 * RESET ATTRIBUTE BYTE TO NORMAL INTENSITY, UNPROTECTED * 05280000 *********************************************************************** 05290000 INPUT100 DS 0H HERE TO PROCESS INPUT DATA 05300000 LH R15,2(,R6) LOAD FIELD OFFSET 05310000 LA R15,DSCBPANL(R15) AND ADDRESS FIELD 05320000 BCTR R15,00 BACK UP TO THE ATTRIBUTE 05330000 NI 0(R15),64 AND OFF HIGHLIGHT ATTRIBUTE 05340000 SPACE 05350000 *********************************************************************** 05360000 * LOAD A(ROUTINE) TO PROCESS DATA AND BASR. (IF NOT ERASE INPUT) * 05370000 *********************************************************************** 05380000 LTR R0,R0 ERASE EOF INPUT FIELD? 05390000 BNP INPUT000 YES, GET NEXT FIELD 05400000 EX R2,INPUTOC INSURE UPPER CASE 05410000 LH R15,6(,R6) Y(OFFSET INTO ROUTINE TBL) 05420000 SLL R15,2 MULTIPLY BY 4 05430000 L R15,TABTABLE(R15) A(ROUTINE TO DEPROCESS INPUT) 05440000 BASR R14,R15 AND CALL SAME 05450000 B INPUT000 05460000 SPACE 2 05470000 INPUTOC OC 0(0,R1),ALLBLANK CONVERT TO UPPER CASE 05480000 EJECT 05490000 *********************************************************************** 05500000 * TEST FOR MODIFIED FILED(S) AND PROCESS ACCORDINGLY * 05510000 *********************************************************************** 05520000 INPUT200 DS 0H HERE AFTER END-OF-INPUT 05530000 TM MISCFLAG,IPTDSNAM+IPTVOL EITHER FIELDS MODIFIED? 05540000 BZ INPUT300 NO, CHECK FOR MODIFIED DSCB 05550000 BAS R10,RSETATTR YES, RESET ALL ATTRIBUTES 05560000 BAS R10,CVAFRLSE YES, RELEASE CVAF BUFFERS 05570000 TM MISCFLAG,IPTVOL VOLUME SERIAL MODIFIED? 05580000 BO UCBLKPLP YES, GO LOOKUP UCB 05590000 TM MISCFLAG,IPTDSNAM DSNAME MODIFIED? 05600000 BO LOCATELP YES, GO LOCATED DATA SET 05610000 INPUT300 DS 0H 05620000 TM MISCFLAG,IPTERROR WAS THERE AN ERROR? 05630000 BO TPUTPANL GO DISPLAY A MESSAGE 05640000 TM MISCFLAG,DSCBMOD WAS THE DSCB MODIFIED? 05650000 LA R15,WHATTODO NO, PROMPT TERM OP FOR INPUT 05660000 BZ PROCEMSG GO DISPLAY A MESSAGE 05670000 *********************************************************************** 05680000 * REWEITE THE DSCB INTO THE VTOC * 05690000 *********************************************************************** 05700000 CVAFDIR ACCESS=WRITE,MF=(E,CVAFREQ),BRANCH=(YES,PGM) 05710000 LTR R15,R15 WAS WRITE SUCCESSFUL? 05720000 BNZ CVAFPROC NO, GO LOAD IN ERROR MESSAGE 05730000 LA R15,DSCBMSG1 YES, ADDRESS SUCCESSFUL MSG 05740000 B PROCEMSG REDISPLAY PANEL 05750000 EJECT 05760000 ENDDSNS DS 0H 05770000 *********************************************************************** 05780000 * TERMINATE FULL SCREEN PROCESSING * 05790000 *********************************************************************** 05800000 STLINENO LINE=1 SET NEXT LINE TO 1 05810000 SPACE 05820000 STFSMODE OFF RESET FROM FULL SCREEN PROCESS 05830000 SPACE 05840000 *********************************************************************** 05850000 * RELEASE CVAF BUFFERS * 05860000 *********************************************************************** 05870000 BAS R10,CVAFRLSE RELEASE CVAF BUFFERS 05880000 SPACE 05890000 *********************************************************************** 05900000 * TERMINATE PROGRAM * 05910000 *********************************************************************** 05920000 RETURN DS 0H 05921000 $AUTHOFF 05922000 L R13,4(,R13) RESTORE BACKWARD POINTER 05950000 RETURN (14,12),T,RC=0 05960000 SPACE 05970000 BADBOY DS 0H KBASS 05971003 TPUT =CL50'YOU ARE NOT ALLOWED TO USE THIS',50 KBASS 05972003 B RETURN KBASS 05973003 MVCERMSG MVC 0(0,R14),2(R15) EXECUTED MOVE 05980000 EJECT 05990000 *********************************************************************** 06000000 * THIS ROUTINE WILL PROCESS A MODIFIED DATA SET NAME. * 06010000 * NOTE: IF A DATA SET NAME IS ENTERED BY THE USER, ALL REMAINING * 06020000 * INPUT, EXCEPT FOR VOLSER, WILL BE IGNORED. * 06030000 *********************************************************************** 06040000 IDSNAME DS 0H 06050000 OI MISCFLAG,IPTDSNAM INDICATE DSN HAS BEEN INPUT 06060000 MVC PDSNAME,ALLZEROS MOVE IN ALL BLANKS 06070000 MVC DS1DSNAM,ALLBLANK MOVE IN ALL BLANKS 06080000 LA R10,PDSNAME A(PANEL DSNAME) 06090000 LA R9,DS1DSNAM A(DSCB DSNAME) 06100000 CLI 0(R1),C'''' DOES DSN BEGIN WITH A QUOTE 06110000 BNE IDSN100 NO, DO NOT PROCESS QUOTES 06120000 EX R2,IDSNMVC2 MOVE DSN INTO PANEL 06130000 LA R1,1(,R1) YES, BYPASS FIRST QUOTE 06140000 BCTR R2,00 DECREMENT FOR FIRST QUOTE 06150000 STH R2,LDSNAME SAVE NEW LENGTH OF DSNAME 06160000 BCTR R2,00 DECREMENT FOR LAST QUOTE 06170000 EX R2,IDSNMVC3 MOVE DSN INTO DSCB 06180000 BR R14 06190000 IDSNMVC2 MVC 0(0,R10),0(R1) MOVE IN DATA SET NAME 06200000 IDSNMVC3 MVC 0(0,R9),0(R1) MOVE IN DATA SET NAME 06210000 IDSNMVC4 MVC 0(0,R10),USERIDI MOVE IN USERID 06220000 IDSNMVC5 MVC 0(0,R9),USERIDI MOVE IN USERID 06230000 SPACE 06240000 IDSN100 DS 0H 06250000 SLR R8,R8 CLEAR WORK REG 06260000 IC R8,USERIDL AL1(LENGTH OF USERID) 06270000 SPACE 06280000 LA R15,1(,R8) USERID + DELIMITER 06290000 AR R15,R0 + LENGTH OF DSNAME 06300000 STH R15,LDSNAME SAVE COMPUTED LENGTH OF DSNAME 06310000 CH R15,=H'46' IS DSNAME GT FIELD LENGTH? 06320000 LA R15,DSNLNGER PROVIDE FOR ERROR MSG 06330000 BH FLDERROR YES, GENERATE ERROR MESSAGE 06340000 SPACE 06350000 BCTR R8,0 DECREMENT FOR EXECUTE 06360000 MVI 0(R10),C'''' MOVE IN A QUOTE 06370000 LA R10,1(,R10) AND ADJUST FOR SAME 06380000 EX R8,IDSNMVC5 MOVE USERID TO DSNAME 06390000 EX R8,IDSNMVC4 MOVE USERID TO DSNAME 06400000 LA R9,1(R8,R9) AND ADJUST FOR SAME 06410000 LA R10,1(R8,R10) AND ADJUST FOR SAME 06420000 MVI 0(R9),C'.' MOVE IN A DELIMITER 06430000 MVI 0(R10),C'.' MOVE IN A DELIMITER 06440000 LA R9,1(,R9) AND ADJUST FOR SAME 06450000 LA R10,1(,R10) AND ADJUST FOR SAME 06460000 EX R2,IDSNMVC2 MOVE DSN INTO PANEL 06470000 EX R2,IDSNMVC3 MOVE DSN INTO DSCB 06480000 LA R10,1(R2,R10) AND ADJUST FOR SAME 06490000 MVI 0(R10),C'''' MOVE IN A QUOTE 06500000 BR R14 06510000 EJECT 06520000 *********************************************************************** 06530000 * THIS ROUTINE WILL PROCESS A VOLUME SERIAL NUMBER. * 06540000 * NOTE: IF A VOLUME SERIAL IS ENTERED BY THE USER, ALL REMAINING * 06550000 * INPUT, EXCEPT FOR DATA SET NAME, WILL BE IGNORED. * 06560000 *********************************************************************** 06570000 IVOLSER DS 0H 06580000 OI MISCFLAG,IPTVOL INDICATE VOLSER ENTERED 06590000 MVC PVOLSER,ALLZEROS CLEAR TARGET FIELD 06600000 EX R2,IVOLMVC AND MOVE IN VOLSER 06610000 BR R14 06620000 IVOLMVC MVC PVOLSER(0),0(R1) EXECUTED MVC 06630000 SPACE 06640000 *********************************************************************** 06650000 * THIS ROUTINE WILL PROCESS A MODIFIED CREATION DATE. * 06660000 *********************************************************************** 06670000 ICREDT DS 0H 06680000 MVC PCREDT,ALLZEROS CLEAR TARGET FIELD 06690000 EX R2,ICREMVC1 MOVE DATA TO PANEL 06700000 EX R2,NUMBRTRT TEST FOR VALID NUMERICS 06710000 LA R15,NUMBERER A(NUMERIC TEST ERROR) 06720000 BNZ FLDERROR IF NOT, REDISPLAY SCREEN 06730000 CH R0,=H'7' CORRECT LENGTH? 06740005 LA R15,LNGTHER1 A(FIELD LENGTH ERROR) 06750000 BNE FLDERROR NO, REDISPLAY SCREEN 06760000 PACK DWORD,0(4,R1) Y2K PACK YEAR MCLANE 06760105 CP DWORD,=P'0000' Y2K MCLANE 06760205 BE ICREX1 Y2K MCLANE 06760305 CP DWORD,=P'1900' Y2K MCLANE 06761005 BL ICREX2 Y2K MCLANE 06762005 SP DWORD,=P'1900' Y2K MCLANE 06763005 ICREX1 DS 0H Y2K MCLANE 06764005 CVB R15,DWORD CONVERT TO BINARY 06780000 STC R15,DS1CREDT AND SAVE IN TARGET FIELD 06790000 PACK DWORD,4(3,R1) Y2K PACK DATE MCLANE 06800005 CVB R15,DWORD CONVERT TO BINARY 06810000 STCM R15,B'0011',DS1CREDT+1 AND SAVE IN TARGET FIELD 06820000 OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED 06830000 EX R2,NUMBPACK PACK CREATION DATE 06840000 UNPK PCREDT,DWORD AND UNPACK INTO FIELD 06850000 ICREX2 DS 0H Y2K MCLANE 06851005 BR R14 RETURN TO CALLER 06860000 ICREMVC1 MVC PCREDT(0),0(R1) EXECUTED MVC 06870000 EJECT 06880000 *********************************************************************** 06890000 * THIS ROUTINE WILL PROCESS A MODIFIED REFERENCE DATE. * 06900000 *********************************************************************** 06910000 IREFD DS 0H 06920000 MVC PREFD,ALLZEROS CLEAR TARGET FIELD 06930000 EX R2,IREFMVC1 MOVE DATA TO PANEL 06940000 EX R2,NUMBRTRT TEST FOR VALID NUMERICS 06950000 LA R15,NUMBERER A(NUMERIC TEST ERROR) 06960000 BNZ FLDERROR IF NOT, REDISPLAY SCREEN 06970000 CH R0,=H'7' Y2K CORRECT LENGTH? MCLANE 06980005 LA R15,LNGTHER1 A(FIELD LENGTH ERROR) 06990000 BNE FLDERROR NO, REDISPLAY SCREEN 07000000 PACK DWORD,0(4,R1) Y2K PACK YEAR MCLANE 07010005 CP DWORD,=P'0000' Y2K MCLANE 07021005 BE IREFX1 Y2K MCLANE 07022005 CP DWORD,=P'1900' Y2K MCLANE 07022105 BL IREFX2 Y2K MCLANE 07022205 SP DWORD,=P'1900' Y2K MCLANE 07023004 IREFX1 DS 0H Y2K MCLANE 07024005 CVB R15,DWORD CONVERT TO BINARY 07031004 STC R15,DS1REFD AND SAVE IN TARGET FIELD 07032005 PACK DWORD,4(3,R1) Y2K PACK DATE MCLANE 07040004 CVB R15,DWORD CONVERT TO BINARY 07050000 STCM R15,B'0011',DS1REFD+1 AND SAVE IN TARGET FIELD 07060000 OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED 07070000 EX R2,NUMBPACK PACK REFERENCE DATE 07080000 UNPK PREFD,DWORD AND UNPACK INTO FIELD 07090000 IREFX2 DS 0H Y2K MCLANE 07091005 BR R14 RETURN TO CALLER 07100000 IREFMVC1 MVC PREFD(0),0(R1) EXECUTED MVC 07110000 SPACE 07120000 *********************************************************************** 07130000 * THIS ROUTINE WILL PROCESS A MODIFIED EXPIRATION DATE. * 07140000 *********************************************************************** 07150000 IEXPDT DS 0H 07160000 MVC PEXPDT,ALLZEROS CLEAR TARGET FIELD 07170000 EX R2,IEXPMVC1 MOVE DATA TO PANEL 07180000 EX R2,NUMBRTRT TEST FOR VALID NUMERICS 07190000 LA R15,NUMBERER A(NUMERIC TEST ERROR) 07200000 BNZ FLDERROR IF NOT, REDISPLAY SCREEN 07210000 CH R0,=H'7' Y2K CORRECT LENGTH? MCLANE 07220005 LA R15,LNGTHER1 A(FIELD LENGTH ERROR) 07230000 BNE FLDERROR NO, REDISPLAY SCREEN 07240000 PACK DWORD,0(4,R1) Y2K PACK YEAR MCLANE 07241005 CP DWORD,=P'0000' Y2K MCLANE 07241105 BE IEXPX1 Y2K MCLANE 07241205 CP DWORD,=P'1900' Y2K MCLANE 07242005 BL IEXPX2 Y2K MCLANE 07243005 SP DWORD,=P'1900' Y2K MCLANE 07244005 IEXPX1 DS 0H Y2K MCLANE 07245005 CVB R15,DWORD CONVERT TO BINARY 07260000 STC R15,DS1EXPDT AND SAVE IN TARGET FIELD 07270000 PACK DWORD,4(3,R1) Y2K PACK DATE MCLANE 07280005 CVB R15,DWORD CONVERT TO BINARY 07290000 STCM R15,B'0011',DS1EXPDT+1 AND SAVE IN TARGET FIELD 07300000 OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED 07310000 EX R2,NUMBPACK PACK EXPIRATION DATE 07320000 UNPK PEXPDT,DWORD AND UNPACK INTO FIELD 07330000 IEXPX2 DS 0H Y2K MCLANE 07331005 BR R14 RETURN TO CALLER 07340000 IEXPMVC1 MVC PEXPDT(0),0(R1) EXECUTED MVC 07350000 EJECT 07360000 *********************************************************************** 07370000 * THIS ROUTINE WILL PROCESS A MODIFIED DATA SET ORGINAZATION. * 07380000 *********************************************************************** 07390000 IDSORG DS 0H 07400000 MVC PDSORG,ALLZEROS CLEAR TARGET FIELD 07410000 EX R2,IDSOMVC1 MOVE INTO PANEL 07420000 CH R0,=H'2' CORRECT LENGTH? 07430000 LA R15,LNGTHER1 A(FIELD LENGTH ERROR) 07440000 BL FLDERROR NO, REDISPLAY SCREEN 07450000 LA R8,DSORGTAB A(DSORG TABLE) 07460000 LA R9,DSORGCNT A(ENTRY COUNT OF SAME) 07470000 IDSORG00 DS 0H 07480000 CLC 0(2,R8),0(R1) COMPARE TABLE ENTRY TO INPUT 07490000 BE IDSORG10 IF EQUAL, PROCESS 07500000 LA R8,DSORGLNG(,R8) BUMP TO NEXT ENTRY 07510000 BCT R9,IDSORG00 AND GO CHECK THAT ONE 07520000 LA R15,DSORGER1 A(DSORG ERROR MESSAGE) 07530000 B FLDERROR 07540000 IDSORG10 DS 0H 07550000 XC FWORD,FWORD CLEAR WORK AREA 07560000 CH R0,=H'3' WAS UNMOVABLE SPECIFIED? 07570000 BNE IDSORG20 NO, BYPASS IT THEN 07580000 CLI 2(R1),64 IS THIS A BLANK 07590000 BE IDSORG20 YES, NOT UNMOVEABLE 07600000 CLI 2(R1),C'U' IS IT UNMOVEABLE? 07610000 LA R15,DSORGER1 NO, INDICATE BAD DSORG 07620000 BNE FLDERROR AND REDISPLAY SCREEN 07630000 OI FWORD,DS1DSGU INDICATE UNMOVEABLE 07640000 IDSORG20 DS 0H 07650000 XC DS1DSORG,DS1DSORG CLEAR DSORG FIELD 07660000 OC DS1DSORG,2(R8) MOVE IN NEW DSORG 07670000 OC DS1DSORG,FWORD AND ADD 'U', IF SUPPLIED 07680000 OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED 07690000 BR R14 07700000 IDSOMVC1 MVC PDSORG(0),0(R1) EXECUTED MOVE 07710000 EJECT 07720000 *********************************************************************** 07730000 * THIS ROUTINE WILL PROCESS A MODIFIED RECORDING FORMAT. * 07740000 *********************************************************************** 07750000 IRECFM DS 0H 07760000 MVC PRECFM,ALLZEROS CLEAR TARGET FIELD 07770000 EX R2,IRECMVC1 MOVE TO PANEL 07780000 LR R10,R0 A(COUNT OF CHARS IN INPUT) 07790000 XC FWORD,FWORD CLEAR WORK FIELD 07800000 IRECFM00 DS 0H 07810000 LA R8,RECFMTAB A(RECFM TABLE) 07820000 LA R9,RECFMCNT A(ENTRY COUNT OF SAME) 07830000 IRECFM05 DS 0H 07840000 CLI 0(R1),64 IS THIS A BLANK? 07850000 BE IRECFM25 YES, BYPASS IT THEN 07860000 SPACE 07870000 IRECFM10 DS 0H 07880000 CLC 0(1,R8),0(R1) MATCHING ENTRY? 07890000 BE IRECFM20 YES, PROCESS 07900000 LA R8,RECFMLNG(,R8) NO, BUMP TO NEXT ENTRY 07910000 BCT R9,IRECFM10 AND GO PROCESS IT 07920000 LA R15,RECFMER1 A(INVALID RECFM INPUT) 07930000 B FLDERROR AND GO PROCESS ERROR 07940000 IRECFM20 DS 0H 07950000 OC FWORD(1),1(R8) SAVE THIS BIT 07960000 IRECFM25 DS 0H 07970000 LA R1,1(,R1) BUMP TO NEXT BYTE 07980000 BCT R10,IRECFM00 PROCESS NEXT BYTE OF INPUT 07990000 SPACE 08000000 LA R15,RECFMER1 PRELOAD INVALID RECFM INPUT MSG 08010000 TM FWORD,DS1RECFU WAS UNDEFINED SPECIFID? 08020000 BNO IRECFM30 NO, BYPASS NEXT TEST 08030000 TM FWORD,255-DS1RECFU-DS1RECFA-DS1RECMC ANY OTHERS? 08040000 BNZ FLDERROR YES, ERRONOUS INPUT 08050000 IRECFM30 DS 0H 08060000 OC FWORD(1),FWORD TEST FOR ANY INPUT 08070000 BZ FLDERROR IF ZERO, INDICATE ERROR 08080000 SPACE 08090000 XC DS1RECFM,DS1RECFM RESET RECORDING FORMAT 08100000 OC DS1RECFM,FWORD AND SET NEW VALUE 08110000 OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED 08120000 BR R14 RETURN TO CALLER 08130000 IRECMVC1 MVC PRECFM(0),0(R1) EXECUTED MVC 08140000 EJECT 08150000 *********************************************************************** 08160000 * THIS ROUTINE WILL PROCESS A MODIFIED LOGICAL RECORD LENGTH. * 08170000 *********************************************************************** 08180000 ILRECL DS 0H 08190000 MVC PLRECL,ALLZEROS CLEAR TARGET FIELD 08200000 EX R2,ILREMVC1 MOVE DATA TO PANEL 08210000 EX R2,NUMBRTRT TEST FOR VALID NUMERICS 08220000 LA R15,NUMBERER A(NUMERIC TEST ERROR) 08230000 BNZ FLDERROR IF NOT, REDISPLAY SCREEN 08240000 EX R2,NUMBPACK PACK LRECL 08250000 UNPK PLRECL,DWORD AND UNPACK INTO FIELD 08260000 CVB R15,DWORD CONVERT TO BINARY 08270000 STCM R15,B'0011',DS1LRECL AND UPDATE DSCB 08280000 OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED 08290000 BR R14 RETURN TO CALLER 08300000 ILREMVC1 MVC PLRECL(0),0(R1) EXECUTED MVC 08310000 SPACE 08320000 *********************************************************************** 08330000 * THIS ROUTINE WILL PROCESS A MODIFIED BLOCK SIZE. * 08340000 *********************************************************************** 08350000 IBLKL DS 0H 08360000 MVC PBLKL,ALLZEROS CLEAR TARGET FIELD 08370000 EX R2,IBLKMVC1 MOVE DATA TO PANEL 08380000 EX R2,NUMBRTRT TEST FOR VALID NUMERICS 08390000 LA R15,NUMBERER A(NUMERIC TEST ERROR) 08400000 BNZ FLDERROR IF NOT, REDISPLAY SCREEN 08410000 EX R2,NUMBPACK PACK BLKL 08420000 UNPK PBLKL,DWORD AND UNPACK INTO FIELD 08430000 CVB R15,DWORD CONVERT TO BINARY 08440000 STCM R15,B'0011',DS1BLKL AND UPDATE DSCB 08450000 OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED 08460000 BR R14 RETURN TO CALLER 08470000 IBLKMVC1 MVC PBLKL(0),0(R1) EXECUTED MVC 08480000 EJECT 08490000 *********************************************************************** 08500000 * THIS ROUTINE WILL PROCESS A MODIFIED KEY LENGTH. * 08510000 *********************************************************************** 08520000 IKEYL DS 0H 08530000 MVC PKEYL,ALLZEROS CLEAR TARGET FIELD 08540000 EX R2,IKEYMVC1 MOVE DATA TO PANEL 08550000 EX R2,NUMBRTRT TEST FOR VALID NUMERICS 08560000 LA R15,NUMBERER A(NUMERIC TEST ERROR) 08570000 BNZ FLDERROR IF NOT, REDISPLAY SCREEN 08580000 EX R2,NUMBPACK PACK KEYL 08590000 UNPK PKEYL,DWORD AND UNPACK INTO FIELD 08600000 CVB R15,DWORD CONVERT TO BINARY 08610000 STC R15,DS1KEYL AND UPDATE DSCB 08620000 OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED 08630000 BR R14 RETURN TO CALLER 08640000 IKEYMVC1 MVC PKEYL(0),0(R1) EXECUTED MVC 08650000 SPACE 08660000 *********************************************************************** 08670000 * THIS ROUTINE WILL PROCESS A MODIFIED RELATIVE KEY POSITION. * 08680000 *********************************************************************** 08690000 IRKP DS 0H 08700000 MVC PRKP,ALLZEROS CLEAR TARGET FIELD 08710000 EX R2,IRKPMVC1 MOVE DATA TO PANEL 08720000 EX R2,NUMBRTRT TEST FOR VALID NUMERICS 08730000 LA R15,NUMBERER A(NUMERIC TEST ERROR) 08740000 BNZ FLDERROR IF NOT, REDISPLAY SCREEN 08750000 EX R2,NUMBPACK PACK RKP 08760000 UNPK PRKP,DWORD AND UNPACK INTO FIELD 08770000 CVB R15,DWORD CONVERT TO BINARY 08780000 STCM R15,B'0011',DS1RKP AND UPDATE DSCB 08790000 OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED 08800000 BR R14 RETURN TO CALLER 08810000 IRKPMVC1 MVC PRKP(0),0(R1) EXECUTED MVC 08820000 EJECT 08830000 *********************************************************************** 08840000 * THIS ROUTINE WILL PROCESS A MODIFIED LSTAR. * 08850000 *********************************************************************** 08860000 ILSTAR DS 0H 08870000 MVC PLSTAR,ALLZEROS CLERA TARGET FIELD 08880000 EX R2,ILSTMVC1 MOVE SAME TO PANEL 08890000 EX R2,NUMHXTRT TEST FOR VALID HEX DIGITS 08900000 LA R15,HEXER IF INVALID, LOAD ERROR MSG 08910000 BNZ FLDERROR AND INFORM USER 08920000 BAS R10,CONV2HEX CONVERT TO HEXIDECIMAL 08930000 STCM R3,B'0111',DS1LSTAR UPDATE DSCB 08940000 OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED 08950000 BR R14 RETURN TO CALLER 08960000 ILSTMVC1 MVC PLSTAR(0),0(R1) EXECUTED MOVE 08970000 SPACE 08980000 *********************************************************************** 08990000 * THIS ROUTINE WILL PROCESS A MODIFIED TRACK BALANCE. * 09000000 *********************************************************************** 09010000 ITRBAL DS 0H 09020000 MVC PTRBAL,ALLZEROS CLERA TARGET FIELD 09030000 EX R2,ITRBMVC1 MOVE SAME TO PANEL 09040000 EX R2,NUMBRTRT TEST FOR VALID NUMERICS 09050000 LA R15,NUMBERER IF INVALID, LOAD ERROR MSG 09060000 BNZ FLDERROR AND INFORM USER 09070000 EX R2,NUMBPACK PACK RKP 09080000 UNPK PTRBAL,DWORD AND UNPACK INTO FIELD 09090000 CVB R15,DWORD CONVERT TO BINARY 09100000 STCM R3,B'0011',DS1TRBAL UPDATE DSCB 09110000 OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED 09120000 BR R14 RETURN TO CALLER 09130000 ITRBMVC1 MVC PTRBAL(0),0(R1) EXECUTED MOVE 09140000 SPACE 09150000 *********************************************************************** 09160000 * THIS ROUTINE WILL PROCESS A MODIFIED SMSIND * 09170000 *********************************************************************** 09180000 SMSIND DS 0H 09190000 MVC PSMSIND,ALLZEROS CLERA TARGET FIELD 09200000 EX R2,SMSIMVC1 MOVE SAME TO PANEL 09210000 EX R2,NUMHXTRT TEST FOR VALID HEX DIGITS 09220000 LA R15,HEXER IF INVALID, LOAD ERROR MSG 09230000 BNZ FLDERROR AND INFORM USER 09240000 BAS R10,CONV2HEX CONVERT TO HEXIDECIMAL 09250000 STC R3,DS1SMSFG UPDATE DSCB 09260000 OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED 09270000 BR R14 RETURN TO CALLER 09280000 SMSIMVC1 MVC PSMSIND(0),0(R1) EXECUTED MOVE 09290000 SPACE 09300000 *********************************************************************** 09310000 * THIS ROUTINE WILL PROCESS A MODIFIED DSIND. * 09320000 *********************************************************************** 09330000 IDSIND DS 0H 09340000 MVC PDSIND,ALLZEROS CLERA TARGET FIELD 09350000 EX R2,IDSIMVC1 MOVE SAME TO PANEL 09360000 EX R2,NUMHXTRT TEST FOR VALID HEX DIGITS 09370000 LA R15,HEXER IF INVALID, LOAD ERROR MSG 09380000 BNZ FLDERROR AND INFORM USER 09390000 BAS R10,CONV2HEX CONVERT TO HEXIDECIMAL 09400000 STC R3,DS1DSIND UPDATE DSCB 09410000 OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED 09420000 BR R14 RETURN TO CALLER 09430000 IDSIMVC1 MVC PDSIND(0),0(R1) EXECUTED MOVE 09440000 SPACE 09450000 *********************************************************************** 09460000 * THIS ROUTINE WILL PROCESS A MODIFIED OPTCD * 09470000 *********************************************************************** 09480000 IOPTCD DS 0H 09490000 MVC OPTCDE,ALLZEROS CLERA TARGET FIELD 09500000 EX R2,IOPTMVC1 MOVE SAME TO PANEL 09510000 EX R2,NUMHXTRT TEST FOR VALID HEX DIGITS 09520000 LA R15,HEXER IF INVALID, LOAD ERROR MSG 09530000 BNZ FLDERROR AND INFORM USER 09540000 BAS R10,CONV2HEX CONVERT TO HEXIDECIMAL 09550000 STC R3,DS1OPTCD UPDATE DSCB 09560000 OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED 09570000 BR R14 RETURN TO CALLER 09580000 IOPTMVC1 MVC OPTCDE(0),0(R1) EXECUTED MOVE 09590000 EJECT 09600000 *********************************************************************** 09610000 * THIS ROUTINE WILL PROCESS A SECONDARY ALLOC TYPE. * 09620000 *********************************************************************** 09630000 ISCALL1 DS 0H 09640000 MVC PSCAL1,ALLZEROS CLEAR TARGET FIELD 09650000 EX R2,ISCAMVC1 MOVE TO PANEL 09660000 LA R8,SCAL1TAB A(TABLE OC ACCEPTABLE VALUES) 09670000 LA R9,SCAL1CNT A(COUNT OF SAME) 09680000 ISCALL00 DS 0H 09690000 CLC 0(1,R8),0(R1) ENTRIES EQUAL?? 09700000 BE ISCALL10 IF EQUAL, PROCESS 09710000 LA R8,SCAL1LNG(,R8) NO, BUMP TO NEXT ENTRY 09720000 BCT R9,ISCALL00 PROCESS THIS ENTRY 09730000 LA R15,SCALLER A(ADDRESS ERROR MESSABE) 09740000 B FLDERROR 09750000 ISCALL10 DS 0H 09760000 XC DS1SCAL1,DS1SCAL1 CLEAR ALLOCATION TYPE 09770000 OC DS1SCAL1,1(R8) AND MOVE IN NEW TYPE 09780000 OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED 09790000 BR R14 RETURN TO CALLER 09800000 ISCAMVC1 MVC PSCAL1(0),0(R1) EXECUTED MVC 09810000 SPACE 09820000 *********************************************************************** 09830000 * THIS ROUTINE WILL PROCESS A SECONDARY ALLOC AMOUNT. * 09840000 *********************************************************************** 09850000 ISCALL3 DS 0H 09860000 MVC PSCAL3,ALLZEROS CLEAR TARGET FIELD 09870000 EX R2,ISCAMVC2 MOVE DATA TO PANEL 09880000 EX R2,NUMBRTRT TEST FOR VALID NUMERICS 09890000 LA R15,NUMBERER A(NUMERIC TEST ERROR) 09900000 BNZ FLDERROR IF NOT, REDISPLAY SCREEN 09910000 EX R2,NUMBPACK PACK SCALL3 09920000 UNPK PSCAL3,DWORD AND UNPACK INTO FIELD 09930000 CVB R15,DWORD CONVERT TO BINARY 09940000 STCM R15,B'0111',DS1SCAL3 AND UPDATE DSCB 09950000 OI MISCFLAG,DSCBMOD INDICATE DSCB MODIFIED 09960000 BR R14 RETURN TO CALLER 09970000 ISCAMVC2 MVC PSCAL3(0),0(R1) EXECUTED MVC 09980000 EJECT 09990000 *********************************************************************** 10000000 * CHAR TO HEX CONVERSION ROUTINE * 10010000 *********************************************************************** 10020000 CONV2HEX DS 0H 10030000 LR R8,R1 LOAD ADDRESS OF SOURCE VALUE 10040000 LR R9,R0 LOAD LOOP COUNTER 10050000 SLR R3,R3 CLEAR TARGET REGISTER 10060000 LOOP2BIN DS 0H 10070000 SLL R3,4 MAKE ROOM FOR NEXT NIBBLE 10080000 SLR R15,R15 CLEAR WORK REG 10090000 IC R15,0(0,R8) INSERT A BYTE 10100000 N R15,=F'15' TURN OFF ALL BUT LAST NIBBLE 10110000 TM 0(R8),240 IS IT NUMERIC 10120000 BO HEX010 YES, BYPASS ADD HALFWORD 10130000 AH R15,=H'9' ADD 9 IF NOT A NUMBER 10140000 HEX010 DS 0H 10150000 OR R3,R15 STORE IN RESULT 10160000 LA R8,1(0,R8) NEXT TARGET BYTE 10170000 BCT R9,LOOP2BIN PROCEED THROUGH FULLWORD 10180000 BR R10 RETURN TO CALLER 10190000 SPACE 10200000 *********************************************************************** 10210000 * FIELD ERROR PROCESSING ROUTINE * 10220000 * ON INPUT: R15 = A(ERROR MESSAGE AREA) * 10230000 * ALL OTHER REGISTERS ARE THE SAME AS UPON INPUT TO A * 10240000 * FIELD DE-PROCESSING ROUTINE. * 10250000 *********************************************************************** 10260000 FLDERROR DS 0H 10270000 TM MISCFLAG,IPTERROR MORE THAN ONE ERROR? 10280000 BO FLDERR10 YES, BYPASS MESSAGE MOVE 10290000 OI MISCFLAG,IPTERROR NO, SET ERROR FLAG 10300000 MVC DSCBPCSR,0(R6) ALTER THE IC BUFF ADDR 10310000 MVC PERRMSG,ALLBLANK CLEAR TARGET FIELD 10320000 LA R10,PERRMSG A(TARGET FOR ERROR MESSAGE) 10330000 LA R8,L'PERRMSG LENGTH OF SAME 10340000 LH R9,0(R15) LOAD LENGTH OF MESSAGE TO DISPLY 10350000 CR R9,R8 GREATER THAN MAXIMUM? 10360000 BNH FLD010 NO, CONTINUE 10370000 LR R9,R8 YES, LOAD MAXIMUM LENGTH 10380000 FLD010 DS 0H 10390000 SR R8,R9 COMPUTE REMAINDER 10400000 BNP FLD020 BYPASS NEXT TWO INSTRS IF NEG 10410000 SRL R8,1 DIVIDE BY TWO 10420000 FLD020 DS 0H 10430000 LA R10,0(R8,R10) CENTER ERROR MESSAGE 10440000 BCTR R9,00 DECREMENT FOR EXECUTE 10450000 EX R9,FLDMVC1 MOVE ERROR MESSAGE 10460000 SPACE 10470000 FLDERR10 DS 0H 10480000 LH R8,02(,R6) LOAD OFFSET TO FIELD 10490000 LA R8,DSCBPANL(R8) AND ADDRESS ACTUAL FIELD 10500000 BCTR R8,00 BACK UP TO ATTRIBUTE BYTE 10510000 OI 0(R8),X'89' TURN ON HIGH-INTENS + MDT 10520000 BR R14 RETURN TO MAINLINE 10530000 TITLE ' TABLE000 -- PROCESS TGET INPUT BUFFER' 10540000 PUSH USING 10550000 DROP R11 DROP PREVIOUS BASE REGISTER 10560000 *********************************************************************** 10570000 * * 10580000 * THIS ROUTINE WILL PROCESS THE INPUT FROM AN 'ASIS' TGET * 10590000 * AGAINST A TABLE OF SBA'S. THE OUTPUT IS THE ADDRESS AND LENGTH * 10600000 * OF THE INPUT FIELD AND THE ADDRESS OF THE ENTRY IN THE SBA * 10610000 * TABLE WITH THE MATCHING SBA. * 10620000 * NOTE: IF, BY CHANCE, A FIELD IS FOUND IN THE INPUT STREAM * 10630000 * THAT DOES NOT HAVE A MATCHING TABLE ENTRY, REG 06 IS RETURNED * 10640000 * EMPTY, BUT THE FIELD ADDRESS AND LENGTHS ARE RETURNED TO THE USER.* 10650000 * * 10660000 * INPUT REGISTERS * 10670000 * R4 - NEXT BYTE TO PROCESS * 10680000 * R5 - REMAINING LENGTH OF DATA * 10690000 * R6 - BUFFTAB LIST (FROM $FLD GENERATION) * 10700000 * R7 - LENGTH OF EACH BUFFER TABLE ENTRY * 10710000 * * 10720000 * OUTPUT REGISTERS * 10730000 * R0 - ACTUAL LENGTH OF INPUT/ZERO IF 'ERASE EOF' OF FIELD * 10740000 * R1 - ADDRESS OF FIELD IN INPUT * 10750000 * R2 - LENGTH - 1 OF FIELD IN INPUT * 10760000 * R4 - NEXT BYTE TO PROCESS * 10770000 * R5 - REMAINING LENGTH OF DATA * 10780000 * R6 - MATCHING BUFFTAB ENTRY OR ZERO * 10790000 * R7 - LENGTH OF EACH BUFFER TABLE ENTRY * 10800000 * * 10810000 *********************************************************************** 10820000 SPACE 10830000 TABLE000 DS 0H HERE TO PROCESS TGET INPUT 10840000 USING TABLE000,R15 10850000 LTR R5,R5 ANY THING LEFT TO CHECK? 10860000 BZ TABLE050 NO, RETURN TO CALLER 10870000 SPACE 10880000 TABLE025 DS 0H CHECK FOR SBA IN INPUT 10890000 CLI 0(R4),X'11' A START FIELD CHARACTER? 10900000 BE TABLE100 YES, GO PROCESS INPUT FIELD 10910000 LA R4,1(,R4) NO, BUMP AROUND 10920000 BCT R5,TABLE025 GO TEST NEXT BYTE 10930000 TABLE050 DS 0H RETURN TO USER WITH NOTHING 10940000 SLR R6,R6 INDICATE NO DATA TO PROCESS 10950000 BR R14 RETURN TO CALLER 10960000 SPACE 10970000 TABLE100 DS 0H 10980000 LA R4,1(,R4) BUMP AROUND SBA 10990000 BCT R5,TABLE120 DECREMENT AND BRANCH AROUND 11000000 B TABLE050 THIS INSTR IF NOT ZERO 11010000 TABLE120 DS 0H 11020000 LH R2,0(R6) LOAD NUMBER OF ENTRIES IN TABLE 11030000 LA R6,2(,R6) BUMP TO START OF TABLE 11040000 EJECT 11050000 TABLE200 DS 0H 11060000 CLC 0(2,R4),0(R6) COMPARE SBA TO TABLE ENTRY 11070000 BE TABLE300 BRANCH OUT IF FOUND 11080000 LA R6,0(R7,R6) BUMP TO NEXT TABLE ENTRY 11090000 BCT R2,TABLE200 GO CHECK NEXT ENTRY 11100000 SLR R6,R6 INDICATE NO MATCH 11110000 SPACE 11120000 TABLE300 DS 0H A MATCHING TABLE ENTRY (MAYBE) 11130000 LA R4,2(R4) BUMP TO DATA ADDRESS 11140000 BCTR R5,00 AND DECREMENT SAME 11150000 BCT R5,TABLE320 DECREMENT AND BRANCH AROUND 11160000 B TABLE050 THIS INSTR IF NOT ZERO 11170000 TABLE320 DS 0H 11180000 LR R1,R4 SAVE STARTING ADDRESS 11190000 SPACE 11200000 TABLE400 DS 0H FIND END OF FIELD 11210000 CLI 0(R4),X'11' LOOK FOR NEXT FIELD START 11220000 BE TABLE500 AND BRENCH OUT IF FOUND 11230000 LA R4,1(,R4) BUMP ANOTHER BYTE 11240000 BCT R5,TABLE400 AND GO CHECK THIS ONE 11250000 SPACE 11260000 TABLE500 DS 0H HERE AT END OF DATA OR NEXT SBA 11270000 LR R2,R4 PREPARE FOR LENGTH COMPUTATION 11280000 SR R2,R1 AND COMPUTE ACTUAL LENGTH 11290000 LR R0,R2 LOAD IT INTO RETURN REG 11300000 BCTR R2,00 DECREMENT FOR EXECUTE(S) 11310000 B 4(,R14) RETURN TO CALLER 11320000 POP USING 11330000 SPACE 11340000 FLDMVC1 MVC 0(0,R10),2(R15) EXECUTED MOVE 11350000 NUMBRTRT TRT 0(0,R1),NUMTAB EXECUTED TRT 11360000 NUMHXTRT TRT 0(0,R1),NUMHEXTB EXECUTED TRANSLATE AND TEST 11370000 NUMBPACK PACK DWORD,0(0,R1) EXECUTED PACK INSTRUCTION 11380000 TITLE ' CVAFPROC -- GENERATE CVAF ERROR MESSAGE' 11390000 *********************************************************************** 11400000 * ROUTINE TO PROCESS ERROR RETURN FROM CVAF * 11410000 *********************************************************************** 11420000 CVAFPROC DS 0H 11430000 USING CVAFMAP,R3 11440000 LA R3,CVAFREQ 11450000 * CLI CVSTAT,00 ERROR GENERATED? 11460000 * BE R14 NO, BYPASS MSG 11470000 CVAFP010 DS 0H 11480000 SLL R15,16 SHIFT RC TO HIGH ORDER 2 BYTES 11490000 LA R1,4 AND LOAD COUNT OF ENTRIES 11500000 LA R2,CVAFRC A(TARGET AREA) 11510000 SPACE 11520000 CVAFP020 DS 0H 11530000 SLR R14,R14 CLEAR WORK REG 11540000 SLDL R14,4 SHIFT HALF A BYTE INTO REG 11550000 STC R14,0(,R2) SAVE THIS HALF BYTE 11560000 LA R2,1(,R2) BUMP TO NEXT TARGET ADDRESS 11570000 BCT R1,CVAFP020 AND PROCESS THAT ONE 11580000 TR CVAFRC,TRTAB TRANSLATE TO PRINTABLE CHARS 11590000 SPACE 11600000 LA R1,CVAFREQ 11610000 SLR R15,R15 CLEAR WORK REG 11620000 IC R15,CVSTAT AND LOAD STATUS BYTE 11630000 CVD R15,DWORD CONVERT TO DECIMAL 11640000 OI DWORD+7,15 INSURE PRINTABLE SIGN 11650000 UNPK CVAFST,DWORD MOVE TO OUTPUT LINE 11660000 SPACE 11670000 MVC CVAFTYPE,=CL5'READ ' DEFAULT TO READ 11680000 CLI CVFCTN,CVDIRD WAS IT A READ? 11690000 BE CVAFP030 YES, BYPASS WRITE 11700000 MVC CVAFTYPE,=CL5'WRITE' NO, INDICATE IT WAS A WRITE 11710000 SPACE 11720000 CVAFP030 DS 0H 11730000 LA R15,CVAFERR GET ADDRESS OF MESSAGE 11740000 B PROCEMSG RETURN TO CALLER 11750000 TITLE ' RSETATTR -- RESET ALL MODIFIABLE FIELD ATTRIBUTES' 11760000 *********************************************************************** 11770000 * ROUTINE TO RESET ALL MODIFIABLE FIELD ATTRIBUTES * 11780000 *********************************************************************** 11790000 RSETATTR DS 0H 11800000 LA R1,PDSCBL-2 A(H'ENTRIES IN TABLE') 11810000 LH R2,0(R1) H'ENTRIES IN TABLE' 11820000 LA R3,PDSCBLEL A(ENTRY LENGTH) 11830000 LA R1,2(,R1) A(TABLE PROPER) 11840000 LA R4,DSCBPANL A(PANEL) 11850000 RSET0000 DS 0H LOOP THROUGH TABLE 11860000 LH R5,2(,R1) LOAD FIELD OFFSET 11870000 BCTR R5,00 DECREMENT BACK TO ATTRIBUTE 11880000 AR R5,R4 ADD PANEL BASE 11890000 NI 0(R5),64 RESET TO MODIFIABLE, NORM INTENS 11900000 LA R1,0(R3,R1) BUMP TO NEXT ENTRY 11910000 BCT R2,RSET0000 AND GO PROCESS SAME 11920000 BR R10 RETURN TO CALLER 11930000 SPACE 2 11940000 *********************************************************************** 11950000 * RELEASE CVAF BUFFERS * 11960000 *********************************************************************** 11970000 CVAFRLSE DS 0H 11980000 CVAFDIR ACCESS=RLSE,BUFLIST=0,IXRCDS=NOKEEP,BRANCH=(YES,PGM), $11990000 IOAREA=NOKEEP,MF=(E,CVAFREQ) 12000000 OC UCBTOKEN,UCBTOKEN 30OCT95 12010000 BZ CVAFR010 30OCT95 12020000 MODESET MODE=SUP 30OCT95 12030000 UCBPIN UNPIN,PTOKEN=UCBTOKEN, 30OCT95X12040000 MF=(E,XUCBPIN) 30OCT95 12050000 MVC UCBTOKEN,ALLZEROS 30OCT95 12060000 MVC UCBADDR,ALLZEROS 30OCT95 12070000 MODESET MODE=PROB 30OCT95 12080000 CVAFR010 DS 0H 30OCT95 12090000 BR R10 RETURN TO CALLER 12100000 BR R10 RETURN TO CALLER 12110000 SPACE 12120000 PRINT DATA 12130000 DC 64S(*) 12140000 PRINT NODATA 12150000 TITLE 'WORKING STORAGE AND CONSTANTS' 12160000 DROP , 12161000 SAVEAREA DS 18F 12170000 DWORD DS D 12180000 FWORD DS F 12190000 ALLBLANK DC 256C' ' 12200000 ALLZEROS DC 256X'00' 12210000 DSNLOC CAMLST NAME,DS1DSNAM,,LOCWORK 12220000 DS 0D 12230000 LOCWORK DS XL512 LOCATE WORK AREA 12240000 INPUT EQU LOCWORK,512 12250000 LDSNAME DS H LENGTH OF DS1DSNAM 12260000 DEFCSRAD DS XL2 DEFAULT CURSOR BUFF ADDR 12270000 SPACE 12280000 UCBADDR DS A(0) 30OCT95 12290000 UCBTOKEN DC XL8'00' 30OCT95 12300000 UCBLOOK MF=(L,XUCBLOOK,0D) 30OCT95 12310000 UCBPIN MF=(L,XUCBPIN,0D) 30OCT95 12320000 SPACE 12330000 SYSDSN DC CL8'SYSDSN' QNAME FOR ENQ 12340000 SPACE 12350000 MODELENQ ENQ (SYSDSN,,E,,SYSTEM),RET=TEST,MF=L 12360000 SPACE 12370000 MODESENQ ENQ (SYSDSN,,E,,SYSTEMS),RET=TEST,MF=L 12380000 SPACE 12390000 USERID DS 0CL9 12400000 USERIDL DS X 12410000 USERIDI DS CL8 12420000 EJECT 12430000 LTORG 12440000 SPACE 12450000 PRINT NOGEN 12460000 DSNLOCER MSSG 'DATA SET NAME NOT CATALOGED - RESPECIFY' 12470000 ENQERMSG MSSG 'DATA SET IS IN USE BY OTHER(S) - MODIFY THIS DSCB WITH $12480000 CAUTION' 12490000 DSNAMEER MSSG 'DATA SET NAME NOT SPECIFIED AT CP INVOCATION - RESPECIF$12500000 Y' 12510000 DSNLNGER MSSG 'LENGTH OF DSNAME AND USERID GREATER THAN FIELD LENGTH -$12520000 RESPECIFY' 12530000 UCBERMSG MSSG 'VOLUME SERIAL REQUESTED NOT ONLINE - RESPECIFY DSN OR V$12540000 OL' 12550000 DSORGER1 MSSG 'INVALID DATASET ORGINIZATION - RESPECIFY - PO/PS/DA/IS/$12560000 AM (U) ALLOWED' 12570000 RECFMER1 MSSG 'INVALID RECORDING FORMAT - RESPECIFY - F/V/U/B/S/A/M' 12580000 NUMBERER MSSG 'INVALID DATA, FIELD MUST BE ALL NUMERIC' 12590000 HEXER MSSG 'INVALID DATA, FIELD MUST BE ALL HEXIDECIMAL CHARACTERS' 12600000 LNGTHER1 MSSG 'INVALID DATA, DATA LENGTH MUST MATCH INPUT FIELD LENGTH$12610000 ' 12620000 SCALLER MSSG 'SECONDARY ALLOCATION TYPE INVALID - RESPECIFY - C/T/B/R$12630000 /U' 12640000 WHATTODO MSSG 'TO TERMINATE, ONE MUST DEPRESS EITHER PFK3 OR PFK15' 12650000 DSCBMSG1 MSSG 'DSCB HAS BEEN SUCCESSFULLY REWRITTEN' 12660000 SPACE 12670000 CVAFERR DC AL2(CVAFERRE-*-2) LENGTH OF ERROR MESSAGE 12680000 DC C'ERROR RETURN FORM CVAF DURING ' 12690000 CVAFTYPE DC CL5' ' 12700000 DC C', RETURN CODE=' 12710000 CVAFRC DC XL4'00' 12720000 DC C', STATUS=' 12730000 CVAFST DC CL3' ' 12740000 CVAFERRE EQU * END OF ERROR MESSAGE 12750000 PRINT GEN 12760000 EJECT 12770000 MISCFLAG DC B'00000000' 12780000 NSHARED EQU B'10000000' INDICATES UCB NOT SHARED 12790000 IPTDSNAM EQU B'01000000' DATA SET NAME HAS CHANGED 12800000 IPTVOL EQU B'00100000' VOLSER PROVIDED BY TERMINAL OPR 12810000 IPTERROR EQU B'00010000' INPUT ERROR HAS BEEN ENCOUNTERED 12820000 DSCBMOD EQU B'00001000' DSCB HAS BEEN MODIFIED 12830000 ENQUEUE EQU B'00000100' DATA SET IS IN USE 12840000 * EQU B'00000010' UNUSED AT PRESENT 12850000 * EQU B'00000001' UNUSED AT PRESENT 12860000 SPACE 12870000 TRTAB DC CL16'0123456789ABCDEF' TRANSLATE TABLE 12880000 SPACE 12890000 NUMTAB DC 256X'FF' VALID NUMERIC TABLE 12900000 ORG NUMTAB+C'0' ORG BACK TO NUMERALS 12910000 DC X'00000000000000000000' 12920000 ORG , RESET LOCATION COUNTER 12930000 SPACE 12940000 NUMHEXTB DC 256X'FF' VALID NUMERIC TABLE 12950000 ORG NUMHEXTB+C'0' ORG BACK TO NUMERALS 12960000 DC X'00000000000000000000' 12970000 ORG NUMHEXTB+C'A' ORG BACK TO HEX CHARS 12980000 DC X'000000000000' 12990000 ORG , RESET LOCATION COUNTER 13000000 SPACE 13010000 DSORGTAB DS 0CL20 DATASET ORGINAZATION TABLE 13020000 DC CL2'IS',AL1(DS1DSGIS,00000000) 13030000 DSORGLNG EQU *-DSORGTAB LENGTH OF ONE ENTRY 13040000 DC CL2'PS',AL1(DS1DSGPS,00000000) 13050000 DC CL2'DA',AL1(DS1DSGDA,00000000) 13060000 DC CL2'PO',AL1(DS1DSGPO,00000000) 13070000 DC CL2'AM',AL1(00000000,DS1ORGAM) 13080000 DSORGCNT EQU (*-DSORGTAB)/DSORGLNG COUNT OF ENTRIES 13090000 SPACE 13100000 RECFMTAB DS 0CL14 DATASET RECFM TABLE 13110000 DC CL1'F',AL1(DS1RECFF) 13120000 RECFMLNG EQU *-RECFMTAB LENGTH OF ONE ENTRY 13130000 DC CL1'V',AL1(DS1RECFV) 13140000 DC CL1'U',AL1(DS1RECFU) 13150000 DC CL1'B',AL1(DS1RECFB) 13160000 DC CL1'S',AL1(DS1RECFS) 13170000 DC CL1'A',AL1(DS1RECFA) 13180000 DC CL1'M',AL1(DS1RECMC) 13190000 RECFMCNT EQU (*-RECFMTAB)/RECFMLNG COUNT OF ENTRIES 13200000 SPACE 13210000 SCAL1TAB DS 0CL14 SECONDARY ALLOCATION TYPE TABLE 13220000 DC CL1'C',AL1(DS1CYL) CYLINDER BOUNDARY 13230000 SCAL1LNG EQU *-SCAL1TAB LENGTH OF ONE ENTRY 13240000 DC CL1'T',AL1(DS1TRK) TRACK BOUNDARY 13250000 DC CL1'B',AL1(DS1AVR) AVR BLOCK 13260000 DC CL1'R',AL1(DS1AVRND) AVG BLOCK AND ROUND 13270000 DC CL1'A',AL1(DS1DSABS) ABSOLUTE TRACK 13280000 SCAL1CNT EQU (*-SCAL1TAB)/SCAL1LNG COUNT OF ENTRIES 13290000 EJECT 13300000 TABTABLE DS 0F VALUE=(Y(00)) IN $FLD 13310000 DC A(IDSNAME) 0 13320000 DC A(IVOLSER) 1 13330000 DC A(ICREDT) 2 13340000 DC A(IREFD) 3 13350000 DC A(IEXPDT) 4 13360000 DC A(IDSORG) 5 13370000 DC A(IRECFM) 6 13380000 DC A(ILRECL) 7 13390000 DC A(IBLKL) 8 13400000 DC A(IKEYL) 9 13410000 DC A(IRKP) 10 13420000 DC A(ILSTAR) 11 13430000 DC A(ITRBAL) 12 13440000 DC A(SMSIND) 13 13450000 DC A(IDSIND) 14 13460000 DC A(IOPTCD) 15 13470000 DC A(ISCALL1) 16 13480000 DC A(X'80000000'+ISCALL3) 17 13490000 SPACE 2 13500000 CVAFREQ CVAFDIR DSN=DS1DSNAM,BUFLIST=CVAFBUF,IOAREA=KEEP, $13510000 IXRCDS=KEEP,MF=L 13520000 EJECT 13530000 CVAFBUF ICVAFBFL DSECT=NO 13540000 EJECT 13550000 DSCB DS 0F 13560000 IECSDSL1 (1) MAP OUT DSCB FORMAT 1 13570000 LDSCB EQU *-DSCB 13580000 TITLE ' -- DSCB FIELD(S) MAP FOR A MODEL 2' 13590000 DSCBPANL $FLD TYPE=INIT,MODEL='3278-2',BUFFTAB=YES,OPERATN=WRITERAS, $13600000 FILL=00 13610000 $FLD POS=(01,20),ATR=SKIP, $13620000 INITIAL='DATA SET CONTROL BLOCK MODIFICATION PANEL' 13630000 $FLD POS=(03,18),ATR=SKIP, $13640000 INITIAL='DATA SET NAME' 13650000 PDSNAME $FLD POS=(03,32),ATR=(IC,UNPR), $13660000 VALUES=(Y(00)),LENGTH=46 13670000 EJECT 13680000 $FLD POS=(05,18),ATR=SKIP, $13690000 INITIAL='VOLUME SERIAL' 13700000 PVOLSER $FLD POS=(05,32),ATR=UNPR, $13710000 VALUES=(Y(01)),LENGTH=6 13720000 $FLD POS=(07,18),ATR=SKIP, $13730000 INITIAL='CREATION DATE' 13740000 PCREDT $FLD POS=(07,32),ATR=UNPR, $13750000 VALUES=(Y(02)),LENGTH=7 13760005 EJECT 13770000 $FLD POS=(08,17),ATR=SKIP, $13780000 INITIAL='REFERANCE DATE' 13790000 PREFD $FLD POS=(08,32),ATR=UNPR, $13800000 VALUES=(Y(03)),LENGTH=7 13810004 $FLD POS=(09,16),ATR=SKIP, $13820000 INITIAL='EXPIRATION DATA' 13830000 PEXPDT $FLD POS=(09,32),ATR=UNPR, $13840000 VALUES=(Y(04)),LENGTH=7 13850005 EJECT 13860000 $FLD POS=(11,10),ATR=SKIP, $13870000 INITIAL='DATA SET ORGINIZATION' 13880000 PDSORG $FLD POS=(11,32),ATR=UNPR, $13890000 VALUES=(Y(05)),LENGTH=3 13900000 $FLD POS=(12,18),ATR=SKIP, $13910000 INITIAL='RECORD FORMAT' 13920000 PRECFM $FLD POS=(12,32),ATR=UNPR, $13930000 VALUES=(Y(06)),LENGTH=4 13940000 EJECT 13950000 $FLD POS=(13,10),ATR=SKIP, $13960000 INITIAL='LOGICAL RECORD LENGTH' 13970000 PLRECL $FLD POS=(13,32),ATR=UNPR, $13980000 VALUES=(Y(07)),LENGTH=5 13990000 $FLD POS=(14,12),ATR=SKIP, $14000000 INITIAL='PHYSICAL BLOCK SIZE' 14010000 PBLKL $FLD POS=(14,32),ATR=UNPR, $14020000 VALUES=(Y(08)),LENGTH=5 14030000 EJECT 14040000 $FLD POS=(15,21),ATR=SKIP, $14050000 INITIAL='KEY LENGTH' 14060000 PKEYL $FLD POS=(15,32),ATR=UNPR, $14070000 VALUES=(Y(09)),LENGTH=3 14080000 $FLD POS=(16,10),ATR=SKIP, $14090000 INITIAL='RELATIVE KEY POSITION' 14100000 PRKP $FLD POS=(16,32),ATR=UNPR, $14110000 VALUES=(Y(10)),LENGTH=3 14120000 EJECT 14130000 $FLD POS=(18,06),ATR=SKIP, $14140000 INITIAL='LAST USED TRACK AND BLOCK' 14150000 PLSTAR $FLD POS=(18,32),ATR=UNPR, $14160000 VALUES=(Y(11)),LENGTH=6 14170000 $FLD POS=(18,40),ATR=(SKIP,BRT), $14180000 INITIAL='<=== HEXADECIMAL' 14190000 $FLD POS=(19,01),ATR=SKIP, $14200000 INITIAL='BYTES REMAINING ON LAST TRACK' 14210000 PTRBAL $FLD POS=(19,32),ATR=UNPR, $14220000 VALUES=(Y(12)),LENGTH=4 14230000 EJECT 14240000 $FLD POS=(20,17),ATR=SKIP, $14250000 INITIAL='SMS INDICATORS' 14260000 PSMSIND $FLD POS=(20,32),ATR=UNPR, $14270000 VALUES=(Y(13)),LENGTH=2 14280000 $FLD POS=(20,40),ATR=(SKIP,BRT), $14290000 INITIAL='<=== HEXADECIMAL' 14300000 SPACE 14310000 $FLD POS=(21,12),ATR=SKIP, $14320000 INITIAL='DATA SET INDICATORS' 14330000 PDSIND $FLD POS=(21,32),ATR=UNPR, $14340000 VALUES=(Y(14)),LENGTH=2 14350000 $FLD POS=(21,40),ATR=(SKIP,BRT), $14360000 INITIAL='<=== HEXADECIMAL' 14370000 SPACE 14380000 $FLD POS=(22,22),ATR=SKIP, $14390000 INITIAL='OPT CODES' 14400000 OPTCDE $FLD POS=(22,32),ATR=UNPR, $14410000 VALUES=(Y(15)),LENGTH=2 14420000 $FLD POS=(22,40),ATR=(SKIP,BRT), $14430000 INITIAL='<=== HEXADECIMAL' 14440000 SPACE 14450000 $FLD POS=(23,11),ATR=SKIP, $14460000 INITIAL='SECONDARY ALLOCATION' 14470000 PSCAL1 $FLD POS=(23,32),ATR=UNPR, $14480000 VALUES=(Y(16)),LENGTH=1 14490000 EJECT 14500000 PSCAL3 $FLD POS=(23,34),ATR=UNPR, $14510000 VALUES=(Y(17)),LENGTH=5 14520000 PERRMSG $FLD POS=(24,02),ATR=(SKIP,BRT), $14530000 INITIAL=' $14540000 ' 14550000 PRINT GEN 14551000 PDSCBL $FLD TYPE=FINAL,BUFFTAB=PDSCBL,EQU=LPDSCBL 14560000 LPDSCB EQU (((*-DSCBPANL+7)/8)*8) LENGTH OF DCT PANEL 14570000 EJECT 14580000 CVAFMAP ICVAFPL DSECT=YES,LABELS=YES 14590000 EJECT 14600000 IKJCPPL CPPL PARAMETER LIST 14610000 PRINT NOGEN 14620000 CVT LIST=YES,DSECT=YES 14630000 IEFUCBOB LIST=YES 14640000 IHAPSA 14650000 IHAACEE 14660000 IHAASCB 14670000 IHAASXB 14680000 PRINT GEN 14690000 EJECT 14700000 YREGS , 14710000 EJECT 14720000 $KEYS 14730000 END 14740000