Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBAMTD1

IBAMTD1.m

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