Share Gallery 1/share_gal_1.zip/share_gal_1/BF/BF015.ZIP/PCPM4.EXE/arc/CPAHOLY.BAS

BASIC Source File | 1987-02-12 | 6KB | 331 lines

    REM **** CPAHOLY ****
    common cpafile$

 UpperCase:
   def fnucase$(cpafile$)
      length=len(cpafile$)

      if length =0 then
         exit def
      end if

      for I=1 to length
         ch=asc(mid$(cpafile$,I,1))

            if ch > 96 and ch < 127 then
            mid$(cpafile$,I,1)=chr$(ch-32)
         end if

        next

      fnucase$=cpafile$
   end def

    cls
    DEFINT A-Z:DEFSNG H,T,Y,D
   DIM H(1000),D$(12)
   CLOSE
   PRINT "**** THIS MODULE CREATES AND MANAGES HOLIDAY [.HOL] FILES ****"
   D$(2)="February"
   D$(3)="March"
   D$(4)="April"
   D$(5)="May"
   D$(6)="June"
   D$(7)="July"
   D$(8)="August"
   D$(9)="September"
   D$(10)="October"
   PRINT
   D$(1)="January"
   D$(11)="November"
   D$(12)="December"
   RSVRD$=".BAS":EXTN$=".HOL"

Start:

    if len(cpafile$) >0 then
        F9$=cpafile$
        goto commndfile
    end if

50 INPUT "Enter the name of the base data file ";F9$
    cpafile$=F9$
    cpafile$=fnucase$(cpafile$)
    F9$=cpafile$

    commndfile:
     GOSUB 12000

    F$=F9$

    GOSUB CheckFileName                 '10250

     IF F9=1 THEN
        goto start                       '50
     end if

     GOSUB ReadHoliday                  '8000 READ HOLIDAY FILE

     IF N=0 THEN
        goto HolidayEnter                '500
     end if

ListOfHolidays:
310 PRINT "**** LIST OF HOLIDAYS FOR THE BASE DATA FILE ";G$;"****"
     PRINT

    FOR I=1 TO N
        D8=H(I)
        GOSUB CvtCentDaMMDDYY                  '4500
        PRINT I;D$(M5);D5;"19";RIGHT$(STR$(Y5),2)

        IF I MOD 20=0 THEN
            INPUT "Press ENTER to Continue ",Q$
        end if

     NEXT I

    PRINT

Ask4Change:
320 INPUT "Do you want to change, add, delete or quit (C/A/D/Q) ";Q$

     IF Q$="Q"or Q$="q" THEN
        goto 440
     end if

     IF Q$="D" THEN
        goto DeleteHol                '2000
     end if

     IF Q$="A" or Q$="a" THEN
        goto HolidayEnter             '500
     end if

     IF Q$<>"C" or Q$<>"c" THEN
        BEEP
        GOTO HolidayEnter             '320
     end if

350 INPUT "Enter number of holiday to change ";K

     IF K>N THEN
        goto 350
     end if

    INPUT "Enter new date in MM,DD,YY format ";M6,D6,Y6

     GOSUB GetDayOfCent                    '5000

    H(K)=D8
     GOTO ListOfHolidays                   '310

440 GOSUB WritAr2Fil                      '3000
     close
     chain "CPAMENU"

HolidayEnter:
500 INPUT "Enter holiday in MM,DD,YY format (0,0,0 if end) ";M6,D6,Y6

     IF M6=0 THEN
        goto ListOfHolidays           '310
     end if

     GOSUB GetDayOfCent                    '5000

     N=N+1
    H(N)=D8
     GOTO HolidayEnter                     '500

EnterHolidays:
1000 I=0
     PRINT "**** ENTER HOLIDAYS IN MM,DD,YY FORMAT - ENTER 0,0,0 IF AT END ****"

1020 I=I+1
     PRINT "Enter holiday";I;
      INPUT M6,D6,Y6

      IF M6=0 THEN
         goto 1090
      end if

      GOSUB GetDayOfCent                   '5000

      H(I)=D8

      GOTO 1020

1090 N=I-1

      GOTO ListOfHolidays                   '310

DeleteHol:
2000 'DELETE

2010 INPUT "Enter number of holiday to delete ";K
      IF K=0 THEN
         goto ListOfHolidays              '310
      end if

      IF K>N THEN
         BEEP
         PRINT "**** INVALID RESPONSE - MAXIMUM IS";N;"****"
         GOTO DeleteHol                    '2010
      end if

     FOR J=K TO N-1
         H(J)=H(J+1)
      NEXT

      N=N-1
      GOTO ListOfHolidays               '310

WritAr2Fil:
3000 REM WRITE ARRAY TO FILE
      INPUT "File changes or Quit (F/Q) ";Q$

      IF LEFT$(Q$,1)="Q" or left$(Q$,1)="q" THEN
         RETURN
      end if

     PRINT "**** FILENAME IS ";F9$;" ****"
     OPEN F9$ FOR OUTPUT AS #1

      FOR I=1 TO N
         WRITE #1,H(I)
      NEXT I

     CLOSE #1
     RETURN

      REM ** CONVERT CENTURY DAY TO MM, DD, YY **************************

CvtCentDaMMDDYY:
4500 T9=INT(D8/1461)
     Y5=INT((D8-T9+364)/365)
     Y4=D8-INT((Y5-1)*1461/4)
      L8=2

      IF Y5/4=INT(Y5/4) THEN
         L8=1
      end if

      T9=Y4

      IF T9>61-L8 THEN
         T9=T9+L8
      end if

     M5=INT((T9*9+269)/275)
     D5=T9-INT(M5*275/9)+30
     D4=D8-INT(D8/7)*7+1
      RETURN

     REM ** GET DAY OF CENTURY OF STARTING DATE **

GetDayOfCent:
5000 L8=2
      IF INT(Y6/4)=Y6/4 THEN
         L8=1
      end if

      D7=INT(M6*275/9)+D6-30

      IF M6>2 THEN
         D7=D7-L8
      end if

     D8=INT((Y6-1)*1461/4)+D7
      RETURN

ReadHoliday:
8000 ON ERROR GOTO 8200
     OPEN F9$ FOR INPUT AS #1
     J=0

8030 J=J+1
      IF EOF(1) THEN
         goto 8100
      end if

     INPUT #1,H(J)
     GOTO 8030

8100 N=J-1  'NUMBER OF HOLIDAYS

8110 CLOSE #1
     RETURN

8200 IF ERR=53 THEN
          PRINT "**** NEW FILE ****"
     end if

      RESUME 8110

     GOTO 11000
      PRINT "**** NEW FILE ****"
      CLOSE #1
      GOTO EnterHolidays                '1000

CheckFileName:
10250 REM SUBROUTINE TO CHECK FILENAMES - PASS IN F9$
      F9=0
        L9=LEN(F9$)

        IF L9>12 OR L9<1 THEN
            BEEP
            GOTO 10274
        end if

      I9=INSTR(F9$,".")
        IF I9<>0 THEN
            goto 10266
        end if

        IF L9<9 THEN
            F9$=F9$+EXTN$
            ELSE F9$=LEFT$(F9$,8)+EXTN$
        end if

        GOTO 10280

10266 IF RIGHT$(F9$,4)=EXTN$ THEN
            goto 10280
        end if

        PRINT "**** WRONG EXTENSION - PLEASE DIAL AGAIN ****"
        BEEP
        GOTO 10278

        IF RIGHT$(F9$,4)=RSRVD$ THEN
            goto 10272
            ELSE goto 10280
        end if

10272 PRINT "**** RESERVED EXTENSION - REENTER ****"
        BEEP

10274 IF L9<1 THEN
            PRINT "**** FILENAME TOO SHORT ****"
        end if

        IF L9>12 THEN
            PRINT "**** FILENAME TOO LONG ****"
        end if

10278 F9=1 'BAD FILENAME - REENTER

10280 RETURN

11000 PRINT "ERROR NUMBER";ERR;"AT LINE";ERL;"PLEASE NOTE"
        END

12000 I1=INSTR(G$,".")

        IF I1<>0 THEN
            G$=LEFT$(G$,I1-1)
        end if

      RETURN