* PROGRAM ID : SUMMER98
* PROG NAME : HOSPITAL BILLING
* PROGRAMMER : MARTIN O'SULLIVAN
* DATE : APRIL 1999
* DATE MODIFIED :
* INSTALLATION : LIMERICK INSTITUTE OF TECHNOLOGY
*****************************************************************
*** INDICATORS = 03 EXIT
*** 99 CHAIN
*** 12 CANCEL
F***********************FILE SPEC*********************************
FHOSTL1 UF E K DISK
FHOSTIP CF E WORKSTN
FHOSREP O E PRINTER
E***********************E SPEC************************************
E TYP# 1 3 1 0 RAT1 6 2
E XTRA 1 2 1 0 RAT2 6 2
E ITM# 1 3 1 0 DESC 20
C***********************MAINLINE CODE*****************************
C EXSR REPHED
C EXSR HEAD
C EXFMTPROMPT
C *IN03 DOWEQ'0'
C *IN12 ANDEQ'0'
C PATNT# CHAINHSPREC 99
C *IN99 IFEQ '1'
C EXFMTERRSCR
C WRITEERROR
C ELSE
C EXSR HEAD
C EXFMTTRNFMT
C *IN12 IFEQ '0'
C *IN03 ANDEQ'0'
C Z-ADD0 RATE 62
C EXSR ROOM
C EXSR SERVEC
C RATE MULT DAYS AMT
C ADD 1 NUMPAT
C WRITEDETAIL
C UPDATHSPREC
C EXFMTAMTSCR
C ENDIF
C ENDIF
C *IN03 IFEQ '0'
C EXSR HEAD
C EXFMTPROMPT
C ENDIF
C ENDDO
C EXSR TOTS
C MOVE '1' *INLR
C*****************************************************************
C* SUBROUTINE : REPORT HEAD
C* PURPOSE: TO WRITE HEADER AND FOOTER LINES
C*****************************************************************
C REPHED BEGSR
C WRITEREPHDG1
C WRITEREPHDG2
C WRITECOLHDG
C ENDSR
C*****************************************************************
C* SUBROUTINE : HEAD
C* PURPOSE: TO DISPLAY HEADER AND FOOTER SCREEN
C*****************************************************************
C HEAD BEGSR
C WRITEFOOT
C WRITEHDRSCN
C ENDSR
C*****************************************************************
C* SUBROUTINE : ROOM
C* PURPOSE: TO CALC ROOM COST
C*****************************************************************
C ROOM BEGSR
C Z-ADD1 X 20 INIT. INDEX
C TYP LOKUPTYP#,X 50FIND ITEM
C MOVE RAT1,X RMCHR
C ADD RAT1,X RATE
C MULT DAYS RMCHR
C TYP LOKUPITM#,X 50FIND ITEM
C MOVELDESC,X DESCP
C TYP IFEQ 1
C ADD RMCHR PRVBIL
C ENDIF
C TYP IFEQ 2
C ADD RMCHR SEMBIL
C ENDIF
C TYP IFEQ 3
C ADD RMCHR INTBIL
C ENDIF
C ENDSR
C*****************************************************************
C* SUBROUTINE : SERVEC
C* PURPOSE: TO CALCULATE EXTRA SERVICES
C*****************************************************************
C SERVEC BEGSR
C Z-ADD0 EXTSER
C OXY IFEQ 'Y'
C Z-ADD1 X
C 1 LOKUPXTRA,X 51
C ADD RAT2,X EXTSER
C ADD RAT2,X RATE
C ENDIF
C TV IFEQ 'Y'
C Z-ADD1 X
C 2 LOKUPXTRA,X 51
C ADD RAT2,X EXTSER
C ADD RAT2,X RATE
C ENDIF
C MULT DAYS EXTSER
C ADD EXTSER XTRBIL
C ENDSR
C*****************************************************************
C* SUBROUTINE : TOTS
C* PURPOSE: TO DISPLAY TOTALS ON THE REPORT
C*****************************************************************
C TOTS BEGSR
C* XFOOTXTRA XTRBIL
C WRITETOTAL
C WRITETOTAL1
C WRITETOTAL2
C WRITETOTAL3
C WRITETOTAL4
C WRITETOTAL5
C WRITEENDMSG
C ENDSR
C*****************************************************************
** TABLE/ARRAY........TYP#
1035000
2022000
3040000
** TABLE/ARRAY.......XTRA
1015000
2001250
** TABLE/ARRAY........ITM#
1PRIVATE ROOM
2SEMI PRIVATE ROOM
3INTENSIVE CARE