         TITLE    'QREMAKE C00E'
*M*      QREMAKE RECONSTRUCTS THE TRANSACTION PROCESSING QUEUE USING THE JRNL
************************************************************************
*                           Q R E M A K E                              *
*P*      PURPOSE:
*DO*
*P*
*   QREMAKE RECONTRUCTS THE QUEUE IF IT HAS BEEN DESTROYED OR LOST.    *
*   THE QUEUE IS RECONSTRUCTED FROM THE COMMON JOURNAL. THE            *
*   RECONSTRUCTED QUEUE MAY BE MORE COMPLETE THAN THE QUEUE AT THE     *
*   TIME OF THE CRASH SINCE IT INCLUDES TRANSACTIONS AND REPORTS       *
*   WHICH HAD BEEN JOURNALIZED BUT NOT YET QUEUED.                     *
*FIN*
*P*      REFERENCE: TRANSACTION PROCESSING REFERENCE MANUAL 90-31-12
*d*      NAME: QREMAKE
*D*      CALL: QREMAKE IS A FREE STANDING SLAVE PROGRAM
*D*      INTERFACE: QREMAKE USES STANDARD ANS TAPE I/O TO DO ALL
*D*      COMMON JOURNAL READING.  CALLS ARE MADE TO THE QUEUE MANAGER
*D*      TO ENTER AND DELETE QUEUE ENTRIES FOUND ON THE COMMON JOURNAL.
*D*      ENVIRONMENT: UNMAPED, SLAVE, PRIVILEGE 40.  QREMAKE MUST BE
*D*      RUN IN THE :SYS ACCOUNT TO REBUILD THE TP QUEUE
*                                                                      *
*   THIS IS PHASE 3 OF TRANSACTION PROCESSING RECOVERY.                *
*                                                                      *
*D*      DATA:
*D*      DYNAMIC BLOCKS FOR TRANSACTIONS AND REPORTS
*D*      WORD 0   TRANID
*D*      WORD 1   WA(NEXT SEQUENTIAL TRANID BLOCK) OR
*D*               ZERO IF LAST BLOCK ON CHAIN.
*D*      WORD 2   WA(LAST SEQUENTIAL TRANID) OR
*D*               ZERO IF FIRST BLOCK ON CHAIN.
*D*      WORD 3   WA(TRANID BLOCK) OF SPAWNED TRANS OR ZERO IF NO
*D*               SPAWNED TRANSACTIONS.
*d*      WORD 4   IF THIS IS A SPAWNED TRANSACTION WA(TRANID BLOCK)
*D*               OF ORIGINATING TRANSACTION.
*D*      WORD 5(1) NAME LENGTH OF TRAN OR REPORT ID
*D*      WORD 5(BIT 8) 1 IF BEGIN ENCOUNTERED BIT 8
*D*      WORD 5(BIT 9) 1 IF END ENCOUNTERED BIT 9
*D*      WORD 5(BITS 15-31) CHAIN OF REPORT BLOCKS ATTACHED TO THIS
*D*               TRANSACTION.
*D*      WORD 6-13 NAME
*D*      WORD 14  FLAGS--JOURNAL AND QUEUE FLAGS (BYTE 0)
*D*
*DO*
*D*
*   INPUT:                                                             *
*     - F:JOURNAL  CONSECUTIVE FILE OF JOURNAL RECORDS. JOURNAL        *
*                  RECORD FORMAT IS DESCRIBED BY SYSTEM DTPJOURNAL.    *
*     - F:TPFILES  DIRECT KEYED FILE THAT IS ACCESSED IN ORDER TO      *
*                  DETERMINE THE CURRENT VOLUME SERIAL NUMBER OF THE   *
*                  JOURNAL.  IF THIS FILE CANNOT BE ACCESSED, THE      *
*                  OPERATOR IS ASKED TO KEY IN THE CURRENT VOLUME      *
*                  SN. RECORD FORMAT IS DEFINED IN READ%TPFILES ROUTINE*
*D*      COMMON JOURNAL RECORD USED ARE AS FOLLOWS-
*D*               BEGIN TRANSACTION
*D*               OUTPUT REPORT
*D*               BEGIN REPORT DELIVERY
*D*               END REPORT DELIVERY
*D*               END TRANSACTION
*D*               QUEUE DUMP
*D*               CRASH
*D*      ALL JOURNAL RECORD FORMATS ARE DESCRIBED IN THE TP REFERENCE
*D*               MANUAL 90-31-12.
*D*      DESCRIPTION: THE LAST USED COMMON JOURNAL IS READ USING
*D*               THE QUEUE DUMP AT ITS BEGINNING TO INITILIZE THE
*D*               QUEUE.  ALL ENCOUNTERED BEGIN TRANSACTIONS ARE PUT
*D*               INTO THE TPQUEUE.  WHEN THEIR CORRESPONDING END
*D*               TRANSACTIONS ARE READ THEY ARE DEQUEUED.  WHEN
*D*               THE END OF THE JOURNAL IS REACHED (CRASH RECORD
*D*               FOLLOWED BY AN END OF FILE) ANY TRANSACTIONS LEFT
*D*               IN THE QUEUE ARE PRESUMED TO BE IN-PROGRESS I.E
*D*               TO BE RECOVERED, SINCE NO END TRANSACTION RECORD
*D*               WAS FOUND FOR THEM.  REPORTS ARE HANDLED IN THE
*D*               SAME MANNER I.E. BEGIN REPORT DELIVERY AND END
*D*               REPORT DELIVERY PAIRS ARE USED TO QUEUE AND DEQUEUE
*d*               REPORTS. ANYTHING LEFT WHEN THE JOURNAL IS PROCESSED
*D*               IS PRESUMED TO BE IN PROGRESS AND TO BE RECOVERED.
*D*               THE HIGHEST TRANSACTION ID ENCOUNTERED ON THE COMMON
*D*               JOURNAL IS SAVED IN THE TTP TABLE (TTI+14) BY QREMAKE.
*   OUTPUT:                                                            *
*     - F:QUEUE    DIRECT RANDOM FILE.  THIS FILE IS INITIALIZED BY    *
*                  QDUMP RECORDS FROM THE JOURNAL.  IT IS THEN         *
*                  RECONSTRUCTED BY M:QUEUE AS RECORDS ARE READ        *
*                  FROM THE JOURNAL.                                   *
*     - M:LL       ANOMALY CONDITIONS AND REPORTS ARE WRITTEN TO       *
*                  LISTING LOG.                                        *
*     - M:OC       ERROR MESSAGES ARE WRITTEN TO THE OPERATOR'S        *
*                  CONSOLE.                                            *
*FIN*
************************************************************************
         PCC      0
         PAGE
*   ASSEMBLY PARAMETERS
         SPACE
DELETE%FAILED%KEEP  SET  1          IF FLAG IS SET, ENDED TRANSACTIONS
*                                   MARKED 'FAILED,KEEP' ARE NOT
*                                   ENTERED IN THE QUEUE.
DELETE%FAILED%KEEP  SET  0          IF FLAG IS RESET, ENDED TRANSACTIONS
DELETE%FAILED%KEEP   SET   1
*                                   MARKED 'FAILED, KEEP' ARE LEFT
*                                   IN THE QUEUE.
         SPACE
DBGKEY   SET      0                 SET TO 1 FOR A DEBUG TRACE
         PAGE
************************************************************************
*   REGISTER USAGE:                                                    *
*                                                                      *
*   - R4-R7   ARE USED FOR PASSING PARAMETERS:                         *
*             R4 =  BA(OUTPUT AREA) FOR FORMATTING ROUTINES.           *
*             R5,R6 POINT TO A DYNAMIC TRAN%BLOCK DESCRIBED BELOW      *
*                   UNDER 'CODES AND RECORD DESCRIPTIONS'              *
*             R7    POINTS TO THE CURRENT JOURNAL RECORD               *
*   - LINK    IS USED FOR SUBROUTINE LINKAGE                           *
*   - ALL OTHER REGISTERS ARE USED FOR WORK REGISTERS.                 *
*     REGISTERS ARE NOT SAVED AND RESTORED BY SUBROUTINES.             *
************************************************************************
         SPACE    2
         SYSTEM   SIG7FDP
         SYSTEM   TPPROCS           WAS SYSTEM BPM FOR TP
         SYSTEM   TP:TPO
         SYSTEM   LP:TPOQ
         PAGE
*   THE FOLLOWING MASKS ARE USED BY THE TP:TPO PROCEDURES
         SPACE
         CSECT    1
         GENTABS
         TITLE    'QREMAKE   PROCEDURES'
         SPACE
*   OPEN VARIABLES USED ONLY BY THESE PROCS.
         OPEN     FLAG,FORMAT%CC,CR
         OPEN     NO%TRACELIST,NO%TRACE%PRESENT
         OPEN     I,J,K,T
         OPEN     TRACE%PRESENT,TRACELIST,PASS,PASS2,LINK
         OPEN     TRACEBIT,SUBADDR,SUBNAME,SUBLISTNUM,EXPLAN,TEMPLOC
         OPEN     EXPL,SNAME,SADDR,OLDLOC,TEMP,SUB#,MSGLOC,@PRINT
         OPEN     CALLMON,FROM%SUB,TOSUB,LAST%PAREN,PRINT%GO,ENTER
         OPEN     RETMON,FROM%SB,NEXT%CODE,FORMAT%ADDRESS,NEXT%HEX%DIGIT
         OPEN     MOVE,MOVE%NEXT,PRINT%LINE,CC,SAVEREGS,SUBSTACK
         OPEN     LINE,CODES,FROM%ADDRESS,MAIN%PROGRAM,TOMAIN,FROM
         OPEN     RPAREN,CALLTO,RETRN,CAL,TO,STACK,PRINT%USED,TYPE%USED
         OPEN     @TYPE,#SUBROUTINES
         SPACE    2
,FPTSECT M:PT     0                 PROTECTION 0 FOR FPT'S
MSGSECT  CSECT    1                 CSECT FOR M:PRINT MESSAGES
MSGLOC   SET      %                 LOCATION COUNTER FOR MESSAGES
QRMK     CSECT    0
         DEF      QRMK              DEF FOR PATCHING
         DEF      MSGSECT,FPTSECT
         DEF      QREMAKE
         DEF      PATCH
SAVE:Q:TID   EQU   TTP+14
         SPACE
TYPE%USED         SET  0            WILL BE SET IF TYPE PROC USED
PRINT%USED        SET  0            WILL BE SET IF PRINT PROC USED
TRACE%PRESENT     SET  0            THIS FLAG WILL BE SET BY FLAG
*                                   FUNCTION IF TRACE%ENTRY      PROC
*                                   IS USED.
NO%TRACE%PRESENT  SET  0            THIS FLAG WILL BE SET BY FLAG
*                                   FUNCTION IF NO%TRACE%ENTRY
*                                   PROC IS USED.
         SPACE
#SUBROUTINES      SET  S:UFV(SUBROUTINE#) NUMBER SUBROUTINES USED
SUBROUTINE#       SET  0            CURRENT SUBROUTINE NUMBER
LINK     EQU      R0                SUBROUTINE LINK REGISTER
         SPACE
*   A LIST IS BUILT FOR EACH SUBROUTINE DEFINED. THE FOLLOWING
*   VARIABLES ARE USED TO ACCESS THE LIST.
SUB#     EQU      1                 SUBROUTINE NUMBER
SUBADDR  EQU      2                 SUBROUTINE ADDRESS
SUBNAME  EQU      3                 SUBROUTINE NAME IN TEXT
EXPLAN   EQU      4                 SUBROUTINE EXPLANATION
SUBLISTNUM        EQU  3            MINIMUM NUMBER OF ELEMENTS IN LIST
         TITLE    'HELPER PROCS USED BY OTHER PROCEDURES'
         SPACE
         DO       DBGKEY=0          IF NOT DEBUGGING, GENERATE
@T       CSECT    0                 CSECT FOR TEMP STORAGE TO SAVE
TEMPLOC  SET      %                 LINK ADDRESSES.
         FIN
         SPACE    2
************************************************************************
*   RESTEMP RESERVES AF WORDS IN TEMP.                                 *
*   RETURN : TEMP = FIRST WORD RESERVED.                               *
************************************************************************
TEMP     SET      %
RESTEMP  CNAME
         PROC
OLDLOC   SET      %                 SAVE LOCATION COUNTER
         ORG      TEMPLOC           SET LOCATION COUNTER TO TEMP CSECT
TEMP     SET      %
         RES      AF                RESERVE AF WORDS
TEMPLOC  SET      %                 UPDATE TEMP LOCATION COUNTER
         ORG      OLDLOC            RESTORE SAVED LOCATION COUNTER
         PEND
         SPACE    2
FLAG     FNAME                      ARGUMENT IS 2-ELEMENT LIST:
         PROC                       (FLAG TO SET,VALUE TO RETURN)
AF(1)    SET      1                 SET FLAG SPECIFIED BY AF(1)
         PEND     AF(2)             RETURN VALUE OF AF(2)
         TITLE    'CALL PROCEDURE'
************************************************************************
*   CALL LINKS TO INTERNAL SUBROUTINE. FORMAT:                         *
*                                                                      *
*        LABEL    CALL   SUBROUTINE                                    *
*                                                                      *
*   OUTPUT IF DEBUGGING:                                               *
*                                                                      *
*        LABEL    BAL,LINK  CALLMON                                    *
*                 GEN,8,1,23  SUB#,TRACEBIT,SUBADDR                    *
*                                                                      *
*   OUTPUT IF NOT DEBUGGING:                                           *
*                                                                      *
*        LABEL    BAL,LINK  SUBADDR                                    *
************************************************************************
CALL     CNAME
         PROC
I        SET      S:UFV(AF)         I = LIST ASSOCIATED WITH SUBROUTINE
         ERROR,7,NUM(I)<SUBLISTNUM ;
         'AF HAS NOT BEEN DEFINED AS A SUBROUTINE'
K        SET      I(EXPLAN)         K = LIST OF TEXT MESSAGES
J        DO       NUM(K)            ONCE FOR EACH LINE OF TEXT
         ERROR,*  ;
         '                                     *  ',K(J)
         FIN
         DO       DBGKEY=1          IF DEBUGGING
LF       BAL,LINK CALLMON
SUBNUM   SET      I(SUB#)           SET SUBROUTINE NUMBER
T        SET      1                 ASSUME TRACE SUBROUTINE
         DO       NO%TRACE%PRESENT  IF SUBROUTINES NOT TO TRACE
T        SET      0                 ARE LISTED IN NO%TRACE%ENTRY PROC
         DO1      NO%TRACELIST(SUBNUM)  IF USER HAS NOT
T        SET      1                 SPECIFIED NO TRACE THEN TRACE
         FIN
         DO1      TRACE%PRESENT     IF SUBROUTINES TO TRACE
T        SET      TRACELIST(SUBNUM) ARE SPECIFIED
         GEN,8,1,23  I(SUB#),T,I(SUBADDR)
         ELSE
LF       BAL,LINK I(SUBADDR)
         FIN
         PEND
         TITLE    'ENTRY PROCEDURE'
************************************************************************
*   ENTRY DEFINES A SUBROUTINE. FORMAT :                               *
*                                                                      *
*        LABEL,'LABEL'   ENTRY  'EXPLANATION',...                      *
*                                                                      *
*   LABEL IS THE NAME OF THE SUBROUTINE USED IN THE CALL PROC.         *
*                                                                      *
*   'LABEL' IS THE NAME OF THE SUBROUTINE IN TEXT FORMAT.              *
*   THIS IS OPTIONAL. IT IS USED TO TRACE SUBROUTINE CALLS.            *
*                                                                      *
*   'EXPLANATION' IS A SHORT DESCRIPTION OF WHAT THE SUBROUTINE DOES.  *
*   EACH 'EXPLANATION' WILL BE GENERATED AS A COMMENT WHEN THE CALL    *
*   IS ENCOUNTERED.                                                    *
*                                                                      *
*   OUTPUT IF DEBUGGING:                                               *
*                                                                      *
*        LABEL    TEXTC  'LABEL'                                       *
*                                                                      *
*   OUTPUT IF NOT DEBUGGING                                            *
*                                                                      *
*        LABEL    STW,LINK   TEMP         SAVE LINK REGISTER           *
************************************************************************
ENTRY    CNAME
         PROC
SUBROUTINE#       SET  SUBROUTINE#+1  INCREMENT NO. OF SUBROUTINES
EXPL     SET      AF                LIST OF EXPLANATION LINES
         DO       NUM(LF)=2
SNAME    SET      LF(2)             SUBROUTINE NAME IN TEXT FORMAT
         ELSE
SNAME    SET      ' '               IF NONE, SET BLANK
         FIN
SADDR    SET      %                 SUBROUTINE ADDRESS
         DO       DBGKEY=1
         TEXTC    SNAME             GENERATE SUBROUTINE NAME
         ELSE
         RESTEMP  1                 RESERVE 1 WORD IN TEMP
         STW,LINK TEMP              SAVE RETURN ADDRESS
         FIN
LF(1)    EQU      SUBROUTINE#,SADDR,SNAME,(EXPL)
         PEND
         TITLE    'TRACE%ENTRY AND NO%TRACE%ENTRY PROCEDURES'
************************************************************************
*   TRACE%ENTRY PROC SETS A FLAG FOR EACH SUBROUTINE TO BE TRACED.     *
*   IF THIS PROC IS NOT USED, ALL SUBROUTINES WILL BE TRACED IF THE    *
*   DBGKEY FLAG IS ON. FORMAT IS:                                      *
*                                                                      *
*        TRACE%ENTRY       SUBROUTINE NAME,...                         *
*                                                                      *
*   NO%TRACE%ENTRY PROC SETS A FLAG FOR EACH SUBROUTINE THAT           *
*   IS NOT TO BE TRACED. IF THIS PROCEDURE  IS USED,                   *
*   SUBROUTINES THAT ARE NOT LISTED WILL BE TRACED.                    *
************************************************************************
NO%TRACE%ENTRY    CNAME  FLAG(NO%TRACE%PRESENT,1) SET NO%TRACE
TRACE%ENTRY       CNAME  FLAG(TRACE%PRESENT,0)  SET TRACE%PRESENT FLAG
         PROC
I        DO       NUM(AF)           ONCE FOR EACH SUBROUTINE LISTED
J        SET      S:UFV(AF(I))      J = LIST ASSOCIATED WITH
*                                   SUBROUTINE NAME
         DO       NUM(J)>1          DO IF LIST, I.E., IF SUBROUTINE
*                                   DEFINED.
K        SET      J(SUB#)           K = SUBROUTINE NUMBER
         DO       NAME              IF NO%TRACE%ENTRY
NO%TRACELIST(K)   SET  1            SET NO TRACE FOR SUBROUTINE
         ELSE                       IF TRACE%ENTRY
TRACELIST(K)      SET  1            SET TRACE FLAG FOR SUBROUTINE
         FIN
         FIN
         FIN
         PEND
         SPACE
         TITLE    'RETURN PROCEDURE'
************************************************************************
*   RETURN RETURNS TO INTERNAL SUBROUTINE. FORMAT:                     *
*                                                                      *
*        LABEL    RETURN                                               *
*                                                                      *
*   OUTPUT IF DEBUGGING:                                               *
*                                                                      *
*        LABEL    BAL,LINK  RETMON                                     *
*                                                                      *
*   OUTPUT IF NOT DEBUGGING:                                           *
*                                                                      *
*        LABEL    B         *LINK                                      *
*                                                                      *
************************************************************************
RETURN   CNAME
         PROC
         DO       DBGKEY=1
LF       BAL,LINK RETMON
         ELSE
LF       B        *TEMP
         FIN
         PEND
         DO       DBGKEY=0
         USECT    QRMK
         FIN
         TITLE    'TYPE AND PRINT PROCEDURES'
************************************************************************
*   PRINT PRINTS A MESSAGE USING M:PRINT.                              *
*   TYPE  PRINTS A MESSAGE USING M:TYPE. FORMAT:                       *
*        LABEL    PRINT  MESSAGE                                       *
*        LABEL    TYPE   MESSAGE                                       *
*   MESSAGE MAY BE A TEXT STRING OR AN ADDRESS OF A TEXTC FORMAT       *
*   MESSAGE.                                                           *
************************************************************************
TYPE     CNAME    FLAG(TYPE%USED,0) SET FLAG IF TYPE PROC IS USED
PRINT    CNAME    FLAG(PRINT%USED,1) SET PRINT%USED FLAG IF THIS
         PROC                        PROC IS USED
         DO       TCOR(AF,S:C)      IF CHARACTER STRING
OLDLOC   SET      %                 SAVE LOCATION COUNTER
         ORG,1    MSGLOC
I        SET      %                 I = ADDRESS FOR M:PRINT
         LIST     0                 TURN OFF LISTING
CR       SET      ''                ASSUME NOT TYPE PROC
         DO1      NAME=0            IF TYPE PROC
CR       SET      ' '               RESERVE 1 CHAR FOR CR
         TEXTC    AF,CR
         DO       NAME=0            IF TYPE PROC
K        SET      S:NUMC(AF)        K = LENGTH OF TEXT STRING
         ORG,1    I+K+1             ORG AT 1ST CHAR AFTER MESSAGE
         GEN,8    X'0D'             GENERATE CARRIER RETURN
         FIN
         BOUND    4                 SET WORD RESOLUTION
         ORG      %
MSGLOC   SET      %                 UPDATE MSGLOC
         ORG      OLDLOC            UPDATE LOCATION COUNTER
         LIST     1                 TURN ON LISTING
         ELSE                       IF NOT CHARACTER STRING
I        SET      S:UFV(WA(AF))     I = ADDRESS FOR M:PRINT
         FIN
         DO       NAME
LF       BAL,LINK @PRINT            LINK TO PRINT ROUTINE
         ELSE
LF       BAL,LINK @TYPE
         FIN
         DATA     WA(I)             ADDRESS OF LINE TO PRINT OR TYPE
         PEND
         SPACE
         SPACE
         DO       TYPE%USED         INCLUDE CODE IF TYPE PROC USED
************************************************************************
*   TYPE ROUTINE FOR TYPE PROC                                         *
*   ENTRY : LINK = WA(WORD THAT CONTAINS WORD ADDRESS OF LINE)         *
*   RETURN TO LINK+1                                                   *
************************************************************************
         LOCAL    RET
@TYPE    STW,LINK RET               SAVE RETURN ADDRESS
         LW,LINK  *LINK             LINK = WA(LINE TO TYPE)
         M:TYPE   (MESS,*LINK)
         MTW,1    RET               INCREMENT RETURN ADDRESS
         B        *RET
RET      RES      1
         LOCAL
         FIN
         SPACE
         DO       PRINT%USED        INCLUDE CODE IF PRINT PROC USED
************************************************************************
*   PRINT ROUTINE FOR PRINT PROC                                       *
*   ENTRY : LINK = WA(WORD THAT CONTAINS WORD ADDRESS OF LINE)         *
*   RETURN TO LINK+1.                                                  *
************************************************************************
         LOCAL    TEMP
@PRINT   STW,LINK TEMP              SAVE RETURN ADDRESS
         LW,LINK  *LINK             LINK = WA(LINE TO PRINT)
         M:PRINT  (MESS,*LINK)      PRINT MESSAGE
         MTW,1    TEMP              INCREMENT RETURN ADDRESS
         B        *TEMP             RETURN TO LINK+1
TEMP     RES      1
         LOCAL
         FIN
         SPACE    2
         TITLE    'CALL MONITOR FOR DEBUG'
         DO       DBGKEY=1          INCLUDE DEBUG MONITOR IF DEBUG
************************************************************************
*   CALLMON. SEE IF SUBROUTINE BEING CALLED IS TO BE TRACED.           *
*   IF SO, FORMAT LINE TO PRINT:                                       *
*                                                                      *
*        CCCC AAAAA CALL  BBBBB  FROM NAME  CALL  TO NAME              *
*                                                                      *
*   CCCC = CONDITION CODE SETTINGS                                     *
*   AAAAA = FROM ADDRESS                                               *
*   BBBBB = TO ADDRESS                                                 *
*                                                                      *
*   ENTRY : LINK = WORD ADDRESS OF PARAMETER.                          *
*                  BIT  8 OF PARAMETER = TRACE BIT = 1 IF TRACE.       *
*                  ADDRESS OF PARAMETER POINTS TO TEXTC NAME OF        *
*                  SUBROUTINE WHICH PRECEDES SUBROUTINE ENTRY POINT.   *
************************************************************************
CALLMON  STCF     CC                SAVE CONDITION CODES
         PSW,LINK SUBSTACK          PUSH LINK REGISTER INTO STACK
         LCI      0
         STM,R0   SAVE%REGS         SAVE REGISTERS 0 - 15
         LW,R1    LINK              R1 = WA(PARAMETER)
         LW,R2    *R1               R2 = PARAMETER
         LW,R3    R2                R3 = PARAMETER
         AND,R2   MASKS+17          R2 = WA(TEXTC NAME) THAT PRECEDES
*                                   SUBROUTINE.
         LB,R4    *R2               R4 = LENGTH OF NAME THAT PRECEDES
*                                   SUBROUTINE IN BYTES.
         LW,R5    R4                R5 = LENGTH OF NAME THAT PRECEDES
         AI,R5    4                 SUBROUTINE
         SLS,R5   -2                IN WORDS.
         AW,R5    R2                R5 = WA(SUBROUTINE ENTRY POINT)
         CW,R3    BT31TO0+32-8      TEST TO SEE IF SUBROUTINE TO TRACE
         BAZ      ENTER             BRANCH IF NO
         BAL,R8   FORMAT%CC         FORMAT CONDITION CODES
         LW,R9    R1                R9 = WA(PARAMETER)
         AI,R9    -1                R9 = WA(CALL)
         LI,R6    BA(FROM%ADDRESS)
         BAL,R8   FORMAT%ADDRESS    FORMAT FROM ADDRESS
         LI,R9    CAL               R9 = WA(TEXTC 'CALL   ')
         BAL,R8   MOVE              MOVE 'CALL   '
         LW,R9    R5                R9 = ADDRESS OF ENTRY POINT
         BAL,R8   FORMAT%ADDRESS    FORMAT TO ADDRESS
         LW,R10   SUBSTACK+1        R10 = WORD COUNT OF NUMBER OF
         AND,R10  MASKS+15          ENTRIES IN STACK.
         CI,R10   1
         BG       FROM%SUB
*   FALL THRU IF ONLY 1 ENTRY IN STACK. CALL IS FROM MAIN PROGRAM.
         LI,R9    MAIN%PROGRAM
         BAL,R8   MOVE              MOVE  'FROM MAIN PROGRAM'
         B        TOSUB
FROM%SUB LI,R9    FROM
         BAL,R8   MOVE              MOVE ' FROM '
         LW,R9    SUBSTACK          R9 = WA(PREVIOUS ENTRY IN STACK)
         AI,R9    -1
         LW,R9    *R9               R9 = PREVIOUS STACK ENTRY =
*                                   WA(PREVIOUS PARAMETER)
         LW,R9    *R9               R9 = PREVIOUS PARAMETER
         AND,R9   MASKS+17          R9 = WA(TEXTC NAME) OF PREVIOUS
*                                   SUBROUTINE
         BAL,R8   MOVE              MOVE NAME OF PREVIOUS SUBROUTINE
TOSUB    LI,R9    CALLTO
         BAL,R8   MOVE              MOVE 'CALL  '
         LW,R9    R2                MOVE NAME OF SUBROUTINE
*                                   BEING CALLED.
PRINT%GO ;
         BAL,R8   MOVE
         BAL,R8   PRINT%LINE
ENTER    STW,R5   SAVE%REGS+LINK    REPLACE LINK REGISTER IN SAVE AREA
*                                   WITH SUBROUTINE ENTRY ADDRESS.
         LCI      0
         LM,R0    SAVE%REGS         RESTORE REGISTERS 0 - 15
         LCF      CC                RESTORE CONDITION CODES
         B        *LINK             ENTER SUBROUTINE
         TITLE    'RETURN MONITOR FOR DEBUG'
************************************************************************
*   RETMON. SEE IF SUBROUTINE RETURNING FROM IS TO BE TRACED.          *
*   IF SO, FORMAT LINE TO PRINT:                                       *
*                                                                      *
*        CCCC AAAAA RETURN BBBB  FROM NAME  TO  NAME                   *
*                                                                      *
*   CCCC = CONDITION CODE SETTINGS                                     *
*   AAAAA = ADDRESS RETURNING FROM                                     *
*   BBBBB = ADDRESS TO RETURN TO                                       *
*                                                                      *
*   ENTRY : LINK = ADDRESS OF RETURN + 1.                              *
*           TOP OF SUBSTACK POINTS TO PARAM FOLLOWING CALL.            *
************************************************************************
RETMON   STCF     CC                SAVE CONDITION CODES
         LCI      0
         STM,R0   SAVE%REGS         SAVE REGISTERS 0-15
         PLW,R1   SUBSTACK          R1 = WA(PARAMETER) OF
*                                   CALLING ROUTINE.
         LW,R2    *R1               R2 = PARAMETER
         LW,R3    R2                R3 = PARAMETER
         AND,R2   MASKS+17          R2 = WA(TEXTC NAME) THAT
*                                   PRECEDES SUBROUTINE
         LW,R5    R1
         AI,R5    1                 R5 = ADDRESS TO RETURN TO
         LW,R1    LINK              R1 = ADDRESS RETURNING FROM+1
         CW,R3    BT31TO0+32-8      TEST TO SEE IF SUBROUTINE TO TRACE
         BAZ      ENTER             BRANCH IF NO
         BAL,R8   FORMAT%CC         FORMAT CONDITION CODES
         LW,R9    R1                R9 = ADDRESS OF RETURN PROC
         AI,R9    -1
         LI,R6    BA(FROM%ADDRESS)
         BAL,R8   FORMAT%ADDRESS    FORMAT FROM ADDRESS
         LI,R9    RETRN
         BAL,R8   MOVE              MOVE 'RETURN'
         LW,R9    R5                SET ADDRESS TO RETURN TO
         BAL,R8   FORMAT%ADDRESS    FORMAT TO ADDRESS
         LI,R9    FROM
         BAL,R8   MOVE              MOVE ' FROM '
         LW,R9    R2                R9 = WA(TEXTC NAME) OF SUBROUTINE
*                                   BEING RETURNED FROM.
         BAL,R8   MOVE              MOVE SUBROUTINE NAME
         LI,R9    TO
         BAL,R8   MOVE              MOVE '  TO  '
         LW,R10   SUBSTACK+1        R10 = WORD COUNT OF NUMBER OF
         AND,R10  MASKS+15          ENTRIES LEFT IN STACK.
         BNEZ     FROM%SB
*   FALL THRU IF STACK IS EMPTY. RETURN IS TO MAIN PROGRAM.
         LI,R9    TOMAIN
*                                   MOVE 'TO MAIN PROGRAM '
         B        PRINT%GO          PRINT LINE AND GO
FROM%SB  LW,R9    *SUBSTACK         R9 = WA(PARAM) OF CALLING ROUTINE
         LW,R9    *R9               R9 = PARAM OF CALLING ROUTINE
         AND,R9   MASKS+17          R9 = WA(TEXTC) OF CALLING ROUTINE
         B        PRINT%GO          MOVE NAME OF CALLING ROUTINE
         SPACE
*   ROUTINE TO FORMAT CONDITION CODES TO PRINT.
*   ENTRY : CC = CONDITION CODES IN HIGH ORDER BYTE, BITS 0-3
         SPACE
FORMAT%CC ;
         LW,R10   CC                R10 = WORD WITH CONDITION CODES
         LI,R7    4                 LOOP 4 TIMES
         LI,R6    BA(CODES)         R6 = BA(CODE IN OUTPUT BUFFER)
NEXT%CODE ;
         LI,R11   C'0'              ASSUME CODE = 0
         CW,R10   BT31TO0+28,R7
         BAZ      %+2               BRANCH IF CODE 0
         LI,R11   C'1'              CODE IS 1
         STB,R11  0,R6              PUT CODE '0' OR '1' IN BUFFER
         AI,R6    1                 INCREMENT BUFFER ADDRESS
         BDR,R7   NEXT%CODE         DECREMENT R7
         B        *R8               RETURN WHEN R7 = 0
         SPACE
*   ROUTINE TO CONVERT HEX ADDRESS TO EBCDIC AND STORE IN PRINT AREA.
*   ENTRY : R6 = BA(1ST CHARACTER OF OUTPUT AREA.
*           R9 = HEX ADDRESS
*   RETURN: R6 = BA(CHARACTER FOLLOWING ADDRESS IN OUTPUT)
         SPACE
FORMAT%ADDRESS ;
         AND,R9   MASKS+17
         AI,R6    4                 R6 = BA(LOW ORDER OUTPUT DIGIT)
         LI,R11   5                 LOOP 5 TIMES
NEXT%HEX%DIGIT ;
         LW,R12   R9                R12 = 4 BITS OF
         AND,R12  MASKS+4           NEXT HEX DIGIT
         AI,R12   X'F0'             ASSUME 0-9
         CI,R12   C'9'
         BLE      %+2               BRANCH IF 0-9
         AI,R12   X'C1'-X'F0'-10    A-F
         STB,R12  0,R6              STORE IN OUTPUT
         SLS,R9   -4                NEXT 4 BITS
         AI,R6    -1                NEXT OUTPUT CHARACTER
         BDR,R11  NEXT%HEX%DIGIT
         AI,R6    6                 POINT TO CHAR FOLLOWING LOW ORDER
*                                   DIGIT.
         LI,R12   X'40'
         STB,R12  0,R6              STORE SPACE AFTER ADDRESS
         AI,R6    1                 INCREMENT POINTER TO OUTPUT
         B        *R8               RETURN
         SPACE
*   MOVE CHARACTERS TO OUTPUT AREA
*   ENTRY : R9 = WA(TEXTC STRING)
*           R6 = BA(NEXT OUTPUT CHARACTER)
*   RETURN: R6 = BA(NEXT OUTPUT CHARACTER)
         SPACE
MOVE     LB,R11   *R9               R11 = BYTE COUNT
         LI,R7    1                 R7 = INDEX TO TEXTC STRING
MOVE%NEXT ;
         LB,R12   *R9,R7            R12 = NEXT BYTE
         STB,R12  0,R6              STORE IN OUTPUT
         LI,R12   BA(LINE)+132
         CW,R6    R12               DO NOT PERMIT LINE OVERFLOW
         BGE      *R8               RETURN IF 132 CHARACTERS
         AI,R6    1                 NEXT OUTPUT BYTE
         AI,R7    1                 NEXT TEXTC BYTE
         BDR,R11  MOVE%NEXT
         B        *R8               RETURN
         SPACE
*    PRINT CONTENTS OF BUFFER
*    ENTRY : R6 = BA(LAST CHAR+1)
         SPACE
PRINT%LINE ;
         AI,R6    -BA(CODES)        R6 = CHARACTER COUNT
         STB,R6   LINE              STORE CHARACTER COUNT
         M:PRINT  (MESS,WA(LINE))
         B        *R8               RETURN
         SPACE    2
CC       RES      1                 CONDITION CODE SAVE AREA
SAVE%REGS ;
         RES      16                REGISTER SAVE AREA
         BOUND    8                 SET DOUBLEWORD BOUNDARY
SUBSTACK DATA     STACK             STACK POINTER
STACK    GEN,16,16 10,0             10-LEVEL MAXIMUM SUBROUTINE NESTING
         RES      10
         ORG,1    %                 SET BYTE RESOLUTION
LINE     GEN,8    0                 COUNT
CODES    GEN,40   'CCCC '
FROM%ADDRESS ;
         GEN,48   'AAAAA '
         ORG      %                 SET WORD RESOLUTION
         ORG      WA(LINE)+34
MAIN%PROGRAM      TEXTC   ' FROM MAIN PROGRAM'
TOMAIN   TEXTC    'MAIN PROGRAM'
FROM     TEXTC    ' FROM '
CALLTO   TEXTC    ' CALL '
RETRN    TEXTC    ' RETURN '
CAL      TEXTC    ' CALL   '
TO       TEXTC    ' RETURN TO '
         FIN                        END OF DEBUG MONITOR IF DEBUGGING
         SPACE
         CLOSE    FLAG,FORMAT%CC,CR
         CLOSE    NO%TRACELIST,NO%TRACE%PRESENT
         CLOSE    I,J,K,T
         CLOSE    TRACE%PRESENT,TRACELIST,PASS,PASS2,LINK
         CLOSE    TRACEBIT,SUBADDR,SUBNAME,SUBLISTNUM,EXPLAN,TEMPLOC
         CLOSE    EXPL,SNAME,SADDR,OLDLOC,TEMP,SUB#,MSGLOC,@PRINT
         CLOSE    CALLMON,FROM%SUB,TOSUB,LAST%PAREN,PRINT%GO,ENTER
         CLOSE    RETMON,FROM%SB,NEXT%CODE,FORMAT%ADDRESS,NEXT%HEX%DIGIT
         CLOSE    MOVE,MOVE%NEXT,PRINT%LINE,CC,SAVEREGS,SUBSTACK
         CLOSE    LINE,CODES,FROM%ADDRESS,MAIN%PROGRAM,TOMAIN,FROM
         CLOSE    RPAREN,CALLTO,RETRN,CAL,TO,STACK,PRINT%USED,TYPE%USED
         CLOSE    @TYPE,#SUBROUTINES
         TITLE    'QREMAKE - CODES AND RECORD DESCRIPTIONS'
         SPACE    2
************************************************************************
*                                                                      *
*   FORMAT OF DYNAMIC BLOCKS ALLOCATED FOR TRANSACTIONS                *
*                                                                      *
************************************************************************
         ADMODE   (IND)
TRANID            WORD  0           TRANID
NEXT%BLOCK        WORD  1           WA(NEXT SEQUENTIAL TRANID BLOCK) OR
*                                   ZERO IF LAST BLOCK ON CHAIN.
LAST%BLOCK        WORD  2           WA(LAST SEQUENTIAL TRANID BLOCK) OR
*                                   ZERO IF FIRST BLOCK ON CHAIN
SPAWNED%TRANS     WORD  3           WA(TRANID BLOCK) OF SPAWNED TRANS
*                                   OR ZERO IF NO SPAWNED TRANSACTIONS.
ORIG%TRANS        WORD  4           IF THIS IS A SPAWNED TRANSACTION,
*                                   WA(TRANID BLOCK) OF ORIGINATING
*                                   TRANSACTION.
*   NOTE THAT A SPAWNED TRANSACTION WILL BE ON TWO LISTS:
*        1. IT WILL BE IN THE LIST POINTED TO BY TRANCHAIN THAT USES
*           NEXT%BLOCK/LAST%BLOCK POINTERS.
*        2. IT WILL BE CHAINED TO THE ORIGINATING TRANSACTION BY THE
*           SPAWNED%TRANS/ORIG%TRANS POINTERS.
*   A REPORT TRANSACTION IS ONLY CHAINED TO THE ORIGINATING TRANSACTION.
REPORT%BLOCK      FIELD 5,(31,17)   WA(NEXT REPORT BLOCK)
*   A TRANSACTION COULD HAVE MORE THAN ONE REPORT BLOCK CHAINED TO IT.
*   REPORT BLOCKS ARE NOT LINKED BACK TO THE ORIGINATING TRANSACTION.
NAME%LENGTH       BYTE  5*4         LENGTH OF NAME
BEGIN             BIT   5,8         BIT = 1 IF BEGIN ENCOUNTERED
END               BIT   5,9         BIT = 1 IF END ENCOUNTERED.
NAME              WORD  6           REPORT OR TRANSACTION NAME
FLAG%BUFF   BYTE    14*4            SAVE JOURNAL AND QUEUE FLAGS HERE
BLOCK%SIZE   EQU  15                NUMBER OF WORDS IN BLOCK
MAX%JOURNAL%RECORD%SIZE  EQU  519
512%JOURNAL%RECORD%SIZE   EQU   512
         SPACE    2
*   THE FOLLOWING FLAG DEFINITION IS ONLY TEMPORARY UNTIL
*   IT IS DEFINED IN THE JOURNAL RECORD
JQUEUEFLAG        BIT  0,0
JDELIVERYFLAG   BIT   0,6
         SPACE
         SPACE
*   CODES FOR JOURNAL RECORD TYPES   BRANCH TABLE NUMBER
         SPACE
BEGIN%TRANSACTION%CODE  EQU   X'10'     1
BEFORE%IMAGE%CODE       EQU   X'05'
AFTER%IMAGE%CODE        EQU   X'06'
OUTPUT%REPORT%CODE      EQU   X'15'     2
END%TRANSACTION%CODE    EQU   X'11'     5
REPORT%BEGIN%CODE       EQU   X'16'     3
REPORT%END%CODE         EQU   X'17'     4
QDUMP%CODE              EQU   X'1A'     6
EDMS%BEGIN%CODE         EQU   X'03'
EDMS%END%CODE           EQU   X'04'
USER%RECORD%CODE        EQU   X'20'
CRASH%RECORD%CODE       EQU   X'12'     7
TPG%END%CODE            EQU   X'13'     7
         SPACE
*   THE BRANCH TABLE VECTOR CONTAINS ONE ENTRY FOR EACH JOURNAL
*   RECORD CODE. A ZERO ENTRY MEANS IGNORE THE RECORD.
*   A NON ZERO ENTRY IS THE BRANCH TABLE NUMBER.
         ORG,1    %                 SET BYTE RESOLUTION
BRANCH%TABLE%VECTOR ;
         DATA     0,0,0,0,0,0,0,0,0
         ORG,1    BRANCH%TABLE%VECTOR+BEGIN%TRANSACTION%CODE
         DATA,1   1
         ORG,1    BRANCH%TABLE%VECTOR+OUTPUT%REPORT%CODE
         DATA,1   2
         ORG,1    BRANCH%TABLE%VECTOR+REPORT%BEGIN%CODE
         DATA,1   3
         ORG,1    BRANCH%TABLE%VECTOR+REPORT%END%CODE
         DATA,1   4
         ORG,1    BRANCH%TABLE%VECTOR+END%TRANSACTION%CODE
         DATA,1   5
         ORG,1    BRANCH%TABLE%VECTOR+QDUMP%CODE
         DATA,1   6
         ORG,1    BRANCH%TABLE%VECTOR+CRASH%RECORD%CODE
         DATA,1   7
         ORG,1    BRANCH%TABLE%VECTOR+TPG%END%CODE
         DATA,1   7
         ORG      WA(BRANCH%TABLE%VECTOR)+9
CODE%LIMIT        EQU  9*4-1        MAXIMUM VALUE OF JOURNAL RECORD
*                                   CODE.
*
*        DATA AREA FOR TEMP STACK AND EXIT%CONTROL FLAG
*
         BOUND    8
R:TSTACK   EQU   %
         DATA     WA(STKSTRT)
         GEN,16,16  64,0
STKSTRT  RES      10
*
BEEN%HERE%BEFORE   DATA   0
         TITLE    'QREMAKE - MAINLINE CODE'
         SPACE
************************************************************************
*   MAINLINE CODE:                                                     *
*     - READ JOURNAL RECORD.                                           *
*     - PROCESS RECORD DEPENDING ON RECORD TYPE.                       *
*     - WHEN CRASH RECORD IS ENCOUNTERED ON THE JOURNAL FILE, THE      *
*       QUEUE HAS BEEN RESTORED TO ITS STATE AT THE TIME OF THE CRASH. *
************************************************************************
QREMAKE  EQU      %
         PRINT    'QREMAKE VERSION C00E'
         CALL     PROGRAM%CONTROL
START    CALL     CURRENT%SN
         CALL     OPEN%JOURNAL
         CALL     OPENQ
         CALL     SEARCH%FOR%QDUMP
RESTORE%QUEUE ;
         CALL     RESTORE%QDUMP
         M:QUEUE  F:QUEUE,UNLOCK,(OLD),(BACKUP),(RECOVER)
         BCR,12   QUEUE%UNLOCKED
         CALL     FORMAT%ERR%CODE
         TYPE     'UNABLE TO UNLOCK QUEUE'
         TYPE     CODE%BUFF
         B        ABORT15
QUEUE%UNLOCKED   EQU   %
         STW,R8   CURRENT:TID
         B        FIRST%TIME%THROUGH
SCAN%LOOP ;
         CALL     READ%JOURNAL
         BCS,1    END%FILE          BRANCH IF END OF FILE
         BCS,2    READ%ERROR        BRANCH IF READ ERROR
         BCS,4    CHECKSUM%ERROR    BRANCH IF CHECKSUM ERROR
FIRST%TIME%THROUGH     ;
         GET,R2   JTYPE,R7          R2 = JOURNAL RECORD%TYPE
         CI,R2    CODE%LIMIT        IF CODE IS OUT OF TABLE LIMITS,
         BG       SCAN%LOOP         SKIP RECORD
         LB,R2    BRANCH%TABLE%VECTOR,R2
         B        %+1,R2
         B        SCAN%LOOP         O SKIP RECORD
         B        BEGIN%TRANS       1
         B        OUTPUT%REP        2
         B        BEGIN%REP         3
         B        REP%END           4
         B        END%TRANS         5
         B        QUEUEDUMP         6
         B        CRASH             7   CRASH RECORD OR TPG END
         SPACE
BEGIN%TRANS ;
         CALL     BEGIN%TRANSACTION
         B        SCAN%LOOP
OUTPUT%REP ;
         CALL     OUTPUT%REPORT
         B        SCAN%LOOP
BEGIN%REP ;
         CALL     REPORT%BEGIN
         B        SCAN%LOOP
REP%END ;
         CALL     REPORT%END
         B        SCAN%LOOP
END%TRANS ;
         CALL     END%TRANSACTION
         B        SCAN%LOOP
QUEUEDUMP ;
         LW,R1    DONT%READ%QDUMP   IF CRASH OCCURRED DURING QDUMP, DO
         BNEZ     CRASH             NOT RESTORE QUEUE.
         CALL     FREE%CORE         FREE ALL DYNAMIC BLOCKS
         M:QUEUE  F:QUEUE,LOCK
         BCR,12   LOCK%OK
         CALL     FORMAT%ERR%CODE
         TYPE     'UNABLE TO LOCK QUEUE'
         TYPE     CODE%BUFF
         B        ABORT15
LOCK%OK   EQU     %
         B        RESTORE%QUEUE
CRASH    CALL     END%PROCESSING
         LW,R6    CURRENT:TID
         M:SYS
         STW,R6   SAVE:Q:TID
         LPSD,0   SLAVEPSD
LOCK%QUEUE   EQU   %
         M:QUEUE  F:QUEUE,LOCK
         TYPE     'QUEUE RECONSTRUCTED - RUN USER-PGM OR LISTQIP'
         M:EXIT                     OH RAVIOLIES
         BOUND    8
SLAVEPSD   EQU   %
         GEN,8,1,1,5,17   0,1,1,0,LOCK%QUEUE
         DATA     0
         SPACE    2
END%FILE TYPE     'UNEXPECTED EOF ON JOURNAL FILE'
         B        ABORT11
         SPACE
READ%ERROR ;
         TYPE     'READ ERROR ON JOURNAL FILE DURING SCAN LOOP'
         TYPE     CODE%BUFF
         CALL     ASK%OPERATOR
         B        SCAN%LOOP
         SPACE
CHECKSUM%ERROR ;
         TYPE     'CHECKSUM ERROR ON JOURNAL FILE DURING SCAN LOOP'
         CALL     ASK%OPERATOR
         B        SCAN%LOOP
         TITLE    'QREMAKE - ASK OPERATOR'
************************************************************************
*   ASK%OPERATOR: TYPE MESSAGE 'TYPE A TO ABORT OR C TO SKIP RECORD    *
*   AND CONTINUE'                                                      *
*   RETURN: OPERATOR HAS REPLIED CONTINUE.                             *
************************************************************************
         LOCAL    KEYIN,WAIT,MSG1,REPLY1,ECB1
ASK%OPERATOR,'ASK%OPERATOR' ;
         ENTRY    'RETURN IF OPERATOR SAYS IGNORE ERROR AND CONTINUE'
KEYIN    M:KEYIN  (MESS,MSG1),(REPLY,REPLY1),(SIZE,12),(ECB,ECB1)
WAIT     M:WAIT   1                 WAIT 1.2 SECONDS
         LW,R5    ECB1              BIT 0 = 1 IF STILL WAITING
         BLZ      WAIT              CONTINUE WAIT IF ECB NOT POSTED
         LH,R5    REPLY1            R5 = REPLY WITH COUNT IN 1ST BYTE
         CI,R5    X'02C1'           SEE IF 'A' TYPED
         BE       ABORT3            ABORT IF YES
         CI,R5    X'02C3'           SEE IF 'C' TYPED
         BNE      KEYIN             IF NOT, REPEAT MESSAGE
         RETURN                     CONTINUE AND IGNORE ERROR
         SPACE
MSG1     TEXTC    'TYPE ''A'' TO ABORT OR ''C'' TO SKIP RECORD',;
                  ' AND CONTINUE '
REPLY1   RES      3                 REPLY KEYED BY OPERATOR
ECB1     DATA     0                 ECB POSTED WHEN REPLY RECEIVED
         LOCAL
         TITLE    'QREMAKE - BEGIN%TRANSACTION'
************************************************************************
*   BEGIN%TRANSACTION: PROCESS BEGIN TRANSACTION RECORD.               *
*      - BUILD DYNAMIC TRAN%BLOCK AND CHAIN TO TRANCHAIN.              *
*      - QUEUE TRANSACTION WITH M:QUEUE                                *
*      - IF THIS IS A SPAWNED TRANSACTION, CHAIN TRAN%BLOCK TO         *
*        TRAN%BLOCK OF ORIGINATING TRANSACTION IF ORIGINATING          *
*        TRANSACTION HAS NOT ENDED.                                    *
*   ENTRY : R7 = WA(JOURNAL RECORD)                                    *
*   RETURN: R7 UNCHANGED, R5 AND R6 DESTROYED                          *
************************************************************************
         LOCAL    SCAN,SAVE%BLOCK%ADDR,DUPLICATE%TRAN,RETURN,;
                  NO%ORIG%TRAN
BEGIN%TRANSACTION,'BEGIN%TRANSACTION' ;
         ENTRY
         CALL     TID%CHECK
         TBIT,R3  JQUEUEFLAG,R7     IF RECORD IS NOT TO BE QUEUED,
         BEZ      RETURN            SKIP IT
         GET,R5   JTRANID,R7        R5 = TRANID OF BEGIN TRANSACTION
         CALL     SEARCH%TRANCHAIN
         BEZ      DUPLICATE%TRAN    ERROR IF DUPLICATE BEGIN TRANSACTION
         CALL     GET%BLOCK
         SBIT,R3  BEGIN,R5          SET BEGIN ENCOUNTERED.
         CALL     CHAIN%TRAN
         CALL     QUEUE
         STW,R5   SAVE%BLOCK%ADDR   SAVE ADDRESS OF NEW TRAN BLOCK
         GET,R5   JORGTRAN,R7       R5 = ID OF ORIGINATING TRANSACTION
         BEZ      RETURN            BRANCH IF NOT SPAWNED TRANSACTION
*   SEARCH FOR TRAN%BLOCK OF ORIGINATING TRANSACTION
         CALL     SEARCH%TRANCHAIN
         BNE      NO%ORIG%TRAN      ERROR IF NOT FOUND
         LW,R2    R6                R2 = TRAN BLOCK ADDRESS
         LW,R4    SAVE%BLOCK%ADDR   R4 = WA(SPAWNED TRANSACTION BLOCK)
         SPACE
*   R4 = WA(TRAN%BLOCK) OF SPAWNED TRANSACTION
*   R2 = WA(TRAN%BLOCK) OF ORIGINATING TRANSACTION
*   CHAIN SPAWNED TRANSACTION TO ORIGINATING TRANSACTION
*                                   SET SPAWNED TRANSACTION TO POINT
         ST,R2,R3 ORIG%TRANS,R4     TO ORIGINATING TRANSACTION.
*   SCAN TO END OF CHAIN OF SPAWNED TRANSACTIONS CHAINED TO
*   ORIGINATING TRANSACTION.
SCAN     LW,R1    R2
         GET,R2   SPAWNED%TRANS,R1  R2 = WA(NEXT SPAWNED TRANSACTION)
         BNEZ     SCAN              BRANCH IF NOT END OF CHAIN
*   R1 = WA(TRAN%BLOCK) OF ORIGINATING TRANSACTION OR OF LAST SPAWNED
         ST,R4,R5 SPAWNED%TRANS,R1  STORE WA(NEW SPAWNED TRANSACTION)
         B        RETURN
         SPACE
*   NO RECORD OF ORIGINATING TRANSACTION.
*   THIS IS AN ERROR. PRINT MESSAGE AND CONTINUE.
NO%ORIG%TRAN ;
         PRINT ;
  'SPAWNED TRANSACTION RECEIVED BUT BEGIN ORIGINATING TRANSACTION',;
  ' NOT FOUND'
         CALL     PRINT%JOURNAL%RECORD
         B        RETURN
         SPACE
*   DUPLICATE BEGIN TRANSACTION RECORD.
*   THIS IS AN ERROR. PRINT MESSAGE AND CONTINUE.
DUPLICATE%TRAN ;
         PRINT    'DUPLICATE BEGIN TRANSACTION - IGNORED'
         CALL     PRINT%JOURNAL%RECORD
RETURN   RETURN
         SPACE
SAVE%BLOCK%ADDR   DATA  0
         LOCAL
         TITLE    'QREMAKE - CHAIN%TRAN'
************************************************************************
*   CHAIN%TRAN: CHAIN DYNAMIC BLOCK INTO TRANCHAIN.                    *
*   ENTRY : R5 = WA(BLOCK TO BE CHAINED)                               *
*           R6 = WA(PREVIOUS BLOCK IN CHAIN) OR 0 IF NONE              *
*   RETURN: NEW BLOCK IS INSERTED IN CHAIN                             *
*           R5,R6,R7 ARE PRESERVED                                     *
************************************************************************
         LOCAL    NOT%ONLY,NOT%FIRST,INSERT,RETURN
CHAIN%TRAN,'CHAIN%TRAN' ;
         ENTRY    'CHAIN TRAN BLOCK POINTED TO BY R5',;
                  'R6 = WA(PREVIOUS BLOCK) OR 0 IF NONE'
         LW,R2    R5                R2 = WA(BLOCK TO CHAIN)
         LW,R1    R7                SAVE R7
         AI,R6    0                 IF R6 = 0, THERE IS NO PREVIOUS
         BNEZ     NOT%FIRST         BLOCK, AND THIS WILL BE THE FIRST.
         LW,R4    TRANCHAIN         R4 = WA(FIRST BLOCK ON CHAIN)
         BNEZ     NOT%ONLY
*   THIS WILL BE THE ONLY BLOCK ON THE CHAIN
         STW,R2   TRANCHAIN         TRANCHAIN POINTS TO CHAINED BLOCK
         ST,R4,R3 NEXT%BLOCK,R2     ZERO NEXT POINTER OF CHAINED BLOCK
         ST,R4,R3 LAST%BLOCK,R2     ZERO LAST POINTER OF CHAINED BLOCK
         B        RETURN
*   THIS IS THE FIRST BLOCK ON THE CHAIN
NOT%ONLY STW,R2   TRANCHAIN         TRANCHAIN POINTS TO NEW BLOCK
         ST,R6,R3 LAST%BLOCK,R2     ZERO LAST POINTER OF CHAINED BLOCK
         ST,R4,R3 NEXT%BLOCK,R2     SET NEXT POINTER OF CHAINED BLOCK
         ST,R2,R3 LAST%BLOCK,R4     SET LAST POINTER OF NEXT BLOCK
         B        RETURN
NOT%FIRST ;
         GET,R4   NEXT%BLOCK,R6     R4 = WA(NEXT BLOCK ON CHAIN)
         BNEZ     INSERT
*   THIS IS THE LAST BLOCK ON THE CHAIN
         ST,R2,R3 NEXT%BLOCK,R6     SET NEXT POINTER IN LAST BLOCK
         ST,R6,R3 LAST%BLOCK,R2     SET LAST POINTER IN CHAINED BLOCK
         ST,R4,R3 NEXT%BLOCK,R2     ZERO NEXT POINTER IN CHAINED BLOCK
         B        RETURN
*   INSERT BLOCK BETWEEN 2 OTHER BLOCKS
INSERT   ST,R2,R3 NEXT%BLOCK,R6     SET NEXT POINTER IN LAST BLOCK
         ST,R2,R3 LAST%BLOCK,R4     SET LAST POINTER IN NEXT BLOCK
         ST,R4,R3 NEXT%BLOCK,R2     SET NEXT POINTER IN CHAINED BLOCK
         ST,R6,R3 LAST%BLOCK,R2     SET LAST POINTER IN CHAINED BLOCK
RETURN   LW,R7    R1                RESTORE R7
         LW,R5    R2                RESTORE R5
         RETURN
         LOCAL
         TITLE    'QREMAKE - CHECK%CHECKSUM'
************************************************************************
*   CHECK%CHECKSUM: CHECK RECORD CHECKSUM.                             *
*   ENTRY : R7 = WA(JOURNAL RECORD)                                    *
*                HW1 OF WORD 0 OF RECORD CONTAINS RECORD SIZE IN BYTES *
*                LAST WORD OF RECORD CONTAINS CHECKSUM.                *
*           M:TRAP(PERMIT,FX) MUST HAVE BEEN EXECUTED TO PERMIT        *
*           FIXED-POINT OVERFLOW.                                      *
*   RETURN: CC = 0000 IF CHECKSUM OK                                   *
*              = 0100 IF CHECKSUM ERROR                                *
************************************************************************
CHECK%CHECKSUM,'CHECK%CHECKSUM' ;
         ENTRY    'R7 = WA(JOURNAL RECORD)',;
                  'CC = 0100 IF ERROR; OTHERWISE CC = 0000'
         LCI      3
         PSM,R2   R:TSTACK
         LI,R2    0
         LI,R4    4
         GET,R3   JLEN,R7
         DW,R2    R4
         CI,R2    0
         BE       CHECK%1
         AI,R3    1                 ONE FOR REMAINDER BYTES
CHECK%1  EQU      %
**                JLEN IS ASSUMED TO INCLUDE CHECKSUM IN LENGTH COUNT
         AI,R3    -2                -1 FOR 0TH WORD, -1 FOR CHECKSUM
         LI,R2    1
         LW,R4    *R7
CHECK%2  EQU      %
         AW,R4    *R7,R2            ADD NEXT WORD TO ACCUMULATOR
         BNC      CHECK%3
         AI,R4    1                 ADD ONE ON OVERFLOW
CHECK%3  EQU      %
         AI,R2    1
         BDR,R3   CHECK%2
         LW,R3    *R7,R2            GET ACTUAL CHECKSUM
         CW,R3    R4                COMPARE W/ CALCULATED VALUE
         BNE      CHECK%5
         LCI      3
         PLM,R2   R:TSTACK
         LCI      0
CHECK%4  EQU      %
         RETURN
CHECK%5  EQU      %
         LCI      3
         PLM,R2   R:TSTACK
         LCI      4
         RETURN
         SPACE
         TITLE    'QREMAKE - CLEANUP%TRANS'
************************************************************************
*   CLEANUP%TRANS: A TRANSACTION HAS ENDED OR A REPORT THAT THE        *
*   TRANSACTION WAS WAITING FOR HAS ENDED. PERFORM CLEANUP             *
*   OPERATIONS FOR THIS TRANSACTION:                                   *
*      - DELETE ANY ENDED REPORT BLOCKS.                               *
*      - IF ENDED SPAWNED  TRANSACTIONS WERE WAITING FOR THIS          *
*        TRANSACTION TO END, DELETE THEM.                              *
*      - IF THIS IS A SPAWNED TRANSACTION, SEE IF THE ORIGINATING      *
*        TRANSACTION HAS ENDED AND IS WAITING FOR THIS TRANSACTION     *
*        TO END. IF SO, UNCHAIN ORIGINATING TRANSACTION AND DELETE IF  *
*        IF IT IS NOT WAITING FOR ANY OTHER TRANSACTIONS TO END.       *
*      - DELETE TRAN%BLOCK FOR THIS TRANSACTION IF IT DOES NOT         *
*        HAVE ANY PENDING TRANSACTIONS AND IF ITS ORIGINATING          *
*        TRANSACTION HAS ENDED.                                        *
*   ENTRY: R5 = WA(TRAN%BLOCK) TO CLEANUP                              *
*          R7 = WA(JOURNAL RECORD                                      *
*   RETURN:R5,R7 PRESERVED, R6 DESTROYED.                              *
************************************************************************
         LOCAL    TEST%NEXT%REPORT,TEST%END%REPORTS,ENDED%REPORT,;
         TEST%NEXT%SPAWNED,TEST%END%SPAWNED,NEXT%SPAWNED,END%SPAWNED,;
         TEST%DELETE,RETURN,OTHER%SPAWNED
CLEANUP%TRANS,'CLEANUP%TRANS' ENTRY
TEST%NEXT%REPORT ;                  R2 = WA(REPORT%BLOCK) OF FIRST
         GET,R2   REPORT%BLOCK,R5   REPORT BLOCK (IF ANY).
TEST%END%REPORTS ;
         BEZ      TEST%NEXT%SPAWNED BRANCH IF NONE
         TBIT,R3  END,R2            HAS REPORT ENDED
         BNEZ     ENDED%REPORT      BRANCH IF YES
*   FALL THRU IF REPORT HAS NOT ENDED. CHAIN TO NEXT REPORT
         GET,R2,R3 REPORT%BLOCK,R2  R2 = WA(NEXT REPORT BLOCK)
         B        TEST%END%REPORTS
ENDED%REPORT ;
         LW,R6    R2                R6 = WA(ENDED REPORT BLOCK)
         CALL     UNCHAIN%REPORT
         XW,R5    R6                R5 = WA(UNCHAINED REPORT BLOCK)
*                                   R6 = WA(ORIGINATING BLOCK)
         CALL     FREE%BLOCK
         LW,R5    R6                R5 = WA(ORIGINATING BLOCK)
         B        TEST%NEXT%REPORT
         SPACE
*   ALL ENDED REPORT BLOCKS ARE DELETED.
*   SEE IF THERE ARE ANY SPAWNED TRANSACTIONS. IF YES, DELETE ALL
         SPACE
TEST%NEXT%SPAWNED ;                 R2 = WA(TRAN%BLOCK) OF FIRST
         GET,R2   SPAWNED%TRANS,R5  SPAWNED TRANSACTION, IF ANY.
TEST%END%SPAWNED ;
         BEZ      END%SPAWNED       BRANCH IF NONE
         TBIT,R3  END,R2            HAS SPAWNED TRANSACTION ENDED
         BEZ      NEXT%SPAWNED      BRANCH IF NOT ENDED
*                                   DOES SPAWNED TRANSACTION HAVE ANY
         GET,R4   REPORT%BLOCK,R2   REPORTS THAT HAVE NOT ENDED
         BNEZ     NEXT%SPAWNED      BRANCH IF REPORTS NOT ENDED
*   SPAWNED TRANSACTION HAS ENDED AND IT HAS NO OUTSTANDING REPORTS.
*   UNCHAIN SPAWNED TRANSACTION AND DELETE IT.
         LW,R6    R2                R6 = WA(SPAWNED TRAN%BLOCK)
         CALL     UNCHAIN%SPAWNED%TRANS
         XW,R6    R5                R6 = WA(ORIGINATING TRAN%BLOCK)
*                                   R5 = WA(SPAWNED TRAN%BLOCK)
         CALL     UNCHAIN%TRAN
         CALL     FREE%BLOCK
         B        TEST%NEXT%SPAWNED
NEXT%SPAWNED ;                      CHAIN TO NEXT SPAWNED TRANSACTION
         GET,R2,R3 SPAWNED%TRANS,R2 R2 = WA(NEXT SPAWNED TRANSACTION)
         B        TEST%END%SPAWNED
         SPACE
*   ALL ENDED SPAWNED TRANSACTIONS HAVE BEEN DELETED.
*   SEE IF TRANSACTION THAT ENDED IS A SPAWNED TRANSACTION.
*   IF SO, DELETE TRAN%BLOCK OF ORIGINATING TRANSACTION IF IT
*   HAS ENDED.
         SPACE
END%SPAWNED ;
*                                   IF THIS IS SPAWNED TRANSACTION,
         GET,R2   ORIG%TRANS,R5     R2 = WA(ORIGINATING TRAN%BLOCK)
         BEZ      TEST%DELETE       BRANCH IF NOT SPAWNED TRANSACTION
         TBIT,R3  END,R2            SEE IF ORIGINATING TRANS ENDED
         BEZ      TEST%DELETE       BRANCH IF NOT
         LW,R6    R2                R6 = WA(ORIGINATING TRAN%BLOCK)
*                                   SEE IF ORIGINATING TRANSACTION HAS
         GET,R2   REPORT%BLOCK,R6   ANY UNENDED REPORTS
         BNEZ     TEST%DELETE       BRANCH IF YES
*   THE ORIGINATING TRANSACTION HAS ENDED AND HAS NO OUTSTANDING
*   REPORTS. UNCHAIN THIS SPAWNED TRANSACTION THAT ENDED.
         LW,R6    R5                R6 = WA(TRAN%BLOCK) OF SPAWNED
*                                   TRANSACTION THAT ENDED.
         CALL     UNCHAIN%SPAWNED%TRANS
*                                   SEE IF ORIGINATING TRANSACTION HAS
         GET,R2   SPAWNED%TRANS,R5  ANY OTHER UNENDED SPAWNED TRANS.
         BNEZ     OTHER%SPAWNED     BRANCH IF YES
*   DELETE TRAN%BLOCK OF ORIGINATING TRANSACTION
         CALL     UNCHAIN%TRAN
         CALL     FREE%BLOCK
OTHER%SPAWNED ;
         LW,R5    R6                R5 = WA(TRAN%BLOCK) OF ENDED SPAWNED TRANS
         SPACE
*   SEE IF BLOCK THAT ENDED CAN BE DELETED. IT CAN IF:
*      - IT HAS NO UNENDED REPORTS, AND
*      - IT HAS NO UNENDED SPAWNED TRANSACTIONS, AND
*      - IT DOES NOT HAVE AN UNENDED ORIGINATING TRANSACTION
TEST%DELETE ;
         GET,R2   REPORT%BLOCK,R5
         BNEZ     RETURN            BRANCH IF UNENDED REPORT BLOCKS
         GET,R2   SPAWNED%TRANS,R5
         BNEZ     RETURN            BRANCH IF UNENDED SPAWNED TRANS
         GET,R2   ORIG%TRANS,R5
         BNEZ     RETURN            BRANCH IF UNENDED ORIGINATING TRANS
         CALL     UNCHAIN%TRAN
         CALL     FREE%BLOCK
RETURN   RETURN
         LOCAL
         TITLE    'QREMAKE - CONVERT%ANS%SN'
************************************************************************
*   CONVERT 6-CHARACTER ANS SERIAL NUMBER TO ONE WORD.                 *
*   ENTRY : SN%BUFF = ANS SERIAL NUMBER IN TEXTC FORMAT.               *
*   RETURN: R5 = CONVERTED SERIAL NUMBER                               *
************************************************************************
         LOCAL    NEXT%ANS%CHAR
CONVERT%ANS%SN,'CONVERT%ANS%SN' ;
         ENTRY    'R5 = CONVERTED ANS SN'
         LI,R9    0                 R9 WILL CONTAIN A 6-DIGIT NUMBER
*                                   USING BITS 4-7 OF EACH ANS CHARACTER
         LI,R10   0                 R10 WILL CONTAIN A 12-BIT STRING
*                                   CONCATENATING BITS 2-3 OF EACH
*                                   ANS CHARACTER. BITS 0-1 OF EACH
*                                   ANS CHARACTER ARE THROWN AWAY.
         LI,R12   6                 LOOP 6 TIMES
         LI,R3    1                 R3 = INDEX TO ANS CHARACTER
NEXT%ANS%CHAR ;
         LB,R13   SN%BUFF,R3        R13 = NEXT CHARACTER
         AND,R13  MASKS+4           MASK OFF BITS 0-4
         MI,R9    10
         AW,R9    R13               ADD NEXT DIGIT TO TOTAL
         LB,R13   SN%BUFF,R3
         SLS,13   -4
         AND,13   MASKS+2           MASK OFF BITS 2-3
         SLS,R10  2
         OR,R10   R13               ADD NEXT ZONE BITS TO TOTAL
         AI,R3    1                 INDEX NEXT CHARACTER
         BDR,R12  NEXT%ANS%CHAR
         SLS,R10  20                ZONE STRING IN HIGH ORDER 12 BITS
         OR,R10   R9                DIGITS IN LOW ORDER 24 BITS
         LW,R5    R10
         RETURN
         LOCAL
         TITLE    'QREMAKE - CONVERT%HEX'
************************************************************************
*   CONVERT%HEX:  CONVERT ONE BYTE OF HEX DATA TO 2 EBCDIC CHARACTERS. *
*   INPUT : R5 = BYTE OF HEX DATA, RIGHT JUSTIFIED.                    *
*   RETURN: R5 = 2 EBCDIC CHARACTERS, RIGHT JUSTIFIED.                 *
*           R4 IS DESTROYED. OTHER REGISTERS ARE PRESERVED.            *
************************************************************************
CONVERT%HEX,'CONVERT%HEX' ;
         ENTRY    'R5 = HEX BYTE CONVERTED TO 2 EBCDIC CHARACTERS.'
         LW,R4    R5
         AND,R4   MASKS+4           R4 = LOW ORDER 4 BITS OF BYTE
         AI,R4    X'F0'             ASSUME 0-9
         CI,R4    C'9'
         BLE      %+2               IF 0-9
         AI,R4    X'C1'-X'F0'-10    IF A-F
         SLS,R5   -4
         AND,R5   MASKS+4           R5 = HIGH ORDER 4 BITS OF BYTE
         AI,R5    X'F0'             ASSUME 0-9
         CI,R5    C'9'
         BLE      %+2               IF 0-9
         AI,R5    X'C1'-X'F0'-10    IF A-F
         SLS,R5   8
         AW,R5    R4                ADD LOW ORDER DIGIT
         RETURN                     R5 = 2 EBCDIC CHARACTERS
         TITLE    'QREMAKE - CURRENT%SN'
************************************************************************
*        CURRENT%SN: GET VOLUME SERIAL NUMBER OF CURRENT VOLUME        *
*        OF JOURNAL ASSOCIATED WITH QUEUE. THE CURRENT SN IS FOUND     *
*        IN THE TPFILES RECORD FOR THE JOURNAL.                        *
*   IF IT IS NOT POSSIBLE TO ACCESS TPFILES, ASK THE OPERATOR TO       *
*   KEY IN THE CURRENT VOLUME SERIAL NUMBER.                           *
*   RETURN: R5 = CURRENT VOLUME SN                                     *
*           SNINDEX = -1 IF TPFILES NOT ACCESSABLE                     *
************************************************************************
         LOCAL    TPFILES%INACCESSABLE,WAIT,RETURN,KEYSN,ECB%KEY
         LOCAL    NOJRNL
CURRENT%SN,'CURRENT%SN' ;
         ENTRY    'BUILD THE SERIAL NUMBERS AND VOLUMN NUMBER',;
                  'INTO THE JOURNAL FPT'
         CALL     READ%TPFILES
         BCS,1    TPFILES%INACCESSABLE
         LW,R5    SNINDEX           SINDEX(HW1)=INDEX
         AND,R5   SNINDEXMASK       R5=INDEX TO CURRENT SN
         STW,R5   JOURNALVOL        START AT THIS VOL NUMBER
         LW,R5    SNINDEX           SEE HOW MANY VOLUMNS THERE ARE
         SLS,R5   -16               USE IT FOR AN INDEX
         LW,R6    SN-1,R5           MOVE THE TPFILES INFORMATION
         STW,R6   JOURNALSN-1,R5    TO THE FPT
         BDR,R5   %-2
         B        RETURN
*   IF TPFILES IS INACCESSABBLE, ASK THE OPERATOR TO KEY IN THE
*   CURRENT VOLUME SERIAL NUMBER.
TPFILES%INACCESSABLE ;
         TYPE     'ENTER ONLY LAST JOURNAL SERIAL NUMBER '
ENTER%NEXT EQU %
         M:KEYIN  (MESS,KEYSN),(REPLY,SN%BUFF),(SIZE,7),(ECB,ECB%KEY)
WAIT     M:WAIT   1                 WAIT 1.2 SECONDS
         LW,R5    ECB%KEY           BIT 0 = 1 IF NOT COMPLETE
         BLZ      WAIT              CONTINUE TO WAIT
         LB,R2    SN%BUFF           GET SERIAL NUMBERS
         CI,R2    1                 CHECK FOR ONLY A CARRAGE RETURN
         BE       NOJRNL            NO JOURNAL TO REBUILD WITH
         CALL     EDIT%SN
         CALL     CONVERT%ANS%SN    GO CONVERT IT
         STW,R5   JOURNALSN         SAVE JUST CONVERTED NUMBER
         LI,R6    1
         STW,R6   JOURNALVOL        STARTS AT LAST USED JOURNAL
         B        RETURN            NOW PROCESS LAST JOURNAL
NOJRNL   EQU      %                 NOTHING TO PROCESS
         TYPE     'NO JOURNAL ASSOCIATED WITH QUEUE'
         B        ABORT2
*********************************
RETURN   RETURN
         SPACE
KEYSN    TEXTC   ;
                  ' ASSOCIATED WITH THE QUEUE '
ECB%KEY  DATA     0                 BIT 0 = 0 WHEN KEYIN COMPLETE
SN%BUFF  RES      2                 6-CHAR REPLY IN TEXTC FORMAT
         LOCAL
         TITLE    'QREMAKE - DEQ%TRAN%BLOCK'
************************************************************************
*   DEQ%TRAN%BLOCK: DEQUEUE REPORT OR TRANSACTION FROM TRAN%BLOCK.     *
*   TRANSFORM TRAN%BLOCK TO JOURNAL RECORD FORMAT AND USE              *
*   DEQUEUE ROUTINE.                                                   *
*   ENTRY : R6 = WA(TRAN%BLOCK)                                        *
*   RETURN: R5 AND R6 ARE PRESERVED, R7 IS DESTROYED.                  *
************************************************************************
         LOCAL    JOURNAL%FORMAT%REC
DEQ%TRAN%BLOCK,'DEQ%TRAN%BLOCK' ;
         ENTRY    'R6 = WA(TRAN%BLOCK) TO DEQUEUE'
         XW,R5    R6                R5 = WA(TRAN%BLOCK) TO DEQUEUE
         LI,R7    JOURNAL%FORMAT%REC  R7 = WA(JOURNAL FORMAT RECORD)
         LI,R4    JTRANAME(I)       R4 = ADDRESS TO MOVE NAME TO
         AW,R4    R7
         SLS,R4   2                 MOVE NAME FROM TRAN%BLOCK TO
         CALL     FORMAT%NAME       JOURNAL FORMAT RECORD.
         GET,R2   TRANID,R5         MOVE TRANID TO JOURNAL FORMAT
         ST,R2,R3 JTRANID,R7        RECORD.
         GET,R2   NAME%LENGTH,R5    MOVE NAME LENGTH
         ST,R2,R3 JNAMELEN,R7
         GET,R2,R3   FLAG%BUFF,R5   GET QUEUE AND JOURNAL FLAGS
         ST,R2,R3    JFLAGS,R7      INIT IN NEW JOURNAL RECORD
         CALL     DEQUEUE
         XW,R6    R5                RESTORE R5 AND R6
         RETURN
         SPACE
JOURNAL%FORMAT%REC ;
         DATA     0,0,0,0,0,0
         RES      8                 SPACE FOR NAME
         LOCAL
         TITLE    'QREMAKE - DUMMY TRAN%BLOCK'
************************************************************************
*   DUMMY%TRAN%BLOCK: BUILD A DUMMY TRAN%BLOCK AND MARK IT ENDED. THIS *
*   ROUTINE IS USED WHEN AN OUTPUT REPORT RECORD, BEGIN REPORT DELIVERY*
*   OR END REPORT DELIVERY IS FOUND BUT NO BEGIN TRANSACTION RECORD    *
*   WAS ENCOUNTERED.                                                   *
*   ENTRY : R6 = WA(PREVIOUS TRAN%BLOCK) OR 0 IF NONE                  *
*           R7 = WA(JOURNAL RECORD)                                    *
*   RETURN: R5 = WA(NEW DUMMY TRAN%BLOCK)                              *
*           R6 = WA(NEW DUMMY TRAN%BLOCK)                              *
*           R7 UNCHANGED                                               *
************************************************************************
DUMMY%TRAN%BLOCK,'DUMMY%TRAN%BLOCK' ENTRY ;
  'BUILD DUMMY TRAN%BLOCK AND MARK IT ENDED',;
  'R5,R6 = WA(NEW DUMMY TRAN%BLOCK)'
         CALL     GET%BLOCK
         SBIT,R3  END,R5            SET TRANSACTION ENDED
         CALL     CHAIN%TRAN
         LW,R6    R5                R6 = WA(NEW DUMMY TRAN%BLOCK)
         RETURN
         TITLE    'QREMAKE - DUPLICATE%REPORT'
************************************************************************
*   DUPLICATE%REPORT: SIGNAL POSSIBLE DUPLICATE REPORT.                *
*   PRINT TRANID, REPORT NAME, TRANSACTION NAME.                       *
*   ENTRY : R5 = WA(TRAN%BLOCK OF ORIGINATING TRANSACTION)             *
*           R6 = WA(REPORT%BLOCK)                                      *
*   RETURN: R5,R6 PRESERVED                                            *
************************************************************************
         LOCAL    TRANS%ENDED,PRINT%REP,DUPLICATE%MSG,;
         LINE,ID,OUTPUT%TRANS%NAME,OUTPUT%REP%NAME,LINE%SIZE,SPACE,;
         INIT%SPACES
DUPLICATE%REPORT,'DUPLICATE%REPORT' ENTRY ;
                  'R5 = WA(TRAN%BLOCK) OF ORIGINATING TRANSACTION',;
                  'R6 = WA(REPORT%BLOCK)'
         PRINT    ' '               SKIP ONE LINE
         PRINT    'THE FOLLOWING REPORT MAY APPEAR TWICE'
         TBIT,R3  END,R5            HAS TRANSACTION ENDED
         BNEZ     TRANS%ENDED       BRANCH IF YES
         PRINT    'THE TRANSACTION IS QUEUED AND WILL BE RESTARTED'
         B        PRINT%REP
TRANS%ENDED ;
         PRINT    'THE TRANSACTION HAS ENDED BUT THE REPORT IS ',;
                  'QUEUED AND WILL BE RESTARTED'
PRINT%REP ;
         PRINT    'THE REPORT HAD BEGUN DELIVERY WHEN THE SYSTEM ',;
                  'CRASHED'
         PRINT    '     TRANID   TRANSACTION NAME                ',;
                  '   REPORT NAME'
*   FORMAT AND PRINT INFORMATION TO MATCH HEADING ABOVE.
         SPACE
         LW,R1    INIT%SPACES       INITIALIZE OUTPUT RECORD WITH
         MBS,R0   BA(SPACE)         SPACES.
         LI,R4    BA(ID)            MOVE TRANSACTION NAME TO PRINT
         CALL     FORMAT%TRANID
*   MOVE TRANSACTION NAME TO OUTPUT
         LI,R4    BA(OUTPUT%TRANS%NAME)
         CALL     FORMAT%NAME
*   MOVE REPORT NAME TO OUTPUT
         XW,R6    R5                R5 = WA(REPORT%BLOCK)
*                                   R6 = WA(TRAN%BLOCK)
         LI,R4    BA(OUTPUT%REP%NAME)
         CALL     FORMAT%NAME
         XW,R6    R5                R5 = WA(TRAN%BLOCK)
*                                   R6 = WA(REPORT%BLOCK)
         PRINT    DUPLICATE%MSG
         RETURN
         SPACE
         ORG,1    %                 SET BYTE RESOLUTION
DUPLICATE%MSG ;                     OUTPUT RECORD
         GEN,8    LINE%SIZE         LENGTH
LINE     GEN,24   '   '
ID       RES,1    8                 TRANSACTION ID - 8 CHARACTERS
         GEN,24   '   '             3 SPACES
OUTPUT%TRANS%NAME ;                 TRANSACTION NAME - 32 CHAR
         RES,1    32
         GEN,24   '   '             3 SPACES
OUTPUT%REP%NAME ;                   OUTPUT REPORT NAME - 32 CHAR
         RES,1    32
LINE%SIZE         EQU %-LINE
SPACE    TEXT     ' '
         ORG      %                 SET WORD RESOLUTION
INIT%SPACES ;                       TO INITIALIZE LINE WITH SPACES
         GEN,8,24 LINE%SIZE,BA(LINE)
         LOCAL
         TITLE    'QREMAKE - DUPLICATE%SPAWNED'
************************************************************************
*   DUPLICATE%SPAWNED: SIGNAL POSSIBLE DUPLICATE SPAWNED TRANSACTION.  *
*   PRINT ORIGINATING TRANID, ORIGINATING TRANSACTION NAME,            *
*   SPAWNED TRANID, SPAWNED TRANSACTION NAME.                          *
*   ENTRY : R6 = WA(TRAN%BLOCK) OF SPAWNED TRANSACTION                 *
*           R5 = WA(TRAN%BLOCK) OF ORIGINATING TRANSACTION             *
*   RETURN: R5,R6 ARE PRESERVED                                        *
************************************************************************
         LOCAL    DUPLICATE%MSG,LINE,ORIG%ID,ORIG%NAME,SPAWNED%ID,;
         SPAWNED%NAME,LINE%SIZE,SPACE,INIT%SPACES
DUPLICATE%SPAWNED,'DUPLICATE%SPAWNDED' ;
         ENTRY    'R5 = WA(TRAN%ID) OF ORIGINATING TRANSACTION',;
                  'R6 = WA(TRAN%ID) OF SPAWNED TRANSACTION'
         PRINT    ' '               SKIP ONE LINE
         PRINT    'THE FOLLOWING SPAWNED TRANSACTION WILL BE RERUN ',;
                  'A SECOND TIME'
         PRINT    'THE ORIGINATING TRANSACTION HAD NOT ENDED, ',;
                  'AND IT HAS BEEN QUEUED TO BE RERUN.'
         PRINT    'THE SPAWNED TRANSACTION HAD ENDED WHEN THE ',;
                  'SYSTEM CRASHED'
         PRINT    'ORIG TRANID   ORIGINATING TRANSACTION NAME       ',;
                  'SPAWNED TRANID   SPAWNED TRANSACTION NAME'
*   FORMAT DATA TO CORRESPOND TO HEADING ABOVE'
         LW,R1    INIT%SPACES       INITIALIZE OUTPUT RECORD
         MBS,R0   BA(SPACE)         WITH SPACES
         LI,R4    BA(ORIG%ID)      .FORMAT TRANID OF ORIGINATING
         CALL     FORMAT%TRANID     TRANSACTION TO PRINT.
         LI,R4    BA(ORIG%NAME)     MOVE NAME OF ORIGINATING
         CALL     FORMAT%NAME       TRANSACTION TO PRINT.
         XW,R6    R5                R5 = WA(TRAN%BLOCK) OF SPAWNED
*                                        TRANSACTION
*                                   R6 = WA(ORIGINATING TRAN%BLOCK)
         LI,R4    BA(SPAWNED%ID)    MOVE TRANID OF SPAWNED TRANSACTION
         CALL     FORMAT%TRANID     TO PRINT.
         LI,R4    BA(SPAWNED%NAME)  MOVE NAME OF SPAWNED TRANSACTION
         CALL     FORMAT%NAME       TO PRINT.
         PRINT    DUPLICATE%MSG
         XW,R6    R5                RESTORE R5, R6
         RETURN
         SPACE
         ORG,1    %                 SET BYTE RESOLUTION
DUPLICATE%MSG ;                     OUTPUT RECORD
         GEN,8    LINE%SIZE         LENGTH
LINE     GEN,24   '  '
ORIG%ID  RES,1    8                 ORIGINATING TRANID - 8 CHARACTERS
         RES,1    3                 3 SPACES
ORIG%NAME ;                         ORIGINATING TRANSACTION NAME
         RES,1    32
         RES,1    3                 3 SPACES
SPAWNED%ID ;                        SPAWNED TRANID - 8 CHAR
         RES,1    8
         RES,1    8                 8 SPACES
SPAWNED%NAME ;                      SPAWNED TRANSACTION NAME
         RES,1    32
LINE%SIZE         EQU  %-LINE
SPACE    TEXT     ' '
         ORG      %                 SET WORD RESOLUTION
INIT%SPACES ;                       TO SET LINE TO SPACES WITH MBS
         GEN,8,24 LINE%SIZE,BA(LINE)
         LOCAL
         TITLE    'QREMAKE - EDIT%SN'
************************************************************************
*   EDIT%SN: EDIT ANS SERIAL NUMBER KEYED IN BY OPERATOR. IF SN IS     *
*   ERRONEOUS, PRINT ERROR MESSAGE AND ASK HIM TO KEY IT IN AGAIN.     *
*   ENTRY : SN%BUFF CONTAINS SN KEYED BY OPERATOR IN TEXTC FORMAT.     *
*   RETURN: SN%BUFF CONTAINS SN IN CORRECT FORMAT.                     *
************************************************************************
         LOCAL    TEST%SN,TEST%CHAR,INVALID%CHAR,INVALID%LENGTH
         LOCAL    CHAR%OK,KEY%AGAIN,WAIT,KEYSN,KEY%ECB,BAD%CHAR,LENG%ERR
EDIT%SN,'EDIT%SN' ENTRY  'EDITED ANS SERIAL NUMBER IS IN SN%BUFF'
TEST%SN  LB,R2    SN%BUFF           R2 = LENGTH OF SN + 1 FOR CR
         AI,R2    -1                ONE LESS FOR CR
         CI,R2    6
         BNE      INVALID%LENGTH    BRANCH IF NOT 6 CHARACTERS LONG
         SPACE
*   TEST NEXT CHARACTER FOR ALPHANUMERIC
TEST%CHAR ;
         LB,R3    SN%BUFF,R2        R3 = NEXT CHARACTER TO TEST
         CI,R3    C'A'
         BL       INVALID%CHAR
         CI,R3    C'I'
         BLE      CHAR%OK           CHARACTER BETWEEN A-I
         CI,R3    C'J'
         BL       INVALID%CHAR
         CI,R3    C'R'
         BLE      CHAR%OK           CHARACTER BETWEEN J-R
         CI,R3    C'S'
         BL       INVALID%CHAR
         CI,R3    C'Z'
         BLE      CHAR%OK           CHARACTER BETWEEN S-Z
         CI,R3    C'0'
         BL       INVALID%CHAR
         CI,R3    C'9'
         BLE      CHAR%OK           CHARACTER BETWEEN 0-9
INVALID%CHAR ;
         TYPE     'INVALID CHARACTER'
KEY%AGAIN ;
         M:KEYIN  (MESS,KEYSN),(REPLY,SN%BUFF),(SIZE,7),(ECB,KEY%ECB)
WAIT     M:WAIT   1                 WAIT 1.2 SECONDS
         LW,R5    KEY%ECB           BIT 0 = 1 IF STILL NOT POSTED
         BLZ      WAIT              CONTINUE TO WAIT FOR KEYIN
         B        TEST%SN           EDIT NEW SN.
         SPACE
INVALID%LENGTH ;
         TYPE     'SN MUST BE 6 CHAR LONG'
         B        KEY%AGAIN
         SPACE
CHAR%OK  BDR,R2   TEST%CHAR         DECREMENT INDEX AND TEST NEXT CHAR
         RETURN
         SPACE
KEYSN    TEXTC    'KEYIN 6-CHAR ALPHANUMERIC VOL SERIAL NUMBER '
KEY%ECB  DATA     0                 ECB TO WAIT FOR KEY IN
         LOCAL
         TITLE    'QREMAKE - END%PROCESSING'
************************************************************************
*   END%PROCESSING: SEARCH THE CHAIN OF TRAN%BLOCKS TO SEE             *
*   WHAT IS LEFT:                                                      *
*      - FOR TRANSACTIONS THAT HAVE NOT ENDED:                         *
*                                                                      *
*        THESE TRANSACTIONS HAVE BEEN QUEUED AND WILL BE RESTARTED.    *
*           - IF THE TRANSACTION HAS ANY REPORT BLOCKS, DEQUEUE THEM.  *
*             THEY WILL BE RESTARTED AUTOMATICALLY BY THE ORIGINAL     *
*             TRANSACTION WHEN IT IS RESTARTED.                        *
*             IF ANY REPORT HAS BEGUN, THIS IS A PROBLEM. THE REPORT   *
*             MAY APPEAR TWICE. SIGNAL THIS ANOMALY.                   *
*                                                                      *
*           - IF THE UNENDED TRANSACTION HAS ANY SPAWNED TRANSACTIONS, *
*             DEQUEUE THEM. THEY WILL BE RESTARTED AUTOMATICALLY       *
*             BY THE ORIGINAL TRANSACTION.                             *
*             IF ANY SPAWNED TRANSACTION HAS TERMINATED, THIS IS A     *
*             PROBLEM BECAUSE THE TRANSACTION WILL BE RUN TWICE.       *
*             SIGNAL THIS ANOMALY.                                     *
*                                                                      *
*      - FOR TRANSACTIONS THAT HAVE ENDED :                            *
*                                                                      *
*        THESE TRANSACTIONS HAVE BEEN DEQUEUED AND WILL NOT BE RERUN.  *
*           - IF THE TRANSACTION HAS ANY REPORT BLOCKS, LEAVE THEM     *
*             QUEUED SO THAT THEY WILL BE RESTARTED.                   *
*             IF ANY REPORT BLOCK HAS BEGUN, THIS IS A PROBLEM. THE    *
*             REPORT MAY APPEAR TWICE. SIGNAL THIS ANOMALY.            *
*                                                                      *
*           - IF THE ENDED TRANSACTION HAS ANY SPAWNED TRANSACTIONS,   *
*             LEAVE THEM QUEUED SO THAT THEY WILL BE RESTARTED.        *
************************************************************************
         LOCAL    TEST%END,TEST%REPORTS,NEXT%REPORT,TEST%SPAWNED,;
         TEST%END%SPAWNED,SPAWNED%ENDED,NEXT%SPAWNED,TRANS%ENDED,;
         TEST%END%REP,NEXT%REP,NEXT%TRANS,RETURN
END%PROCESSING,'END%PROCESSING' ENTRY
         LW,R5    TRANCHAIN         R5 = WA(FIRST TRAN%BLOCK)
         BEZ      RETURN            CHAIN IS EMPTY, NOTHING TO DO
TEST%END ;
         TBIT,R3  END,R5
         BNEZ     TRANS%ENDED       BRANCH IF TRANSACTION HAS ENDED
         GET,R6   REPORT%BLOCK,R5   R6 = WA(FIRST REPORT BLOCK)
TEST%REPORTS ;
         BEZ      TEST%SPAWNED      BRANCH IF NONE
         CALL     DEQ%TRAN%BLOCK
         TBIT,R3 BEGIN,R6           SEE IF REPORT HAS BEGUN
         BEZ      NEXT%REPORT       BRANCH IF NO
         CALL     DUPLICATE%REPORT
NEXT%REPORT ;
         GET,R6,R3 REPORT%BLOCK,R6  CHAIN TO NEXT REPORT
         B        TEST%REPORTS
         SPACE
TEST%SPAWNED ;
         GET,R6   ORIG%TRANS,R5
         BNEZ     NEXT%TRANS        BRANCH IF THIS IS SPAWNED TRANS.
*   IF THIS TRANSACTION IS ITSELF A SPAWNED TRANSACTION, IT WILL BE
*   PROCESSED WHEN WE COME TO THE TRAN%BLOCK OF THE ORIGINATING
*   TRANSACTION.
         GET,R6   SPAWNED%TRANS,R5  R6 = WA(FIRST SPAWNED TRANSACTION)
TEST%END%SPAWNED ;
         BEZ      NEXT%TRANS        BRANCH IF NO MORE SPAWNED TRANS.
         TBIT,R3  END,R6            HAS SPAWNED TRANSACTION ENDED
         BNEZ     SPAWNED%ENDED     BRANCH IF YES
         CALL     DEQ%TRAN%BLOCK    DEQUEUE IF NOT
         B        NEXT%SPAWNED
SPAWNED%ENDED ;                     SIGNAL POSSIBLE DUPLICATE
         CALL     DUPLICATE%SPAWNED SPAWNED TRANSACTION.
NEXT%SPAWNED ;
         GET,R6,R3 SPAWNED%TRANS,R6 CHAIN TO NEXT SPAWNED TRANSACTION
         B        TEST%END%SPAWNED
         SPACE    2
*   TRANSACTION HAS ENDED.
         SPACE
TRANS%ENDED ;
         GET,R6   REPORT%BLOCK,R5   R6 = BA(FIRST REPORT BLOCK)
TEST%END%REP ;
         BEZ      NEXT%TRANS        BRANCH IF END REPORT BLOCKS
         TBIT,R3  BEGIN,R6          SEE IF REPORT HAS BEGUN
         BEZ      NEXT%REP          BRANCH IF NO
         CALL     DUPLICATE%REPORT
NEXT%REP ;
         GET,R6,R3 REPORT%BLOCK,R6  CHAIN TO NEXT REPORT BLOCK
         B        TEST%END%REP
NEXT%TRANS ;
         GET,R5,R3 NEXT%BLOCK,R5    CHAIN TO NEXT TRAN%BLOCK
         BNEZ     TEST%END          BRANCH IF NOT END OF CHAIN
RETURN   EQU      %
         PRINT    ' '               SKIP ONE LINE
         PRINT    'END OF JOB - QUEUE RESTORED'
         RETURN
         LOCAL
         TITLE    'QREMAKE - END%TRANSACTION'
************************************************************************
*   END%TRANSACTION: PROCESS END TRANSACTION RECORD.                   *
*      - DEQUEUE WITH M:QUEUE.                                         *
*      - UNCHAIN SPAWNED TRANSACTIONS, IF ANY. SPAWNED TRANSACTIONS    *
*        THAT HAVE NOT ENDED WILL NOT BE RESTARTED BY THE ORIGINATING  *
*        TRANSACTION. THEY WILL RESTART BY THEMSELVES IF AN END IS     *
*        NOT FOUND.                                                    *
*      - IF THIS IS A SPAWNED TRANSACTION, SEE IF THE ORIGINATING      *
*        TRANSACTION HAS ENDED. IF NOT, THEN THIS RECORD COULD BE      *
*        SPAWNED AGAIN IF THE ORIGINATING TRANSACTION IS RESTARTED.    *
*        KEEP A RECORD OF IT.                                          *
*      - FREE   ANY COMPLETED REPORT BLOCKS.                           *
*      - FREE TRAN%BLOCK IF THERE ARE NO UNENDED REPORT BLOCKS AND     *
*        NO UNENDED ORIGINATING TRANSACTION.                           *
*   ENTRY : R7 = WA(JOURNAL RECORD)                                    *
*   RETURN: R7 UNCHANGED, R5 AND R6 DESTROYED.                         *
************************************************************************
         LOCAL    TRAN%FOUND,RETURN,Q%GET,GET%PURGE,GET%LIST
END%TRANSACTION,'END%TRANSACTION' ENTRY
         CALL     TID%CHECK
         GET,R5   JTRANID,R7        R5 = TRANID OF ENDED TRANSACTION
         CALL     SEARCH%TRANCHAIN
         BEZ      CHECK%FOR%DUMMY
LOOK%IN%QUEUE EQU %
         CALL     QSEARCH           SEE IF TRANSACTION IS IN QUEUE
         BNEZ     BAD%END%TRANS
         CI,R10   1                 IS IT QUEUED ONLY
         BE       DESTRUCT%GET
         CI,R10   2
         BE       DESTRUCT%PUT
         TYPE     'BAD QSEARCH CODE'
         B        ABORT20
DESTRUCT%GET EQU %
         LW,R1    R7
         SLS,R1   2
         AI,R1    JNAMELEN(I)+1
         STW,R1   GET%LIST
         GET,R3   JNAMELEN,R7
         STB,R3   GET%LIST
         AW,R1    R3
         LI,R2    FLAG%DESTRUCT
         STB,R2   0,R1
         M:QUEUE  GET%LIST,DEFINELIST,(LSIZE,1),(WAIT)
         BCR,12   Q%GET
         BCS,8    Q%UNAVAILABLE
         B        Q%ERROR
Q%GET    EQU      %
         STW,R8   SAVE%LISTID
         M:QUEUE  *R8,GET,(BUF,QBUFFER),;
                  (BSIZE,512%JOURNAL%RECORD%SIZE),;
                  (WAIT)
         BCR,12   GET%PURGE
         BCS,8    Q%UNAVAILABLE
         B        Q%ERROR
GET%PURGE EQU %
         M:QUEUE  *SAVE%LISTID,PURGE,(WAIT)
         BCR,12   CHK%TRN%BLK  RMC 3-20-74
         BCS,8    Q%UNAVAILABLE
         B        Q%ERROR
DESTRUCT%PUT EQU %
         CALL     DEQUEUE
CHK%TRN%BLK EQU %                   MAKE SURE THERE IS A BLOCK
         GET,R5   JTRANID,R7        RMC 3-19-74
         CALL SEARCH%TRANCHAIN      RMC 3-19-74
         BNEZ     RETURN            NO TRANBLOCK TO CLEANUP
         B        END%TRAN%CLEANUP
BAD%END%TRANS EQU %
*   FALL THRU IF NO RECORD OF BEGIN TRANSACTION.
*   THIS IS AN ERROR. PRINT MESSAGE AND CONTINUE.
         PRINT ;
  'END TRANSACTION RECEIVED BUT NO BEGIN TRANSACTION FOUND'
         CALL     PRINT%JOURNAL%RECORD
         B        RETURN
CHECK%FOR%DUMMY EQU %
         TBIT,R3  END,R6            END BIT SET IF SO TRAN BLK IS DUMMY MUST SEA
         BEZ      LOOK%IN%QUEUE
         B        END%TRAN%CLEANUP
         SPACE
TRAN%FOUND ;
         CALL     DEQUEUE
END%TRAN%CLEANUP EQU %
         LW,R5    R6                R5 = WA(TRAN%BLOCK) OF ENDED TRANS.
         SBIT,R3  END,R6            SET BIT TRANSACTION ENDED
         CALL     CLEANUP%TRANS
RETURN   RETURN
SAVE%LISTID DATA 0
GET%LIST DATA 0
FLAG%DESTRUCT EQU X'4F' TO DO GET WITH DESTRUCTIVE READ OUT
         LOCAL
         TITLE    'QREMAKE - FORMAT%ERR%CODE'
************************************************************************
*   FORMAT%ERR%CODE: FORMAT ERROR CODE OR ABN CODE TO PRINT.           *
*   INPUT : SR3(BYTE 0) = ERROR CODE                                   *
*               (BITS 8-14) = SUBCODE                                  *
*              (ADDR) = DCB ADDRESS                                    *
*           SR1 = ADDRESS OF LOCATION FOLLOWING CAL1                   *
*   RETURN: CODE%BUFF = 'CODE = XX XX'                                 *
*           SR1 AND SR3 ARE PRESERVED                                  *
*                                                                      *
************************************************************************
         LOCAL    CODE,SUBCODE
FORMAT%ERR%CODE,'FORMAT%ERR%CODE' ;
         ENTRY    'CODE%BUFF = ERROR CODE FORMATTED TO PRINT'
         LB,R5    SR3               R5 = ERROR CODE
         CALL     CONVERT%HEX
         STH,R5   CODE              STORE EBCDIC CHARACTERS IN OUTPUT
         LH,R5    SR3               R5 = CODE + SUBCODE
         AND,R5   MASKS+8
         SLS,R5   -1                R5 = 7-BIT SUBCODE
         CALL     CONVERT%HEX
         STH,R5   SUBCODE           STORE 2 EBCDIC CHARACTERS IN OUTPUT
         RETURN
         SPACE
CODE%BUFF ;
         GEN,8,56  14,'CODE = '
CODE     GEN,16,16 0,'  '           HW0 = CODE
SUBCODE  GEN,16,16   0,X'0000'
         LOCAL
         TITLE    'QREMAKE - FORMAT%NAME'
************************************************************************
*   FORMAT%NAME: FORMAT REPORT NAME OR TRANSACTION NAME FOR OUTPUT.    *
*   ENTRY : R5 = WA(TRAN%BLOCK) TO MOVE NAME FROM.                     *
*           R4 = BA(OUTPUT AREA)                                       *
*   RETURN: R5,R6,R7 PRESERVED                                         *
*           R9 = BA(NEXT CHARACTER IN OUTPUT)
************************************************************************
FORMAT%NAME,'FORMAT%NAME' ;
         ENTRY    'R5 = WA(TRAN%BLOCK) TO MOVE NAME FROM',;
   'R4 = BA(OUTPUT AREA). ON RETURN R9 = BA(NEXT OUTPUT CHARACTER)'
         LW,R8    R5                R8 = BA(TRANSACTION NAME)
         AI,R8    NAME(I)
         SLS,R8   2
         LW,R9    R4                R9 = BA(OUTPUT AREA)
         GET,R2   NAME%LENGTH,R5    R2 = LENGTH OF NAME
         STB,R2   R9                STORE COUNT MOVE MOVE
         MBS,R8   0                 MOVE FROM TRAN%BLOCK TO OUTPUT
         RETURN
         TITLE    'QREMAKE - FORMAT%TRANID'
************************************************************************
*   FORMAT TRANID TO PRINT AS 8-DIGIT HEX NUMBER                       *
*   ENTRY : R5 = WA(TRAN%BLOCK)                                        *
*           R4 = BA(OUTPUT AREA)                                       *
*   RETURN: R5,R6,R7 PRESERVED                                         *
************************************************************************
         LOCAL    NEXT%HEX%DIGIT
FORMAT%TRANID,'FORMAT%TRANID' ;
         ENTRY    'R5 POINTS TO TRAN%BLOCK WITH TRANID TO FORMAT',;
                  'R4 = BA(OUTPUT AREA)'
         GET,R3   TRANID,R5         R3 = TRANID TO CONVERT
         AI,R4    7                 R4 POINTS TO LOW ORDER DIGIT
*                                   IN OUTPUT AREA.
         LI,R2    8                 LOOP 8 TIMES
NEXT%HEX%DIGIT ;
         LW,R1    R3
         AND,R1   MASKS+4           R1 = NEXT 4 BITS OF HEX NUMBER
         AI,R1    X'F0'             ASSUME 0-9
         CI,R1    C'9'
         BLE      %+2               BRANCH IF 0-9
         AI,R1    X'C1'-X'F0'-10    A-F
         STB,R1   0,R4              STORE IN OUTPUT AREA
         AI,R4    -1                NEXT OUTPUT DIGIT
         SLS,R3   -4                NEXT 4 BITS OF TRANID
         BDR,R2   NEXT%HEX%DIGIT    BRANCH IF NOT 8 YET
         RETURN
         LOCAL
         TITLE    'QREMAKE - FREE%BLOCK'
************************************************************************
*   FREE%BLOCK: RETURN DYNAMIC BLOCK TO FREE CHAIN. CHECK TO BE        *
*   SURE BLOCK IS NOT STILL CHAINED TO SOMETHING.                      *
*   ENTRY : R5 = ADDRESS OF BLOCK TO FREE.                             *
*   RETURN: BLOCK IS ON FREE CHAIN.                                    *
*           R5,R6,R7 ARE PRESERVED.                                    *
************************************************************************
FREE%BLOCK,'FREE%BLOCK' ;
         ENTRY    'FREE DYNAMIC BLOCK POINTED TO BY R5.'
         LW,R2    FREE%BLOCK%CHAIN  R2 = POINTER TO FREE LIST
         STW,R5   FREE%BLOCK%CHAIN  FREE CHAIN POINTS TO BLOCK
*                                   BEING FREED.
         SPACE
*   CHECK TO BE SURE THE BLOCK BEING FREED DOES NOT
*   STILL POINT TO SOMETHING. IF IT DOES, THIS IS A SERIOUS
*   PROGRAMMING LOGIC ERROR.
         SPACE
         GET,R3   NEXT%BLOCK,R5
         BNEZ     CHAIN%ERROR
         GET,R3   LAST%BLOCK,R5
         BNEZ     CHAIN%ERROR
         GET,R3   SPAWNED%TRANS,R5
         BNEZ     CHAIN%ERROR
         GET,R3   ORIG%TRANS,R5
         BNEZ     CHAIN%ERROR
         GET,R3   REPORT%BLOCK,R5
         BNEZ     CHAIN%ERROR
         ST,R2,R3 NEXT%BLOCK,R5     CHAIN BLOCK TO FREE LIST
         RETURN
CHAIN%ERROR       EQU  S:UFV(ABORT10)
         TITLE    'QREMAKE - FREE%CORE'
************************************************************************
*   FREE%CORE: FREE ALL DYNAMIC CORE BLOCKS AND INITIALIZE POINTERS.   *
*   IF A QUEUEDUMP IS FOUND, WE START ALL OVER AGAIN.                  *
************************************************************************
FREE%CORE,'FREE%CORE' ENTRY
         M:FP     *PAGES%ALLOCATED  FREE ALL PAGES ALLOCATED
         LI,R2    0                 ZERO ALL ALLOCATION POINTERS
         STW,R2   PAGES%ALLOCATED
         STW,R2   FREE%BLOCK%CHAIN
         STW,R2   NEXT%FREE%WORD
         STW,R2   FREE%WORD%COUNT
         RETURN
         TITLE    'QREMAKE - GET%BLOCK'
************************************************************************
*   GET%BLOCK: GET DYNAMIC BLOCK FOR TRANSACTION OR REPORT BLOCK.      *
*   INITIALIZE TRANID AND NAME FROM JOURNAL RECORD AND SET REST        *
*   OF BLOCK TO ZERO.                                                  *
*   ENTRY : R7 = WA(JOURNAL RECORD)                                    *
*   RETURN: R5 = WA(NEW DYNAMIC BLOCK)                                 *
*           R6,R7 ARE PRESERVED                                        *
************************************************************************
         LOCAL    ALLOCATE,UNCHAIN,INIT%BLOCK,NO%CORE,ZERO%LOOP
GET%BLOCK,'GET%BLOCK' ;
         ENTRY    'R5 = ADDRESS OF ALLOCATED BLOCK',;
  'TRANID AND NAME ARE INITIALIZED FROM JOURNAL RECORD POINTED TO BY R7'
         LI,R4    BLOCK%SIZE        R4 = NUMBER OF WORDS NEEDED
         LW,R5    FREE%BLOCK%CHAIN  R5 = POINTER TO FREE CHAIN
         BNEZ     UNCHAIN           BRANCH IF THERE IS A FREE BLOCK
         CW,R4    FREE%WORD%COUNT   SEE IF ANY SPACE LEFT IN LAST PAGE
         BLE      ALLOCATE          ALLOCATED.
         M:GCP    1                 GET PAGE FROM MONITOR
         BCS,8    NO%CORE           BRANCH IF NO CORE AVAILABLE
         MTW,1    PAGES%ALLOCATED   INCREMENT NUMBER OF
*                                   PAGES ALLOCATED.
*   SR2 = ADDRESS OF PAGE ALLOCATED
         STW,SR2  NEXT%FREE%WORD    INITIALIZE ADDRESS OF NEXT FREE WORD
         LI,R2    512               INITIALIZE WORD COUNT
         STW,R2   FREE%WORD%COUNT
ALLOCATE LW,R5    NEXT%FREE%WORD    R5 = ADDRESS OF NEXT BLOCK
         AWM,R4   NEXT%FREE%WORD    UPDATE ADDRESS OF NEXT FREE WORD
         LCW,SR2  R4                UPDATE NUMBER OF WORDS LEFT
         AWM,SR2  FREE%WORD%COUNT
         B        INIT%BLOCK
UNCHAIN  GET,R2   NEXT%BLOCK,R5     R2 = WA(NEXT BLOCK ON FREE CHAIN)
         STW,R2   FREE%BLOCK%CHAIN  UPDATE FREE CHAIN POINTER
INIT%BLOCK ;
         SLS,R4   2                 NUMBER OF BYTES
         LI,R0    0                 INIT BLOCK W/ ZEROS
ZERO%LOOP   EQU   %
         STB,R0   *R5,R4
         BDR,R4   ZERO%LOOP
         STB,R0   *R5               INIT ZEROTH BYTE
         GET,R2,R3   JFLAGS,R7      GET QUEUE AND JOURNAL FLAGS
         ST,R2,R3    FLAG%BUFF,R5   SAVE IN DYNAMIC BLOCK
         GET,R2   JTRANID,R7        INITIALIZE BLOCK TRANID FROM
         ST,R2,R3 TRANID,R5         JOURNAL RECORD.
         CALL     MOVE%NAME
         RETURN
         SPACE
NO%CORE  TYPE     'NO MEMORY SPACE LEFT'
         B        ABORT7
         SPACE
FREE%BLOCK%CHAIN  DATA  0           POINTER TO CHAIN OF FREE TRAN%BLOCKS
PAGES%ALLOCATED   DATA  0           NUMBER OF PAGES ALLOCATED
FREE%WORD%COUNT   DATA  0           NUMBER OF WORDS LEFT IN PAGE
NEXT%FREE%WORD    DATA  0           WA(NEXT FREE WORD) IN PAGE
         LOCAL
         TITLE    'QREMAKE - MOVE%NAME'
************************************************************************
*   MOVE%NAME: MOVE REPORT NAME FROM JOURNAL RECORD TO                 *
*   DYNAMIC    TRAN%BLOCK.                                             *
*   ENTRY : R5 = WA(DYNAMIC BLOCK)                                     *
*           R7 = WA(JOURNAL RECORD)                                    *
*   RETURN: R5,R7 UNCHANGED                                            *
************************************************************************
MOVE%NAME,'MOVE%NAME' ;
         ENTRY    'MOVE NAME TO DYNAMIC BLOCK',;
                  'R5 = WA(DYNAMIC BLOCK), R7 = WA(JOURNAL RECORD)'
         GET,R2   JNAMELEN,R7       R2 = LENGTH OF NAME
         LI,R8    JTRANAME(I)
         AW,R8    R7                R8 = WA(NAME) IN JOURNAL
         SLS,R8   2                 R8 = BA(NAME) FOR SOURCE ADDRESS
         LW,R9    R5
         AI,R9    NAME(I)           R9 = WA(NAME) IN DYNAMIC BLOCK
         SLS,R9   2                 R9 = BA(NAME) FOR DESTINATION ADDR.
         STB,R2   R9                STORE COUNT
         MBS,R8   0                 MOVE FROM JOURNAL TO BLOCK
         ST,R2,R3 NAME%LENGTH,R5    SAVE NAME LENGTH IN BLOCK
         RETURN
         TITLE    'QREMAKE - OPEN JOURNAL'
************************************************************************
*   OPEN%JOURNAL: STORE SERIAL NUMBER OF VOLUME TO OPEN IN FPT         *
*   AND EXECUTE M:OPEN. START FIRST READ.                              *
*   ENTRY : R5 = CURRENT VOLUME SERIAL NUMBER                          *
*           R6 = NEXT VOLUME SERIAL NUMBER                             *
************************************************************************
OPEN%JOURNAL,'OPEN%JOURNAL' ;
         ENTRY    'THE FPT MUST BE READY TO BE OPENED'
         LI,R2    0                 INITIALIZE BUFFER NUMBER
         STW,R2   BUFFER%NUMBER     TO READ FIRST RECORD INTO BUFFO.
         M:OPEN,E OPEN%JOURNAL%FPT
         M:READ   F:JOURNAL,(BUF,BUFFER0),;
                  (SIZE,MAX%JOURNAL%RECORD%SIZE**2)
         RETURN
*
JRNL%ERR   EQU    %
         TYPE     'UNEXPECTED ERROR ON JOURNAL OPEN'
JRNL%OPEN%1   EQU  %
         CALL     FORMAT%ERR%CODE
         TYPE     CODE%BUFF
         B        ABORT19
*
JRNL%ABN   EQU    %
         TYPE     'UNEXPECTED ABN ON JOURNAL OPEN'
         B        JRNL%OPEN%1
*
         SPACE
*   THE LOCATION OF THE SERIAL NUMBER IN THE FPT DEPENDS ON THE OPTIONS
*   SPECIFIED IN THE M:OPEN BELOW. IF ANY OPTIONS ARE CHANGED, CHECK
*   TO SEE IF THE VARIABLE-LENGTH PARAMETER ENTRY FOR THE SN CHANGES.
         SPACE
OPEN%JOURNAL%FPT  M:OPEN,L  F:JOURNAL,(ANSLBL,'JOURNAL'),(IN),;
                  (VOL,1),(ERR,JRNL%ERR),(ABN,JRNL%ABN),;
                  (SAVE),;
                   (SN,;    LEAVE ROOM FOR 20 POSSIBLE SN'S
                  '    ','    ','    ','    ',;
                  '    ','    ','    ','    ',;
                  '    ','    ','    ','    ',;
                  '    ','    ','    ','    ')
JOURNALSN EQU OPEN%JOURNAL%FPT+14
JOURNALVOL EQU OPEN%JOURNAL%FPT+6
         RES      5
         TITLE    'QREMAKE - OPENQ'
************************************************************************
*   OPENQ: OPEN F:QUEUE FILE AS OUTPUT.                                *
*   RETURN: F:QUEUE SUCCESSFULLY OPENED.                               *
************************************************************************
OPENQ,'OPENQ'     ENTRY  'OPEN F:QUEUE FOR OUTPUT'
         REF      F:QUEUE           INCLUDE DCB FROM LIBRARY
OPENQ%1  EQU      %
         M:OPEN   F:QUEUE,(FILE,'TPQUEUE'),(RANDOM),(DIRECT),;
                  (LRECL,MAX%JOURNAL%RECORD%SIZE*4),;
                  (BLKL,MAX%JOURNAL%RECORD%SIZE*4),;
                  (SAVE),;
                  (INOUT),(ERR,QERR),(ABN,QABN)
         RETURN
*   IF THE FILE DOES NOT EXIST, A NEW RANDOM FILE IS CREATED.
*
QABN     EQU      %
         LB,R3    R10               CHECK CODE
         CI,R3    FILE%NOT%EXIST
         BE       QABN1
         CALL     FORMAT%ERR%CODE
         TYPE     'ABNORMAL ON QUEUE OPEN'
         TYPE     CODE%BUFF
         B        ABORT16
QABN1    EQU      %
         M:INT    QABN2
         TYPE     'CALL TPG TO REINITIALIZE QUEUE THEN INT  QREMAKE'
WAIT%LOOP   EQU   %
         M:WAIT   50
         B        WAIT%LOOP
QABN2    EQU      %
         TYPE     'THANK YOU'
         B        OPENQ%1
*
QERR     EQU      %
         CALL     FORMAT%ERR%CODE
         TYPE     'UNEXPECTED ERROR UPON OPENING QUEUE'
         TYPE     CODE%BUFF
         B        ABORT17
         TITLE    'QREMAKE - OUTPUT%REPORT'
************************************************************************
*   OUTPUT%REPORT. PROCESS OUTPUT REPORT RECORD.                       *
*      - QUEUE RECORD WITH M:QUEUE                                     *
*      - BUILD DYNAMIC REPORT%BLOCK                                    *
*      - CHAIN REPORT%BLOCK TO TRAN%BLOCK OF ORIGINATING TRANSACTION.  *
*   ENTRY : R7 = WA(JOURNAL RECORD)                                    *
*   RETURN: R7 UNCHANGED                                               *
************************************************************************
         LOCAL    GET%REPORT,DUPLICATE,RETURN
OUTPUT%REPORT,'OUTPUT%REPORT' ;
         ENTRY
         CALL     TID%CHECK
         TBIT,R3  JQUEUEFLAG,R7     IS REPORT TO BE QUEUED?
         BEZ      RETURN            NO
         TBIT,R3  JDELIVERYFLAG,R7  IS REPORT DELIVERY TO BE JRNL'D?
         BEZ      RETURN            NO
         GET,R5   JTRANID,R7        R5 = TRANID
*   SEE IF ORIGINATING TRANSACTION HAS ENDED
         CALL     SEARCH%TRANCHAIN
         BEZ      GET%REPORT        BRANCH IF ORIGINATING TRANSACTION
         CALL     DUMMY%TRAN%BLOCK
         SPACE
*   BUILD REPORT BLOCK
GET%REPORT ;
         CALL     SEARCH%REPORT%BLOCK
         BE       DUPLICATE
         CALL     GET%BLOCK         GET NEW REPORT BLOCK
*   CHAIN NEW REPORT BLOCK TO ORIGINATING TRANSACTION OR
*   PREVIOUS REPORT BLOCK CHAINED TO ORIGINATING TRANSACTION
         LW,R2    R5                R2 = WA(NEW REPORT  BLOCK)
         ST,R2,R5 REPORT%BLOCK,R6   CHAIN TO PREVIOUS BLOCK
         CALL     QUEUE
         B        RETURN
         SPACE
DUPLICATE ;
         PRINT    'DUPLICATE OUTPUT REPORT - IGNORED'
         CALL     PRINT%JOURNAL%RECORD
RETURN   RETURN
         SPACE
         LOCAL
         TITLE    'QREMAKE - PREVIOUS%JOURNAL%VOL'
************************************************************************
*   PREVIOUS%JOURNAL%VOL: CLOSE JOURNAL AND ATTEMPT TO BACK UP TO      *
*   THE PREVIOUS VOLUME. THE QJOURNAL%RECORD CONTAINS A LIST OF        *
*   JOURNAL VOLUMES AND AN INDEX TO THE CURRENT VOLUME. IF THE INDEX   *
*   IS NOT ZERO, IT IS POSSIBLE TO BACK UP TO THE PREVIOUS VOLUME.     *
************************************************************************
         LOCAL      GOTSN,LAST%VOLUME,BAD%TPFILES,WAIT,KEY%SN,ECB%KEY
         LOCAL    NONE
PREVIOUS%JOURNAL%VOL,'PREVIOUS%JOURNAL%VOL' ;
         ENTRY
         M:CLOSE  F:JOURNAL,(REM)
         LI,R4    1                 R4 = 1 TO INDEX HW1
         LH,R5    SNINDEX,R4        R5 = CURRENT INDEX
         BEZ      LAST%VOLUME       BRANCH IF NO PREVIOUS VOLUME
         BLZ      BAD%TPFILES       BRANCH IF TPFILES INACCESSABLE
         AI,R5    -1                UPDATE INDEX TO POINT TO
         BLEZ     LAST%VOLUME       NO MORE VOLUMES TO BACK UP TO
         STW,R5   JOURNALVOL        BACKUP ONE VOLUMN
         STH,R5   SNINDEX,R4        PREVIOUS VOLUME.
         LCI      2
         LM,R5    SN,R5             R5 = PREVIOUS VOLUME SERIAL NUMBER
*                                   R6 = CURRENT VOLUME SERIAL NUMBER
GOTSN    CALL     OPEN%JOURNAL
         RETURN                     PREVIOUS VOLUME SUCCESSFULLY OPENED
         SPACE
LAST%VOLUME ;
         TYPE     'NO PREVIOUS JOURNAL VOLUMES'
         B        ABORT2            USER ABORT
         SPACE
*   IF TPFILES INACCESSABLE, ASK OPERATOR TO KEY IN VOLUME SN
*   OF PREVIOUS JOURNAL, IF ANY.
BAD%TPFILES ;
         TYPE     'KEYIN SN OF PREVIOUS JOURNAL VOLUME IF ANY;'
         M:KEYIN  (MESS,KEY%SN),(REPLY,SN%BUFF),(SIZE,7),(ECB,ECB%KEY)
WAIT     M:WAIT   1                 WAIT 1.2 SECONDS
         LW,R5    ECB%KEY           TEST FOR COMPLETION
         BLZ      WAIT              BIT 0 = 0 IF COMPLETE
         LW,R5    SN%BUFF           R5 = 1ST WORD OF REPLY
         CW,R5    NONE
         BE       LAST%VOLUME       BRANCH IF NO PREVIOUS VOLUME
         CALL     EDIT%SN
         CALL     CONVERT%ANS%SN
         STW,R5   JOURNALSN         SAVE THE JOURNAL NUMBER
         B        GOTSN
         SPACE
KEY%SN   TEXTC   ;
                  'OTHERWISE KEY ''NONE'' '
ECB%KEY  DATA     0                 BIT 0 = 0 WHEN KEYIN COMPLETE
NONE     TEXTC    'NONE '
         LOCAL
         TITLE    'QREMAKE - PRINT%BLOCK'
************************************************************************
*   PRINT%BLOCK: PRINT TRANID AND TRANSACTION NAME OF TRAN%BLOCK       *
*   OR REPORT BLOCK.                                                   *
*   ENTRY : R5 = WA(TRAN%BLOCK)                                        *
*   RETURN: R5,R6,R7 ARE PRESERVED.                                    *
************************************************************************
         LOCAL    LINE,BLOCK%TRANID,BLOCK%NAME
PRINT%BLOCK,'PRINT%BLOCK' ;
         ENTRY    'PRINT TRANID AND NAME IN BLOCK POINTED TO BY R5'
         LI,R4    BA(BLOCK%TRANID)  MOVE TRANID TO PRINT AREA
         CALL     FORMAT%TRANID
         LI,R4    BA(BLOCK%NAME)    MOVE NAME TO PRINT AREA
         CALL     FORMAT%NAME
         AI,R9    -BA(LINE)-1       R9 = LENGTH OF LINE
         STB,R9   LINE              STORE LENGTH
         PRINT    LINE
         RETURN
         SPACE
         ORG,1    %                 SET BYTE RESOLUTION
LINE     GEN,8    0                 LINE LENGTH
         GEN,56   'TRANID='
BLOCK%TRANID ;
         GEN,80   '         '
         GEN,64   '   NAME='
BLOCK%NAME        RES,1 32
         BOUND    4
         ORG      %                 SET WORD RESOLUTION
         LOCAL
         TITLE    'QREMAKE - PRINT%JOURNAL%RECORD'
************************************************************************
*   PRINT%JOURNAL%RECORD: PRINT TRANID AND NAME OF JOURNAL RECORD.     *
*   ENTRY : R7 = WA(JOURNL RECORD)                                     *
*   RETURN: R5,R6,R7 ARE PRESERVED.                                    *
************************************************************************
         LOCAL    SAVE
PRINT%JOURNAL%RECORD,'PRINT%JOURNAL%RECORD' ;
         ENTRY ;
         'PRINT TRANID AND NAME OF JOURNAL RECORD POINTED TO BY R7'
         STW,R5   SAVE              SAVE R5
         CALL     GET%BLOCK         GET DUMMY BLOCK TO FORMAT DATA
         CALL     PRINT%BLOCK
         CALL     FREE%BLOCK        FREE DUMMY BLOCK
         LW,R5    SAVE              RESTORE R5
         RETURN
SAVE     DATA     0
         LOCAL
         TITLE    'QREMAKE - PROGRAM%CONTROL'
***************************************************************
*        PROGRAM%CONTROL  ESTABLISH TRAP AND EXIT CONTROL
*                 NO INPUT OR OUTPUT
*                 EXIT%CONTROL IS THE EXIT ROUTINE
****************************************************************
PROGRAM%CONTROL,'PROGRAM%CONTROL'   ;
         ENTRY   ;
                  'ESTABLISH TRAP AND EXIT CONTROL'
         M:TRAP   (IGNORE,FX)
         M:XCON   EXIT%CONTROL
         RETURN
*
EXIT%CONTROL   EQU   %
         PRINT    'ENTRY TO EXIT%CONTROL'
         MTW,0    BEEN%HERE%BEFORE
         BGZ      EXIT%CONT%2       CONT'T LOOP IN EXIT
         MTW,1    BEEN%HERE%BEFORE
         CI,R8    0
         BE       EXIT%CONT%3       R8=ABORT CODE OR 0
         CALL     FORMAT%ERR%CODE
         TYPE     'UNEXPECTED ENTRY TO EXIT%CONTROL'
         TYPE     CODE%BUFF
         M:QUEUE  F:QUEUE,LOCK
         BCR,12   QLOCKED
         CALL     FORMAT%ERR%CODE
         TYPE     'UNABLE TO LOCK QUEUE'
         TYPE     CODE%BUFF
QLOCKED   EQU   %
         M:XXX
EXIT%CONT%2   EQU   %
         TYPE     'LOOPIN IN EXIT CONTROL - PROGRAM ABORTED'
EXIT%CONT%3   EQU   %
         M:EXIT
*********************************************************************
         TITLE    'QREMAKE - QSEARCH'
************************************************************************
*   QSEARCH : EXECUTE M:QUEUE GET TO SEE IF RECORD IS IN THE QUEUE.
*   ENTRY : R7 = WA(JOURNAL RECORD)
*   RETURN: R5-R7 UNCHANGED
*           CC = 0000 IF RECORD IS IN THE QUEUE
*           CC = 0001 IF RECORD IS NOT IN THE QUEUE
*        R10 = 1 IF ENTRY QUEUED
*        R10 = 2 IF ENTRY QUEUED AND IN PROGRESS
************************************************************************
         LOCAL    RETURN,LIST,CRITERION,LISTID,MQECB
QSEARCH,'QSEARCH' ENTRY ;
  ' CC = 0000 IF RECORD IS IN THE QUEUE; OTHERWISE CC = 0001'
*   BUILD CRITERION FOR M:QUEUE DEFINELIST
         GET,R10,R1 JNAMELEN,R7     R2 = LENGTH OF NAME
         STB,R10  LIST              FIRST BYTE OF DEFINELIST =
*                                   LENGTH OF CRITERION
         LI,R2    JTRANAME(I)       R2 = BA(TRANSACTION NAME)
         AW,R2    R7                IN JOURNAL RECORD TO
         SLS,R2   2                 MOVE FROM
         LW,R3    LIST              R3 = DESTINATION ADDRESS +
*                                   LENGTH FOR MOVE
         MBS,R2   0                 MOVE NAME FROM JOURNAL RECORD
*                                    TO CRITERION AREA.
         M:QUEUE  LIST,STATS,(LSIZE,1),;
                  (WAIT)
         LI,R10   0                 RMC 2-4-74
         LW,R9    R8                TEST IF QUEUED
         AND,R9   QUEUED%STATUS YES INCREMENT REG 10
         BEZ      RETURN%CC%1
         MTW,1    R10
         AND,R8   IN%PROGRESS%STATUS NON-ZERO RESULT IF QUEUED
*                                   COULD ALREADY BE IN PROGRESS
         BEZ      RETURN%CC%0       SET UP RETURN CONDITION
         MTW,1    R10               QUEUED AND IN PROGRESS
         B        RETURN%CC%0       RMC 2-4-74
RETURN%CC%1 EQU %                   RMC 2-4-74
         LCI      1                 ANY OTHER RESULT INDICATES
*                                   ENTRY NOT IN QUEUE
         B        RETURN
RETURN%CC%0   EQU   %
         LCI      0                 ENTRY WAS FOUND IN QUEUE
RETURN   EQU   %
         RETURN
IN%PROGRESS%STATUS   DATA   X'10000000'
*                                   ENTRIES ARE ACCEPTABLE.
ENTRY%NOT%FOUND   EQU  QABN14       RETURN CODE FOR ENTRY NOT FOUND
*                                   FOR QUEUE REQUEST THAT REQUIRES
*                                   AN EXISTING ENTRY
LIST     GEN,8,24 0,BA(CRITERION)   EXISTING ENTRY
CRITERION  RES    MAX%JOURNAL%RECORD%SIZE
LISTID   RES      1
MQECB    DATA     0,0
QBUFFER  RES      MAX%JOURNAL%RECORD%SIZE
         LOCAL
QUEUED%STATUS DATA X'80000000'
         TITLE    'QREMAKE - QUEUE, DEQUEUE'
************************************************************************
*   QUEUE: QUEUE TRANSACTION.                                          *
*   DEQUEUE: DEQUEUE TRANSACTION.                                      *
*   ENTRY : R7 = WA(JOURNAL RECORD) OF TRANSACTION TO QUEUE OR DEQUEUE.*
*   RETURN: R7 PRESERVED, TRANSACTION QUEUED OR DEQUEUED.              *
************************************************************************
         LOCAL    PUT%LIST,RETURN,Q%GET,GET%LIST
QUEUE,'QUEUE'     ENTRY  'R7 = ADDRESS OF JOURNAL RECORD TO QUEUE'
         LI,R1    FLAG%QUEUE
         CALL     MQ                DO THIS FOR PROPER DEBUGGING RMC
         RETURN                     RMC 4-2-74
DEQUEUE,'DEQUEUE' ENTRY  'R7 = ADDRESS OF JOURNAL RECORD TO DEQUEUE'
         LI,R1    FLAG%DEQUEUE
         GET,R2   JCODE,R7          R2 = COMPLETION CODE
         BEZ      DO%MQ             GO TO COMMON QUEUE-DEQUEUE RTN
         CI,R2    FAILED%KEEP       SEE IF TRANSACTION MARKED
*                                   'FAILED, KEEP'
         BNE      DO%MQ             RMC 4-2-74 FIX DEBUG ERROR
         DO1      DELETE%FAILED%KEEP=0
         LI,R1    FLAG%MARK%FAILED
DO%MQ    EQU      %                 RMC FIXES THE DEBUG PROBLEM
         CALL     MQ                COMMON QUEUEING RMC 4-1-74
         RETURN
MQ,'COMMON%QUEUE%RTN' ;
         ENTRY    'COMMON QUEUE-DEQUEUE ROUTINE'
         STW,R7   PUT%LIST          RMC 1-31-74
         GET,R2   JFLAGS,R7
         AND,R2   CLEAN%FLAG        RMC 2-1-74
         OR,R2    R1                INCLUDE JOURNAL FLAGS IN STATUS
         STB,R2   PUT%LIST          STORE FLAGS IN PUT LIST
         M:QUEUE  PUT%LIST,PUT,(LSIZE,1),(WAIT)
         BCS,8    Q%UNAVAILABLE     BRANCH IF QUEUE UNAVAILABLE
         BCS,4    Q%ERROR
         CI,R1    FLAG%QUEUE        DO WE NEED TO DO IN PROGRESS PROC?
         BNE      RETURN            BRANCH IF NO
*                 MARK ENTRY IN PROGRESS
         LW,R1    R7                GET LIST ADR
         SLS,R1   2                 CONVERT TO BYTES
         AI,R1    JNAMELEN(I)+1     POINT TO NAME SOURCE
         STW,R1   GET%LIST          INIT BA POINTER
         GET,R3   JNAMELEN,R7       GET LENGTH IN BYTES
         STB,R3   GET%LIST
         AW,R1    R3                POINT TO END OF NAME
         GET,R2   JTYPE,R7          RMC 1-31-74
         CI,R2    X'11'             RMC 1-31-74
         BE       DESTRUCT          RMC 1-31-74
         LI,R2    FLAG%IN%PROGRESS  RMC 1-31-74
         B        DO%QUEUE%GET      RMC 1-31-74
DESTRUCT LI,R2    FLAG%DESTRUCT     RMC 1-31-74
DO%QUEUE%GET EQU %   RMC 1-31-74
         STB,R2   0,R1              INIT FLAG IN JOURNAL REC
         M:QUEUE  GET%LIST,DEFINELIST,(LSIZE,1),;
                  (WAIT)
         BCR,12   Q%GET             BRANCH IF OK
         BCS,8    Q%UNAVAILABLE
         B        Q%ERROR
Q%GET    EQU      %
         STW,R8   SAVE%LIST%ID
         M:QUEUE  *R8,GET,(BUF,QBUFFER),;
                  (BSIZE,512%JOURNAL%RECORD%SIZE),;
                  (WAIT)
         BCR,12   GET%PURGE
         BCS,8    Q%UNAVAILABLE
         B        Q%ERROR
GET%PURGE   EQU   %
         M:QUEUE  *SAVE%LIST%ID,PURGE,(WAIT)
         BCR,12   RETURN
         BCS,8    Q%UNAVAILABLE
         B        Q%ERROR
RETURN   EQU      %
         RETURN                     RETURN - TRANS QUEUED OR DEQUEUED
         SPACE
Q%UNAVAILABLE ;
         TYPE     'ERROR RETURN FROM M:QUEUE - QUEUE UNAVAILABLE'
         CALL     FORMAT%ERR%CODE
         TYPE     CODE%BUFF
         B        ABORT8
Q%ERROR  CALL     FORMAT%ERR%CODE
         TYPE     'ERROR RETURN FROM M:QUEUE'
         TYPE     CODE%BUFF
         B        ABORT9
         SPACE
PUT%LIST DATA     0
FLAG%QUEUE   EQU  X'80'
FLAG%DEQUEUE   EQU   X'10'
CLEAN%FLAG  EQU X'0000000F'
FAILED%KEEP       EQU  1            COMPLETION CODE OF 'FAILED, KEEP'
FLAG%MARK%FAILED   EQU   X'CF'
FLAG%IN%PROGRESS   EQU   X'00'
GET%LIST DATA     0
SAVE%LIST%ID   DATA   0
         TITLE    'QREMAKE - READ%JOURNAL'
************************************************************************
*   READ%JOURNAL: READ NEXT CONSECUTIVE RECORD FROM JOURNAL TAPE.      *
*   THE JOURNAL FILE IS DOUBLE-BUFFERED.                               *
*      - DO M:CHECK ON PREVIOUS READ                                   *
*      - SWITCH BUFFERS                                                *
*      - START READ INTO SECOND BUFFER                                 *
*   RETURN : CC = 0000  R7 = WA(NEXT JOURNAL RECORD)                   *
*                 0001  IF END OF FILE ENCOUNTERED                     *
*                 0010  READ ERROR. CODE%BUFF CONTAINS 'CODE = XX XX'  *
*                 0100  CHECKSUM ERROR.                                *
*            IF UNEXPECTED ABN, ABORT.                                 *
************************************************************************
         LOCAL    CHECK,JOURNAL%READ%ERR,JOURNAL%READ%ABN,JOURNAL%EOF,;
         ERROR%LAST%ENTRY,ERROR%FLAG,BUFFER%ADDRESS,RETURN
READ%JOURNAL,'READ%JOURNAL' ;
         ENTRY    'R7 = WA(NEXT JOURNAL RECORD',;
         'CC = 0001 IF EOF, 0010 IF READ ERROR, 0100 IF CHECKSUM ERROR'
CHECK    LW,R1    BUFFER%NUMBER     R1 = NUMBER OF LAST BUFFER READ
*                                   INTO: 0 OR 1.
         LW,R7    BUFFER%ADDRESS,R1 R1 = WA(LAST BUFFER READ INTO) TO
*                                   RETURN TO CALLER
         AI,R1    -1
         BEZ      %+2               BRANCH IF LAST BUFFER WAS 1
         LI,R1    1                 LAST BUFFER WAS 0
         STW,R1   BUFFER%NUMBER     UPDATE BUFFER NUMBER
         LW,R2    BUFFER%ADDRESS,R1 R2 = WA(NEXT BUFFER TO READ INTO)
         MTW,0    ERROR%FLAG
         BNEZ     ERROR%LAST%ENTRY  IF READ ERROR RETURN LAST TIME
         M:CHECK  F:JOURNAL,(ERR,JOURNAL%READ%ERR),;
                  (ABN,JOURNAL%READ%ABN)
*   START NEXT READ
         M:READ   F:JOURNAL,(BUF,*R2),;
                  (SIZE,MAX%JOURNAL%RECORD%SIZE**2)
         CALL CHECK%CHECKSUM
         B        RETURN
         SPACE
JOURNAL%READ%ERR  EQU  %
*   RETURN HERE IF READ ERROR ON JOURNAL ON LAST READ.
         SPACE
         CALL     FORMAT%ERR%CODE
         MTW,1    ERROR%FLAG        SET ERROR FLAG
         LCI      2                 CC = 0010
         B        RETURN            RETURN
         SPACE    2
JOURNAL%READ%ABN  EQU  %
*   RETURN HERE IF ABNORMAL CONDITION ON JOURNAL.
         SPACE
         LB,R5    SR3               R5 = ABNORMAL CODE
         CI,R5    EOF
         BE       JOURNAL%EOF
         CALL     FORMAT%ERR%CODE
         TYPE     'UNEXPECTED ABN ON JOURNAL'
         TYPE     CODE%BUFF         PRINT ABN CODE
         B        ABORT1            USER ABORT
         SPACE
JOURNAL%EOF ;                       END-OF-FILE ON JOURNAL
         LCI      1                 CC = 0001
         B        RETURN            EOF RETURN
         SPACE
EOF      EQU      6                 END-OF-FILE CODE
         SPACE
*   A READ ERROR OCCURRED LAST ENTRY, AND IT WAS IGNORED.
*   A NEW READ WAS NOT STARTED.
ERROR%LAST%ENTRY ;
         MTW,-1   ERROR%FLAG        TURN OFF ERROR FLAG
         M:READ   F:JOURNAL,(BUF,*R2),;
                  (SIZE,MAX%JOURNAL%RECORD%SIZE**2)
         B        CHECK
         SPACE
RETURN   RETURN
         SPACE
ERROR%FLAG        DATA  0           FLAG = 1 IF ERROR
BUFFER%NUMBER     DATA  0           BUFFER NUMBER: 0 OR 1
BUFFER%ADDRESS    DATA  BUFFER0,BUFFER1
BUFFER0  RES      MAX%JOURNAL%RECORD%SIZE
BUFFER1  RES      MAX%JOURNAL%RECORD%SIZE
         LOCAL
         TITLE    'QREMAKE - READ%TPFILES'
************************************************************************
*   READ%TPFILES: READ THE TPFILES RECORD THAT CONTAINS THE LIST OF    *
*   VOLUME SERIAL NUMBERS ASSOCIATED WITH THE JOURNAL.                 *
*   RETURN: CC = 0000  SNINDEX(HW0) = NUMBER OF SERIAL NUMBERS         *
*                             (HW1) = INDEX TO CURRENT SERIAL NUMBER   *
*                      SN = LIST OF SERIAL NUMBERS.                    *
*           CC = 0001  UNABLE TO READ TPFILES. ERROR MESSAGE OUTPUT.   *
*                      SNINDEX = -1                                    *
************************************************************************
         LOCAL    READ%JOURNAL%REC,READ%OK,ZERO%ABN,READ%ERR,;
         JOURNAL%ABN,TPFILES%ABN,TPFILES%ERR,NO%TPFILES,ERROR%RETURN,;
         RETURN
READ%TPFILES,'READ%TPFILES' ;
         ENTRY    'READ RECORD THAT CONTAINS JOURNAL SERIAL NUMBERS',;
                  'CC = 0 IF RECORD READ SUCCESSFULLY'
*   OPEN TPFILES
         REF      F:TPFILES         INCLUDE DCB FROM LIBRARY
         M:OPEN   F:TPFILES,(FILE,'TPFILES'),(KEYED),(DIRECT),(IN),;
                  (ABN,TPFILES%ABN),(ERR,TPFILES%ERR)
*   READ IN ZERO RECORD
         M:READ   F:TPFILES,(BUF,ZERO%RECORD),;
                  (SIZE,ZERO%RECORD%SIZE**2),;
                  (KEY,KEY%ZERO%RECORD),(ABN,ZERO%ABN),(ERR,READ%ERR)
READ%JOURNAL%REC  EQU  %
*
*   READ IN TPFILES JOURNAL RECORD ASSOCIATED WITH QUEUE.
         M:READ   F:TPFILES,(BUF,QJOURNAL%RECORD),;
                  (KEY,QJOURNAL%KEY),;
                  (SIZE,JOURNAL%RECORD%SIZE**2),;
                  (ABN,JOURNAL%ABN),(ERR,READ%ERR)
READ%OK ;
         LCI      0                 CC = 0000 FOR NORMAL RETURN
         B        RETURN
         SPACE
ZERO%ABN ;                          ABNORMAL RETURN WHILE READING
         LB,R5    SR3               ZERO RECORD.
         CI,R5    BUFF%TOO%SMALL    IF RECORD TOO SMALL FOR BUFFER,
         BE       READ%JOURNAL%REC  NO PROBLEM.
         SPACE
READ%ERR  ;
         CALL     FORMAT%ERR%CODE
         TYPE     'ERROR ON TPFILES'
         TYPE     CODE%BUFF
         B        ERROR%RETURN      UNABLE TO READ RECORD
         SPACE
JOURNAL%ABN ;                       ABNORMAL RETURN WHILE READING
         LB,R5    SR3               JOURNAL RECORD
         CI,R5    BUFF%TOO%SMALL    IF RECORD TOO SMALL FOR BUFFER,
         BE       READ%OK           NO PROBLEM.
         B        READ%ERR          BRANCH IF OTHER ERROR.
         SPACE
TPFILES%ABN ;                       ABNORMAL RETURN WHILE OPENING
         LB,R5    SR3               TPFILES.
         CI,R5    FILE%NOT%EXIST
         BE       NO%TPFILES        BRANCH IF TPFILES DOES NOT EXIST
TPFILES%ERR ;                       ERROR RETURN WHILE OPENING
         CALL     FORMAT%ERR%CODE   TPFILES.
         TYPE     'UNABLE TO OPEN TPFILES'
         TYPE     CODE%BUFF         PRINT ERROR CODE
         B        ERROR%RETURN
NO%TPFILES ;                        TPFILES DOES NOT EXIST
         TYPE     'TPFILES DOES NOT EXIST'
         SPACE
*   IF UNABLE TO READ THE TPFILES RECORD THAT CONTAINS THE VOLUME
*   SERIAL NUMBERS OF THE JOURNAL, SET CC FOR ERROR RETURN.
ERROR%RETURN ;
         LI,R5    -1                SET SNINDEX=-1 TO INDICATE
         STW,R5   SNINDEX           RECORD NOT READ.
         LCI      1                 CC = 0001
RETURN   RETURN
         SPACE    2
*   BUFFER TO READ ZERO RECORD FROM TPFILES
         SPACE
ZERO%RECORD ;
         DATA     0                 RECORD SIZE
         DATA     0                 NUMBER OF JOURNALS
QJOURNAL%KEY ;
         RES      8                 KEY IN TEXTC FORMAT TO READ IN
*                                   JOURNAL ASSOCIATED WITH QUEUE.
ZERO%RECORD%SIZE  EQU  %-ZERO%RECORD
         SPACE
*   BUFFER TO READ QUEUE JOURNAL RECORD FROM TPFILES
         SPACE
QJOURNAL%RECORD   EQU  %
*                                   BIT 0 = 1  EXISTS
*                                   BIT 2 = 1  THIS IS A JOURNAL
*                                   BIT 3 = 1  JOURNAL ASSOCIATED WITH Q
         DATA     0                 DEVICE TYPE
         DATA     0
         DATA     0                 ONE MORE FOR GLENN
         RES      8                 KEY IN TEXTC FORMAT
SNINDEX  DATA     0                 HW0 NUMBER OF SERIAL NUMBERS
*                                   HW1  INDEX TO CURRENT SERIAL NUMBER
SN       RES      20
JOURNAL%RECORD%SIZE   EQU  %-QJOURNAL%RECORD
         SPACE
*   MASK TO BE SURE ALL THE RIGHT BITS ARE SET IN THE TPFILES RECORD
MASK%VERIFY%QJOURNAL ;              ASSOCIATED WITH THE QUEUE JOURNAL.
         DATA     X'B0000000'       BITS 0, 2, 3
         SPACE
KEY%ZERO%RECORD ;                   KEY TO READ ZERO RECORD
         DATA     X'030000C1'       FROM TP FILES
SNINDEXMASK       EQU  MASKS+16     MASK FOR RELATIVE POSITION OF
*                                   CURRENT SN.
BUFF%TOO%SMALL    EQU  X'07'        ABN CODE IF BUFFER TOO SMALL
*                                   FOR RECORD READ.
FILE%NOT%EXIST    EQU  X'03'        ABN CODE IF FILE DOES NOT EXIST
         LOCAL
         TITLE    'QREMAKE - REPORT%BEGIN'
************************************************************************
*   REPORT%BEGIN: PROCESS BEGIN REPORT RECORD                          *
*   SET BIT IN REPORT%BLOCK TO INDICATE REPORT HAS BEGUN.              *
*   ENTRY : R7 = WA(JOURNAL RECORD)                                    *
*   RETURN: R7 UNCHANNGED                                              *
************************************************************************
         LOCAL    TRAN%FOUND,REPORT%FOUND,RETURN,NO%OUTPUT%REPORT
REPORT%BEGIN,'REPORT%BEGIN' ;
         ENTRY
         CALL     TID%CHECK
         GET,R5   JTRANID,R7        R5 = TRANID OF REPORT
         CALL     SEARCH%TRANCHAIN
         BEZ      TRAN%FOUND        BRANCH IF ORIGINATING TRANSACTION
*                                   FOUND.
         CALL     DUMMY%TRAN%BLOCK
         B        NO%OUTPUT%REPORT
         SPACE
TRAN%FOUND ;
         CALL     SEARCH%REPORT%BLOCK
         BE       REPORT%FOUND      BRANCH IF MATCHING RECORD FOUND
*   FALL THRU IF REPORT BEGIN DOES NOT HAVE A MATCHING REPORT RECORD.
NO%OUTPUT%REPORT ;
         CALL     GET%BLOCK         GET DUMMY REPORT BLOCK
*   CHAIN DUMMY REPORT BLOCK TO ORIGINATING TRANSACTION.
         LW,R2    R5                R2 = WA(NEW REPORT BLOCK)
         ST,R2,R3 REPORT%BLOCK,R6   CHAIN TO DUMMY ORIGINATING BLOCK
         CALL     QSEARCH           SEE IF RECORD IS IN QUEUE
         BEZ      REPORT%FOUND      BRANCH IF RECORD IS IN QUEUE
         SBIT,R3  END,R5            NOT QUEUED - SO END IT
         PRINT  ;
  'REPORT BEGIN ENCOUNTERED, BUT NO MATCHING ',;
  'OUTPUT REPORT RECORD WAS FOUND.'
         CALL     PRINT%JOURNAL%RECORD
REPORT%FOUND ;
         SBIT,R3  BEGIN,R6          SET REPORT BEGIN BIT
RETURN   RETURN
         TITLE    'QREMAKE - REPORT%END'
************************************************************************
*   REPORT%END: PROCESS REPORT END RECORD.                             *
*      - DEQUEUE RECORD WITH M:QUEUE PROCEDURE.                        *
*      - SET REPORT ENDED BIT.                                         *
*      - IF THE ORIGINATING TRANSACTION HAS ENDED, DELETE THE          *
*        REPORT BLOCK.                                                 *
*      - IF THE ORIGINATING TRANSACTION HAS NOT ENDED, KEEP THE        *
*        REPORT BLOCK. IF THE ORIGINATING TRANSACTION DOES NOT END     *
*        IT WILL BE RESTARTED  CAUSING THIS RECORD TO BE GENERATED     *
*        AGAIN. WE KEEP THE REPORT BLOCK IN ORDER TO REPORT THIS       *
*        ANOMALY.                                                      *
*   ENTRY : R7 = WA(JOURNAL RECORD)                                    *
*   RETURN: R7 UNCHANGED, R5 AND R6 DESTROYED.                         *
************************************************************************
         LOCAL    TRAN%FOUND,REPORT%FOUND,RETURN,NO%REPORT%FOUND
REPORT%END,'REPORT%END' ;
         ENTRY
         CALL     TID%CHECK
         GET,R5   JTRANID,R7        R5 = TRANID OF REPORT END RECORD
         CALL     SEARCH%TRANCHAIN
         BNEZ     TESTQ             BRANCH IF NO ORIGINATING TRANSACTION
TRAN%FOUND ;
         CALL     SEARCH%REPORT%BLOCK
         BE       REPORT%FOUND
TESTQ    CALL     QSEARCH           SEE IF RECORD IS QUEUED
         BNEZ     NO%REPORT%FOUND   BRANCH IF NOT QUEUED
         CALL     DEQUEUE
         B        RETURN
*   COME HERE IF NO RECORD OF REPORT BEGIN.
*   THIS IS AN ERROR. PRINT MESSAGE AND CONTINUE.
NO%REPORT%FOUND ;
         PRINT ;
  'REPORT END RECEIVED BUT NO OUTPUT REPORT RECORD FOUND'
         CALL     PRINT%JOURNAL%RECORD
         B        RETURN
REPORT%FOUND ;
         TBIT,R3  END,R6            HAS REPORT ENDED
         BNEZ     REPORT%NOT%QUEUED SENTINEL FOR REPORT NOT BEING
*                                   QUEUED (SEE REPORT%BEGIN ROUTINE)
         CALL     DEQUEUE
         SBIT,R3  END,R6            TURN ON END BIT
REPORT%NOT%QUEUED   ;
         TBIT,R3  END,R5            HAS ORIGINATING TRANSACTION ENDED
         BEZ      RETURN            IF NOT, RETURN AND KEEP RECORD
         CALL     CLEANUP%TRANS
RETURN   RETURN
         LOCAL
         TITLE    'QREMAKE - RESTORE%QDUMP'
************************************************************************
*   RESTORE%QDUMP: A QDUMP HAS BEEN FOUND ON THE JOURNAL TAPE.         *
*   RESTORE THE QUEUE.                                                 *
*   ENTRY : R7 = WA(FIRST RECORD OF QUEUE DUMP)                        *
*   RETURN: QUEUE HAS BEEN RESTORED.                                   *
*           R7 = WA(JOURNAL RECORD) OF NEXT RECORD AFTER QUEUE DUMP.   *
************************************************************************
         LOCAL    QWRITE,JOURNAL%EOF,JOURNAL%ERR,JOURNAL%CHECKSUM%ERR
         LOCAL    CRASH,RETURN,READJ
RESTORE%QDUMP,'RESTORE%QDUMP' ;
         ENTRY    'QUEUE HAS BEEN RESTORED FROM QDUMP',;
                  'JOURNAL RECORD CONTAINS RECORD FOLLOWING QDUMP'
QWRITE   LI,R8    JQBLOCK(I)
         AW,R8    R7                R8 = WA(QUEUE BLOCK)
         LI,R9    JQSECTOR(I)
         AW,R9    R7                R9 = WA(QUEUE BLOCK SECTOR NUMBER)
         LW,R9    *R9
         M:WRITE  F:QUEUE,(BUF,*R8),(SIZE,512),;
                  (BLOCK,*R9),(WAIT)
         MTW,-1   QSIZE             QSIZE COUNTDOWN D01 #26429
READJ    CALL     READ%JOURNAL
         BCS,1    JOURNAL%EOF       BRANCH IF END OF FILE
         BCS,2    JOURNAL%ERR       BRANCH IF ERROR
         BCS,4    JOURNAL%CHECKSUM%ERR
         GET,R2   JTYPE,R7          R2 = RECORD TYPE OF NEXT JOURNAL REC
         CI,R2    QDUMP%CODE        TEST FOR QDUMP RECORD
         BE       QWRITE            IF YES, CONTINUE
         CI,R2    TPG%END%CODE      BRANCH IF CRASH OCCURRED
         BE       CRASH             DURING QDUMP
         CI,R2    CRASH%RECORD%CODE
         BE       CRASH             BRANCH IF CRASH OCCURRED DURING
         B        RETURN            QDUMP.
         SPACE
JOURNAL%EOF ;
         TYPE     'UNEXPECTED EOF WHILE READING QUEUE DUMP'
         B        ABORT4            ABORT PROGRAM
JOURNAL%ERR ;
         TYPE     'READ ERROR WHILE RESTORING QUEUE DUMP'
         TYPE     CODE%BUFF         PRINT 'CODE = XX XX'
         CALL     ASK%OPERATOR
         B        READJ             SKIP ERRONEOUS RECORD
JOURNAL%CHECKSUM%ERR ;
         TYPE     'CHECKSUM ERROR WHILE RESTORING QUEUE DUMP'
         CALL     ASK%OPERATOR
         B        READJ             SKIP ERRONEOUS RECORD
         SPACE
*   THE CRASH OCCURRED DURING THE QUEUEDUMP. THE ONLY HOPE IS TO
*   RESTART FROM THE PREVIOUS VOLUME.
         SPACE
CRASH    MTW,1    DONT%READ%QDUMP   SET FLAG SO WE DONT TRY TO READ
*                                   THE QDUMP AGAIN WHEN WE COME
*                                   BACK TO IT.
         MTW,0    QSIZE             RMC D01     #26429
         BEZ      RETURN            ALL THE QUEUE IS RESTORED
         TYPE     'CRASH OCCURRED DURING QDUMP - MUST TRY TO BACK UP ',;
                  'TO PREVIOUS VOLUME'
         CALL     PREVIOUS%JOURNAL%VOL
         CALL     SEARCH%FOR%QDUMP
         B        QWRITE
         SPACE
RETURN   RETURN
         LOCAL
         TITLE    'QREMAKE - SEARCH FOR QDUMP'
************************************************************************
*   SEARCH%FOR%QDUMP: SEARCH JOURNAL TAPE FOR QDUMP RECORD.            *
*   RETURN: R7 = WA(FIRST RECORD OF QDUMP)                             *
*         - IF NO QDUMP, PRINT ERROR MESSAGE AND ABORT.                *
*         - IF READ ERROR  OR CHECKSUM ERROR, PRINT MESSAGE AND THEN   *
*           IGNORE RECORD OR ABORT DEPENDING ON OPERATOR KEYIN.        *
*         - IF CRASH RECORD FOUND BEFORE QDUMP, TRY TO BACK UP TO      *
*           PREVIOUS VOLUME.                                           *
************************************************************************
         LOCAL       READ%NEXT,JOURNAL%ERR,JOURNAL%ABN,CHECKSUM%ERROR,;
         CRASH%RECORD%FOUND,JOURNAL%EOF
SEARCH%FOR%QDUMP,'SEARCH%FOR%QDUMP' ;
         ENTRY    'R7 POINTS TO FIRST RECORD OF QDUMP'
READ%NEXT ;
         CALL     READ%JOURNAL
         BCS,1    JOURNAL%EOF       BRANCH IF END OF FILE
         BCS,2    JOURNAL%ERR       BRANCH IF ERROR
         BCS,4    CHECKSUM%ERROR    BRANCH IF CHECKSUM ERROR
         GET,R2   JTYPE,R7          R2 = RECORD TYPE
         CI,R2    QDUMP%CODE        TEST FOR QDUMP RECORD
         BE       QDUMP%FOUND       BRANCH IF FOUND
         CI,R2    CRASH%RECORD%CODE
         BE       CRASH%RECORD%FOUND
         CI,R2    TPG%END%CODE
         BE       CRASH%RECORD%FOUND
         B        READ%NEXT         CONTINUE SEARCH
         SPACE
************************************************************************
*    THE CRASH RECORD HAS BEEN FOUND, BUT NO QDUMP RECORD HAS BEEN     *
*    FOUND. THE CRASH MUST HAVE OCCURRED BEFORE THE QDUMP COULD BE     *
*    WRITTEN. TRY TO BACK UP TO PREVIOUS VOLUME.                       *
************************************************************************
CRASH%RECORD%FOUND ;
         TYPE     'CRASH RECORD FOUND BEFORE QDUMP - MUST BACK UP ',;
                  'TO PREVIOUS VOLUME'
         CALL     PREVIOUS%JOURNAL%VOL
         B        READ%NEXT
         SPACE
CHECKSUM%ERROR ;
         TYPE     'CHECKSUM ERROR WHILE SEARCHING FOR QDUMP'
         CALL     ASK%OPERATOR
         B        READ%NEXT
         SPACE
JOURNAL%ERR       EQU  %
*   READ ERROR ON JOURNAL. CODE%BUFF CONTAINS 'CODE = XX XX'
         TYPE     'READ ERROR WHILE SEARCHING FOR QDUMP'
         TYPE     CODE%BUFF         PRINT ERROR CODE
         CALL     ASK%OPERATOR
         B        READ%NEXT
         SPACE
JOURNAL%EOF ;
         TYPE     'EOF FOUND ON JOURNAL. NO QDUMP OR ',;
         'CRASH RECORD FOUND'
         B        ABORT5            ABORT PROGRAM
QDUMP%FOUND ;
         AI,R7    4                 WANT QUEUE INFORMATION
         GET,R2   CONTNAVGRANS,R7   NUMBER OF QUEUE BLOCKS
         STW,R2   QSIZE             SAVE THE NUMBER OF BLOCKS
         AI,R7    -4                RESET THE POINTER
         RETURN
         SPACE
DONT%READ%QDUMP   DATA  0
QSIZE    RES      1                 NUMBER OF QUEUE BLOCKS
         LOCAL
         TITLE    'QREMAKE - SEARCH%REPORT%BLOCK'
************************************************************************
*   SEARCH%REPORT%BLOCK: SEARCH CHAIN OF REPORT BLOCKS ON ORIGINATING  *
*   TRANSACTION FOR MATCH WITH JOURNAL RECORD.                         *
*   ENTRY : R7 = WA(JOURNAL RECORD)                                    *
*           R6 = WA(TRAN%BLOCK) OF ORIGINATING TRANSACTION             *
*   RETURN: R7    UNCHANGED                                            *
*           R5 = WA(TRAN%BLOCK) OF ORINGINATING TRANSACTION                     *
*           CC = 0000  MATCH. R6 = WA(REPORT%BLOCK)                    *
*                0001  NOMATCH. R6 = WA(TRAN%BLOCK) OF ORIGINATING     *
*                      TRANSACTION OR OF LAST REPORT BLOCK CHAINED     *
*                      TO ORIGINATING TRANSACTION.                     *
************************************************************************
         LOCAL    TEST,NEXT,NO%MATCH,RETURN
SEARCH%REPORT%BLOCK,'SEARCH%REPORT%BLOCK' ;
         ENTRY    'SEARCH FOR REPORT BLOCK THAT MATCHES JOURNAL REC',;
         'CC = 0000 IF MATCH. R6 = WA(BLOCK)',;
         'CC = 0001 IF NOMATCH. R6 = WA(LAST BLOCK)',;'
         'R5 = WA(TRAN%BLOCK) OF ORIGINATING TRANSACTION'
         LW,R5    R6                R5 = WA(ORIGINATING BLOCK)
         GET,R2   REPORT%BLOCK,R5   R2 = WA(FIRST REPORT BLOCK)
         BEZ      NO%MATCH          BRANCH IF NO REPORT BLOCKS
TEST     LI,R8    JTRANAME(I)       SET UP R8 WITH BYTE ADDRESS OF
         AW,R8    R7                REPORT NAME IN JOURNAL RECORD
         SLS,R8   2                 FOR COMPARE.
         GET,R10,R1 JNAMELEN,R7     R10 = LENGTH OF REPORT NAME
*                                   SEE IF LENGTH OF NAME IN JOURNAL
         C,R10,R3 NAME%LENGTH,R2    RECORD MATCHES LENGTH OF NAME
*                                   IN REPORT BLOCK.
         BNE      NEXT              BRANCH IF NOT
         LI,R9    NAME(I)           SET UP R9 WITH BYTE ADDRESS OF
         AW,R9    R2                NAME IN REPORT%BLOCK FOR
         SLS,R9   2                 COMPARE.
         STB,R10  R9                STORE LENGTH
         CBS,R8   0                 COMPARE NAME IN JOURNAL WITH NAME
*                                   IN REPORT%BLOCK
         BNE      NEXT              BRANCH IF NOT EQUAL
         LW,R6    R2                R6 = ADDRESS OF MATCHING BLOCK
         LCI      0                 CC = 0000
         B        RETURN
NEXT     LW,R6    R2                CHAIN TO NEXT REPORT BLOCK
         GET,R2,R3 REPORT%BLOCK,R2  R2 = WA(NEXT REPORT BLOCK)
         BNEZ     TEST              BRANCH IF NOT END OF CHAIN
         SPACE
NO%MATCH LCI      1                 CC = 0001
RETURN   RETURN
         LOCAL
         TITLE    'QREMAKE - SEARCH%TRANCHAIN'
************************************************************************
*   SEARCH%TRANCHAIN: SEARCH CHAIN OF BLOCKS TO SEE IF TRANID IS IN    *
*   CHAIN OF DYNAMIC BLOCKS.                                           *
*   ENTRY : R5 = TRANID                                                *
*   RETURN: CC = 0000  MATCH. R6 = WA(BLOCK WITH MATCHING TRANID)      *
*              = 0001  NOMATCH. R6 = WA(PREVIOUS SEQUENTIAL TRANID)    *
*                                    OR ZERO IF NONE                   *
************************************************************************
         LOCAL    NOMATCH,TEST,MATCH,RETURN
SEARCH%TRANCHAIN,'SEARCH%TRANCHAIN' ;
         ENTRY    'CC = 0000 IF R6 = WA(BLOCK WITH MATCHING TRANID)',;
                  'CC = 0001 IF R6 = WA(PREVIOUS BLOCK) OR 0 IN NONE'
         LI,R6    0                 ASSUME NO PREVIOUS BLOCK
         LW,R2    TRANCHAIN         R2 = WA(FIRST BLOCK ON CHAIN)
         BNEZ     TEST              BRANCH IF CHAIN NOT EMPTY
NOMATCH  LCI      1                 CC = 0001
         B        RETURN
TEST     C,R5,R3  TRANID,R2         IF TRANID LESS THAN TRANID IN
         BL       NOMATCH           BLOCK, IT IS NOT IN THE LIST.
         BE       MATCH
         LW,R6    R2                R6 = ADDRESS OF CURRENT BLOCK
         GET,R2   NEXT%BLOCK,R6     R2 = WA(NEXT BLOCK)
         BNEZ     TEST
         B        NOMATCH
MATCH    LW,R6    R2                R6 = ADDRESS OF BLOCK WITH MATCH
         LCI      0                 CC = 0000
RETURN   RETURN
         SPACE
TRANCHAIN         DATA  0           ADDRESS OF FIRST BLOCK IN LIST
         LOCAL
         TITLE    'QREMAKE - TID%CHECK'
******************************************************************
*        TID%CHECK : KEEP TRACK OF HIGHEST TRAN ID VALUE TO
*                    PUT IN QUEUE TTP TABLE BEFORE LOCKING IT
*
*        ENTRY : R7=WA(JOURNAL RECORD)
*        RETURN : CURRENT:TID IS CHANGED IF NEW VALUE IS GREATER
****************************************************************
TID%CHECK,'TID%CHECK'  ;
         ENTRY    'CHECK NEW TRAN ID AGAINST CURRENT HIGHEST VALUE'
         GET,R3   JTRANID,R7
         BLZ      NEGATIVE%TID
         CW,R3    CURRENT:TID
         BLE      TID%RETURN
         STW,R3   CURRENT:TID
         B        TID%RETURN
NEGATIVE%TID   EQU   %
         CW,R3    CURRENT:TID
         BGE      TID%RETURN
         STW,R3   CURRENT:TID
TID%RETURN   EQU   %
         RETURN
CURRENT:TID   DATA    0
***************************************************************
         TITLE    'QREMAKE - UNCHAIN%REPORT'
************************************************************************
*   UNCHAIN%REPORT: UNCHAIN REPORT%BLOCK FROM ORIGINATING              *
*   TRANSACTION.                                                       *
*   ENTRY : R5 = WA(ORIGINATING BLOCK)                                 *
*           R6 = WA(REPORT BLOCK TO BE UNCHAINED)                      *
*   RETURN: R5,R6,R7 PRESERVED.                                        *
************************************************************************
         LOCAL    SCAN,FOUND%PRECEDENT
UNCHAIN%REPORT,'UNCHAIN%REPORT' ;
         ENTRY    'R5 = WA(TRAN%BLOCK) OF ORIGINATING TRANSACTION',;
                  'R6 = WA(REPORT%BLOCK) TO BE UNCHAINED'
*   SINCE REPORT%BLOCKS ARE NOT DOUBLY LINKED, START FROM THE
*   ORIGINATING BLOCK AND FIND THE BLOCK THAT PRECEDES THE
*   BLOCK TO BE UNCHAINED.
         LW,R1    R5                R1 = WA(ORIGINATING BLOCK)
SCAN     GET,R2   REPORT%BLOCK,R1   R2 = WA(NEXT REPORT BLOCK)
         BEZ      ABORT12           ERROR IF END OF CHAIN
         CW,R2    R6                IS THIS THE POINTER TO THE BLOCK
*                                   TO UNCHAIN.
         BE       FOUND%PRECEDENT   BRANCH IF YES
         LW,R1    R2                R1 = WA(NEXT REPORT BLOCK)
         B        SCAN              CONTINUE SEARCH
FOUND%PRECEDENT ;
         GET,R2   REPORT%BLOCK,R6   MOVE FORWARD  POINTER FROM BLOCK TO
         ST,R2,R3 REPORT%BLOCK,R1   UNCHAIN TO PRECEEDING BLOCK.
         LI,R2    0                 ZERO POINTER IN BLOCK BEING
         ST,R2,R3 REPORT%BLOCK,R6   UNCHAINED.
         RETURN
         LOCAL
         TITLE    'QREMAKE - UNCHAIN%SPAWNED%TRANS'
************************************************************************
*   UNCHAIN%SPAWNED%TRANS: UNCHAIN SPAWNED TRANSACTION FROM            *
*   ORIGINATING TRANSACTION.                                           *
*   ENTRY : R6 = WA(TRAN%BLOCK) TO BE UNCHAINED                        *
*   RETURN: R6, R7 PRESERVED                                           *
*           R5 = WA(TRAN%BLOCK) OF ORIGINATING TRANSACTION.            *
************************************************************************
         LOCAL    SCAN,FOUND%PRECEDENT
UNCHAIN%SPAWNED%TRANS,'UNCHAIN%SPAWNED%TRANS' ;
         ENTRY    'R6 = WA(SPAWNED TRAN%BLOCK) TO BE UNCHAINED',;
                  'ON RETURN R5 = WA(ORIGINATING TRAN%BLOCK)'
*   SINCE SPAWNED TRAN%BLOCKS ARE NOT DOUBLY LINKED, START FROM THE
*   ORIGINATING BLOCK AND FIND THE BLOCK THAT PRECEDES THE
*   BLOCK TO BE UNCHAINED.
         GET,R4   ORIG%TRANS,R6     R4 = WA(ORIGINATING TRAN%BLOCK)
         LW,R5    R4                R5 = WA(ORIGINATING TRAN%BLOCK)
*                                   FOR RETURN
SCAN     GET,R2   SPAWNED%TRANS,R4  R2 = WA(NEXT SPAWNED BLOCK)
         BEZ      ABORT13           ERROR IF END OF CHAIN
         CW,R2    R6                IS THIS THE POINTER TO THE BLOCK
*                                   TO UNCHAIN.
         BE       FOUND%PRECEDENT   BRANCH IF YES
         LW,R4    R2                R4 = WA(NEXT SPAWNED BLOCK)
         B        SCAN              CONTINUE SEARCH
FOUND%PRECEDENT ;
         GET,R2   SPAWNED%TRANS,R6  MOVE FORWARD POINTER FROM BLOCK TO
         ST,R2,R3 SPAWNED%TRANS,R4  UNCHAIN TO PRECEEDING BLOCK.
         LI,R2    0                 ZERO SPAWNED%TRANS POINTERS
         ST,R2,R3 ORIG%TRANS,R6     IN UNCHAINED BLOCK.
         ST,R2,R3 SPAWNED%TRANS,R6
         RETURN
         LOCAL
         TITLE    'QREMAKE - UNCHAIN%TRAN'
************************************************************************
*   UNCHAIN%TRAN. UNCHAIN DYNAMIC BLOCK IN TRAN CHAIN.                 *
*   ENTRY : R5 =  WA(DYNAMIC BLOCK TO UNCHAIN                          *
*   RETURN: R5 UNCHANGED, BLOCK UNCHAINED.                             *
************************************************************************
         LOCAL    NOT%LAST,NOT%FIRST,LAST,INIT%POINTERS
UNCHAIN%TRAN,'UNCHAIN%TRAN' ENTRY 'UNCHAIN TRAN BLOCK POINTED TO BY R5'
         LW,R1    R5                R1 = WA(BLOCK TO UNCHAIN)
         GET,R2   LAST%BLOCK,R5     R2 = ADDRESS OF PREVIOUS BLOCK
         BNEZ     NOT%FIRST
*   THERE IS NO PREVIOUS BLOCK
         GET,R4   NEXT%BLOCK,R1     R4 = ADDRESS OF NEXT BLOCK
         BNEZ     NOT%LAST          UNCHAIN FIRST BLOCK
*   THE CHAIN IS EMPTY
         STW,R4   TRANCHAIN         ZERO TRANCHAIN
         B        INIT%POINTERS
*   UNCHAIN FIRST BLOCK
NOT%LAST STW,R4   TRANCHAIN         TRANCHAIN POINTS TO NEXT BLOCK
         ST,R2,R3 LAST%BLOCK,R4     ZERO LAST POINTER IN NEXT BLOCK
         B        INIT%POINTERS
NOT%FIRST ;
         GET,R4   NEXT%BLOCK,R1     R4 = ADDRESS OF NEXT BLOCK
         BEZ      LAST              BRANCH IF UNCHAINING LAST BLOCK
         ST,R4,R3 NEXT%BLOCK,R2     SET NEXT POINTER IN LAST BLOCK
         ST,R2,R3 LAST%BLOCK,R4     SET LAST POINTER IN NEXT BLOCK
         B        INIT%POINTERS
LAST     ST,R4    NEXT%BLOCK,R2     ZERO NEXT POINTER IN LAST BLOCK
INIT%POINTERS ;                     RESTORE R5 TO POINT TO
         LW,R5    R1                BLOCK BEING FREED
         LI,R2    0
         ST,R2,R3 NEXT%BLOCK,R5     INITIALIZE POINTERS
         ST,R2,R3 LAST%BLOCK,R5     IN FREED BLOCK.
         RETURN
         LOCAL
         TITLE    'QREMAKE   M:XXX ABORTS'
         SPACE
ABORT1   M:XXX                      UNEXPECTED ABN ON JOURNAL
ABORT2   M:XXX                      NO PREVIOUS JOURNAL VOLUMES TO
*                                   BACK UP TO.
ABORT3   M:XXX                      ABORT AFTER OPERATOR REPLY ON
*                                   READ ERROR
ABORT4   M:XXX                      ABORT WHEN UNEXPECTED EOF OCCURS ON
*                                   JOURNAL WHILE RESTORING QDUMP.
ABORT5   M:XXX                      EOF FOUND ON JOURNAL. NO QDUMP OR
*                                   CRASH RECORD FOUND.
ABORT6   M:XXX                      ERROR ON TPFILES
ABORT7   M:XXX                      OUT OF CORE
ABORT8   M:XXX                      ERROR RETURN FROM M:QUEUE
*                                   QUEUE UNAVAILABLE
ABORT9   M:XXX                      OTHER QUEUE ERROR. CODE WAS PRINTED.
ABORT10  M:XXX                      DISASTROUS PROGRAMMING ERROR. BLOCK
*                                   BEING FREED WITH NON ZERO POINTERS.
ABORT11  M:XXX                      UNEXPECTED EOF ON JOURNAL FILE
ABORT12  M:XXX                      PROGRAMMING ERROR - UNCHAINING REPORT
*                                   BLOCK NOT LINKED TO ORIGINATING BLOCK
ABORT13  M:XXX                      PROGRAMMING ERROR - UNCHAINING SPAWNED BLOCK
*                                   NOT LINKED TO ORIGINATING BLOCK
ABORT14  M:XXX                      UNABLE TO UNLOCK QUEUE
ABORT15  M:XXX                      UNABLE TO LOCK QUEUE
*
ABORT16  M:XXX                      ABN ON QUEUE OPEN
ABORT17  M:XXX                      ERR ON QUEUE OPEN
*
ABORT18  M:XXX                      QUEUE NOT INITIALIZED
ABORT19  M:XXX                      PROBLEM IN OPENING JOURNAL
ABORT20  M:XXX                      BAD QSEARCH CODE
PATCH    RES      100
F:JOURNAL DSECT 1
F:JOURNAL M:DCB   (ANSLBL,'JOURNAL'),(SN,20)
         END      QREMAKE

