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 Dec 13, 2024@02:26:54 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
