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

IBAMTI.m

Go to the documentation of this file.
  1. IBAMTI ;ALB/CPM - SPECIAL INPATIENT BILLING CASES ; 11-AUG-93
  1. ;;2.0;INTEGRATED BILLING;**52,132,153,156,234,247,339**;21-MAR-94;Build 2
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ADM(DFN,IBPM,IBCL) ; Create a new case record upon admission
  1. ; Input: DFN -- Pointer to the patient in file #2
  1. ; IBPM -- Pointer to the adm movement in file #405
  1. ; IBCL -- Patient class [1-ao|2-ir|3-sc|4-swa|5-mst|6-hnc|7-cv|8-shad]
  1. I '$G(DFN)!'$G(IBPM)!'$G(IBCL) G ADMQ
  1. N DA,DIC,DIE,DR,IBC,X,Y
  1. ;
  1. ; - need to swap the input of 3 (SC) to 4, and 4 (EC) to 3
  1. S IBCL=$S(IBCL=3:4,IBCL=4:3,IBCL=5:5,1:IBCL)
  1. ;
  1. K DD,DO S DIC="^IBE(351.2,",DIC(0)="",X=DFN D FILE^DICN S IBC=+Y
  1. S DR=".02////"_IBPM_";.03////"_IBCL_";.05////1;2.01////"_DUZ_";2.02///NOW;2.03////"_DUZ_";2.04///NOW"
  1. S DA=IBC,DIE=DIC D ^DIE
  1. D BULL(1,IBCL) ; send admission bulletin
  1. ADMQ Q
  1. ;
  1. DIS(IBPM) ; Update the case record upon discharge
  1. ; Input: IBPM -- Pointer to the adm movement in file #405
  1. N DA,DIE,DR,IBC
  1. S IBC=$O(^IBE(351.2,"AC",+$G(IBPM),0)) I 'IBC G DISQ
  1. S DR=".05////2;.06////"_DT_";2.03////"_DUZ_";2.04///NOW"
  1. S DA=IBC,DIE="^IBE(351.2," D ^DIE
  1. D BULL(2,+$P($G(^IBE(351.2,IBC,0)),"^",3)) ; send discharge bulletin
  1. DISQ Q
  1. ;
  1. BGJ ; Perform nightly background monitoring of all case records.
  1. N IBC,IBCD,IBNUM
  1. S IBC=0 F S IBC=$O(^IBE(351.2,IBC)) Q:'IBC S IBCD=$G(^(IBC,0)) D
  1. .Q:$P(IBCD,"^",8) ; case has been dispositioned
  1. .Q:$P(IBCD,"^",5)=1 ; patient still admitted
  1. .I '$P(IBCD,"^",6) S $P(^IBE(351.2,IBC,0),"^",6)=DT Q ; no disch date
  1. .S IBNUM=$$FMDIFF^XLFDT(DT,$P(IBCD,"^",6))
  1. .Q:IBNUM<45 ; still time to disposition the case
  1. .D NOTICE(IBNUM,+IBCD,+$P(IBCD,"^",2),+$P(IBCD,"^",3)) ; send reminder to disposition
  1. Q
  1. ;
  1. BULL(IBEV,IBCL) ; Send a bulletin at admission and discharge.
  1. ; Input: IBEV -- Event [1:admission|2:discharge]
  1. ; IBCL -- Patient class [1-ao|2-ir|3-swa|4-sc|5-mst|6-hnc|7-cv|8-shad]
  1. K IBT S IBPT=$$PT^IBEFUNC(DFN)
  1. S XMSUB=$E($P(IBPT,"^"),1,14)_" "_$P(IBPT,"^",3)_" - "_$$UCCL(IBCL)_$S($G(IBEV)=1:" ADM",1:" DISCH")
  1. S IBT(1)="The following Means Test copay "_$$LCCL(IBCL)_" patient was just "_$S($G(IBEV)=1:"admitted:",1:"discharged:")
  1. S IBT(2)=" " S IBC=2
  1. S IBDUZ=DUZ D PAT^IBAERR1
  1. S IBC=IBC+1,IBT(IBC)=" "
  1. S IBC=IBC+1,IBT(IBC)=$S($G(IBEV)=1:"Please note that a special inpatient case record has been created for",1:"Please note that you have 45 days to determine if this episode of care")
  1. S IBC=IBC+1,IBT(IBC)=$S($G(IBEV)=1:"this admission.",1:"should be billed.")
  1. ;---CV
  1. I IBCL=7,$G(IBEV)=2 D
  1. . N Y,X,IBZ,IBFL,IBEXP,IBTODAY,IBDIS
  1. . S (Y,X,IBZ,IBFL,IBEXP,IBTODAY,IBDIS)=0
  1. . D NOW^%DTC S IBTODAY=%\1
  1. . S IBZ=$$CVEDT^IBACV(DFN,IBTODAY)
  1. . I +IBZ=1 Q ;patient is still CV
  1. . S IBEXP=+$P(IBZ,"^",2)\1
  1. . S IBDIS=+$G(^DGPM(+$P($G(^DGPM(+$G(IBPM),0)),"^",17),0))\1
  1. . ; if CV expired during inpatient stay
  1. . I IBDIS>0,IBEXP'>IBDIS D
  1. . . S IBFL=1
  1. . . S Y=IBEXP D DD^%DT S IBEXP=Y
  1. . . S IBC=IBC+1,IBT(IBC)=""
  1. . . S IBC=IBC+1,IBT(IBC)="WARNING: Patient's CV status has expired on "_IBEXP_" during the"
  1. . . S IBC=IBC+1,IBT(IBC)="inpatient stay. Billing needs to be adjusted accordingly."
  1. . ; if discharge move was entered after actual discharge date
  1. . I IBFL=0 D
  1. . . S Y=IBEXP D DD^%DT S IBEXP=Y
  1. . . S IBC=IBC+1,IBT(IBC)=""
  1. . . S IBC=IBC+1,IBT(IBC)="WARNING: Patient CV status has expired on "_IBEXP_""
  1. ;---
  1. I IBEV=2 D
  1. .I '$$BIL^DGMTUB(DFN,DT) S IBC=IBC+1,IBT(IBC)=" ",IBC=IBC+1,IBT(IBC)="Note: This patient, who was MT copay at admission, is no longer MT billable."
  1. .I $$BFO^IBECEAU(DFN,+$G(^DGPM(IBPM,0))\1) S IBC=IBC+1,IBT(IBC)=" ",IBC=IBC+1,IBT(IBC)="Note: This patient was billed the outpatient copayment at admission."
  1. D SEND^IBACVA2
  1. Q
  1. ;
  1. NOTICE(IBNUM,DFN,IBPM,IBCL) ; Notice to disposition billing case
  1. ; Input: IBNUM -- Number of days since discharge
  1. ; DFN -- Pointer to the patient in file #2
  1. ; IBPM -- Pointer to the admission in file #405
  1. ; IBCL -- Patient class [1-ao|2-ir|3-swa|4-sc|5-mst|6-hnc|7-cv|8-shad]
  1. ;
  1. Q:IBNUM#15 ; send notice every 15 days only
  1. N IBC K IBT S IBPT=$$PT^IBEFUNC(DFN)
  1. S XMSUB="NOTICE TO DISPOSITION SPECIAL INPATIENT BILLING CASE"
  1. S IBT(1)="The case record for this Means Test copay "_$$LCCL(IBCL)_" patient"
  1. S IBT(2)="is now "_IBNUM_" days old and should be dispositioned:"
  1. S IBT(3)=" " S IBC=3
  1. S IBDUZ=DUZ D PAT^IBAERR1
  1. S Y=+$G(^DGPM(+$G(IBPM),0)) D DD^%DT
  1. S IBC=IBC+1,IBT(IBC)=" Adm Date: "_Y
  1. S Y=+$G(^DGPM(+$P($G(^DGPM(+$G(IBPM),0)),"^",17),0)) D DD^%DT
  1. S IBC=IBC+1,IBT(IBC)="Disc Date: "_Y
  1. S IBC=IBC+1,IBT(IBC)=" "
  1. S IBC=IBC+1,IBT(IBC)="Please determine if this episode of care should be billed, and use"
  1. S IBC=IBC+1,IBT(IBC)="the Cancel/Edit/Add Patient Charges option to add charges, or the"
  1. S IBC=IBC+1,IBT(IBC)="Disposition Special Inpatient Billing Cases option to enter the reason"
  1. S IBC=IBC+1,IBT(IBC)="for not billing."
  1. D SEND^IBACVA2
  1. Q
  1. ;
  1. UCCL(X) ; Return the upper case classification description.
  1. ; Input: X -- Patient class [1-ao|2-ir|3-swa|4-sc|5-mst|6-hnc|7-cv|8-shad]
  1. Q $S('$G(X):"SPECIAL",1:$$PATTYPE^IBACV(X))
  1. ;
  1. LCCL(X) ; Return the lower case classification description.
  1. ; Input: X -- Patient class [1-ao|2-ir|3-swa|4-sc|5-mst|6-hnc|7-cv|8-shad]
  1. Q $S('$G(X):"Special",1:$$PATTYPE^IBACV(X,"M"))
  1. ;