000010****************************************************************** 000020 000030 000040 IDENTIFICATION DIVISION. 000050 000060****************************************************************** 000070 000080 PROGRAM-ID. DBRIP08. 000090 000100 AUTHOR. XXXX XXXXXX 000110 000120 XXXX XXXXX. 000130 000140 DATE-WRITTEN. DEC-1991. 000150 000160****************************************************************** 000170 000180 000190 PROCEDURE DIVISION. 000200 000210****************************************************************** 000220****************************************************************** 000230* STEUER PROCEDURE 000240****************************************************************** 000250 000260 STEUER SECTION. 000270 000280 ST-000. 000290 PERFORM VORVERARB 000300 PERFORM ST-100 000310 PERFORM ST-990. 000320 000330 ST-999. 000340 GOBACK. 000350 EJECT 000360****************************************************************** 000370* VORVERARBEITUNG 000380****************************************************************** 000390 000400 VORVERARB SECTION. 000410 000420 VV-000. 000430 MOVE DFHCOMMAREA TO COMMAREA 000440 MOVE +6000 TO CA-LENGTH 000450 MOVE LOW-VALUE TO DBRIM8DI 000460 PERFORM VV-100. 000470 000480 VV-999. 000490 EXIT. 000500 EJECT 000510****************************************************************** 000520* HAUPTVERARBEITUNG 000530****************************************************************** 000540 000550 HAUPTVERARB SECTION. 000560 000570 HV-000. 000580 IF CA-SCHRITT = ZERO 000590 PERFORM HV-500 000600 GO HV-999 000610 END-IF. 000620 000630 HV-050. 000640**** HANDLING PF-FUNKTIONEN 000650 EVALUATE SWPF 000660 WHEN 1 GO HV-81 000670 WHEN 2 GO HV-82 000680 WHEN 3 000690 PERFORM HV-83 000700 GO HV-84 000710 WHEN 4 GO HV-84 000720 WHEN 5 GO HV-85 000730 WHEN 6 GO HV-86 000740 WHEN 7 GO HV-87 000750 WHEN 8 GO HV-88 000760 WHEN 9 GO HV-89 000770 WHEN 10 000780 PERFORM HV-90 000790 GO HV-91 000800 WHEN 11 GO HV-91 000810 WHEN 12 GO HV-92 000820 WHEN 13 GO HV-93 000830 WHEN 14 GO HV-94 000840 WHEN 15 000850 PERFORM HV-95 000860 GO HV-999 000870 WHEN 16 000880 PERFORM HV-96 000890 GO HV-999 000900 END-EVALUATE. 000910 000920 HV-81. 000930**** PF1-TASTE (HELP-PROGRAMM) 000940 PERFORM HV-95 000950 GO HV-999. 000960 000970 HV-94. 000980**** CLEAR (SENDEN LEERE MASKE) 000990 PERFORM HV-83 001000 GO HV-84. 001010 001020 HV-82. 001030**** PF2-TASTE / PRINTER-AUFRUF 001040 MOVE 2 TO CA-SWPF 001050 MOVE 0 TO CA-SCHRITT 001060 EXEC CICS LINK 001070 PROGRAM ( 'D154' ) 001080 END-EXEC 001090 GO HV-999. 001100 001110 HV-84. 001120**** PF4-TASTE 001130 PERFORM HV-95 001140 GO HV-999. 001150 001160 HV-85. 001170**** PF5-TASTE 001180 PERFORM HV-95 001190 GO HV-999. 001200 001210 HV-86. 001220**** PF6-TASTE 001230 PERFORM HV-95 001240 GO HV-999. 001250 001260 HV-87. 001270* PF7-TASTE 001280**** RUECKWAERTS BLAETTERN (INDIV.) 001290 PERFORM HV-95 001300 GO HV-999. 001310 001320 HV-88. 001330* PF8-TASTE 001340**** VORWAERTS BLAETTERN (INDIV.) 001350 PERFORM HV-95 001360 GO HV-999. 001370 001380 HV-89. 001390**** PF9-TASTE 001400 PERFORM HV-95 001410 GO HV-999. 001420 001430 HV-91. 001440**** PF11-TASTE 001450**** AUSDRUCKEN: ZUERST NORMALE VER- 001460**** ARBEITUNG (PLAUSI ETC.) 001470 PERFORM HV-200 001480 GO HV-999. 001490 001500 HV-92. 001510**** PF12 - ENDE DER TRANSAKTION 001520**** BILDSCHIRM AUF GROSS UMSCHALTEN 001530 MOVE 'G' TO P1-XM269 001540 MOVE K-XM269 TO P200-1 001550 CALL 'XM200' 001560 USING 001570 P-P008 001580 P200-1 001590 P1-XM269 001600 PERFORM MODULE 001610 MOVE 99 TO SWPF 001620 GO HV-999. 001630 001640 HV-93. 001650**** ENTER (EMPFANGEN SCREEN) 001660 PERFORM HV-200 001670 GO HV-999. 001680 001690 HV-999. 001700 EXIT. 001710 EJECT 001720****************************************************************** 001730****************************************************************** 001740* PROGRAMM - SUBROUTINEN ---> PLAUSI UND VERARB <--- 001750****************************************************************** 001760****************************************************************** 001770****************************************************************** 001780* PLAUSIBILITAET 001790****************************************************************** 001800 001810 PLAUSI SECTION. 001820 001830 PL-000. 001840 MOVE ZERO TO 001850 SWFEHL 001860 CA-SWFEHL 001870 IF CA-SCHRITT > ZERO 001880 PERFORM PL-500 001890 PERFORM PL-510 001900 PERFORM PL-520 001910 PERFORM PL-530 001920 PERFORM PL-540 001930 PERFORM PL-560 001940 PERFORM PL-590 001950 PERFORM PL-620 001960 PERFORM PL-690 001970 ELSE 001980 PERFORM PL-100 001990 END-IF. 002000 002010 PL-999. 002020 EXIT. 002030 EJECT 002040****************************************************************** 002050* VERARBEITUNG 002060****************************************************************** 002070 002080 VERARB SECTION. 002090 002100 VA-000. 002110 IF CA-SCHRITT > ZERO 002120 CONTINUE 002130 PERFORM VA-500 002140 ELSE 002150 MOVE 1 TO CA-SCHRITT 002160 DIVIDE CA-LB-SALDO BY CA-LB-RATE GIVING 002170 CA-LB-ANZRA 002180 REMAINDER 002190 R-REST 002200 IF R-REST NOT = ZERO 002210 MOVE 'Q' TO M8ANZRAA 002220 MOVE DFHBMBRY TO M8RATEA 002230 MOVE -1 TO M8ANZRAL 002240 MOVE 349 TO 002250 FEHL-NR 002260 CA-FEHLNR 002270 MOVE 1 TO SWFEHL 002280 END-IF 002290 END-IF. 002300 002310 VA-999. 002320 EXIT. 002330 EJECT 002340****************************************************************** 002350****************************************************************** 002360* DIVERSE - SUBROUTINEN 002370****************************************************************** 002380****************************************************************** 002390****************************************************************** 002400* FUELLEN COMMON-AREA 002410****************************************************************** 002420 002430 CAFILL SECTION. 002440 002450 CA-000. 002460 IF M8PRIDL > ZERO 002470 MOVE M8PRIDI TO CA-PRINTER 002480 END-IF 002490 IF M8PRIDF = X80 002500 MOVE SPACE TO CA-PRINTER 002510 END-IF 002520 IF M8CANL > ZERO 002530 MOVE M8CANI TO CA-SCHACHTX 002540 END-IF 002550 IF M8CANF = X80 002560 MOVE ZERO TO CA-SCHACHT 002570 END-IF 002580 IF M8ABS1L > ZERO 002590 MOVE M8ABS1I TO CA-ABS1 002600 END-IF 002610 IF M8ABS1F = X80 002620 MOVE SPACE TO CA-ABS1 002630 END-IF 002640 IF M8ABS2L > ZERO 002650 MOVE M8ABS2I TO CA-ABS2 002660 END-IF 002670 IF M8ABS2F = X80 002680 MOVE SPACE TO CA-ABS2 002690 END-IF 002700 IF M8ABS3L > ZERO 002710 MOVE M8ABS3I TO CA-ABS3 002720 END-IF 002730 IF M8ABS3F = X80 002740 MOVE SPACE TO CA-ABS3 002750 END-IF 002760 IF M8ABS4L > ZERO 002770 MOVE M8ABS4I TO CA-ABS4 002780 END-IF 002790 IF M8ABS4F = X80 002800 MOVE SPACE TO CA-ABS4 002810 END-IF 002820 IF M8ADRZ1L > ZERO 002830 MOVE M8ADRZ1I TO CA-ADRZ1 002840 END-IF 002850 IF M8ADRZ1F = X80 002860 MOVE SPACE TO CA-ADRZ1 002870 END-IF 002880 IF M8ADRZ2L > ZERO 002890 MOVE M8ADRZ2I TO CA-ADRZ2 002900 END-IF 002910 IF M8ADRZ2F = X80 002920 MOVE SPACE TO CA-ADRZ2 002930 END-IF 002940 IF M8ADRZ3L > ZERO 002950 MOVE M8ADRZ3I TO CA-ADRZ3 002960 END-IF 002970 IF M8ADRZ3F = X80 002980 MOVE SPACE TO CA-ADRZ3 002990 END-IF 003000 IF M8ADRZ4L > ZERO 003010 MOVE M8ADRZ4I TO CA-ADRZ4 003020 END-IF 003030 IF M8ADRZ4F = X80 003040 MOVE SPACE TO CA-ADRZ4 003050 END-IF 003060 IF M8ADRZ5L > ZERO 003070 MOVE M8ADRZ5I TO CA-ADRZ5 003080 END-IF 003090 IF M8ADRZ5F = X80 003100 MOVE SPACE TO CA-ADRZ5 003110 END-IF 003120 IF M8ADSW1L > ZERO 003130 MOVE M8ADSW1I TO CA-ADRSW1 003140 END-IF 003150 IF M8ADSW1F = X80 003160 MOVE SPACE TO CA-ADRSW1 003170 END-IF 003180 IF M8ADSW2L > ZERO 003190 MOVE M8ADSW2I TO CA-ADRSW2 003200 END-IF 003210 IF M8ADSW2F = X80 003220 MOVE SPACE TO CA-ADRSW2 003230 END-IF 003240 IF M8ADSW3L > ZERO 003250 MOVE M8ADSW3I TO CA-ADRSW3 003260 END-IF 003270 IF M8ADSW3F = X80 003280 MOVE SPACE TO CA-ADRSW3 003290 END-IF 003300 IF M8ADSW4L > ZERO 003310 MOVE M8ADSW4I TO CA-ADRSW4 003320 END-IF 003330 IF M8ADSW4F = X80 003340 MOVE SPACE TO CA-ADRSW4 003350 END-IF 003360 IF M8SACHTL > ZERO 003370 MOVE M8SACHTI TO CA-SACHBT 003380 END-IF 003390 IF M8SACHTF = X80 003400 MOVE SPACE TO CA-SACHBT 003410 END-IF 003420 IF M8SACH1L > ZERO 003430 MOVE M8SACH1I TO CA-SACHB1 003440 END-IF 003450 IF M8SACH1F = X80 003460 MOVE SPACE TO CA-SACHB1 003470 END-IF 003480 IF M8SACH2L > ZERO 003490 MOVE M8SACH2I TO CA-SACHB2 003500 END-IF 003510 IF M8SACH2F = X80 003520 MOVE SPACE TO CA-SACHB2 003530 END-IF 003540 IF M8ANREDL > ZERO 003550 MOVE M8ANREDI TO CA-ANRED 003560 END-IF 003570 IF M8ANREDF = X80 003580 MOVE SPACE TO CA-ANRED 003590 END-IF 003600 IF M8ERDATL > ZERO 003610 MOVE M8ERDATI TO CA-LB-ERDAT 003620 END-IF 003630 IF M8ERDATF = X80 003640 MOVE SPACE TO CA-LB-ERDAT 003650 END-IF 003660 IF M8MENDZL > ZERO 003670 MOVE M8MENDZI TO CA-LB-MENDZ 003680 END-IF 003690 IF M8MENDZF = X80 003700 MOVE SPACE TO CA-LB-MENDZ 003710 END-IF 003720 IF M8MENDVL > ZERO 003730 MOVE M8MENDVI TO CA-LB-MENDV 003740 END-IF 003750 IF M8MENDVF = X80 003760 MOVE SPACE TO CA-LB-MENDV 003770 END-IF 003780 IF M8OBJL > ZERO 003790 MOVE M8OBJI TO CA-LB-OBJ 003800 END-IF 003810 IF M8OBJF = X80 003820 MOVE SPACE TO CA-LB-OBJ 003830 END-IF 003840 IF M8UEBETL > ZERO 003850 MOVE K-XM246 TO P200-1 003860 CALL 'XM200' 003870 USING 003880 P-P008 003890 P200-1 003900 XM246-P1 003910 M8UEBETI 003920 CA-LB-UEBET 003930 Z-UEBET 003940 PERFORM MODULE 003950 END-IF 003960 IF M8UEBETF = X80 003970 MOVE ZERO TO CA-LB-UEBET 003980 MOVE SPACE TO Z-UEBET 003990 END-IF 004000 IF M8KAUTIL > ZERO 004010 MOVE K-XM246 TO P200-1 004020 CALL 'XM200' 004030 USING 004040 P-P008 004050 P200-1 004060 XM246-P1 004070 M8KAUTII 004080 CA-LB-KAUTI 004090 Z-KAUTI 004100 PERFORM MODULE 004110 END-IF 004120 IF M8KAUTIF = X80 004130 MOVE ZERO TO CA-LB-KAUTI 004140 MOVE SPACE TO Z-KAUTI 004150 END-IF 004160 IF M8ZGUTL > ZERO 004170 MOVE K-XM246 TO P200-1 004180 CALL 'XM200' 004190 USING 004200 P-P008 004210 P200-1 004220 XM246-P1 004230 M8ZGUTI 004240 CA-LB-ZGUT 004250 Z-ZGUT 004260 PERFORM MODULE 004270 END-IF 004280 IF M8ZGUTF = X80 004290 MOVE ZERO TO CA-LB-ZGUT 004300 MOVE SPACE TO Z-ZGUT 004310 END-IF 004320 IF M8ANZRAL > ZERO 004330 MOVE M8ANZRAI TO CA-LB-ANZRA 004340 END-IF 004350 IF M8ANZRAF = X80 004360 MOVE ZERO TO CA-LB-ANZRA 004370 END-IF 004380 IF M8RATEL > ZERO 004390 MOVE K-XM246 TO P200-1 004400 CALL 'XM200' 004410 USING 004420 P-P008 004430 P200-1 004440 XM246-P1 004450 M8RATEI 004460 R-RATE 004470 Z-RATE 004480 PERFORM MODULE 004490 MOVE R-RATE TO CA-LB-RATE 004500 END-IF 004510 IF M8RATEF = X80 004520 MOVE ZERO TO CA-LB-RATE 004530 MOVE SPACE TO Z-RATE 004540 END-IF 004550 IF M8FZ1L > ZERO 004560 MOVE M8FZ1I TO CA-FZ-1 004570 END-IF 004580 IF M8FZ1F = X80 004590 MOVE SPACE TO CA-FZ-1 004600 END-IF 004610 IF M8FZ2L > ZERO 004620 MOVE M8FZ2I TO CA-FZ-2 004630 END-IF 004640 IF M8FZ2F = X80 004650 MOVE SPACE TO CA-FZ-2 004660 END-IF 004670 IF M8FZ3L > ZERO 004680 MOVE M8FZ3I TO CA-FZ-3 004690 END-IF 004700 IF M8FZ3F = X80 004710 MOVE SPACE TO CA-FZ-3 004720 END-IF 004730 IF M8XJUMPL > ZERO 004740 PERFORM XJUMP 004750 END-IF. 004760 004770 CA-999. 004780 EXIT. 004790 EJECT 004800****************************************************************** 004810* FEHLERMELDUNG HOLEN (XM181) 004820****************************************************************** 004830 004840 FEHLMELD SECTION. 004850 004860 FM-000. 004870 MOVE CA-SPR TO FEHL-SPR 004880 EXEC CICS LINK 004890 PROGRAM ( 'XM181' ) 004900 COMMAREA ( XM181-P ) 004910 LENGTH ( XM181L ) 004920 END-EXEC 004930 MOVE FEHL-MELD TO M8MSGO 004940 MOVE SPACE TO 004950 FEHL-VAR1 004960 FEHL-VAR2 004970 FEHL-VAR3 004980 FEHL-VAR4 004990 FEHL-VAR5 005000 FEHL-VAR6. 005010 005020 FM-999. 005030 EXIT. 005040 EJECT 005050****************************************************************** 005060* MODULE-AUFRUF-INTERFACE (P008) 005070****************************************************************** 005080 005090 MODULE SECTION. 005100 005110 MO-000. 005120 EXEC CICS LINK 005130 PROGRAM ( 'P008' ) 005140 COMMAREA ( P-P008 ) 005150 LENGTH ( P-P008L ) 005160 END-EXEC. 005170 005180 MO-999. 005190 EXIT. 005200 EJECT 005210****************************************************************** 005220* LINK-PROGRAMME AUFRUFEN 005230****************************************************************** 005240 005250 PRGLINK SECTION. 005260 005270 PRG-000. 005280 EXEC CICS LINK 005290 PROGRAM ( 'DBRIP58' ) 005300 COMMAREA ( COMMAREA ) 005310 LENGTH ( CA-LENGTH ) 005320 END-EXEC. 005330 005340 PRG-999. 005350 EXIT. 005360 EJECT 005370****************************************************************** 005380* UEBERTRAGEN CA --> SCREEN 005390****************************************************************** 005400**** (INDIVIDUELLE VERARBEITUNG) 005410 005420 SCREENFILL SECTION. 005430 005440 SC-000. 005450 MOVE CA-RKDN1X TO M8REF1O 005460 MOVE CA-RKDN2X TO M8REF2O 005470 MOVE CA-VNRX TO M8VNRO 005480 MOVE CA-PRINTER TO M8PRIDO 005490 MOVE CA-SCHACHT TO M8CANO 005500 MOVE CA-BRIEF TO M8BRIEFO 005510 MOVE CA-ABS1 TO M8ABS1O 005520 MOVE CA-ABS2 TO M8ABS2O 005530 MOVE CA-ABS3 TO M8ABS3O 005540 MOVE CA-ABS4 TO M8ABS4O 005550 MOVE CA-ADRZ1 TO M8ADRZ1O 005560 MOVE CA-ADRZ2 TO M8ADRZ2O 005570 MOVE CA-ADRZ3 TO M8ADRZ3O 005580 MOVE CA-ADRZ4 TO M8ADRZ4O 005590 MOVE CA-ADRZ5 TO M8ADRZ5O 005600 MOVE CA-ADRSW1 TO M8ADSW1O 005610 MOVE CA-ADRSW2 TO M8ADSW2O 005620 MOVE CA-ADRSW3 TO M8ADSW3O 005630 MOVE CA-ADRSW4 TO M8ADSW4O 005640 MOVE CA-SACHBT TO M8SACHTO 005650 MOVE CA-SACHB1 TO M8SACH1O 005660 MOVE CA-SACHB2 TO M8SACH2O 005670 MOVE CA-ANRED TO M8ANREDO 005680 MOVE CA-LB-ERDAT TO M8ERDATO 005690 MOVE CA-LB-MENDZ TO M8MENDZO 005700 MOVE CA-LB-MENDV TO M8MENDVO 005710 MOVE CA-LB-OBJ TO M8OBJO 005720 IF Z-UEBET = SPACE 005730 IF CA-LB-UEBET = ZERO 005740 MOVE SPACE TO M8UEBETO 005750 ELSE 005760 MOVE CA-LB-UEBET TO MO-BETRA 005770 MOVE MO-BETRAX TO M8UEBETO 005780 END-IF 005790 ELSE 005800 MOVE Z-UEBET TO M8UEBETO 005810 END-IF 005820 IF Z-KAUTI = SPACE 005830 IF CA-LB-KAUTI = ZERO 005840 MOVE SPACE TO M8KAUTIO 005850 ELSE 005860 MOVE CA-LB-KAUTI TO MO-BETRA 005870 MOVE MO-BETRAX TO M8KAUTIO 005880 END-IF 005890 ELSE 005900 MOVE Z-KAUTI TO M8KAUTIO 005910 END-IF 005920 IF Z-ZGUT = SPACE 005930 IF CA-LB-ZGUT = ZERO 005940 MOVE SPACE TO M8ZGUTO 005950 ELSE 005960 MOVE CA-LB-ZGUT TO MO-BETRA 005970 MOVE MO-BETRAX TO M8ZGUTO 005980 END-IF 005990 ELSE 006000 MOVE Z-ZGUT TO M8ZGUTO 006010 END-IF 006020 MOVE CA-LB-ANZRA TO M8ANZRAO 006030 IF Z-RATE = SPACE 006040 IF CA-LB-RATE = ZERO 006050 MOVE SPACE TO M8RATEO 006060 ELSE 006070 MOVE CA-LB-RATE TO MO-BETRA 006080 MOVE MO-BETRAX TO M8RATEO 006090 END-IF 006100 ELSE 006110 MOVE Z-RATE TO M8RATEO 006120 END-IF 006130 MOVE CA-FZ-1 TO M8FZ1O 006140 MOVE CA-FZ-2 TO M8FZ2O 006150 MOVE CA-FZ-3 TO M8FZ3O. 006160 006170 SC-999. 006180 EXIT. 006190 EJECT 006200****************************************************************** 006210* IDENT-FELDER IN SCREEN FUELLEN 006220****************************************************************** 006230 006240 SCRIDENT SECTION. 006250 006260 SI-000. 006270 MOVE EIBTRMID TO TID 006280 MOVE EIBTIME TO Z-TIME 006290 MOVE K-XM278 TO P200-1 006300 CALL 'XM200' 006310 USING 006320 P-P008 006330 P200-1 006340 Z-DATE 006350 PERFORM MODULE 006360 MOVE TIMR1 TO HH 006370 MOVE TIMR2 TO MI 006380 MOVE TIMR3 TO SS 006390 MOVE DATR0 TO 006400 TT 006410 Z-DAT0 006420 MOVE DATR1 TO 006430 MM 006440 Z-DAT1 006450 MOVE DATR2 TO 006460 YY 006470 Z-DAT2 006480 MOVE CA-KKZ TO OPID 006490 MOVE CA-BURO TO GS 006500 MOVE K-XM014A TO P200-1 006510 CALL 'XM200' 006520 USING 006530 P-P008 006540 P200-1 006550 CA-FIRMA 006560 FA 006570 PERFORM MODULE 006580 MOVE CA-TRANS TO TRANS 006590 MOVE W-IDE TO M8IDEO 006600 MOVE W-IDA TO M8IDAO. 006610 006620 SI-999. 006630 EXIT. 006640 EJECT 006650****************************************************************** 006660* GEWUENSCHTE LEERZEILEN IN ADRESSE INSERTEN 006670****************************************************************** 006680 006690 ADRINSERT SECTION. 006700 006710 AI-000. 006720 IF CA-ADRSW4 NOT = SPACE 006730 MOVE CA-ADRZ4 TO CA-ADRZ5 006740 MOVE SPACE TO CA-ADRZ4 006750 MOVE SPACE TO CA-ADRSW4 006760 MOVE -1 TO M8ADRZ4L 006770 END-IF 006780 IF CA-ADRSW3 NOT = SPACE 006790 MOVE CA-ADRZ4 TO CA-ADRZ5 006800 MOVE CA-ADRZ3 TO CA-ADRZ4 006810 MOVE SPACE TO CA-ADRZ3 006820 MOVE SPACE TO CA-ADRSW3 006830 MOVE -1 TO M8ADRZ3L 006840 END-IF 006850 IF CA-ADRSW2 NOT = SPACE 006860 MOVE CA-ADRZ4 TO CA-ADRZ5 006870 MOVE CA-ADRZ3 TO CA-ADRZ4 006880 MOVE CA-ADRZ2 TO CA-ADRZ3 006890 MOVE SPACE TO CA-ADRZ2 006900 MOVE SPACE TO CA-ADRSW2 006910 MOVE -1 TO M8ADRZ2L 006920 END-IF 006930 IF CA-ADRSW1 NOT = SPACE 006940 MOVE CA-ADRZ4 TO CA-ADRZ5 006950 MOVE CA-ADRZ3 TO CA-ADRZ4 006960 MOVE CA-ADRZ2 TO CA-ADRZ3 006970 MOVE CA-ADRZ1 TO CA-ADRZ2 006980 MOVE SPACE TO CA-ADRZ1 006990 MOVE SPACE TO CA-ADRSW1 007000 MOVE -1 TO M8ADRZ1L 007010 END-IF. 007020 007030 AI-999. 007040 EXIT. 007050 EJECT 007060****************************************************************** 007070* LEERZEILEN AUS ADRESSE ELIMINIEREN UND SWITCHERS MITSCHIEBEN 007080****************************************************************** 007090 007100 ADRKOMPR SECTION. 007110 007120 AK-000. 007130 MOVE CA-ADRSW1 TO P1-XM314-ADRSW ( 1 ) 007140 MOVE CA-ADRZ1 TO P1-XM314-ADRZ ( 1 ) 007150 MOVE CA-ADRSW2 TO P1-XM314-ADRSW ( 2 ) 007160 MOVE CA-ADRZ2 TO P1-XM314-ADRZ ( 2 ) 007170 MOVE CA-ADRSW3 TO P1-XM314-ADRSW ( 3 ) 007180 MOVE CA-ADRZ3 TO P1-XM314-ADRZ ( 3 ) 007190 MOVE CA-ADRSW4 TO P1-XM314-ADRSW ( 4 ) 007200 MOVE CA-ADRZ4 TO P1-XM314-ADRZ ( 4 ) 007210 MOVE SPACE TO P1-XM314-ADRSW ( 5 ) 007220 MOVE CA-ADRZ5 TO P1-XM314-ADRZ ( 5 ) 007230 MOVE K-XM314 TO P200-1 007240 CALL 'XM200' 007250 USING 007260 P-P008 007270 P200-1 007280 P1-XM314 007290 P2-XM314 007300 PERFORM MODULE 007310 MOVE P1-XM314-ADRSW ( 1 ) TO CA-ADRSW1 007320 MOVE P1-XM314-ADRZ ( 1 ) TO CA-ADRZ1 007330 MOVE P1-XM314-ADRSW ( 2 ) TO CA-ADRSW2 007340 MOVE P1-XM314-ADRZ ( 2 ) TO CA-ADRZ2 007350 MOVE P1-XM314-ADRSW ( 3 ) TO CA-ADRSW3 007360 MOVE P1-XM314-ADRZ ( 3 ) TO CA-ADRZ3 007370 MOVE P1-XM314-ADRSW ( 4 ) TO CA-ADRSW4 007380 MOVE P1-XM314-ADRZ ( 4 ) TO CA-ADRZ4 007390 MOVE P1-XM314-ADRZ ( 5 ) TO CA-ADRZ5. 007400 007410 AK-999. 007420 EXIT. 007430 EJECT 007440****************************************************************** 007450****************************************************************** 007460* C I C S - SUBROUTINEN 007470****************************************************************** 007480****************************************************************** 007490****************************************************************** 007500* SENDEN SCREEN 007510****************************************************************** 007520 007530 SENDEN SECTION. 007540 007550 SE-000. 007560 PERFORM SCRIDENT 007570 PERFORM SCREENFILL 007580 MOVE -1 TO M8SACHTL 007590 IF CA-SPR = 2 007600 CONTINUE 007610 PERFORM SE-100 007620 ELSE 007630 MOVE 'SN' TO X-CICS-FUNCTION 007640 MOVE DBRIM8DO TO X-CICS-MAP 007650 EXEC CICS LINK 007660 PROGRAM ( 'XTPOUT' ) 007670 COMMAREA ( X-CICS-PARAM ) 007680 LENGTH ( X-CICS-PARAM-LNG ) 007690 END-EXEC 007700 MOVE X-CICS-RETCODE TO EIBRESP 007710 END-IF. 007720 007730 SE-999. 007740 EXIT. 007750 EJECT 007760****************************************************************** 007770* SENDEN SCREEN MIT FEHLERMELDUNG 007780****************************************************************** 007790 007800 SENDFEHL SECTION. 007810 007820 SF-000. 007830 PERFORM SCRIDENT 007840 PERFORM SCREENFILL 007850 IF M8MSGO = LOW-VALUE 007860 MOVE 'ABER...ABER...PROGRAMMIERFEHLER' TO M8MSGO 007870 END-IF 007880 IF CA-SPR = 2 007890 CONTINUE 007900 PERFORM SF-100 007910 ELSE 007920 MOVE 'SN' TO X-CICS-FUNCTION 007930 MOVE DBRIM8DO TO X-CICS-MAP 007940 EXEC CICS LINK 007950 PROGRAM ( 'XTPOUT' ) 007960 COMMAREA ( X-CICS-PARAM ) 007970 LENGTH ( X-CICS-PARAM-LNG ) 007980 END-EXEC 007990 MOVE X-CICS-RETCODE TO EIBRESP 008000 END-IF. 008010 008020 SF-999. 008030 EXIT. 008040 EJECT 008050****************************************************************** 008060* SCREEN EMPFANGEN 008070****************************************************************** 008080 008090 RECEIVEN SECTION. 008100 008110 RE-000. 008120 MOVE LOW-VALUE TO DBRIM8DI 008130 IF CA-SPR = 2 008140 CONTINUE 008150 PERFORM RE-100 008160 ELSE 008170 MOVE 'RC' TO X-CICS-FUNCTION 008180 MOVE DBRIM8DI TO X-CICS-MAP 008190 EXEC CICS LINK 008200 PROGRAM ( 'XTPINP' ) 008210 COMMAREA ( X-CICS-PARAM ) 008220 LENGTH ( X-CICS-PARAM-LNG ) 008230 END-EXEC 008240 MOVE X-CICS-RETCODE TO EIBRESP 008250 EVALUATE TRUE 008260 WHEN X-MAPFAIL 008270* GO TO VV-860 008280 PERFORM VV-860 008290 WHEN X-PF1 008300* GO TO VV-710 008310 PERFORM VV-710 008320 WHEN X-PF2 008330* GO TO VV-720 008340 PERFORM VV-720 008350 WHEN X-PF3 008360* GO TO VV-730 008370 PERFORM VV-730 008380 WHEN X-PF10 008390* GO TO VV-800 008400 PERFORM VV-800 008410 WHEN X-PF11 008420* GO TO VV-810 008430 PERFORM VV-810 008440 WHEN X-PF12 008450* GO TO VV-820 008460 PERFORM VV-820 008470 WHEN X-CLEAR 008480* GO TO VV-840 008490 PERFORM VV-840 008500 WHEN X-ANYKEY 008510* GO TO VV-850 008520 PERFORM VV-850 008530 END-EVALUATE 008540 END-IF. 008550 008560 RE-999. 008570 EXIT. 008580 EJECT 008590****************************************************************** 008600* PROGRAMM MIT RETURN TRANSID VERLASSEN 008610****************************************************************** 008620 008630 TRANSID SECTION. 008640 008650 TR-000. 008660 EXEC CICS RETURN 008670 TRANSID ( CA-TRANS ) 008680 COMMAREA ( COMMAREA ) 008690 LENGTH ( CA-LENGTH ) 008700 END-EXEC. 008710 008720 TR-999. 008730 EXIT. 008740 EJECT 008750****************************************************************** 008760* PROGRAMM VERLASSEN 008770****************************************************************** 008780 008790 XCTL SECTION. 008800 008810 XC-000. 008820 MOVE 5 TO 008830 FEHL-NR 008840 CA-FEHLNR 008850 MOVE CA-TRANS TO FEHL-VAR1 008860 PERFORM FEHLMELD 008870 MOVE 'SN' TO X-CICS-FUNCTION 008880 MOVE M8MSGO TO X-CICS-MAP 008890 EXEC CICS LINK 008900 PROGRAM ( 'XTPOUT' ) 008910 COMMAREA ( X-CICS-PARAM ) 008920 LENGTH ( X-CICS-PARAM-LNG ) 008930 END-EXEC 008940 MOVE X-CICS-RETCODE TO EIBRESP 008950 EXEC CICS RETURN 008960 END-EXEC. 008970* EXEC CICS SEND 008980* FROM (M8MSGO) 008990* LENGTH (77) 009000* WAIT 009010* ERASE 009020* END-EXEC. 009030 009040 XC-999. 009050 EXIT. 009060 EJECT 009070****************************************************************** 009080* CROSS-JUMPER AUFRUFEN 009090****************************************************************** 009100 009110 XJUMP SECTION. 009120 009130 XJ-000. 009140 MOVE M8XJUMPI TO P1-XM229 009150 MOVE K-XM229 TO P200-1 009160 CALL 'XM200' 009170 USING 009180 P-P008 009190 P200-1 009200 P1-XM229 009210 P2-XM229 009220 P3-XM229 009230 PERFORM MODULE 009240 MOVE P1-XM229 TO CA-CIXJUMP 009250 MOVE CA-SPR TO XM179-SPRCD 009260 MOVE CA-CIXACT TO XM179-TRANS 009270 EXEC CICS LINK 009280 PROGRAM ( 'XM179' ) 009290 COMMAREA ( XM179-P ) 009300 LENGTH ( XM179L ) 009310 END-EXEC 009320 IF XM179-TEXT = SPACE 009330 MOVE 25 TO 009340 FEHL-NR 009350 CA-FEHLNR 009360 MOVE CA-CIXACT TO FEHL-VAR1 009370 MOVE DFHBMBRY TO M8XJUMPA 009380 MOVE -1 TO M8XJUMPL 009390 MOVE 1 TO 009400 SWFEHL 009410 CA-SWFEHL 009420 ELSE 009430 MOVE ZERO TO CA-SCHRITT 009440 MOVE 'G' TO P1-XM269 009450 MOVE K-XM269 TO P200-1 009460 CALL 'XM200' 009470 USING 009480 P-P008 009490 P200-1 009500 P1-XM269 009510 PERFORM MODULE 009520 IF CA-SWAC = 'C' 009530 EXEC CICS XCTL 009540 PROGRAM ( 'D007' ) 009550 COMMAREA ( COMMAREA ) 009560 LENGTH ( 1650 ) 009570 END-EXEC 009580**** *** XXXXXX, XXXXXXX *** 009590 ELSE 009600 EXEC CICS XCTL 009610 PROGRAM ( 'P007' ) 009620 COMMAREA ( COMMAREA ) 009630 LENGTH ( 1650 ) 009640 END-EXEC 009650 END-IF 009660 END-IF. 009670**** *** CONTISSIIMO *** 009680 009690 XJ-999. 009700 EXIT. 009710****************************************************************** 009720**** ENDE SOURCE DBRIP08 009730****************************************************************** 009740 009750 BAR SECTION. 009760 009770 BAR-PARAGRAPH. 009780 STOP RUN. 009790 009800 STEUER-SUBROUTINES SECTION. 009810 009820 ST-100. 009830 PERFORM HAUPTVERARB. 009840 009850 ST-990. 009860 IF SWPF = 99 009870 PERFORM XCTL 009880 ELSE 009890 MOVE +6000 TO CA-LENGTH 009900 PERFORM TRANSID 009910 END-IF. 009920 009930 VORVERARB-SUBROUTINES SECTION. 009940 009950 VV-860. 009960**** M A P F A I L 009970 MOVE 16 TO SWPF. 009980 009990 VV-850. 010000**** ANYKEY-TASTE 010010 MOVE 15 TO SWPF. 010020 010030 VV-840. 010040**** CLEAR-TASTE 010050 MOVE 14 TO SWPF. 010060 010070 VV-820. 010080**** PF12-TASTE 010090 MOVE 12 TO SWPF. 010100 010110 VV-810. 010120**** PF11-TASTE 010130 MOVE 11 TO SWPF. 010140 010150 VV-800. 010160**** PF10-TASTE 010170 MOVE 10 TO SWPF. 010180 010190 VV-730. 010200**** PF3-TASTE 010210 MOVE 3 TO SWPF. 010220 010230 VV-720. 010240**** PF2-TASTE 010250 MOVE 2 TO SWPF. 010260 010270 VV-710. 010280**** PF1-TASTE 010290 MOVE 1 TO SWPF. 010300 010310 VV-700. 010320**** HANDLE AID UND CONDITION 010330* EXEC CICS HANDLE CONDITION MAPFAIL (VV-860) 010340* END-EXEC. 010350**** HANDLE AID 1. TEIL 010360* EXEC CICS HANDLE AID PF1 (VV-710) 010370* PF2 (VV-720) 010380* PF3 (VV-730) 010390* PF10 (VV-800) 010400* PF11 (VV-810) 010410* PF12 (VV-820) 010420* CLEAR (VV-840) 010430* ANYKEY (VV-850) 010440* END-EXEC. 010450**** R E C E I V E 010460 PERFORM RECEIVEN 010470 MOVE 13 TO SWPF. 010480 010490 VV-100. 010500 IF CA-SCHRITT = ZERO 010510 CONTINUE 010520 ELSE 010530 PERFORM VV-700 010540 END-IF. 010550 010560 HAUPTVERARB-SUBROUTINES SECTION. 010570 010580 HV-83. 010590**** PF3-TASTE 010600 MOVE 3 TO CA-SWPF 010610 MOVE 0 TO CA-SCHRITT 010620 EXEC CICS XCTL 010630 PROGRAM ( 'DBRIT' ) 010640 COMMAREA ( COMMAREA ) 010650 LENGTH ( CA-LENGTH ) 010660 END-EXEC. 010670 010680 HV-90. 010690**** PF10-TASTE 010700**** BILDSCHIRM AUF GROSS UMSCHALTEN 010710 MOVE 'G' TO P1-XM269 010720 MOVE K-XM269 TO P200-1 010730 CALL 'XM200' 010740 USING 010750 P-P008 010760 P200-1 010770 P1-XM269 010780 PERFORM MODULE 010790 MOVE ZERO TO CA-LENGTH 010800 EXEC CICS XCTL 010810 PROGRAM ( 'PF10T' ) 010820 COMMAREA ( COMMAREA ) 010830 LENGTH ( CA-LENGTH ) 010840 END-EXEC. 010850 010860 HV-900. 010870**** FEHLER 010880 PERFORM FEHLMELD 010890 PERFORM SENDFEHL 010900 MOVE 90 TO SWPF. 010910 010920 HV-800. 010930**** SENDEN SCREEN 010940 PERFORM SENDEN 010950 IF CA-SCHRITT = 0 010960 MOVE 1 TO CA-SCHRITT 010970 END-IF 010980 MOVE 80 TO SWPF. 010990 011000 HV-500. 011010**** AUFRUF DER VERARBEITUNG 011020* NACH ERFOLGREICHEN PLAUS-TESTS 011030 PERFORM VERARB 011040 IF SWFEHL > ZERO 011050 PERFORM HV-900 011060 ELSE 011070 PERFORM HV-800 011080 END-IF. 011090 011100 HV-300. 011110**** INPUT PRUEFEN 011120 PERFORM PLAUSI 011130 IF SWFEHL = ZERO 011140 CONTINUE 011150 PERFORM HV-500 011160 ELSE 011170 IF FEHL-NR = 0 011180 MOVE 3 TO 011190 FEHL-NR 011200 CA-FEHLNR 011210 END-IF 011220 PERFORM HV-900 011230 END-IF. 011240 011250 HV-200. 011260**** COMMONAREA MIT SCREENDATEN LADEN 011270 PERFORM CAFILL 011280 IF SWFEHL > ZERO 011290 PERFORM HV-900 011300 ELSE 011310 PERFORM HV-300 011320 END-IF. 011330 011340 HV-100. 011350**** INITIALISIEREN SCREEN 011360 MOVE LOW-VALUE TO DBRIM8DO 011370 PERFORM HV-800. 011380 011390 HV-97. 011400**** AUFRUF AUS CROSS-JUMPER 011410 PERFORM HV-200. 011420 011430 HV-96. 011440**** MAPFAIL (KEINE EINGABE) 011450 PERFORM HV-200. 011460 011470 HV-95. 011480**** ANYKEY (FALSCHE FUNKTIONS-TASTE) 011490 PERFORM CAFILL 011500 IF SWFEHL > ZERO 011510 CONTINUE 011520 ELSE 011530 MOVE LOW-VALUE TO DBRIM8DI 011540 MOVE 1 TO 011550 FEHL-NR 011560 CA-FEHLNR 011570 MOVE -1 TO M8SACHTL 011580 END-IF 011590 PERFORM HV-900. 011600 011610 PLAUSI-SUBROUTINES SECTION. 011620 011630 PL-500. 011640******** PRINTER PRUEFEN 011650******** *************** 011660 IF CA-PRINTER = SPACE 011670 MOVE DFHBMBRY TO M8PRIDA 011680 MOVE -1 TO M8PRIDL 011690 MOVE 3 TO 011700 FEHL-NR 011710 CA-FEHLNR 011720 MOVE 1 TO SWFEHL 011730 ELSE 011740 MOVE CA-PRINTER TO P1-XM229 011750 MOVE K-XM229 TO P200-1 011760 CALL 'XM200' 011770 USING 011780 P-P008 011790 P200-1 011800 P1-XM229 011810 P2-XM229 011820 P3-XM229 011830 PERFORM MODULE 011840 MOVE P1-XM229 TO CA-PRINTER 011850 MOVE 'G' TO BER-FUNC 011860 MOVE CA-PRINTER TO BER-PRTID 011870 EXEC CICS LINK 011880 PROGRAM ( 'XM177' ) 011890 COMMAREA ( P-XM177 ) 011900 LENGTH ( P-XM177L ) 011910 END-EXEC 011920 IF BER-RET1 = '1' 011930 MOVE DFHBMBRY TO M8PRIDA 011940 IF SWFEHL = ZERO 011950 MOVE -1 TO M8PRIDL 011960 MOVE 1 TO SWFEHL 011970 MOVE 96 TO 011980 FEHL-NR 011990 CA-FEHLNR 012000 END-IF 012010 END-IF 012020 END-IF. 012030 012040 PL-510. 012050******** SCHACHT PRUEFEN 012060******** *************** 012070 IF CA-SCHACHTX NOT NUMERIC 012080 MOVE 'Q' TO M8CANA 012090 IF SWFEHL = ZERO 012100 MOVE -1 TO M8CANL 012110 MOVE 1 TO SWFEHL 012120 MOVE 52 TO 012130 FEHL-NR 012140 CA-FEHLNR 012150 END-IF 012160 END-IF 012170 IF CA-SCHACHTX > '0' AND CA-SCHACHTX < '4' 012180 CONTINUE 012190 ELSE 012200 IF CA-SCHACHTX = '9' 012210 CONTINUE 012220 ELSE 012230 MOVE 'Q' TO M8CANA 012240 IF SWFEHL = ZERO 012250 MOVE -1 TO M8CANL 012260 MOVE 1 TO SWFEHL 012270 MOVE 3 TO 012280 FEHL-NR 012290 CA-FEHLNR 012300 END-IF 012310 END-IF 012320 END-IF. 012330 012340 PL-520. 012350******** MIND. 1 ABSENDERZEILE 012360******** ********************* 012370 IF CA-ABS1 = SPACE AND 012380 CA-ABS2 = SPACE AND CA-ABS3 = SPACE AND CA-ABS4 = SPACE 012390 MOVE DFHBMBRY TO 012400 M8ABS1A 012410 M8ABS2A 012420 M8ABS3A 012430 M8ABS4A 012440 IF SWFEHL = ZERO 012450 MOVE -1 TO M8ABS1L 012460 MOVE 74 TO 012470 FEHL-NR 012480 CA-FEHLNR 012490 MOVE 1 TO SWFEHL 012500 END-IF 012510 END-IF 012520 IF CA-ADRESSE = SPACE 012530 MOVE DFHBMBRY TO 012540 M8ADRZ1A 012550 M8ADRZ2A 012560 M8ADRZ3A 012570 MOVE DFHBMBRY TO 012580 M8ADRZ4A 012590 M8ADRZ5A 012600 IF SWFEHL = ZERO 012610 MOVE -1 TO M8ADRZ1L 012620 MOVE 74 TO 012630 FEHL-NR 012640 CA-FEHLNR 012650 MOVE 1 TO SWFEHL 012660 END-IF 012670 END-IF 012680 MOVE ZERO TO 012690 R-ADRSW 012700 R-LEERZ 012710 IF CA-ADRESS-SWITCHES = SPACE 012720 CONTINUE 012730 ELSE 012740 IF CA-ADRSW1 NOT = SPACE 012750 ADD 1 TO R-ADRSW 012760 END-IF 012770 IF CA-ADRSW2 NOT = SPACE 012780 ADD 1 TO R-ADRSW 012790 END-IF 012800 IF CA-ADRSW3 NOT = SPACE 012810 ADD 1 TO R-ADRSW 012820 END-IF 012830 IF CA-ADRSW4 NOT = SPACE 012840 ADD 1 TO R-ADRSW 012850 END-IF 012860 IF CA-ADRZ1 = SPACE 012870 ADD 1 TO R-LEERZ 012880 END-IF 012890 IF CA-ADRZ2 = SPACE 012900 ADD 1 TO R-LEERZ 012910 END-IF 012920 IF CA-ADRZ3 = SPACE 012930 ADD 1 TO R-LEERZ 012940 END-IF 012950 IF CA-ADRZ4 = SPACE 012960 ADD 1 TO R-LEERZ 012970 END-IF 012980 IF CA-ADRZ5 = SPACE 012990 ADD 1 TO R-LEERZ 013000 END-IF 013010 IF R-ADRSW > R-LEERZ 013020 MOVE DFHBMBRY TO 013030 M8ADSW1A 013040 M8ADSW2A 013050 M8ADSW3A 013060 M8ADSW4A 013070 IF SWFEHL = ZERO 013080 MOVE -1 TO M8ADSW1L 013090 MOVE 03 TO 013100 FEHL-NR 013110 CA-FEHLNR 013120 MOVE 1 TO SWFEHL 013130 END-IF 013140 END-IF 013150 IF (CA-ADRSW1 NOT = SPACE) AND (CA-ADRZ1 = SPACE) 013160 MOVE DFHBMBRY TO 013170 M8ADSW1A 013180 M8ADRZ1A 013190 IF SWFEHL = ZERO 013200 MOVE -1 TO M8ADSW1L 013210 MOVE 03 TO 013220 FEHL-NR 013230 CA-FEHLNR 013240 MOVE 1 TO SWFEHL 013250 END-IF 013260 END-IF 013270 IF (CA-ADRSW2 NOT = SPACE) AND (CA-ADRZ2 = SPACE) 013280 MOVE DFHBMBRY TO 013290 M8ADSW2A 013300 M8ADRZ2A 013310 IF SWFEHL = ZERO 013320 MOVE -1 TO M8ADSW2L 013330 MOVE 03 TO 013340 FEHL-NR 013350 CA-FEHLNR 013360 MOVE 1 TO SWFEHL 013370 END-IF 013380 END-IF 013390 IF (CA-ADRSW3 NOT = SPACE) AND (CA-ADRZ3 = SPACE) 013400 MOVE DFHBMBRY TO 013410 M8ADSW3A 013420 M8ADRZ3A 013430 IF SWFEHL = ZERO 013440 MOVE -1 TO M8ADSW3L 013450 MOVE 03 TO 013460 FEHL-NR 013470 CA-FEHLNR 013480 MOVE 1 TO SWFEHL 013490 END-IF 013500 END-IF 013510 IF (CA-ADRSW4 NOT = SPACE) AND (CA-ADRZ4 = SPACE) 013520 MOVE DFHBMBRY TO 013530 M8ADSW4A 013540 M8ADRZ4A 013550 IF SWFEHL = ZERO 013560 MOVE -1 TO M8ADSW4L 013570 MOVE 03 TO 013580 FEHL-NR 013590 CA-FEHLNR 013600 MOVE 1 TO SWFEHL 013610 END-IF 013620 END-IF 013630 END-IF. 013640 013650 PL-530. 013660******** UNTERSTE ADR-ZEILE MUSS PLZ HABEN 013670******** ********************************* 013680 MOVE CA-ADRESSE TO T-ADRESSE 013690 MOVE 5 TO I-1. 013700 013710 PL-550. 013720 MOVE DFHBMBRY TO 013730 M8ADRZ1A 013740 M8ADRZ2A 013750 M8ADRZ3A 013760 M8ADRZ4A 013770 M8ADRZ5A 013780 IF SWFEHL = ZERO 013790 MOVE -1 TO M8ADRZ1L 013800 MOVE 1 TO SWFEHL 013810 MOVE 319 TO 013820 FEHL-NR 013830 CA-FEHLNR 013840 END-IF. 013850 013860 PL-580. 013870 MOVE '.' TO 013880 Z-P110 013890 Z-P210 013900 MOVE Z-DATE10 TO CA-LB-ERDAT. 013910 013920 PL-610. 013930 MOVE '.' TO 013940 Z-P110 013950 Z-P210 013960 MOVE Z-DATE10 TO CA-LB-MENDZ. 013970 013980 PL-640. 013990 MOVE '.' TO 014000 Z-P110 014010 Z-P210 014020 MOVE Z-DATE10 TO CA-LB-MENDV. 014030 014040 PL-650. 014050******** OBJEKT-TEXT 014060******** *********** 014070 IF CA-LB-OBJ = SPACE 014080 MOVE DFHBMBRY TO M8OBJA 014090 IF SWFEHL = ZERO 014100 MOVE -1 TO M8OBJL 014110 MOVE 74 TO 014120 FEHL-NR 014130 CA-FEHLNR 014140 MOVE 1 TO 014150 SWFEHL 014160 CA-SWFEHL 014170 END-IF 014180 END-IF 014190 IF Z-UEBET = SPACE 014200 CONTINUE 014210 ELSE 014220 MOVE DFHBMBRY TO M8UEBETA 014230 IF SWFEHL = ZERO 014240 MOVE -1 TO M8UEBETL 014250 MOVE 52 TO 014260 FEHL-NR 014270 CA-FEHLNR 014280 MOVE 1 TO 014290 SWFEHL 014300 CA-SWFEHL 014310 END-IF 014320 END-IF. 014330 014340 PL-660. 014350* ... IST OBLIGATORISCH 014360******** ********************* 014370 IF CA-LB-UEBET = ZERO 014380 MOVE DFHBMBRY TO M8UEBETA 014390 IF SWFEHL = ZERO 014400 MOVE -1 TO M8UEBETL 014410 MOVE 74 TO 014420 FEHL-NR 014430 CA-FEHLNR 014440 MOVE 1 TO 014450 SWFEHL 014460 CA-SWFEHL 014470 END-IF 014480 END-IF 014490 IF Z-KAUTI = SPACE 014500 CONTINUE 014510 ELSE 014520 MOVE DFHBMBRY TO M8KAUTIA 014530 IF SWFEHL = ZERO 014540 MOVE -1 TO M8KAUTIL 014550 MOVE 52 TO 014560 FEHL-NR 014570 CA-FEHLNR 014580 MOVE 1 TO 014590 SWFEHL 014600 CA-SWFEHL 014610 END-IF 014620 END-IF. 014630 014640 PL-670. 014650******** ZINSGUTSCHRIFT 014660******** ************** 014670 IF Z-ZGUT = SPACE 014680 CONTINUE 014690 ELSE 014700 MOVE DFHBMBRY TO M8ZGUTA 014710 IF SWFEHL = ZERO 014720 MOVE -1 TO M8ZGUTL 014730 MOVE 52 TO 014740 FEHL-NR 014750 CA-FEHLNR 014760 MOVE 1 TO 014770 SWFEHL 014780 CA-SWFEHL 014790 END-IF 014800 END-IF. 014810 014820 PL-680. 014830******** ANZAHL RATEN 014840******** ************ 014850 IF CA-LB-ANZRAX NOT NUMERIC 014860 MOVE DFHBMBRY TO M8ANZRAA 014870 IF SWFEHL = ZERO 014880 MOVE -1 TO M8ANZRAL 014890 MOVE 52 TO 014900 FEHL-NR 014910 CA-FEHLNR 014920 MOVE 1 TO 014930 SWFEHL 014940 CA-SWFEHL 014950 END-IF 014960 END-IF 014970 IF Z-RATE = SPACE 014980 CONTINUE 014990 ELSE 015000 MOVE DFHBMBRY TO M8RATEA 015010 IF SWFEHL = ZERO 015020 MOVE -1 TO M8RATEL 015030 MOVE 52 TO 015040 FEHL-NR 015050 CA-FEHLNR 015060 MOVE 1 TO 015070 SWFEHL 015080 CA-SWFEHL 015090 END-IF 015100 END-IF. 015110 015120 PL-810. 015130******** ZUKUNFT: > CURRENT-DATE 015140******** *********************** 015150 IF CA-LB-MENDZ = SPACE 015160 CONTINUE 015170 ELSE 015180 MOVE K-XM005 TO P200-1 015190 CALL 'XM200' 015200 USING 015210 P-P008 015220 P200-1 015230 Z-DUMMY6 015240 Z-MENDZ-BIN 015250 CA-LB-MENDZ 015260 PERFORM MODULE 015270 IF Z-MENDZ-BIN NOT > Z-CURR-BIN 015280 MOVE DFHBMBRY TO M8MENDZA 015290 IF SWFEHL = ZERO 015300 MOVE -1 TO M8MENDZL 015310 MOVE 03 TO 015320 FEHL-NR 015330 CA-FEHLNR 015340 MOVE 1 TO 015350 SWFEHL 015360 CA-SWFEHL 015370 END-IF 015380 END-IF 015390 END-IF. 015400 015410 PL-830. 015420******** ZINSGUTSCHRIFT UND RATEN 015430******** SCHLIESSEN SICH AUS 015440******** ************************ 015450 IF (CA-LB-ZGUT NOT = ZERO) AND (CA-LB-RATE NOT = ZERO) 015460 MOVE 'Q' TO M8ANZRAA 015470 MOVE DFHBMBRY TO 015480 M8RATEA 015490 M8ZGUTA 015500 MOVE -1 TO M8ZGUTL 015510 MOVE 30 TO 015520 FEHL-NR 015530 CA-FEHLNR 015540 MOVE 1 TO 015550 SWFEHL 015560 CA-SWFEHL 015570 ELSE 015580 IF (SWPF = 11) AND (CA-ADRESS-SWITCHES NOT = SPACE) 015590 MOVE DFHBMBRY TO 015600 M8ADSW1A 015610 M8ADSW2A 015620 M8ADSW3A 015630 M8ADSW4A 015640 IF SWFEHL = ZERO 015650 MOVE -1 TO M8ADSW1L 015660 MOVE 1 TO 015670 FEHL-NR 015680 CA-FEHLNR 015690 MOVE 1 TO 015700 SWFEHL 015710 CA-SWFEHL 015720 END-IF 015730 END-IF 015740 END-IF. 015750 015760 PL-540. 015770 PERFORM TEST BEFORE UNTIL (I-1 < 2) OR NOT (T-ADRZ-EL ( I-1 ) = SPACE) 015780 SUBTRACT 1 FROM I-1 015790 END-PERFORM 015800 IF I-1 < 2 015810 CONTINUE 015820 PERFORM PL-550 015830 ELSE 015840 IF T-ADRZ-PLZ ( I-1 ) NUMERIC 015850 CONTINUE 015860 ELSE 015870 PERFORM PL-550 015880 END-IF 015890 END-IF. 015900 015910 PL-560. 015920******** IHRE SACHBEARBEITER-TEXT 015930******** ************************ 015940 IF CA-SACHBT = SPACE 015950 MOVE DFHBMBRY TO M8SACHTA 015960 IF SWFEHL = ZERO 015970 MOVE -1 TO M8SACHTL 015980 MOVE 74 TO 015990 FEHL-NR 016000 CA-FEHLNR 016010 MOVE 1 TO SWFEHL 016020 END-IF 016030 END-IF 016040 IF CA-SACHB1 = SPACE AND CA-SACHB2 = SPACE 016050 MOVE DFHBMBRY TO 016060 M8SACH1A 016070 M8SACH2A 016080 IF SWFEHL = ZERO 016090 MOVE -1 TO M8SACH1L 016100 MOVE 74 TO 016110 FEHL-NR 016120 CA-FEHLNR 016130 MOVE 1 TO SWFEHL 016140 END-IF 016150 END-IF 016160 IF CA-ANRED = SPACE 016170 MOVE DFHBMBRY TO M8ANREDA 016180 IF SWFEHL = ZERO 016190 MOVE -1 TO M8ANREDL 016200 MOVE 74 TO 016210 FEHL-NR 016220 CA-FEHLNR 016230 MOVE 1 TO SWFEHL 016240 END-IF 016250 END-IF 016260 MOVE ZERO TO XM016-P1 016270 MOVE ZERO TO XM016-P2 016280 MOVE CA-LB-ERDAT TO XM016-P3 016290 MOVE K-XM016 TO P200-1 016300 CALL 'XM200' 016310 USING 016320 P-P008 016330 P200-1 016340 XM016-P1 016350 XM016-P2 016360 XM016-P3 016370 PERFORM MODULE 016380 IF XM016-P2 NOT = ZERO 016390 MOVE DFHBMBRY TO M8ERDATA 016400 IF SWFEHL = ZERO 016410 MOVE 73 TO 016420 FEHL-NR 016430 CA-FEHLNR 016440 MOVE -1 TO M8ERDATL 016450 MOVE 1 TO 016460 SWFEHL 016470 CA-SWFEHL 016480 ELSE 016490 CONTINUE 016500 END-IF 016510 ELSE 016520 MOVE SPACE TO 016530 Z-TESTDATUM 016540 Z-DATE10 016550 MOVE CA-LB-ERDAT TO Z-TESTDATUM 016560 IF Z-TD-6OPF = SPACE 016570 MOVE Z-TD-6OPT TO Z-TT10 016580 MOVE Z-TD-6OPM TO Z-MM10 016590 MOVE Z-TD-6OPJ TO Z-JZ10 016600 IF Z-TD-6OPJ > 80 016610 MOVE 19 TO Z-JH10 016620 ELSE 016630 MOVE 20 TO Z-JH10 016640 END-IF 016650 ELSE 016660 IF Z-TD-8MPJ NUMERIC 016670 MOVE Z-TD-8MPX TO Z-DATE10 016680 ELSE 016690 IF Z-TD-6MP1 = '.' AND Z-TD-6MP2 = '.' 016700 MOVE Z-TD-6MPT TO Z-TT10 016710 MOVE Z-TD-6MPM TO Z-MM10 016720 MOVE Z-TD-6MPJ TO Z-JZ10 016730 IF Z-TD-6MPJ > 80 016740 MOVE 19 TO Z-JH10 016750 ELSE 016760 MOVE 20 TO Z-JH10 016770 END-IF 016780 ELSE 016790 MOVE Z-TD-8OPT TO Z-TT10 016800 MOVE Z-TD-8OPM TO Z-MM10 016810 MOVE Z-TD-8OPJ TO Z-JJ10 016820 END-IF 016830 END-IF 016840 END-IF 016850 PERFORM PL-580 016860 END-IF. 016870 016880 PL-590. 016890******** DATUM LAEUFT AM .... AB 016900******** *********************** 016910 IF CA-LB-MENDZ = SPACE 016920 CONTINUE 016930 ELSE 016940 MOVE ZERO TO XM016-P1 016950 MOVE ZERO TO XM016-P2 016960 MOVE CA-LB-MENDZ TO XM016-P3 016970 MOVE K-XM016 TO P200-1 016980 CALL 'XM200' 016990 USING 017000 P-P008 017010 P200-1 017020 XM016-P1 017030 XM016-P2 017040 XM016-P3 017050 PERFORM MODULE 017060 IF XM016-P2 NOT = ZERO 017070 MOVE 73 TO 017080 FEHL-NR 017090 CA-FEHLNR 017100 MOVE -1 TO M8MENDZL 017110 MOVE DFHBMBRY TO M8MENDZA 017120 MOVE 1 TO 017130 SWFEHL 017140 CA-SWFEHL 017150 ELSE 017160 MOVE SPACE TO 017170 Z-TESTDATUM 017180 Z-DATE10 017190 MOVE CA-LB-MENDZ TO Z-TESTDATUM 017200 IF Z-TD-6OPF = SPACE 017210 MOVE Z-TD-6OPT TO Z-TT10 017220 MOVE Z-TD-6OPM TO Z-MM10 017230 MOVE Z-TD-6OPJ TO Z-JZ10 017240 IF Z-TD-6OPJ > 80 017250 MOVE 19 TO Z-JH10 017260 ELSE 017270 MOVE 20 TO Z-JH10 017280 END-IF 017290 ELSE 017300 IF Z-TD-8MPJ NUMERIC 017310 MOVE Z-TD-8MPX TO Z-DATE10 017320 ELSE 017330 IF Z-TD-6MP1 = '.' AND Z-TD-6MP2 = '.' 017340 MOVE Z-TD-6MPT TO Z-TT10 017350 MOVE Z-TD-6MPM TO Z-MM10 017360 MOVE Z-TD-6MPJ TO Z-JZ10 017370 IF Z-TD-6MPJ > 80 017380 MOVE 19 TO Z-JH10 017390 ELSE 017400 MOVE 20 TO Z-JH10 017410 END-IF 017420 ELSE 017430 MOVE Z-TD-8OPT TO Z-TT10 017440 MOVE Z-TD-8OPM TO Z-MM10 017450 MOVE Z-TD-8OPJ TO Z-JJ10 017460 END-IF 017470 END-IF 017480 END-IF 017490 PERFORM PL-610 017500 END-IF 017510 END-IF. 017520 017530 PL-620. 017540******** DATUM IST AM .... ABGELAUFEN 017550******** **************************** 017560 IF CA-LB-MENDV = SPACE 017570 PERFORM PL-650 017580 PERFORM PL-660 017590 PERFORM PL-670 017600 PERFORM PL-680 017610 ELSE 017620 MOVE ZERO TO XM016-P1 017630 MOVE ZERO TO XM016-P2 017640 MOVE CA-LB-MENDV TO XM016-P3 017650 MOVE K-XM016 TO P200-1 017660 CALL 'XM200' 017670 USING 017680 P-P008 017690 P200-1 017700 XM016-P1 017710 XM016-P2 017720 XM016-P3 017730 PERFORM MODULE 017740 IF XM016-P2 NOT = ZERO 017750 MOVE 73 TO 017760 FEHL-NR 017770 CA-FEHLNR 017780 MOVE -1 TO M8MENDVL 017790 MOVE DFHBMBRY TO M8MENDVA 017800 MOVE 1 TO 017810 SWFEHL 017820 CA-SWFEHL 017830 PERFORM PL-650 017840 PERFORM PL-660 017850 PERFORM PL-670 017860 PERFORM PL-680 017870 ELSE 017880 MOVE SPACE TO 017890 Z-TESTDATUM 017900 Z-DATE10 017910 MOVE CA-LB-MENDV TO Z-TESTDATUM 017920 IF Z-TD-6OPF = SPACE 017930 MOVE Z-TD-6OPT TO Z-TT10 017940 MOVE Z-TD-6OPM TO Z-MM10 017950 MOVE Z-TD-6OPJ TO Z-JZ10 017960 IF Z-TD-6OPJ > 80 017970 MOVE 19 TO Z-JH10 017980 ELSE 017990 MOVE 20 TO Z-JH10 018000 END-IF 018010 ELSE 018020 IF Z-TD-8MPJ NUMERIC 018030 MOVE Z-TD-8MPX TO Z-DATE10 018040 ELSE 018050 IF Z-TD-6MP1 = '.' AND Z-TD-6MP2 = '.' 018060 MOVE Z-TD-6MPT TO Z-TT10 018070 MOVE Z-TD-6MPM TO Z-MM10 018080 MOVE Z-TD-6MPJ TO Z-JZ10 018090 IF Z-TD-6MPJ > 80 018100 MOVE 19 TO Z-JH10 018110 ELSE 018120 MOVE 20 TO Z-JH10 018130 END-IF 018140 ELSE 018150 MOVE Z-TD-8OPT TO Z-TT10 018160 MOVE Z-TD-8OPM TO Z-MM10 018170 MOVE Z-TD-8OPJ TO Z-JJ10 018180 END-IF 018190 END-IF 018200 END-IF 018210 PERFORM PL-640 018220 PERFORM PL-650 018230 PERFORM PL-660 018240 PERFORM PL-670 018250 PERFORM PL-680 018260 END-IF 018270 END-IF. 018280 018290 PL-820. 018300******** ANZRA UND RATE BEIDE NULL ODER 018310******** BEIDE NICHT NULL 018320******** ****************************** 018330 IF (CA-LB-ANZRA = ZERO) AND (CA-LB-RATE = ZERO) 018340 CONTINUE 018350 PERFORM PL-830 018360 ELSE 018370 IF (CA-LB-ANZRA NOT = ZERO) AND (CA-LB-RATE NOT = ZERO) 018380 CONTINUE 018390 PERFORM PL-830 018400 ELSE 018410 MOVE 'Q' TO M8ANZRAA 018420 MOVE DFHBMBRY TO M8RATEA 018430 MOVE -1 TO M8ANZRAL 018440 MOVE 30 TO 018450 FEHL-NR 018460 CA-FEHLNR 018470 MOVE 1 TO 018480 SWFEHL 018490 CA-SWFEHL 018500 END-IF 018510 END-IF. 018520 018530 PL-800. 018540******** EIN ABLAUFDATUM OBLIGATORISCH 018550******** ***************************** 018560 IF (CA-LB-MENDV = SPACE) AND (CA-LB-MENDZ = SPACE) 018570 MOVE DFHBMBRY TO 018580 M8MENDZA 018590 M8MENDVA 018600 MOVE -1 TO M8MENDZL 018610 MOVE 74 TO 018620 FEHL-NR 018630 CA-FEHLNR 018640 MOVE 1 TO 018650 SWFEHL 018660 CA-SWFEHL 018670 ELSE 018680 IF (CA-LB-MENDV NOT = SPACE) AND (CA-LB-MENDZ NOT = SPACE) 018690 MOVE DFHBMBRY TO 018700 M8MENDZA 018710 M8MENDVA 018720 MOVE -1 TO M8MENDZL 018730 MOVE 30 TO 018740 FEHL-NR 018750 CA-FEHLNR 018760 MOVE 1 TO 018770 SWFEHL 018780 CA-SWFEHL 018790 ELSE 018800 MOVE K-XM278 TO P200-1 018810 CALL 'XM200' 018820 USING 018830 P-P008 018840 P200-1 018850 Z-DATE 018860 Z-CURRDATE 018870 PERFORM MODULE 018880 MOVE K-XM005 TO P200-1 018890 CALL 'XM200' 018900 USING 018910 P-P008 018920 P200-1 018930 Z-DUMMY6 018940 Z-CURR-BIN 018950 Z-CURRDATE 018960 PERFORM MODULE 018970 IF CA-LB-MENDV = SPACE 018980 CONTINUE 018990 ELSE 019000 MOVE K-XM005 TO P200-1 019010 CALL 'XM200' 019020 USING 019030 P-P008 019040 P200-1 019050 Z-DUMMY6 019060 Z-MENDV-BIN 019070 CA-LB-MENDV 019080 PERFORM MODULE 019090 IF Z-MENDV-BIN > Z-CURR-BIN 019100 MOVE DFHBMBRY TO M8MENDVA 019110 IF SWFEHL = ZERO 019120 MOVE -1 TO M8MENDVL 019130 MOVE 03 TO 019140 FEHL-NR 019150 CA-FEHLNR 019160 MOVE 1 TO 019170 SWFEHL 019180 CA-SWFEHL 019190 END-IF 019200 END-IF 019210 END-IF 019220 PERFORM PL-810 019230 PERFORM PL-820 019240 END-IF 019250 END-IF. 019260 019270 PL-690. 019280 IF SWFEHL NOT = ZERO 019290 CONTINUE 019300 ELSE 019310 PERFORM PL-800 019320 END-IF. 019330 019340 PL-100. 019350 MOVE 1 TO CA-SCHRITT. 019360 019370 VERARB-SUBROUTINES SECTION. 019380 019390 VA-500. 019400**** PERFORM DRUCKPROGRAMM, RETURN-CODE MIT QUITTUNG 019410**** AN BENUETZER ZURUECKGEBEN (NUR BEI PF11) 019420 MOVE ZERO TO CA-FEHLNR 019430 IF CA-SACHB1 = SPACE 019440 MOVE CA-SACHB2 TO CA-SACHB1 019450 MOVE SPACE TO CA-SACHB2 019460 END-IF 019470 MOVE SPACE TO P1-XM314 019480 MOVE CA-ABS1 TO P1-XM314-EL ( 1 ) 019490 MOVE CA-ABS2 TO P1-XM314-EL ( 2 ) 019500 MOVE CA-ABS3 TO P1-XM314-EL ( 3 ) 019510 MOVE CA-ABS4 TO P1-XM314-EL ( 4 ) 019520 MOVE K-XM314 TO P200-1 019530 CALL 'XM200' 019540 USING 019550 P-P008 019560 P200-1 019570 P1-XM314 019580 P2-XM314 019590 PERFORM MODULE 019600 MOVE P1-XM314-EL ( 1 ) TO CA-ABS1 019610 MOVE P1-XM314-EL ( 2 ) TO CA-ABS2 019620 MOVE P1-XM314-EL ( 3 ) TO CA-ABS3 019630 MOVE P1-XM314-EL ( 4 ) TO CA-ABS4 019640 PERFORM ADRKOMPR 019650 IF CA-ADRESS-SWITCHES NOT = SPACE 019660 PERFORM ADRINSERT 019670 END-IF 019680 IF SWPF NOT = 11 019690 MOVE -1 TO M8SACHTL 019700 ELSE 019710 PERFORM PRGLINK 019720 IF CA-FEHLNR = ZERO 019730 MOVE 253 TO CA-FEHLNR 019740 END-IF 019750 MOVE -1 TO M8SACHTL 019760 MOVE 1 TO SWFEHL 019770 MOVE CA-FEHLNR TO FEHL-NR 019780 END-IF. 019790* ADRESS-LEERZEILEN ELIMINIEREN 019800* ***************************** 019810* GEWUENSCHTE LEERZEILEN INSERTEN 019820* ******************************* 019830**** ENDE VERARBEITUNG DER DATEN 019840 019850 CAFILL-SUBROUTINES SECTION. 019860 019870 FEHLMELD-SUBROUTINES SECTION. 019880 019890 MODULE-SUBROUTINES SECTION. 019900 019910 PRGLINK-SUBROUTINES SECTION. 019920 019930 SCREENFILL-SUBROUTINES SECTION. 019940 019950 SCRIDENT-SUBROUTINES SECTION. 019960 019970 ADRINSERT-SUBROUTINES SECTION. 019980 019990 ADRKOMPR-SUBROUTINES SECTION. 020000 020010 SENDEN-SUBROUTINES SECTION. 020020 020030 SE-100. 020040* EXEC CICS SEND MAP ('DBRIM8F') 020050* MAPSET ('DBRIS8') 020060* FROM (DBRIM8DO) 020070* FREEKB 020080* CURSOR 020090* WAIT ERASE 020100* END-EXEC. 020110 MOVE 'SN' TO X-CICS-FUNCTION 020120 MOVE DBRIM8DO TO X-CICS-MAP 020130 EXEC CICS LINK 020140 PROGRAM ( 'XTPOUT' ) 020150 COMMAREA ( X-CICS-PARAM ) 020160 LENGTH ( X-CICS-PARAM-LNG ) 020170 END-EXEC 020180 MOVE X-CICS-RETCODE TO EIBRESP. 020190 020200 SENDFEHL-SUBROUTINES SECTION. 020210 020220 SF-100. 020230* EXEC CICS SEND MAP ('DBRIM8F') 020240* MAPSET ('DBRIS8') 020250* FROM (DBRIM8DO) 020260* CURSOR 020270* FREEKB 020280* WAIT ERASE 020290* END-EXEC. 020300 MOVE 'SN' TO X-CICS-FUNCTION 020310 MOVE DBRIM8DO TO X-CICS-MAP 020320 EXEC CICS LINK 020330 PROGRAM ( 'XTPOUT' ) 020340 COMMAREA ( X-CICS-PARAM ) 020350 LENGTH ( X-CICS-PARAM-LNG ) 020360 END-EXEC 020370 MOVE X-CICS-RETCODE TO EIBRESP. 020380 020390 RECEIVEN-SUBROUTINES SECTION. 020400 020410 RE-100. 020420* EXEC CICS RECEIVE MAP ('DBRIM8F') 020430* MAPSET ('DBRIS8') 020440* INTO (DBRIM8DI) 020450* END-EXEC. 020460 MOVE 'RC' TO X-CICS-FUNCTION 020470 MOVE DBRIM8DI TO X-CICS-MAP 020480 EXEC CICS LINK 020490 PROGRAM ( 'XTPINP' ) 020500 COMMAREA ( X-CICS-PARAM ) 020510 LENGTH ( X-CICS-PARAM-LNG ) 020520 END-EXEC 020530 MOVE X-CICS-RETCODE TO EIBRESP 020540 EVALUATE TRUE 020550 WHEN X-MAPFAIL 020560* GO TO VV-860 020570 PERFORM VV-860 020580 WHEN X-PF1 020590* GO TO VV-710 020600 PERFORM VV-710 020610 WHEN X-PF2 020620* GO TO VV-720 020630 PERFORM VV-720 020640 WHEN X-PF3 020650* GO TO VV-730 020660 PERFORM VV-730 020670 WHEN X-PF10 020680* GO TO VV-800 020690 PERFORM VV-800 020700 WHEN X-PF11 020710* GO TO VV-810 020720 PERFORM VV-810 020730 WHEN X-PF12 020740* GO TO VV-820 020750 PERFORM VV-820 020760 WHEN X-CLEAR 020770* GO TO VV-840 020780 PERFORM VV-840 020790 WHEN X-ANYKEY 020800* GO TO VV-850 020810 PERFORM VV-850 020820 END-EVALUATE. 020830 020840 TRANSID-SUBROUTINES SECTION. 020850 020860 XCTL-SUBROUTINES SECTION. 020870 020880 XJUMP-SUBROUTINES SECTION.