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

IBRFN2.m

Go to the documentation of this file.
  1. IBRFN2 ;ALB/AAS - PASS INSURANCE/BEDSECTION DATA TO A/R FOR MCCR/NDB ; 8-OCT-93
  1. ;;2.0;INTEGRATED BILLING;**75,80,345**;21-MAR-94;Build 28
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. CRIT(IBIFN) ; Pass AR insurance data for MCCR/NDB
  1. ; Input: IBIFN -- Internal entry of Bill (ptr to #399)
  1. ; (should be same as ptr to 430)
  1. ;
  1. ; Returns: piece 1 = criteria 3 (type of policy)
  1. ; piece 2 = criteria 4 (how policy identified)
  1. ; piece 3 = criteria 5 (primary bedsection of bill)
  1. ; see table below for values
  1. ;
  1. ; -------------------------------------------------------------------
  1. ; | | Numeric Value |
  1. ; |-------|-----------------------------------------------------------|
  1. ; | Piece | 1 | 2 | 3 | 4 |
  1. ; |-------|----------------|--------------|-------------|-------------|
  1. ; | 1 | Full Medical | Medicare Sup | *Other | - |
  1. ; | 2 | *By interview | By Data Match| by IVM |by pre-regist|
  1. ; | 3 | Medical | Surgical | Pschiatric | *Any Other |
  1. ; | | | | |including opt|
  1. ; -------------------------------------------------------------------
  1. ;
  1. ; -- error, returns -1, bill does not exist
  1. ;
  1. N IBX
  1. S IBX=-1
  1. ; -- set value to defaults if okayed by vaco
  1. ;S IBX="3^1^4"
  1. ;
  1. I '$G(IBIFN)!($G(^DGCR(399,+$G(IBIFN),0))="") G CRITQ
  1. S IBX=""
  1. ;
  1. S $P(IBX,"^",1)=$$TYPOL(IBIFN)
  1. S $P(IBX,"^",2)=$$HOWID(IBIFN)
  1. S $P(IBX,"^",3)=$$BEDSC(IBIFN)
  1. ;
  1. CRITQ Q IBX
  1. ;
  1. ;
  1. TYPOL(IBIFN) ; -- compute type of policy for a bill
  1. N IBX,IBCDFN,IBCPOL,TYPE
  1. S IBX=""
  1. S IBCDFN=$$POL(IBIFN) I 'IBCDFN G TYPOLQ
  1. S IBCPOL=$P($G(^DPT(+$P($G(^DGCR(399,+$G(IBIFN),0)),"^",2),.312,IBCDFN,0)),"^",18) ; pointer to group plan (355.3)
  1. I 'IBCPOL S IBX=3 ; default type of policy is 3 or other
  1. I IBCPOL D
  1. .S TYPE=$P($G(^IBE(355.1,+$P($G(^IBA(355.3,+IBCPOL,0)),"^",9),0)),"^",3)
  1. .S IBX=$S(TYPE=1:1,TYPE=11:2,1:3) ; full medical, medicare supplementa or other
  1. TYPOLQ I IBX<1!(IBX>3)!(IBX'?1N) S IBX=3 ; must be number from 1-3, default=3
  1. Q IBX
  1. ;
  1. ;
  1. HOWID(IBIFN) ; -- compute how policy was identified
  1. N IBX,IBCDFN
  1. S IBX=""
  1. S IBCDFN=$$POL(IBIFN) I 'IBCDFN G HOWIDQ
  1. S IBX=$P($G(^DPT(+$P($G(^DGCR(399,+$G(IBIFN),0)),"^",2),.312,IBCDFN,1)),"^",9)
  1. ;
  1. HOWIDQ I IBX<1!(IBX'?1N) S IBX=1 ; must be number, default=1 by interview
  1. Q IBX
  1. ;
  1. ;
  1. BEDSC(IBIFN) ; -- compute primary bedsection for a bill
  1. ; -- based on greatest length of stay
  1. N IBX,IBRC,IBBS,IBUN,IBMAX
  1. S IBX=""
  1. I '$G(IBIFN) G BEDSCQ
  1. I $P($G(^DGCR(399,+IBIFN,0)),"^",5)>2 S IBX=4 G BEDSCQ ; opt bill
  1. ;
  1. ; -- add up all los for each rev code.
  1. S IBRC=0 F S IBRC=$O(^DGCR(399,+IBIFN,"RC",IBRC)) Q:'IBRC D
  1. .S IBUN=$P($G(^DGCR(399,+IBIFN,"RC",IBRC,0)),"^",3) ; units of service
  1. .S IBBS=$P($G(^DGCR(399,+IBIFN,"RC",IBRC,0)),"^",5) ; bedsection from 399.1
  1. .Q:IBBS=""
  1. .S IBBS(IBBS)=$G(IBBS(IBBS))+IBUN
  1. .Q
  1. ;
  1. ; -- find bedsection with highest los
  1. S IBMAX=""
  1. S X=0 F S X=$O(IBBS(X)) Q:'X I IBBS(X)>$G(IBBS(+IBMAX)) S IBMAX=X
  1. ;
  1. S IBX=$P($G(^DGCR(399.1,+IBMAX,0)),"^")
  1. ;
  1. BEDSCQ S IBX=$S(IBX="":4,IBX["MEDICAL":1,IBX["SURGICAL":2,IBX["PSYCHIATRIC":3,1:4)
  1. Q IBX
  1. ;
  1. POL(IBIFN) ; -- compute internal policy id for a bill
  1. N X,Y,DFN,IBDD,IBCDFN
  1. S IBCDFN=$P($G(^DGCR(399,+IBIFN,"MP")),"^",2)
  1. I 'IBCDFN D
  1. .S IBCNS=+$G(^DGCR(399,+IBIFN,"MP"))
  1. .S DFN=$P($G(^DGCR(399,+IBIFN,0)),"^",2)
  1. .S X="IBCNS1" X ^%ZOSF("TEST") I $T D ALL^IBCNS1(DFN,"IBDD")
  1. .I '$D(IBDD) Q
  1. .S X=0 F S X=$O(IBDD(X)) Q:'X I IBCNS=+$G(IBDD(X,0)) S IBCDFN=X Q
  1. .Q
  1. POLQ Q IBCDFN