source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN2.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1IBRFN2 ;ALB/AAS - PASS INSURANCE/BEDSECTION DATA TO A/R FOR MCCR/NDB ; 8-OCT-93
2 ;;2.0;INTEGRATED BILLING;**75,80,345**;21-MAR-94;Build 28
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5CRIT(IBIFN) ; Pass AR insurance data for MCCR/NDB
6 ; Input: IBIFN -- Internal entry of Bill (ptr to #399)
7 ; (should be same as ptr to 430)
8 ;
9 ; Returns: piece 1 = criteria 3 (type of policy)
10 ; piece 2 = criteria 4 (how policy identified)
11 ; piece 3 = criteria 5 (primary bedsection of bill)
12 ; see table below for values
13 ;
14 ; -------------------------------------------------------------------
15 ; | | Numeric Value |
16 ; |-------|-----------------------------------------------------------|
17 ; | Piece | 1 | 2 | 3 | 4 |
18 ; |-------|----------------|--------------|-------------|-------------|
19 ; | 1 | Full Medical | Medicare Sup | *Other | - |
20 ; | 2 | *By interview | By Data Match| by IVM |by pre-regist|
21 ; | 3 | Medical | Surgical | Pschiatric | *Any Other |
22 ; | | | | |including opt|
23 ; -------------------------------------------------------------------
24 ;
25 ; -- error, returns -1, bill does not exist
26 ;
27 N IBX
28 S IBX=-1
29 ; -- set value to defaults if okayed by vaco
30 ;S IBX="3^1^4"
31 ;
32 I '$G(IBIFN)!($G(^DGCR(399,+$G(IBIFN),0))="") G CRITQ
33 S IBX=""
34 ;
35 S $P(IBX,"^",1)=$$TYPOL(IBIFN)
36 S $P(IBX,"^",2)=$$HOWID(IBIFN)
37 S $P(IBX,"^",3)=$$BEDSC(IBIFN)
38 ;
39CRITQ Q IBX
40 ;
41 ;
42TYPOL(IBIFN) ; -- compute type of policy for a bill
43 N IBX,IBCDFN,IBCPOL,TYPE
44 S IBX=""
45 S IBCDFN=$$POL(IBIFN) I 'IBCDFN G TYPOLQ
46 S IBCPOL=$P($G(^DPT(+$P($G(^DGCR(399,+$G(IBIFN),0)),"^",2),.312,IBCDFN,0)),"^",18) ; pointer to group plan (355.3)
47 I 'IBCPOL S IBX=3 ; default type of policy is 3 or other
48 I IBCPOL D
49 .S TYPE=$P($G(^IBE(355.1,+$P($G(^IBA(355.3,+IBCPOL,0)),"^",9),0)),"^",3)
50 .S IBX=$S(TYPE=1:1,TYPE=11:2,1:3) ; full medical, medicare supplementa or other
51TYPOLQ I IBX<1!(IBX>3)!(IBX'?1N) S IBX=3 ; must be number from 1-3, default=3
52 Q IBX
53 ;
54 ;
55HOWID(IBIFN) ; -- compute how policy was identified
56 N IBX,IBCDFN
57 S IBX=""
58 S IBCDFN=$$POL(IBIFN) I 'IBCDFN G HOWIDQ
59 S IBX=$P($G(^DPT(+$P($G(^DGCR(399,+$G(IBIFN),0)),"^",2),.312,IBCDFN,1)),"^",9)
60 ;
61HOWIDQ I IBX<1!(IBX'?1N) S IBX=1 ; must be number, default=1 by interview
62 Q IBX
63 ;
64 ;
65BEDSC(IBIFN) ; -- compute primary bedsection for a bill
66 ; -- based on greatest length of stay
67 N IBX,IBRC,IBBS,IBUN,IBMAX
68 S IBX=""
69 I '$G(IBIFN) G BEDSCQ
70 I $P($G(^DGCR(399,+IBIFN,0)),"^",5)>2 S IBX=4 G BEDSCQ ; opt bill
71 ;
72 ; -- add up all los for each rev code.
73 S IBRC=0 F S IBRC=$O(^DGCR(399,+IBIFN,"RC",IBRC)) Q:'IBRC D
74 .S IBUN=$P($G(^DGCR(399,+IBIFN,"RC",IBRC,0)),"^",3) ; units of service
75 .S IBBS=$P($G(^DGCR(399,+IBIFN,"RC",IBRC,0)),"^",5) ; bedsection from 399.1
76 .Q:IBBS=""
77 .S IBBS(IBBS)=$G(IBBS(IBBS))+IBUN
78 .Q
79 ;
80 ; -- find bedsection with highest los
81 S IBMAX=""
82 S X=0 F S X=$O(IBBS(X)) Q:'X I IBBS(X)>$G(IBBS(+IBMAX)) S IBMAX=X
83 ;
84 S IBX=$P($G(^DGCR(399.1,+IBMAX,0)),"^")
85 ;
86BEDSCQ S IBX=$S(IBX="":4,IBX["MEDICAL":1,IBX["SURGICAL":2,IBX["PSYCHIATRIC":3,1:4)
87 Q IBX
88 ;
89POL(IBIFN) ; -- compute internal policy id for a bill
90 N X,Y,DFN,IBDD,IBCDFN
91 S IBCDFN=$P($G(^DGCR(399,+IBIFN,"MP")),"^",2)
92 I 'IBCDFN D
93 .S IBCNS=+$G(^DGCR(399,+IBIFN,"MP"))
94 .S DFN=$P($G(^DGCR(399,+IBIFN,0)),"^",2)
95 .S X="IBCNS1" X ^%ZOSF("TEST") I $T D ALL^IBCNS1(DFN,"IBDD")
96 .I '$D(IBDD) Q
97 .S X=0 F S X=$O(IBDD(X)) Q:'X I IBCNS=+$G(IBDD(X,0)) S IBCDFN=X Q
98 .Q
99POLQ Q IBCDFN
Note: See TracBrowser for help on using the repository browser.