source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCONS2.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: 9.5 KB
Line 
1IBCONS2 ;ALB/CPM - NSC W/INSURANCE OUTPUT (CON'T) ;31-JAN-92
2 ;;2.0;INTEGRATED BILLING;**19,36,54,66,91,99,108,120,142,174,155**;21-MAR-94
3 ;
4 ;MAP TO DGCRONS2
5 ;
6LOOP1 ; Compilation for both Inpatient Admisssion and Discharge reports.
7 N DA,IBADM K ^TMP($J,"PATIENT INCLUDE"),^TMP($J,"PATIENT EXCLUDE")
8 D DIV
9 F I=(IBBEG-.0001):0 S I=$O(^DGPM(IBSUB,I)) Q:'I!(I>(IBEND+.99)) D
10 . S DFN=0 F S DFN=$O(^DGPM(IBSUB,I,DFN)) Q:'DFN S DA=+$O(^(DFN,0)) D D:PTF PTF I $G(IBDV) D PROC K IBADMVT
11 .. S:IBINPT=2 DA=+$P($G(^DGPM(DA,0)),"^",14),IBADM=+$G(^DGPM(DA,0))
12 .. S PTF=$P($G(^DGPM(DA,0)),"^",16)
13 .. S IBADMVT=DA
14 .. S IBDV=+$P($G(^DIC(42,+$P($G(^DGPM(DA,0)),"^",6),0)),"^",11)
15 K ^TMP($J,"PATIENT INCLUDE"),^TMP($J,"PATIENT EXCLUDE")
16 Q
17 ;
18 ;
19LOOP2 ; Compilation for the Outpatient report
20 N DFN,IBDTA,IBDV,IBVAL,IBFILTER,IBCBK,IBNO,IBOE,IBOE0,IBSTOP,IBOEZ,Y,Y0,IBQUERY2
21 D DIV K ^TMP($J,"PATIENT INCLUDE"),^TMP($J,"PATIENT EXCLUDE")
22 ;
23 S IBQUERY2=""
24 S IBVAL("BDT")=IBBEG,IBVAL("EDT")=IBEND+.99
25 S IBFILTER="I '$P(Y0,U,6)"
26 S IBCBK="D CALLBCK^IBCONS2(Y,Y0,.IBQUERY2)"
27 K ^TMP("IBOEC",$J)
28 D SCAN^IBSDU("DATE/TIME",.IBVAL,IBFILTER,IBCBK,1) K ^TMP("DIERR",$J)
29 I $G(IBQUERY2) D CLOSE^IBSDU(IBQUERY2)
30 ;
31 ; Process stand-alone add/edits extracted
32 S DFN=0 F S DFN=$O(^TMP("IBOEC",$J,DFN)) Q:'DFN I $D(^DPT(DFN,0)) D
33 . S IBDTA=0 F S IBDTA=$O(^TMP("IBOEC",$J,DFN,IBDTA)) Q:'IBDTA D
34 .. K IBOE,IBSTOP,IBCOMB
35 .. S IBNO=1
36 .. S IBOEZ=0 F S IBOEZ=$O(^TMP("IBOEC",$J,DFN,IBDTA,IBOEZ)) Q:'IBOEZ S IBOE0=$$SCE^IBSDU(IBOEZ,"",0) D
37 ... S IBDV=$P(IBOE0,U,11)
38 ... S:$L($G(IBOE(IBNO)))+$L(IBOEZ)+1>200 IBNO=IBNO+1
39 ... S IBOE(IBNO)=$G(IBOE(IBNO))_IBOEZ_U I '$G(IBOE) S IBOE=+IBOE(1)
40 ... S Z=+$P($G(^DIC(40.7,+$P(IBOE0,U,3),0)),U,2) S:Z IBCOMB(Z)=$G(IBCOMB(Z))+1
41 .. S:'$D(IBSTOP) IBSTOP="Add/Edit Stop Code^"
42 .. S Z=0 F S Z=$O(IBCOMB(Z)) Q:'Z S IBSTOP=IBSTOP_Z_$S(IBCOMB(Z)=1:"",1:"(x"_IBCOMB(Z)_")")_U
43 .. ;
44 .. S I=IBDTA
45 .. I $G(IBOE) D PROCO ;All add/edit encounters for a patient/date on a single line
46 ;
47 K ^TMP("IBOEC",$J),^TMP($J,"PATIENT INCLUDE"),^TMP($J,"PATIENT EXCLUDE")
48 Q
49 ;
50CALLBCK(IBOE,IBOE0,IBQUERY2) ; Executed by scan call back logic to process encounters
51 ; IBOE = encounter ien
52 ; IBOE0 = 0-node of the encounter
53 ;
54 N DFN,I,IBDC,IBDS,IBDV,IBSTOP,IBT,Z
55 I '$$BDSRC^IBEFUNC3($P($G(IBOE0),U,5)) Q ; non-billable visit data source
56 ;
57 S IBT=$P(IBOE0,U,8),DFN=$P(IBOE0,U,2),IBDV=$P(IBOE0,U,11),(IBDS,IBDC)=""
58 S I=+IBOE0
59 Q:'I Q:DFN=""
60 I IBT=1 D
61 . S IBDC=+$P(IBOE0,U,4)
62 . I IBDV="" S IBDV=$P($G(^SC(IBDC,0)),U,15)
63 ;
64 I IBT=3 D
65 . S IBDS=$$DISND^IBSDU(IBOE,IBOE0)
66 . I IBDV="" S IBDV=$P(IBDS,U,4)
67 ;
68 Q:'$$VALID()
69 ;
70 ; Screen to only include 1-3 originating process and
71 ; for 1 or 2, include only those that have appt types indicating they
72 ; are included on reports
73 ;
74 I $S(IBT<3:$$RPT^IBEFUNC($P(IBOE0,U,10),+IBOE0),1:IBT=3) D
75 . ; Extract add/edits to global so we can combine the data into one line (2 lines if RNB defined)
76 . I IBT=2 D Q ; Stand-alone Add/Edits
77 .. I VAUTD'=1 Q:'$D(VAUTD(+IBDV))
78 .. I VAUTD=1 Q:'IBDV
79 .. I +$$RNBOE(IBOE) S ^TMP("IBOEC",$J,DFN,(IBOE0\1)_".",IBOE)="" Q
80 .. S ^TMP("IBOEC",$J,DFN,IBOE0\1,IBOE)=""
81 . ;
82 . I IBT=1 D Q ;Appointments
83 .. I IBDC D
84 ... S X=$$CHILD(IBOE,IBOE0,.IBVAL,.IBSTOP,.IBQUERY2)
85 ... S IBSTOP="Clinic: "_$P($G(^SC(IBDC,0)),U)_$S('X:"",1:" -- "_IBSTOP)
86 ... S I=+IBOE0 D PROCO
87 . ;
88 . I IBT=3 D Q ;Registration
89 .. N X
90 .. Q:'$$DISCT^IBEFUNC(IBOE,IBOE0)
91 .. S X=$$CHILD(IBOE,IBOE0,.IBVAL,.IBSTOP,.IBQUERY2)
92 .. S IBSTOP="Registration: "_$P($G(^DIC(37,+$P(IBDS,U,7),0)),U)_$S('X:"",1:" -- "_IBSTOP)
93 .. S I=+IBOE0 D PROCO
94 ;
95 Q
96 ;
97CHILD(IBOE,IBOE0,IBVAL,IBSTOP,IBQUERY2) ;Find any child add/edits
98 ; IBSTOP and IBQUERY2 are returned
99 N IBVAL1,IBFILTER,IBCBK,IBCOMB,Z
100 M IBVAL1=IBVAL
101 S (IBFILTER,IBSTOP)="",IBVAL1("DFN")=+$P(IBOE0,U,2)
102 S IBCBK="I $S(Y=IBOE:1,1:$P(Y0,U,6)=IBOE),$P(Y0,U,3),$$RPT^IBEFUNC($P(Y0,U,10),+Y0) S Z=+$P($G(^DIC(40.7,+$P(Y0,U,3),0)),U,2) S:Z IBCOMB(Z)=$G(IBCOMB(Z))+1"
103 D SCAN^IBSDU("PATIENT/DATE",.IBVAL1,IBFILTER,IBCBK,0,.IBQUERY2) K ^TMP("DIERR",$J)
104 S Z=0 F S Z=$O(IBCOMB(Z)) Q:'Z S IBSTOP=$S(IBSTOP="":"Stop Codes^",1:IBSTOP)_Z_$S(IBCOMB(Z)=1:"",1:"(x"_IBCOMB(Z)_")")_U
105 Q (IBSTOP'="")
106 ;
107PROC ; -process each episode of care
108 Q:'$$VALID()
109PROCO ; Entrypoint for outpatient loop2
110 K IBRMARK
111 I '$G(IBSC) D TRACK^IBCONS3 ; -find tracking entry get reason not billable
112 I +$G(IBSC) S IBRMARK="{ALL MOVES SC}" ; stays with all SC moves not added to CT but on rpt w/RNB ** PATCH 66
113 D BILL,SET ; -on billed or unbilled list
114 Q
115 ;
116VALID() ;
117 N IBOK
118 S IBOK=0
119 I +$G(IBSELRNG),$D(^TMP($J,"PATIENT EXCLUDE",DFN)) G VALIDQ ; pat already excluded from select range ** PATCH 66
120 I +$G(IBSELRNG),+$G(IBSELRNG)<3,'$$PAT(DFN) G VALIDQ ; patient in selected range ** PATCH 66
121 I VAUTD'=1 G:'$D(VAUTD(+IBDV)) VALIDQ
122 I VAUTD=1 G:'IBDV VALIDQ
123 D PTCHK G:'IBFLAG VALIDQ ; -is patient a vet and have ins data
124 D INS G:'IBFLAG VALIDQ ; -is insurance valid for date of care
125 I +$G(IBSELRNG)=3,'$$PTINS(DFN) G VALIDQ ; patient ins is included in range ** PATCH 66
126 S IBOK=1
127VALIDQ Q IBOK
128 ;
129INS S IBFLAG=$$INSURED^IBCNS1(DFN,I)
130 I +IBFLAG,+IBINPT,'$$PTCOV^IBCNSU3(DFN,+I,"INPATIENT") S IBFLAG=0
131 Q
132 ;
133PTCHK S IBFLAG=0 I $D(^DPT(+DFN,.312)),$G(^("VET"))="Y" S IBFLAG=1
134 ; Patch #36 - removes non-veteran eligibilities and inpatient visits
135 I 'IBINPT D
136 .N IBTEMP,IBOE0 S IBTEMP=$$SCE^IBSDU(+IBOE,13,0),IBOE0=$$SCE^IBSDU(+IBOE)
137 .I $P($G(^DIC(8,+IBTEMP,0)),U,5)="N" S IBFLAG=0 Q
138 .I '$$APPTCT^IBEFUNC(IBOE0) S IBFLAG=0 Q
139 Q
140 ;
141SET N DPT0,IBSUBSC2,IBSUBSC3,IBSUBSC4,IBSUBSC6 S DPT0=$G(^DPT(+DFN,0))
142 S IBSUBSC2=+IBDV I +$G(IBSELCDV) S IBSUBSC2="COMBINED"
143 S IBSUBSC3=$S(B]"":2,1:1)
144 S IBSUBSC4=$P(DPT0,U,1) I +$G(IBSELTRM) S IBSUBSC4=+$$TERMDG(DFN)
145 S IBSUBSC6=I F IBSUBSC6=IBSUBSC6:.000001 Q:'$D(^TMP($J,IBSUBSC2,IBSUBSC3,IBSUBSC4,DFN,IBSUBSC6))
146 S ^TMP($J,IBSUBSC2,IBSUBSC3,IBSUBSC4,DFN,IBSUBSC6)=B
147 I $D(IBSTOP),'$D(^TMP($J,IBSUBSC2,IBSUBSC3,IBSUBSC4,DFN,IBSUBSC6,1)) S ^(1)=IBSTOP
148 I $G(IBRMARK)'="" S ^TMP($J,IBSUBSC2,IBSUBSC3,IBSUBSC4,DFN,IBSUBSC6,2)=$G(IBRMARK)
149 K IBSTOP,IBRMARK
150 Q
151 ;
152BILL ; Add to billed list if is insurance bill, not canceled
153 ; if opt, date is in list, if inpt, admission date = event date
154 ; ** PATCH 66 modified to include check for bill authorized status and add that to the stored TMP array
155 ;
156 S B="",I1=$S(IBINPT=2:IBADM,IBINPT:I,1:I\1),IBAUTH=2 N IB0
157 ; -- the following line modified in patch 19 to check for only inpt. bills ($p(^(0),u,5)<3) are counted as bills,
158 ; for when there is an outpatient bill with the same event date.
159 I IBINPT,$D(^DGCR(399,"C",DFN)) F M=0:0 S M=$O(^DGCR(399,"C",DFN,M)) Q:'M D Q:$L(B)>200
160 . S IB0=$G(^DGCR(399,M,0))
161 . I IB0'="",$P(IB0,"^",5)<3,$P(IB0,"^",13)<7,$P($P(IB0,"^",3),".")=$P(I1,"."),$P(IB0,"^",11)="i" S B=B_M_"^" I $P(IB0,"^",13)<2 S IBAUTH=1
162 ;
163 I 'IBINPT,$D(^DGCR(399,"AOPV",DFN,I1)) F M=0:0 S M=$O(^DGCR(399,"AOPV",DFN,I1,M)) Q:'M D Q:$L(B)>200
164 . S IB0=$G(^DGCR(399,M,0))
165 . I IB0'="",$P(IB0,"^",13)<7,$P(IB0,"^",11)="i" S B=B_M_"^" I $P(IB0,"^",13)<2 S IBAUTH=1
166 I +B S B=IBAUTH_"^"_B
167 Q
168 ;
169PTF ; if all movements are for sc condition then not billable
170 ;
171 S IBSC="" Q:'$D(^DGPT(+PTF))
172 S IBMOV=0 F S IBMOV=$O(^DGPT(PTF,"M",IBMOV)) Q:'IBMOV S IBSC=$P($G(^(IBMOV,0)),"^",18) I IBSC=2!(IBSC="") Q
173 S IBSC=$S(IBSC=2!(IBSC=""):0,1:1)
174 Q
175DIV ;adds the requested divisions to the report
176 N IBDIV I +$G(IBSELCDV) S ^TMP($J,"COMBINED")="" Q
177 I VAUTD'=1 D
178 .S IBDIV="" F S IBDIV=$O(VAUTD(IBDIV)) Q:'IBDIV S ^TMP($J,IBDIV)=""
179 I VAUTD=1 D
180 .S IBDIV="" F S IBDIV=$O(^DG(40.8,IBDIV)) Q:IBDIV']""!(+IBDIV'=IBDIV) I $P($G(^DG(40.8,IBDIV,0)),"^",1)]"" S ^TMP($J,IBDIV)=""
181 Q
182 ;
183PAT(DFN) ; true if patient is included in range requested ** PATCH 66
184 N IBX,IBY S IBX=1
185 I $D(^TMP($J,"PATIENT INCLUDE",DFN)) S IBX=1 G PATQ
186 I $D(^TMP($J,"PATIENT EXCLUDE",DFN)) S IBX=0 G PATQ
187 ;
188 I +$G(IBSELRNG)=2 S IBY=$$TERMDG(DFN) D
189 . I IBY<$G(IBSELSR1) S IBX=0
190 . I +$G(IBSELSR2),IBY>IBSELSR2 S IBX=0
191 ;
192 I +$G(IBSELRNG)=1 S IBY=$P($G(^DPT(+DFN,0)),U,1),IBX=$$STGRNG(IBY)
193 ;
194 I +IBX S ^TMP($J,"PATIENT INCLUDE",DFN)=""
195 I 'IBX S ^TMP($J,"PATIENT EXCLUDE",DFN)=""
196PATQ Q IBX
197 ;
198PTINS(DFN) ; check if patients ins is within selected range ** PATCH 66
199 N IBY,IBX,IBAR,IBI S IBX=1
200 I $D(^TMP($J,"PATIENT INCLUDE",DFN)) S IBX=1 G PTINSQ
201 I $D(^TMP($J,"PATIENT EXCLUDE",DFN)) S IBX=0 G PTINSQ
202 ;
203 I $G(IBSELRNG)=3 D ALL^IBCNS1(DFN,"IBAR",1,IBBEG),ALL^IBCNS1(DFN,"IBAR",1,IBEND) S IBX=0
204 S IBI=0 F S IBI=$O(IBAR(IBI)) Q:'IBI S IBY=+$G(IBAR(IBI,0)),IBY=$P($G(^DIC(36,+IBY,0)),U,1) I +$$STGRNG(IBY) S IBX=1 Q
205 ;
206 I +IBX S ^TMP($J,"PATIENT INCLUDE",DFN)=""
207 I 'IBX S ^TMP($J,"PATIENT EXCLUDE",DFN)=""
208PTINSQ Q IBX
209 ;
210STGRNG(STRNG) ; check if the string passed in is contained within the selected ASCII range ** PATCH 66
211 N IBSB,IBSE,IBI,IBY,IBX S IBX=1,STRNG=$$ASCII($G(STRNG))
212 F IBI=1:1 S IBSB=$P($G(IBSELSR1),",",IBI),IBY=$P(STRNG,",",IBI) Q:'IBSB Q:IBSB<IBY I IBSB>IBY S IBX=0 Q
213 F IBI=1:1 S IBSE=$P($G(IBSELSR2),",",IBI),IBY=$P(STRNG,",",IBI) Q:'IBSE Q:IBSE>IBY I IBSE<IBY S IBX=0 Q
214 Q IBX
215 ;
216ASCII(STRNG) ; returns string in ASCII ** PATCH 66
217 N IBI,IBX,IBY S IBX=""
218 I $G(STRNG)'="" F IBI=1:1 S IBY=$E(STRNG,IBI) Q:IBY="" S IBX=IBX_$A(IBY)_"," Q:$L(IBX)>196
219 Q IBX
220 ;
221TERMDG(DFN) ; returns a patients terminal digit ** PATCH 66
222 N TERMD,DPT0,SSN S TERMD="",DPT0=$G(^DPT(+DFN,0)),SSN=$P(DPT0,"^",9)
223 S TERMD=$E(SSN,8,9)_$E(SSN,6,7)_$E(SSN,4,5)_$E(SSN,1,3)
224 Q TERMD
225 ;
226RNBOE(IBOE) ; return a Reason Not Billable for the encounter if one can be found
227 N IBX,IBR S IBR="" I +$G(IBOE) S IBX=+$O(^IBT(356,"ASCE",+IBOE,0)) I +IBX S IBR=$P($G(^IBT(356,IBX,0)),U,19)
228 Q IBR
Note: See TracBrowser for help on using the repository browser.