IDENTIFICATION DIVISION. PROGRAM-ID. GOPU. AUTHOR. GREG LEHEY, SPERRY UNIVAC UVS-G FRANKFURT/MAIN. INSTALLATION. KASSENAERZTLICHE VEREINIGUNG. DATE-WRITTEN. 11 NOVEMBER 1973. DATE-COMPILED. ENVIRONMENT DIVISION. CONFIGURATION SECTION. SOURCE-COMPUTER. UNIVAC-1108. OBJECT-COMPUTER. UNIVAC-1106. INPUT-OUTPUT SECTION. FILE-CONTROL. SELECT CARD, ASSIGN TO CARD-READER. SELECT PRINTOUT, ASSIGN TO PRINTER. DATA DIVISION. FILE SECTION. FD CARD LABEL RECORDS ARE OMITTED. 01 INCARD. 02 ANGABEN. 03 ARZT-NR. 04 FILLER, PICTURE IS 99. 04 ARTEXT, PICTURE IS 99. 04 ARTIX, PICTURE IS 9. 04 FILLER, PICTURE IS 9(7). 03 FILLER, PICTURE IS X. 03 GO-NO, PICTURE IS 9. 03 FILLER, PICTURE IS XX. 03 SWFLAG, PICTURE IS X. 02 FILLER, PICTURE IS X. 02 LEISTUNG OCCURS 9 TIMES. 03 LEXT, PICTURE IS 999. 03 FILLER, PICTURE IS XXX. 02 SEQ-NO, PICTURE IS 9(8). 01 ST-KART REDEFINES INCARD. 02 KV-NR. 03 OKV, PICTURE IS 99. 03 UKV, PICTURE IS 99. 02 FILLER, PICTURE IS X(76). FD PRINTOUT LABEL RECORDS ARE OMITTED. 01 ZEILE. 02 FILLER, PICTURE IS X(132). SCHEMA SECTION. INVOKE SCHEMA KVDMS COPYING COMMON ALL RECORD COMMON DELIVERY-AREA IS PUFFER OVERLAY PUFFER WITH ALL ERROR RECOVERY IS HELL ROLLBACK IS IMPOSSIBLE. WORKING-STORAGE SECTION. 77 GO-NAME, USAGE IS AREA-NAME. 77 AHDR-NAME, USAGE IS AREA-NAME. 77 SEK-NAME, USAGE IS AREA-NAME. 77 AZINNO, PICTURE IS H9(5). 77 LEISTNR, PICTURE IS H9(5). 77 SETVAL, PICTURE IS X. 01 GO-KEY, USAGE IS AREA-KEY. 01 AHDR-KEY, USAGE IS AREA-KEY. 01 SEK-KEY, USAGE IS AREA-KEY. 01 KV-NUMM. 02 OKV, PICTURE IS 99. 02 UKV, PICTURE IS 99. 01 FLAGS. 02 GO-SWITCH, PICTURE IS 9. 02 UPDAT, PICTURE IS 9. 02 MAT-FULL, PICTURE IS 9. 02 NEW-MATRATZ, PICTURE IS 9. 02 ARZT-SWITCH, PICTURE IS 9. 01 EXP-MATRATZ. 02 FILLER, PICTURE IS X, VALUE IS '@'. 02 MATVAL OCCURS 10000 TIMES, PICTURE IS X. 01 DUD-ARZT-MSG. 02 FILLER, PICTURE IS X(30), VALUE IS ' *** ARZT MIT EXTERNER NUMMER'. 02 DUD-ARZT-NAM, PICTURE IS 9(12). 02 FILLER, PICTURE IS X(40), VALUE IS ' NICHT GEFUNDEN. ***'. 01 NO-GO-MSG. 02 FILLER, PICTURE IS X(35), VALUE IS ' *** FEHLERHAFTE GEBUEHRENORDNUNG:'. 02 NO-GO-GO, PICTURE IS 9. 01 DUD-LEIST-MSG. 02 FILLER, PICTURE IS X(14), VALUE IS ' *** LEISTUNG'. 02 DUD-LEIST, PICTURE IS X(8). 02 FILLER, PICTURE IS X(7), VALUE IS ' IN GO'. 02 DUD-LEIST-GO, PICTURE IS 9. 02 FILLER, PICTURE IS X(19), VALUE IS ' NICHT GEFUNDEN ***'. 01 LETZT-ARZT. 02 ARZT-NR. 03 FILLER, PICTURE IS 99. 03 ARTEXT, PICTURE IS 99. 03 ARTIX, PICTURE IS 9. 03 FILLER, PICTURE IS 9(7). 02 FILLER, PICTURE IS X. 02 GO-NO, PICTURE IS 9. 02 FILLER, PICTURE IS XX. 02 SWFLAG, PICTURE IS X. 01 KOPFKISSEN. 02 FILLER, PICTURE IS XXXX, VALUE IS '@@@@'. 02 SZSPA, PICTURE IS 9, VALUE IS 1. 02 FILLER, PICTURE IS X(8), VALUE IS '@@@@@@@@'. 02 SZA, PICTURE IS 9(5). 02 FILLER, PICTURE IS X(6), VALUE IS '@@@@@@'. 02 SZL, PICTURE IS 9(5), VALUE IS 1. PROCEDURE DIVISION. START-HERE. IMPART. OPEN ALL USAGE-MODE IS UPDATE. OPEN INPUT CARD, OUTPUT PRINTOUT. MOVE ZEROS TO FLAGS. READ CARD RECORD, AT END GO TO END-UPDAT. * CURRENT DATEI-RECORD HOLEN (GOPU) MOVE 'DSK1' TO SEK-NAME. MOVE 1 TO RECORD-NUM OF SEK-KEY, PAGE-NUM OF SEK-KEY. FIND SEK-KEY, SEK-NAME. SEK-MADE. MOVE UKV OF KV-NR TO SKV-NR. FIND SKV RECORD. MOVE 'G' TO ALPHZ. FIND ALPHA RECORD, ON ERROR GO TO WRITE-ALPHA. * FEHLER BEDEUTET VERNUTLICH, DASS 'G' RECORD FEHLT; SCHREIBEN. WROTE-ALPHA. MOVE 'GOPU ' TO DATNAM. FIND DATEI RECORD, ON ERROR GO TO MAKE-GOPU. MOVE 1 TO UPDAT. NOTE 1 BEDEUTET GOPU SCHON VORHANDEN. DISPLAY ' *** GOPU UPDATE-LAUF ***' UPON PRINTER. * HIER ZURUECK, WENN GOPU ERSTELLT. FOUND-GOPU. * AKV-RECORD FUER DIESE KV HOLEN. MOVE 'DST1' TO AHDR-NAME. MOVE 1 TO RECORD-NUM OF AHDR-KEY, PAGE-NUM OF AHDR-KEY. FIND AHDR-KEY, AHDR-NAME. MOVE UKV OF KV-NR TO AKV-NR. FIND AKV RECORD. * GOHDR RECORD FINDEN MOVE 'DST3' TO GO-NAME. MOVE 1 TO RECORD-NUM OF GO-KEY, PAGE-NUM OF GO-KEY. FIND GO-KEY, GO-NAME. MOVE KV-NR TO KV-NUMM. * JETZT IN ERNST ANFANGEN NEXT-CARD. READ CARD RECORD, AT END GO TO END-UPDAT. CARD-GAP. WRITE ZEILE FROM INCARD AFTER ADVANCING 1 LINE. IF ARZT-NR OF ANGABEN IS NOT EQUAL TO SPACES, EXAMINE ARZT-NR OF ANGABEN OF INCARD REPLACING ALL SPACES BY ZEROS. IF GO-NO OF INCARD IS NOT EQUAL TO SPACES AND IS NOT EQUAL TO GO-NO OF LETZT-ARZT, MOVE HIGH-VALUES TO GO-SWITCH, ELSE MOVE ZERO TO GO-SWITCH. IF ARZT-NR OF INCARD IS EQUAL TO SPACES OR IS EQUAL TO ARZT-NR OF LETZT-ARZT, MOVE ZERO TO ARZT-SWITCH, ELSE MOVE HIGH-VALUES TO ARZT-SWITCH. IF ARZT-SWITCH IS EQUAL TO ZERO AND GO-SWITCH IS EQUAL TO ZERO, GO TO MAKE-MATRATZ. IF MAT-FULL IS NOT EQUAL TO 1, GO TO NEXT-MAT. ENTER COMPRESSION SUBROUTINE REFERENCING EXP-MATRATZ. MOVE 1 TO SZL OF MATRATZ. MOVE 1 TO SZSPA OF MATRATZ; MOVE SZA OF KOPFKISSEN TO SZA OF MATRATZ. IF NEW-MATRATZ IS EQUAL TO 1 OR UPDAT IS EQUAL TO 0, STORE MATRATZ, ELSE PERFORM MODIFY-MATRATZ. MOVE ALL '@' TO EXP-MATRATZ. IF ARZT-SWITCH IS EQUAL TO ZERO, GO TO CONT-CARD. * NEUER ARZT; RECORD HOLEN. NEXT-MAT. MOVE ANGABEN TO LETZT-ARZT; MOVE ARTEXT OF ARZT-NR OF LETZT-ARZT TO ARFACH; MOVE ARTIX OF ARZT-NR OF LETZT-ARZT TO ARFGIX; FIND AEX RECORD, ON ERROR GO TO KEIN-ARZT. MOVE ARZT-NR OF LETZT-ARZT TO AREXNR. FETCH ARZT RECORD, ON ERROR GO TO KEIN-ARZT. FOUND-ARZT. MOVE ARINNR TO AZINNO, SZA OF KOPFKISSEN. CONT-CARD. IF GO-SWITCH IS EQUAL TO ZERO, GO TO NO-NEW-GO. MOVE GO-NO OF INCARD TO GO-NO OF LETZT-ARZT. MOVE GO-NO OF LETZT-ARZT TO GONUMM; FIND GOHDR RECORD. MOVE UKV OF KV-NUMM TO GKV-NR. FIND GKV RECORD, ON ERROR GO TO NO-GO. NO-NEW-GO. MOVE ALL '@' TO MATIX; MOVE GO-NO OF LETZT-ARZT TO MATGO. FIND MATIX RECORD, ON ERROR GO TO DUD-GO. GO-OK. IF UPDAT IS EQUAL TO ZERO, GO TO MAKE-MATRATZ. MOVE ALL '@' TO SZDIM OF MATRATZ. MOVE AZINNO TO SZA OF MATRATZ. MOVE 1 TO SZL OF MATRATZ. FETCH MATRATZ VIA MAT-SATZ USING SZDIM, ON ERROR GO TO DUD-ARZT. MOVE 0 TO NEW-MATRATZ. * MATRATZ EXPANDIEREN. ARZT-OK. ENTER EXPANSION SUBROUTINE REFERENCING EXP-MATRATZ. MAKE-MATRATZ. IF SWFLAG OF ANGABEN IS EQUAL TO 'L', MOVE '@' TO SETVAL ELSE MOVE '[' TO SETVAL. MOVE 1 TO LEISTNR, MAT-FULL. NEXT-LEISTUNG. * INTERNE LEISTUNGE-NUMMER FINDEN MOVE LEXT (LEISTNR) TO LEXIND. FIND LEX RECORD, ON ERROR GO TO NOLEIST. MOVE LEISTUNG (LEISTNR) TO GOEXNR. FETCH LEIST RECORD, ON ERROR GO TO NOLEIST. * ENTSPRECHENDES ELEMENT IN MATRATZ SETZEN. MOVE SETVAL TO MATVAL (GOINNR). SET-MATRATZ. ADD 1 TO LEISTNR. IF LEISTUNG (LEISTNR) IS NOT EQUAL TO SPACES AND LEISTNR IS LESS THAN 10, GO TO NEXT-LEISTUNG. GO TO NEXT-CARD. END-UPDAT. ENTER COMPRESSION SUBROUTINE REFERENCING EXP-MATRATZ. MOVE 1 TO SZL OF MATRATZ; MOVE 1 TO SZSPA OF MATRATZ. MOVE SZA OF KOPFKISSEN TO SZA OF MATRATZ. IF NEW-MATRATZ IS EQUAL TO 1 OR UPDAT IS EQUAL TO 0, STORE MATRATZ, ELSE PERFORM MODIFY-MATRATZ. DEPART. DISPLAY 'GOPU ENDE'. STOP RUN. * MATRATZ AENDERN MODIFY-MATRATZ SECTION. NORMAL. FIND MATRATZ VIA MAT-SATZ USING SZDIM, ON ERROR GO TO DAMNATION. MODIFY. GO TO AUSGANG. DAMNATION. STORE MATRATZ. AUSGANG. EXIT. ERROR-RECOVERY SECTION. * KEIN ALPHA RECORD;,SCHREIBEN. WRITE-ALPHA. IF ERROR-STATUS IS NOT EQUAL TO '000307', GO TO HELL. STORE ALPHA. GO TO WROTE-ALPHA. * GOPU NOCH NICHT DEFINIERT; DEFINIEREN. MAKE-GOPU. IF ERROR-STATUS IS NOT EQUAL TO '000307', GO TO HELL. MOVE ALL '@' TO DATDIM. MOVE 0 TO DATKZ. MOVE 1 TO DATGO, DATAR, DATL. STORE DATEI. MOVE ZERO TO UPDAT. DISPLAY ' *** GOPU ERSTELLUNGSLAUF ***' UPON PRINTER. GO TO FOUND-GOPU. DUD-ARZT. * KEIN MATRATZ FUER DIESEN ARZT DEFINIERT; AUFBAUEN. MOVE 1 TO NEW-MATRATZ. GO TO MAKE-MATRATZ. KEIN-ARZT. MOVE ARZT-NR OF LETZT-ARZT TO DUD-ARZT-NAM. WRITE ZEILE FROM DUD-ARZT-MSG AFTER ADVANCING 4 LINES. DISCARD. READ CARD RECORD, AT END GO TO END-UPDAT. IF ARZT-NR OF ANGABEN IS EQUAL TO SPACES, GO TO DISCARD. GO TO CARD-GAP. NO-GO. IF ERROR-STATUS IS NOT EQUAL TO '000307', GO TO NO-GONE. MOVE OKV OF KV-NUMM TO GKV-NR. FIND GKV RECORD, ON ERROR GO TO NO-GONE. GO TO NO-NEW-GO. NO-GONE. MOVE GO-NO OF LETZT-ARZT TO NO-GO-GO. WRITE ZEILE FROM NO-GO-MSG AFTER ADVANCING 4 LINES. DEPART WITH ROLLBACK. STOP RUN. * FEHLER BEI MATIX-LESEN; ERSTELLEN? DUD-GO. IF ERROR-STATUS IS NOT EQUAL TO '000307' GO TO HELL. STORE MATIX. GO TO GO-OK. NOLEIST. MOVE LEISTUNG (LEISTNR) TO DUD-LEIST. FETCH CURRENT GOHDR RECORD. MOVE GONUMM TO DUD-LEIST-GO. WRITE ZEILE FROM DUD-LEIST-MSG AFTER ADVANCING 2 LINES. HELL. DISPLAY ' *** DMS-FEHLER ***' UPON PRINTER. DISPLAY 'GOPU ERROR', ERROR-STATUS. BUGGERY. MONITOR ERROR-STATUS, ERROR-RECORD, ERROR-SET, ERROR-AREA. MONITOR PUFFER, FLAGS. DEPART WITH ROLLBACK, ON ERROR GO TO IMPOSSIBLE. STOP RUN. IMPOSSIBLE. DISPLAY ' *** DMS ROLLBACK ***' UPON PRINTER. DISPLAY 'GOPU ROLLBACK'. MONITOR ERROR-STATUS, ERROR-RECORD, ERROR-SET, ERROR-AREA. STOP RUN.