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

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

initial load of WorldVistAEHR
File size: 9.5 KB
Line 
1IBCU ;ALB/MRL - BILLING UTILITY ROUTINE ;01 JUN 88 12:00
2 ;;2.0;INTEGRATED BILLING;**52,106,51,191,232,323,320**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;MAP TO DGCRU
6 ;
7ARSTAT ;find status of bill in file 430.3 (ar) return status number
8 S IBARST=$$STA^PRCAFN(IBIFN)
9 Q
10 ;
11ARCAT ;Trigger logic to set who's responsible in 399.3 from AR Category
12 S X=$P($$CATN^PRCAFN($P(^DGCR(399.3,DA,0),"^",6)),"^",3)
13 S:X'="" X=$S("PC"[X:"p",X="N":"o",X="T":"i",1:"")
14 Q
15 ;
16PTF ;Screen for appropriate PTF records
17 K IBDD1 S DFN=+$P(^DGCR(399,+DA,0),"^",2) Q:'$D(^DPT(+DFN,0)) S IB05=$P(^(0),"^",1),IB03=$P(^DGCR(399,+DA,0),"^",3)
18 S IB01="",IB02=0 F IB02=0:0 S IB01=$O(^DD(45,0,"ID",IB01)) Q:'IB01 S IB02=IB02+1,IBDD(IB02)=^(IB01)
19 F IB01=0:0 S IB01=$O(^DGPT("B",+DFN,IB01)) Q:'IB01 I $D(^DGPT(+IB01,0)) S IB04=$P(^(0),"^",2),Y=+IB01 I $P(IB03,".",1)=$P(IB04,".",1) S IBDD1(+Y)="" I $S('$D(X):0,X["?":1,1:0) D PTFW
20 G PTFQ:X'["?" I '$O(IBDD1(0)) W !,"Patient has no ACTIVE PTF RECORDS for this event date.",!,"A 'PTF NUMBER' is required for inpatient billing records."
21 E W !!,"Select the appropriate billing record from the above listing by number."
22PTFQ W ! K IB01,IB02,IB03,IB04,IB05,IBDD Q
23PTFW W !,Y,?15,IB05 F IB02=0:0 S IB02=$O(IBDD(IB02)) Q:'IB02 X IBDD(IB02)
24 Q
25 ;
26AGE ;Input Transform for Condition Code 17
27 I X=18 G SEX
28 I X=17 S IBC=X,DFN=$P(^DGCR(399,D0,0),"^",2) D DEM^VADPT I VADM(4)<100 W !!,"This patient is only ",VADM(4)," years old!!",!! K IBC Q
29 I $D(IBC) S X=IBC
30 Q
31 ;
32SEX ;Input Transform for Condition Code 18
33 I X=18 S IBC=X,DFN=$P(^DGCR(399,D0,0),"^",2) D DEM^VADPT I $E(VADM(5))="M" W !!,"This patient is a MALE!! Condition code 18 applies only to FEMALES!!",!! K IBC,X
34 I $D(IBC) S X=IBC
35 Q
36 ;
37REV ;Input Transform for Revenue Code
38 I X=-1 W !!,"Choose only ACTIVE Revenue Codes!!",!! S D="AC" ;S X="" S X=$O(^DGCR(399.2,"AC",X)) Q:X="" W !,$P(^DGCR(399.2,X,0),"^",1),?30,$P(^(0),"^",2) K X Q
39 I '$D(IBC) I $D(^DGCR(399.2,X,0)) I '$P(^DGCR(399.2,X,0),"^",3) W !!,"Only ACTIVE Revenue Codes may be selected!!",!! K X Q
40 Q
41 ;
42YN S X=$E(X),X=$S(X=1:X,X=0:X,X="Y":1,X="y":1,X="n":0,X="N":0,1:2) I X'=2 W " (",$S(X:"YES",1:"NO"),")" Q
43 W !?4,"NOT A VALID CHOICE!",*7 K X Q
44 Q
45 ;
46NOPTF ; Input transform for file 399, field 159.5 (NON-VA ADMIT TIME)
47 N %DT
48 I X>24 K:X'=99 X Q
49 I $P($G(^DGCR(399,DA,0)),U,8) K X Q ; PTF pointer exists
50 S X=$TR(X,"M ") S:X=0 X="12A" S:X<12 X=$TR(X,"A")
51 S:X?1N.N&($L(X)<3) Y="."_$E("0",$L(X))_X S:X'?1.2N %DT="TPR",X=DT_"@"_X D:$L(X)>2 ^%DT S X=$E($P(Y,".",2)_"00",1,2)#24 K:Y=-1 X
52 Q
53 ;
54DIS ;Determine Billing Discharge status from PTF
55 ;Called from triggers on fields .08 and 161
56 N A
57 I '$D(^DGCR(399,DA,0)) S X="" G DISQ
58 S X=$P(^DGCR(399,DA,0),"^",6) I X=2!(X=3) S X=$O(^DGCR(399.1,"B","STILL PATIENT",0)) G DISQ
59 S X=$P(^DGCR(399,DA,0),"^",8) I $S(X="":1,'$D(^DGPT(X)):1,1:0) S X="" G DISQ
60 I '+$G(^DGPT(X,70)) S X=$O(^DGCR(399.1,"B","STILL PATIENT",0)) G DISQ
61 S A=$P($G(^DGCR(399,DA,"U")),"^",2) I A,(A+.24)<+$G(^DGPT(X,70)) S X=$O(^DGCR(399.1,"B","STILL PATIENT",0)) G DISQ
62 S X=+$P($G(^DGPT(X,70)),"^",3)
63 I X=1 S X=$O(^DGCR(399.1,"B",$E("DISCHARGED TO HOME OR SELF CARE",1,30),0)) G DISQ
64 I X=4 S X=$O(^DGCR(399.1,"B",$E("LEFT AGAINST MEDICAL ADVICE",1,30),0)) G DISQ
65 I X=6!(X=7) S X=$O(^DGCR(399.1,"B","EXPIRED",0)) G DISQ
66 I X=5!(X=2) S X=$O(^DGCR(399.1,"B",$E("DISCHARGED TO ANOTHER SHORT-TERM GENERAL HOSPITAL",1,30),0)) G DISQ
67 S X=""
68DISQ Q
69 ;
70INST ;Ask Institutution address info
71 S DIC("DR")="1.01;1.02;1.03;.02;1.04" I $D(^XUSEC("IB SUPERVISOR",DUZ)) S DLAYGO=4
72 Q
73 ;
74PTADD(DFN,MAXL) ; outputs patient address for the trigger on Patient Short Address (399,110)
75 N IBX,IBY,IBI,IBDPT S (IBX,IBDPT)="" I $G(MAXL)="PSA" S MAXL=47
76 I +$G(DFN) S IBDPT=$G(^DPT(DFN,.11)) F IBI=1:1:4 S IBY=$P(IBDPT,U,IBI) I IBY'="" S IBX=IBX_IBY_","
77 I +$P(IBDPT,U,5) S IBY=$P($G(^DIC(5,+$P(IBDPT,U,5),0)),U,2),IBX=IBX_IBY
78 I $P(IBDPT,U,12)'="" S IBX=IBX_" "_$P(IBDPT,U,12)
79 I +$G(MAXL),$L(IBX)>+MAXL S IBX=""
80 Q IBX
81 ;
82SM ;Flag for printing medicare statment on UB-82
83 ;DGSM=0 means figure out which statement, DGSM=1 means no statements
84 S DGSM=0 Q
85 ;IBCU
86 ;
87CHGTYP(IBIFN,ARR) ; sets up array of all charge types defined on a bill: ARR(TYPE, COMPONENT)=""
88 N IBI,IBX,IBT K ARR
89 I +$O(^DGCR(399,+$G(IBIFN),"RC",0)) S IBI=0 F S IBI=$O(^DGCR(399,+IBIFN,"RC",IBI)) Q:'IBI D
90 . S IBX=$G(^DGCR(399,+IBIFN,"RC",IBI,0)),IBT=$P(IBX,U,10) I +IBT S ARR(IBT,+$P(IBX,U,12))=""
91 Q
92 ;
93CHGTYPE(IBIFN) ; returns list of charge types on a bill: TYPE ^ TYPE ^ ... ; EXTERNAL TYPE , EXTERNAL TYPE , ...
94 N IBAR,IBY,IBS,IBI,IBC,IBJ,IBX
95 D CHGTYP($G(IBIFN),.IBAR)
96 S (IBX,IBY,IBS)="",IBI=0 F S IBI=$O(IBAR(IBI)) Q:'IBI D
97 . S IBX=IBX_IBI_U
98 . S IBC="INPT" I IBI=1 S IBJ=$O(IBAR(IBI,0)),IBC=$S(IBJ=1:"INST",IBJ=2:"PF",1:"INPT") I +$O(IBAR(IBI,IBJ)) S IBC="INPT"
99 . S IBY=IBY_IBS_$S(IBI=1:IBC,IBI=2:"VST",IBI=3:"RX",IBI=4:"CPT",IBI=5:"PI",IBI=6:"DRG",IBI=9:"UN",1:""),IBS=","
100 S IBY=IBX_";"_IBY
101 Q IBY
102 ;
103BCHGTYPE(IBIFN) ; returns type of bill and charges: (CLASS (.05): TYPE, TYPE, ...)
104 N IBCLASS,IBTYPE,IBY S IBY=""
105 S IBCLASS=$P($G(^DGCR(399,+$G(IBIFN),0)),U,5)
106 S IBTYPE=$P($$CHGTYPE(+$G(IBIFN)),";",2) I IBTYPE="INPT" S IBTYPE=""
107 I +IBCLASS S IBY=$S(IBCLASS<3:"Inpt",1:"Opt") I IBTYPE'="" S IBY=IBY_" ("_IBTYPE_")"
108 Q IBY
109 ;
110CLNSCRN(IBDT,CLIFN) ; screen for a Procedures Associated Clinic (399, 304, 6), returns true if clinic can be used
111 ; clinic must be defined as a 'Clinic' and it must be active on date of procedure
112 ;
113 N IBCL0,IBCLI,IBX S IBX=0
114 S IBCL0=$G(^SC(+$G(CLIFN),0)),IBCLI=$G(^SC(+$G(CLIFN),"I"))
115 S IBX=$S($P(IBCL0,U,3)'="C":0,'$G(IBDT):0,'IBCLI:1,+IBCLI>+IBDT:1,'$P(IBCLI,U,2):0,1:$P(IBCLI,U,2)'>IBDT)
116 Q IBX
117 ;
118PRVNUM(IBIFN,IBINS,COB) ; Trigger code (399:122,123,124)
119 ; on Primary Secondary/Tertiary Carrier (399:101,102,103)
120 ; returns the Provider Number for the Insurance Company
121 ; Hospital Provider Number for prov id in file 355.92
122 ; or Medicare A provider Number (psych/non-psych) if Medicare A
123 ;
124 ; Input IBIFN - bill ifn
125 ; IBINS - insurance company ifn (opt)
126 ; COB - 1 for primary, 2 for secondary, 3 for tertiary
127 ;
128 N IBX,IBB0,IBBF,IBFT,Z,Z0
129 S:'$G(COB) COB=1
130 S IBX=$P($G(^DGCR(399,+$G(IBIFN),"M1")),U,COB+1),IBB0=$G(^DGCR(399,+$G(IBIFN),0))
131 I $G(IBINS)="" S IBINS=+$G(^DGCR(399,+$G(IBIFN),"I"_COB))
132 G:'IBINS PRVNQ
133 ;
134 ; OEC - 12/21/05 - If an MRA is being processed into an MRA secondary
135 ; claim and the billing provider # already exists, then leave it
136 I $G(IBPRCOB),IBX'="" G PRVNQ
137 ;
138 I +$G(IBIFN),COB N DA S DA=IBIFN I $$MCRACK^IBCBB3(+IBIFN,$P($G(^DGCR(399,+IBIFN,"TX")),U,5),+COB) S IBX=$$MCRANUM^IBCBB3(+IBIFN) G PRVNQ
139 ;
140 ; WCJ - 1/17/06 - Some Insurances require certain electronic plan types to have no secondary ID
141 ; Check if this plan type requires a blank sec id to go out for this insurance
142 N NOSEC S NOSEC=0
143 I $D(^DIC(36,IBINS,13)),$G(IBIFN) D
144 . N PLAN,PLANTYPE
145 . S PLAN=$P($G(^DGCR(399,IBIFN,"I"_COB)),U,18) Q:'PLAN
146 . S PLANTYPE=$P($G(^IBA(355.3,PLAN,0)),U,15) Q:'PLANTYPE
147 . Q:'$D(^DIC(36,IBINS,13,"B",PLANTYPE))
148 . S NOSEC=1,IBX=""
149 I NOSEC G PRVNQ
150 ;
151 ; If using attending/rendering secondary ID, don't do anything
152 I $$FT^IBCEF(IBIFN)=2,$$GET1^DIQ(36,IBINS,4.06,"I") G PRVNQ
153 I $$FT^IBCEF(IBIFN)=3,$$GET1^DIQ(36,IBINS,4.08,"I") G PRVNQ
154 ;
155 S IBX=$$FACNUM^IBCEP2B(IBIFN,COB)
156 ;
157 I IBX="" S IBX=$$GET1^DIQ(350.9,1,1.05)
158 ;
159PRVNQ Q IBX
160 ;
161BF() ; Returns ien of billing fac primary id type
162 N Z,IBX
163 S IBX="",Z=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G(^(Z,1)),U,9) S IBX=Z Q
164 Q IBX
165 ;
166BILLPNS(IBIFN) ; Trigger Code that sets all Bill P/S/T Prov# and QUAL (399: .122,123,124,128,129,130)
167 ; on Bill Form Type (399:.19)
168 N IBDR
169 ;
170 I +$G(^DGCR(399,+$G(IBIFN),"I1")) S IBDR(399,IBIFN_",",122)=$$PRVNUM(IBIFN,"",1),IBDR(399,IBIFN_",",128)=$$PRVQUAL(IBIFN,"",1)
171 I +$G(^DGCR(399,+$G(IBIFN),"I2")) S IBDR(399,IBIFN_",",123)=$$PRVNUM(IBIFN,"",2),IBDR(399,IBIFN_",",129)=$$PRVQUAL(IBIFN,"",2)
172 I +$G(^DGCR(399,+$G(IBIFN),"I3")) S IBDR(399,IBIFN_",",124)=$$PRVNUM(IBIFN,"",3),IBDR(399,IBIFN_",",130)=$$PRVQUAL(IBIFN,"",3)
173 ;
174 I $O(IBDR(0)) D FILE^DIE("","IBDR")
175 Q
176 ;
177PRVQUAL(IBIFN,IBINS,COB) ; Trigger code for Bill P/S/T Prov QUAL (399:128,129,130)
178 ; on P/S/T Carrier (399: 101,102,103)
179 ; returns the Provider ID QUALIFIER
180 ;
181 ; Input IBIFN - bill ifn
182 ; IBINS - insurance company ifn (opt)
183 ; COB - 1 for primary, 2 for secondary, 3 for tertiary
184 ;
185 N IBX,IBB0,IBBF,IBFT,Z,Z0
186 S:'$G(COB) COB=1
187 S IBX=$P($G(^DGCR(399,+$G(IBIFN),"M1")),U,COB+9),IBB0=$G(^DGCR(399,+$G(IBIFN),0))
188 I $G(IBINS)="" S IBINS=+$G(^DGCR(399,+$G(IBIFN),"I"_COB))
189 G:'IBINS PRVQUALQ
190 ;
191 ; If an MRA is being processed into an MRA secondary claim and the
192 ; billing provider qualifier already exists, then leave it alone
193 I $G(IBPRCOB),IBX'="" G PRVQUALQ
194 ;
195 I +$G(IBIFN),COB N DA S DA=IBIFN I $$MCRACK^IBCBB3(+IBIFN,$P($G(^DGCR(399,+IBIFN,"TX")),U,5),+COB) S IBX=$$FIND1^DIC(355.97,,"MX","MEDICARE PART A") G PRVQUALQ
196 ;
197 ; Some Insurances require certain electronic plan types to have no secondary ID
198 ; If this is the case, there is no qualifier
199 N NOSEC S NOSEC=0
200 I $D(^DIC(36,IBINS,13)),$G(IBIFN) D
201 . N PLAN,PLANTYPE
202 . S PLAN=$P($G(^DGCR(399,IBIFN,"I"_COB)),U,18) Q:'PLAN
203 . S PLANTYPE=$P($G(^IBA(355.3,PLAN,0)),U,15) Q:'PLANTYPE
204 . Q:'$D(^DIC(36,IBINS,13,"B",PLANTYPE))
205 . S NOSEC=1,IBX=""
206 I NOSEC G PRVQUALQ
207 ;
208 ; Leave qualifer blank if sending REND/ATT ID
209 I $$FT^IBCEF(IBIFN)=2,$$GET1^DIQ(36,IBINS,4.06,"I") G PRVQUALQ
210 I $$FT^IBCEF(IBIFN)=3,$$GET1^DIQ(36,IBINS,4.08,"I") G PRVQUALQ
211 ;
212 S IBX=$$FACNUM^IBCEP2B(IBIFN,COB,1)
213 ;
214 I IBX="",$$GET1^DIQ(350.9,1,1.05)=$P($G(^DGCR(399,IBIFN,"M1")),U,COB+1) S IBX=$$FIND1^DIC(355.97,,"MX","1J")
215 ;
216PRVQUALQ Q IBX
Note: See TracBrowser for help on using the repository browser.