%****************************************************************** IDENTIFICATION DIVISION. %****************************************************************** PROGRAM-ID. DBRIP08. AUTHOR. XXXX XXXXXX %i XXXX XXXXX. DATE-WRITTEN. DEC-1991. %****************************************************************** PROCEDURE DIVISION. %****************************************************************** %****************************************************************** %* STEUER PROCEDURE %****************************************************************** STEUER SECTION. ST-000. PERFORM VORVERARB PERFORM ST-100 PERFORM ST-990. ST-999. GA-TERUG. EJECT %****************************************************************** %* VORVERARBEITUNG %****************************************************************** VORVERARB SECTION. VV-000. MOVE DFHCOMMAREA TO COMMAREA MOVE +6000 TO CA-LENGTH MOVE LOW-VALUE TO DBRIM8DI PERFORM VV-100. VV-999. EXIT. EJECT %****************************************************************** %* HAUPTVERARBEITUNG %****************************************************************** HAUPTVERARB SECTION. HV-000. IF CA-SCHRITT = ZERO PERFORM HV-500 GO HV-999 END-IF. HV-050. %**** HANDLING PF-FUNKTIONEN EVALUATE SWPF WHEN 1 GO HV-81 WHEN 2 GO HV-82 WHEN 3 PERFORM HV-83 GO HV-84 WHEN 4 GO HV-84 WHEN 5 GO HV-85 WHEN 6 PERFORM HV-86 GO HV-999 WHEN 7 PERFORM HV-87 GO HV-999 WHEN 8 PERFORM HV-88 GO HV-999 WHEN 9 PERFORM HV-89 GO HV-999 WHEN 10 PERFORM HV-90 PERFORM HV-91 GO HV-999 WHEN 11 PERFORM HV-91 GO HV-999 WHEN 12 PERFORM HV-92 GO HV-999 WHEN 13 PERFORM HV-93 GO HV-999 WHEN 14 GO HV-94 WHEN 15 PERFORM HV-95 GO HV-999 WHEN 16 PERFORM HV-96 GO HV-999 END-EVALUATE. HV-81. %**** PF1-TASTE (HELP-PROGRAMM) PERFORM HV-95 GO HV-999. HV-94. %**** CLEAR (SENDEN LEERE MASKE) PERFORM HV-83 GO HV-84. HV-82. %**** PF2-TASTE / PRINTER-AUFRUF MOVE 2 TO CA-SWPF MOVE 0 TO CA-SCHRITT EXEC CICS LINK PROGRAM ( 'D154' ) END-EXEC GO HV-999. HV-84. %**** PF4-TASTE PERFORM HV-95 GO HV-999. HV-85. %**** PF5-TASTE PERFORM HV-95. HV-999. EXIT. EJECT %****************************************************************** %****************************************************************** %* PROGRAMM - SUBROUTINEN ---> PLAUSI UND VERARB <--- %****************************************************************** %****************************************************************** %****************************************************************** %* PLAUSIBILITAET %****************************************************************** PLAUSI SECTION. PL-000. MOVE ZERO TO SWFEHL CA-SWFEHL IF CA-SCHRITT > ZERO PERFORM PL-500 PERFORM PL-510 PERFORM PL-520 PERFORM PL-530 PERFORM PL-540 PERFORM PL-560 PERFORM PL-590 PERFORM PL-620 PERFORM PL-690 ELSE PERFORM PL-100 END-IF. PL-999. EXIT. EJECT %****************************************************************** %* VERARBEITUNG %****************************************************************** VERARB SECTION. VA-000. IF CA-SCHRITT > ZERO CONTINUE PERFORM VA-500 ELSE MOVE 1 TO CA-SCHRITT DIVIDE CA-LB-SALDO BY CA-LB-RATE GIVING CA-LB-ANZRA REMAINDER R-REST IF R-REST NOT = ZERO MOVE 'Q' TO M8ANZRAA MOVE DFHBMBRY TO M8RATEA MOVE -1 TO M8ANZRAL MOVE 349 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL END-IF END-IF. VA-999. EXIT. EJECT %****************************************************************** %****************************************************************** %* DIVERSE - SUBROUTINEN %****************************************************************** %****************************************************************** %****************************************************************** %* FUELLEN COMMON-AREA %****************************************************************** CAFILL SECTION. CA-000. IF M8PRIDL > ZERO MOVE M8PRIDI TO CA-PRINTER END-IF IF M8PRIDF = X80 MOVE SPACE TO CA-PRINTER END-IF IF M8CANL > ZERO MOVE M8CANI TO CA-SCHACHTX END-IF IF M8CANF = X80 MOVE ZERO TO CA-SCHACHT END-IF IF M8ABS1L > ZERO MOVE M8ABS1I TO CA-ABS1 END-IF IF M8ABS1F = X80 MOVE SPACE TO CA-ABS1 END-IF IF M8ABS2L > ZERO MOVE M8ABS2I TO CA-ABS2 END-IF IF M8ABS2F = X80 MOVE SPACE TO CA-ABS2 END-IF IF M8ABS3L > ZERO MOVE M8ABS3I TO CA-ABS3 END-IF IF M8ABS3F = X80 MOVE SPACE TO CA-ABS3 END-IF IF M8ABS4L > ZERO MOVE M8ABS4I TO CA-ABS4 END-IF IF M8ABS4F = X80 MOVE SPACE TO CA-ABS4 END-IF IF M8ADRZ1L > ZERO MOVE M8ADRZ1I TO CA-ADRZ1 END-IF IF M8ADRZ1F = X80 MOVE SPACE TO CA-ADRZ1 END-IF IF M8ADRZ2L > ZERO MOVE M8ADRZ2I TO CA-ADRZ2 END-IF IF M8ADRZ2F = X80 MOVE SPACE TO CA-ADRZ2 END-IF IF M8ADRZ3L > ZERO MOVE M8ADRZ3I TO CA-ADRZ3 END-IF IF M8ADRZ3F = X80 MOVE SPACE TO CA-ADRZ3 END-IF IF M8ADRZ4L > ZERO MOVE M8ADRZ4I TO CA-ADRZ4 END-IF IF M8ADRZ4F = X80 MOVE SPACE TO CA-ADRZ4 END-IF IF M8ADRZ5L > ZERO MOVE M8ADRZ5I TO CA-ADRZ5 END-IF IF M8ADRZ5F = X80 MOVE SPACE TO CA-ADRZ5 END-IF IF M8ADSW1L > ZERO MOVE M8ADSW1I TO CA-ADRSW1 END-IF IF M8ADSW1F = X80 MOVE SPACE TO CA-ADRSW1 END-IF IF M8ADSW2L > ZERO MOVE M8ADSW2I TO CA-ADRSW2 END-IF IF M8ADSW2F = X80 MOVE SPACE TO CA-ADRSW2 END-IF IF M8ADSW3L > ZERO MOVE M8ADSW3I TO CA-ADRSW3 END-IF IF M8ADSW3F = X80 MOVE SPACE TO CA-ADRSW3 END-IF IF M8ADSW4L > ZERO MOVE M8ADSW4I TO CA-ADRSW4 END-IF IF M8ADSW4F = X80 MOVE SPACE TO CA-ADRSW4 END-IF IF M8SACHTL > ZERO MOVE M8SACHTI TO CA-SACHBT END-IF IF M8SACHTF = X80 MOVE SPACE TO CA-SACHBT END-IF IF M8SACH1L > ZERO MOVE M8SACH1I TO CA-SACHB1 END-IF IF M8SACH1F = X80 MOVE SPACE TO CA-SACHB1 END-IF IF M8SACH2L > ZERO MOVE M8SACH2I TO CA-SACHB2 END-IF IF M8SACH2F = X80 MOVE SPACE TO CA-SACHB2 END-IF IF M8ANREDL > ZERO MOVE M8ANREDI TO CA-ANRED END-IF IF M8ANREDF = X80 MOVE SPACE TO CA-ANRED END-IF IF M8ERDATL > ZERO MOVE M8ERDATI TO CA-LB-ERDAT END-IF IF M8ERDATF = X80 MOVE SPACE TO CA-LB-ERDAT END-IF IF M8MENDZL > ZERO MOVE M8MENDZI TO CA-LB-MENDZ END-IF IF M8MENDZF = X80 MOVE SPACE TO CA-LB-MENDZ END-IF IF M8MENDVL > ZERO MOVE M8MENDVI TO CA-LB-MENDV END-IF IF M8MENDVF = X80 MOVE SPACE TO CA-LB-MENDV END-IF IF M8OBJL > ZERO MOVE M8OBJI TO CA-LB-OBJ END-IF IF M8OBJF = X80 MOVE SPACE TO CA-LB-OBJ END-IF IF M8UEBETL > ZERO MOVE K-XM246 TO P200-1 CALL 'XM200' USING P-P008 P200-1 XM246-P1 M8UEBETI CA-LB-UEBET Z-UEBET PERFORM MODULE END-IF IF M8UEBETF = X80 MOVE ZERO TO CA-LB-UEBET MOVE SPACE TO Z-UEBET END-IF IF M8KAUTIL > ZERO MOVE K-XM246 TO P200-1 CALL 'XM200' USING P-P008 P200-1 XM246-P1 M8KAUTII CA-LB-KAUTI Z-KAUTI PERFORM MODULE END-IF IF M8KAUTIF = X80 MOVE ZERO TO CA-LB-KAUTI MOVE SPACE TO Z-KAUTI END-IF IF M8ZGUTL > ZERO MOVE K-XM246 TO P200-1 CALL 'XM200' USING P-P008 P200-1 XM246-P1 M8ZGUTI CA-LB-ZGUT Z-ZGUT PERFORM MODULE END-IF IF M8ZGUTF = X80 MOVE ZERO TO CA-LB-ZGUT MOVE SPACE TO Z-ZGUT END-IF IF M8ANZRAL > ZERO MOVE M8ANZRAI TO CA-LB-ANZRA END-IF IF M8ANZRAF = X80 MOVE ZERO TO CA-LB-ANZRA END-IF IF M8RATEL > ZERO MOVE K-XM246 TO P200-1 CALL 'XM200' USING P-P008 P200-1 XM246-P1 M8RATEI R-RATE Z-RATE PERFORM MODULE MOVE R-RATE TO CA-LB-RATE END-IF IF M8RATEF = X80 MOVE ZERO TO CA-LB-RATE MOVE SPACE TO Z-RATE END-IF IF M8FZ1L > ZERO MOVE M8FZ1I TO CA-FZ-1 END-IF IF M8FZ1F = X80 MOVE SPACE TO CA-FZ-1 END-IF IF M8FZ2L > ZERO MOVE M8FZ2I TO CA-FZ-2 END-IF IF M8FZ2F = X80 MOVE SPACE TO CA-FZ-2 END-IF IF M8FZ3L > ZERO MOVE M8FZ3I TO CA-FZ-3 END-IF IF M8FZ3F = X80 MOVE SPACE TO CA-FZ-3 END-IF IF M8XJUMPL > ZERO PERFORM XJUMP END-IF. CA-999. EXIT. EJECT %****************************************************************** %* FEHLERMELDUNG HOLEN (XM181) %****************************************************************** FEHLMELD SECTION. FM-000. MOVE CA-SPR TO FEHL-SPR EXEC CICS LINK PROGRAM ( 'XM181' ) COMMAREA ( XM181-P ) LENGTH ( XM181L ) END-EXEC MOVE FEHL-MELD TO M8MSGO MOVE SPACE TO FEHL-VAR1 FEHL-VAR2 FEHL-VAR3 FEHL-VAR4 FEHL-VAR5 FEHL-VAR6. FM-999. EXIT. EJECT %****************************************************************** %* MODULE-AUFRUF-INTERFACE (P008) %****************************************************************** MODULE SECTION. MO-000. EXEC CICS LINK PROGRAM ( 'P008' ) COMMAREA ( P-P008 ) LENGTH ( P-P008L ) END-EXEC. MO-999. EXIT. EJECT %****************************************************************** %* LINK-PROGRAMME AUFRUFEN %****************************************************************** PRGLINK SECTION. PRG-000. EXEC CICS LINK PROGRAM ( 'DBRIP58' ) COMMAREA ( COMMAREA ) LENGTH ( CA-LENGTH ) END-EXEC. PRG-999. EXIT. EJECT %****************************************************************** %* UEBERTRAGEN CA --> SCREEN %****************************************************************** %**** (INDIVIDUELLE VERARBEITUNG) SCREENFILL SECTION. SC-000. MOVE CA-RKDN1X TO M8REF1O MOVE CA-RKDN2X TO M8REF2O MOVE CA-VNRX TO M8VNRO MOVE CA-PRINTER TO M8PRIDO MOVE CA-SCHACHT TO M8CANO MOVE CA-BRIEF TO M8BRIEFO MOVE CA-ABS1 TO M8ABS1O MOVE CA-ABS2 TO M8ABS2O MOVE CA-ABS3 TO M8ABS3O MOVE CA-ABS4 TO M8ABS4O MOVE CA-ADRZ1 TO M8ADRZ1O MOVE CA-ADRZ2 TO M8ADRZ2O MOVE CA-ADRZ3 TO M8ADRZ3O MOVE CA-ADRZ4 TO M8ADRZ4O MOVE CA-ADRZ5 TO M8ADRZ5O MOVE CA-ADRSW1 TO M8ADSW1O MOVE CA-ADRSW2 TO M8ADSW2O MOVE CA-ADRSW3 TO M8ADSW3O MOVE CA-ADRSW4 TO M8ADSW4O MOVE CA-SACHBT TO M8SACHTO MOVE CA-SACHB1 TO M8SACH1O MOVE CA-SACHB2 TO M8SACH2O MOVE CA-ANRED TO M8ANREDO MOVE CA-LB-ERDAT TO M8ERDATO MOVE CA-LB-MENDZ TO M8MENDZO MOVE CA-LB-MENDV TO M8MENDVO MOVE CA-LB-OBJ TO M8OBJO IF Z-UEBET = SPACE IF CA-LB-UEBET = ZERO MOVE SPACE TO M8UEBETO ELSE MOVE CA-LB-UEBET TO MO-BETRA MOVE MO-BETRAX TO M8UEBETO END-IF ELSE MOVE Z-UEBET TO M8UEBETO END-IF IF Z-KAUTI = SPACE IF CA-LB-KAUTI = ZERO MOVE SPACE TO M8KAUTIO ELSE MOVE CA-LB-KAUTI TO MO-BETRA MOVE MO-BETRAX TO M8KAUTIO END-IF ELSE MOVE Z-KAUTI TO M8KAUTIO END-IF IF Z-ZGUT = SPACE IF CA-LB-ZGUT = ZERO MOVE SPACE TO M8ZGUTO ELSE MOVE CA-LB-ZGUT TO MO-BETRA MOVE MO-BETRAX TO M8ZGUTO END-IF ELSE MOVE Z-ZGUT TO M8ZGUTO END-IF MOVE CA-LB-ANZRA TO M8ANZRAO IF Z-RATE = SPACE IF CA-LB-RATE = ZERO MOVE SPACE TO M8RATEO ELSE MOVE CA-LB-RATE TO MO-BETRA MOVE MO-BETRAX TO M8RATEO END-IF ELSE MOVE Z-RATE TO M8RATEO END-IF MOVE CA-FZ-1 TO M8FZ1O MOVE CA-FZ-2 TO M8FZ2O MOVE CA-FZ-3 TO M8FZ3O. SC-999. EXIT. EJECT %****************************************************************** %* IDENT-FELDER IN SCREEN FUELLEN %****************************************************************** SCRIDENT SECTION. SI-000. MOVE EIBTRMID TO TID MOVE EIBTIME TO Z-TIME MOVE K-XM278 TO P200-1 CALL 'XM200' USING P-P008 P200-1 Z-DATE PERFORM MODULE MOVE TIMR1 TO HH MOVE TIMR2 TO MI MOVE TIMR3 TO SS MOVE DATR0 TO TT Z-DAT0 MOVE DATR1 TO MM Z-DAT1 MOVE DATR2 TO YY Z-DAT2 MOVE CA-KKZ TO OPID MOVE CA-BURO TO GS MOVE K-XM014A TO P200-1 CALL 'XM200' USING P-P008 P200-1 CA-FIRMA FA PERFORM MODULE MOVE CA-TRANS TO TRANS MOVE W-IDE TO M8IDEO MOVE W-IDA TO M8IDAO. SI-999. EXIT. EJECT %****************************************************************** %* GEWUENSCHTE LEERZEILEN IN ADRESSE INSERTEN %****************************************************************** ADRINSERT SECTION. AI-000. IF CA-ADRSW4 NOT = SPACE MOVE CA-ADRZ4 TO CA-ADRZ5 MOVE SPACE TO CA-ADRZ4 MOVE SPACE TO CA-ADRSW4 MOVE -1 TO M8ADRZ4L END-IF IF CA-ADRSW3 NOT = SPACE MOVE CA-ADRZ4 TO CA-ADRZ5 MOVE CA-ADRZ3 TO CA-ADRZ4 MOVE SPACE TO CA-ADRZ3 MOVE SPACE TO CA-ADRSW3 MOVE -1 TO M8ADRZ3L END-IF IF CA-ADRSW2 NOT = SPACE MOVE CA-ADRZ4 TO CA-ADRZ5 MOVE CA-ADRZ3 TO CA-ADRZ4 MOVE CA-ADRZ2 TO CA-ADRZ3 MOVE SPACE TO CA-ADRZ2 MOVE SPACE TO CA-ADRSW2 MOVE -1 TO M8ADRZ2L END-IF IF CA-ADRSW1 NOT = SPACE MOVE CA-ADRZ4 TO CA-ADRZ5 MOVE CA-ADRZ3 TO CA-ADRZ4 MOVE CA-ADRZ2 TO CA-ADRZ3 MOVE CA-ADRZ1 TO CA-ADRZ2 MOVE SPACE TO CA-ADRZ1 MOVE SPACE TO CA-ADRSW1 MOVE -1 TO M8ADRZ1L END-IF. AI-999. EXIT. EJECT %****************************************************************** %* LEERZEILEN AUS ADRESSE ELIMINIEREN UND SWITCHERS MITSCHIEBEN %****************************************************************** ADRKOMPR SECTION. AK-000. MOVE CA-ADRSW1 TO P1-XM314-ADRSW ( 1 ) MOVE CA-ADRZ1 TO P1-XM314-ADRZ ( 1 ) MOVE CA-ADRSW2 TO P1-XM314-ADRSW ( 2 ) MOVE CA-ADRZ2 TO P1-XM314-ADRZ ( 2 ) MOVE CA-ADRSW3 TO P1-XM314-ADRSW ( 3 ) MOVE CA-ADRZ3 TO P1-XM314-ADRZ ( 3 ) MOVE CA-ADRSW4 TO P1-XM314-ADRSW ( 4 ) MOVE CA-ADRZ4 TO P1-XM314-ADRZ ( 4 ) MOVE SPACE TO P1-XM314-ADRSW ( 5 ) MOVE CA-ADRZ5 TO P1-XM314-ADRZ ( 5 ) MOVE K-XM314 TO P200-1 CALL 'XM200' USING P-P008 P200-1 P1-XM314 P2-XM314 PERFORM MODULE MOVE P1-XM314-ADRSW ( 1 ) TO CA-ADRSW1 MOVE P1-XM314-ADRZ ( 1 ) TO CA-ADRZ1 MOVE P1-XM314-ADRSW ( 2 ) TO CA-ADRSW2 MOVE P1-XM314-ADRZ ( 2 ) TO CA-ADRZ2 MOVE P1-XM314-ADRSW ( 3 ) TO CA-ADRSW3 MOVE P1-XM314-ADRZ ( 3 ) TO CA-ADRZ3 MOVE P1-XM314-ADRSW ( 4 ) TO CA-ADRSW4 MOVE P1-XM314-ADRZ ( 4 ) TO CA-ADRZ4 MOVE P1-XM314-ADRZ ( 5 ) TO CA-ADRZ5. AK-999. EXIT. EJECT %****************************************************************** %****************************************************************** %* C I C S - SUBROUTINEN %****************************************************************** %****************************************************************** %****************************************************************** %* SENDEN SCREEN %****************************************************************** SENDEN SECTION. SE-000. PERFORM SCRIDENT PERFORM SCREENFILL MOVE -1 TO M8SACHTL IF CA-SPR = 2 CONTINUE PERFORM SE-100 ELSE MOVE 'SN' TO X-CICS-FUNCTION MOVE DBRIM8DO TO X-CICS-MAP EXEC CICS LINK PROGRAM ( 'XTPOUT' ) COMMAREA ( X-CICS-PARAM ) LENGTH ( X-CICS-PARAM-LNG ) END-EXEC MOVE X-CICS-RETCODE TO EIBRESP END-IF. SE-999. EXIT. EJECT %****************************************************************** %* SENDEN SCREEN MIT FEHLERMELDUNG %****************************************************************** SENDFEHL SECTION. SF-000. PERFORM SCRIDENT PERFORM SCREENFILL IF M8MSGO = LOW-VALUE MOVE 'ABER...ABER...PROGRAMMIERFEHLER' TO M8MSGO END-IF IF CA-SPR = 2 CONTINUE PERFORM SF-100 ELSE MOVE 'SN' TO X-CICS-FUNCTION MOVE DBRIM8DO TO X-CICS-MAP EXEC CICS LINK PROGRAM ( 'XTPOUT' ) COMMAREA ( X-CICS-PARAM ) LENGTH ( X-CICS-PARAM-LNG ) END-EXEC MOVE X-CICS-RETCODE TO EIBRESP END-IF. SF-999. EXIT. EJECT %****************************************************************** %* SCREEN EMPFANGEN %****************************************************************** RECEIVEN SECTION. RE-000. MOVE LOW-VALUE TO DBRIM8DI IF CA-SPR = 2 CONTINUE PERFORM RE-100 ELSE MOVE 'RC' TO X-CICS-FUNCTION MOVE DBRIM8DI TO X-CICS-MAP EXEC CICS LINK PROGRAM ( 'XTPINP' ) COMMAREA ( X-CICS-PARAM ) LENGTH ( X-CICS-PARAM-LNG ) END-EXEC MOVE X-CICS-RETCODE TO EIBRESP EVALUATE TRUE WHEN X-MAPFAIL %* GO TO VV-860 PERFORM VV-860 WHEN X-PF1 %* GO TO VV-710 PERFORM VV-710 WHEN X-PF2 %* GO TO VV-720 PERFORM VV-720 WHEN X-PF3 %* GO TO VV-730 PERFORM VV-730 WHEN X-PF10 %* GO TO VV-800 PERFORM VV-800 WHEN X-PF11 %* GO TO VV-810 PERFORM VV-810 WHEN X-PF12 %* GO TO VV-820 PERFORM VV-820 WHEN X-CLEAR %* GO TO VV-840 PERFORM VV-840 WHEN X-ANYKEY %* GO TO VV-850 PERFORM VV-850 END-EVALUATE END-IF. RE-999. EXIT. EJECT %****************************************************************** %* PROGRAMM MIT RETURN TRANSID VERLASSEN %****************************************************************** TRANSID SECTION. TR-000. EXEC CICS RETURN TRANSID ( CA-TRANS ) COMMAREA ( COMMAREA ) LENGTH ( CA-LENGTH ) END-EXEC. TR-999. EXIT. EJECT %****************************************************************** %* PROGRAMM VERLASSEN %****************************************************************** XCTL SECTION. XC-000. MOVE 5 TO FEHL-NR CA-FEHLNR MOVE CA-TRANS TO FEHL-VAR1 PERFORM FEHLMELD MOVE 'SN' TO X-CICS-FUNCTION MOVE M8MSGO TO X-CICS-MAP EXEC CICS LINK PROGRAM ( 'XTPOUT' ) COMMAREA ( X-CICS-PARAM ) LENGTH ( X-CICS-PARAM-LNG ) END-EXEC MOVE X-CICS-RETCODE TO EIBRESP EXEC CICS RETURN END-EXEC. %* EXEC CICS SEND %* FROM (M8MSGO) %* LENGTH (77) %* WAIT %* ERASE %* END-EXEC. XC-999. EXIT. EJECT %****************************************************************** %* CROSS-JUMPER AUFRUFEN %****************************************************************** XJUMP SECTION. XJ-000. MOVE M8XJUMPI TO P1-XM229 MOVE K-XM229 TO P200-1 CALL 'XM200' USING P-P008 P200-1 P1-XM229 P2-XM229 P3-XM229 PERFORM MODULE MOVE P1-XM229 TO CA-CIXJUMP MOVE CA-SPR TO XM179-SPRCD MOVE CA-CIXACT TO XM179-TRANS EXEC CICS LINK PROGRAM ( 'XM179' ) COMMAREA ( XM179-P ) LENGTH ( XM179L ) END-EXEC IF XM179-TEXT = SPACE MOVE 25 TO FEHL-NR CA-FEHLNR MOVE CA-CIXACT TO FEHL-VAR1 MOVE DFHBMBRY TO M8XJUMPA MOVE -1 TO M8XJUMPL MOVE 1 TO SWFEHL CA-SWFEHL ELSE MOVE ZERO TO CA-SCHRITT MOVE 'G' TO P1-XM269 MOVE K-XM269 TO P200-1 CALL 'XM200' USING P-P008 P200-1 P1-XM269 PERFORM MODULE IF CA-SWAC = 'C' EXEC CICS XCTL PROGRAM ( 'D007' ) COMMAREA ( COMMAREA ) LENGTH ( 1650 ) END-EXEC %**** *** XXXXXX, XXXXXXX *** ELSE EXEC CICS XCTL PROGRAM ( 'P007' ) COMMAREA ( COMMAREA ) LENGTH ( 1650 ) END-EXEC END-IF END-IF. %**** *** CONTISSIIMO *** XJ-999. EXIT. %****************************************************************** %**** ENDE SOURCE DBRIP08 %****************************************************************** BAR SECTION. BAR-PARAGRAPH. STOP RUN. STEUER-SUBROUTINES SECTION. ST-100. PERFORM HAUPTVERARB. ST-990. IF SWPF = 99 PERFORM XCTL ELSE MOVE +6000 TO CA-LENGTH PERFORM TRANSID END-IF. VORVERARB-SUBROUTINES SECTION. VV-860. %**** M A P F A I L MOVE 16 TO SWPF. VV-850. %**** ANYKEY-TASTE MOVE 15 TO SWPF. VV-840. %**** CLEAR-TASTE MOVE 14 TO SWPF. VV-820. %**** PF12-TASTE MOVE 12 TO SWPF. VV-810. %**** PF11-TASTE MOVE 11 TO SWPF. VV-800. %**** PF10-TASTE MOVE 10 TO SWPF. VV-730. %**** PF3-TASTE MOVE 3 TO SWPF. VV-720. %**** PF2-TASTE MOVE 2 TO SWPF. VV-710. %**** PF1-TASTE MOVE 1 TO SWPF. VV-700. %**** HANDLE AID UND CONDITION %* EXEC CICS HANDLE CONDITION MAPFAIL (VV-860) %* END-EXEC. %**** HANDLE AID 1. TEIL %* EXEC CICS HANDLE AID PF1 (VV-710) %* PF2 (VV-720) %* PF3 (VV-730) %* PF10 (VV-800) %* PF11 (VV-810) %* PF12 (VV-820) %* CLEAR (VV-840) %* ANYKEY (VV-850) %* END-EXEC. %**** R E C E I V E PERFORM RECEIVEN MOVE 13 TO SWPF. VV-100. IF CA-SCHRITT = ZERO CONTINUE ELSE PERFORM VV-700 END-IF. HAUPTVERARB-SUBROUTINES SECTION. HV-83. %**** PF3-TASTE MOVE 3 TO CA-SWPF MOVE 0 TO CA-SCHRITT EXEC CICS XCTL PROGRAM ( 'DBRIT' ) COMMAREA ( COMMAREA ) LENGTH ( CA-LENGTH ) END-EXEC. HV-90. %**** PF10-TASTE %**** BILDSCHIRM AUF GROSS UMSCHALTEN MOVE 'G' TO P1-XM269 MOVE K-XM269 TO P200-1 CALL 'XM200' USING P-P008 P200-1 P1-XM269 PERFORM MODULE MOVE ZERO TO CA-LENGTH EXEC CICS XCTL PROGRAM ( 'PF10T' ) COMMAREA ( COMMAREA ) LENGTH ( CA-LENGTH ) END-EXEC. HV-900. %**** FEHLER PERFORM FEHLMELD PERFORM SENDFEHL MOVE 90 TO SWPF. HV-800. %**** SENDEN SCREEN PERFORM SENDEN IF CA-SCHRITT = 0 MOVE 1 TO CA-SCHRITT END-IF MOVE 80 TO SWPF. HV-500. %**** AUFRUF DER VERARBEITUNG %* NACH ERFOLGREICHEN PLAUS-TESTS PERFORM VERARB IF SWFEHL > ZERO PERFORM HV-900 ELSE PERFORM HV-800 END-IF. HV-300. %**** INPUT PRUEFEN PERFORM PLAUSI IF SWFEHL = ZERO CONTINUE PERFORM HV-500 ELSE IF FEHL-NR = 0 MOVE 3 TO FEHL-NR CA-FEHLNR END-IF PERFORM HV-900 END-IF. HV-200. %**** COMMONAREA MIT SCREENDATEN LADEN PERFORM CAFILL IF SWFEHL > ZERO PERFORM HV-900 ELSE PERFORM HV-300 END-IF. HV-100. %**** INITIALISIEREN SCREEN MOVE LOW-VALUE TO DBRIM8DO PERFORM HV-800. HV-97. %**** AUFRUF AUS CROSS-JUMPER PERFORM HV-200. HV-96. %**** MAPFAIL (KEINE EINGABE) PERFORM HV-200. HV-95. %**** ANYKEY (FALSCHE FUNKTIONS-TASTE) PERFORM CAFILL IF SWFEHL > ZERO CONTINUE ELSE MOVE LOW-VALUE TO DBRIM8DI MOVE 1 TO FEHL-NR CA-FEHLNR MOVE -1 TO M8SACHTL END-IF PERFORM HV-900. HV-93. %**** ENTER (EMPFANGEN SCREEN) PERFORM HV-200. HV-92. %**** PF12 - ENDE DER TRANSAKTION %**** BILDSCHIRM AUF GROSS UMSCHALTEN MOVE 'G' TO P1-XM269 MOVE K-XM269 TO P200-1 CALL 'XM200' USING P-P008 P200-1 P1-XM269 PERFORM MODULE MOVE 99 TO SWPF. HV-91. %**** PF11-TASTE %**** AUSDRUCKEN: ZUERST NORMALE VER- %**** ARBEITUNG (PLAUSI ETC.) PERFORM HV-200. HV-89. %**** PF9-TASTE PERFORM HV-95. HV-88. %* PF8-TASTE %**** VORWAERTS BLAETTERN (INDIV.) PERFORM HV-95. HV-87. %* PF7-TASTE %**** RUECKWAERTS BLAETTERN (INDIV.) PERFORM HV-95. HV-86. %**** PF6-TASTE PERFORM HV-95. PLAUSI-SUBROUTINES SECTION. PL-500. %******** PRINTER PRUEFEN %******** *************** IF CA-PRINTER = SPACE MOVE DFHBMBRY TO M8PRIDA MOVE -1 TO M8PRIDL MOVE 3 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL ELSE MOVE CA-PRINTER TO P1-XM229 MOVE K-XM229 TO P200-1 CALL 'XM200' USING P-P008 P200-1 P1-XM229 P2-XM229 P3-XM229 PERFORM MODULE MOVE P1-XM229 TO CA-PRINTER MOVE 'G' TO BER-FUNC MOVE CA-PRINTER TO BER-PRTID EXEC CICS LINK PROGRAM ( 'XM177' ) COMMAREA ( P-XM177 ) LENGTH ( P-XM177L ) END-EXEC IF BER-RET1 = '1' MOVE DFHBMBRY TO M8PRIDA IF SWFEHL = ZERO MOVE -1 TO M8PRIDL MOVE 1 TO SWFEHL MOVE 96 TO FEHL-NR CA-FEHLNR END-IF END-IF END-IF. PL-510. %******** SCHACHT PRUEFEN %******** *************** IF CA-SCHACHTX NOT NUMERIC MOVE 'Q' TO M8CANA IF SWFEHL = ZERO MOVE -1 TO M8CANL MOVE 1 TO SWFEHL MOVE 52 TO FEHL-NR CA-FEHLNR END-IF END-IF IF CA-SCHACHTX > '0' AND CA-SCHACHTX < '4' CONTINUE ELSE IF CA-SCHACHTX = '9' CONTINUE ELSE MOVE 'Q' TO M8CANA IF SWFEHL = ZERO MOVE -1 TO M8CANL MOVE 1 TO SWFEHL MOVE 3 TO FEHL-NR CA-FEHLNR END-IF END-IF END-IF. PL-520. %******** MIND. 1 ABSENDERZEILE %******** ********************* IF CA-ABS1 = SPACE AND CA-ABS2 = SPACE AND CA-ABS3 = SPACE AND CA-ABS4 = SPACE MOVE DFHBMBRY TO M8ABS1A M8ABS2A M8ABS3A M8ABS4A IF SWFEHL = ZERO MOVE -1 TO M8ABS1L MOVE 74 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL END-IF END-IF IF CA-ADRESSE = SPACE MOVE DFHBMBRY TO M8ADRZ1A M8ADRZ2A M8ADRZ3A MOVE DFHBMBRY TO M8ADRZ4A M8ADRZ5A IF SWFEHL = ZERO MOVE -1 TO M8ADRZ1L MOVE 74 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL END-IF END-IF MOVE ZERO TO R-ADRSW R-LEERZ IF CA-ADRESS-SWITCHES = SPACE CONTINUE ELSE IF CA-ADRSW1 NOT = SPACE ADD 1 TO R-ADRSW END-IF IF CA-ADRSW2 NOT = SPACE ADD 1 TO R-ADRSW END-IF IF CA-ADRSW3 NOT = SPACE ADD 1 TO R-ADRSW END-IF IF CA-ADRSW4 NOT = SPACE ADD 1 TO R-ADRSW END-IF IF CA-ADRZ1 = SPACE ADD 1 TO R-LEERZ END-IF IF CA-ADRZ2 = SPACE ADD 1 TO R-LEERZ END-IF IF CA-ADRZ3 = SPACE ADD 1 TO R-LEERZ END-IF IF CA-ADRZ4 = SPACE ADD 1 TO R-LEERZ END-IF IF CA-ADRZ5 = SPACE ADD 1 TO R-LEERZ END-IF IF R-ADRSW > R-LEERZ MOVE DFHBMBRY TO M8ADSW1A M8ADSW2A M8ADSW3A M8ADSW4A IF SWFEHL = ZERO MOVE -1 TO M8ADSW1L MOVE 03 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL END-IF END-IF IF (CA-ADRSW1 NOT = SPACE) AND (CA-ADRZ1 = SPACE) MOVE DFHBMBRY TO M8ADSW1A M8ADRZ1A IF SWFEHL = ZERO MOVE -1 TO M8ADSW1L MOVE 03 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL END-IF END-IF IF (CA-ADRSW2 NOT = SPACE) AND (CA-ADRZ2 = SPACE) MOVE DFHBMBRY TO M8ADSW2A M8ADRZ2A IF SWFEHL = ZERO MOVE -1 TO M8ADSW2L MOVE 03 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL END-IF END-IF IF (CA-ADRSW3 NOT = SPACE) AND (CA-ADRZ3 = SPACE) MOVE DFHBMBRY TO M8ADSW3A M8ADRZ3A IF SWFEHL = ZERO MOVE -1 TO M8ADSW3L MOVE 03 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL END-IF END-IF IF (CA-ADRSW4 NOT = SPACE) AND (CA-ADRZ4 = SPACE) MOVE DFHBMBRY TO M8ADSW4A M8ADRZ4A IF SWFEHL = ZERO MOVE -1 TO M8ADSW4L MOVE 03 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL END-IF END-IF END-IF. PL-530. %******** UNTERSTE ADR-ZEILE MUSS PLZ HABEN %******** ********************************* MOVE CA-ADRESSE TO T-ADRESSE MOVE 5 TO I-1. PL-550. MOVE DFHBMBRY TO M8ADRZ1A M8ADRZ2A M8ADRZ3A M8ADRZ4A M8ADRZ5A IF SWFEHL = ZERO MOVE -1 TO M8ADRZ1L MOVE 1 TO SWFEHL MOVE 319 TO FEHL-NR CA-FEHLNR END-IF. PL-580. MOVE '.' TO Z-P110 Z-P210 MOVE Z-DATE10 TO CA-LB-ERDAT. PL-610. MOVE '.' TO Z-P110 Z-P210 MOVE Z-DATE10 TO CA-LB-MENDZ. PL-640. MOVE '.' TO Z-P110 Z-P210 MOVE Z-DATE10 TO CA-LB-MENDV. PL-650. %******** OBJEKT-TEXT %******** *********** IF CA-LB-OBJ = SPACE MOVE DFHBMBRY TO M8OBJA IF SWFEHL = ZERO MOVE -1 TO M8OBJL MOVE 74 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL CA-SWFEHL END-IF END-IF IF Z-UEBET = SPACE CONTINUE ELSE MOVE DFHBMBRY TO M8UEBETA IF SWFEHL = ZERO MOVE -1 TO M8UEBETL MOVE 52 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL CA-SWFEHL END-IF END-IF. PL-660. %* ... IST OBLIGATORISCH %******** ********************* IF CA-LB-UEBET = ZERO MOVE DFHBMBRY TO M8UEBETA IF SWFEHL = ZERO MOVE -1 TO M8UEBETL MOVE 74 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL CA-SWFEHL END-IF END-IF IF Z-KAUTI = SPACE CONTINUE ELSE MOVE DFHBMBRY TO M8KAUTIA IF SWFEHL = ZERO MOVE -1 TO M8KAUTIL MOVE 52 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL CA-SWFEHL END-IF END-IF. PL-670. %******** ZINSGUTSCHRIFT %******** ************** IF Z-ZGUT = SPACE CONTINUE ELSE MOVE DFHBMBRY TO M8ZGUTA IF SWFEHL = ZERO MOVE -1 TO M8ZGUTL MOVE 52 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL CA-SWFEHL END-IF END-IF. PL-680. %******** ANZAHL RATEN %******** ************ IF CA-LB-ANZRAX NOT NUMERIC MOVE DFHBMBRY TO M8ANZRAA IF SWFEHL = ZERO MOVE -1 TO M8ANZRAL MOVE 52 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL CA-SWFEHL END-IF END-IF IF Z-RATE = SPACE CONTINUE ELSE MOVE DFHBMBRY TO M8RATEA IF SWFEHL = ZERO MOVE -1 TO M8RATEL MOVE 52 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL CA-SWFEHL END-IF END-IF. PL-810. %******** ZUKUNFT: > CURRENT-DATE %******** *********************** IF CA-LB-MENDZ = SPACE CONTINUE ELSE MOVE K-XM005 TO P200-1 CALL 'XM200' USING P-P008 P200-1 Z-DUMMY6 Z-MENDZ-BIN CA-LB-MENDZ PERFORM MODULE IF Z-MENDZ-BIN NOT > Z-CURR-BIN MOVE DFHBMBRY TO M8MENDZA IF SWFEHL = ZERO MOVE -1 TO M8MENDZL MOVE 03 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL CA-SWFEHL END-IF END-IF END-IF. PL-830. %******** ZINSGUTSCHRIFT UND RATEN %******** SCHLIESSEN SICH AUS %******** ************************ IF (CA-LB-ZGUT NOT = ZERO) AND (CA-LB-RATE NOT = ZERO) MOVE 'Q' TO M8ANZRAA MOVE DFHBMBRY TO M8RATEA M8ZGUTA MOVE -1 TO M8ZGUTL MOVE 30 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL CA-SWFEHL ELSE IF (SWPF = 11) AND (CA-ADRESS-SWITCHES NOT = SPACE) MOVE DFHBMBRY TO M8ADSW1A M8ADSW2A M8ADSW3A M8ADSW4A IF SWFEHL = ZERO MOVE -1 TO M8ADSW1L MOVE 1 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL CA-SWFEHL END-IF END-IF END-IF. PL-540. PERFORM TEST BEFORE UNTIL (I-1 < 2) OR NOT (T-ADRZ-EL ( I-1 ) = SPACE) SUBTRACT 1 FROM I-1 END-PERFORM IF I-1 < 2 CONTINUE PERFORM PL-550 ELSE IF T-ADRZ-PLZ ( I-1 ) NUMERIC CONTINUE ELSE PERFORM PL-550 END-IF END-IF. PL-560. %******** IHRE SACHBEARBEITER-TEXT %******** ************************ IF CA-SACHBT = SPACE MOVE DFHBMBRY TO M8SACHTA IF SWFEHL = ZERO MOVE -1 TO M8SACHTL MOVE 74 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL END-IF END-IF IF CA-SACHB1 = SPACE AND CA-SACHB2 = SPACE MOVE DFHBMBRY TO M8SACH1A M8SACH2A IF SWFEHL = ZERO MOVE -1 TO M8SACH1L MOVE 74 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL END-IF END-IF IF CA-ANRED = SPACE MOVE DFHBMBRY TO M8ANREDA IF SWFEHL = ZERO MOVE -1 TO M8ANREDL MOVE 74 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL END-IF END-IF MOVE ZERO TO XM016-P1 MOVE ZERO TO XM016-P2 MOVE CA-LB-ERDAT TO XM016-P3 MOVE K-XM016 TO P200-1 CALL 'XM200' USING P-P008 P200-1 XM016-P1 XM016-P2 XM016-P3 PERFORM MODULE IF XM016-P2 NOT = ZERO MOVE DFHBMBRY TO M8ERDATA IF SWFEHL = ZERO MOVE 73 TO FEHL-NR CA-FEHLNR MOVE -1 TO M8ERDATL MOVE 1 TO SWFEHL CA-SWFEHL ELSE CONTINUE END-IF ELSE MOVE SPACE TO Z-TESTDATUM Z-DATE10 MOVE CA-LB-ERDAT TO Z-TESTDATUM IF Z-TD-6OPF = SPACE MOVE Z-TD-6OPT TO Z-TT10 MOVE Z-TD-6OPM TO Z-MM10 MOVE Z-TD-6OPJ TO Z-JZ10 IF Z-TD-6OPJ > 80 MOVE 19 TO Z-JH10 ELSE MOVE 20 TO Z-JH10 END-IF ELSE IF Z-TD-8MPJ NUMERIC MOVE Z-TD-8MPX TO Z-DATE10 ELSE IF Z-TD-6MP1 = '.' AND Z-TD-6MP2 = '.' MOVE Z-TD-6MPT TO Z-TT10 MOVE Z-TD-6MPM TO Z-MM10 MOVE Z-TD-6MPJ TO Z-JZ10 IF Z-TD-6MPJ > 80 MOVE 19 TO Z-JH10 ELSE MOVE 20 TO Z-JH10 END-IF ELSE MOVE Z-TD-8OPT TO Z-TT10 MOVE Z-TD-8OPM TO Z-MM10 MOVE Z-TD-8OPJ TO Z-JJ10 END-IF END-IF END-IF PERFORM PL-580 END-IF. PL-590. %******** DATUM LAEUFT AM .... AB %******** *********************** IF CA-LB-MENDZ = SPACE CONTINUE ELSE MOVE ZERO TO XM016-P1 MOVE ZERO TO XM016-P2 MOVE CA-LB-MENDZ TO XM016-P3 MOVE K-XM016 TO P200-1 CALL 'XM200' USING P-P008 P200-1 XM016-P1 XM016-P2 XM016-P3 PERFORM MODULE IF XM016-P2 NOT = ZERO MOVE 73 TO FEHL-NR CA-FEHLNR MOVE -1 TO M8MENDZL MOVE DFHBMBRY TO M8MENDZA MOVE 1 TO SWFEHL CA-SWFEHL ELSE MOVE SPACE TO Z-TESTDATUM Z-DATE10 MOVE CA-LB-MENDZ TO Z-TESTDATUM IF Z-TD-6OPF = SPACE MOVE Z-TD-6OPT TO Z-TT10 MOVE Z-TD-6OPM TO Z-MM10 MOVE Z-TD-6OPJ TO Z-JZ10 IF Z-TD-6OPJ > 80 MOVE 19 TO Z-JH10 ELSE MOVE 20 TO Z-JH10 END-IF ELSE IF Z-TD-8MPJ NUMERIC MOVE Z-TD-8MPX TO Z-DATE10 ELSE IF Z-TD-6MP1 = '.' AND Z-TD-6MP2 = '.' MOVE Z-TD-6MPT TO Z-TT10 MOVE Z-TD-6MPM TO Z-MM10 MOVE Z-TD-6MPJ TO Z-JZ10 IF Z-TD-6MPJ > 80 MOVE 19 TO Z-JH10 ELSE MOVE 20 TO Z-JH10 END-IF ELSE MOVE Z-TD-8OPT TO Z-TT10 MOVE Z-TD-8OPM TO Z-MM10 MOVE Z-TD-8OPJ TO Z-JJ10 END-IF END-IF END-IF PERFORM PL-610 END-IF END-IF. PL-620. %******** DATUM IST AM .... ABGELAUFEN %******** **************************** IF CA-LB-MENDV = SPACE PERFORM PL-650 PERFORM PL-660 PERFORM PL-670 PERFORM PL-680 ELSE MOVE ZERO TO XM016-P1 MOVE ZERO TO XM016-P2 MOVE CA-LB-MENDV TO XM016-P3 MOVE K-XM016 TO P200-1 CALL 'XM200' USING P-P008 P200-1 XM016-P1 XM016-P2 XM016-P3 PERFORM MODULE IF XM016-P2 NOT = ZERO MOVE 73 TO FEHL-NR CA-FEHLNR MOVE -1 TO M8MENDVL MOVE DFHBMBRY TO M8MENDVA MOVE 1 TO SWFEHL CA-SWFEHL PERFORM PL-650 PERFORM PL-660 PERFORM PL-670 PERFORM PL-680 ELSE MOVE SPACE TO Z-TESTDATUM Z-DATE10 MOVE CA-LB-MENDV TO Z-TESTDATUM IF Z-TD-6OPF = SPACE MOVE Z-TD-6OPT TO Z-TT10 MOVE Z-TD-6OPM TO Z-MM10 MOVE Z-TD-6OPJ TO Z-JZ10 IF Z-TD-6OPJ > 80 MOVE 19 TO Z-JH10 ELSE MOVE 20 TO Z-JH10 END-IF ELSE IF Z-TD-8MPJ NUMERIC MOVE Z-TD-8MPX TO Z-DATE10 ELSE IF Z-TD-6MP1 = '.' AND Z-TD-6MP2 = '.' MOVE Z-TD-6MPT TO Z-TT10 MOVE Z-TD-6MPM TO Z-MM10 MOVE Z-TD-6MPJ TO Z-JZ10 IF Z-TD-6MPJ > 80 MOVE 19 TO Z-JH10 ELSE MOVE 20 TO Z-JH10 END-IF ELSE MOVE Z-TD-8OPT TO Z-TT10 MOVE Z-TD-8OPM TO Z-MM10 MOVE Z-TD-8OPJ TO Z-JJ10 END-IF END-IF END-IF PERFORM PL-640 PERFORM PL-650 PERFORM PL-660 PERFORM PL-670 PERFORM PL-680 END-IF END-IF. PL-820. %******** ANZRA UND RATE BEIDE NULL ODER %******** BEIDE NICHT NULL %******** ****************************** IF (CA-LB-ANZRA = ZERO) AND (CA-LB-RATE = ZERO) CONTINUE PERFORM PL-830 ELSE IF (CA-LB-ANZRA NOT = ZERO) AND (CA-LB-RATE NOT = ZERO) CONTINUE PERFORM PL-830 ELSE MOVE 'Q' TO M8ANZRAA MOVE DFHBMBRY TO M8RATEA MOVE -1 TO M8ANZRAL MOVE 30 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL CA-SWFEHL END-IF END-IF. PL-800. %******** EIN ABLAUFDATUM OBLIGATORISCH %******** ***************************** IF (CA-LB-MENDV = SPACE) AND (CA-LB-MENDZ = SPACE) MOVE DFHBMBRY TO M8MENDZA M8MENDVA MOVE -1 TO M8MENDZL MOVE 74 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL CA-SWFEHL ELSE IF (CA-LB-MENDV NOT = SPACE) AND (CA-LB-MENDZ NOT = SPACE) MOVE DFHBMBRY TO M8MENDZA M8MENDVA MOVE -1 TO M8MENDZL MOVE 30 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL CA-SWFEHL ELSE MOVE K-XM278 TO P200-1 CALL 'XM200' USING P-P008 P200-1 Z-DATE Z-CURRDATE PERFORM MODULE MOVE K-XM005 TO P200-1 CALL 'XM200' USING P-P008 P200-1 Z-DUMMY6 Z-CURR-BIN Z-CURRDATE PERFORM MODULE IF CA-LB-MENDV = SPACE CONTINUE ELSE MOVE K-XM005 TO P200-1 CALL 'XM200' USING P-P008 P200-1 Z-DUMMY6 Z-MENDV-BIN CA-LB-MENDV PERFORM MODULE IF Z-MENDV-BIN > Z-CURR-BIN MOVE DFHBMBRY TO M8MENDVA IF SWFEHL = ZERO MOVE -1 TO M8MENDVL MOVE 03 TO FEHL-NR CA-FEHLNR MOVE 1 TO SWFEHL CA-SWFEHL END-IF END-IF END-IF PERFORM PL-810 PERFORM PL-820 END-IF END-IF. PL-690. IF SWFEHL NOT = ZERO CONTINUE ELSE PERFORM PL-800 END-IF. PL-100. MOVE 1 TO CA-SCHRITT. VERARB-SUBROUTINES SECTION. VA-500. %**** PERFORM DRUCKPROGRAMM, RETURN-CODE MIT QUITTUNG %**** AN BENUETZER ZURUECKGEBEN (NUR BEI PF11) MOVE ZERO TO CA-FEHLNR IF CA-SACHB1 = SPACE MOVE CA-SACHB2 TO CA-SACHB1 MOVE SPACE TO CA-SACHB2 END-IF MOVE SPACE TO P1-XM314 MOVE CA-ABS1 TO P1-XM314-EL ( 1 ) MOVE CA-ABS2 TO P1-XM314-EL ( 2 ) MOVE CA-ABS3 TO P1-XM314-EL ( 3 ) MOVE CA-ABS4 TO P1-XM314-EL ( 4 ) MOVE K-XM314 TO P200-1 CALL 'XM200' USING P-P008 P200-1 P1-XM314 P2-XM314 PERFORM MODULE MOVE P1-XM314-EL ( 1 ) TO CA-ABS1 MOVE P1-XM314-EL ( 2 ) TO CA-ABS2 MOVE P1-XM314-EL ( 3 ) TO CA-ABS3 MOVE P1-XM314-EL ( 4 ) TO CA-ABS4 PERFORM ADRKOMPR IF CA-ADRESS-SWITCHES NOT = SPACE PERFORM ADRINSERT END-IF IF SWPF NOT = 11 MOVE -1 TO M8SACHTL ELSE PERFORM PRGLINK IF CA-FEHLNR = ZERO MOVE 253 TO CA-FEHLNR END-IF MOVE -1 TO M8SACHTL MOVE 1 TO SWFEHL MOVE CA-FEHLNR TO FEHL-NR END-IF. %* ADRESS-LEERZEILEN ELIMINIEREN %* ***************************** %* GEWUENSCHTE LEERZEILEN INSERTEN %* ******************************* %**** ENDE VERARBEITUNG DER DATEN CAFILL-SUBROUTINES SECTION. FEHLMELD-SUBROUTINES SECTION. MODULE-SUBROUTINES SECTION. PRGLINK-SUBROUTINES SECTION. SCREENFILL-SUBROUTINES SECTION. SCRIDENT-SUBROUTINES SECTION. ADRINSERT-SUBROUTINES SECTION. ADRKOMPR-SUBROUTINES SECTION. SENDEN-SUBROUTINES SECTION. SE-100. %* EXEC CICS SEND MAP ('DBRIM8F') %* MAPSET ('DBRIS8') %* FROM (DBRIM8DO) %* FREEKB %* CURSOR %* WAIT ERASE %* END-EXEC. MOVE 'SN' TO X-CICS-FUNCTION MOVE DBRIM8DO TO X-CICS-MAP EXEC CICS LINK PROGRAM ( 'XTPOUT' ) COMMAREA ( X-CICS-PARAM ) LENGTH ( X-CICS-PARAM-LNG ) END-EXEC MOVE X-CICS-RETCODE TO EIBRESP. SENDFEHL-SUBROUTINES SECTION. SF-100. %* EXEC CICS SEND MAP ('DBRIM8F') %* MAPSET ('DBRIS8') %* FROM (DBRIM8DO) %* CURSOR %* FREEKB %* WAIT ERASE %* END-EXEC. MOVE 'SN' TO X-CICS-FUNCTION MOVE DBRIM8DO TO X-CICS-MAP EXEC CICS LINK PROGRAM ( 'XTPOUT' ) COMMAREA ( X-CICS-PARAM ) LENGTH ( X-CICS-PARAM-LNG ) END-EXEC MOVE X-CICS-RETCODE TO EIBRESP. RECEIVEN-SUBROUTINES SECTION. RE-100. %* EXEC CICS RECEIVE MAP ('DBRIM8F') %* MAPSET ('DBRIS8') %* INTO (DBRIM8DI) %* END-EXEC. MOVE 'RC' TO X-CICS-FUNCTION MOVE DBRIM8DI TO X-CICS-MAP EXEC CICS LINK PROGRAM ( 'XTPINP' ) COMMAREA ( X-CICS-PARAM ) LENGTH ( X-CICS-PARAM-LNG ) END-EXEC MOVE X-CICS-RETCODE TO EIBRESP EVALUATE TRUE WHEN X-MAPFAIL %* GO TO VV-860 PERFORM VV-860 WHEN X-PF1 %* GO TO VV-710 PERFORM VV-710 WHEN X-PF2 %* GO TO VV-720 PERFORM VV-720 WHEN X-PF3 %* GO TO VV-730 PERFORM VV-730 WHEN X-PF10 %* GO TO VV-800 PERFORM VV-800 WHEN X-PF11 %* GO TO VV-810 PERFORM VV-810 WHEN X-PF12 %* GO TO VV-820 PERFORM VV-820 WHEN X-CLEAR %* GO TO VV-840 PERFORM VV-840 WHEN X-ANYKEY %* GO TO VV-850 PERFORM VV-850 END-EVALUATE. TRANSID-SUBROUTINES SECTION. XCTL-SUBROUTINES SECTION. XJUMP-SUBROUTINES SECTION.