- IBAMTD1 ;ALB/CPM - MOVEMENT EVENT DRIVER INTERFACE (CON'T) ; 21-OCT-91
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- EN ; Create charges for one-day admissions
- ; Input: DFN, DGPMA, IBDT, IBBS, IBCLDA
- ; IBCLCT/IBCLDAY/IBCLDOL/IBCLDT (if IBCLDA'=0)
- ;
- ; - quit if patient is not Cat C at discharge
- G:'$$BIL^DGMTUB(DFN,+DGPMA) END
- ; - handle clock
- I $D(IBCLDT),IBCLDT>IBDT S IBY="-1^IB034" G END
- I IBCLDA D COUNT^IBAMTD S IBCLCT=IBCLCT+1 I IBCLCT>365 S IBWHER=2 D CLOCKCL^IBAUTL3 G:IBY<1 END S IBCLDA=0
- I 'IBCLDA S IBCLDT=IBDT,IBWHER=7 D CLADD^IBAUTL3 G:IBY<1 END S IBCLCT=1,(IBCLDAY,IBCLDOL)=0
- ; - build event
- S IBNH=$P($G(^DGCR(399.1,IBBS,0)),"^")["NURSING",IBSL="405:"_$P(DGPMA,"^",14),IBEVDT=IBDT,IBWHER=6
- D EVADD^IBAUTL3 G:IBY<1 END
- S IBCLDAY=IBCLDAY+1
- ; - cancel any OPT charges
- D OPT(DFN,IBDT)
- ; - process per diem
- G:IBDT<$$DIEM^IBAUTL5 COPAY
- S IBX="P",IBWHER=8 D TYPE^IBAUTL2 G:IBY<1 END
- S IBWHER=13 D CHADD^IBAUTL2 G:IBY<1 END
- S IBNOS=IBN,IBWHER=26 D FILER^IBAUTL5 G:IBY<1 END
- COPAY ; - process co-payment
- G:IBCLDAY>360 LAST
- I IBCLDAY>1,IBCLDAY#90=1 S IBCLDOL=0
- S IBMAX=IBMED I IBCLDAY>90,'IBNH S IBMAX=IBMAX/2
- G:IBCLDOL'<IBMAX LAST
- S IBWHER=14 D COPAY^IBAUTL2 G:IBY<1 END
- S IBCHARG=IBMAX-IBCLDOL I IBCHG<IBCHARG S IBCHARG=IBCHG
- S IBCHG=IBCHARG S:IBCHG<0 IBCHG=0
- S IBCLDOL=IBCLDOL+IBCHG
- S IBWHER=18 D CHADD^IBAUTL2 G:IBY<1 END
- S IBNOS=IBN,IBWHER=27 D FILER^IBAUTL5 G:IBY<1 END
- LAST ; - close event, update billing clock
- S IBWHER=23,IBEVCLD=IBDT D EVCLOSE^IBAUTL3,CLUPD^IBAUTL3,CLOCKCL^IBAUTL3:IBCLCT>364
- END Q
- ;
- ;
- UNFLAG ; Unflag continuous patient, if not transferring from the facility.
- N TRAN S TRAN=$P(DGPMA,"^",18)=10
- I 'TRAN!(IBASIH) W !,"Unflagging patient as continuous since 7/1/86..." D
- . D NOW^%DTC S DIE="^IBE(351.1,",DA=+$O(^IBE(351.1,"B",DFN,0))
- . S DR=".02////"_$P(+DGPMA,".")_";.05////"_DUZ_";.06////"_% D ^DIE K DIE,DA,DR
- . W "completed."
- ; - send bulletin to Category C Billing mailgroup, if patient did not die.
- I $P($G(^DG(405.1,+$P(DGPMA,"^",4),0)),"^")'["DEATH" D CTPT^IBAMTBU
- Q
- ;
- OPT(DFN,IBDATE) ; Cancel any OPT charges on days billed for inpatient care.
- ; Input: DFN -- Pointer to patient in file #2
- ; IBDATE -- Date to check for OPT charges
- N IBN,IBCRES,IBDUZ S IBDUZ=DUZ
- S IBN=$$BFO^IBECEAU(DFN,IBDATE) I 'IBN G OPTQ
- S IBCRES=$O(^IBE(350.3,"B","RECD INPATIENT CARE",0))
- S:'IBCRES IBCRES=25
- D CANCH^IBECEAU4(IBN,IBCRES)
- OPTQ Q
- IBAMTD1 ;ALB/CPM - MOVEMENT EVENT DRIVER INTERFACE (CON'T) ; 21-OCT-91
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- EN ; Create charges for one-day admissions
- +1 ; Input: DFN, DGPMA, IBDT, IBBS, IBCLDA
- +2 ; IBCLCT/IBCLDAY/IBCLDOL/IBCLDT (if IBCLDA'=0)
- +3 ;
- +4 ; - quit if patient is not Cat C at discharge
- +5 IF '$$BIL^DGMTUB(DFN,+DGPMA)
- GOTO END
- +6 ; - handle clock
- +7 IF $DATA(IBCLDT)
- IF IBCLDT>IBDT
- SET IBY="-1^IB034"
- GOTO END
- +8 IF IBCLDA
- DO COUNT^IBAMTD
- SET IBCLCT=IBCLCT+1
- IF IBCLCT>365
- SET IBWHER=2
- DO CLOCKCL^IBAUTL3
- IF IBY<1
- GOTO END
- SET IBCLDA=0
- +9 IF 'IBCLDA
- SET IBCLDT=IBDT
- SET IBWHER=7
- DO CLADD^IBAUTL3
- IF IBY<1
- GOTO END
- SET IBCLCT=1
- SET (IBCLDAY,IBCLDOL)=0
- +10 ; - build event
- +11 SET IBNH=$PIECE($GET(^DGCR(399.1,IBBS,0)),"^")["NURSING"
- SET IBSL="405:"_$PIECE(DGPMA,"^",14)
- SET IBEVDT=IBDT
- SET IBWHER=6
- +12 DO EVADD^IBAUTL3
- IF IBY<1
- GOTO END
- +13 SET IBCLDAY=IBCLDAY+1
- +14 ; - cancel any OPT charges
- +15 DO OPT(DFN,IBDT)
- +16 ; - process per diem
- +17 IF IBDT<$$DIEM^IBAUTL5
- GOTO COPAY
- +18 SET IBX="P"
- SET IBWHER=8
- DO TYPE^IBAUTL2
- IF IBY<1
- GOTO END
- +19 SET IBWHER=13
- DO CHADD^IBAUTL2
- IF IBY<1
- GOTO END
- +20 SET IBNOS=IBN
- SET IBWHER=26
- DO FILER^IBAUTL5
- IF IBY<1
- GOTO END
- COPAY ; - process co-payment
- +1 IF IBCLDAY>360
- GOTO LAST
- +2 IF IBCLDAY>1
- IF IBCLDAY#90=1
- SET IBCLDOL=0
- +3 SET IBMAX=IBMED
- IF IBCLDAY>90
- IF 'IBNH
- SET IBMAX=IBMAX/2
- +4 IF IBCLDOL'<IBMAX
- GOTO LAST
- +5 SET IBWHER=14
- DO COPAY^IBAUTL2
- IF IBY<1
- GOTO END
- +6 SET IBCHARG=IBMAX-IBCLDOL
- IF IBCHG<IBCHARG
- SET IBCHARG=IBCHG
- +7 SET IBCHG=IBCHARG
- IF IBCHG<0
- SET IBCHG=0
- +8 SET IBCLDOL=IBCLDOL+IBCHG
- +9 SET IBWHER=18
- DO CHADD^IBAUTL2
- IF IBY<1
- GOTO END
- +10 SET IBNOS=IBN
- SET IBWHER=27
- DO FILER^IBAUTL5
- IF IBY<1
- GOTO END
- LAST ; - close event, update billing clock
- +1 SET IBWHER=23
- SET IBEVCLD=IBDT
- DO EVCLOSE^IBAUTL3
- DO CLUPD^IBAUTL3
- IF IBCLCT>364
- DO CLOCKCL^IBAUTL3
- END QUIT
- +1 ;
- +2 ;
- UNFLAG ; Unflag continuous patient, if not transferring from the facility.
- +1 NEW TRAN
- SET TRAN=$PIECE(DGPMA,"^",18)=10
- +2 IF 'TRAN!(IBASIH)
- WRITE !,"Unflagging patient as continuous since 7/1/86..."
- Begin DoDot:1
- +3 DO NOW^%DTC
- SET DIE="^IBE(351.1,"
- SET DA=+$ORDER(^IBE(351.1,"B",DFN,0))
- +4 SET DR=".02////"_$PIECE(+DGPMA,".")_";.05////"_DUZ_";.06////"_%
- DO ^DIE
- KILL DIE,DA,DR
- +5 WRITE "completed."
- End DoDot:1
- +6 ; - send bulletin to Category C Billing mailgroup, if patient did not die.
- +7 IF $PIECE($GET(^DG(405.1,+$PIECE(DGPMA,"^",4),0)),"^")'["DEATH"
- DO CTPT^IBAMTBU
- +8 QUIT
- +9 ;
- OPT(DFN,IBDATE) ; Cancel any OPT charges on days billed for inpatient care.
- +1 ; Input: DFN -- Pointer to patient in file #2
- +2 ; IBDATE -- Date to check for OPT charges
- +3 NEW IBN,IBCRES,IBDUZ
- SET IBDUZ=DUZ
- +4 SET IBN=$$BFO^IBECEAU(DFN,IBDATE)
- IF 'IBN
- GOTO OPTQ
- +5 SET IBCRES=$ORDER(^IBE(350.3,"B","RECD INPATIENT CARE",0))
- +6 IF 'IBCRES
- SET IBCRES=25
- +7 DO CANCH^IBECEAU4(IBN,IBCRES)
- OPTQ QUIT