- IBRFN2 ;ALB/AAS - PASS INSURANCE/BEDSECTION DATA TO A/R FOR MCCR/NDB ; 8-OCT-93
- ;;2.0;INTEGRATED BILLING;**75,80,345**;21-MAR-94;Build 28
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- CRIT(IBIFN) ; Pass AR insurance data for MCCR/NDB
- ; Input: IBIFN -- Internal entry of Bill (ptr to #399)
- ; (should be same as ptr to 430)
- ;
- ; Returns: piece 1 = criteria 3 (type of policy)
- ; piece 2 = criteria 4 (how policy identified)
- ; piece 3 = criteria 5 (primary bedsection of bill)
- ; see table below for values
- ;
- ; -------------------------------------------------------------------
- ; | | Numeric Value |
- ; |-------|-----------------------------------------------------------|
- ; | Piece | 1 | 2 | 3 | 4 |
- ; |-------|----------------|--------------|-------------|-------------|
- ; | 1 | Full Medical | Medicare Sup | *Other | - |
- ; | 2 | *By interview | By Data Match| by IVM |by pre-regist|
- ; | 3 | Medical | Surgical | Pschiatric | *Any Other |
- ; | | | | |including opt|
- ; -------------------------------------------------------------------
- ;
- ; -- error, returns -1, bill does not exist
- ;
- N IBX
- S IBX=-1
- ; -- set value to defaults if okayed by vaco
- ;S IBX="3^1^4"
- ;
- I '$G(IBIFN)!($G(^DGCR(399,+$G(IBIFN),0))="") G CRITQ
- S IBX=""
- ;
- S $P(IBX,"^",1)=$$TYPOL(IBIFN)
- S $P(IBX,"^",2)=$$HOWID(IBIFN)
- S $P(IBX,"^",3)=$$BEDSC(IBIFN)
- ;
- CRITQ Q IBX
- ;
- ;
- TYPOL(IBIFN) ; -- compute type of policy for a bill
- N IBX,IBCDFN,IBCPOL,TYPE
- S IBX=""
- S IBCDFN=$$POL(IBIFN) I 'IBCDFN G TYPOLQ
- S IBCPOL=$P($G(^DPT(+$P($G(^DGCR(399,+$G(IBIFN),0)),"^",2),.312,IBCDFN,0)),"^",18) ; pointer to group plan (355.3)
- I 'IBCPOL S IBX=3 ; default type of policy is 3 or other
- I IBCPOL D
- .S TYPE=$P($G(^IBE(355.1,+$P($G(^IBA(355.3,+IBCPOL,0)),"^",9),0)),"^",3)
- .S IBX=$S(TYPE=1:1,TYPE=11:2,1:3) ; full medical, medicare supplementa or other
- TYPOLQ I IBX<1!(IBX>3)!(IBX'?1N) S IBX=3 ; must be number from 1-3, default=3
- Q IBX
- ;
- ;
- HOWID(IBIFN) ; -- compute how policy was identified
- N IBX,IBCDFN
- S IBX=""
- S IBCDFN=$$POL(IBIFN) I 'IBCDFN G HOWIDQ
- S IBX=$P($G(^DPT(+$P($G(^DGCR(399,+$G(IBIFN),0)),"^",2),.312,IBCDFN,1)),"^",9)
- ;
- HOWIDQ I IBX<1!(IBX'?1N) S IBX=1 ; must be number, default=1 by interview
- Q IBX
- ;
- ;
- BEDSC(IBIFN) ; -- compute primary bedsection for a bill
- ; -- based on greatest length of stay
- N IBX,IBRC,IBBS,IBUN,IBMAX
- S IBX=""
- I '$G(IBIFN) G BEDSCQ
- I $P($G(^DGCR(399,+IBIFN,0)),"^",5)>2 S IBX=4 G BEDSCQ ; opt bill
- ;
- ; -- add up all los for each rev code.
- S IBRC=0 F S IBRC=$O(^DGCR(399,+IBIFN,"RC",IBRC)) Q:'IBRC D
- .S IBUN=$P($G(^DGCR(399,+IBIFN,"RC",IBRC,0)),"^",3) ; units of service
- .S IBBS=$P($G(^DGCR(399,+IBIFN,"RC",IBRC,0)),"^",5) ; bedsection from 399.1
- .Q:IBBS=""
- .S IBBS(IBBS)=$G(IBBS(IBBS))+IBUN
- .Q
- ;
- ; -- find bedsection with highest los
- S IBMAX=""
- S X=0 F S X=$O(IBBS(X)) Q:'X I IBBS(X)>$G(IBBS(+IBMAX)) S IBMAX=X
- ;
- S IBX=$P($G(^DGCR(399.1,+IBMAX,0)),"^")
- ;
- BEDSCQ S IBX=$S(IBX="":4,IBX["MEDICAL":1,IBX["SURGICAL":2,IBX["PSYCHIATRIC":3,1:4)
- Q IBX
- ;
- POL(IBIFN) ; -- compute internal policy id for a bill
- N X,Y,DFN,IBDD,IBCDFN
- S IBCDFN=$P($G(^DGCR(399,+IBIFN,"MP")),"^",2)
- I 'IBCDFN D
- .S IBCNS=+$G(^DGCR(399,+IBIFN,"MP"))
- .S DFN=$P($G(^DGCR(399,+IBIFN,0)),"^",2)
- .S X="IBCNS1" X ^%ZOSF("TEST") I $T D ALL^IBCNS1(DFN,"IBDD")
- .I '$D(IBDD) Q
- .S X=0 F S X=$O(IBDD(X)) Q:'X I IBCNS=+$G(IBDD(X,0)) S IBCDFN=X Q
- .Q
- POLQ Q IBCDFN
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBRFN2 3800 printed Jan 18, 2025@03:28:06 Page 2
- 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
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- CRIT(IBIFN) ; Pass AR insurance data for MCCR/NDB
- +1 ; Input: IBIFN -- Internal entry of Bill (ptr to #399)
- +2 ; (should be same as ptr to 430)
- +3 ;
- +4 ; Returns: piece 1 = criteria 3 (type of policy)
- +5 ; piece 2 = criteria 4 (how policy identified)
- +6 ; piece 3 = criteria 5 (primary bedsection of bill)
- +7 ; see table below for values
- +8 ;
- +9 ; -------------------------------------------------------------------
- +10 ; | | Numeric Value |
- +11 ; |-------|-----------------------------------------------------------|
- +12 ; | Piece | 1 | 2 | 3 | 4 |
- +13 ; |-------|----------------|--------------|-------------|-------------|
- +14 ; | 1 | Full Medical | Medicare Sup | *Other | - |
- +15 ; | 2 | *By interview | By Data Match| by IVM |by pre-regist|
- +16 ; | 3 | Medical | Surgical | Pschiatric | *Any Other |
- +17 ; | | | | |including opt|
- +18 ; -------------------------------------------------------------------
- +19 ;
- +20 ; -- error, returns -1, bill does not exist
- +21 ;
- +22 NEW IBX
- +23 SET IBX=-1
- +24 ; -- set value to defaults if okayed by vaco
- +25 ;S IBX="3^1^4"
- +26 ;
- +27 IF '$GET(IBIFN)!($GET(^DGCR(399,+$GET(IBIFN),0))="")
- GOTO CRITQ
- +28 SET IBX=""
- +29 ;
- +30 SET $PIECE(IBX,"^",1)=$$TYPOL(IBIFN)
- +31 SET $PIECE(IBX,"^",2)=$$HOWID(IBIFN)
- +32 SET $PIECE(IBX,"^",3)=$$BEDSC(IBIFN)
- +33 ;
- CRITQ QUIT IBX
- +1 ;
- +2 ;
- TYPOL(IBIFN) ; -- compute type of policy for a bill
- +1 NEW IBX,IBCDFN,IBCPOL,TYPE
- +2 SET IBX=""
- +3 SET IBCDFN=$$POL(IBIFN)
- IF 'IBCDFN
- GOTO TYPOLQ
- +4 ; pointer to group plan (355.3)
- SET IBCPOL=$PIECE($GET(^DPT(+$PIECE($GET(^DGCR(399,+$GET(IBIFN),0)),"^",2),.312,IBCDFN,0)),"^",18)
- +5 ; default type of policy is 3 or other
- IF 'IBCPOL
- SET IBX=3
- +6 IF IBCPOL
- Begin DoDot:1
- +7 SET TYPE=$PIECE($GET(^IBE(355.1,+$PIECE($GET(^IBA(355.3,+IBCPOL,0)),"^",9),0)),"^",3)
- +8 ; full medical, medicare supplementa or other
- SET IBX=$SELECT(TYPE=1:1,TYPE=11:2,1:3)
- End DoDot:1
- TYPOLQ ; must be number from 1-3, default=3
- IF IBX<1!(IBX>3)!(IBX'?1N)
- SET IBX=3
- +1 QUIT IBX
- +2 ;
- +3 ;
- HOWID(IBIFN) ; -- compute how policy was identified
- +1 NEW IBX,IBCDFN
- +2 SET IBX=""
- +3 SET IBCDFN=$$POL(IBIFN)
- IF 'IBCDFN
- GOTO HOWIDQ
- +4 SET IBX=$PIECE($GET(^DPT(+$PIECE($GET(^DGCR(399,+$GET(IBIFN),0)),"^",2),.312,IBCDFN,1)),"^",9)
- +5 ;
- HOWIDQ ; must be number, default=1 by interview
- IF IBX<1!(IBX'?1N)
- SET IBX=1
- +1 QUIT IBX
- +2 ;
- +3 ;
- BEDSC(IBIFN) ; -- compute primary bedsection for a bill
- +1 ; -- based on greatest length of stay
- +2 NEW IBX,IBRC,IBBS,IBUN,IBMAX
- +3 SET IBX=""
- +4 IF '$GET(IBIFN)
- GOTO BEDSCQ
- +5 ; opt bill
- IF $PIECE($GET(^DGCR(399,+IBIFN,0)),"^",5)>2
- SET IBX=4
- GOTO BEDSCQ
- +6 ;
- +7 ; -- add up all los for each rev code.
- +8 SET IBRC=0
- FOR
- SET IBRC=$ORDER(^DGCR(399,+IBIFN,"RC",IBRC))
- if 'IBRC
- QUIT
- Begin DoDot:1
- +9 ; units of service
- SET IBUN=$PIECE($GET(^DGCR(399,+IBIFN,"RC",IBRC,0)),"^",3)
- +10 ; bedsection from 399.1
- SET IBBS=$PIECE($GET(^DGCR(399,+IBIFN,"RC",IBRC,0)),"^",5)
- +11 if IBBS=""
- QUIT
- +12 SET IBBS(IBBS)=$GET(IBBS(IBBS))+IBUN
- +13 QUIT
- End DoDot:1
- +14 ;
- +15 ; -- find bedsection with highest los
- +16 SET IBMAX=""
- +17 SET X=0
- FOR
- SET X=$ORDER(IBBS(X))
- if 'X
- QUIT
- IF IBBS(X)>$GET(IBBS(+IBMAX))
- SET IBMAX=X
- +18 ;
- +19 SET IBX=$PIECE($GET(^DGCR(399.1,+IBMAX,0)),"^")
- +20 ;
- BEDSCQ SET IBX=$SELECT(IBX="":4,IBX["MEDICAL":1,IBX["SURGICAL":2,IBX["PSYCHIATRIC":3,1:4)
- +1 QUIT IBX
- +2 ;
- POL(IBIFN) ; -- compute internal policy id for a bill
- +1 NEW X,Y,DFN,IBDD,IBCDFN
- +2 SET IBCDFN=$PIECE($GET(^DGCR(399,+IBIFN,"MP")),"^",2)
- +3 IF 'IBCDFN
- Begin DoDot:1
- +4 SET IBCNS=+$GET(^DGCR(399,+IBIFN,"MP"))
- +5 SET DFN=$PIECE($GET(^DGCR(399,+IBIFN,0)),"^",2)
- +6 SET X="IBCNS1"
- XECUTE ^%ZOSF("TEST")
- IF $TEST
- DO ALL^IBCNS1(DFN,"IBDD")
- +7 IF '$DATA(IBDD)
- QUIT
- +8 SET X=0
- FOR
- SET X=$ORDER(IBDD(X))
- if 'X
- QUIT
- IF IBCNS=+$GET(IBDD(X,0))
- SET IBCDFN=X
- QUIT
- +9 QUIT
- End DoDot:1
- POLQ QUIT IBCDFN