*******************************************************************
*
*                      L I S T Q I P
*
*         LIST QUEUE IN PROGRESS TRANSACTIONS AND OUTPUT REPORTS
*
*              PHASE 5 OF TRANSACTION PROCESSING RECOVERY
*
*****************************************************************
         SYSTEM   TP:TPO
         SYSTEM   BPM
         SYSTEM   LP:TPOQ
         SYSTEM   SIG7FDP
*
         DEF      @P,@T,@D,FPTSECT
         DEF      LISTQIP
SAVE:Q:TID   EQU   TTP+14           GET LOCATIONTO RESTORE Q:TID
         DEF      PATCH
*
         REF      M:SI,M:LO
         REF      F:QUEUE,F:IPLIST,F:TPFILES
***************************************************************
DBGKEY   EQU      0                 SET TO NO DEBUG PRINTOUT
*                 SET TO 1 FOR A DEBUG PRINT AND TRACE RMC 3-22-74
********************************************************************
         DO       DBGKEY=1
ALLRECKEY  EQU    1
         ELSE
ALLRECKEY   EQU   0
         FIN
         PCC      0
         TITLE    ' *** LISTQIP ** VERSION 0 ** PROCEDURES'
         GENTABS
PUSH     CNAME    X'0B'
PULL     CNAME    X'0A'
*
*                 FORMAT OF CALL:
*                    PULL     2,R7       PULLS R7,R8 FROM R:TSTACK
*                    PUSH   3,R0       PUSHES R0,R1,R2 INTO R:TSTACK
*                 NOTE THAT R:TSTACK MUST BE DECLARED AND
*                 INITIALIZED AS A STACK DOUBLEWORD POINTER
*
         PROC
LF       EQU      %
TMP      SET      -2
         DO       NUM(AF)>1
         DO       AF(1)<16
         LCI      AF(1)
         ELSE
         LCI      0
         FIN
TMP      SET      0
         FIN
         GEN,8,4,20  NAME+TMP,AF(NUM(AF)),R:TSTACK
         PEND
***********************************************************************
DEBUG    CNAME
         PROC
         LOCAL    %1,%2
         DO       DBGKEY=1
         B        %1
%2       TEXTC    AF
%1       EQU      %
         M:PRINT  (MESS,%2)
         FIN
         PEND
***********************************************************
*
EXPLAIN  CNAME,0                    PRINTS OUT EXPLANATIONS
         PROC
         OPEN     X,I
X        SET      S:UFV(AF)         LIST OF MESSAGES
I        DO       NUM(X)
         ERROR,*  ;
         '                                                       ****';
                  ,X(I)
         FIN
         CLOSE    X,I
         PEND
******************************************************************
*
*        CALL, ENTRY, AND RETURN ARE FOR INTERNAL LINKING.
*                 THE LINK LABEL IS A 2-ITEM LIST:
*                 1.  ADDRESS  OF A ROUTINE
*                 2.  ADDRESS OF A TEMP FOR REMEMBERING CALLER'S
*                      ADDRESS
*                 ENTRY IS THE ENTRY POINT INTO THE CALLED ROUTINE.
*                 RETURN RETURNS CONTROL TO THE
*                 CALLING PROGRAM.
*
*                 THESE ROUTINES WERE DONATED BY TED MARTNER
*                 THEIR OPERATION IS IDENTICAL TO THEIR USE IN THE
*                 TRANSACTION PROCESSING CONTROLLER
*
******************************************************************
         OPEN     X
*
CALL     CNAME                      CALL CALLS A SUBROUTINE
         PROC
X        SET      S:UFV(AF)
         ERROR,7,NUM(X)<2     'BAD CALL'  COMPLAIN IF IT ISN'T A SUBR
LF       BAL,11   X(1)              CALL IT
         EXPLAIN  X(3)
         PEND
*
ENTRY    CNAME                      ENTRY STARTS A SUBROUTINE
         PROC
         LOCAL    X,Y
         USECT    @T                PRESERVE A WORD IN TEMP SPACE
X        EQU      %
         DATA     0                 FOR HOLDING RETURN ADDRESS
         USECT    @P
Y        EQU      %
LF       EQU      Y,X,(AF)
         STW,11   X                 REMEMBER CALLER'S ADDRESS
         PEND
*
*                 ENTRYR NOT IMPLEMENTED FOR THIS PROGRAM
*
RETURN   CNAME
         PROC
X        SET      S:UFV(AF)
         ERROR,7,NUM(X)<2   'BAD RETURN'
LF       B        *X(2)             RETURN TO CALLER
         PEND
         CLOSE    X
*
@T       CSECT    0
@D       CSECT    0
@P       CSECT    1
         TITLE    '**  LISTQIP ** VERSION 0'
************************************************************************
*
*                             L I S T Q I P
*
*        BUILDS A FILE OF IN-PROGRESS TRANSACTIONS FROM THE QUEUE
*
*        INPUT:  THE QUEUE FILE TO BE PROCESSED VIA THE F:QUEUE DCB
*        OUTPUT: A KEYED FILE OF BEGIN TRANSACTION AND OUTPUT REPORT
*                RECORDS WITH APPROPRIATE CONTROL INFORMATION. THIS
*                FILE, ACCESSED VIA THE F:IPLIST DCB, REPRESENTS THE
*                SET OF QUEUE ENTRIES WHICH WERE IN PROGRESS WHEN TP WAS
*                STOPPED.
*        ENTRY POINT: LISTQIP
*
************************************************************************
*
         USECT    @P
LISTQIP  EQU      %
*                 INITIALIZATION
         CALL     PROGRAM%CONTROL
*        RMC NO DEBUG PATCH
         DO       DBGKEY=0
         B        NOLISTOPTION
         FIN
,FPTSECT   M:KEYIN   (MESS,DEBUGMES),(REPLY,TPBUF),;
                  (SIZE,4),(ECB,DBGECB)
WAITLOOP   EQU   %
         M:WAIT   1
         LW,R1    DBGECB
         BLZ      WAITLOOP
         LI,R1    BA(TPBUF)         ADR OF BUFFER START
         LB,R2    1,R1
         CI,R2    'D'               LIST QUEUE ENTRIES IF IN DEBUG
         BNE      NOLISTOPTION      NO
YESLISTOPTION   EQU   %
         MTW,1    LISTOPTION        YES
NOLISTOPTION  EQU %
         LI,R5    0                 PREPARE TO CALL IPLISTWRT SUBROUTINE
         CALL     IPLISTWRT         FOR INITIALIZATION
*                 OPEN AND UNLOCK QUEUE
         M:OPEN   F:QUEUE,(FILE,'TPQUEUE'),(RANDOM),(DIRECT);
                  ,(IN),(ERR,OPENQERR),(ABN,OPENQABN)
*
         M:QUEUE  F:QUEUE,UNLOCK,(OLD),(QPAGES,5),(RECOVER)
         BCR,12   UNLOCKOK
         M:SNAP   'CHK 10'
         LI,R1    ERROR30
         CALL     ADVISE
UNLOCKOK EQU      %
         LW,R6    R8                PREPARE TO SAVE Q:TID
         M:SYS                      GET INTO MASTER MODE
         STW,R6   SAVE:Q:TID        PRESERVE TID IN TTP
         LPSD,0   SLAVEPSD          RETURN TO SLAVE MODE
QOPEN    EQU      %
         LI,R6    0
PHASE5LOOP   EQU  %
         CALL     GETNEXT
         CI,R5    0                 IS THIS THE LAST TRANSACTION
         BLE      EXITPROC          YES
TOTALCNT EQU      %
         GET,R2,R4  DATASTATUSR,*R6
         AND,R2   INPROGMASK        WAS ENTRY IN PROGRESS?
         BEZ      PHASE5LOOP        NO-FINISHED WITH THIS ENTRY
         MTW,1    IPTOTAL
         CI,R5    2                 R5=2 FOR REPORTS
         BE       REPT              ITEM IS A REPORT
         MTW,1    IPTRAN            YES
         LI,R10   1
         B        GETIMAGE
REPT     EQU      %
         MTW,1    IPREPT
         LI,R10   2
GETIMAGE EQU      %
         CALL     QUEUEGET          GET ENTRY IMAGE
         CALL     IPLISTWRT         WITH R10 = 1 OR 2
         B        PHASE5LOOP        PROCESS NEXT ENTRY
*
OPENQERR  EQU     %
         LI,R1    ERROR1C           ERROR ON OPENING QUEUE
         CALL     ADVISE
OPENQABN   EQU    %
         LI,R1    ERROR1D           ABN ON  OPENING QUEUE
         CALL     ADVISE
         PAGE
************************************************************************
*
EXITPROC EQU      %
         MTW,0    INDEX:CD          WERE ALL INDEX BLKS FOUND
         BNEZ     EXITPROC21        NO
         MTW,0    ENTRY:CD          DID WE FIND ALL ENTRIES?
         BNEZ     EXITPROC20
         LI,R5    CONTROLBLK        GET INDEX REGISTER
         GET,R13,R4  CONTHTID,*R5   GET HIGHEST TID VALUE
         STW,R13  IP:HTID
         STW,R13  KEYHTID
         LW,R5    IPTOTAL           DID WE FIND ANYTHING IN PROGRESS ?
         BEZ      NOIPMESS
         LI,R5    3
         CALL     IPLISTWRT         WRITE CTL RECORD TO IPLIST FILE
*
*                 WRITE STATISTICAL SUMMARY
         LW,R1    KEYTRANCNT
         STW,R1   SUMBUF1
         LW,R1    KEYREPTCNT
         STW,R1   SUMBUF2
         M:WRITE  M:LO,(BUF,SUMBUF),(SIZE,SUMBUFSZ)
*
         LW,R5    IPTRAN
         BEZ      PHASE8MESS
PHASE6MESS    EQU %
         M:TYPE   (MESS,GOTO6)
         B        CLEANUP
*
EXITPROC20  EQU   %
         LI,R1    ERROR18
         CALL     ADVISE
EXITPROC21  EQU   %
         LI,R1    ERROR1B           ERROR: NOT ALL INDEX BLOCKS WERE FOUND
         CALL     ADVISE
*
NOIPMESS  EQU     %
         M:TYPE   (MESS,NOIPM)
         LI,R1    0
         STW,R1   IPFLG             TPIPLIST WILL NOT BE LOCKED
         B        CLEANUP
PHASE8MESS   EQU  %
         M:TYPE   (MESS,GOTO8)
CLEANUP  EQU      %
*                 MAKE ENTRY IN TPFILES FOR FOLLOWING RECOVERY JOBS
         M:OPEN   F:TPFILES,(FILE,'TPFILES'),(KEYED),(DIRECT);
                  ,(ERR,TPOPNERR),(ABN,TPOPNABN);
                  ,(INOUT),(SAVE)
         M:WRITE  F:TPFILES,(BUF,IPBUF),(SIZE,IPBUFSZ),(KEY,IPKEY),;
                  (ERR,TPWRTERR),(ABN,TPWRTABN),;
                  (ONEWKEY)
         M:CLOSE  F:TPFILES,(SAVE)
         CALL     CONVERTID         GET IT IN EBCDIC FOR M:TYPE
         LI,R1    M4BUF
         STD,R14  0,R1              INIT MESSAGE W/ TRANID
         M:TYPE   (MESS,ABRTIPM4)
         M:QUEUE  F:QUEUE,LOCK
         BCR,12   OKTOCLOSE
         M:SNAP   'CHK 10'
         LI,R1    ERROR30            ERROR IN LOCK
         CALL     ADVISE
OKTOCLOSE   EQU   %
         M:CLOSE  F:QUEUE,(SAVE)
*
ENDLISTQIP  EQU   %
         M:EXIT
         PAGE
TPWRTERR   EQU    %
         M:SNAP   'CHK 10'
         LI,R1    ERROR31
         CALL     ADVISE
*
TPWRTABN   EQU    %
         M:SNAP   'CHK 10'
         LI,R1    ERROR32
         CALL     ADVISE
*
TPOPNERR   EQU    %
         M:SNAP   'CHK 10'
         LI,R1    ERROR33
         CALL     ADVISE
*
TPOPNABN   EQU    %
         M:SNAP   'CHK 10'
         LI,R1    ERROR34
         CALL     ADVISE
*
         PAGE
*******************************************************************
*
*                  LISTQIP DATA AND DCB AREA
*
******************************************************************
         USECT    @D
         BOUND    8
R:TSTACK  DATA    WA(STKSTRT)
         GEN,16,16  64,0
STKSTRT  RES      64
*
*        PSD TO GET BACK TO SLAVE MODE
         BOUND    8
SLAVEPSD   EQU   %
         GEN,8,1,1,5,17   0,1,1,0,QOPEN
         DATA     0
*
DBGECB   DATA     0
SAVE%LIST%ID   DATA   0
IPTOTAL  DATA     0
IPTRAN   DATA     0
IPREPT   DATA     0
         DO       DBGKEY=1
LISTOPTION   DATA 1
         ELSE
LISTOPTION   DATA 0
         FIN
TPBUF    RES      512
TPBUFLEN DATA     2048
TPBUFSZ   EQU     2048
TPBUFWDS   EQU   512
INPROGMASK   DATA  X'10'
         BOUND    8
CONTROLBLK    RES      512
INXCONTROLBLK  RES     512
INDEXBLK      RES      512
DATABLK  RES      512
         BOUND    8
SUMBUF   TEXT     '*** SUMMARY ***',' NNNN TRANSACTIONS FOUND      ';
                  ,' * NNNN REPORTS FOUND      '
SUMBUF1  EQU      WA(SUMBUF)+4
SUMBUF2  EQU      WA(SUMBUF)+12
SUMBUFSZ   EQU    72
         BOUND    8
OUTBUF   RES      20
OUTBUFSIZE   EQU   80
***************************************
*
BEEN%HERE%BEFORE   DATA    0
*
IPBUF    EQU      %
         GEN,4,28  9,0              RECOVERY FILE
         DO1      2
         DATA     0                 RESERVED WORDS
IPKEY    TEXTC    'TPIPLIST'
IPFLG    GEN,8,24  1,0              THE DO NOT DESTROY THIS FILE FLG
IP:HTID  DATA     0
IPBUFSZ  EQU      32
NOIPM    TEXTC    'NO IN PROGRESS ENTRIES IN QUEUE - OK TO RESTART TP'
GOTO6    TEXTC    'DATABASE RECOVERY NEEDED * OK TO RUN PREPLOAD'
*
GOTO8    TEXTC    'NO DATABASE RECOVERY NEEDED - OK TO RUN QPREP'
IN%EXIT%LOOP   TEXTC   'LISTQIP LOOPING IN ABORT EXIT';
                  ,' - PROGRAM ABORTED'
DEBUGMES   TEXTC  'ENTER D FOR DEBUG OPTION (D OR N/L)'
UNABLETOLOCKQ   TEXTC   'LISTQIP IS UNABLE TO LOCK QUEUE'
***************************************************************
         PAGE
****************************************************************
*
*                 P R O G R A M % C O N T R O L
*
*        PROGRAM%CONTROL ESTABLISHES THE EXIT  AND TRAP CONTROL
*
*        INPUT: R8 = ABORT OR EXIT CODE
*        OUTPUT: EXIT AND TRAP CONTROL ARE INITIALIZED
*        REGISTERS USED: NONE
*        SUBROUTINES USED: NONE; EXIT%CONTROL IS CALLED IF
*                 THE PROGRAM EXITS, ABORTS OR IS ABORTED
*        CALLED BY: LISTQIP
*
********************************************************************
PROGRAM%CONTROL   ENTRY   'ESTABLISH TRAP AND EXIT CONTROL'
         DEBUG    'ENTERING PROGRAM%CONTROL'
         M:TRAP   (IGNORE,FX)
         M:XCON   EXIT%CONTROL
         DEBUG    'EXITING PROGRAM%CONTROL'
         RETURN   PROGRAM%CONTROL
*
EXIT%CONTROL   EQU   %
         MTW,0    BEEN%HERE%BEFORE  LET'S NOT GET INTO AN EXIT LOOP
         BGZ      EXIT%CONT%2
         MTW,1    BEEN%HERE%BEFORE  SET SENTINEL
         CI,R8    0                 EXIT OR ABORT ENTRY?
         BE       EXIT%CONT%3
         M:QUEUE  F:QUEUE,LOCK
         BCR,12   QLOCKED           BRANCH IF CAL WAS OK
         M:SNAP   'CHK 10'
         M:TYPE   (MESS,UNABLETOLOCKQ)
QLOCKED   EQU     %
         M:XXX                      FOR REAL FINAL ABORT
EXIT%CONT%2   EQU   %
         M:TYPE   (MESS,IN%EXIT%LOOP)
EXIT%CONT%3   EQU   %
         M:EXIT                     FOR REAL NORMAL EXIT
**********************************************************************
         TITLE    '*** LISTQIP ** VERSION 0 ** IPLISTWRT'
********************************************************
*                     IPLISTWRT
*
*
*     CONTROLS THE CONSTRUCTION OF THE LIST OF IN PROGRESS
*     TRANSACTIONS AND REPORTS ON THE DISK.  ADDITIONALLY
*     IT WRITES A SHORTENED SUMMARY OF THE IN PROGRESS
*     ITEM TO THE SYMBIONT OUTPUT FILE.
*
*        INPUT:  R5  = 0 FOR INITIALIZATION
*                      1 FOR TRANSACTION
*                      2 FOR REPORTS
*                      3 FOR CONTROL
*                TPBUF  AND TPBUFLEN FROM CALLING PROGRAM CONTAIN
*                THE ITEM TO BE TRANSFERRED TO DISK.
*        OUTPUT : THE DISK FILE, ACCESSED BY DCB F:IPLIST,
*                 IS OPENED DURING INITIALIZATION.
*                 FOR INPUT MODES 1 AND 2 THE CONTENTS OF
*                 TPBUF  ARE WRITTEN TO THE DISK WITH THE
*                 APPROPRIATE KEY. THE KEYTABLE IS UPDATED
*                 TO SHOW THIS KEY BEFORE THE RECORD IS WRITTEN
*                 THE BEGIN IMAGE OF A TRANSACTION IS
*                 RECORDED ON DISK WITH A KEY OF THE FOLLOWING
*                 TYPE:
*                             TRN1111
*                 WHERE 1111 REPRESENTS A TYPICAL 4 CHARACTER
*                 EBCDIC NUMBER.  SIMILIARLY, A REPORT IS
*                 WRITTEN TO DISK WITH A SAMPLE KEY:
*                             RPT0070
*                 THE CONTROL RECORD, ALIAS THE KEYTABLE,
*                 HAS THE FOLLOWING KEY.
*
*                             CTL0000
*        REGISTERS: NONE ARE DESTROYED, 3,4,5,10,11 ARE USED
*        SUBROUTINES: PRINTREC, EBCDICCNT
*        CALLED BY:  LISTQIP
*
*******************************************************************
         USECT    @P
IPLISTWRT  ENTRY  'CONSTRUCTION OF LIST FILE OF';
                  ,' IN PROGRESS ENTRIES'
         DEBUG    ' ENTERING IPLISTWRT'
         PUSH     3,R3
         PUSH     2,R10
         CI,R5    0
         BE       WRTINIT
         CI,R5    1
         BE       WRTTRN
         CI,R5    2
         BE       WRTRPT
         CI,R5    3
         BE       WRTCTL
         LI,R1    ERROR21           UNKNOWN REGISTER CODE
         CALL     ADVISE
*
IPLISTRET         EQU      %
         PULL     2,R10
         PULL     3,R3
         DEBUG    'EXITING IPLISTWRT'
         RETURN   IPLISTWRT
*********************
*
WRTINIT  EQU      %
*                 SET UP ABNORMAL RETURN AND TRY TO OPEN
*                 FILE IN UPDATE MODE
         M:OPEN   F:IPLIST,(FILE,'TPIPLIST'),(KEYED),(DIRECT);
                  ,(INOUT),(SAVE),(ERR,IPWRTERR);
                  ,(ABN,OPENUPABN)
*
*                 IF F:IPLIST ALREADY EXISTS,CONTROL RETURNS
*                 HERE
*                 MAKE SURE PREVIOUS CONTENTS OF F:IPLIST WERE
*                 RESTORED TO THE DATABASE.  DO NOT DESTROY
*                 THE RECORDS IF THEY ARE STILL CURRENT BY
*                  CHECKING THE FLAGS IN THE CORRESPONDING
*                 ENTRY IN TPFILES.
*
WRTINIT5  EQU     %
         M:OPEN   F:TPFILES,(FILE,'TPFILES'),(KEYED),(DIRECT);
                  ,(IN),(SAVE),(ERR,TPFILERR),(ABN,TPFILABN)
*
         M:READ   F:TPFILES,(BUF,TPBUF),(SIZE,TPBUFSZ);
                  ,(ERR,TPFILERR),(ABN,TPFILABN);
                  ,(KEY,TPFKEY)
*
         LI,R4    27                GET STATUS BYTE FROM WORD 6
         LB,R3    TPBUF,R4          GET STATUS BYTE OF IPLIST FILE
*
         CI,R3    X'01'             IS FLAG SET?
         BE       ABRTIPWRT         YES - CALL ABORT
*
WRITINIT10  EQU   %
         M:CLOSE  F:TPFILES,(SAVE)
         M:SETDCB F:IPLIST,(ABN,IPWRTABN)
         B        IPLISTRET
*
OPENUPABN  EQU    %
*                 THIS ROUTINE GETS CONTROL IF TPIPLIST DOES NOT
*                 EXIST AND CANNOT BE OPENED IN UPDATE
*                 MODE. OPEN IT IN OUTPUT MODE, WRITE A BLANK RECORD,
*                 CLOSE THE FILE AND REOPEN IT IN UPDATE MODE
*
         LB,R3    R10               PICK UP ERROR CODE
         CI,R3    X'03'             DOES FILE EXIST?
         BE       OPENUP2           NO
         LI,R1    ERROR26           UNEXPECTED ABN ON TPIPLIST
         CALL     ADVISE
OPENUP2  EQU      %
         M:OPEN   F:IPLIST,(FILE,'TPIPLIST'),(KEYED);
                  ,(DIRECT),(OUT),(SAVE),(ABN,IPWRTABN)
         CALL     MOVEBLANKS
         M:WRITE  F:IPLIST,(BUF,OUTBUF),(SIZE,OUTBUFSIZE);
                  ,(KEY,CTLKEY),(NEWKEY)
         M:CLOSE  F:IPLIST,(SAVE)
         M:OPEN   F:IPLIST,(FILE,'TPIPLIST'),(KEYED),(DIRECT);
                  ,(INOUT),(SAVE)
         B        IPLISTRET
*
IPWRTERR EQU      %
         M:SNAP   'CHK 10'          R10 HAS CODE
         LI,R1    ERROR22
         CALL     ADVISE
TPFILERR EQU      %
         LB,R3    R10               PICK UP ERROR CODE
         CI,R3    X'43'             KEY NOT PRESENT IN TPFILES
         BE       WRITINIT10        OK, CONTINUE
         M:SNAP   'CHK 10'
         LI,R1    ERROR23
         CALL     ADVISE
TPFILABN EQU      %
         LB,R3    R10
         CI,R3    X'03'
         BNE      TPFILABN1
         LI,R1    ERROR24
         CALL     ADVISE
TPFILABN1  EQU    %
         M:SNAP   'CHK 10'
         LI,R1    ERROR25
         CALL     ADVISE
ABRTIPWRT  EQU    %
         M:TYPE   (MESS,ABRTIPM1)
         M:TYPE   (MESS,ABRTIPM2)
         LI,R4    7                 GET TID FOR REFERENCE
         LW,R13   TPBUF,R4
         CALL     CONVERTID         GET HTID IN EBCDIC
         STD,R14  M4BUF             PUT IT IN M:TYPE BUFFER
         M:TYPE   (MESS,ABRTIPM4)
         M:KEYIN  (MESS,ABRTIPM3),(REPLY,REPBUF),(SIZE,3),;
                  (ECB,TPFECB)
ABRTIP1  EQU      %
         M:WAIT   1
         LW,R4    TPFECB            HAS THE REPLY COME YET?
         BLZ      ABRTIP1
         LI,R3    1                 YES
         LB,R4    REPBUF,R3         FIRST TYPED CHARACTER
         CI,R4    C'Y'              YES OF NO
         BE       WRITINIT10
         LI,R1    ERROR27
         CALL     ADVISE
IPWRTABN  EQU     %
         M:SNAP   'CHK 10'
         LI,R1    ERROR26
         CALL     ADVISE
*
*********************
*
WRTTRN   EQU      %
         CALL     EBCDICCNT
         M:WRITE  F:IPLIST,(BUF,TPBUF),(SIZE,*TPBUFLEN),(KEY,KEYTRAN);
                  ,(ONEWKEY)
         LI,R3    KEYTRAN
         CALL     PRINTREC
         B        IPLISTRET
*
*********************
*
WRTRPT   EQU      %
         CALL     EBCDICCNT
         M:WRITE  F:IPLIST,(BUF,TPBUF),(SIZE,*TPBUFLEN);
                  ,(KEY,KEYREPT),(ONEWKEY)
         LI,R3    KEYREPT
         CALL     PRINTREC
         B        IPLISTRET
*
*********************
*
WRTCTL   EQU      %
         M:TIME   KEYTIME
         M:WRITE  F:IPLIST,(BUF,TPKEYSTRT),(SIZE,TPKEYSIZE);
                  ,(KEY,CTLKEY),(ONEWKEY)
         M:CLOSE  F:IPLIST,(SAVE)
         B        IPLISTRET
*
*********************
          PAGE
*
**********************************************************************
*
*                 E B C D I C C N T
*
*        GENERATION OF KEY FOR TPIPLIST
*
*        INPUT: R5= 1 FOR TRANSACTION
*                   2 FOR REPORT
*        OUTPUT: NEW KEY IS STORED IN KEY DOUBLEWORD
*                 (KEYTRAN FOR TRANSACTIONS, KEYREPT FOR REPORTS)
*        REGISTERS USED: R13-R15
*        CALLEDBY: IPLISTWRT
*        SUBROUTINES USED: CONVERTID
*
********************************************************************************
EBCDICCNT   ENTRY    'GENERATE TPIPLIST KEY IN EBCDIC'
         DEBUG    'ENTERING EBCDICCNT'
         CI,R5    1
         BNE      EBCNT2            PROCESS REPORT SEPERATELY
         MTW,1    BINTRANCNT        INCREMENT COUNTER
         LW,R13   BINTRANCNT        INIT REGISTER FOR CONVERTID
         CALL     CONVERTID
         STW,R15  KEYTRANCNT        SAVE RESULT IN KEY DW
EBCNT1   EQU      %
         DEBUG    'EXITING EBCDICCNT'
         RETURN   EBCDICCNT
EBCNT2   EQU      %
         MTW,1    BINREPTCNT
         LW,R13   BINREPTCNT
         CALL     CONVERTID
         STW,R15  KEYREPTCNT
         B        EBCNT1
*
*******************************************************************
*                 IPLISTWRT DATA AND MESSAGE AREA
*******************************************************************
         USECT    @D
ABRTIPM1  TEXTC   'TPFILES SAYS DATABASE NOT RESTORED AFTER LAST'
ABRTIPM2  TEXTC   ' CRASH - CALL DATABASE ANALYST BEFORE CONTINUING'
*
TPFKEY   TEXTC    'TPIPLIST'
*
TPFECB   DATA     0
         DATA     0
REPBUF   DATA     0
*
ABRTIPM3  TEXTC   ' OVERWRITE CURRENT TPIPLIST (Y OR N)?'
         BOUND    8
ABRTIPM4 TEXTC    ' *** HIGHEST TRAN ID = NNNNNNNN'
M4BUF    EQU      DA(%-2)
*
*                 TPKEY TABLE
*
         BOUND    8
TPKEYSTRT         EQU    %
KEYTRAN  GEN,8,24  7,C'TRN'         WORD 0
KEYTRANCNT   DATA   C'    '         WORD 1
KEYREPT  GEN,8,24  7,C'RPT'         WORD 2
KEYREPTCNT   DATA  C'    '          WORD 3
KEYTIME  RES      4                 WORD 4
KEYHTID   DATA   0
TPKEYSIZE EQU   36
CTLKEY   GEN,8,24   7,C'CTL'
         DATA     C'0000'
BINTRANCNT  DATA  0
BINREPTCNT  DATA  0
         TITLE    '*** LISTQIP ** VERSION 0 ** PRINTREC ROUTINES'
********************************************************************
*
*
*                       P R I N T R E C
*
*
*        PRINTREC OUTPUTS A SUMMARY OF THE IN PROGRESS ITEM
*
*        INPUT:  R3=ADDRESS OF  KEYCNT  (LOCATION DIFFERS DEPENDING ON
*                   WHETHER ITEM IS A TRANSACTION OR A REPORT)
*                 = NEGATIVE VALUE FOR NON IN PROGRESS ITEM
*                 R7 AND R6 POINT TO INDEX AND DATA PARTS OF CURRENT ENTRY
*        OUTPUT: SUMMARY LINE TO M:LO
*        REGISTERS USED: R5,R6,R7 - NO REGISTERS ARE DESTROYED
*        SUBROUTINES USED: CONVERTID, MOVEIKEY, MOVEDKEY, MOVEBLANKS
*        CALLED BY:  IPLISTWRT, NEXTDKEY (IN DEBUG MODE ONLY)
*        ENTRY POINT: PRINTREC
*
************************************************************************
*
         USECT    @P
PRINTREC ENTRY    'PRINT SUMMARY OF IN PROGRESS ENTRY'
         DEBUG    '  ENTERING PRINTREC'
         CALL     MOVEBLANKS
         MTW,0    R3                IS IT A NON-IP ITEM?
         BLEZ     PRINT30           YES
         LD,R4    *R3               PICK UP IPLIST KEY
         STD,R4   OUTBUFA
         B        PRINT40
PRINT30  EQU      %
         LD,R4    ALLSTARS
         STD,R4   OUTBUFA
PRINT40  EQU      %
         CALL     MOVEIKEY
*                 WRITE RECORD
         CALL     MOVEDKEY
         M:WRITE  M:LO,(BUF,OUTBUF),(SIZE,OUTBUFSIZE)
         MTW,0    LISTOPTION
         BEZ      PRINT45
         M:WRITE  M:DO,(BUF,OUTBUF),(SIZE,OUTBUFSIZE)
         LW,R4    R6
         STW,R4   PRINTFPT+1
         AI,R4    20
         STW,R4   PRINTFPT+2
,PRINTFPT  M:SNAP 'TEXT',(ALLSTARS,ALLSTARS+1)
PRINT45  EQU      %
         DEBUG    ' EXITING PRINTREC'
         RETURN   PRINTREC
OUTBUFA  EQU      DA(OUTBUF)
         BOUND    8
ALLSTARS TEXT     C'********'
********************************************************************
         PAGE
*****************************************************************
*
*                 MOVEBLANKS
*
*        INTERNAL ROUTINE TO INITIALIZE OUTBUF
*
*        INPUT: NONE
*        OUTPUT: OUTBUF CONTAINS ALL BLANKS
*        REGISTERS USED: R5 IS USED; R10 IS DESTROYED
*        CALLED BY: IPLISTWRT AND PRINTREC
*
******************************************************************
MOVEBLANKS   ENTRY   ' INITIALIZE OUTBUF  WITH BLANKS'
         DEBUG    'ENTERING MOVEBLANKS'
         LW,R10   BLANKS
         LI,R5    OUTBUFSIZE        LOAD TABLE SIZE
         SLS,R5   -2                CONVERT BYTES TO WORDS
         AI,R5    -1                DON'T WRITE INTO IPBUF
BLANKSLOOP  EQU   %
         STW,R10  OUTBUF,R5         BLANK OUT BUFFER
         BDR,R5   BLANKSLOOP
         STW,R10  OUTBUF            FORGET NOT WORD ZERO
         DEBUG    'EXITING MOVEBLANKS'
         RETURN   MOVEBLANKS
*
BLANKS   DATA     C'    '
********************************************************************
         PAGE
******************************************************************
*
*                 MOVEIKEY
*
*        MOVE INDEX PART OF KEY NAME TO BUFFER AND INSERT
*        TRAILING PERIOD.
*
*        INPUT: CURRENT INDEX KEY ENTRY IN R7
*        OUTPUT:  OUTBUF CONTAINS INDEX PART OF KEY
*                 R5 POINTS TO NEXT BYTE POSITION IN OUTBUF
*        CALLED BY: PRINTREC
*        REGISTERS USED:   R3-R5 AND R10 DESTROYED, R7 USED
*
*************************************************************************
MOVEIKEY   ENTRY   ' MOVE INDEX PART OF KEY TO OUTBUF'
         DEBUG    'ENTERING MOVEIKEY'
         GET,R4,R3   INDEXNAMESZR,*R7      GET BYTE COUNT
         LI,R5    OUTBUFB           INIT DESTINATION ADDR FOR MBS OPERATION
         STB,R4   R5                INIT BYTE COUNT
         LW,R4    R7                INIT SOURCE ADDRESS
         AI,R4    3                 SKIP  INDEX KEY HEADER
         SLS,R4   2                 CONVERT TO BYTE ADDR
         MBS,R4   1                 MOVE STRING, SKIPPING BYTE COUNT IN SOURCE
         LI,R10   C'.'              INSERT PERIOD
         STB,R10  0,R5
         MTW,1    R5                INCREMENT BYTE POINTER FOR MOVEDKEY
         DEBUG    'EXITING MOVEIKEY'
         RETURN   MOVEIKEY
OUTBUFB  EQU      BA(OUTBUF)+16
******************************************************************
         PAGE
********************************************************************
*
*                 MOVEDKEY
*
*        MOVE DATA PART OF KEY NAME TO BUFFER, CONVERTING
*        TRANSACTION IS TO EBCDIC
*
*        INPUT: R5=CURRENT BYTE POSITION IN OUTBUF
*                 R6= POINTER TO CURRENT DATA KEY ENTRY
*        OUTPUT: DATA KEY PART IS COPIED INTO OUTBUF WITH TRAN ID IN EBCDIC
*        REGISTERS USED: R3-R5  DESTROYED, R6 AND R12-R15 USED
*        CALLED BY: PRINTREC
*        SUBROUTINES USED: CONVERTID
***********************************************************************
MOVEDKEY   ENTRY     ' MOVE DATA PART OF KEY TO BUFFER'
         DEBUG    'ENTERING MOVEDKEY'
         GET,R3,R4  DATANAMECNTR,*R6  GET BYTE CNT OF NAME
         STB,R3   R5                INIT BYTE COUNT IN R5
*                 (THE DESTINATION WAS ALREADY INIT. IN MOVEIKEY)
         LW,R4    R6                INIT SOURCE ADDRESS
         AI,R4    2                 SKIP DATA KEY HEADER
         SLS,R4   2                 CONVERT WORD ADR TO BYTE ADR
         MBS,R4   1                 SKIP BYTE COUNT IN SOURCE
         DEBUG    'EXITING MOVEDKEY'
         RETURN   MOVEDKEY
************************************************************************
         TITLE    '*** LISTQIP ** VERSION 0 ** GETNEXT ROUTINES'
************************************************************************
*                                                                      *
*                             G E T N E X T                            *
*                                                                      *
*        GETNEXT ACCESSES THE QUEUE WHERE THE NAME OF THE ITEM TO BE   *
*        RETRIEVED IS NOT KNOWN.   IT AUTOMATICALLY FINDS THE NEXT     *
*        ACTIVE ITEM AND SETS UP OOINTERS (R6 AND R7) TO THE ITEM.     *
*        INPUT: R5 = 1 FOR TRANSACTION, 2 FOR REPORT                   *
*               R6 = 0 FOR INITIALIZATION                              *
*                  = POINTER TO CURRENT DATA ITEM                      *
*               R7 = POINTER TO CURRENT INDEX ITEM                     *
*               R11= RETURN ADDRESS                                    *
*                                                                      *
*        OUTPUT: R5 = 0 FOR NO MORE ENTRIES, 1 FOR TRANSACTION,        *
*                     2 FOR REPORT (NOTE THAT R5 CHANGES WHENEVER R7   *
*                     CHANGES)                                         *
*                R6 = POINTER TO NEW CURRENT DATA ITEM                 *
*                R7 = POINTER TO NEW CURRENT INDEX ITEM                *
*                                                                      *
*        REGISTERS USED: ALL; NONE ARE DESTROYED; OUTPUT REGISTERS     *
*                        CHANGE  AS NOTED                              *
*                                                                      *
*        ENTRY POINT: GETNEXT                                          *
*                                                                      *
*        SUBROUTINES: READBLOCK, DUMPBLOCK, NEXTDKEY,
*                    NEXTIKEY, NEXTIBLK, ADVISE
*                                                                      *
*        CALLED BY: LISTQIP                                            *
*                                                                      *
************************************************************************
*
GETNEXT  ENTRY    'GET NEXT ENTRY OUT OF QUEUE'
         DEBUG    'ENTERING GETNEXT'
*
         PUSH     5,R0              PUSH R0 THRU R4
         PUSH     8,R8              PUSH R8 THRU R15
         CI,R6    0                 INITIALIZATION ?
         BE       GETNEXTINIT
         CALL     NEXTDKEY
ENDGETNEXT EQU    %
         PULL     8,R8
         PULL     5,R0
         DEBUG    ' EXITING GETNEXT'
         RETURN   GETNEXT
*
GETNEXTINIT EQU   %
         LI,R13   0                 INPUT TO READBLOCK (BLK #)
         LI,R14   1                 DITTO (BLK TYPE)
         CALL     READBLOCK
         LI,R2    CONTROLBLK        INIT INDEX REGISTER
         CALL     DUMPBLOCK
         GET,R8,R4  CONTINDEXES,*R2 INIT INDEX BLOCK COUNTDOWN
         STW,R8   INDEX:CD
         GET,R8,R4 CONTENTRIES,*R2  INIT # ENTRIES QUEUED COUNTDOWN
         STW,R8   ENTRY:CD
         GET,R8,R4 CONTFIRSTGDA,*R2  INIT # OF BLOCK ALLOCATED IN
         STW,R8   A:BLKBIAS          FIRST ALLMAP
         STW,R8   A:BLKCNT          INIT BLOCK NUMBER COUNTER
         GET,R8,R4 CONTKEYM,*R2
         AI,R8    3                 HDR SIZE IS 3 FOR INDEX BLOCK
         STW,R8   IKEYMAX           DIVIDE INTO 512 TO FIND SUPER MAX!!!
         LI,R8    0
         LI,R9    502
         DW,R8    IKEYMAX           HOW MANY KEYS IN INDEX BLK?
         STW,R9   ISUPERMAX         ISUPERMAX MANY, THAT'S HOW
         GET,R8,R4   CONTNAVGRANS,*R2    INIT MAX BLOCK SIZE
         AI,R8    -1                ZERO INDEXING ON REL BLK #
         STW,R8   BLOCKMAX
         GET,R8,R4 CONTHTID,*R2     FIND OUT IF CONTROL BLK WAS SAVED
*                                   OK BY RECOVERY
         BEZ      GET200            NO
         GET,R13,R4  CONTINXCONT,*R2  YES
         LI,R6    1
         LI,R14   2                 INDEX CONTROL BLOCK TYPE
         CALL     READBLOCK
         CALL     DUMPBLOCK
         T,R0,R4  CONTCON,*R2       IS ALLOCATION MAP IN CONTROL BLK?
         BNEZ     GET65             YES IF CONTCON = 1
*                 RESERVE PAGE BUFFER FOR ALLOCATION BLOCK, READ IT IN
*                 AND SET UP ALLOCATION TABLES
         GET,R13,R4 CONTMAP,*R2     BLOCK # OF ALLOCATION MAP
         LI,R14   3                 INIT BLOCK TYPE
*
GET40    EQU      %
         LW,R2    ALLOX             PICK UP INDEX INTO ALLOC TABLES
         M:GP     1                 GET SPACE FOR ALLOCATION BLOCK
         STW,R9   ASTART,R2         SAVE ADR OF NEW PAGE
         SLS,R9   1                 CONVERT TO HW ADDR
         AI,R9    512*2-10+1
         STW,R9   ALASTHW,R2        SAVE ADR OF LAST HW
         CALL     READBLOCK
         CALL     DUMPBLOCK
         LW,R3    ASTART,R2         GET START ADR OF BLK FOR INDEX REG
GET55    EQU      %
         GET,R13,R4  ALLFLINK,*R3   BLOCK # FORWARD LINK
         BEZ      GET70             NONE EXISTS
         MTW,1    ALLOX
         B        GET40             CONTINUE UNTIL ENTIRE MAP IS IN CORE
*
GET65    EQU      %                 FOR ALLOC MAP STARTING IN CONTROLBLK
         GET,R8,R4  CONTMAPBIAS,*R2  BIAS IN CNTLBLK TO ALLOC MAP
         AW,R8    R2                CALCULATE START ADR OF ALLOC MAP
         STW,R8   ASTART
         LW,R2    R8                INDEX INTO INDEX REG
         GET,R8,R4  ALLBLOCKNAV,*R2  # OF HW'S IN THIS SHORT BLOCK
         SLS,R2   1                 CONVERT TO HW
         AW,R2    R8                CALCULATE HW ADR OF LAST HW IN BLK
         AI,R2    1
         STW,R2   ALASTHW
         LW,R3    ASTART            SET UP REGS TO FIND NEXT ALLOC BLK
         LI,R14   3
         B        GET55             JOIN ROUTINE TO LOAD ENTIRE 'A' MAP
*
GET70    EQU      %
         LW,R2    ASTART            SET UP PTR TO GET FIRST INDEX BLOCK
         SLS,R2   1                 CONVERT TO HALFWORDS
         AI,R2    10                SKIP HDR INFO (5 WORDS)
         STW,R2   ALLOC:HW          SAVE VALUE
         CALL     NEXTIBLK
         CALL     NEXTIKEY
         LI,R6    0
         CALL     NEXTDKEY
         B        ENDGETNEXT        RETURN
*
GET200   EQU      %
         LW,R1    ENTRY:CD
         BEZ      GET202
         LI,R1    ERROR10           ERROR 10: CONTROL BLK NOT OK
         CALL     ADVISE
GET202   EQU      %
         LI,R1    ERROR11           ERROR 11: QUEUE IS EMPTY
         CALL     ADVISE
************************************************************
*
*                 GETNEXT DATA AREA
*
***************************************************************
         USECT    @D
INDEX:CD DATA     0                 # INDEX BLOCKS COUNTDOWN
ENTRY:CD DATA     0                 TOTAL # ENTRIES QUEUED COUNTDOWN
*
ALLOC:HW DATA     0                 HW POINTER TO ALLMAP'S IN ALLOCBLK
ALLOX    DATA     0                 INDEX OF CURRENT ALLOCATION BLOCK
*                                   BEING SEARCHED
ASIZE    EQU      10                SIZE OF PARALLEL ALLOCATION TABLES
*                                   (EXPECTED # OF ALLOCATION BLOCKS)
ASTART   DO1      ASIZE
         DATA     -1
*
ALASTHW  DO1      ASIZE
         DATA     X'FFFFFFF'
*
IKENT:CD DATA     0                 # ENTRIES QUEUED W/ THIS INDEX KEY
A:BLKBIAS DATA    0                 # OF BLOCK ALLOCATED IN FIRST ALLMAP
*
TEMP12   DATA     0                 TO SAVE EXIT ADDRESS **MAKE INTO STK
*
ALLA:MASK DATA    X'00001000'
ALLT:MASK DATA    X'00002000'
ANAV:MASK DATA    X'00000FFF'
*
IKEY#    DATA     0                 INDEX KEY POSITION NUMBER
A:BLKCNT  DATA    0                 BLOCK COUNTER FOR ALLOC MAP
I:HDCNT  EQU      10                10 WORDS IN HEADER FOR INDEX BLK
IKEY:HDCNT  EQU   3                 3 WORDS IN HEADER FOR INDEX KEY
A:HW:HDCNT  EQU   10                10 HW'S IN ALLOC BLK HEADER
IACTKEYS DATA     0                 COUNT OF ACTIVE KEYS IN INDEX BLK
ISUPERMAX  DATA   0                 MAX POSSIBLE # OF KEYS IN INDEX BLK
IKEYMAX  DATA     0                 SIZE OF INDEX KEY INCL HEADER
DATA:DW  DATA     0                 # OF AVAIL. DW'S IN DATABLK
A:HDCNT  EQU      5                 # OF WORDS IN ALLOC BLK HEADER
BLOCKMAX DATA     0
D:MINDW  EQU      1
         USECT    @P
         PAGE
************************************************************************
*
*        NEXTIBLK
*
*        INTERNAL ROUTINE TO FIND THE NEXT SUCCESSIVE INDEX BLOCK IN
*        THE ALLOCATION MAP, READ IT IN, AND SET UP R7 TO POINT TO
*        THE KEY BEFORE THE FIRST KEY (NEXTIKEY WILL INCREMENT IT).
*
*        INPUT: ALLOC:HW = CURRENT POSITION IN ALLOCATION MAP
*               ALLOCATION TABLES ASTART,ALASTHW
*        OUTPUT: R7 POINTS TO PREVIOUS ENTRY (IE, THE NON ENTRY BEFORE
*                THE FIRST ENTRY)
*        ROUTINES CALLED: READBLOCK, DUMPBLOCK
*        REGISTERS USED: R1-R3,R5-R8,R13-R15 ARE DESTROYED OR REINITIALIZED
*        CALLED BY: GETNEXTINIT, NEXTIKEY
*
************************************************************************
*
NEXTIBLK  ENTRY   ' INITIALIZE NEXT ALLOCATED INDEX BLOCK'
         DEBUG    'ENTERING NEXTIBLK'
         LI,R5    0                 REINIT ALL INPUT REGISTERS
         LI,R6    0
         LI,R7    0
         LW,R2    ALLOC:HW
         BLEZ     IBLK25            NO MORE INDEX BLOCKS SIGNAL
*
IBLK10   EQU      %
         LH,R8    0,R2              LOAD NEXT ALLMAP FROM ALLOC. MAP
         AND,R8   ALLA:MASK         IS ALLA SET ?
         BGZ      IBLK50            YES
IBLK20   EQU      %
         AI,R2    1                 INCR ALLOC MAP HW POINTER
         STW,R2   ALLOC:HW
         MTW,1    A:BLKCNT          INCR BLOCK # COUNTER
         LW,R3    ALLOX
         CW,R2    ALASTHW,R3        IS THIS THE END OF THIS ALLOC BLK?
         BG       IBLK23            YES
IBLK21   EQU      %
         CI,R7    0                 WAS NEXT INDEX BLOCK FOUND YET?
         BE       IBLK10            NO  - CONTINUE SEARCH
         DEBUG    'EXITING NEXTIBLK'
         RETURN   NEXTIBLK
IBLK23   EQU      %                 LOOK FOR NEXT ALLOCATION BLOCK
         MTW,1    ALLOX             INCR  INDEX INTO ALLOC TABLES
         AI,R3    1                 INCR REGISTER CONTAINING SAME
         LW,R2    ASTART,R3         PICK UP START OF NEXT ALLOC BLK
         BLEZ     IBLK27            IF NEG, THERE ARE NO MORE 'A' BLKS
         AW,R2    R2                CONVERT TO HALFWORDS
         AI,R2    A:HW:HDCNT        #  HW'S IN ALLOC BLK HEADER
         STW,R2   ALLOC:HW
         B        IBLK21
*
IBLK25   EQU      %
         LI,R5    0                 SET NO MORE ENTRIES IN QUEUE FLAG
         DEBUG    'EXITING NEXTIBLK TO ENDGETNEXT'
         B        ENDGETNEXT        RETURN TO PRIMARY CALLER
IBLK27   EQU      %
         CI,R7    0                 WAS ANOTHER IBLK FOUND
         BE       IBLK25            NO
         STW,R2   ALLOC:HW          SET NO MORE IBLKS FLAG
         DEBUG    'EXITING NEXTIBLK'
         RETURN   NEXTIBLK
*
IBLK50   EQU      %
         LH,R8    0,R2              RELOAD ALLMAP
         AND,R8   ALLT:MASK         IS ALLT SET (ALLT=1 FOR DATABLOCK)
         BGZ      IBLK20            YES - CONTINUE SEARCH FOR INDEX BLK
         LW,R13   A:BLKCNT          THIS BLOCK'S A WINNER
         LI,R14   4
         CALL     READBLOCK
         CALL     DUMPBLOCK
         MTW,-1   INDEX:CD          COUNT DOWN TOTAL # INDEX BLOCKS
         BGEZ     IBLK55
         LI,R1    ERROR12           ERROR 12: CONTROL BLOCK INVALID
         CALL     ADVISE
IBLK55   EQU      %
*                 FIND ALLOC MAP VALUE FOR # OF INDEX KEYS IN USE
         LH,R8    0,R2              RELOAD ALLMAP
         AND,R8   ANAV:MASK         MASK OFF BIT FLAGS
         LI,R7    INDEXBLK          INIT INDEX REGISTER
         C,R8,R1  INDEXKEYS,*R7     SHOULD BE THE SAME
         BE       IBLK60            OK
         LI,R1    ERROR13           ERROR 13: ALLOCATION BLOCK INVALID
         CALL     ADVISE
IBLK60   EQU      %
         AI,R7    I:HDCNT           MANIPULATE R7 TO POINT TO PHONY
         SW,R7    IKEYMAX           SUBTRACT KEY MAX
*            FIRST KEY HAS DATAENTRY# = 1, NOT 0
*                 BECAUSE NEXTIKEY WILL INCREMENT IKEY# WHEN IT FINDS
*                 THE FIRST KEY, INIT IKEY# TO 0
         LI,R3    0
         STW,R3   IKEY#
         STW,R3   IACTKEYS
         B        IBLK20            INCR ALLOC BLK PTRS AND EXIT
*
         PAGE
***********************************************************************
*
*        NEXTIKEY
*
*        INTERNAL ROUTINE TO FIND NEXT ACTIVE ENTRY IN INDEX BLK.
*
*        INPUT: R7 POINTS TO PREVIOUS ACTIVE KEY
*               INDEX BLOCK WHICH CONTAINS KEYS
*               R12 = RETURN ADDRESS
*        OUTPUT: R7 POINTS TO NEW KEY
*                R5 = 1 FOR TRANSACTION
*                   = 2 FOR REPORT
*                ENTRY NUMBER (IKEY#) IS INCREMENTED
*                # ENTRIES QUEUED THIS KEY (IKENT:CD) IS INITIALIZED
*        ROUTINES CALLED: NEXTIBLK
*        REGISTERS USED: R0-R4 ARE DESTROYED; R5 IS REINITIALIZED
*        CALLED BY: NEXTDKEY, GETNEXTINIT
************************************************************************
*
NEXTIKEY    ENTRY     'UPDATE R7 TO POINT TO NEXT ACTIVE INDEX KEY'
         DEBUG    'ENTERING NEXTIKEY'
*
*
*
         LI,R4    INDEXBLK
         GET,R2,R5  INDEXKEYS,*R4   GET ACTIVE KEYS
         CW,R2    IACTKEYS          COMPARE W/ ACTIVE KEYS FOUND
         BLE      IKEY40            YES - GET NEW INDEX BLOCK
IKEY10   EQU      %
         AW,R7    IKEYMAX           INCREMENT TO NEXT KEY
         MTW,1    IKEY#             INCR KEY POSITION #
         LW,R2    IKEY#             HAS END OF BLOCK BEEN REACHED
         CW,R2    ISUPERMAX         KEYS FOUND :: KEYS POSSIBLE
         BG       IKEY50
         T,R0,R4  INDEXFR,*R7       IS KEY ACTIVE ?
         BEZ      IKEY10            NO
         MTW,1    IACTKEYS
*                 DETERMINE WHETHER KEY IS TRANSACTION OR REPORT
         GET,R4,R2  INDEXTYPER,*R7  GET  TYPE BYTE
         CI,R4    C'?'               ? INDICATES A TRANSACTION
         BNE      IKEY20            ERGO, A REPORT
         LI,R5    1                 TRANS = 1
         B        IKEY30
IKEY20   EQU      %
         LI,R5    2                 REPORT OR WHATEVER = 2
IKEY30   EQU      %
         GET,R2,R4 INDEXCOUNTR,*R7  # ENTRIES QUEUED THIS NAME
         STW,R2   IKENT:CD          SAVE FOR COUNTDOWN
         DEBUG    'EXITING NEXTIKEY'
         RETURN   NEXTIKEY
IKEY40   EQU      %
         CALL     NEXTIBLK
         B        IKEY10            CONTINUE
IKEY50   EQU      %
         LI,R1    ERROR20           UNABLE TO FIND EXPECTED ACTIVE ENTTRY IN INDEX BLK
         CALL     ADVISE
         PAGE
************************************************************************
*
*        NEXTDKEY
*
*        INTERNAL ROUTINE TO FIND NEXT ACTIVE ENTRY IN DATA BLOCK
*
*        INPUT: R6=0 FOR INITIALIZATION
*                 = PREVIOUS ENTRY IN DATA BLOCK OTHERWISE
*               R7= CURRENT ENTRY IN INDEX BLOCK
*        OUTPUT: R6= ADR OF NEW ENTRY IN DATA BLOCK
*        ROUTINES CALLED: NEXTIKEY, READBLOCK, PRINTREC (IN DEBUG MODE),
*                 ADVISE, FINDMAP
*        REGISTERS: ALL EXCEPT R5 AND R7 ARE DESTROYED
*        CALLED BY: GETNEXT, GETNEXTINIT
*
************************************************************************
*
NEXTDKEY    ENTRY     'UPDATE R6 TO POINT TO NEXT DATA KEY'
         DEBUG    'ENTERING NEXTDKEY'
         CI,R6    0                 INITIALIZATION ?
         BE       NEXTDBLK          YES
         GET,R2,R4 DATAFLINKR,*R6   IS THERE ANOTHER ENTRY ?
         BEZ      DKEY10            NO
         LI,R1    DATABLK
         C,R2,R4   DATABLOCK,*R1    IS NEXT ENTRY IN THIS BLOCK ?
         BE       DKEY100           YES
         LW,R13   R2                SET UP R13 FOR READBLOCK CALL
         B        DKEY30            NO
DKEY10   EQU      %
         MTW,0    IKENT:CD          END OF ENTRIES QUEUED THIS INDEX KEY
         BEZ      DKEY15            YES - OK
         LI,R1    ERROR14           ERROR 14: NOT ALL EXPECTED DATA
*                                    ITEMS WERE FOUND - INDEX BLK BAD
         CALL     ADVISE
DKEY15   EQU      %
         CALL     NEXTIKEY
         LI,R1    DATABLK
         GET,R2,R4  DATABLOCK,*R1
         C,R2,R4   INDEXHTXT,*R7    NEED TO INPUT NEW DATA BLOCK ?
         BNE      NEXTDBLK          YES
         B        DKEY40            NO
*
NEXTDBLK EQU      %
         GET,R13,R4  INDEXHTXTR,*R7   GET BLOCK # OF NEW DATA BLOCK
DKEY30   EQU      %
         LI,R14   5                 DATA BLOCK TYPE
         CALL     READBLOCK
         CALL     FINDMAP
*                 CHECK FOR 'EMPTY' DATA BLOCK
         LI,R4    D:MINDW           GET MINIMUM POSSIBLE DW'S USED
         CW,R4    DATA:DW           CHK WITH VALUE FROM ALLOC MAP
         BLE      DKEY40            OK
         LI,R1    ERROR1F           SEARCHING EMPTY DATABLK
         CALL     ADVISE
DKEY40   EQU      %
         LI,R6    WA(DATABLK)+D:HDCNT DATA HDR = 2 WORDS
DKEY50   EQU      %
         GET,R2,R4  DATAENTRY#R,*R6  GET INDEX KEY POSITION
         CW,R2    IKEY#              IS IT EQUAL TO CALCULATED VALUE?
         BNE      DKEY100           NO
         GET,R2,R4  DATAINDEXR,*R6   GET INDEX BLOCK #
         LI,R3    INDEXBLK
         C,R2,R4  INDEXBLOCK,*R3     IS IT THE RIGHT BLOCK # ?
         BNE      DKEY100           NO
         MTW,0    LISTOPTION
         BEZ      GETNOPRINT
         LI,R3    -1
         PUSH     1,R5
         CALL     PRINTREC
         PULL     1,R5
GETNOPRINT   EQU   %
         MTW,-1   IKENT:CD          COUNTDOWN # ENTRIES THIS KEY
         BGEZ     DKEY60
         LI,R1    ERROR15           ERROR 15: INDEX BLOCK INVALID - NOT
*                                   ENOUGH DATA ENTRIES INDICATED
         CALL     ADVISE
DKEY60   EQU      %
         MTW,-1   ENTRY:CD          COUNTDOWN TOTAL # OF ENTRIES
         BLZ      DKEY65
         DEBUG    'EXITING NEXTDKEY'
         RETURN   NEXTDKEY
DKEY65   EQU      %
         LI,R1    ERROR17           ERROR: # OF DATA ENTRIES FOUND
*                                   EXCEEDS NUMBER ANTICIPATED
*                                   CONTROL BLOCK INVALID
         CALL     ADVISE
DKEY100  EQU      %                 INCR R6 TO NEXT KEY
         LI,R0    0
         GET,R2,R4  DATANAMECNTR,*R6 MUST USE EVEN REG FOR GET
         AI,R2    1                 ADD 1 FOR BYTE COUNT BYTE
*                 SKIP DATA NAME
DKEY101  EQU      %
         LI,R3    0                  TRANSFER DIVIDEND TO ODD
         XW,R2    R3
         LI,R4    4
         DW,R2    R4                DIVIDE BYTE CNT BY 4
         AW,R6    R3                ADD QUOTIENT TO INDEX
         CI,R2    0                 ANY REMAINDER ?
         BLE      DKEY102           NO
         AI,R6    1                 FORCE WORD BOUNDARY ON REMAINDER
DKEY102  EQU      %
*                 SKIP DATA TEXT
         CI,R0    0                 2ND TIME THROUGH?
         BG       DKEY105           YES
         AI,R6    2                 ACCOUNT FOR ENTRY HDR
         LH,R2    *R6               GET BYTE COUNT OF TEXT
         AI,R2    2                 ACCOUNT FOR 2 BYTES IN HW COUNT
         LI,R0    1                 SET SENTINEL
         B        DKEY101
DKEY105  EQU      %                 FORCE DW BOUNDARY
         AI,R6    1
         SLS,R6   -1
*                                   CK TO SEE IF BEYOND END OF BLOCK
         LW,R4    R6
         AI,R4    -DA(DATABLK)      GET # OF DW'S USED
         CW,R4    DATA:DW           GET # AVAIL DW'S FROM ALLOCATN MAP
         BLE      DKEY110           COMPARE OK
         LI,R1    ERROR16
*                                   ERROR 16: # AVAIL DW'S IN ALLOCATION
*                                   MAP DOESN'T COMPARE W/ DATABLOCK
         CALL     ADVISE
DKEY110  EQU      %                 R6 BACK TO WORD BOUNDARY
         SLS,R6   1
         B        DKEY50
*
D:HDCNT  EQU      2
         TITLE    '*** LISTQIP ** VERSION 0 ** SERVICE ROUTINES'
*******************************************************************
*
*                 ADVISE
*
*
*        INTERNAL ROUTINE TO PRINT OUT ERROR MESSAGE FROM
*        MESSAGE LIST AND ABORT JOB
*
*        INPUT: R1=START OF ERROR MESSAGE
*        OUTPUT: ERROR MESSAGE IS WRITTEN TO OPERATOR'S CONSOLE
*                 AND TO M:LO
*        REGISTERS USED: R3 AND R4 ARE DESTROYED
*        CALLED BY: LISTQIP, GETNEXT, NEXTIBLK, NEXTIKEY,
*                   NEXTDKEY, IPLISTWRT, READBLOCK
***********************************************************************************
ADVISE    ENTRY    'PRINT ERROR MESSAGE AND ABORT JOB'
         DEBUG    'ENTERING ADVISE'
         PUSH     5,R1
         LB,R4    *R1               GET BYTE COUNT OF MESSAGE
         CI,R4    60                MAX # OF CHARS PER TY LINE
         BLE      TYPE%OUT          OK AS IS
*                 PRINT MESSAGE IN TWO PARTS
         LI,R4    X'3C'
FIND%BLANK   EQU  %
         LB,R5    R1,R4             LOOK AT BYTE 0 CHARACTER
         CI,R5    C' '              IS IT BLANK
         BE       TYPE%ONE
         AI,R4    -1                KEEP LOOKING
         B        FIND%BLANK
*                 PRINT FIRST PART OF MESSAGE
TYPE%ONE   EQU    %
         LB,R5    *R1               SAVE PREVIOUS COUNT
         STB,R4   *R1               INIT NEW COUNT
         M:TYPE   (MESS,*R1)        TYPE FIRST PART
         STB,R5   *R1               REINIT COUNT TO ORIG VALUE
         SLS,R4   2                 CONVERT TO WORD CNT
         LW,R2    R1                GET NEW POINTER
         AW,R2    R4                POINT TO NEXT PART OF MESSAGE TO PRINT
         LCW,R4   R4                GET NEGATIVE VALUE
         AW,R5    R4                NEW COUNT
         STB,R5   *R2
         M:TYPE   (MESS,*R2)
*                 RESTABLISH ERROR MESSAGE FOR M:WRITE
         LI,R4    C' '
         STB,R4   *R2
         B        WRITE%OUT
TYPE%OUT EQU      %
         M:TYPE   (MESS,*R1)        REPORT TO OPERATOR
WRITE%OUT   EQU   %
         LI,R3    C' '              GET RID OF BYTE CNT
         LB,R4    *R1               GET BYTE CNT OF MESSAGE
         AI,R4    1                 PLUS 1 FOR BYTE CNT TURNED BLANK
         STB,R3   *R1               CHANGE TEXTC TO TEXT
         M:WRITE  M:LO,(BUF,*R1),(SIZE,*R4)
         PULL     5,R1              RESTORE REGISTERS
         M:XXX
         RETURN   ADVISE            (NOT NEEDED - INCLUDED FOR AESTHETICS)
*
*****************************************************************
         PAGE
*******************************************************************
*
*                 DUMPBLOCK
*
*        LIST OUT INDICATED BLOCK IF IN DEBUG MODE
*
*        INPUT: LISTOPTION= GREATER THAN 0 IF DEBUG OPTION IS SPECIFIED
*                 EITHER BY DBGKEY ASSEMBLY PARAMETER OR BY CARD INPUT
*               R14=BLOCK TYPE (SAME AS FOR READBLOCK)
*                 R15=STARTING ADDRESS OF BUFFER TO BE OUTPUT
*        OUTPUT: TITLE OF BLOCK AND M:SNAP OF FIRST 40 WORDS
*        REGISTERS: R2,R14,R15 ARE USED BUT NOT DESTROYED
*                   R1 IS DESTROYED
*        CALLED BY: GETNEXTINIT, GETNEXT, LISTQIP, NEXTIBLK,
*                 NEXTDKEY
********************************************************************
DUMPBLOCK    ENTRY   'DUMP BLOCK IF IN DEBUG MODE'
         DEBUG    'ENTERING DUMPBLOCK'
         PUSH     1,R2
         MTW,0    LISTOPTION        DEBUG MODE?
         BEZ      DUMP11            CHK ON DBGKEY, TOO
DUMP1    EQU      %
         DO       DBGKEY=0
         CI,R14   4                 DUMP ALLOCATION BLOCK?
         BG       DUMP11            NO
         FIN
DUMP5    EQU      %
         LW,R2    R14               MOVE TO INDEX REG
         LW,R1    MESFILE,R2        GET APPROPRIATE MESSAGE
         M:WRITE   M:DO,(BUF,*R1),(SIZE,MESFILESZ)
         STW,R15  DUMPFPT+1
         AI,R15   512
         STW,R15  DUMPFPT+2
         AI,R15   -512
,DUMPFPT   ;
         M:SNAP   '  ',(*R15,*R15+40)
DUMP11    EQU     %
         DEBUG    'EXITING DUMPBLOCK'
         PULL     1,R2
         RETURN   DUMPBLOCK
DUMPA    TEXT     ' *** CONTROL  BLOCK *** '
DUMPB    TEXT     ' * INDEXCONTROL  BLOCK *'
DUMPC    TEXT     ' ** ALLOCATION BLOCK ** '
DUMPD    TEXT     ' **** INDEX  BLOCK **** '
DUMPE    TEXT     ' ***** DATA  BLOCK *****'
MESFILESZ    EQU  24
*
MESFILE  EQU      %-1
         DATA     WA(DUMPA)
         DATA     WA(DUMPB)
         DATA     WA(DUMPC)
         DATA     WA(DUMPD)
         DATA     WA(DUMPE)
*********************************************************************
         PAGE
**********************************************************************
*
*                 FINDMAP
*
*        FIND ALLOCATION MAP ENTRY ASSOCIATED WITH DATA BLOCK
*        INPUT: R13=RELATIVE BLOCK NUMBER OF DATA BLOCK
*        OUTPUT: DATA:DW=NUMBER OF DOUBLEWORDS IN USE IN A GIVEN DATA
*                 BLOCK (INCLUDING BOTH BLOCK HEADER AND ENTRIES).
*                 NOTE THAT INFORMATION IN A DATA BLOCK IS CLOSE-
*                 PACKED IN THE BLOCK>
*        REGISTERS: R1-R4,R13-R14 ARE DESTROYED
*        CALLED BY: NEXTDKEY
*
*********************************************************************
FINDMAP    ENTRY    'FIND ALLOCATION MAP ENTRY FOR DATABLOCK'
         DEBUG    'ENTERING FINDMAP'
         SW,R13   A:BLKBIAS         REMOVE BIAS OF FIRST ENTRY
         LW,R14   R13               SAVE BLOCK NUMBER
         LI,R4    0                 INDEX REG TO START OF ALLOC MAP
FINDMAP10  EQU    %
         LW,R3    ASTART,R4         PICK UP BEGINNING OF BLOCK
         GET,R2,R6   ALLBLOCKNAV,*R3    # BLOCKS REPRESENTED BY THIS MAP
         SW,R13   R2                FIND OUT IF THIS BLK  HAS GIVEN BLK ALLOC ENTRY
         BLEZ     FINDMAP20         YES
         LW,R14   R13               SAVE NEW DISPLACEMENT
         AI,R4    1                 INCR INDEX TO LOOK AT NEXT MAP
         B        FINDMAP10
FINDMAP20  EQU    %
         SLS,R3   1                 CONVERT TO HW
         AI,R3    A:HW:HDCNT        HEADER FOR ALLOC BLOCK
         AW,R3    R14               DISPL INTO MAP
         LH,R2    0,R3              GET MAP ENTRY
         AND,R2   ANAV:MASK         GET RID OF ALLOCATION BITS
         STW,R2   DATA:DW           SAVE AVAIL # OF DW'S FOR LATER
         DEBUG    'EXITING FINDMAP'
         RETURN   FINDMAP
*****************************************************************
         PAGE
************************************************************************
*                                                                      *
*                 READBLOCK                                            *
*                                                                      *
*                 AN INTERNAL ROUTINE TO READ A SPECIFIED BLOCK OUT    *
*                 OF THE QUEUE FILE AND PUT IT IN THE APPROPRIATE      *
*                 BUFFER                                               *
*                                                                      *
*                 INPUT: R13 = RELATIVE BLOCK NUMBER
*                        R14 = BLOCK TYPE                              *
*                               1 FOR CONTROL                          *
*                               2 FOR INDEX CONTROL                    *
*                               3 FOR ALLOCATION                       *
*                               4 FOR INDEX                            *
*                               5 FOR DATA                             *
*                 OUTPUT: INPUT REGISTERS SAME                         *
*                        R15 = BUFFER ADDRESS                          *
*                 REGISTERS  USED: R1 IS DESTROYED                     *
*                 SUBROUTINES CALLED: ADVISE                           *
*                 CALLED BY: GETNEXTINIT, NEXTIBLK, NEXTDKEY           *
*                                                                      *
************************************************************************
*                                                                      *
READBLOCK   ENTRY    'READ SPECIFIED BLOCK INTO CORRECT BUFFER'
         DEBUG    'ENTERING READBLOCK'
*                 CHECK VALIDTY OF BLOCK NUMBER IN R13
         CI,R13   0
         BL       RBLK70
         CW,R13   BLOCKMAX
         BG       RBLK70
         CI,R14   3                 ALLOCATION BLOCK TYPE
         BNE      RBLK40            NO
*
*                 ALLOCATION BLOCK
*                                   BUFFER ADDR IS IN ASTART(ALLOX)
         LW,R1    ALLOX
         LW,R15   ASTART,R1         INIT BUFFER ADDR
         B        RBLK60
RBLK40   EQU      %
         LW,R1    R14               INDEX TO INDEX REGISTER
         LW,R15   TYPE,R1           LOAD BUFFER ADDRESS
*
RBLK60   EQU      %
         M:READ   F:QUEUE,(BUF,*R15),(BLOCK,*R13),(ERR,QERR),(ABN,QABN);
                  ,(SIZE,2048)
         DEBUG    'EXITING READBLOCK'
         RETURN   READBLOCK
*
*
QABN     EQU      %
         LI,R1    ERROR19           ERROR: ABN ENCOUNTERED ON READING QUEUE
         CALL     ADVISE
*
QERR     EQU      %
         LI,R1    ERROR1A           ERROR: ERR ON READING QUEUE
         CALL     ADVISE
RBLK70   EQU      %
         LI,R1    ERROR1E           ERROR: BLOCK # OUT OF RANGE OF FILE
         CALL     ADVISE
*
TYPE     EQU      %-1               NO TYPE(0)
         DATA     WA(CONTROLBLK)
         DATA     WA(INXCONTROLBLK)
         DATA     0                 NO ALLOCATION BLK ADDR VIA TYPE
         DATA     WA(INDEXBLK)
         DATA     WA(DATABLK)
*
*
         PAGE
************************************************************************
*
*                           C O N V E R T I D
*
*        CONVERT A HEXADECIMAL ID TO EBCDIC FOR PRINT OUT
*                 THIS ROUTINE SUPPLIED BY TED MARTNER
*
*        INPUT:  R13=ID IN HEXADECIMAL
*        OUTPUT: R14 AND R15 CONTAIN THE TRAN ID IN EBCDIC
*        ENTRY POINT:  CONVERTID
*        SUBROUTINES USED:  NONE
*        REGISTERS DESTROYED:  NONE
*        CALLED BY: LISTQIP, IPLISTWRT, MOVEDKEY, EBCDICCNT, GETNEXT
*
*********************************************************************
CONVERTID   ENTRY   'CONVERT CONTENTS OF R13 INTO AN';
                  ,' EBCDIC VALUE IN R14 AND R15'
         DEBUG    'ENTERING CONVERTID'
         PUSH     1,R12
         LI,R14   0                 INITIALIZE REGISTERS
         LI,R15   0
CONVERTID%1  EQU  %
         LI,R12   '0'**-4           CONVERT 1 DIGIT TO EBCDIC
         SLD,R12  +4
         CI,R12   '9'               WAS IT CONVERTED OK?
         BLE      CONVERTID%2       YES
         AI,R12   'A'-'9'-1         NO ADJUST IT
CONVERTID%2  EQU  %
         SLD,R14  8
         OR,R15   R12
         BNOV     CONVERTID%1       OV SET BY SLD WHEN DONE
         PULL     1,R12
         DEBUG    'EXITING CONVERTID'
         RETURN   CONVERTID
*
************************************************************************
         PAGE
************************************************************************
*
*                           Q U E U E G E T
*
*        REQUESTS IN PROGRESS ITEMS FROM THE SYSTEM QUEUE MANAGER
*
*
*        INPUT:  R6=POINTER TO KEY IN DATA BLOCK
*                R7=POINTER TO KEY IN INDEX BLOCK (KEY IS IN TEXTC
*                   FORMAT)
*        OUTPUT: NEW ENTRY IN TPBUF
*                ENTRY LENGTH IN TPBUFLEN
*        SUBROUTINES USED:
*        REGISTERS USED: R6 AND R7 ARE NOT CHANGED
*                 R4 AND R5 ARE USED BUT NOT DESTROYED
*                 R3 IS DESTROYED
*        CALLED BY: LISTQIP
************************************************************************
QUEUEGET   ENTRY   'REQUEST IN PROGRESS ITEM FROM';
                  ,' SYSTEM QUEUE MANAGER'
         DEBUG    ' ENTERING QUEUEGET'
         PUSH     2,R4
*                 BUILD CRITERIA
*                 MOVE FIRST PART OF KEY WHICH IS IN INDEX BLOCK
         LI,R5    BA(DEFCRIT)       SET UP DESTINATION ADR FOR MBS
         LI,R3    12
         LB,R4    *R7,R3            GET BYTE COUNT OF KEY
         STB,R4   R5                INITIALIZE STRING COUNT FOR MBS
         STW,R4   NAMLEN            KEEP COUNT
         LW,R4    R7                INIT SOURCE ADDRESS FOR MBS
         AI,R4    3                 SKIP INDEX KEY HEADER
         SLS,R4   2                 CONVERT TO BYTE ADR
         MBS,R4   1                 MOVE SOURCE TO DEST; SKIP TEXTC CNT
*                 LEAVE DESTINATION INTACT  TO MOVE  REST  OF KEY FROM
*                 DATA BLOCK
         LI,R3    8
         LB,R4    *R6,R3            GET TEXTC COUNT OF NID
         STB,R4   R5                INIT STRING CNT
         AW,R4    NAMLEN            KEEP COUNT CURRENT
         STW,R4   NAMLEN
*                 INSERT PERIOD BETWEEN IKEY AND DKEY
         LI,R4    C'.'
         STB,R4   0,R5              INSERT INTO DEFCRIT
         MTW,1    R5                INCREMENT BYTE COUNTER
         MTW,1    NAMLEN            INCREMENT BYTE CNT FOR C'.'
         LW,R4    R6                INIT SOURCE ADR
         AI,R4    2                 SKIP DATA KEY HEADER
         SLS,R4   2                 CONVERT TO BYTE ADDR
         MBS,R4   1                 MOVE REST OF KEY TO CRITERIA BLOCK
*                                   IN TEXT FORMAT
         LW,R4    NAMLEN
         STB,R4   DEFLEN            INIT DEFINELIST
*                 R5 POINTS  TO  BYTE LOC  IN  DEST OF FLAGBYTE
         LB,R4    FLAGBYTE          PRE-DETERMINED CRITERIA STATUS FLAG
         STB,R4   0,R5              SET UP FLAG FOR DEFINELIST
         DEBUG    ' DEFINELIST'
         DO       DBGKEY=1
         M:SNAP   '    ',(NAMLEN,DEFCRIT+32)
         FIN
*                 SEND  CRITERIA TO QUEUE MANAGER
*                 WAIT ON RESPONSE VIA ECB  MECHANISM
         M:QUEUE  DEFLEN,DEFINELIST,(LSIZE,1);
                  ,(WAIT)
         BCR,12   NEXTCAL           B IF ALL IS OK
         M:SNAP   'CHK 10'
         LI,R1    ERROR28
         CALL     ADVISE
*
*                 UPON RETURN FROM QUEUE MANAGER, REQUEST ENTRY TO
*                 BE TRANSFERRED TO BUFFER
NEXTCAL  EQU      %
         STW,R8   SAVE%LIST%ID
          M:QUEUE     *R8,GET,(BUF,TPBUF),(BSIZE,TPBUFWDS);
                  ,(WAIT)
         BCR,12   GETOK
         M:SNAP   'CHK 10'
         LI,R1    ERROR29
         CALL     ADVISE
GETOK    EQU      %
         M:QUEUE  *SAVE%LIST%ID,PURGE,(WAIT)
         DEBUG    ' BUFFER AFTER QUEUEGET'
         DO1      DBGKEY=1
         M:SNAP   '  ',(TPBUF,TPBUF+20)
*
*                 RETURN TO CALLER
*
         DEBUG    ' EXITING QUEUEGET'
         LI,R4    TPBUF             INIT INDEX REGISTER
         GET,R8,R5  JLEN,*R4        GET RECORD LENGTH
         AI,R8    4                 INCLUDE CKSUM WORD IN RECORD
         STW,R8   TPBUFLEN
         PULL     2,R4
         RETURN   QUEUEGET
*
**************** QUEUEGET DATA AREA ******************************
         USECT    @D
FLAGBYTE DATA,1   X'10'             REQUEST IN PROGRESS ENTRY
         BOUND    4
NAMLEN   DATA     0
DEFLEN   GEN,8,24 0,BA(DEFCRIT)     DEFINELIST :
*                                     1 BYTE FOR LENGTH OF NAME
*                                     3 BYTES FOR BUFFER ADR OF NAME
DEFCRIT  RES      32
*
         PAGE
*****************************************************************
*
*                 ERROR  TABLES
*
**************************************************************************
ERRMES   EQU      %
ERROR10  TEXTC    'CONTROL BLOCK NOT SAVED BY RECOVERY (NO TID)'
ERROR11  TEXTC    'THE QUEUE IS EMPTY'
ERROR12  TEXTC    'THE TOTAL # OF INDEX BLKS EXPECTED IS LESS ';
                  ,'THAN THE TOTAL NUMBER FOUND. INVALID CONTROL BLK'
ERROR13  TEXTC    '# OF ACTIVE INDEX KEYS IN INDEX BLK IS NOT';
                  ,' EQUAL TO EXPECTED # IN ALLOCATION MAP';
                  ,'INVALID ALLOCATION MAP'
ERROR14  TEXTC    'NOT ALL EXPECTED DATA ENTRIES WERE FOUND FOR ';
                  ,' CURRENT INDEX KEY. INVALID INDEX BLOCK'
ERROR15  TEXTC    'MORE THEN EXPECTED # OF DATA ENTRIES WERE';
                  ,' FOUND FOR CURRENT INDEX KEY. INVALID INDEX BLOCK'
ERROR16  TEXTC    '# AVAIL DWS FOR DATA BLOCK IN ALLOCATION';
                  ,' MAP DOES NOT EQUAL CALCULATED #.';
                  ,' INVALID ALLOCATION BLOCK'
ERROR17  TEXTC    'TOTAL # OF DATA ENTRIES FOUND EXCEEDS #';
                  ,' ANTICIPATED. INVALID CONTROL BLOCK'
ERROR18  TEXTC    ' NOT ALL ANTICIPATED DATA ENTRIES WERE FOUND. ';
                  ,' INVALID CONTROL BLOCK'
ERROR19  TEXTC    'ABN ENCOUNTERED ON READING QUEUE'
ERROR1A  TEXTC    'ERROR ENCOUNTERED ON READING QUEUE'
ERROR1B  TEXTC    'NOT ALL INDEX BLOCKS WERE FOUND.';
                  ,'INVALID CONTROL BLOCK.'
ERROR1C  TEXTC    'ERROR WHILE TRYING TO OPEN QUEUE'
ERROR1D  TEXTC    'ABNORMAL WHILE TRYING TO OPEN QUEUE'
ERROR1E  TEXTC    'BLOCK NUMBER OUT OF RANGE OF FILE IN READBLOCK'
ERROR1F  TEXTC    'SEARCHING EMPTY DATA BLOCK FOR ENTRY ';
                  ,'INVALID ALLOCATION BLK'
ERROR20  TEXTC    'UNABLE TO FIND EXPECTED ACTIVE ENTRY IN INDEX BLOCK';
                  ,' INVALID ALLOCATION BLOCK'
ERROR21  TEXTC    'UNKNOWN CODE SENT TO IPLISTWRT IN R5'
ERROR22  TEXTC    'WRITE ERROR ON F:IPLIST'
ERROR23  TEXTC    'READ ERROR ON TPFILES * RESTORE TPFILES BEFORE';
                  ,' RERUNNING JOB'
ERROR24  TEXTC    'TPFILES MISSING * PLEASE RESTORE THIS FILE'
ERROR25  TEXTC    'UNEXPECTED ABNORMAL ON TPFILES'
ERROR26  TEXTC    'UNEXPECTED ABNORMAL ON F:IPLIST'
ERROR27  TEXTC    'LISTQIP ABORTED BY OPERATOR'
ERROR28  TEXTC    'QUEUE MANAGER REJECTS DEFINE LIST '
ERROR29  TEXTC    'QUEUE MANAGER REJECTS GET REQUEST'
ERROR30  TEXTC    'QUEUE MANAGER REJECTED REQUEST TO UNLOCK QUEUE'
ERROR31  TEXTC    'UNEXPECTED WRITE ERROR ON TPFILES'
ERROR32  TEXTC    'UNEXPECTED WRITE ABNORMAL ON TPFILES'
ERROR33  TEXTC    'UNEXPECTED OPEN UPDATE ERROR ON TPFILES'
ERROR34  TEXTC    'UNEXPECTED OPEN UPDATE ABNORMAL ON TPFILES'
PATCH    RES      20
         END      LISTQIP

