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
