079700****************************************************************** 079710 079720 079730 IDENTIFICATION DIVISION. 079740 079750****************************************************************** 079760 079770 PROGRAM-ID. DBRIP08. 079780 079790 AUTHOR. XXXX XXXXXX 079800 079810 XXXX XXXXX. 079820 079830 DATE-WRITTEN. DEC-1991. 079840 079850****************************************************************** 079860 079870 079880 PROCEDURE DIVISION. 079890 079900****************************************************************** 079910****************************************************************** 079920* STEUER PROCEDURE 079930****************************************************************** 079940 079950 STEUER SECTION. 079960 079970 ST-000. 079980 PERFORM VORVERARB. 079990 080000 ST-100. 080010 PERFORM HAUPTVERARB. 080020 080030 ST-990. 080040 IF SWPF = 99 080050 PERFORM XCTL 080060 ELSE 080070 MOVE +6000 TO CA-LENGTH 080080 PERFORM TRANSID 080090 END-IF. 080100 080110 ST-999. 080120 GA-TERUG. 080130 EJECT 080140****************************************************************** 080150* VORVERARBEITUNG 080160****************************************************************** 080170 080180 VORVERARB SECTION. 080190 080200 VV-000. 080210 MOVE DFHCOMMAREA TO COMMAREA 080220 MOVE +6000 TO CA-LENGTH 080230 MOVE LOW-VALUE TO DBRIM8DI. 080240 080250 VV-100. 080260 IF CA-SCHRITT = ZERO 080270 GO VV-999 080280 END-IF. 080290 080300 VV-700. 080310**** HANDLE AID UND CONDITION 080320* EXEC CICS HANDLE CONDITION MAPFAIL (VV-860) 080330* END-EXEC. 080340**** HANDLE AID 1. TEIL 080350* EXEC CICS HANDLE AID PF1 (VV-710) 080360* PF2 (VV-720) 080370* PF3 (VV-730) 080380* PF10 (VV-800) 080390* PF11 (VV-810) 080400* PF12 (VV-820) 080410* CLEAR (VV-840) 080420* ANYKEY (VV-850) 080430* END-EXEC. 080440**** R E C E I V E 080450 PERFORM RECEIVEN 080460 MOVE 13 TO SWPF 080470 GO VV-999. 080480**** ENTER-TASTE 080490 080500 VV-710. 080510**** PF1-TASTE 080520 MOVE 1 TO SWPF 080530 GO VV-999. 080540 080550 VV-720. 080560**** PF2-TASTE 080570 MOVE 2 TO SWPF 080580 GO VV-999. 080590 080600 VV-730. 080610**** PF3-TASTE 080620 MOVE 3 TO SWPF 080630 GO VV-999. 080640 080650 VV-800. 080660**** PF10-TASTE 080670 MOVE 10 TO SWPF 080680 GO VV-999. 080690 080700 VV-810. 080710**** PF11-TASTE 080720 MOVE 11 TO SWPF 080730 GO VV-999. 080740 080750 VV-820. 080760**** PF12-TASTE 080770 MOVE 12 TO SWPF 080780 GO VV-999. 080790 080800 VV-840. 080810**** CLEAR-TASTE 080820 MOVE 14 TO SWPF 080830 GO VV-999. 080840 080850 VV-850. 080860**** ANYKEY-TASTE 080870 MOVE 15 TO SWPF 080880 GO VV-999. 080890 080900 VV-860. 080910**** M A P F A I L 080920 MOVE 16 TO SWPF. 080930 080940 VV-999. 080950 EXIT. 080960 EJECT 080970****************************************************************** 080980* HAUPTVERARBEITUNG 080990****************************************************************** 081000 081010 HAUPTVERARB SECTION. 081020 081030 HV-000. 081040 IF CA-SCHRITT = ZERO 081050 GO HV-500 081060 END-IF. 081070 081080 HV-050. 081090**** HANDLING PF-FUNKTIONEN 081100 GO 081110 HV-81 081120 HV-82 081130 HV-83 081140 HV-84 081150 HV-85 081160 HV-86 081170 HV-87 081180 HV-88 081190 HV-89 081200 HV-90 081210 HV-91 081220 HV-92 081230 HV-93 081240 HV-94 081250 HV-95 081260 HV-96 DEPENDING SWPF. 081270 081280 HV-81. 081290**** PF1-TASTE (HELP-PROGRAMM) 081300 GO HV-95. 081310 081320 HV-82. 081330**** PF2-TASTE / PRINTER-AUFRUF 081340 MOVE 2 TO CA-SWPF 081350 MOVE 0 TO CA-SCHRITT 081360 EXEC CICS LINK 081370 PROGRAM ( 'D154' ) 081380 END-EXEC 081390 GO HV-999. 081400 081410 HV-83. 081420**** PF3-TASTE 081430 MOVE 3 TO CA-SWPF 081440 MOVE 0 TO CA-SCHRITT 081450 EXEC CICS XCTL 081460 PROGRAM ( 'DBRIT' ) 081470 COMMAREA ( COMMAREA ) 081480 LENGTH ( CA-LENGTH ) 081490 END-EXEC. 081500 081510 HV-84. 081520**** PF4-TASTE 081530 GO HV-95. 081540 081550 HV-85. 081560**** PF5-TASTE 081570 GO HV-95. 081580 081590 HV-86. 081600**** PF6-TASTE 081610 GO HV-95. 081620 081630 HV-87. 081640* PF7-TASTE 081650**** RUECKWAERTS BLAETTERN (INDIV.) 081660 GO HV-95. 081670 081680 HV-88. 081690* PF8-TASTE 081700**** VORWAERTS BLAETTERN (INDIV.) 081710 GO HV-95. 081720 081730 HV-89. 081740**** PF9-TASTE 081750 GO HV-95. 081760 081770 HV-90. 081780**** PF10-TASTE 081790**** BILDSCHIRM AUF GROSS UMSCHALTEN 081800 MOVE 'G' TO P1-XM269 081810 MOVE K-XM269 TO P200-1 081820 CALL 'XM200' 081830 USING 081840 P-P008 081850 P200-1 081860 P1-XM269 081870 PERFORM MODULE 081880 MOVE ZERO TO CA-LENGTH 081890 EXEC CICS XCTL 081900 PROGRAM ( 'PF10T' ) 081910 COMMAREA ( COMMAREA ) 081920 LENGTH ( CA-LENGTH ) 081930 END-EXEC. 081940 081950 HV-91. 081960**** PF11-TASTE 081970**** AUSDRUCKEN: ZUERST NORMALE VER- 081980**** ARBEITUNG (PLAUSI ETC.) 081990 GO HV-200. 082000 082010 HV-92. 082020**** PF12 - ENDE DER TRANSAKTION 082030**** BILDSCHIRM AUF GROSS UMSCHALTEN 082040 MOVE 'G' TO P1-XM269 082050 MOVE K-XM269 TO P200-1 082060 CALL 'XM200' 082070 USING 082080 P-P008 082090 P200-1 082100 P1-XM269 082110 PERFORM MODULE 082120 MOVE 99 TO SWPF 082130 GO HV-999. 082140 082150 HV-93. 082160**** ENTER (EMPFANGEN SCREEN) 082170 GO HV-200. 082180 082190 HV-94. 082200**** CLEAR (SENDEN LEERE MASKE) 082210 GO HV-83. 082220 082230 HV-95. 082240**** ANYKEY (FALSCHE FUNKTIONS-TASTE) 082250 PERFORM CAFILL 082260 IF SWFEHL > ZERO 082270 GO HV-900 082280 END-IF 082290 MOVE LOW-VALUE TO DBRIM8DI 082300 MOVE 1 TO 082310 FEHL-NR 082320 CA-FEHLNR 082330 MOVE -1 TO M8SACHTL 082340 GO HV-900. 082350 082360 HV-96. 082370**** MAPFAIL (KEINE EINGABE) 082380 GO HV-200. 082390 082400 HV-97. 082410**** AUFRUF AUS CROSS-JUMPER 082420 GO HV-200. 082430 082440 HV-100. 082450**** INITIALISIEREN SCREEN 082460 MOVE LOW-VALUE TO DBRIM8DO 082470 GO HV-800. 082480 082490 HV-200. 082500**** COMMONAREA MIT SCREENDATEN LADEN 082510 PERFORM CAFILL 082520 IF SWFEHL > ZERO 082530 GO HV-900 082540 END-IF. 082550 082560 HV-300. 082570**** INPUT PRUEFEN 082580 PERFORM PLAUSI 082590 IF SWFEHL = ZERO 082600 GO HV-500 082610 END-IF 082620 IF FEHL-NR = 0 082630 MOVE 3 TO 082640 FEHL-NR 082650 CA-FEHLNR 082660 END-IF 082670 GO HV-900. 082680**** WENN KEINE FEHLER IN PLAUSI 082690* WEITER ZU HV-500 082700 082710 HV-500. 082720**** AUFRUF DER VERARBEITUNG 082730* NACH ERFOLGREICHEN PLAUS-TESTS 082740 PERFORM VERARB 082750 IF SWFEHL > ZERO 082760 GO HV-900 082770 END-IF. 082780 082790 HV-800. 082800**** SENDEN SCREEN 082810 PERFORM SENDEN 082820 IF CA-SCHRITT = 0 082830 MOVE 1 TO CA-SCHRITT 082840 END-IF 082850 MOVE 80 TO SWPF 082860 GO HV-999. 082870 082880 HV-900. 082890**** FEHLER 082900 PERFORM FEHLMELD 082910 PERFORM SENDFEHL 082920 MOVE 90 TO SWPF. 082930 082940 HV-999. 082950 EXIT. 082960 EJECT 082970****************************************************************** 082980****************************************************************** 082990* PROGRAMM - SUBROUTINEN ---> PLAUSI UND VERARB <--- 083000****************************************************************** 083010****************************************************************** 083020****************************************************************** 083030* PLAUSIBILITAET 083040****************************************************************** 083050 083060 PLAUSI SECTION. 083070 083080 PL-000. 083090 MOVE ZERO TO 083100 SWFEHL 083110 CA-SWFEHL 083120 IF CA-SCHRITT > ZERO 083130 GO PL-500 083140 END-IF. 083150 083160 PL-100. 083170 MOVE 1 TO CA-SCHRITT 083180 GO PL-999. 083190* ------------------------------- 083200**** P L A U S I S C H R I T T 1 083210* ------------------------------- 083220 083230 PL-500. 083240******** PRINTER PRUEFEN 083250******** *************** 083260 IF CA-PRINTER = SPACE 083270 MOVE DFHBMBRY TO M8PRIDA 083280 MOVE -1 TO M8PRIDL 083290 MOVE 3 TO 083300 FEHL-NR 083310 CA-FEHLNR 083320 MOVE 1 TO SWFEHL 083330 GO PL-510 083340 END-IF 083350 MOVE CA-PRINTER TO P1-XM229 083360 MOVE K-XM229 TO P200-1 083370 CALL 'XM200' 083380 USING 083390 P-P008 083400 P200-1 083410 P1-XM229 083420 P2-XM229 083430 P3-XM229 083440 PERFORM MODULE 083450 MOVE P1-XM229 TO CA-PRINTER 083460 MOVE 'G' TO BER-FUNC 083470 MOVE CA-PRINTER TO BER-PRTID 083480 EXEC CICS LINK 083490 PROGRAM ( 'XM177' ) 083500 COMMAREA ( P-XM177 ) 083510 LENGTH ( P-XM177L ) 083520 END-EXEC 083530 IF BER-RET1 = '1' 083540 MOVE DFHBMBRY TO M8PRIDA 083550 IF SWFEHL = ZERO 083560 MOVE -1 TO M8PRIDL 083570 MOVE 1 TO SWFEHL 083580 MOVE 96 TO 083590 FEHL-NR 083600 CA-FEHLNR 083610 END-IF 083620 END-IF. 083630 083640 PL-510. 083650******** SCHACHT PRUEFEN 083660******** *************** 083670 IF CA-SCHACHTX NOT NUMERIC 083680 MOVE 'Q' TO M8CANA 083690 IF SWFEHL = ZERO 083700 MOVE -1 TO M8CANL 083710 MOVE 1 TO SWFEHL 083720 MOVE 52 TO 083730 FEHL-NR 083740 CA-FEHLNR 083750 END-IF 083760 END-IF 083770 IF CA-SCHACHTX > '0' AND CA-SCHACHTX < '4' 083780 GO PL-520 083790 END-IF 083800 IF CA-SCHACHTX = '9' 083810 GO PL-520 083820 END-IF 083830 MOVE 'Q' TO M8CANA 083840 IF SWFEHL = ZERO 083850 MOVE -1 TO M8CANL 083860 MOVE 1 TO SWFEHL 083870 MOVE 3 TO 083880 FEHL-NR 083890 CA-FEHLNR 083900 END-IF. 083910 083920 PL-520. 083930******** MIND. 1 ABSENDERZEILE 083940******** ********************* 083950 IF CA-ABS1 = SPACE AND 083960 CA-ABS2 = SPACE AND CA-ABS3 = SPACE AND CA-ABS4 = SPACE 083970 MOVE DFHBMBRY TO 083980 M8ABS1A 083990 M8ABS2A 084000 M8ABS3A 084010 M8ABS4A 084020 IF SWFEHL = ZERO 084030 MOVE -1 TO M8ABS1L 084040 MOVE 74 TO 084050 FEHL-NR 084060 CA-FEHLNR 084070 MOVE 1 TO SWFEHL 084080 END-IF 084090 END-IF 084100 IF CA-ADRESSE = SPACE 084110 MOVE DFHBMBRY TO 084120 M8ADRZ1A 084130 M8ADRZ2A 084140 M8ADRZ3A 084150 MOVE DFHBMBRY TO 084160 M8ADRZ4A 084170 M8ADRZ5A 084180 IF SWFEHL = ZERO 084190 MOVE -1 TO M8ADRZ1L 084200 MOVE 74 TO 084210 FEHL-NR 084220 CA-FEHLNR 084230 MOVE 1 TO SWFEHL 084240 END-IF 084250 END-IF 084260 MOVE ZERO TO 084270 R-ADRSW 084280 R-LEERZ 084290 IF CA-ADRESS-SWITCHES = SPACE 084300 GO PL-530 084310 END-IF 084320 IF CA-ADRSW1 NOT = SPACE 084330 ADD 1 TO R-ADRSW 084340 END-IF 084350 IF CA-ADRSW2 NOT = SPACE 084360 ADD 1 TO R-ADRSW 084370 END-IF 084380 IF CA-ADRSW3 NOT = SPACE 084390 ADD 1 TO R-ADRSW 084400 END-IF 084410 IF CA-ADRSW4 NOT = SPACE 084420 ADD 1 TO R-ADRSW 084430 END-IF 084440 IF CA-ADRZ1 = SPACE 084450 ADD 1 TO R-LEERZ 084460 END-IF 084470 IF CA-ADRZ2 = SPACE 084480 ADD 1 TO R-LEERZ 084490 END-IF 084500 IF CA-ADRZ3 = SPACE 084510 ADD 1 TO R-LEERZ 084520 END-IF 084530 IF CA-ADRZ4 = SPACE 084540 ADD 1 TO R-LEERZ 084550 END-IF 084560 IF CA-ADRZ5 = SPACE 084570 ADD 1 TO R-LEERZ 084580 END-IF 084590 IF R-ADRSW > R-LEERZ 084600 MOVE DFHBMBRY TO 084610 M8ADSW1A 084620 M8ADSW2A 084630 M8ADSW3A 084640 M8ADSW4A 084650 IF SWFEHL = ZERO 084660 MOVE -1 TO M8ADSW1L 084670 MOVE 03 TO 084680 FEHL-NR 084690 CA-FEHLNR 084700 MOVE 1 TO SWFEHL 084710 END-IF 084720 END-IF 084730 IF (CA-ADRSW1 NOT = SPACE) AND (CA-ADRZ1 = SPACE) 084740 MOVE DFHBMBRY TO 084750 M8ADSW1A 084760 M8ADRZ1A 084770 IF SWFEHL = ZERO 084780 MOVE -1 TO M8ADSW1L 084790 MOVE 03 TO 084800 FEHL-NR 084810 CA-FEHLNR 084820 MOVE 1 TO SWFEHL 084830 END-IF 084840 END-IF 084850 IF (CA-ADRSW2 NOT = SPACE) AND (CA-ADRZ2 = SPACE) 084860 MOVE DFHBMBRY TO 084870 M8ADSW2A 084880 M8ADRZ2A 084890 IF SWFEHL = ZERO 084900 MOVE -1 TO M8ADSW2L 084910 MOVE 03 TO 084920 FEHL-NR 084930 CA-FEHLNR 084940 MOVE 1 TO SWFEHL 084950 END-IF 084960 END-IF 084970 IF (CA-ADRSW3 NOT = SPACE) AND (CA-ADRZ3 = SPACE) 084980 MOVE DFHBMBRY TO 084990 M8ADSW3A 085000 M8ADRZ3A 085010 IF SWFEHL = ZERO 085020 MOVE -1 TO M8ADSW3L 085030 MOVE 03 TO 085040 FEHL-NR 085050 CA-FEHLNR 085060 MOVE 1 TO SWFEHL 085070 END-IF 085080 END-IF 085090 IF (CA-ADRSW4 NOT = SPACE) AND (CA-ADRZ4 = SPACE) 085100 MOVE DFHBMBRY TO 085110 M8ADSW4A 085120 M8ADRZ4A 085130 IF SWFEHL = ZERO 085140 MOVE -1 TO M8ADSW4L 085150 MOVE 03 TO 085160 FEHL-NR 085170 CA-FEHLNR 085180 MOVE 1 TO SWFEHL 085190 END-IF 085200 END-IF. 085210 085220 PL-530. 085230******** UNTERSTE ADR-ZEILE MUSS PLZ HABEN 085240******** ********************************* 085250 MOVE CA-ADRESSE TO T-ADRESSE 085260 MOVE 5 TO I-1. 085270 085280 PL-540. 085290 IF I-1 < 2 085300 GO PL-550 085310 END-IF 085320 IF T-ADRZ-EL ( I-1 ) = SPACE 085330 SUBTRACT 1 FROM I-1 085340 GO PL-540 085350 END-IF 085360 IF T-ADRZ-PLZ ( I-1 ) NUMERIC 085370 GO PL-560 085380 END-IF. 085390 085400 PL-550. 085410 MOVE DFHBMBRY TO 085420 M8ADRZ1A 085430 M8ADRZ2A 085440 M8ADRZ3A 085450 M8ADRZ4A 085460 M8ADRZ5A 085470 IF SWFEHL = ZERO 085480 MOVE -1 TO M8ADRZ1L 085490 MOVE 1 TO SWFEHL 085500 MOVE 319 TO 085510 FEHL-NR 085520 CA-FEHLNR 085530 END-IF. 085540 085550 PL-560. 085560******** IHRE SACHBEARBEITER-TEXT 085570******** ************************ 085580 IF CA-SACHBT = SPACE 085590 MOVE DFHBMBRY TO M8SACHTA 085600 IF SWFEHL = ZERO 085610 MOVE -1 TO M8SACHTL 085620 MOVE 74 TO 085630 FEHL-NR 085640 CA-FEHLNR 085650 MOVE 1 TO SWFEHL 085660 END-IF 085670 END-IF 085680 IF CA-SACHB1 = SPACE AND CA-SACHB2 = SPACE 085690 MOVE DFHBMBRY TO 085700 M8SACH1A 085710 M8SACH2A 085720 IF SWFEHL = ZERO 085730 MOVE -1 TO M8SACH1L 085740 MOVE 74 TO 085750 FEHL-NR 085760 CA-FEHLNR 085770 MOVE 1 TO SWFEHL 085780 END-IF 085790 END-IF 085800 IF CA-ANRED = SPACE 085810 MOVE DFHBMBRY TO M8ANREDA 085820 IF SWFEHL = ZERO 085830 MOVE -1 TO M8ANREDL 085840 MOVE 74 TO 085850 FEHL-NR 085860 CA-FEHLNR 085870 MOVE 1 TO SWFEHL 085880 END-IF 085890 END-IF 085900 MOVE ZERO TO XM016-P1 085910 MOVE ZERO TO XM016-P2 085920 MOVE CA-LB-ERDAT TO XM016-P3 085930 MOVE K-XM016 TO P200-1 085940 CALL 'XM200' 085950 USING 085960 P-P008 085970 P200-1 085980 XM016-P1 085990 XM016-P2 086000 XM016-P3 086010 PERFORM MODULE 086020 IF XM016-P2 NOT = ZERO 086030 MOVE DFHBMBRY TO M8ERDATA 086040 IF SWFEHL = ZERO 086050 MOVE 73 TO 086060 FEHL-NR 086070 CA-FEHLNR 086080 MOVE -1 TO M8ERDATL 086090 MOVE 1 TO 086100 SWFEHL 086110 CA-SWFEHL 086120 GO PL-590 086130 ELSE 086140 GO PL-590 086150 END-IF 086160 END-IF 086170 MOVE SPACE TO 086180 Z-TESTDATUM 086190 Z-DATE10 086200 MOVE CA-LB-ERDAT TO Z-TESTDATUM 086210 IF Z-TD-6OPF = SPACE 086220 MOVE Z-TD-6OPT TO Z-TT10 086230 MOVE Z-TD-6OPM TO Z-MM10 086240 MOVE Z-TD-6OPJ TO Z-JZ10 086250 IF Z-TD-6OPJ > 80 086260 MOVE 19 TO Z-JH10 086270 GO PL-580 086280 ELSE 086290 MOVE 20 TO Z-JH10 086300 GO PL-580 086310 END-IF 086320 END-IF 086330 IF Z-TD-8MPJ NUMERIC 086340 MOVE Z-TD-8MPX TO Z-DATE10 086350 GO PL-580 086360 END-IF 086370 IF Z-TD-6MP1 = '.' AND Z-TD-6MP2 = '.' 086380 MOVE Z-TD-6MPT TO Z-TT10 086390 MOVE Z-TD-6MPM TO Z-MM10 086400 MOVE Z-TD-6MPJ TO Z-JZ10 086410 IF Z-TD-6MPJ > 80 086420 MOVE 19 TO Z-JH10 086430 GO PL-580 086440 ELSE 086450 MOVE 20 TO Z-JH10 086460 GO PL-580 086470 END-IF 086480 END-IF 086490 MOVE Z-TD-8OPT TO Z-TT10 086500 MOVE Z-TD-8OPM TO Z-MM10 086510 MOVE Z-TD-8OPJ TO Z-JJ10. 086520**** TEST-DATUM = 'TTMMJJ ' 086530**** ************************* 086540 086550 PL-580. 086560 MOVE '.' TO 086570 Z-P110 086580 Z-P210 086590 MOVE Z-DATE10 TO CA-LB-ERDAT. 086600 086610 PL-590. 086620******** DATUM LAEUFT AM .... AB 086630******** *********************** 086640 IF CA-LB-MENDZ = SPACE 086650 GO PL-620 086660 END-IF 086670 MOVE ZERO TO XM016-P1 086680 MOVE ZERO TO XM016-P2 086690 MOVE CA-LB-MENDZ TO XM016-P3 086700 MOVE K-XM016 TO P200-1 086710 CALL 'XM200' 086720 USING 086730 P-P008 086740 P200-1 086750 XM016-P1 086760 XM016-P2 086770 XM016-P3 086780 PERFORM MODULE 086790 IF XM016-P2 NOT = ZERO 086800 MOVE 73 TO 086810 FEHL-NR 086820 CA-FEHLNR 086830 MOVE -1 TO M8MENDZL 086840 MOVE DFHBMBRY TO M8MENDZA 086850 MOVE 1 TO 086860 SWFEHL 086870 CA-SWFEHL 086880 GO PL-620 086890 END-IF 086900 MOVE SPACE TO 086910 Z-TESTDATUM 086920 Z-DATE10 086930 MOVE CA-LB-MENDZ TO Z-TESTDATUM 086940 IF Z-TD-6OPF = SPACE 086950 MOVE Z-TD-6OPT TO Z-TT10 086960 MOVE Z-TD-6OPM TO Z-MM10 086970 MOVE Z-TD-6OPJ TO Z-JZ10 086980 IF Z-TD-6OPJ > 80 086990 MOVE 19 TO Z-JH10 087000 GO PL-610 087010 ELSE 087020 MOVE 20 TO Z-JH10 087030 GO PL-610 087040 END-IF 087050 END-IF 087060 IF Z-TD-8MPJ NUMERIC 087070 MOVE Z-TD-8MPX TO Z-DATE10 087080 GO PL-610 087090 END-IF 087100 IF Z-TD-6MP1 = '.' AND Z-TD-6MP2 = '.' 087110 MOVE Z-TD-6MPT TO Z-TT10 087120 MOVE Z-TD-6MPM TO Z-MM10 087130 MOVE Z-TD-6MPJ TO Z-JZ10 087140 IF Z-TD-6MPJ > 80 087150 MOVE 19 TO Z-JH10 087160 GO PL-610 087170 ELSE 087180 MOVE 20 TO Z-JH10 087190 GO PL-610 087200 END-IF 087210 END-IF 087220 MOVE Z-TD-8OPT TO Z-TT10 087230 MOVE Z-TD-8OPM TO Z-MM10 087240 MOVE Z-TD-8OPJ TO Z-JJ10. 087250**** TEST-DATUM = 'TTMMJJ ' 087260**** ************************* 087270 087280 PL-610. 087290 MOVE '.' TO 087300 Z-P110 087310 Z-P210 087320 MOVE Z-DATE10 TO CA-LB-MENDZ. 087330 087340 PL-620. 087350******** DATUM IST AM .... ABGELAUFEN 087360******** **************************** 087370 IF CA-LB-MENDV = SPACE 087380 GO PL-650 087390 END-IF 087400 MOVE ZERO TO XM016-P1 087410 MOVE ZERO TO XM016-P2 087420 MOVE CA-LB-MENDV TO XM016-P3 087430 MOVE K-XM016 TO P200-1 087440 CALL 'XM200' 087450 USING 087460 P-P008 087470 P200-1 087480 XM016-P1 087490 XM016-P2 087500 XM016-P3 087510 PERFORM MODULE 087520 IF XM016-P2 NOT = ZERO 087530 MOVE 73 TO 087540 FEHL-NR 087550 CA-FEHLNR 087560 MOVE -1 TO M8MENDVL 087570 MOVE DFHBMBRY TO M8MENDVA 087580 MOVE 1 TO 087590 SWFEHL 087600 CA-SWFEHL 087610 GO PL-650 087620 END-IF 087630 MOVE SPACE TO 087640 Z-TESTDATUM 087650 Z-DATE10 087660 MOVE CA-LB-MENDV TO Z-TESTDATUM 087670 IF Z-TD-6OPF = SPACE 087680 MOVE Z-TD-6OPT TO Z-TT10 087690 MOVE Z-TD-6OPM TO Z-MM10 087700 MOVE Z-TD-6OPJ TO Z-JZ10 087710 IF Z-TD-6OPJ > 80 087720 MOVE 19 TO Z-JH10 087730 GO PL-640 087740 ELSE 087750 MOVE 20 TO Z-JH10 087760 GO PL-640 087770 END-IF 087780 END-IF 087790 IF Z-TD-8MPJ NUMERIC 087800 MOVE Z-TD-8MPX TO Z-DATE10 087810 GO PL-640 087820 END-IF 087830 IF Z-TD-6MP1 = '.' AND Z-TD-6MP2 = '.' 087840 MOVE Z-TD-6MPT TO Z-TT10 087850 MOVE Z-TD-6MPM TO Z-MM10 087860 MOVE Z-TD-6MPJ TO Z-JZ10 087870 IF Z-TD-6MPJ > 80 087880 MOVE 19 TO Z-JH10 087890 GO PL-640 087900 ELSE 087910 MOVE 20 TO Z-JH10 087920 GO PL-640 087930 END-IF 087940 END-IF 087950 MOVE Z-TD-8OPT TO Z-TT10 087960 MOVE Z-TD-8OPM TO Z-MM10 087970 MOVE Z-TD-8OPJ TO Z-JJ10. 087980**** TEST-DATUM = 'TTMMJJ ' 087990**** ************************* 088000 088010 PL-640. 088020 MOVE '.' TO 088030 Z-P110 088040 Z-P210 088050 MOVE Z-DATE10 TO CA-LB-MENDV. 088060 088070 PL-650. 088080******** OBJEKT-TEXT 088090******** *********** 088100 IF CA-LB-OBJ = SPACE 088110 MOVE DFHBMBRY TO M8OBJA 088120 IF SWFEHL = ZERO 088130 MOVE -1 TO M8OBJL 088140 MOVE 74 TO 088150 FEHL-NR 088160 CA-FEHLNR 088170 MOVE 1 TO 088180 SWFEHL 088190 CA-SWFEHL 088200 END-IF 088210 END-IF 088220 IF Z-UEBET = SPACE 088230 GO PL-660 088240 END-IF 088250 MOVE DFHBMBRY TO M8UEBETA 088260 IF SWFEHL = ZERO 088270 MOVE -1 TO M8UEBETL 088280 MOVE 52 TO 088290 FEHL-NR 088300 CA-FEHLNR 088310 MOVE 1 TO 088320 SWFEHL 088330 CA-SWFEHL 088340 END-IF. 088350 088360 PL-660. 088370* ... IST OBLIGATORISCH 088380******** ********************* 088390 IF CA-LB-UEBET = ZERO 088400 MOVE DFHBMBRY TO M8UEBETA 088410 IF SWFEHL = ZERO 088420 MOVE -1 TO M8UEBETL 088430 MOVE 74 TO 088440 FEHL-NR 088450 CA-FEHLNR 088460 MOVE 1 TO 088470 SWFEHL 088480 CA-SWFEHL 088490 END-IF 088500 END-IF 088510 IF Z-KAUTI = SPACE 088520 GO PL-670 088530 END-IF 088540 MOVE DFHBMBRY TO M8KAUTIA 088550 IF SWFEHL = ZERO 088560 MOVE -1 TO M8KAUTIL 088570 MOVE 52 TO 088580 FEHL-NR 088590 CA-FEHLNR 088600 MOVE 1 TO 088610 SWFEHL 088620 CA-SWFEHL 088630 END-IF. 088640 088650 PL-670. 088660******** ZINSGUTSCHRIFT 088670******** ************** 088680 IF Z-ZGUT = SPACE 088690 GO PL-680 088700 END-IF 088710 MOVE DFHBMBRY TO M8ZGUTA 088720 IF SWFEHL = ZERO 088730 MOVE -1 TO M8ZGUTL 088740 MOVE 52 TO 088750 FEHL-NR 088760 CA-FEHLNR 088770 MOVE 1 TO 088780 SWFEHL 088790 CA-SWFEHL 088800 END-IF. 088810 088820 PL-680. 088830******** ANZAHL RATEN 088840******** ************ 088850 IF CA-LB-ANZRAX NOT NUMERIC 088860 MOVE DFHBMBRY TO M8ANZRAA 088870 IF SWFEHL = ZERO 088880 MOVE -1 TO M8ANZRAL 088890 MOVE 52 TO 088900 FEHL-NR 088910 CA-FEHLNR 088920 MOVE 1 TO 088930 SWFEHL 088940 CA-SWFEHL 088950 END-IF 088960 END-IF 088970 IF Z-RATE = SPACE 088980 GO PL-690 088990 END-IF 089000 MOVE DFHBMBRY TO M8RATEA 089010 IF SWFEHL = ZERO 089020 MOVE -1 TO M8RATEL 089030 MOVE 52 TO 089040 FEHL-NR 089050 CA-FEHLNR 089060 MOVE 1 TO 089070 SWFEHL 089080 CA-SWFEHL 089090 END-IF. 089100 089110 PL-690. 089120 IF SWFEHL NOT = ZERO 089130 GO PL-999 089140 END-IF. 089150 089160 PL-800. 089170******** EIN ABLAUFDATUM OBLIGATORISCH 089180******** ***************************** 089190 IF (CA-LB-MENDV = SPACE) AND (CA-LB-MENDZ = SPACE) 089200 MOVE DFHBMBRY TO 089210 M8MENDZA 089220 M8MENDVA 089230 MOVE -1 TO M8MENDZL 089240 MOVE 74 TO 089250 FEHL-NR 089260 CA-FEHLNR 089270 MOVE 1 TO 089280 SWFEHL 089290 CA-SWFEHL 089300 GO PL-999 089310 END-IF 089320 IF (CA-LB-MENDV NOT = SPACE) AND (CA-LB-MENDZ NOT = SPACE) 089330 MOVE DFHBMBRY TO 089340 M8MENDZA 089350 M8MENDVA 089360 MOVE -1 TO M8MENDZL 089370 MOVE 30 TO 089380 FEHL-NR 089390 CA-FEHLNR 089400 MOVE 1 TO 089410 SWFEHL 089420 CA-SWFEHL 089430 GO PL-999 089440 END-IF 089450 MOVE K-XM278 TO P200-1 089460 CALL 'XM200' 089470 USING 089480 P-P008 089490 P200-1 089500 Z-DATE 089510 Z-CURRDATE 089520 PERFORM MODULE 089530 MOVE K-XM005 TO P200-1 089540 CALL 'XM200' 089550 USING 089560 P-P008 089570 P200-1 089580 Z-DUMMY6 089590 Z-CURR-BIN 089600 Z-CURRDATE 089610 PERFORM MODULE 089620 IF CA-LB-MENDV = SPACE 089630 GO PL-810 089640 END-IF 089650 MOVE K-XM005 TO P200-1 089660 CALL 'XM200' 089670 USING 089680 P-P008 089690 P200-1 089700 Z-DUMMY6 089710 Z-MENDV-BIN 089720 CA-LB-MENDV 089730 PERFORM MODULE 089740 IF Z-MENDV-BIN > Z-CURR-BIN 089750 MOVE DFHBMBRY TO M8MENDVA 089760 IF SWFEHL = ZERO 089770 MOVE -1 TO M8MENDVL 089780 MOVE 03 TO 089790 FEHL-NR 089800 CA-FEHLNR 089810 MOVE 1 TO 089820 SWFEHL 089830 CA-SWFEHL 089840 END-IF 089850 END-IF. 089860******** VERGANGENHEIT: NICHT > CURRENT-DATE 089870******** *********************************** 089880 089890 PL-810. 089900******** ZUKUNFT: > CURRENT-DATE 089910******** *********************** 089920 IF CA-LB-MENDZ = SPACE 089930 GO PL-820 089940 END-IF 089950 MOVE K-XM005 TO P200-1 089960 CALL 'XM200' 089970 USING 089980 P-P008 089990 P200-1 090000 Z-DUMMY6 090010 Z-MENDZ-BIN 090020 CA-LB-MENDZ 090030 PERFORM MODULE 090040 IF Z-MENDZ-BIN NOT > Z-CURR-BIN 090050 MOVE DFHBMBRY TO M8MENDZA 090060 IF SWFEHL = ZERO 090070 MOVE -1 TO M8MENDZL 090080 MOVE 03 TO 090090 FEHL-NR 090100 CA-FEHLNR 090110 MOVE 1 TO 090120 SWFEHL 090130 CA-SWFEHL 090140 END-IF 090150 END-IF. 090160 090170 PL-820. 090180******** ANZRA UND RATE BEIDE NULL ODER 090190******** BEIDE NICHT NULL 090200******** ****************************** 090210 IF (CA-LB-ANZRA = ZERO) AND (CA-LB-RATE = ZERO) 090220 GO PL-830 090230 END-IF 090240 IF (CA-LB-ANZRA NOT = ZERO) AND (CA-LB-RATE NOT = ZERO) 090250 GO PL-830 090260 END-IF 090270 MOVE 'Q' TO M8ANZRAA 090280 MOVE DFHBMBRY TO M8RATEA 090290 MOVE -1 TO M8ANZRAL 090300 MOVE 30 TO 090310 FEHL-NR 090320 CA-FEHLNR 090330 MOVE 1 TO 090340 SWFEHL 090350 CA-SWFEHL 090360 GO PL-999. 090370 090380 PL-830. 090390******** ZINSGUTSCHRIFT UND RATEN 090400******** SCHLIESSEN SICH AUS 090410******** ************************ 090420 IF (CA-LB-ZGUT NOT = ZERO) AND (CA-LB-RATE NOT = ZERO) 090430 MOVE 'Q' TO M8ANZRAA 090440 MOVE DFHBMBRY TO 090450 M8RATEA 090460 M8ZGUTA 090470 MOVE -1 TO M8ZGUTL 090480 MOVE 30 TO 090490 FEHL-NR 090500 CA-FEHLNR 090510 MOVE 1 TO 090520 SWFEHL 090530 CA-SWFEHL 090540 GO PL-999 090550 END-IF 090560 IF (SWPF = 11) AND (CA-ADRESS-SWITCHES NOT = SPACE) 090570 MOVE DFHBMBRY TO 090580 M8ADSW1A 090590 M8ADSW2A 090600 M8ADSW3A 090610 M8ADSW4A 090620 IF SWFEHL = ZERO 090630 MOVE -1 TO M8ADSW1L 090640 MOVE 1 TO 090650 FEHL-NR 090660 CA-FEHLNR 090670 MOVE 1 TO 090680 SWFEHL 090690 CA-SWFEHL 090700 END-IF 090710 END-IF. 090720 090730 PL-999. 090740 EXIT. 090750 EJECT 090760****************************************************************** 090770* VERARBEITUNG 090780****************************************************************** 090790 090800 VERARB SECTION. 090810 090820 VA-000. 090830 IF CA-SCHRITT > ZERO 090840 GO VA-500 090850 END-IF 090860 MOVE 1 TO CA-SCHRITT 090870 DIVIDE CA-LB-SALDO BY CA-LB-RATE GIVING 090880 CA-LB-ANZRA 090890 REMAINDER 090900 R-REST 090910 IF R-REST NOT = ZERO 090920 MOVE 'Q' TO M8ANZRAA 090930 MOVE DFHBMBRY TO M8RATEA 090940 MOVE -1 TO M8ANZRAL 090950 MOVE 349 TO 090960 FEHL-NR 090970 CA-FEHLNR 090980 MOVE 1 TO SWFEHL 090990 END-IF 091000 GO VA-999. 091010******** WARNMELDUNG AUSGEBEN, WENN ANZAHL 091020******** RATEN NICHT AUFGEHT 091030******** ********************************* 091040*------------------------------------------------------------- 091050**** V E R A R B S C H R I T T 1 091060* ------------------------------- 091070 091080 VA-500. 091090**** PERFORM DRUCKPROGRAMM, RETURN-CODE MIT QUITTUNG 091100**** AN BENUETZER ZURUECKGEBEN (NUR BEI PF11) 091110 MOVE ZERO TO CA-FEHLNR 091120 IF CA-SACHB1 = SPACE 091130 MOVE CA-SACHB2 TO CA-SACHB1 091140 MOVE SPACE TO CA-SACHB2 091150 END-IF 091160 MOVE SPACE TO P1-XM314 091170 MOVE CA-ABS1 TO P1-XM314-EL ( 1 ) 091180 MOVE CA-ABS2 TO P1-XM314-EL ( 2 ) 091190 MOVE CA-ABS3 TO P1-XM314-EL ( 3 ) 091200 MOVE CA-ABS4 TO P1-XM314-EL ( 4 ) 091210 MOVE K-XM314 TO P200-1 091220 CALL 'XM200' 091230 USING 091240 P-P008 091250 P200-1 091260 P1-XM314 091270 P2-XM314 091280 PERFORM MODULE 091290 MOVE P1-XM314-EL ( 1 ) TO CA-ABS1 091300 MOVE P1-XM314-EL ( 2 ) TO CA-ABS2 091310 MOVE P1-XM314-EL ( 3 ) TO CA-ABS3 091320 MOVE P1-XM314-EL ( 4 ) TO CA-ABS4 091330 PERFORM ADRKOMPR 091340 IF CA-ADRESS-SWITCHES NOT = SPACE 091350 PERFORM ADRINSERT 091360 END-IF 091370 IF SWPF NOT = 11 091380 MOVE -1 TO M8SACHTL 091390 GO VA-999 091400 END-IF 091410 PERFORM PRGLINK 091420 IF CA-FEHLNR = ZERO 091430 MOVE 253 TO CA-FEHLNR 091440 END-IF 091450 MOVE -1 TO M8SACHTL 091460 MOVE 1 TO SWFEHL 091470 MOVE CA-FEHLNR TO FEHL-NR. 091480* ADRESS-LEERZEILEN ELIMINIEREN 091490* ***************************** 091500* GEWUENSCHTE LEERZEILEN INSERTEN 091510* ******************************* 091520**** ENDE VERARBEITUNG DER DATEN 091530 091540 VA-999. 091550 EXIT. 091560 EJECT 091570****************************************************************** 091580****************************************************************** 091590* DIVERSE - SUBROUTINEN 091600****************************************************************** 091610****************************************************************** 091620****************************************************************** 091630* FUELLEN COMMON-AREA 091640****************************************************************** 091650 091660 CAFILL SECTION. 091670 091680 CA-000. 091690 IF M8PRIDL > ZERO 091700 MOVE M8PRIDI TO CA-PRINTER 091710 END-IF 091720 IF M8PRIDF = X80 091730 MOVE SPACE TO CA-PRINTER 091740 END-IF 091750 IF M8CANL > ZERO 091760 MOVE M8CANI TO CA-SCHACHTX 091770 END-IF 091780 IF M8CANF = X80 091790 MOVE ZERO TO CA-SCHACHT 091800 END-IF 091810 IF M8ABS1L > ZERO 091820 MOVE M8ABS1I TO CA-ABS1 091830 END-IF 091840 IF M8ABS1F = X80 091850 MOVE SPACE TO CA-ABS1 091860 END-IF 091870 IF M8ABS2L > ZERO 091880 MOVE M8ABS2I TO CA-ABS2 091890 END-IF 091900 IF M8ABS2F = X80 091910 MOVE SPACE TO CA-ABS2 091920 END-IF 091930 IF M8ABS3L > ZERO 091940 MOVE M8ABS3I TO CA-ABS3 091950 END-IF 091960 IF M8ABS3F = X80 091970 MOVE SPACE TO CA-ABS3 091980 END-IF 091990 IF M8ABS4L > ZERO 092000 MOVE M8ABS4I TO CA-ABS4 092010 END-IF 092020 IF M8ABS4F = X80 092030 MOVE SPACE TO CA-ABS4 092040 END-IF 092050 IF M8ADRZ1L > ZERO 092060 MOVE M8ADRZ1I TO CA-ADRZ1 092070 END-IF 092080 IF M8ADRZ1F = X80 092090 MOVE SPACE TO CA-ADRZ1 092100 END-IF 092110 IF M8ADRZ2L > ZERO 092120 MOVE M8ADRZ2I TO CA-ADRZ2 092130 END-IF 092140 IF M8ADRZ2F = X80 092150 MOVE SPACE TO CA-ADRZ2 092160 END-IF 092170 IF M8ADRZ3L > ZERO 092180 MOVE M8ADRZ3I TO CA-ADRZ3 092190 END-IF 092200 IF M8ADRZ3F = X80 092210 MOVE SPACE TO CA-ADRZ3 092220 END-IF 092230 IF M8ADRZ4L > ZERO 092240 MOVE M8ADRZ4I TO CA-ADRZ4 092250 END-IF 092260 IF M8ADRZ4F = X80 092270 MOVE SPACE TO CA-ADRZ4 092280 END-IF 092290 IF M8ADRZ5L > ZERO 092300 MOVE M8ADRZ5I TO CA-ADRZ5 092310 END-IF 092320 IF M8ADRZ5F = X80 092330 MOVE SPACE TO CA-ADRZ5 092340 END-IF 092350 IF M8ADSW1L > ZERO 092360 MOVE M8ADSW1I TO CA-ADRSW1 092370 END-IF 092380 IF M8ADSW1F = X80 092390 MOVE SPACE TO CA-ADRSW1 092400 END-IF 092410 IF M8ADSW2L > ZERO 092420 MOVE M8ADSW2I TO CA-ADRSW2 092430 END-IF 092440 IF M8ADSW2F = X80 092450 MOVE SPACE TO CA-ADRSW2 092460 END-IF 092470 IF M8ADSW3L > ZERO 092480 MOVE M8ADSW3I TO CA-ADRSW3 092490 END-IF 092500 IF M8ADSW3F = X80 092510 MOVE SPACE TO CA-ADRSW3 092520 END-IF 092530 IF M8ADSW4L > ZERO 092540 MOVE M8ADSW4I TO CA-ADRSW4 092550 END-IF 092560 IF M8ADSW4F = X80 092570 MOVE SPACE TO CA-ADRSW4 092580 END-IF 092590 IF M8SACHTL > ZERO 092600 MOVE M8SACHTI TO CA-SACHBT 092610 END-IF 092620 IF M8SACHTF = X80 092630 MOVE SPACE TO CA-SACHBT 092640 END-IF 092650 IF M8SACH1L > ZERO 092660 MOVE M8SACH1I TO CA-SACHB1 092670 END-IF 092680 IF M8SACH1F = X80 092690 MOVE SPACE TO CA-SACHB1 092700 END-IF 092710 IF M8SACH2L > ZERO 092720 MOVE M8SACH2I TO CA-SACHB2 092730 END-IF 092740 IF M8SACH2F = X80 092750 MOVE SPACE TO CA-SACHB2 092760 END-IF 092770 IF M8ANREDL > ZERO 092780 MOVE M8ANREDI TO CA-ANRED 092790 END-IF 092800 IF M8ANREDF = X80 092810 MOVE SPACE TO CA-ANRED 092820 END-IF 092830 IF M8ERDATL > ZERO 092840 MOVE M8ERDATI TO CA-LB-ERDAT 092850 END-IF 092860 IF M8ERDATF = X80 092870 MOVE SPACE TO CA-LB-ERDAT 092880 END-IF 092890 IF M8MENDZL > ZERO 092900 MOVE M8MENDZI TO CA-LB-MENDZ 092910 END-IF 092920 IF M8MENDZF = X80 092930 MOVE SPACE TO CA-LB-MENDZ 092940 END-IF 092950 IF M8MENDVL > ZERO 092960 MOVE M8MENDVI TO CA-LB-MENDV 092970 END-IF 092980 IF M8MENDVF = X80 092990 MOVE SPACE TO CA-LB-MENDV 093000 END-IF 093010 IF M8OBJL > ZERO 093020 MOVE M8OBJI TO CA-LB-OBJ 093030 END-IF 093040 IF M8OBJF = X80 093050 MOVE SPACE TO CA-LB-OBJ 093060 END-IF 093070 IF M8UEBETL > ZERO 093080 MOVE K-XM246 TO P200-1 093090 CALL 'XM200' 093100 USING 093110 P-P008 093120 P200-1 093130 XM246-P1 093140 M8UEBETI 093150 CA-LB-UEBET 093160 Z-UEBET 093170 PERFORM MODULE 093180 END-IF 093190 IF M8UEBETF = X80 093200 MOVE ZERO TO CA-LB-UEBET 093210 MOVE SPACE TO Z-UEBET 093220 END-IF 093230 IF M8KAUTIL > ZERO 093240 MOVE K-XM246 TO P200-1 093250 CALL 'XM200' 093260 USING 093270 P-P008 093280 P200-1 093290 XM246-P1 093300 M8KAUTII 093310 CA-LB-KAUTI 093320 Z-KAUTI 093330 PERFORM MODULE 093340 END-IF 093350 IF M8KAUTIF = X80 093360 MOVE ZERO TO CA-LB-KAUTI 093370 MOVE SPACE TO Z-KAUTI 093380 END-IF 093390 IF M8ZGUTL > ZERO 093400 MOVE K-XM246 TO P200-1 093410 CALL 'XM200' 093420 USING 093430 P-P008 093440 P200-1 093450 XM246-P1 093460 M8ZGUTI 093470 CA-LB-ZGUT 093480 Z-ZGUT 093490 PERFORM MODULE 093500 END-IF 093510 IF M8ZGUTF = X80 093520 MOVE ZERO TO CA-LB-ZGUT 093530 MOVE SPACE TO Z-ZGUT 093540 END-IF 093550 IF M8ANZRAL > ZERO 093560 MOVE M8ANZRAI TO CA-LB-ANZRA 093570 END-IF 093580 IF M8ANZRAF = X80 093590 MOVE ZERO TO CA-LB-ANZRA 093600 END-IF 093610 IF M8RATEL > ZERO 093620 MOVE K-XM246 TO P200-1 093630 CALL 'XM200' 093640 USING 093650 P-P008 093660 P200-1 093670 XM246-P1 093680 M8RATEI 093690 R-RATE 093700 Z-RATE 093710 PERFORM MODULE 093720 MOVE R-RATE TO CA-LB-RATE 093730 END-IF 093740 IF M8RATEF = X80 093750 MOVE ZERO TO CA-LB-RATE 093760 MOVE SPACE TO Z-RATE 093770 END-IF 093780 IF M8FZ1L > ZERO 093790 MOVE M8FZ1I TO CA-FZ-1 093800 END-IF 093810 IF M8FZ1F = X80 093820 MOVE SPACE TO CA-FZ-1 093830 END-IF 093840 IF M8FZ2L > ZERO 093850 MOVE M8FZ2I TO CA-FZ-2 093860 END-IF 093870 IF M8FZ2F = X80 093880 MOVE SPACE TO CA-FZ-2 093890 END-IF 093900 IF M8FZ3L > ZERO 093910 MOVE M8FZ3I TO CA-FZ-3 093920 END-IF 093930 IF M8FZ3F = X80 093940 MOVE SPACE TO CA-FZ-3 093950 END-IF 093960 IF M8XJUMPL > ZERO 093970 PERFORM XJUMP 093980 END-IF. 093990 094000 CA-999. 094010 EXIT. 094020 EJECT 094030****************************************************************** 094040* FEHLERMELDUNG HOLEN (XM181) 094050****************************************************************** 094060 094070 FEHLMELD SECTION. 094080 094090 FM-000. 094100 MOVE CA-SPR TO FEHL-SPR 094110 EXEC CICS LINK 094120 PROGRAM ( 'XM181' ) 094130 COMMAREA ( XM181-P ) 094140 LENGTH ( XM181L ) 094150 END-EXEC 094160 MOVE FEHL-MELD TO M8MSGO 094170 MOVE SPACE TO 094180 FEHL-VAR1 094190 FEHL-VAR2 094200 FEHL-VAR3 094210 FEHL-VAR4 094220 FEHL-VAR5 094230 FEHL-VAR6. 094240 094250 FM-999. 094260 EXIT. 094270 EJECT 094280****************************************************************** 094290* MODULE-AUFRUF-INTERFACE (P008) 094300****************************************************************** 094310 094320 MODULE SECTION. 094330 094340 MO-000. 094350 EXEC CICS LINK 094360 PROGRAM ( 'P008' ) 094370 COMMAREA ( P-P008 ) 094380 LENGTH ( P-P008L ) 094390 END-EXEC. 094400 094410 MO-999. 094420 EXIT. 094430 EJECT 094440****************************************************************** 094450* LINK-PROGRAMME AUFRUFEN 094460****************************************************************** 094470 094480 PRGLINK SECTION. 094490 094500 PRG-000. 094510 EXEC CICS LINK 094520 PROGRAM ( 'DBRIP58' ) 094530 COMMAREA ( COMMAREA ) 094540 LENGTH ( CA-LENGTH ) 094550 END-EXEC. 094560 094570 PRG-999. 094580 EXIT. 094590 EJECT 094600****************************************************************** 094610* UEBERTRAGEN CA --> SCREEN 094620****************************************************************** 094630**** (INDIVIDUELLE VERARBEITUNG) 094640 094650 SCREENFILL SECTION. 094660 094670 SC-000. 094680 MOVE CA-RKDN1X TO M8REF1O 094690 MOVE CA-RKDN2X TO M8REF2O 094700 MOVE CA-VNRX TO M8VNRO 094710 MOVE CA-PRINTER TO M8PRIDO 094720 MOVE CA-SCHACHT TO M8CANO 094730 MOVE CA-BRIEF TO M8BRIEFO 094740 MOVE CA-ABS1 TO M8ABS1O 094750 MOVE CA-ABS2 TO M8ABS2O 094760 MOVE CA-ABS3 TO M8ABS3O 094770 MOVE CA-ABS4 TO M8ABS4O 094780 MOVE CA-ADRZ1 TO M8ADRZ1O 094790 MOVE CA-ADRZ2 TO M8ADRZ2O 094800 MOVE CA-ADRZ3 TO M8ADRZ3O 094810 MOVE CA-ADRZ4 TO M8ADRZ4O 094820 MOVE CA-ADRZ5 TO M8ADRZ5O 094830 MOVE CA-ADRSW1 TO M8ADSW1O 094840 MOVE CA-ADRSW2 TO M8ADSW2O 094850 MOVE CA-ADRSW3 TO M8ADSW3O 094860 MOVE CA-ADRSW4 TO M8ADSW4O 094870 MOVE CA-SACHBT TO M8SACHTO 094880 MOVE CA-SACHB1 TO M8SACH1O 094890 MOVE CA-SACHB2 TO M8SACH2O 094900 MOVE CA-ANRED TO M8ANREDO 094910 MOVE CA-LB-ERDAT TO M8ERDATO 094920 MOVE CA-LB-MENDZ TO M8MENDZO 094930 MOVE CA-LB-MENDV TO M8MENDVO 094940 MOVE CA-LB-OBJ TO M8OBJO 094950 IF Z-UEBET = SPACE 094960 IF CA-LB-UEBET = ZERO 094970 MOVE SPACE TO M8UEBETO 094980 ELSE 094990 MOVE CA-LB-UEBET TO MO-BETRA 095000 MOVE MO-BETRAX TO M8UEBETO 095010 END-IF 095020 ELSE 095030 MOVE Z-UEBET TO M8UEBETO 095040 END-IF 095050 IF Z-KAUTI = SPACE 095060 IF CA-LB-KAUTI = ZERO 095070 MOVE SPACE TO M8KAUTIO 095080 ELSE 095090 MOVE CA-LB-KAUTI TO MO-BETRA 095100 MOVE MO-BETRAX TO M8KAUTIO 095110 END-IF 095120 ELSE 095130 MOVE Z-KAUTI TO M8KAUTIO 095140 END-IF 095150 IF Z-ZGUT = SPACE 095160 IF CA-LB-ZGUT = ZERO 095170 MOVE SPACE TO M8ZGUTO 095180 ELSE 095190 MOVE CA-LB-ZGUT TO MO-BETRA 095200 MOVE MO-BETRAX TO M8ZGUTO 095210 END-IF 095220 ELSE 095230 MOVE Z-ZGUT TO M8ZGUTO 095240 END-IF 095250 MOVE CA-LB-ANZRA TO M8ANZRAO 095260 IF Z-RATE = SPACE 095270 IF CA-LB-RATE = ZERO 095280 MOVE SPACE TO M8RATEO 095290 ELSE 095300 MOVE CA-LB-RATE TO MO-BETRA 095310 MOVE MO-BETRAX TO M8RATEO 095320 END-IF 095330 ELSE 095340 MOVE Z-RATE TO M8RATEO 095350 END-IF 095360 MOVE CA-FZ-1 TO M8FZ1O 095370 MOVE CA-FZ-2 TO M8FZ2O 095380 MOVE CA-FZ-3 TO M8FZ3O. 095390 095400 SC-999. 095410 EXIT. 095420 EJECT 095430****************************************************************** 095440* IDENT-FELDER IN SCREEN FUELLEN 095450****************************************************************** 095460 095470 SCRIDENT SECTION. 095480 095490 SI-000. 095500 MOVE EIBTRMID TO TID 095510 MOVE EIBTIME TO Z-TIME 095520 MOVE K-XM278 TO P200-1 095530 CALL 'XM200' 095540 USING 095550 P-P008 095560 P200-1 095570 Z-DATE 095580 PERFORM MODULE 095590 MOVE TIMR1 TO HH 095600 MOVE TIMR2 TO MI 095610 MOVE TIMR3 TO SS 095620 MOVE DATR0 TO 095630 TT 095640 Z-DAT0 095650 MOVE DATR1 TO 095660 MM 095670 Z-DAT1 095680 MOVE DATR2 TO 095690 YY 095700 Z-DAT2 095710 MOVE CA-KKZ TO OPID 095720 MOVE CA-BURO TO GS 095730 MOVE K-XM014A TO P200-1 095740 CALL 'XM200' 095750 USING 095760 P-P008 095770 P200-1 095780 CA-FIRMA 095790 FA 095800 PERFORM MODULE 095810 MOVE CA-TRANS TO TRANS 095820 MOVE W-IDE TO M8IDEO 095830 MOVE W-IDA TO M8IDAO. 095840 095850 SI-999. 095860 EXIT. 095870 EJECT 095880****************************************************************** 095890* GEWUENSCHTE LEERZEILEN IN ADRESSE INSERTEN 095900****************************************************************** 095910 095920 ADRINSERT SECTION. 095930 095940 AI-000. 095950 IF CA-ADRSW4 NOT = SPACE 095960 MOVE CA-ADRZ4 TO CA-ADRZ5 095970 MOVE SPACE TO CA-ADRZ4 095980 MOVE SPACE TO CA-ADRSW4 095990 MOVE -1 TO M8ADRZ4L 096000 END-IF 096010 IF CA-ADRSW3 NOT = SPACE 096020 MOVE CA-ADRZ4 TO CA-ADRZ5 096030 MOVE CA-ADRZ3 TO CA-ADRZ4 096040 MOVE SPACE TO CA-ADRZ3 096050 MOVE SPACE TO CA-ADRSW3 096060 MOVE -1 TO M8ADRZ3L 096070 END-IF 096080 IF CA-ADRSW2 NOT = SPACE 096090 MOVE CA-ADRZ4 TO CA-ADRZ5 096100 MOVE CA-ADRZ3 TO CA-ADRZ4 096110 MOVE CA-ADRZ2 TO CA-ADRZ3 096120 MOVE SPACE TO CA-ADRZ2 096130 MOVE SPACE TO CA-ADRSW2 096140 MOVE -1 TO M8ADRZ2L 096150 END-IF 096160 IF CA-ADRSW1 NOT = SPACE 096170 MOVE CA-ADRZ4 TO CA-ADRZ5 096180 MOVE CA-ADRZ3 TO CA-ADRZ4 096190 MOVE CA-ADRZ2 TO CA-ADRZ3 096200 MOVE CA-ADRZ1 TO CA-ADRZ2 096210 MOVE SPACE TO CA-ADRZ1 096220 MOVE SPACE TO CA-ADRSW1 096230 MOVE -1 TO M8ADRZ1L 096240 END-IF. 096250 096260 AI-999. 096270 EXIT. 096280 EJECT 096290****************************************************************** 096300* LEERZEILEN AUS ADRESSE ELIMINIEREN UND SWITCHERS MITSCHIEBEN 096310****************************************************************** 096320 096330 ADRKOMPR SECTION. 096340 096350 AK-000. 096360 MOVE CA-ADRSW1 TO P1-XM314-ADRSW ( 1 ) 096370 MOVE CA-ADRZ1 TO P1-XM314-ADRZ ( 1 ) 096380 MOVE CA-ADRSW2 TO P1-XM314-ADRSW ( 2 ) 096390 MOVE CA-ADRZ2 TO P1-XM314-ADRZ ( 2 ) 096400 MOVE CA-ADRSW3 TO P1-XM314-ADRSW ( 3 ) 096410 MOVE CA-ADRZ3 TO P1-XM314-ADRZ ( 3 ) 096420 MOVE CA-ADRSW4 TO P1-XM314-ADRSW ( 4 ) 096430 MOVE CA-ADRZ4 TO P1-XM314-ADRZ ( 4 ) 096440 MOVE SPACE TO P1-XM314-ADRSW ( 5 ) 096450 MOVE CA-ADRZ5 TO P1-XM314-ADRZ ( 5 ) 096460 MOVE K-XM314 TO P200-1 096470 CALL 'XM200' 096480 USING 096490 P-P008 096500 P200-1 096510 P1-XM314 096520 P2-XM314 096530 PERFORM MODULE 096540 MOVE P1-XM314-ADRSW ( 1 ) TO CA-ADRSW1 096550 MOVE P1-XM314-ADRZ ( 1 ) TO CA-ADRZ1 096560 MOVE P1-XM314-ADRSW ( 2 ) TO CA-ADRSW2 096570 MOVE P1-XM314-ADRZ ( 2 ) TO CA-ADRZ2 096580 MOVE P1-XM314-ADRSW ( 3 ) TO CA-ADRSW3 096590 MOVE P1-XM314-ADRZ ( 3 ) TO CA-ADRZ3 096600 MOVE P1-XM314-ADRSW ( 4 ) TO CA-ADRSW4 096610 MOVE P1-XM314-ADRZ ( 4 ) TO CA-ADRZ4 096620 MOVE P1-XM314-ADRZ ( 5 ) TO CA-ADRZ5. 096630 096640 AK-999. 096650 EXIT. 096660 EJECT 096670****************************************************************** 096680****************************************************************** 096690* C I C S - SUBROUTINEN 096700****************************************************************** 096710****************************************************************** 096720****************************************************************** 096730* SENDEN SCREEN 096740****************************************************************** 096750 096760 SENDEN SECTION. 096770 096780 SE-000. 096790 PERFORM SCRIDENT 096800 PERFORM SCREENFILL 096810 MOVE -1 TO M8SACHTL 096820 IF CA-SPR = 2 096830 GO SE-100 096840 END-IF 096850 MOVE 'SN' TO X-CICS-FUNCTION 096860 MOVE DBRIM8DO TO X-CICS-MAP 096870 EXEC CICS LINK 096880 PROGRAM ( 'XTPOUT' ) 096890 COMMAREA ( X-CICS-PARAM ) 096900 LENGTH ( X-CICS-PARAM-LNG ) 096910 END-EXEC 096920 MOVE X-CICS-RETCODE TO EIBRESP 096930 GO SE-999. 096940 096950 SE-100. 096960* EXEC CICS SEND MAP ('DBRIM8F') 096970* MAPSET ('DBRIS8') 096980* FROM (DBRIM8DO) 096990* FREEKB 097000* CURSOR 097010* WAIT ERASE 097020* END-EXEC. 097030 MOVE 'SN' TO X-CICS-FUNCTION 097040 MOVE DBRIM8DO TO X-CICS-MAP 097050 EXEC CICS LINK 097060 PROGRAM ( 'XTPOUT' ) 097070 COMMAREA ( X-CICS-PARAM ) 097080 LENGTH ( X-CICS-PARAM-LNG ) 097090 END-EXEC 097100 MOVE X-CICS-RETCODE TO EIBRESP. 097110 097120 SE-999. 097130 EXIT. 097140 EJECT 097150****************************************************************** 097160* SENDEN SCREEN MIT FEHLERMELDUNG 097170****************************************************************** 097180 097190 SENDFEHL SECTION. 097200 097210 SF-000. 097220 PERFORM SCRIDENT 097230 PERFORM SCREENFILL 097240 IF M8MSGO = LOW-VALUE 097250 MOVE 'ABER...ABER...PROGRAMMIERFEHLER' TO M8MSGO 097260 END-IF 097270 IF CA-SPR = 2 097280 GO SF-100 097290 END-IF 097300 MOVE 'SN' TO X-CICS-FUNCTION 097310 MOVE DBRIM8DO TO X-CICS-MAP 097320 EXEC CICS LINK 097330 PROGRAM ( 'XTPOUT' ) 097340 COMMAREA ( X-CICS-PARAM ) 097350 LENGTH ( X-CICS-PARAM-LNG ) 097360 END-EXEC 097370 MOVE X-CICS-RETCODE TO EIBRESP 097380 GO SF-999. 097390 097400 SF-100. 097410* EXEC CICS SEND MAP ('DBRIM8F') 097420* MAPSET ('DBRIS8') 097430* FROM (DBRIM8DO) 097440* CURSOR 097450* FREEKB 097460* WAIT ERASE 097470* END-EXEC. 097480 MOVE 'SN' TO X-CICS-FUNCTION 097490 MOVE DBRIM8DO TO X-CICS-MAP 097500 EXEC CICS LINK 097510 PROGRAM ( 'XTPOUT' ) 097520 COMMAREA ( X-CICS-PARAM ) 097530 LENGTH ( X-CICS-PARAM-LNG ) 097540 END-EXEC 097550 MOVE X-CICS-RETCODE TO EIBRESP. 097560 097570 SF-999. 097580 EXIT. 097590 EJECT 097600****************************************************************** 097610* SCREEN EMPFANGEN 097620****************************************************************** 097630 097640 RECEIVEN SECTION. 097650 097660 RE-000. 097670 MOVE LOW-VALUE TO DBRIM8DI 097680 IF CA-SPR = 2 097690 GO RE-100 097700 END-IF 097710 MOVE 'RC' TO X-CICS-FUNCTION 097720 MOVE DBRIM8DI TO X-CICS-MAP 097730 EXEC CICS LINK 097740 PROGRAM ( 'XTPINP' ) 097750 COMMAREA ( X-CICS-PARAM ) 097760 LENGTH ( X-CICS-PARAM-LNG ) 097770 END-EXEC 097780 MOVE X-CICS-RETCODE TO EIBRESP 097790 EVALUATE TRUE 097800 WHEN X-MAPFAIL 097810* GO TO VV-860 097820 PERFORM VV-860 097830 WHEN X-PF1 097840* GO TO VV-710 097850 PERFORM VV-710 097860 WHEN X-PF2 097870* GO TO VV-720 097880 PERFORM VV-720 097890 WHEN X-PF3 097900* GO TO VV-730 097910 PERFORM VV-730 097920 WHEN X-PF10 097930* GO TO VV-800 097940 PERFORM VV-800 097950 WHEN X-PF11 097960* GO TO VV-810 097970 PERFORM VV-810 097980 WHEN X-PF12 097990* GO TO VV-820 098000 PERFORM VV-820 098010 WHEN X-CLEAR 098020* GO TO VV-840 098030 PERFORM VV-840 098040 WHEN X-ANYKEY 098050* GO TO VV-850 098060 PERFORM VV-850 098070 END-EVALUATE 098080 GO RE-999. 098090 098100 RE-100. 098110* EXEC CICS RECEIVE MAP ('DBRIM8F') 098120* MAPSET ('DBRIS8') 098130* INTO (DBRIM8DI) 098140* END-EXEC. 098150 MOVE 'RC' TO X-CICS-FUNCTION 098160 MOVE DBRIM8DI TO X-CICS-MAP 098170 EXEC CICS LINK 098180 PROGRAM ( 'XTPINP' ) 098190 COMMAREA ( X-CICS-PARAM ) 098200 LENGTH ( X-CICS-PARAM-LNG ) 098210 END-EXEC 098220 MOVE X-CICS-RETCODE TO EIBRESP 098230 EVALUATE TRUE 098240 WHEN X-MAPFAIL 098250* GO TO VV-860 098260 PERFORM VV-860 098270 WHEN X-PF1 098280* GO TO VV-710 098290 PERFORM VV-710 098300 WHEN X-PF2 098310* GO TO VV-720 098320 PERFORM VV-720 098330 WHEN X-PF3 098340* GO TO VV-730 098350 PERFORM VV-730 098360 WHEN X-PF10 098370* GO TO VV-800 098380 PERFORM VV-800 098390 WHEN X-PF11 098400* GO TO VV-810 098410 PERFORM VV-810 098420 WHEN X-PF12 098430* GO TO VV-820 098440 PERFORM VV-820 098450 WHEN X-CLEAR 098460* GO TO VV-840 098470 PERFORM VV-840 098480 WHEN X-ANYKEY 098490* GO TO VV-850 098500 PERFORM VV-850 098510 END-EVALUATE. 098520 098530 RE-999. 098540 EXIT. 098550 EJECT 098560****************************************************************** 098570* PROGRAMM MIT RETURN TRANSID VERLASSEN 098580****************************************************************** 098590 098600 TRANSID SECTION. 098610 098620 TR-000. 098630 EXEC CICS RETURN 098640 TRANSID ( CA-TRANS ) 098650 COMMAREA ( COMMAREA ) 098660 LENGTH ( CA-LENGTH ) 098670 END-EXEC. 098680 098690 TR-999. 098700 EXIT. 098710 EJECT 098720****************************************************************** 098730* PROGRAMM VERLASSEN 098740****************************************************************** 098750 098760 XCTL SECTION. 098770 098780 XC-000. 098790 MOVE 5 TO 098800 FEHL-NR 098810 CA-FEHLNR 098820 MOVE CA-TRANS TO FEHL-VAR1 098830 PERFORM FEHLMELD 098840 MOVE 'SN' TO X-CICS-FUNCTION 098850 MOVE M8MSGO TO X-CICS-MAP 098860 EXEC CICS LINK 098870 PROGRAM ( 'XTPOUT' ) 098880 COMMAREA ( X-CICS-PARAM ) 098890 LENGTH ( X-CICS-PARAM-LNG ) 098900 END-EXEC 098910 MOVE X-CICS-RETCODE TO EIBRESP 098920 EXEC CICS RETURN 098930 END-EXEC. 098940* EXEC CICS SEND 098950* FROM (M8MSGO) 098960* LENGTH (77) 098970* WAIT 098980* ERASE 098990* END-EXEC. 099000 099010 XC-999. 099020 EXIT. 099030 EJECT 099040****************************************************************** 099050* CROSS-JUMPER AUFRUFEN 099060****************************************************************** 099070 099080 XJUMP SECTION. 099090 099100 XJ-000. 099110 MOVE M8XJUMPI TO P1-XM229 099120 MOVE K-XM229 TO P200-1 099130 CALL 'XM200' 099140 USING 099150 P-P008 099160 P200-1 099170 P1-XM229 099180 P2-XM229 099190 P3-XM229 099200 PERFORM MODULE 099210 MOVE P1-XM229 TO CA-CIXJUMP 099220 MOVE CA-SPR TO XM179-SPRCD 099230 MOVE CA-CIXACT TO XM179-TRANS 099240 EXEC CICS LINK 099250 PROGRAM ( 'XM179' ) 099260 COMMAREA ( XM179-P ) 099270 LENGTH ( XM179L ) 099280 END-EXEC 099290 IF XM179-TEXT = SPACE 099300 MOVE 25 TO 099310 FEHL-NR 099320 CA-FEHLNR 099330 MOVE CA-CIXACT TO FEHL-VAR1 099340 MOVE DFHBMBRY TO M8XJUMPA 099350 MOVE -1 TO M8XJUMPL 099360 MOVE 1 TO 099370 SWFEHL 099380 CA-SWFEHL 099390 GO XJ-999 099400 END-IF 099410 MOVE ZERO TO CA-SCHRITT 099420 MOVE 'G' TO P1-XM269 099430 MOVE K-XM269 TO P200-1 099440 CALL 'XM200' 099450 USING 099460 P-P008 099470 P200-1 099480 P1-XM269 099490 PERFORM MODULE 099500 IF CA-SWAC = 'C' 099510 EXEC CICS XCTL 099520 PROGRAM ( 'D007' ) 099530 COMMAREA ( COMMAREA ) 099540 LENGTH ( 1650 ) 099550 END-EXEC 099560**** *** XXXXXX, XXXXXXX *** 099570 ELSE 099580 EXEC CICS XCTL 099590 PROGRAM ( 'P007' ) 099600 COMMAREA ( COMMAREA ) 099610 LENGTH ( 1650 ) 099620 END-EXEC 099630 END-IF. 099640**** *** CONTISSIIMO *** 099650 099660 XJ-999. 099670 EXIT. 099680****************************************************************** 099690**** ENDE SOURCE DBRIP08 099700******************************************************************