C SUBROUTINE FILERD C C C SUBROUTINE FILERD LOCATES RT - 11 FILE WITH EXTENSION AEXT C COLLECTION FILES ON DISK DRIVES SY0: AND SY1: C C C C C NB THE DIRECTORY STARTS FROM BLOCK 7 AND THE ARE 36 C ENTERIES IN EACH 'PAIR' OF DIRECTORY BLOCKS . C C TO EXAMINE THE DIRECTORY USE R DUMP C I.E. T1:=DK1:/S:6/X/N C C C SUBROUTINE FILERD(FILSPC,AEXT) COMMON /DDIP/ITTY,ISTAT INTEGER REXT,NAMES(4,101),IIDISK(4) INTEGER FILSPC(39) REAL*8 IDISK(2) DIMENSION IB(512),NFILES(2,100) LOGICAL*1 YDATA,NDATA,AEXT(4),IBYTES(512),IBUFF(100),ANS(2) LOGICAL*1 DSKSPC(12),LDISK(20),LBYT(12) EQUIVALENCE (IB,IBYTES,IBUFF) EQUIVALENCE(IDISK(1),DSKSPC(1)),(IIDISK,IDISK(2)) DATA NDATA/'N'/,YDATA/'Y'/ DATA DSKSPC/'S','Y',' ',' ',' ',' ',' ',' ',' ',' ',' ',' '/ C C CONVERT EXTENSION TO RAD50 C IR = IRAD50(3,AEXT,REXT) C C INITIALISE FILSPC TO NO SPEC LOADED C FILSPC(16) = 0 C C C SET UP POINTERS C ITTY = 7 102 NNNCNT = 0 LCNT = 1 NCNT = 1 D CALL RCTRLO WRITE(7,100) 100 FORMAT('$ENTER SY DRIVE NOS. STUDIES OR RETURN TO ENTER FILSPC ') READ(5,101)(LDISK(L),L=1,20) 101 FORMAT(20A1) TYPE * IF (LDISK(1).EQ.'-'.OR.LDISK(1).EQ.' ') RETURN !ENTER FILE SPEC LLL = 1 105 DO 114 I = LLL,20 C C IGNORE SPACES AND COMMAS C IF (LDISK(I).NE."40.AND.LDISK(I).NE."54) GOTO 115 114 CONTINUE GOTO 7 115 IF (LDISK(I).LT."60.OR.LDISK(I).GT."70) GOTO 102 DSKSPC(3) = LDISK(I) LLL = I + 1 CALL IRAD50(12,DSKSPC,IDISK(2)) ICHAN = IGETC(IGC) IF (ICHAN.LT.0) STOP 'NO CHANNEL AVAILABLE ' IF (IFETCH(IDISK(2)).NE.0) STOP 'BAD FETCH ' IF (LOOKUP(ICHAN,IDISK(2)).LT.0) STOP 'BAD LOOKUP ' C C OBTAIN NUMBER OF DISK BLOCKS IN DIRECTORY C IV = 6 CALL READW (256,IB,IV,ICHAN) IBLK = IB(3) ICNT = 6 LINK = 1 C C C C THE DIRECTORY IS STRUCTURED IN SEGMENTS AND ARE LINKED C BY THE 2 WORD OF THE FIRST BLOCK OF THE SEGMENT. EACH SEGMENT C IS 2 BLOCKS LONG OR 512 WORDS WHICH CAN HOLD UP C TO 72 FILE NAMES . C C THE ABSOLUTE DISK BLOCK NUMBER WHERE STUDY STARTS AND THE C CHANNEL ASSIGNED TO THE DISK ARE STORED IN COMMON AREA /FILES/ C C DO 2 I = 1,IBLK C C CALCULATE BLOCK ADDRESS OF NEXT SEGMENT C IV = (LINK*2 - 2) + 6 CALL READW (512,IB,IV,ICHAN) IBLKCT = IB (5) LINK = IB(2) DO 4 M = 1,72 C C CHECK FOR END OF SEGMENT C IF (IB(ICNT).EQ.2048) GOTO 2 C C CHECK IF PERMANENT FILE ?? C IF (IB(ICNT).NE.1024) GOTO 5 IBB = IB(ICNT + 3) C C CHECK IF RT - 11 FILE C IF (IBB.NE.REXT) GOTO 5 C C STORE ABSOLUTE DISK BLOCK NUMBER FOR STUDY AND CHANNEL FOR DISK C 12 NFILES(1,LCNT) = IBLKCT NFILES(2,LCNT) = ICHAN C C CREATE FILE SPEC FOR EACH FILE C NAMES(1,LCNT) = IIDISK(1) !STORE DISK NAMES(2,LCNT) = IB(ICNT+1) NAMES(3,LCNT) = IB(ICNT+2) NAMES(4,LCNT) = REXT LCNT = LCNT + 1 IF (LCNT.EQ.101) GOTO 17 5 IBLKCT = IBLKCT + IB (ICNT + 4) 4 ICNT = ICNT + 7 2 ICNT = 6 C C REARRANGE FILES TO BE IN THE SAME ORDER AS GAMMA PRINTS THEM C 17 LCNT = LCNT - 1 IF (NCNT.NE.LCNT+1) GOTO 18 WRITE(7,300)(AEXT(I),I=1,4),LDISK(LLL-1) REWIND 7 300 FORMAT('0THERE ARE NO ',4A1,' STUDIES ON SY: DISK ',A1) GOTO 9 18 NNCNT = NNNCNT IF (ANS(1).EQ.'B'.OR.ANS(1).EQ.'N') CALL NEWPAG ICNT = 0 IPAGE = 12 IF (LCNT.LE.IPAGE) IPAGE = LCNT DO 8 I =LCNT , NCNT , -1 NNCNT = NNCNT +1 IF (ICNT.EQ.0) TYPE *,' INDEX TO PATIENT STUDIES ' IV = NFILES(1,I) !HEADER BLOCK CALL READW (256,IB,IV,NFILES(2,I)) C C PACK NAME INTO IBUFF C IC = 1 CALL PACK (IBYTES,IBUFF,IC,21,40) C C PACK PATIENTS NUMBER INTO IBUFF C CALL PACK (IBYTES,IBUFF,IC,41,60) C C STORE STUDY TYPE C CALL PACK(AEXT,IBUFF,IC,1,3) C C PACK STUDY DATE INTO IBUFF C CALL PACK(IBYTES,IBUFF,IC,81,100) C C STORE FILE NAME C CALL R50ASC(12,NAMES(1,I),LBYT) CALL PACK(LBYT,IBUFF,IC,4,9) IBUFF(IC-2) = '.' IC = IC - 1 CALL PACK(AEXT,IBUFF,IC,1,3) IC = IC - 3 C C WRITE STUDY I.D. AND STUDY DETAILS ON CONSOLE C WRITE(7,200)NNCNT,(IBUFF(N1),N1=1,IC) REWIND 7 200 FORMAT(' ',I2,' ',65A1) TYPE * IF (NNCNT.EQ.100) GOTO 16 ICNT = ICNT + 1 IF (I.EQ.NCNT) GOTO 24 !END OF LIST IF (ICNT.NE.IPAGE) GOTO 8 !END OF PAGE ? 24 TYPE* TYPE *,'SELECT STUDY BY NUMBER, OR' IF (ICNT.EQ.12) TYPE *,'TYPE N FOR NEXT PAGE' IF (NNCNT.GE.12) TYPE *,'TYPE B TO RETURN TO BEGINNING' TYPE * READ(5,101)ANS IF (ANS(1).EQ.'N') GOTO 11 !NEXT PAGE ? IF (ANS(1).EQ.'B') GOTO 18 !BACK TO BEGINING IF (ANS(2).NE.' ') GOTO 109 ANS(2) = ANS(1) ANS(1) = ' ' 109 DECODE(2,108,ANS)NUM 108 FORMAT(I2) IF (NUM.GE.1.AND.NUM.LE.LCNT) GOTO 7 !SELECTION OK ?? IF (NUM.EQ.0) GOTO 13 !REPRINT PAGE OF DATA CALL NEWPAG !ERROR - GOTO BEGINNING GOTO 18 11 IF (LCNT.EQ.NCNT) GOTO 9 !SET UP FOR NEXT PAGE 13 CALL NEWPAG ICNT =0 8 CONTINUE 9 CALL CLOSEC(ICHAN) CALL IFREEC(ICHAN) LCNT = LCNT + 1 IBLK = 4 NCNT = LCNT - 1 NNNCNT = LCNT - 1 CALL RCTRLO GOTO 105 7 CONTINUE D CALL RCTRLO C C STORE FILE NAME AS EQUIVALENT FOR CSI INPUT C C C TO DANGEROUS TO USE DISK AS UNSTRUCTURED DEVICE C ISTUDY = LCNT - NUM + 1 + NNNCNT C C STORE FILE SPEC FOR LOOKUP C DO 27 I = 1,4 27 FILSPC(15+I) = NAMES(I,ISTUDY) CALL R50ASC(12,NAMES(1,ISTUDY),LBYT) D WRITE(7,107)(LBYT(I),I=1,12) 107 FORMAT(' ','FILNAME',12A1) IF (NUM.GT.0) CALL NEWPAG CALL CLOSEC(ICHAN) CALL IFREEC(ICHAN) RETURN 16 WRITE(7,290) 290 FORMAT(//' MORE THAN 100 FILES ON DISK(S) OTHERS CAN NOT 1 BE ACCESSED'//) GOTO 7 END C C C PACK IS USED TO CREATE IDENTIFICATION OF STUDY C C SUBROUTINE PACK(IBYTES,IBUFF,IC,I4,I5) LOGICAL*1 IBYTES(1),IBUFF(1) DO 10 N1 = I4,I5 IF (IBYTES(N1).EQ.' '.AND.IBYTES(N1+1).EQ.' ') GOTO 12 IF (IBYTES(N1).EQ."0) GOTO 12 IBUFF(IC) = IBYTES(N1) 10 IC = IC +1 12 IBUFF(IC) = 44. IBUFF(IC+1) = 32. IC = IC + 2 RETURN END