source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTUBOU.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: 7.6 KB
Line 
1IBTUBOU ;ALB/RB - UNBILLED AMOUNTS (UTILITIES) ;03 Aug 2004 7:21 AM
2 ;;2.0;INTEGRATED BILLING;**123,159,155**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5DT1 ; - Select date range (returns variables IBBDT and IBEDT).
6 N DT0,DT1,DTOUT,DUOUT,Y
7 S DT0=$O(^IBT(356,"D",""))\1,DT1=""
8 I DT0 S DT1=$$DAT3^IBOUTL(DT0),DIR("B")=DT1
9 S DIR(0)="DA^"_DT0_":"_DT_":AEX",DIR("A")="Start with DATE: "
10 S DIR("?",1)="If you enter a start date here, the report will look for"
11 S DIR("?",2)="events ON or AFTER this date. Press <CR> if you want to"
12 S DIR("?",3)="skip this prompt and have the report look thru ALL events"
13 S DIR("?",4)="or enter '^' to exit.",DIR("?",5)=""
14 S DIR("?",6)="NOTE: The earliest date that can be entered is "_DT1_","
15 S DIR("?",7)=" which is the date of the first event on file, and"
16 S DIR("?")=" it is NOT possible to enter a future date."
17 D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S IBBDT="^" G DT1Q
18 S IBBDT=Y,DT1=$$DAT3^IBOUTL(IBBDT)
19 ;
20 S DIR("B")=$$DAT3^IBOUTL(DT)
21 S DIR(0)="DA^"_IBBDT_":"_DT_":AEX",DIR("A")=" Go to DATE: "
22 S DIR("?",1)="If you enter a end date here, the report will look for"
23 S DIR("?",2)="events from "_DT1_" to this date. Press <CR> to have"
24 S DIR("?",3)="the report look at all events from "_DT1_" to today,"
25 S DIR("?",4)="or enter '^' to exit."
26 S DIR("?",5)=""
27 S DIR("?",6)="NOTE: This date MUST NOT be earlier than "_DT1_" neither"
28 S DIR("?")=" later than today."
29 D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S IBBDT="^" G DT1Q
30 S IBEDT=Y+.9
31 ;
32DT1Q Q
33 ;
34DT2(STR) ; - Select re-compile date (returns variable IBTIMON).
35 ; Input: STR - String that describe the type of data that will be
36 ; re-compiled: "Unbilled Amounts", "Average Bill Amounts", etc...
37 ;
38 N DIRUT,DT0,DT1,DT2,Y
39 ; - AUG 1993 is the first month on file with Unbilled Amounts data
40 S DT0=2930800,DT1=$$DAT2^IBOUTL(DT0)
41 S DT2=$$M1^IBJDE(DT,1),DIR("B")=$$DAT2^IBOUTL(DT2)
42 S DIR(0)="DA^"_$E(DT0,1,5)_"00:"_DT2_":AE^K:$E(Y,6,7)'=""00"" X"
43 S DIR("A")="Re-compile "_$G(STR)_" through MONTH/YEAR: "
44 S DIR("?",1)="Enter a past month/year (ex. Oct 2000).",DIR("?",2)=""
45 S DIR("?",3)="NOTE: The earliest month/year that can be entered is "_DT1_", and"
46 S DIR("?")=" it is NOT possible to enter the current or a future month/year."
47 D ^DIR K DIR I $D(DIRUT) S IBTIMON="^" G DT2Q
48 I $E(Y,6,7)'="00"!($E(Y,4,7)="0000") W " ??" G DT2
49 S IBTIMON=Y
50 ;
51DT2Q Q
52 ;
53YR2(D) ; - Return a date two years from date D.
54 N X,X1,X2 S X="" G:'$G(D) YR2Q S X1=D,X2=-730 D C^%DTC
55 ;
56YR2Q Q X
57 ;
58COV(P,E,T) ; - Check if patient has insurance coverage.
59 ; Input: P=patient IEN, E=event date,
60 ; T=1-inpatient/2-outpatient/3-pharmacy
61 ; Output: Y=1-patient has coverage/0-no coverage or unknown
62 N X,XY,Y S Y=0 G:'$G(P)!('$G(E))!('$G(T)) COVQ
63 S X=$S(T=1:"INPATIENT",T=2:"OUTPATIENT",1:"PHARMACY")
64 S Y=$$PTCOV^IBCNSU3(P,E,X,.XY)
65 ;
66COVQ Q Y
67 ;
68PTCHK(DFN,IBNODE) ; - See if patient has a non-veteran eligibility.
69 ; Input: DFN=patient IEN
70 ; IBNODE=zero node to CT entry
71 ; Output: IBFLAG=0-nonbillable, 1-billable
72 N IBFLAG S IBFLAG=0 G:'$G(DFN) PTCKQ
73 I $D(^DPT(+DFN,.312)),$G(^("VET"))="Y" S IBFLAG=1
74 I $P(IBNODE,U,4),$P($G(^DIC(8,+$$SCE^IBSDU(+$P(IBNODE,U,4),13),0)),U,5)="N" S IBFLAG=0
75 ;
76PTCKQ Q IBFLAG
77 ;
78NCCL(ENC) ; - Check if Encounter is NON-COUNT CLINIC
79 ; Input: ENC = Pointer to the ENCOUNTER file (#409.69)
80 ; Output: NCCL= 1 - NON-COUNT CLINIC / 0 - NO NON-COUNT CLINIC
81 N NCCL,HLOC
82 S NCCL=0,HLOC=$$SCE^IBSDU(+ENC,4)
83 I HLOC,$P($G(^SC(+HLOC,0)),"^",17)="Y" S NCCL=1
84 ;
85 Q NCCL
86 ;
87HOSP(ADM) ; Is the patient still hospitalized (not discharged)?
88 ; Input: ADM = Pointer to the PATIENT MOVEMENT file (#405)
89 ;Output: HOSP = 1 - Hospitalized / 0 - Discharged
90 ;
91 N HOSP,X
92 S HOSP=1,X=$G(^DGPM(+ADM,0)) I $P(X,"^",17) S HOSP=0
93 ;
94 Q HOSP
95 ;
96CKBIL(X,Y) ; - Return valid claim data.
97 ; Input: X=IEN from file #399, Y=0-outpatient, 1-inpatient
98 ; Output: Z=rate^status^auth date^1-inst claim/2-prof claim^
99 ; event date (if Y=1), or null^req MRA date
100 N X1,X2,Y1,Z S Z="" G:'$G(X) CKBLQ S:'$G(Y) Y=0
101 S X1=$G(^DGCR(399,X,0)) G:X1="" CKBLQ
102 I $G(DFN),$P(X1,U,2)'=DFN G CKBLQ ; Invalid patient IEN.
103 I '$G(IBRX),'Y,'$$NOTRX(X) G CKBLQ ; Bill has RX rev codes.
104 I $P(X1,U,5)<3,'Y G CKBLQ ; Not inpatient bill.
105 I $P(X1,U,5)>2,Y G CKBLQ ; Not outpatient bill.
106 I $P(X1,U,11)'="i" G CKBLQ ; Not an insurance bill.
107 S X2=$P($G(^DGCR(399,X,"S")),U,10)
108 I 'X2 G:$P(X1,U,13)'=2 CKBLQ ; No authorization date, not MRA req
109 I $P(X1,U,13)<2!($P(X1,U,13)>5) G CKBLQ ; Status not auth, prin, trans.
110 S Z=$P(X1,U,7)_U_$P(X1,U,13)_U_X2,Y1=$P($P(X1,U,3),".")
111 S:$P(X1,U,13)=2 $P(Z,U,6)=$P($G(^DGCR(399,X,"S")),U,7)
112 I $P(X1,U,27)=1!($P(X1,U,19)=3)!(Y1<2990901) S $P(Z,U,4)=1 G CKBL1
113 I $P(X1,U,27)=2!($P(X1,U,19)=2) S $P(Z,U,4)=2
114 I '$P(Z,U,4) S Z="" G CKBLQ ; Not institutional or professional bill.
115CKBL1 I Y S $P(Z,U,5)=Y1
116 ;
117CKBLQ Q Z
118 ;
119CKENC(IBOE,IBOE0,IBQUIT) ; - Check outpatient encounters.
120 N IBCK,IBZ,IBPB,IBZERR
121 I $G(IBOE0)="" D GETGEN^SDOE(IBOE,"IBZ","IBZERR") S IBOE0=$G(IBZ(0))
122 F IBZ=9,13,14 S IBCK(IBZ)=""
123 I '$$BILLCK^IBAMTEDU(IBOE,IBOE0) S IBQUIT=1 ; Not billable.
124 Q
125 ;
126SCAN(DFN,IBDT,IBQUERY) ; - Look at all visits for a day.
127 N IBNDT,IBVAL,IBFILTER,IBCBK
128 S IBVAL("DFN")=DFN,IBVAL("BDT")=IBDT,IBVAL("EDT")=IBDT,IBFILTER=""
129 S IBCBK="I $P(Y0,U,8)=3,Y0>IBDT S:'IBNDT IBNDT=+Y0 D:IBNDT=+Y0 CKENC^IBTUBOU(Y,Y0,.IBQUIT) S:$S('$G(IBQUIT):1,1:Y0>IBNDT) SDSTOP=1"
130 S IBNDT=0 D SCAN^IBSDU("PATIENT/DATE",.IBVAL,IBFILTER,IBCBK,0,.IBQUERY)
131 Q
132 ;
133SC(PTF) ; - If patient is SC, are movements for SC care.
134 ; Input: PTF=PTF record
135 ; Output: IBM=1-all movements PTF, 0-one or more not flagged as SC
136 N M,IBM S IBM=1,M=0 G:$G(^DGPT(+$G(PTF),0))="" SCQ
137 F S M=$O(^DGPT(PTF,"M",M)) Q:'M D Q:'IBM
138 .I $P($G(^DGPT(PTF,"M",M,0)),U,18)'=1 S IBM=0
139 ;
140SCQ Q IBM
141 ;
142LD(L,M) ; - Load average/unbilled totals into file #356.19
143 ; Input: L=1-average (mon), 2-average (12m), 3-unbilled
144 ; M=file #356.19 IEN
145 I '$G(L)!('$G(M)) G LDQ
146 S DA=M,DIE="^IBE(356.19,"
147 S DR=$S(L=3:"[IBT UNBILLED AMOUNTS]",L=2:"[IBT AVERAGE BILL AMOUNTS (12M)]",1:"[IBT AVERAGE BILL AMOUNTS (MON)]")
148 D ^DIE K DA,DIE,DR
149 ;
150LDQ Q
151 ;
152XTRACT ; - Calculate remaining extract totals and load into file #351.71
153 ; - Set IB with the average and total amounts and call E^IBJDE
154 N X,AVGS
155 S AVGS=$$INPAVG(IBTIMON)
156 S IB(2)=$J(IB(1)*$P(AVGS,"^"),0,2)
157 S IB(4)=$J(IB(3)*$P(AVGS,"^",2),0,2)
158 S IB(6)=$J(IB(2)+IB(4),0,2)
159 S IB(13)=IB(9)+IB(11),IB(15)=IB(7)+IB(14)
160 F X=8,10,12,18 S IB(X)=$J(IB(X),0,2)
161 S IB(16)=$J(IB(8)+IB(10)+IB(12),0,2)
162 S IB(19)=$J(IB(6)+IB(16)+IB(18),0,2)
163 D E^IBJDE(37,0)
164 Q
165 ;
166INPAVG(IBYRMO) ; - Calculate the Average Inpatient INST. & PROF. Billed Amounts
167 ; Input: IBYRMO - YEAR/MONTH (YYYMM00) being calculated/updated
168 ; Output: Avg.Inpt.Inst.Bill Amount ^ Avg.Inpt.Prof. Bill Amount
169 ;
170 N AVGI,AVGP,ND I '$G(IBYRMO) Q ""
171 F Q:$P($G(^IBE(356.19,IBYRMO,1)),"^",14)'=""!'IBYRMO D
172 . S IBYRMO=$O(^IBE(356.19,IBYRMO),-1)
173 S (AVGI,AVGP)=0 I 'IBYRMO Q ""
174 S ND=$G(^IBE(356.19,IBYRMO,1))
175 I $P(ND,"^",9) S AVGI=$J($P(ND,"^",8)/$P(ND,"^",9),0,2)
176 I $P(ND,"^",12) S AVGP=$J($P(ND,"^",11)/$P(ND,"^",12),0,2)
177 Q (AVGI_"^"_AVGP)
178 ;
179NOTRX(BILL) ; - Determine if bill contains outpatient visit (use this check
180 ; to make sure not just rx bill returns one if contains a revenue
181 ; code for outpatient visit or a zero if no outpatient visit code
182 ; on bill).
183 N IBRX,RC,X
184 S (IBRX,RC)=0 G:'$O(^DGCR(399,BILL,"OP",0)) NOTRXQ
185 F S RC=$O(^DGCR(399,BILL,"RC",RC)) Q:'RC I $P($G(^DGCR(399.1,+$P($G(^DGCR(399,BILL,"RC",RC,0)),U,5),0)),U)'="PRESCRIPTION" S IBRX=1 Q
186 ;
187NOTRXQ Q IBRX
Note: See TracBrowser for help on using the repository browser.