ProCalc COBOL Program
NEXT+ ...1....*....2....*....3....*....4....*....5....*....6....*....7..
001000$SET LIST FREE XREF
001100$SHARING = SHAREDBYALL
001200$SET TEMPORARY FEDLEVEL = 5
001300*
001400***************************************************************
001500* $ OPTION CARDS: SHARING MUST BE SHAREDBYALL TO FORCE ONLY *
001600* ONE COPY OF THE LIBRARY. TEMPORARY CAUSES *
001700* THE LIBRARY TO LEAVE THE MIX WHEN NONE OF *
001800* PROGRAMS THAT ACCESS IT ARE IN THE MIX. *
001900***************************************************************
002000*
002100*************************
002200 IDENTIFICATION DIVISION.
002300*************************
002400
002500***************************************************************
002600* PROGRAM ID IS NOT NEEDED SINCE THE ENTRY POINT FROM LINC IS*
002700* "PROCEDURE DIVISION". *
002800***************************************************************
002900*
003000*****PROGRAM-ID.
003100 AUTHOR. GARY KUCHARK.
003200 DATE-WRITTEN. JANUARY 1996.
003300 DATE-COMPILED.
003400******************************************************************
003500*REMARKS.
003600* PURPOSE. TO DETERMINE THE PRORATION CALCULATION FOR AN
003700* HC STUDENT BASED ON DATES OF SERVICE. THE
003800* SERVICE START AND END DATE IS PASSED TO THIS
003900* PROGRAM IN THE LINC GLB.PARAM FIELD, AND IS
004000* MOVED TO THIS PROGRAM'S ??? FIELD.
004100* THE RESULTING PRORATE VALUE IS PASSED BACK TO
004200* THE CALLING PROGRAM IN THE ??? FIELD.
004300* VALUES ARE PASSED BACK AND FORTH IN THE LINC
004400* SYSTEM DATA ITEM 'GLB.PARAM'.
004500*
004600* ENTRY POINTS: THE ENTRY POINT TO THIS LIBRARY IS THE
004700* PROCEDUREDIVISION.
004800*
004900* REFS: REFER TO THE COBOL MANUAL AND SOG VOLUME 2 FOR
005000* MORE INFORMATION ON LIBRARIES. (LOTSA LUCK!)
005100*
005200****************************************************************
005300/
005400**********************
005500 ENVIRONMENT DIVISION.
005600**********************
005700
005800 CONFIGURATION SECTION.
005900
006000 SOURCE-COMPUTER. A16.
006100 OBJECT-COMPUTER. A16.
006200*
006300/
006400***************
006500 DATA DIVISION.
006600***************
006700*
006800/
006900*************************
007000 WORKING-STORAGE SECTION.
007100*************************
007200*
007300*****************************************************
007400* FOR LIBRARY PROGRAMS, THE DESIGNATION 'REF' IS *
007500* REQUIRED AFTER THE DATA ITEM THAT IS USED. *
007600*****************************************************
007700*
007800********************************************
007900* NOTE: WS-FILE-NAM-C MUST BE TERMINATED *
008000* WITH A PERIOD OR THE MESSAGE *
008100* "ATTRIBUTE ERROR IN IN1-EXTRACT-FILE.TI*
008200* TLE ILLEGAL STRING @ (LINE) 600400" *
008300* WILL BE RECEIVED A RUN TIME AND THE *
008400* PROGRAM WILL NOT RUN CORRECTLY. *
008500********************************************
008600*
008700 01 WS-GLOBPARAM REF.
008800 03 WS-BEG-CCYYMMDD PIC 9(8).
008900 03 WS-END-CCYYMMDD PIC 9(8).
009000 03 WS-VARIANT PIC X.
009100 03 WS-PERIOD PIC X.
009200 03 WS-DURATION PIC XX.
009300* Test stuff
009400 03 WS-BEGIN PIC X(15).
009500 03 WS-END PIC X(15).
009600* 03 WS-TEST1 PIC 99.
009700* 03 WS-TEST2 PIC 99.
009800* 03 WS-TEST3 PIC 9.
009900* 03 WS-TEST4 PIC 9999.
010000* 03 WS-TEST5 PIC 9999.
010100* 03 WS-TEST6 PIC 9999.
010200* 03 WS-TEST7 PIC 9.
010300* 03 WS-TEST8 PIC 9.
010400* 03 WS-TEST9 PIC 9.
010500* 03 WS-TEST10 PIC 9.
010600* 03 WS-GLB-DATE PIC 9(8).
010700* 03 WS-GLB-JJUL PIC 999.
010800
010900 01 PRORATE-REC.
011000 05 PRORATE-DATA-FIELDS.
011100 10 PRO-GREG-DATE.
011200 15 PRO-GREG-MM PIC 99.
011300 15 PRO-GREG-DD PIC 99.
011400 10 PRO-JJUL-DATE PIC 999.
011500 10 PRO-MONTH-SUB PIC 99.
011600 10 PRO-DAYS-IN-MONTH PIC 99.
011700 10 PRO-DAY-SUB PIC 9.
011800 10 PRO-FIRST-DAY-OF-MONTH PIC 9.
011900 10 PRO-5WK-MONTH PIC 9.
012000
012100 01 MONTHS-ARAY.
012200* Based on school year months, 07-06.
012300 03 FILLER PIC 9(5) VALUE 31031.
012400 03 FILLER PIC 9(5) VALUE 31062.
012500 03 FILLER PIC 9(5) VALUE 30092.
012600 03 FILLER PIC 9(5) VALUE 31123.
012700 03 FILLER PIC 9(5) VALUE 30153.
012800 03 FILLER PIC 9(5) VALUE 31184.
012900 03 FILLER PIC 9(5) VALUE 31215.
013000 03 FILLER PIC 9(5) VALUE 28243.
013100 03 FILLER PIC 9(5) VALUE 31274.
013200 03 FILLER PIC 9(5) VALUE 30304.
013300 03 FILLER PIC 9(5) VALUE 31335.
013400 03 FILLER PIC 9(5) VALUE 30365.
013500 01 MONTHS-ARRAY REDEFINES MONTHS-ARAY.
013600 03 DAYS-N-JULIAN OCCURS 12 TIMES.
013700 05 DAYS-IN-MONTH PIC 99.
013800 05 JULIAN-VALUE PIC 999.
013900
014000 01 WS-JULIAN-DAYS PIC 9(5).
014100
014200 01 WS-LEAP-YEARS PIC 9.
014300
014400 01 WS-DAYS-REM PIC 9.
014500
014600 01 WS-DAY-SUB PIC 9.
014700
014800 01 WS-JJUL-DATE PIC 999.
014900
015000 01 WS-JULDATE.
015100 03 WS-JULD PIC 9(5).
015200
015300 01 WS-JULSPLIT.
015400 05 WS-JULD-YY PIC 99.
015500 05 WS-JULD-DDD PIC 999.
015600
015700 01 WS-GDATE.
015800 03 WS-GD PIC 9(6).
015900
016000 01 WS-DATE.
016100 03 WS-YEAR PIC 9999.
016200 03 WS-MM PIC 99.
016300 03 WS-DD PIC 99.
016400
016500 01 WS-TOSS PIC 9999.
016600
016700 77 WS-JULBIN PIC 9(11) BINARY.
016800 77 WS-DAY PIC 9(11) BINARY.
016900
017000 01 WS-REM PIC 9.
017100 88 LEAP-YEAR VALUE 0.
017200
017300******************************************************************
017400* P R O R A T I O N C A L C U L A T I O N *
017500* ( P R O - C A L C ) *
017600* W O R K I N G - S T O R A G E C O D I N G *
017700******************************************************************
017800*ONLY FIELDS REFERENCED BY THE PROGRAM ARE SHOWN ON THE PROGRAM *
017900*LISTING IN ORDER TO SAVE SPACE AND TO PRESERVE LOGIC FLOW. *
018000******************************************************************
018100* TO USE PRO-CALC: *
018200* 1)MOVE YOUR BEGINNING DATE (MMDDYY) TO PC-DURATION-BEGIN *
018300* 2)MOVE YOUR ENDING DATE (MMDDYY) TO PC-DURATION-END *
018400* 3)IF THE SERVICE IS A SUMMER VARIANT PROGRAM, *
018500* MOVE "Y" TO PC-VARIANT *
018600* 4)PERFORM THE PRO-CALC CODING *
018700* 5)THE RESULT WILL BE FOUND IN THE PC-DURATION FIELD *
018800* (PIC 99) EXPRESSED IN WEEKS *
018900* 6)NUMBER OF DAYS BETWEEN BEG AND END DATE WILL BE IN *
019000* PC-DAYS-IN-PROGRAM. INCLUDES BEG AND END DAY IN COUNT.*
019100* *
019200******************************************************************
019300*
019400 01 PC-PRORATE-DATA.
019500*
019600 03 PC-DURATION-DATES.
019700*
019800******************************************************************
019900*THE CALCULATION BEGINNING DATE MUST BE MOVED HERE (MMDDYY ORDER)*
020000******************************************************************
020100*
020200 05 PC-DURATION-BEGIN.
020300 10 PC-DUR-B-CC PIC 99.
020400 10 PC-DUR-B-YY PIC 99.
020500 10 PC-DUR-B-MM PIC 99.
020600 10 PC-DUR-B-DD PIC 99.
020700*
020800******************************************************************
020900*THE CALCULATION ENDING DATE MUST BE MOVED HERE (MMDDYY ORDER) *
021000******************************************************************
021100*
021200 05 PC-DURATION-END.
021300 10 PC-DUR-E-CC PIC 99.
021400 10 PC-DUR-E-YY PIC 99.
021500 10 PC-DUR-E-MM PIC 99.
021600 10 PC-DUR-E-DD PIC 99.
021700*
021800******************************************************************
021900*IF THE CALCULATION DATES ARE VARIANT, MOVE A "Y" TO THIS FIELD. *
022000******************************************************************
022100*
022200 03 PC-VARIANT PIC X.
022300*
022400******************************************************************
022500*THIS FIELD CONTAINS THE WEEKS CALCULATION DERIVED BY THE PRORA- *
022600*TION CALCULATION. *
022700******************************************************************
022800*
022900 03 PC-DURATION PIC 99.
023000*
023100******************************************************************
023200*THIS FIELD CONTAINS THE DAYS BETWEEN THE BEG AND END DATE OF *
023300*THE PROGRAM. *
023400******************************************************************
023500*
023600 03 PC-DAYS-IN-7DAY-PROGRAM PIC 999.
023700*
023800******************************************************************
023900*THE FOLLOWING FIELD CONTAINS THE PRORATE FILE STATUS. IT IS DIS-*
024000*PLAYED IF A READ PROBLEM OCCURS. *
024100******************************************************************
024200*
024300 03 PC-STAT PIC XX.
024400******************************************************************
024500*RESET LIST
024600******************************************************************
024700*THIS TABLE IS USED TO DETERMINE THE NUMBER OF WEEKS DIFFERENCE *
024800*WITHIN DAYS IN A MONTH. (USED FOR ALL EXCEPT SUMMER PLACEMENTS) *
024900******************************************************************
025000*
025100 03 PC-DAYS-TABLE.
025200* SUNDAY TABLE.
025300 05 FILLER PIC 99 VALUE 03.
025400 05 FILLER PIC 99 VALUE 10.
025500 05 FILLER PIC 99 VALUE 17.
025600 05 FILLER PIC 99 VALUE 24.
025700 05 FILLER PIC 99 VALUE 31.
025800* MONDAY TABLE.
025900 05 FILLER PIC 99 VALUE 02.
026000 05 FILLER PIC 99 VALUE 09.
026100 05 FILLER PIC 99 VALUE 16.
026200 05 FILLER PIC 99 VALUE 23.
026300 05 FILLER PIC 99 VALUE 31.
026400* TUESDAY TABLE.
026500 05 FILLER PIC 99 VALUE 02.
026600 05 FILLER PIC 99 VALUE 08.
026700 05 FILLER PIC 99 VALUE 15.
026800 05 FILLER PIC 99 VALUE 22.
026900 05 FILLER PIC 99 VALUE 31.
027000* WEDNESDAY TABLE.
027100 05 FILLER PIC 99 VALUE 02.
027200 05 FILLER PIC 99 VALUE 07.
027300 05 FILLER PIC 99 VALUE 14.
027400 05 FILLER PIC 99 VALUE 21.
027500 05 FILLER PIC 99 VALUE 31.
027600* THURSDAY TABLE.
027700 05 FILLER PIC 99 VALUE 06.
027800 05 FILLER PIC 99 VALUE 13.
027900 05 FILLER PIC 99 VALUE 20.
028000 05 FILLER PIC 99 VALUE 27.
028100 05 FILLER PIC 99 VALUE 31.
028200* FRIDAY TABLE.
028300 05 FILLER PIC 99 VALUE 05.
028400 05 FILLER PIC 99 VALUE 12.
028500 05 FILLER PIC 99 VALUE 19.
028600 05 FILLER PIC 99 VALUE 26.
028700 05 FILLER PIC 99 VALUE 31.
028800* SATURDAY TABLE.
028900 05 FILLER PIC 99 VALUE 04.
029000 05 FILLER PIC 99 VALUE 11.
029100 05 FILLER PIC 99 VALUE 18.
029200 05 FILLER PIC 99 VALUE 25.
029300 05 FILLER PIC 99 VALUE 31.
029400 03 PC-DAYS-TAB REDEFINES PC-DAYS-TABLE.
029500 05 PC-DAY-OF-WEEK OCCURS 7 TIMES.
029600 10 PC-DAY-DIFFERENCE
029700 PIC 99 OCCURS 5 TIMES.
029800*
029900******************************************************************
030000*THIS TABLE IS USED TO DETERMINE THE NUMBER OF WEEKS DIFFERENCE *
030100*WITHIN DAYS IN A MONTH. (USED FOR SUMMER PLACEMENTS) *
030200******************************************************************
030300*
030400 03 PC-DAYS-TABLE-S.
030500* SUNDAY TABLE.
030600 05 FILLER PIC 99 VALUE 03.
030700 05 FILLER PIC 99 VALUE 10.
030800 05 FILLER PIC 99 VALUE 17.
030900 05 FILLER PIC 99 VALUE 24.
031000 05 FILLER PIC 99 VALUE 31.
031100 05 FILLER PIC 99 VALUE 99.
031200* MONDAY TABLE.
031300 05 FILLER PIC 99 VALUE 02.
031400 05 FILLER PIC 99 VALUE 09.
031500 05 FILLER PIC 99 VALUE 16.
031600 05 FILLER PIC 99 VALUE 23.
031700 05 FILLER PIC 99 VALUE 30.
031800 05 FILLER PIC 99 VALUE 31.
031900* TUESDAY TABLE.
032000 05 FILLER PIC 99 VALUE 02.
032100 05 FILLER PIC 99 VALUE 08.
032200 05 FILLER PIC 99 VALUE 15.
032300 05 FILLER PIC 99 VALUE 22.
032400 05 FILLER PIC 99 VALUE 29.
032500 05 FILLER PIC 99 VALUE 31.
032600* WEDNESDAY TABLE.
032700 05 FILLER PIC 99 VALUE 02.
032800 05 FILLER PIC 99 VALUE 07.
032900 05 FILLER PIC 99 VALUE 14.
033000 05 FILLER PIC 99 VALUE 21.
033100 05 FILLER PIC 99 VALUE 28.
033200 05 FILLER PIC 99 VALUE 31.
033300* THURSDAY TABLE.
033400 05 FILLER PIC 99 VALUE 06.
033500 05 FILLER PIC 99 VALUE 13.
033600 05 FILLER PIC 99 VALUE 20.
033700 05 FILLER PIC 99 VALUE 27.
033800 05 FILLER PIC 99 VALUE 31.
033900 05 FILLER PIC 99 VALUE 99.
034000* FRIDAY TABLE.
034100 05 FILLER PIC 99 VALUE 05.
034200 05 FILLER PIC 99 VALUE 12.
034300 05 FILLER PIC 99 VALUE 19.
034400 05 FILLER PIC 99 VALUE 26.
034500 05 FILLER PIC 99 VALUE 31.
034600 05 FILLER PIC 99 VALUE 99.
034700* SATURDAY TABLE.
034800 05 FILLER PIC 99 VALUE 04.
034900 05 FILLER PIC 99 VALUE 11.
035000 05 FILLER PIC 99 VALUE 18.
035100 05 FILLER PIC 99 VALUE 25.
035200 05 FILLER PIC 99 VALUE 31.
035300 05 FILLER PIC 99 VALUE 99.
035400 03 PC-DAYS-TAB-S REDEFINES PC-DAYS-TABLE-S.
035500 05 PC-DAY-OF-WEEK-S OCCURS 7 TIMES.
035600 10 PC-DAY-DIFFERENCE-S
035700 PIC 99 OCCURS 6 TIMES.
035800*
035900******************************************************************
036000*THESE FIELDS ARE USED TO DETERMINE VARIANT PROGRAM "JUNE" DATE *
036100*LEAP YEAR AND REGULAR YEAR CALCULATIONS. *
036200******************************************************************
036300*
036400 03 PC-YEAR PIC 99.
036500 03 PC-REM PIC 99.
036600*
036700 03 PC-VARIANT-COMPARE-DATES.
036800 05 PC-DAY PIC 9.
036900 05 PC-FIRST-DAY-OF-MONTH
037000 PIC 9.
037100*
037200******************************************************************
037300*THESE FIELDS ARE SUBSCRIPTS USED BY THE PRORATION CALCULATION. *
037400******************************************************************
037500*
037600 03 PRORATION-SUBSCRIPTS.
037700 05 PC-DAYS-DIFF PIC 99.
037800 05 PC-DAY-SUB PIC 99.
037900 05 PC-DIFF-SUB PIC 99.
038000*
038100******************************************************************
038200*THESE FIELDS ARE USED AS A KEY TO READ THE PRORATION FILE. *
038300******************************************************************
038400*
038500 03 PC-PRO-KEY.
038600 05 PC-PRO-MM PIC XX.
038700 05 PC-PRO-DD PIC 99.
038800*
038900******************************************************************
039000*THE BEGINNING DATE DATA READ FROM THE PRORATION FILE IS *
039100*STORED HERE. *
039200******************************************************************
039300*
039400 03 PC-BEG-FIELDS.
039500 05 PC-BEG-GREG-DATE PIC 9(4).
039600 05 PC-BEG-JJUL-DATE PIC 999.
039700 05 PC-BEG-MONTH-SUB PIC 99.
039800 05 PC-BEG-DAYS-IN-MONTH
039900 PIC 99.
040000 05 PC-BEG-DAY-OF-WEEK
040100 PIC 9.
040200 05 PC-BEG-FIRST-DAY-OF-MONTH
040300 PIC 9.
040400 05 PC-BEG-5WK-MONTH PIC 9.
040500*
040600******************************************************************
040700*THE ENDING DATE DATA READ FROM THE PRORATION FILE IS STORED *
040800*HERE. *
040900******************************************************************
041000*
041100 03 PC-END-FIELDS.
041200 05 PC-END-GREG-DATE PIC 9(4).
041300 05 PC-END-JJUL-DATE PIC 999.
041400 05 PC-END-MONTH-SUB PIC 99.
041500 05 PC-END-DAYS-IN-MONTH
041600 PIC 99.
041700 05 PC-END-DAY-OF-WEEK
041800 PIC 9.
041900 05 PC-END-FIRST-DAY-OF-MONTH
042000 PIC 9.
042100 05 PC-END-5WK-MONTH PIC 9.
042200
042300/
042400********************
042500 PROCEDURE DIVISION
042600********************
042700
042800 USING WS-GLOBPARAM.
042900
043000 1000-HOUSEKEEPING.
043100
043200*****************************************************
043300* Added for the LINC library routine coding. *
043400*****************************************************
043500*
043600 MOVE WS-BEG-CCYYMMDD TO PC-DURATION-BEGIN.
043700 MOVE WS-END-CCYYMMDD TO PC-DURATION-END.
043800 MOVE WS-VARIANT TO PC-VARIANT.
043900*
044000******************************************************************
044100* P R O R A T I O N C A L C U L A T I O N *
044200* ( P R O - C A L C ) *
044300* P R O C E D U R E D I V I S I O N C O D I N G *
044400******************************************************************
044500*THIS CODING IS NOT SHOWN ON THE PROGRAM LISTING IN ORDER TO SAVE*
044600*SPACE AND TO PRESERVE LOGIC FLOW. *
044700******************************************************************
044800* TO USE PRO-CALC: *
044900* 1)MOVE YOUR BEGINNING DATE (MMDDYY) TO PC-DURATION-BEGIN *
045000* 2)MOVE YOUR ENDING DATE (MMDDYY) TO PC-DURATION-END *
045100* 3)IF THE SERVICE IS A SUMMER VARIANT PROGRAM, *
045200* MOVE "Y" TO PC-VARIANT *
045300* 4)PERFORM THE PRO-CALC CODING *
045400* 5)THE RESULT WILL BE FOUND IN THE PC-DURATION FIELD *
045500* (PIC 99) EXPRESSED IN WEEKS *
045600* *
045700******************************************************************
045800
045900
046000******************************************************************
046100*THIS IS THE CONTROL MODULE FOR THE PRORATION CALCULATION. *
046200******************************************************************
046300*
046400 POOO-DETERMINE-PRORATE.
046500 IF PC-VARIANT = "1"
046600 MOVE "Y" TO PC-VARIANT.
046700*
046800 MOVE PC-DURATION-BEGIN TO WS-DATE.
046900*
047000 PERFORM P040-READ-PRORATEFILE.
047100 MOVE PRORATE-DATA-FIELDS TO PC-BEG-FIELDS.
047200*
047300 MOVE PC-DURATION-END TO WS-DATE.
047400*
047500 PERFORM P040-READ-PRORATEFILE.
047600 MOVE PRORATE-DATA-FIELDS TO PC-END-FIELDS.
047700* Test stuff
047800 MOVE PC-BEG-FIELDS TO WS-BEGIN.
047900 MOVE PC-END-FIELDS TO WS-END.
048000*
048100 COMPUTE PC-DAYS-IN-7DAY-PROGRAM =
048200 PC-END-JJUL-DATE - PC-BEG-JJUL-DATE + 1.
048300
048400 IF (PC-DUR-B-MM = 06) AND (PC-VARIANT = "Y")
048500 ADD 1 PC-DUR-B-YY
048600 GIVING PC-YEAR
048700 DIVIDE PC-YEAR BY 4
048800 GIVING PC-YEAR
048900 REMAINDER PC-REM
049000 MOVE PC-BEG-DAY-OF-WEEK TO PC-DAY
049100 MOVE PC-BEG-FIRST-DAY-OF-MONTH TO PC-FIRST-DAY-OF-MONTH
049200 PERFORM P003-DETERMINE-VARIANT-DATES
049300 MOVE ZERO TO PC-BEG-MONTH-SUB
049400 MOVE PC-DAY TO PC-BEG-DAY-OF-WEEK
049500 MOVE PC-FIRST-DAY-OF-MONTH TO PC-BEG-FIRST-DAY-OF-MONTH.
049600*
049700 IF (PC-DUR-E-MM = 06) AND (PC-VARIANT = "Y")
049800 ADD 1 PC-DUR-E-YY
049900 GIVING PC-YEAR
050000 DIVIDE PC-YEAR BY 4
050100 GIVING PC-YEAR
050200 REMAINDER PC-REM
050300 MOVE PC-END-DAY-OF-WEEK TO PC-DAY
050400 MOVE PC-END-FIRST-DAY-OF-MONTH TO PC-FIRST-DAY-OF-MONTH
050500 PERFORM P003-DETERMINE-VARIANT-DATES
050600 MOVE ZERO TO PC-END-MONTH-SUB
050700 MOVE PC-DAY TO PC-END-DAY-OF-WEEK
050800 MOVE PC-FIRST-DAY-OF-MONTH TO PC-END-FIRST-DAY-OF-MONTH.
050900*
051000 SUBTRACT PC-BEG-MONTH-SUB FROM PC-END-MONTH-SUB
051100 GIVING PC-DURATION.
051200 IF PC-DURATION > ZERO
051300 SUBTRACT 1 FROM PC-DURATION
051400 MULTIPLY 4 BY PC-DURATION
051500 PERFORM P010-DETERMINE-LONG-DUR
051600 ELSE
051700 PERFORM P015-DETERMINE-SHORT-DUR.
051800******************************************************************
051900 IF (PC-DUR-B-MM = 06) AND (PC-DUR-E-MM = 08)
052000 MOVE PC-DURATION-BEGIN TO WS-DATE
052100 MOVE 07 TO WS-MM
052200 MOVE 01 TO WS-DD
052300* MOVE "0701" TO PC-PRO-KEY
052400 PERFORM P005-DETERMINE-5WK
052500 GO TO P100-PRORATE-EXIT.
052600*
052700 IF (PC-DUR-B-MM = 06) AND (PC-DUR-E-MM = 09)
052800 MOVE PC-DURATION-BEGIN TO WS-DATE
052900 MOVE 07 TO WS-MM
053000 MOVE 01 TO WS-DD
053100* MOVE "0701" TO PC-PRO-KEY
053200 PERFORM P005-DETERMINE-5WK
053300 IF PC-BEG-5WK-MONTH = 1
053400 GO TO P100-PRORATE-EXIT
053500 ELSE
053600 MOVE PC-DURATION-BEGIN TO WS-DATE
053700 MOVE 08 TO WS-MM
053800 MOVE 01 TO WS-DD
053900* MOVE "0801" TO PC-PRO-KEY
054000 PERFORM P005-DETERMINE-5WK
054100 GO TO P100-PRORATE-EXIT.
054200*
054300 IF (PC-DUR-B-MM = 07) AND (PC-DUR-E-MM NOT = 07 AND 08)
054400 MOVE PC-DURATION-BEGIN TO WS-DATE
054500 MOVE 08 TO WS-MM
054600 MOVE 01 TO WS-DD
054700* MOVE "0801" TO PC-PRO-KEY
054800 PERFORM P005-DETERMINE-5WK
054900 GO TO P100-PRORATE-EXIT.
055000*
055100 IF PC-DURATION = ZERO
055200 MOVE 1 TO PC-DURATION.
055300*
055400 GO TO P100-PRORATE-EXIT.
055500*
055600******************************************************************
055700*THIS MODULE IS USED TO "ADJUST" VARIANT PROGRAM DATES IF THEY *
055800*FALL WITHIN THE MONTH OF JUNE. THIS ADJUSTMENT IS NECESSARY *
055900*SINCE THE PRORATION FILE IS CREATED TO REFLECT JULY-JUNE SCHOOL *
056000*YEAR DATES. *
056100******************************************************************
056200*
056300 P003-DETERMINE-VARIANT-DATES.
056400 IF PC-REM = ZERO
056500 IF PC-DAY > 2
056600 SUBTRACT 2 FROM PC-DAY
056700 ELSE
056800 IF PC-DAY = 2
056900 MOVE 7 TO PC-DAY
057000 ELSE
057100 MOVE 6 TO PC-DAY
057200 ELSE
057300 IF PC-DAY > 1
057400 SUBTRACT 1 FROM PC-DAY
057500 ELSE
057600 MOVE 7 TO PC-DAY.
057700*
057800 IF PC-REM = ZERO
057900 IF PC-FIRST-DAY-OF-MONTH > 2
058000 SUBTRACT 2 FROM PC-FIRST-DAY-OF-MONTH
058100 ELSE
058200 IF PC-FIRST-DAY-OF-MONTH = 2
058300 MOVE 7 TO PC-FIRST-DAY-OF-MONTH
058400 ELSE
058500 MOVE 6 TO PC-FIRST-DAY-OF-MONTH
058600 ELSE
058700 IF PC-FIRST-DAY-OF-MONTH > 1
058800 SUBTRACT 1 FROM PC-FIRST-DAY-OF-MONTH
058900 ELSE
059000 MOVE 1 TO PC-FIRST-DAY-OF-MONTH.
059100*
059200*****************************************************************
059300*THIS MODULE DETERMINES IF AN EXTRA WEEK NEEDS TO BE ADDED FOR *
059400*SUMMER DATES (BECAUSE THEY ENCOMPASS A 5 WEEK MONTH). *
059500*****************************************************************
059600*
059700 P005-DETERMINE-5WK.
059800 PERFORM P040-READ-PRORATEFILE.
059900 MOVE PRORATE-DATA-FIELDS TO PC-BEG-FIELDS.
059920* The following code commented out to eliminate incorrect 49 week
059940* calc for programs. GMK 6/30/97
060000* IF PC-BEG-5WK-MONTH = 1
060100* ADD 1 TO PC-DURATION.
060200*
060300*****************************************************************
060400*THIS MODULE IS PERFORMED TO DETERMINE THE PRORATION CALCULATION*
060500*WHEN THE BEGINNING AND ENDING DATES ARE NOT IN THE SAME MONTH. *
060600*****************************************************************
060700*
060800 P010-DETERMINE-LONG-DUR.
060900 SUBTRACT PC-DUR-B-DD FROM PC-BEG-DAYS-IN-MONTH
061000 GIVING PC-DAYS-DIFF.
061100 MOVE PC-BEG-DAY-OF-WEEK TO PC-DAY-SUB.
061200 IF (PC-DUR-B-MM = 07 OR 08) AND (PC-DUR-E-MM = 07 OR 08)
061400 PERFORM P030-CHECK-SUMMER-DAYS
061500 PERFORM P035-CHECK-SUMMER-BEGIN-MONTH
061600 ELSE
061700 PERFORM P020-CHECK-DAYS.
061800*
061900 SUBTRACT 1 FROM PC-DUR-E-DD
062000 GIVING PC-DAYS-DIFF.
062100 MOVE PC-END-FIRST-DAY-OF-MONTH TO PC-DAY-SUB.
062200 IF (PC-DUR-E-MM = 07 OR 08) AND (PC-DUR-B-MM = 07 OR 08)
062400 PERFORM P030-CHECK-SUMMER-DAYS
062500 PERFORM P036-CHECK-SUMMER-END-MONTH
062600 ELSE
062700 PERFORM P020-CHECK-DAYS.
062800*
062900*****************************************************************
063000*THIS MODULE IS USED TO DETERMINE THE PRORATION CALCULATION WHEN*
063100*THE BEGINNING AND ENDING DATES ARE IN THE SAME MONTH. *
063200*****************************************************************
063300*
063400 P015-DETERMINE-SHORT-DUR.
063500 SUBTRACT PC-DUR-B-DD FROM PC-DUR-E-DD
063600 GIVING PC-DAYS-DIFF.
063700 MOVE PC-BEG-DAY-OF-WEEK TO PC-DAY-SUB.
063800 IF (PC-DUR-B-MM = 07 OR 08) OR
063900 ((PC-DUR-B-MM = 06 OR 09) AND (PC-VARIANT = "Y"))
064000 PERFORM P030-CHECK-SUMMER-DAYS
064100 ELSE
064200 PERFORM P020-CHECK-DAYS.
064300*
064400*****************************************************************
064500*THIS MODULE IS USED TO DETERMINE HOW MANY WEEKS (IF ANY) SHOULD*
064600*BE ADDED TO THE PRORATION CALCULATION TO ACCOUNT FOR A PARTIAL *
064700*MONTH ENROLLMENT.(USED FOR SCHOOL YEAR ONLY) *
064800*****************************************************************
064900*
065000 P020-CHECK-DAYS.
065100 PERFORM P021-CHECK-DAYS-TABLE
065200 VARYING PC-DIFF-SUB FROM 1 BY 1
065300 UNTIL PC-DIFF-SUB > 5.
065400*
065500 P021-CHECK-DAYS-TABLE.
065600 IF PC-DAYS-DIFF < PC-DAY-DIFFERENCE(PC-DAY-SUB,PC-DIFF-SUB)
065700 SUBTRACT 1 FROM PC-DIFF-SUB
065800 ADD PC-DIFF-SUB TO PC-DURATION
065900 MOVE 5 TO PC-DIFF-SUB.
066000*
066100*****************************************************************
066200*THIS MODULE IS USED TO DETERMINE HOW MANY WEEKS (IF ANY) SHOULD*
066300*BE ADDED TO THE PRORATION CALCULATION TO ACCOUNT FOR A PARTIAL *
066400*MONTH ENROLLMENT.(USED FOR SUMMER ONLY) *
066500*****************************************************************
066600*
066700 P030-CHECK-SUMMER-DAYS.
066800 PERFORM P031-CHECK-SUMMER-DAYS-TABLE
066900 VARYING PC-DIFF-SUB FROM 1 BY 1
067000 UNTIL PC-DIFF-SUB > 6.
067100*
067200 P031-CHECK-SUMMER-DAYS-TABLE.
067300 IF PC-DAYS-DIFF < PC-DAY-DIFFERENCE-S(PC-DAY-SUB,PC-DIFF-SUB)
067400 SUBTRACT 1 FROM PC-DIFF-SUB
067500 ADD PC-DIFF-SUB TO PC-DURATION
067600 MOVE 6 TO PC-DIFF-SUB.
067700*
067800*****************************************************************
067900*THESE MODULES ARE PERFORMED FOR SUMMER MONTHS ONLY. (JULY *
068000*THROUGH AUGUST FOR REGULAR PROGRAMS, JUNE THROUGH SEPTEMBER FOR*
068100*VARIANT PROGRAMS). THEY WILL ADD 1 WEEK OF DURATION TO DATES *
068200*WHICH HAVE "SPLIT MONTHS", WHICH ARE DATES THAT HAVE 1 OR 2 *
068300*DAYS OF DURATION IN ONE MONTH AND THE REST OF THE WEEK IN AN *
068400*ADJACENT MONTH. *
068500*****************************************************************
068600*
068700 P035-CHECK-SUMMER-BEGIN-MONTH.
068800 IF (PC-BEG-DAY-OF-WEEK = 3 AND PC-DAYS-DIFF = 1)
068900 OR
069000 (PC-BEG-DAY-OF-WEEK = 4 AND PC-DAYS-DIFF < 2)
069100 ADD 1 TO PC-DURATION.
069200*
069300 P036-CHECK-SUMMER-END-MONTH.
069400 IF (PC-END-DAY-OF-WEEK = 4 AND PC-DAYS-DIFF < 2)
069500 OR
069600 (PC-END-DAY-OF-WEEK = 5 AND PC-DAYS-DIFF = 1)
069700 ADD 1 TO PC-DURATION.
069800*
069900*****************************************************************
070000*THIS MODULE READS THE PRORATION FILE. *
070100*****************************************************************
070200*
070300 P040-READ-PRORATEFILE.
070400*
070500 MOVE SPACES TO PRORATE-REC.
070600
070700**************************************************************
070800* 1) Find out if this critter is a leap year... *
070900**************************************************************
071000*
071100 DIVIDE WS-YEAR BY 4 GIVING WS-TOSS
071200 REMAINDER WS-REM.
071300*
071400**************************************************************
071500* 2) Determine Month subscript (07=1)[Start of school year] *
071600**************************************************************
071700*
071800 MOVE WS-MM TO PRO-MONTH-SUB.
071900 ADD 6 TO PRO-MONTH-SUB.
072000 IF PRO-MONTH-SUB > 12 THEN
072100 SUBTRACT 12 FROM PRO-MONTH-SUB.
072200*
072300**************************************************************
072400* 3) Determine Gregorian date. *
072500**************************************************************
072600*
072700 MOVE WS-MM TO PRO-GREG-MM.
072800 MOVE WS-DD TO PRO-GREG-DD.
072900*
073000**************************************************************
073100* 4) Determine the number of days in the month. *
073200**************************************************************
073300*
073400 MOVE DAYS-IN-MONTH(PRO-MONTH-SUB) TO PRO-DAYS-IN-MONTH.
073500*
073600**************************************************************
073700* 5) Determine Julian date. *
073800**************************************************************
073900*
074000 IF PRO-MONTH-SUB NOT = 1
074100 MOVE JULIAN-VALUE(PRO-MONTH-SUB - 1) TO PRO-JJUL-DATE.
074200
074300 ADD WS-DD TO PRO-JJUL-DATE.
074400
074500* It's a leap year and past Feb 29th. Add another day to JJUL.
074600 IF LEAP-YEAR AND PRO-JJUL-DATE > 244
074700 ADD 1 TO PRO-JJUL-DATE.
074800*
074900**************************************************************
075000* 6) Determine the day of the week (1=Sunday thru 6=Saturday)*
075100* We've got to add 1 to the result returned here, since *
075200* the function returns a 0 for Sunday and we use a 1. *
075300**************************************************************
075400*
075500 MOVE PRO-JJUL-DATE TO WS-JJUL-DATE.
075600 PERFORM P041-DETERMINE-JJUL-DATE.
075700 MOVE WS-DAY-SUB TO PRO-DAY-SUB.
075800*
075900
076000**************************************************************
076100* 7) Determine the day of the week of the 1st day of the *
076200* month. Same situation as above, add 1 to the result of *
076300* the function call. *
076400**************************************************************
076500*
076600 IF WS-DD > 1
076700 SUBTRACT WS-DD FROM PRO-JJUL-DATE
076800 GIVING WS-JJUL-DATE
076900 ADD 1 TO WS-JJUL-DATE.
077000
077100 PERFORM P041-DETERMINE-JJUL-DATE.
077200 MOVE WS-DAY-SUB TO PRO-FIRST-DAY-OF-MONTH.
077300*
077400**************************************************************
077500* 8) Determine if this is a 5 week month. *
077600**************************************************************
077700*
077800 IF (PRO-FIRST-DAY-OF-MONTH = 2 AND PRO-DAYS-IN-MONTH > 30)
077900 OR
078000 (PRO-FIRST-DAY-OF-MONTH = 3 AND PRO-DAYS-IN-MONTH > 29)
078100 OR
078200 (PRO-FIRST-DAY-OF-MONTH = 4 AND PRO-DAYS-IN-MONTH > 28)
078300 MOVE 1 TO PRO-5WK-MONTH
078400 ELSE
078500 MOVE 0 TO PRO-5WK-MONTH.
078600*
078700 P041-DETERMINE-JJUL-DATE.
078800*
078900* MOVE WS-DATE TO WS-GLB-DATE.
079000* MOVE PRO-JJUL-DATE TO WS-GLB-JJUL.
079100
079200 SUBTRACT 1980 FROM WS-YEAR
079300 GIVING WS-JULIAN-DAYS.
079400* MOVE WS-JULIAN-DAYS TO WS-TEST1.
079500*
079600 IF PRO-JJUL-DATE > 184
079700 SUBTRACT 1 FROM WS-JULIAN-DAYS.
079800* MOVE WS-JULIAN-DAYS TO WS-TEST2.
079900
080000 DIVIDE WS-JULIAN-DAYS BY 4
080100 GIVING WS-LEAP-YEARS.
080200* MOVE WS-LEAP-YEARS TO WS-TEST3.
080300
080400 MULTIPLY WS-JULIAN-DAYS BY 365
080500 GIVING WS-JULIAN-DAYS.
080600* MOVE WS-JULIAN-DAYS TO WS-TEST4.
080700
080800 ADD WS-LEAP-YEARS TO WS-JULIAN-DAYS.
080900* MOVE WS-JULIAN-DAYS TO WS-TEST5.
081000
081100 ADD WS-JJUL-DATE TO WS-JULIAN-DAYS.
081200* MOVE WS-JULIAN-DAYS TO WS-TEST6.
081300
081400 DIVIDE WS-JULIAN-DAYS BY 7
081500 GIVING WS-JULIAN-DAYS
081600 REMAINDER WS-DAYS-REM.
081700* MOVE WS-DAYS-REM TO WS-TEST7.
081800
081900 MOVE 2 TO WS-DAY-SUB.
082000* MOVE WS-DAY-SUB TO WS-TEST8.
082100
082200 ADD WS-DAYS-REM TO WS-DAY-SUB.
082300* MOVE WS-DAY-SUB TO WS-TEST9.
082400
082500 IF WS-DAY-SUB > 7
082600 SUBTRACT 7 FROM WS-DAY-SUB.
082700* MOVE WS-DAY-SUB TO WS-TEST10.
082800*
082900 P041-DETERMINE-JJUL-DATE-EXIT.
083000*
083100
083200 P100-PRORATE-EXIT.
083300 MOVE SPACE TO PC-VARIANT.
083400
083500***************************************************
083600* Added for LINC library routine coding. *
083700***************************************************
083800*
083900 MOVE PC-DURATION TO WS-DURATION.
084000*
084100 EXIT PROGRAM.
#DISPLAY COMPLETE