PROC MIKESCREATERECHANDLER (MCRRH) IS ( LITERAL RECNAME, LITERAL USE_DEFN_FILE := "", LITERAL SAVE_DEFN_FILE := "", LITERAL SOURCELIBRARY := "*SRC", LITERAL OMFLIBRARY := "*OMF", LITERAL SYNONYM := "", RESPONSE (RESPONSE) RESP := RESULT) BEGIN STOPT(NAM = NOLCS) STRING PHASE INT FLAG, SFLAG WHENEVER FLAG NE 0 THEN IF FLAG > 0 THEN SMSG("ERRORS WHEN " + PHASE) RESP := FLAG RETURN ELSE SMSG("WARNINGS WHEN " + PHASE) SRSMSG(FLAG) FLAG := 0 FI FI STRING AMSG_SCR, REPLY, REC_BUFF, RECORD_NAME, DEFN_FILE, FIELD_NAME, FIELD_TYPE, FIELD_LEN, FIRST_FIELD_LEN, BIN_LEN_LIST IS "011223344455667788899" INT REPLY_LEN, REPLY_PTR, LINE_PTR, BIN_PTR, PART_PTR, SEGMENT_LEN, SOM_POSN @ record_name is required for substitution in some of the following @ superstrings RECORD_NAME := REC_NAME WHILE RECORD_NAME INCLUDES "-" DO RECORD_NAME := RECORD_NAME BEFORE "-" + "_" + RECORD_NAME AFTER "-" REPEAT @ Fixed part of text to be generated - saves cluttering up the @ procedure body SUPERSTRING PROC_HEAD := "PROC " + RECORD_NAME + "HANDLER (" + SYNONYM + ") IS (" & " LITERAL INFILE := ''," & " LITERAL OUTFILE := ''," & " LITERAL VALIDATE := 'Y'," & " RESPONSE (RESPONSE) RESP := RESULT)" & "PROCBEGIN" & " " & " STRING PHASE" & " " & " INT FLAG" & " " & " WHENEVER FLAG NE 0 THEN" & " IF FLAG > 0 THEN" & " SMSG('ERRORS WHEN ' + PHASE)" & " RESP := FLAG" & " RETURN" & " ELSE" & " SMSG('WARNINGS WHEN ' + PHASE)" & " SRSMSG(FLAG)" & " FLAG := 0" & " FI" & " FI" & " " & " STRING RUNTYPE," & " FLD_START," & " FLD_END," & " AMSG_SCR," & " MSG_FIELD," & " REPLY," & " REPLY_FLD," & " REC_BUFF," & " IN_REC," & " SIGN_CHAR," & " LAST_REPLY," & " CHECK_CHAR," & " HEX_CHARS IS '0123456789ABCDEF'," & " PRINTABLE IS ' [.<(+!&]$*);^-/|,%_>?`:£@' +" & " HEX(7D) + '=' + HEX(7F) + 'abcdefghi' +" & " 'jklmnopqr~stuvwxyz{ABCDEFGHI}JKLMNOPQR\' +" & 0040099 " 'STUVWXYZ0123456789'" & " " & " INT REPLY_LEN," & " REPLY_PTR," & " IN_PTR," & " FLD_PTR," & " VALID_PTR," & " DISPLAY_LEN," & " REC_FLD_LEN," & " REPLY_FLD_NUM" & " " & " BOOL VALIDATE_FLD," & " REC_VALID," & " END_OF_FILE" & " " & "[500] BOOL FLD_VALID" & " " & " IF ((VALIDATE = '')" & " OR ('Yy' INCLUDES SUBSTR(VALIDATE))) THEN" & " VALIDATE_FLD := TRUE" & " ELSE" & " VALIDATE_FLD := FALSE" & " FI" & " " & " FOR VALID_PTR FROM 0 BY 1 TO BOUND FLD_VALID" & " DO" & " FLD_VALID[VALID_PTR] := TRUE" & " REPEAT" & " " & " IF INFILE NE '' THEN" & " IF OUTFILE NE '' THEN" & " RUNTYPE := 'E'" & " FLD_START := '3C'" & " ELSE" & " RUNTYPE := 'B'" & " FLD_START := '11'" & " FI" & " ELSE" & " IF OUTFILE NE '' THEN" & " RUNTYPE := 'C'" & " FLD_START := '3C'" & " ELSE" & " SMSG('NEITHER INFILE NOR OUTFILE SUPPLIED')" & " RETURN" & " FI" & " FI" & " " & " IF RUNTYPE NE 'C' THEN" & " PHASE := 'OPENING INPUT FILE FOR READ'" & " " & " OPF(NAM = VAL INFILE," & " CHA = IN," & " ACC = R," & " RES = FLAG)" & " " & " END_OF_FILE := FALSE" & " " & " FI" & " " & " IF RUNTYPE NE 'B' THEN" & " PHASE := 'CREATING OUTPUT FILE'" & " " & " CRF(NAM = VAL OUTFILE," & " LNA = OUTFL," & " RES = FLAG)" & " SVF(RES = FLAG)" & " " & " PHASE := 'OPENING OUTPUT FILE FOR WRITE'" & " " & " OPF(NAM = *OUTFL," & " CHA = OUT," & " ACC = O," & " RES = FLAG)" & " FI" & " " & " IF RUNTYPE NE 'C' THEN" & " " & " PHASE := 'READING INPUT FILE (1)'" & " " & " RDR(CHA = IN," & " REC = IN_REC," & " RES = SFLAG)" & " " & " IF SFLAG = 26272 THEN" & " END_OF_FILE := TRUE" & " ELSE" & " FLAG := SFLAG" & " FI" & " " & " ELSE" & " " & " SFLAG := 0" & " " & " FI" & " " & " REC_VALID := TRUE" & " " & " UNTIL (((((END_OF_FILE AND (RUNTYPE = 'B'))" & " OR (REPLY STARTSWITH 'E'))" & " OR (REPLY STARTSWITH 'e'))" & " OR (REPLY STARTSWITH 'Q'))" & " OR (REPLY STARTSWITH 'q'))" & " DO" & " " & " IN_PTR := 0" & " VALID_PTR := 0" & " " & " IF NOT REC_VALID THEN" & " IF RUNTYPE = 'C' THEN" & " REPLY_PTR := 0" & " ELSE" & " REPLY_PTR := 1" & " FI" & " FI" & " " & " IF RUNTYPE = 'C' THEN" & " REPLY := ''" & " AMSG_SCR := HEX(0C112320) + '" + RECORD_NAME + "' +" & " HEX(22022300)" & " ELSE" & " REPLY := ' '" & " " & " AMSG_SCR := HEX(0C112320) + '" + RECORD_NAME + "' +" & " HEX(22012305) + 'Action: ' + HEX(3C4011) +" & " HEX(22022300)" & " FI" & " " @ **** decide on start byte for fields - protected, unprotected, or @ **** unprotected flashing (for errors) SUPERSTRING START_BYTES := " " & " IF FLD_VALID[VALID_PTR] THEN" & " AMSG_SCR := AMSG_SCR + HEX(40) + HEX(VAL(FLD_START))" & " ELSE" & " AMSG_SCR := AMSG_SCR + HEX(5C13)" & " FLD_VALID[VALID_PTR] := TRUE" & " FI" & " " @ **** put the previous reply into the input fields if there were @ **** errors, to allow reinput SUPERSTRING REC_VALID_CHECK := " " & " IF NOT REC_VALID THEN" & " AMSG_SCR := AMSG_SCR +" & " SUBSTR[LAST_REPLY, REPLY_PTR, DISPLAY_LEN] +" & " HEX(1140)" & " REPLY_PTR := REPLY_PTR + DISPLAY_LEN" & " ELSE" & " IF ((RUNTYPE NE 'C') AND (NOT END_OF_FILE)) THEN" @ **** set up a type X field content SUPERSTRING DISPLAY_TYPE_X := " MSG_FIELD := SUBSTR(IN_REC, IN_PTR, DISPLAY_LEN)" & " " & " FOR FLD_PTR FROM 0 BY 1 TO LENGTH MSG_FIELD - 1" & " DO" & " CHECK_CHAR := SUBSTR(MSG_FIELD, FLD_PTR, 1)" & " IF INDEX(PRINTABLE, CHECK_CHAR) = -1 THEN" & " SUBSTR(MSG_FIELD, FLD_PTR, 1) := ' '" & " FI" & " REPEAT" & " " & " IN_PTR := IN_PTR + DISPLAY_LEN" & " FLD_END := HEX(1140)" @ **** set up a type H field content SUPERSTRING DISPLAY_TYPE_H := " REC_FLD_LEN := DISPLAY_LEN / 2" & " MSG_FIELD := HEXTOCHAR(SUBSTR(IN_REC," + " IN_PTR," + " REC_FLD_LEN))" & " IN_PTR := IN_PTR + REC_FLD_LEN" & " FLD_END := HEX(1140)" @ **** set up a type D (display numeric) field content and flag with @ **** an "!" after the field and "?" in the appropriate position in @ **** the field if there are any non-numeric characters present SUPERSTRING DISPLAY_TYPE_D := " MSG_FIELD := SUBSTR(IN_REC, IN_PTR, DISPLAY_LEN)" & " " & " WHILE MSG_FIELD STARTSWITH '0'" & " DO" & " MSG_FIELD := (MSG_FIELD AFTER '0') + ' '" & " REPEAT" & " " & " IF MSG_FIELD = '' THEN" & " MSG_FIELD := '0' + (MSG_FIELD AFTER ' ')" & " FI" & " " & " FLD_END := HEX(1140)" & " " & " FOR FLD_PTR FROM 0 BY 1 TO LENGTH MSG_FIELD - 1" & " DO" & " CHECK_CHAR := SUBSTR(MSG_FIELD, FLD_PTR, 1)" & " IF INDEX(' 1234567890', CHECK_CHAR) = -1 THEN" & " SUBSTR(MSG_FIELD, FLD_PTR, 1) := '?'" & " FLD_END := HEX(114F)" & " FI" & " REPEAT" & " " & " IN_PTR := IN_PTR + DISPLAY_LEN" @ **** set up type U and S (comp unsigned and signed) field content @ **** and flag with an "!" after the field if the value is too large @ **** for the field SUPERSTRING DISPLAY_TYPE_U_AND_S := "@ substituted at run time @" & " MSG_FIELD := NUMERIC(STINT(SUBSTR(IN_REC," + " IN_PTR," + " REC_FLD_LEN)))" & " " & " IF LENGTH MSG_FIELD < DISPLAY_LEN THEN" & " MSG_FIELD := MSG_FIELD + FILL(DISPLAY_LEN" + " - LENGTH MSG_FIELD)" & " FLD_END := HEX(1140)" & " ELSF LENGTH MSG_FIELD > DISPLAY_LEN THEN" & " MSG_FIELD := SUBSTR(MSG_FIELD, 0, DISPLAY_LEN)" & " FLD_END := HEX(114F)" & " FI" & " " & " IN_PTR := IN_PTR + REC_FLD_LEN" @ **** set up packed (COMP-3) field content SUPERSTRING DISPLAY_TYPE_P := "@ substituted at run time @" & " MSG_FIELD := HEXTOCHAR(SUBSTR(IN_REC," & " IN_PTR," & " REC_FLD_LEN))" & " " & " SIGN_CHAR := SUBSTR(MSG_FIELD,0,1)" & " MSG_FIELD := MSG_FIELD AFTER SIGN_CHAR" & " " & " IF SIGN_CHAR = 'D' THEN" & " MSG_FIELD := '-' + MSG_FIELD" & " FI" & " " & " IF LENGTH MSG_FIELD < DISPLAY_LEN THEN" & " MSG_FIELD := MSG_FIELD + FILL(DISPLAY_LEN" + " - LENGTH MSG_FIELD)" & " FI" & " " & " IN_PTR := IN_PTR + REC_FLD_LEN" & " FLD_END := HEX(1140)" @ **** for create, output empty field (unless redisplaying an error) @ **** and for others, display field content SUPERSTRING AMSG_FIELD := " REPLY := REPLY + MSG_FIELD" & " ELSE" & " MSG_FIELD := HEX(20) + BIN(DISPLAY_LEN, 1)" & " FI" & " " & " AMSG_SCR := AMSG_SCR + MSG_FIELD + FLD_END" & " " & " FI" & " " & " VALID_PTR := VALID_PTR + 1" & " " @ **** call AMSG to get the next record and decide what to do with @ **** it after checking the ACTION SUPERSTRING AMSG_CALL_1 := " " & " IF RUNTYPE = 'C' THEN" SUPERSTRING AMSG_CALL_2 := "@ substituted at runtime @" & " ELSE" & " AMSG_SCR := AMSG_SCR + HEX(2201230E)" & " FI" & " " & " REC_VALID := TRUE" & " VALID_PTR := 0" & " " & " REPLY_LEN := 0" & " REPLY := REPLY + FILL(2000 - LENGTH REPLY)" & " " & " PHASE := 'DOING AMSG (1)'" & " " & " AMSG(PRO = AMSG_SCR," & " MES = REPLY," & " LEN = REPLY_LEN," & " RES = FLAG)" & " " & " REPLY := REPLY + FILL(2001 - REPLY_LEN)" & " " & " IF RUNTYPE NE 'C' THEN" & " IF REPLY_LEN > 0 THEN" & " ACTION := SUBSTR(REPLY)" & " ELSE" & " ACTION := ' '" & " FI" & " FI" & " " & " IF (((RUNTYPE = 'C')" & " AND ((REPLY = '') OR (REPLY = 'Q')))" & " OR ((RUNTYPE NE 'C')" & " AND ('SsEeQq' INCLUDES ACTION))) THEN" & " " & " @ skip record @" & " " & " ELSF ((RUNTYPE = 'E')" & " AND (ACTION = 'C')) THEN" & " " & " WRR(CHA = OUT," & " REC = IN_REC," & " RES = FLAG)" & " " & " ELSF RUNTYPE NE 'B' THEN" & " " & " IF RUNTYPE = 'C' THEN" & " REPLY_PTR := 0" & " ELSE" & " REPLY_PTR := 1" & " FI" @ **** get a field from the screen input - type X SUPERSTRING X_FIELD_FETCH := " REPLY_FLD := SUBSTR(REPLY,REPLY_PTR,DISPLAY_LEN)" & " " @ **** get a field from the screen input - other (ie. numeric) fields SUPERSTRING NUM_FIELD_FETCH := " REPLY_FLD := SUBSTR(REPLY,REPLY_PTR,DISPLAY_LEN)" & " REPLY_FLD := (REPLY_FLD + ' ') BEFORE ' '" & " " & " IF REPLY_FLD = '' THEN" & " REPLY_FLD := '0'" & " FI" & " " & " IF REPLY_FLD STARTSWITH '-' THEN" & " SIGN_CHAR := '-'" & " REPLY_FLD := REPLY_FLD AFTER '-'" & " ELSE" & " SIGN_CHAR := '+'" & " IF REPLY_FLD STARTSWITH '+' THEN" & " REPLY_FLD := REPLY_FLD AFTER '+'" & " FI" & " FI" & " " & " IF (VALIDATE_FLD" & " AND (NOT DIGITS(REPLY_FLD))) THEN" & " FLD_VALID[VALID_PTR] := FALSE" & " REC_VALID := FALSE" & " ELSE" & " REPLY_FLD_NUM := CHARTOINT(SIGN_CHAR + REPLY_FLD)" & " FI" & " " @ **** allow extra validation to be specified in the file definition SUPERSTRING CUSTOM_VLDN := "@substituted at run time" & "@substituted at run time" & " @ passes validation @" & " ELSE" & " FLD_VALID[VALID_PTR] := FALSE" & " REC_VALID := FALSE" & " FI" & " " @ **** validates hex input and sets up output field SUPERSTRING VALIDATE_TYPE_H := " " & " FOR FLD_PTR FROM 0 BY 1" & " UNTIL FLD_PTR >= DISPLAY_LEN" & " DO" & " HEX_CHAR := SUBSTR(REPLY_FLD, FLD_PTR)" & " IF NOT (HEX_CHARS INCLUDES HEX_CHAR) THEN" & " FLD_VALID[VALID_PTR] := FALSE" & " REC_VALID := FALSE" & " FI" & " REPEAT" & " " & " IF FLD_VALID[VALID_PTR] THEN" & " REC_BUFF := REC_BUFF + " & " HEX(VAL REPLY_FLD, (DISPLAY_LEN / 2))" & " FI" & " " @ **** validates display numeric input and sets up output field SUPERSTRING VALIDATE_TYPE_D := " " & " IF FLD_VALID[VALID_PTR] THEN" & " REC_BUFF := REC_BUFF +" & " FILL(DISPLAY_LEN - LENGTH REPLY_FLD, '0') +" & " REPLY_FLD" & " FI" & " " @ **** validates unsigned numeric input and sets up comp output field SUPERSTRING VALIDATE_TYPE_U := " " & " IF SIGN_CHAR = '-' THEN" & " FLD_VALID[VALID_PTR] := FALSE" & " REC_VALID := FALSE" & " FI" & " " & " IF FLD_VALID[VALID_PTR] THEN" @ **** validates signed numeric input and sets up comp output field SUPERSTRING VALIDATE_TYPE_S := " " & " IF FLD_VALID[VALID_PTR] THEN" @ **** validates signed input and sets up packed output field SUPERSTRING VALIDATE_TYPE_P := " " & " IF FLD_VALID[VALID_PTR] THEN" & " IF SIGN_CHAR = '-' THEN" & " SIGN_CHAR := 'D'" & " ELSE" & " SIGN_CHAR := 'C'" & " FI" & " " & " REC_BUFF := REC_BUFF + " & " HEX(VAL (REPLY_FLD + SIGN_CHAR), " & " (DISPLAY_LEN / 2) + 1)" & " FI" @ **** procedure trailer SUPERSTRING PROC_TAIL := " " & " IF REC_VALID THEN" & " " & " PHASE := 'WRITING RECORD AWAY'" & " " & " WRR(CHA = OUT," & " REC = REC_BUFF," & " RES = FLAG)" & " " & " FI" & " " & " FI" & " " & " REC_BUFF := ''" & " REPLY_LEN := 0" & " " & " IF ((((REPLY STARTSWITH 'E')" & " OR (REPLY STARTSWITH 'e'))" & " OR (REPLY STARTSWITH 'Q'))" & " OR (REPLY STARTSWITH 'q')) THEN" & " " & " @ leave the reply alone so loop can finish" & " " & " ELSE" & " " & " IF ((RUNTYPE = 'E')" & " AND ((REPLY STARTSWITH 'I') " & " OR (REPLY STARTSWITH 'i'))) THEN" & " " & " @ redisplay the last record read @" & " " & " ELSF NOT REC_VALID THEN" & " " & " @ redisplay the screen with bad fields highlighted @" & " LAST_REPLY := REPLY" & " " & " ELSF RUNTYPE NE 'C' THEN" & " " & " IF NOT END_OF_FILE THEN" & " " & " PHASE := 'READING INPUT FILE (2)'" & " " & " RDR(CHA = IN," & " REC = IN_REC," & " RES = SFLAG)" & " " & " IF SFLAG = 26272 THEN" & " END_OF_FILE := TRUE" & " ELSE" & " FLAG := SFLAG" & " FI" & " " & " FI" & " " & " FI" & " " & " FI" & " " & " REPEAT" & " " & " IF ((RUNTYPE = 'E')" & " AND ((REPLY STARTSWITH 'E')" & " OR (REPLY STARTSWITH 'e'))) THEN" & " PHASE := 'COPYING TO END OF FILE'" & " UNTIL END_OF_FILE" & " DO" & " WRR(CHA = OUT," & " REC = IN_REC," & " RES = FLAG)" & " RDR(CHA = IN," & " REC = IN_REC," & " RES = SFLAG)" & " IF SFLAG = 26272 THEN" & " END_OF_FILE := TRUE" & " ELSE" & " FLAG := SFLAG" & " FI" & " REPEAT" & " FI" & " " & " IF RUNTYPE NE 'C' THEN" & " PHASE := 'CLOSING INPUT FILE'" & " " & " CLOF(CHA = IN," & " RES = FLAG)" & " FI" & " " & " IF RUNTYPE NE 'B' THEN" & " PHASE := 'CLOSING OUTPUT FILE'" & " " & " CLOF(CHA = OUT," & " RES = FLAG)" & " FI" & " " & " SMSG(HEX(0C))" & " " & "PROCEND" PHASE := "CREATING HANDLER SOURCE FILE" CRF(NAM = VAL (SOURCELIBRARY + "." + RECORD_NAME + "HANDLER"), LNA = SRCFILE, RES = FLAG) SVF(RES = FLAG) @ Use a previously existing definition or get the input from screen @ (and save it to a new definition file) ? IF USE_DEFN_FILE = "" THEN DEFN_FILE := SAVE_DEFN_FILE IF DEFN_FILE = "" THEN DEFN_FILE := RECORD_NAME + "DEFN" FI PHASE := "CREATING SAVED DEFN FILE" CRF(NAM = VAL DEFN_FILE, LNA = SAVE_DEFN, RES = FLAG) SVF(RES = FLAG) PHASE := "OPENING DEFN FILE FOR WRITE" OPF(NAM = *SAVE_DEFN, CHA = DEFN, ACC = O, RES = FLAG) AMSG_SCR := HEX(0C11231A) + "Generating handler for " + RECORD_NAME + HEX(2202230A) + "Field name" + HEX(2322) + "Type" + HEX(2327) + "Length" + HEX(233A) + "Validation" + HEX(153C2706201E11403C4011403C200311403C202211) FOR LINE_PTR FROM 1 BY 1 TO 18 DO AMSG_SCR := AMSG_SCR + HEX(153C201E11403C4011403C200311403C202211) REPEAT AMSG_SCR := AMSG_SCR + HEX(22032301) REPLY_LEN := 0 REPLY := FILL(2000) PHASE := "DOING AMSG (1)" AMSG(PRO = AMSG_SCR, MES = REPLY, LEN = REPLY_LEN, RES = FLAG) UNTIL ((REPLY = "") OR (REPLY = "Q")) DO FOR LINE_PTR FROM 1 BY 1 UNTIL LINE_PTR > 19 DO REPLY_PTR := (LINE_PTR - 1) * 68 FIELD_NAME := SUBSTR(REPLY, REPLY_PTR, 30) FIELD_TYPE := SUBSTR(REPLY, REPLY_PTR + 30, 1) FIELD_LEN := SUBSTR(REPLY, REPLY_PTR + 31, 3) FIELD_VLDN := SUBSTR(REPLY, REPLY_PTR + 34, 34) WHILE FIELD_NAME STARTSWITH " " DO FIELD_NAME := FIELD_NAME AFTER " " REPEAT WHILE FIELD_LEN STARTSWITH " " DO FIELD_LEN := FIELD_LEN AFTER " " REPEAT IF (((FIELD_NAME NE "") AND (FIELD_TYPE NE "")) AND (FIELD_LEN NE "")) THEN REC_BUFF := SUBSTR(FIELD_NAME + FILL(30),,30) + SUBSTR(FIELD_TYPE + " ") + SUBSTR(FIELD_LEN + " ",,3) + SUBSTR(FIELD_VLDN + FILL(34),,34) PHASE := "WRITING SAVED DEFN FILE" WRR(CHA = DEFN, REC = REC_BUFF, RES = FLAG) FI REPEAT REPLY_LEN := 0 REPLY := FILL(2000) PHASE := "DOING AMSG (2)" AMSG(PRO = AMSG_SCR, MES = REPLY, LEN = REPLY_LEN, RES = FLAG) REPEAT PHASE := "CLOSING SAVE_DEFN FILE" CLOF(CHA = DEFN, RES = FLAG) SMSG(HEX(0C)) ELSE DEFN_FILE := USE_DEFN_FILE FI @ Now generate the edit procedure from the input data @ PHASE := "ASSIGNING DEFN_FILE" AF(NAM = VAL DEFN_FILE, LNA = USE_DEFN, RES = FLAG) PHASE := "OPENING DEFN_FILE" OPF(NAM = *USE_DEFN, CHA = DEFN, ACC = R, RES = FLAG) PHASE := "OPENING SOURCE FILE" OPF(NAM = *SRCFILE, CHA = SOURCE, ACC = A, RES = FLAG) PHASE := "WRITING HEADER STUFF" FOR PART_PTR FROM 0 BY 1 TO COUNT PROC_HEAD DO WRR(CHA = SOURCE, REC = PROC_HEAD[PART_PTR], RES = FLAG) REPEAT LINE_PTR := 0 PHASE := "READING USE_DEFN RECORD (1)" RDR(CHA = DEFN, REC = REC_BUFF, RES = SFLAG) UNTIL SFLAG NE 0 DO REC_BUFF := REC_BUFF + " " FIELD_NAME := SUBSTR(REC_BUFF, 0, 30) FIELD_TYPE := SUBSTR(REC_BUFF, 30, 1) FIELD_LEN := SUBSTR(REC_BUFF, 31, 3) WHILE FIELD_NAME ENDSWITH " " DO FIELD_NAME := SUBSTR(FIELD_NAME,,LENGTH FIELD_NAME - 1) REPEAT WHILE FIELD_LEN ENDSWITH " " DO FIELD_LEN := SUBSTR(FIELD_LEN,,LENGTH FIELD_LEN - 1) REPEAT IF SOM_POSN = 0 THEN SOM_POSN := LENGTH FIELD_NAME + 1 FI SEGMENT_LEN := CHARTOINT(FIELD_LEN) + LENGTH FIELD_NAME + 4 IF ((SEGMENT_LEN > 80) OR ((SEGMENT_LEN + LINE_PTR) > 80)) THEN PHASE := "WRITING NEWLINE" WRR(CHA = SOURCE, REC = " AMSG_SCR := AMSG_SCR + HEX(15)", RES = FLAG) WRR(CHA = SOURCE, REC = " ", RES = FLAG) LINE_PTR := 0 FI PHASE := "WRITING FIELD NAME" WRR(CHA = SOURCE, REC = " AMSG_SCR := AMSG_SCR + '" + FIELD_NAME + "'", RES = FLAG) PHASE := "WRITING FIELD START BYTE" FOR PART_PTR FROM 0 BY 1 TO COUNT START_BYTES DO WRR(CHA = SOURCE, REC = START_BYTES[PART_PTR], RES = FLAG) REPEAT PHASE := "WRITING DISPLAY_LEN ASSIGNMENT" WRR(CHA = SOURCE, REC = " DISPLAY_LEN := " + FIELD_LEN, RES = FLAG) @ This starts to get a bit complicated now... @ If it's a build or edit, we want to output the actual contents @ of the record as they currently exist, otherwise just put a @ blank field there, unless it's an error record, when we want @ to put the previously input contents in there PHASE := "WRITING FIELD CONTENTS FOR EDIT/BROWSE" FOR PART_PTR FROM 0 BY 1 TO COUNT REC_VALID_CHECK DO WRR(CHA = SOURCE, REC = REC_VALID_CHECK[PART_PTR], RES = FLAG) REPEAT IF FIELD_TYPE = "X" THEN FOR PART_PTR FROM 0 BY 1 TO COUNT DISPLAY_TYPE_X DO WRR(CHA = SOURCE, REC = DISPLAY_TYPE_X[PART_PTR], RES = FLAG) REPEAT ELSF FIELD_TYPE = "H" THEN FOR PART_PTR FROM 0 BY 1 TO COUNT DISPLAY_TYPE_H DO WRR(CHA = SOURCE, REC = DISPLAY_TYPE_H[PART_PTR], RES = FLAG) REPEAT ELSF FIELD_TYPE = "D" THEN FOR PART_PTR FROM 0 BY 1 TO COUNT DISPLAY_TYPE_D DO WRR(CHA = SOURCE, REC = DISPLAY_TYPE_D[PART_PTR], RES = FLAG) REPEAT ELSF FIELD_TYPE = "U" THEN BIN_PTR := CHARTOINT(FIELD_LEN) DISPLAY_TYPE_U_AND_S[0] := " REC_FLD_LEN := " + SUBSTR(BIN_LEN_LIST, BIN_PTR, 1) FOR PART_PTR FROM 0 BY 1 TO COUNT DISPLAY_TYPE_U_AND_S DO WRR(CHA = SOURCE, REC = DISPLAY_TYPE_U_AND_S[PART_PTR], RES = FLAG) REPEAT ELSF FIELD_TYPE = "S" THEN BIN_PTR := CHARTOINT(FIELD_LEN) - 1 DISPLAY_TYPE_U_AND_S[0] := " REC_FLD_LEN := " + SUBSTR(BIN_LEN_LIST, BIN_PTR, 1) FOR PART_PTR FROM 0 BY 1 TO COUNT DISPLAY_TYPE_U_AND_S DO WRR(CHA = SOURCE, REC = DISPLAY_TYPE_U_AND_S[PART_PTR], RES = FLAG) REPEAT ELSF FIELD_TYPE = "P" THEN DISPLAY_TYPE_P[0] := " REC_FLD_LEN := " + NUMERIC((CHARTOINT(FIELD_LEN) / 2) + 1) FOR PART_PTR FROM 0 BY 1 TO COUNT DISPLAY_TYPE_P DO WRR(CHA = SOURCE, REC = DISPLAY_TYPE_P[PART_PTR], RES = FLAG) REPEAT FI PHASE := "WRITING AMSG FIELD LINES" FOR PART_PTR FROM 0 BY 1 TO COUNT AMSG_FIELD DO WRR(CHA = SOURCE, REC = AMSG_FIELD[PART_PTR], RES = FLAG) REPEAT LINE_PTR := LINE_PTR + SEGMENT_LEN PHASE := "READING USE_DEFN RECORD (2)" RDR(CHA = DEFN, REC = REC_BUFF, RES = SFLAG) REPEAT IF SFLAG NE 26272 THEN FLAG := SFLAG FI PHASE := "WRITING NEXT SET OF FIXED INSTRUCTIONS" FOR PART_PTR FROM 0 BY 1 TO COUNT AMSG_CALL_1 DO WRR(CHA = SOURCE, REC = AMSG_CALL_1[PART_PTR], RES = FLAG) REPEAT AMSG_CALL_2[0] := " AMSG_SCR := AMSG_SCR + HEX(220223" + HEXTOCHAR(BIN(SOM_POSN),2) + "270623" + HEXTOCHAR(BIN(SOM_POSN + 1),2) + ")" FOR PART_PTR FROM 0 BY 1 TO COUNT AMSG_CALL_2 DO WRR(CHA = SOURCE, REC = AMSG_CALL_2[PART_PTR], RES = FLAG) REPEAT PHASE := "CLOSING DEFN_FILE" CLOF(CHA = DEFN, RES = FLAG) PHASE := "OPENING DEFN_FILE AGAIN" OPF(NAM = *USE_DEFN, CHA = DEFN, ACC = R, RES = FLAG) PHASE := "READING USE_DEFN RECORD (3)" RDR(CHA = DEFN, REC = REC_BUFF, RES = SFLAG) UNTIL SFLAG NE 0 DO REC_BUFF := REC_BUFF + FILL(36) FIELD_NAME := (SUBSTR(REC_BUFF, 0, 30) + " ") BEFORE " " FIELD_TYPE := (SUBSTR(REC_BUFF, 30, 1) + " ") BEFORE " " FIELD_LEN := (SUBSTR(REC_BUFF, 31, 3) + " ") BEFORE " " FIELD_VLDN := SUBSTR(REC_BUFF, 34, 34) IF FIELD_VLDN NE "" THEN WHILE FIELD_VLDN INCLUDES "%F" DO IF ((FIELD_TYPE = "X") OR (FIELD_TYPE = "H")) THEN FIELD_VLDN := (FIELD_VLDN BEFORE "%F") + "REPLY_FLD" + (FIELD_VLDN AFTER "%F") ELSE FIELD_VLDN := (FIELD_VLDN BEFORE "%F") + "REPLY_FLD_NUM" + (FIELD_VLDN AFTER "%F") FI REPEAT WHILE FIELD_VLDN ENDSWITH " " DO FIELD_VLDN := SUBSTR(FIELD_VLDN, 0, LENGTH FIELD_VLDN - 1) REPEAT FI PHASE := "WRITING START OF FIELD PROCESSING" WRR(CHA = SOURCE, REC = " ", RES = FLAG) WRR(CHA = SOURCE, REC = "@ Processing for " + FIELD_NAME + " @", RES = FLAG) WRR(CHA = SOURCE, REC = " ", RES = FLAG) WRR(CHA = SOURCE, REC = " DISPLAY_LEN := " + FIELD_LEN, RES = FLAG) PHASE := "WRITING FIELD_FETCH" IF ((FIELD_TYPE = "X") OR (FIELD_TYPE = "H")) THEN FOR PART_PTR FROM 0 BY 1 TO COUNT X_FIELD_FETCH DO WRR(CHA = SOURCE, REC = X_FIELD_FETCH[PART_PTR], RES = FLAG) REPEAT ELSE FOR PART_PTR FROM 0 BY 1 TO COUNT NUM_FIELD_FETCH DO WRR(CHA = SOURCE, REC = NUM_FIELD_FETCH[PART_PTR], RES = FLAG) REPEAT FI IF FIELD_VLDN NE "" THEN PHASE := "WRITING CUSTOM VALIDATION" CUSTOM_VLDN[0] := " IF (VALIDATE_FLD" CUSTOM_VLDN[1] := " AND (" + FIELD_VLDN + ")) THEN" FOR PART_PTR FROM 0 BY 1 TO COUNT CUSTOM_VLDN DO WRR(CHA = SOURCE, REC = CUSTOM_VLDN[PART_PTR], RES = FLAG) REPEAT FI PHASE := "WRITING REPLY_PTR INCREMENT" WRR(CHA = SOURCE, REC = " REPLY_PTR := REPLY_PTR + DISPLAY_LEN", RES = FLAG) IF FIELD_TYPE = "X" THEN PHASE := "WRITING VALIDATE TYPE X" WRR(CHA = SOURCE, REC = " REC_BUFF := REC_BUFF + REPLY_FLD", RES = FLAG) ELSF FIELD_TYPE = "H" THEN PHASE := "WRITING VALIDATE_H" FOR PART_PTR FROM 0 BY 1 TO COUNT VALIDATE_TYPE_H DO WRR(CHA = SOURCE, REC = VALIDATE_TYPE_H[PART_PTR], RES = FLAG) REPEAT ELSF FIELD_TYPE = "D" THEN PHASE := "WRITING VALIDATE_D" FOR PART_PTR FROM 0 BY 1 TO COUNT VALIDATE_TYPE_D DO WRR(CHA = SOURCE, REC = VALIDATE_TYPE_D[PART_PTR], RES = FLAG) REPEAT ELSF FIELD_TYPE = "U" THEN BIN_PTR := CHARTOINT(FIELD_LEN) PHASE := "WRITING VALIDATE_U" FOR PART_PTR FROM 0 BY 1 TO COUNT VALIDATE_TYPE_U DO WRR(CHA = SOURCE, REC = VALIDATE_TYPE_U[PART_PTR], RES = FLAG) REPEAT PHASE := "WRITING VALIDATE_U LAST BIT" WRR(CHA = SOURCE, REC = " REC_BUFF := REC_BUFF + " + "BIN(CHARTOINT(REPLY_FLD), " + SUBSTR(BIN_LEN_LIST, BIN_PTR, 1) + ")", RES = FLAG) WRR(CHA = SOURCE, REC = " FI", RES = FLAG) WRR(CHA = SOURCE, REC = " ", RES = FLAG) ELSF FIELD_TYPE = "S" THEN BIN_PTR := CHARTOINT(FIELD_LEN) - 1 PHASE := "WRITING VALIDATE_S" FOR PART_PTR FROM 0 BY 1 TO COUNT VALIDATE_TYPE_S DO WRR(CHA = SOURCE, REC = VALIDATE_TYPE_S[PART_PTR], RES = FLAG) REPEAT PHASE := "WRITING VALIDATE_S LAST BIT" WRR(CHA = SOURCE, REC = " REC_BUFF := REC_BUFF + " + "BIN(CHARTOINT(SIGN_CHAR + REPLY_FLD), " + SUBSTR(BIN_LEN_LIST, BIN_PTR, 1) + ")", RES = FLAG) WRR(CHA = SOURCE, REC = " FI", RES = FLAG) WRR(CHA = SOURCE, REC = " ", RES = FLAG) ELSF FIELD_TYPE = "P" THEN PHASE := "WRITING VALIDATE_P" FOR PART_PTR FROM 0 BY 1 TO COUNT VALIDATE_TYPE_P DO WRR(CHA = SOURCE, REC = VALIDATE_TYPE_P[PART_PTR], RES = FLAG) REPEAT FI PHASE := "WRITING VALID_PTR INCREMENT" WRR(CHA = SOURCE, REC = " VALID_PTR := VALID_PTR + 1", RES = FLAG) PHASE := "READING USE_DEFN RECORD (4)" RDR(CHA = DEFN, REC = REC_BUFF, RES = SFLAG) REPEAT IF SFLAG NE 26272 THEN FLAG := SFLAG FI PHASE := "CLOSING DEFN_FILE AGAIN" CLOF(CHA = DEFN, RES = FLAG) PHASE := "WRITING LAST FIXED BIT OF SOURCE FILE" FOR PART_PTR FROM 0 BY 1 TO COUNT PROC_TAIL DO WRR(CHA = SOURCE, REC = PROC_TAIL[PART_PTR], RES = FLAG) REPEAT PHASE := "CLOSING SOURCE FILE" CLOF(CHA = SOURCE, RES = FLAG) PHASE := "COMPILING GENERATED SCL" CSCL(INP = *SRCFILE, OUT = VAL OMFLIBRARY, COD = NE, RES = FLAG) END