source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNS3.m@ 1801

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

initial load of FOIAVistA 6/30/08 version
File size: 8.3 KB
Line 
1IBCNS3 ;ALB/ARH - DISPLAY EXTENDED INSURANCE ; 01-DEC-04
2 ;;2.0;INTEGRATED BILLING;**287**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5DISP(DFN,DATE,DISPLAY) ; Display all insurance company information
6 ; input: DFN = pointer to patient
7 ; DATE = date to check for coverage and riders
8 ; DISPLAY = contain indicators of data to display (123)
9 ;
10 Q:'$G(DFN) D:'$D(IOF) HOME^%ZIS
11 N IBINS,IBPOLFN,IBPOL0,IBPLNFN S DISPLAY=$G(DISPLAY) I '$G(DATE) S DATE=DT
12 K ^TMP($J,"IBCNS3")
13 ;
14 D ALL^IBCNS1(DFN,"IBINS")
15 ;
16 I '$D(IBINS) D SETLN(" "),SETLN("No Insurance Information")
17 ;
18 ;
19 S IBPOLFN=0 F S IBPOLFN=$O(IBINS(IBPOLFN)) Q:'IBPOLFN D
20 . S IBPOL0=IBINS(IBPOLFN,0),IBPLNFN=$P(IBPOL0,U,18)
21 . S ^TMP($J,"IBCNS3")=IBPOLFN
22 . ;
23 . D GETLN(IBPOL0,DATE)
24 . I DISPLAY[2 D GETEXT(DFN,IBPOLFN,IBPOL0,DATE) ; display extended
25 . I DISPLAY[3 D GETCOM(IBPLNFN,$G(IBINS(IBPOLFN,1))) ; display extended 3, comments
26 ;
27 S ^TMP($J,"IBCNS3")="" D GETNOTES(DFN)
28 ;
29 D PRINT
30 ;
31DISPQ K ^TMP($J,"IBCNS3")
32 Q
33 ;
34PRINT ; display compiled array of patient insurance information in ^TMP($J,"IBCNS3")
35 N IBSUB,IBCOUNT,IBQUIT,IBLEVEL,IBLNX,IBDASH,IBLINE,IBCNTLN S $P(IBDASH,"-",80)="-" S DISPLAY=+$G(DISPLAY)
36 ;
37 D HDR S IBSUB="IBCNS3",IBCOUNT=3,IBQUIT=0
38 ;
39 S IBLEVEL=0 F S IBLEVEL=$O(^TMP($J,IBSUB,IBLEVEL)) Q:'IBLEVEL D Q:IBQUIT
40 . S IBCNTLN=+$G(^TMP($J,IBSUB,IBLEVEL))+1
41 . ;
42 . I IBCOUNT>10,(IBCNTLN+IBCOUNT)>(IOSL-3) S IBQUIT=$$EOP Q:IBQUIT D HDR S IBCOUNT=3
43 . ;
44 . S IBLNX=0 F S IBLNX=$O(^TMP($J,IBSUB,IBLEVEL,IBLNX)) Q:'IBLNX D Q:IBQUIT
45 .. ;
46 .. S IBLINE=$G(^TMP($J,IBSUB,IBLEVEL,IBLNX))
47 .. ;
48 .. W !,IBLINE S IBCOUNT=IBCOUNT+1 I IBCOUNT>(IOSL-3) S IBQUIT=$$EOP Q:IBQUIT W @IOF S IBCOUNT=2
49 . ;
50 . I 'IBQUIT,DISPLAY>1 W !,IBDASH S IBCOUNT=IBCOUNT+1
51 ;
52 I 'IBQUIT,IBCOUNT>2 S IBQUIT=$$EOP
53 Q
54 ;
55SETLN(LINE) ; set line as next line for current policy
56 N CNT,POL S LINE=$G(LINE)
57 S POL=+$G(^TMP($J,"IBCNS3"))
58 I 'POL S POL=$O(^TMP($J,"IBCNS3","~"),-1)+1 S ^TMP($J,"IBCNS3")=POL
59 ;
60 S CNT=+$G(^TMP($J,"IBCNS3",POL))+1
61 S ^TMP($J,"IBCNS3",POL)=CNT
62 S ^TMP($J,"IBCNS3",POL,CNT)=LINE
63 Q
64 ;
65 ;
66 ;
67GETLN(IBPOL0,IBDATE) ; get single line of primary data on insurance policy
68 ; input: IBPOL0 = line from array, zero node of patient policy (2,.312)
69 ; IBDATE = date to check coverage, default today
70 ; output: formatted line of data for insurance policy in TMP($J,"IBCNS")
71 ;
72 N IBX,IBLINE S IBLINE=" " S IBPOL0=$G(IBPOL0)
73 ;
74 S IBX=$G(^DIC(36,+IBPOL0,0)),IBX=$S($P(IBX,U,1)'="":$P(IBX,U,1),1:"UNKNOWN") S IBLINE=$$FRMLN(IBX,IBLINE,11,0)
75 S IBX=$P(IBPOL0,U,20),IBX=$S(IBX=1:"p",IBX=2:"s",IBX=3:"t",1:"") S IBLINE=$$FRMLN(IBX,IBLINE,1,14)
76 S IBX=$P(IBPOL0,U,2) S IBLINE=$$FRMLN(IBX,IBLINE,16,17)
77 S IBX=$$FNDGRP($P(IBPOL0,U,18)) S IBLINE=$$FRMLN(IBX,IBLINE,10,35)
78 S IBX=$P(IBPOL0,U,6),IBX=$S(IBX="v":"SELF",IBX="s":"SPOUSE",1:"OTHER") S IBLINE=$$FRMLN(IBX,IBLINE,7,47)
79 S IBX=$$DAT1^IBOUTL($P(IBPOL0,U,8)) S IBLINE=$$FRMLN(IBX,IBLINE,8,55)
80 S IBX=$$DAT1^IBOUTL($P(IBPOL0,U,4)) S IBLINE=$$FRMLN(IBX,IBLINE,8,65)
81 S IBX=$$FNDCOV(+IBPOL0,+$P(IBPOL0,U,18),$G(IBDATE)) S IBLINE=$$FRMLN(IBX,IBLINE,5,75)
82 ;
83 D SETLN(IBLINE)
84GETLNQ Q
85 ;
86 ;
87GETEXT(DFN,IBPOLFN,IBPOL0,DATE) ; display extended insurance information
88 ; Plan Filing Timeframe, Plan Coverage, Conditional Coverage Comments, and Riders
89 ; input: DFN = pointer to patient (2)
90 ; IBPOLFN = pointer to patient insurance policy in 2.312
91 ; IBPOL0 = line from array, zero node of patient policy (2,.312)
92 ; DATE = date to check coverage, default today
93 ; DISPARR = array to pass data back in, pass by reference
94 ; output: array of extended data in TMP($J,"IBCNS")
95 ;
96 N IBX,IBY,IBZ,IBC,IBINSFN,IBPLNFN,IBPLN0,IBLINE,IBCAT,IBCATFN,IBCOVRD,ARR,ARR1 S:'$G(DATE) DATE=DT
97 S IBINSFN=+$G(IBPOL0) Q:'IBINSFN S IBPLNFN=+$P(IBPOL0,U,18),IBPLN0=$G(^IBA(355.3,IBPLNFN,0)) Q:IBPLN0=""
98 ;
99 S IBLINE="Last Verified: ",(IBY,IBX)=""
100 S IBY=$P($G(^DPT(DFN,.312,IBPOLFN,1)),U,3) I IBY'="" S IBX=$$DAT1^IBOUTL(IBY) S IBLINE=IBLINE_IBX D SETLN(" "),SETLN(IBLINE)
101 ;
102 S IBLINE="Plan Filing Time Frame: "
103 S IBY=$P(IBPLN0,U,13) I IBY'="" S IBLINE=IBLINE_IBY D:IBX="" SETLN(" ") D SETLN(IBLINE)
104 ;
105 S IBLINE="Insurance Comp: "
106 I $P($G(^DIC(36,IBINSFN,0)),U,2)="N" S IBLINE=IBLINE_"Will Not Reimburse" D SETLN(" "),SETLN(IBLINE)
107 ;
108 S IBLINE="Conditional: ",IBCOVRD=""
109 K ARR F IBCAT="INPATIENT","OUTPATIENT","PHARMACY","MENTAL HEALTH","DENTAL" D
110 . S IBCATFN=+$O(^IBE(355.31,"B",IBCAT,"")) Q:'IBCATFN
111 . S IBY=$$PLCOV^IBCNSU3(+IBPLNFN,DATE,IBCATFN,.ARR) Q:IBY'>0
112 . I IBY=1 S IBCOVRD=$G(IBCOVRD)_IBCAT_", " Q
113 . S IBX=IBCAT_": ",IBC=$G(IBC)+100 S IBLINE=$$FRMLN(IBX,IBLINE,15,17)
114 . S IBZ=0 F S IBZ=$O(ARR(IBZ)) Q:'IBZ S IBX=ARR(IBZ) D S IBLINE=""
115 .. S IBLINE=$$FRMLN(IBX,IBLINE,46,33) S ARR1(IBC+IBZ)=IBLINE
116 I IBCOVRD'="" S IBLINE="Plan Coverage: "_$G(IBCOVRD) D SETLN(" "),SETLN(IBLINE)
117 I $O(ARR1("")) D:IBCOVRD="" SETLN(" ") S IBZ=0 F S IBZ=$O(ARR1(IBZ)) Q:'IBZ S IBX=ARR1(IBZ) D SETLN(IBX)
118 ;
119 S IBLINE="Policy Riders: "
120 K ARR D RIDERS^IBCNSU3(+$G(DFN),+$G(IBPOLFN),.ARR) I $O(ARR("")) D SETLN(" ")
121 S IBZ=0 F S IBZ=$O(ARR(IBZ)) Q:'IBZ S IBX=ARR(IBZ) D S IBLINE=""
122 . S IBLINE=$$FRMLN(IBX,IBLINE,62,17) D SETLN(IBLINE)
123 Q
124 ;
125 ;
126GETCOM(IBPLNFN,IBPOL1) ; get patient insurance and plan insurance comments in TMP($J,"IBCNS")
127 N IBX,IBY
128 ;
129 S IBX=$P($G(IBPOL1),U,8) I IBX'="" S IBY="Patient Policy Comments: " D SETLN(" "),SETLN(IBY),SETLN(IBX)
130 ;
131 I +$G(IBPLNFN),$O(^IBA(355.3,+IBPLNFN,11,0)) S IBX="Group/Plan Comments:" D SETLN(" "),SETLN(IBX) D
132 . S IBX=0 F S IBX=$O(^IBA(355.3,+IBPLNFN,11,IBX)) Q:'IBX S IBY=$G(^IBA(355.3,+IBPLNFN,11,IBX,0)) D SETLN(IBY)
133 Q
134 ;
135 ;
136GETNOTES(DFN) ; get final notes/warnings in TMP($J,"IBCNS")
137 N IBX,IBY,IBLINE1,IBLINE2,IBFND S (IBFND,IBLINE1,IBLINE2)="" Q:'$G(DFN)
138 ;
139 S IBX=+$G(^IBA(354,DFN,60)) I +IBX S IBY="*** Verification of No Coverage "_$$FMTE^XLFDT(IBX)_" ***" S IBLINE1=$$FRMLN(IBY,"",60,16),IBFND=1
140 I $$BUFFER^IBCNBU1(DFN) S IBY="*** Patient has Insurance Buffer entries ***" S IBLINE2=$$FRMLN(IBY,"",50,17),IBFND=1
141 ;
142 I +IBFND D SETLN(" ") D:IBLINE1'="" SETLN(IBLINE1) D:IBLINE2'="" SETLN(IBLINE2) D SETLN(" ")
143 ;
144 Q
145 ;
146 ;
147 ;
148 ;
149FRMLN(FIELD,IBLINE,FLNG,COL) ; format line data fields, returns IBLINE with FIELD of length FLNG at column COL
150 N IBNEW,IBL S FIELD=$G(FIELD),IBLINE=$G(IBLINE),FLNG=$G(FLNG),COL=$G(COL)
151 ;
152 S IBNEW=$E(IBLINE,1,COL),IBL=$L(IBNEW),IBNEW=IBNEW_$J("",COL-IBL)
153 S IBNEW=IBNEW_$E(FIELD,1,FLNG),IBL=$L(FIELD),IBNEW=IBNEW_$J("",FLNG-IBL)
154 S IBNEW=IBNEW_$E(IBLINE,COL+FLNG+1,9999)
155 Q IBNEW
156 ;
157 ;
158 ;
159FNDCOV(IBINSFN,IBPLNFN,IBDATE) ; -- return group/plan coverage limitations indications
160 ; input: IBINSFN = pointer to insurance company entry in 36
161 ; IBPLNFN = pointer to insurance plan entry in 355.3
162 ; IBDATE = date to check coverage, default today
163 ; output: if insurance company will not reimburse = WNR, if all covered then returns null
164 ; otherwise list of first characters of types covered, if conditional then character in lower case
165 ;
166 N IBOUT,IBX,IBY,IBCAT,IBCATFN S IBOUT="" S:'$G(IBDATE) IBDATE=DT I '$G(IBINSFN)!'$G(IBPLNFN) G FNDCOVQ
167 ;
168 I $P($G(^DIC(36,+IBINSFN,0)),U,2)="N" S IBOUT="*WNR*" G FNDCOVQ
169 F IBCAT="INPATIENT","OUTPATIENT","PHARMACY","MENTAL HEALTH","DENTAL" D
170 . S IBCATFN=+$O(^IBE(355.31,"B",IBCAT,"")) Q:'IBCATFN
171 . S IBY=$$PLCOV^IBCNSU3(+IBPLNFN,IBDATE,+IBCATFN) Q:'IBY
172 . S IBX=$S(IBCAT="PHARMACY":"R",1:$E(IBCAT)) S:IBY>1 IBX=$C($A(IBX)+32) S IBOUT=IBOUT_IBX
173 S:IBOUT="" IBOUT="no CV" I IBOUT?5U S IBOUT=""
174FNDCOVQ Q IBOUT
175 ;
176 ;
177FNDGRP(IBPLNFN) ; -- return group name/group policy
178 ; input: IBPLNFN = pointer to insurance plan entry in 355.3
179 ; output: group name or group number, if both group NUMBER, check for Individual plans
180 ;
181 N IBX,IBOUT S IBOUT=""
182 S IBX=$G(^IBA(355.3,+$G(IBPLNFN),0))
183 S IBOUT=$S($P(IBX,U,4)'="":$P(IBX,U,4),1:$P(IBX,U,3))
184 I $P(IBX,U,10) S IBOUT="Ind. Plan "_IBOUT
185FNDGRPQ Q IBOUT
186 ;
187 ;
188 ;
189 ;
190HDR ; -- print header
191 N IBX W @IOF
192 W !,"Insurance",?13,"COB",?17,"Subscriber ID",?35,"Group",?47,"Holder",?55,"Effectve",?65,"Expires",?75,"Only"
193 S IBX="",$P(IBX,"=",80)="=" W !,IBX
194 Q
195 ;
196EOP() ; ask user for return at end of page, return 1 if '^' entered
197 N IBQ,DIR,DIRUT,DUOUT,DTOUT,X,Y W ! S IBQ=0,DIR(0)="E" D ^DIR K DIR I $D(DUOUT)!($D(DIRUT)) S IBQ=1
198 Q IBQ
Note: See TracBrowser for help on using the repository browser.