source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNS.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: 5.5 KB
Line 
1IBCNS ;ALB/AAS - IS INSURANCE ACTIVE ; 22-JULY-91
2 ;;2.0;INTEGRATED BILLING;**28,43,80,82,133**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;MAP TO DGCRNS
6 ;
7 ;Input - DFN = patient
8 ; - IBINDT = (optional) date to check ins active for or today if not defined
9 ; - IBOUTP = (optional) 1 if want active insurance returned in IBDD(insurance company)=node in patient file
10 ; - = 2 if want all ins returned
11 ;
12 ;Output - IBINS = 1 if has active ins., 0 if no active ins.
13 ; - IBDD() = internal node in patient file of valid ins.
14 ; - IBDDI() = internal node in patient file of invalid ins.
15 ;
16% N J,X S IBINS=0 K IBDD,IBDDI
17 S J=0 F S J=$O(^DPT(DFN,.312,J)) Q:'J I $D(^DPT(DFN,.312,J,0)) S X=^(0) D CHK
18 Q
19 ;
20CHK ;
21 ;Input - IBI = entry in insurance multiple
22 ;
23 S Z=$S($D(IBINDT):IBINDT,1:DT),Z1=$S($D(IBOUTP):IBOUTP,1:0)
24 G:'$D(^DIC(36,+X,0)) CHKQ S X1=^(0) ;insurance company entry doesn't exist
25 I $P(X,"^",8) G:Z<$P(X,"^",8) CHKQ ;effective date later than care
26 I $P(X,"^",4) G:Z>$P(X,"^",4) CHKQ ;care after expiration date
27 I $P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",11) G CHKQ ;plan is inactive
28 G:$P(X1,"^",5) CHKQ ;insurance company inactive
29 I '$G(IBWNR) G:$P(X1,"^",2)="N" CHKQ ;insurance company will not reimburse
30 S IBINS=1 I Z1 D
31 .S IBDD(+X)=X
32 .Q:'$P(IBDD(+X),"^",18)
33 .S Y=$G(^IBA(355.3,+$P(IBDD(+X),"^",18),0))
34 .I $P(Y,"^",4)'="" S $P(IBDD(+X),"^",3)=$P(Y,"^",4) ; move group number
35 .I $P(Y,"^",3)'="" S $P(IBDD(+X),"^",15)=$P(Y,"^",3) ; move group name
36CHKQ I Z1=2&('$D(IBDD(+X))) D
37 .S IBDDI(+X)=X
38 .Q:'$P(IBDDI(+X),"^",18)
39 .S Y=$G(^IBA(355.3,+$P(IBDDI(+X),"^",18),0))
40 .I $P(Y,"^",4)'="" S $P(IBDDI(+X),"^",3)=$P(Y,"^",4) ; move group number
41 .I $P(Y,"^",3)'="" S $P(IBDDI(+X),"^",15)=$P(Y,"^",3) ; move group name
42 K X,X1,Z,Z1,Y Q
43 ;
44DD ; - called from input transform and x-refs for field 101,102,103
45 ; - input requires da=internal entry number in 399
46 ; - outputs IBdd(ins co.) array
47 ; patch 80 - Companies that Will Not Reimburse should be included so they can be added to the bill
48 N DFN,IBWNR S DFN=$P(^DGCR(399,DA,0),"^",2),IBOUTP=1,IBINDT=$S(+$G(^DGCR(399,DA,"U")):+$G(^("U")),1:DT),IBWNR=1
49 D %
50DDQ K IBOUTP,IBINDT Q
51 ;
52 ;
53DISP ; -Display all insurance company information
54 ; -input DFN
55 ;
56 N IBDTIN
57DISPDT ; Entrypoint if IBDTIN is to be used to display coverage
58 Q:'$D(DFN) D:'$D(IOF) HOME^%ZIS
59 N X,IBINS,IBX
60 D ALL^IBCNS1(DFN,"IBINS")
61 ;
62 D HDR
63 I '$D(IBINS) W !," No Insurance Information" G DISPQ
64 ;
65 S X=0 F S X=$O(IBINS(X)) Q:'X S IBINS=IBINS(X,0) D D1 I +$G(IBCOVEXT) D D2EXT ; display
66 ;
67DISPQ W ! S X=+$G(^IBA(354,DFN,60)) I +X W !,?16,"*** Verification of No Coverage ",$$FMTE^XLFDT(X)," ***"
68 I $$BUFFER^IBCNBU1(DFN) W !,?17,"*** Patient has Insurance Buffer entries ***"
69 Q
70 ;
71OLDISP ; -Display all insurance company information
72 ; -input DFN
73 ;
74 Q:'$D(DFN) D:'$D(IOF) HOME^%ZIS
75 ;
76 S IBOUTP=2 D IBCNS
77 ;
78 N IBDTIN
79 D HDR
80 I '$D(IBDD),'$D(IBDDI) W !," No Insurance Information" G DISPQ
81 ;
82 S X="" F S X=$O(IBDD(X)) Q:X="" S IBINS=IBDD(X) D D1 ;active insurance
83 S X="" F S X=$O(IBDDI(X)) Q:X="" S IBINS=IBDDI(X) D D1 ;inactive ins
84 ;
85OLDISPQ K IBDD,IBDDI,IBX
86 Q
87 ;
88HDR ; -- print standard header
89 D HDR1("=",IOM-$S($G(IBDTIN):1,1:4))
90 Q
91 ;
92HDR1(CHAR,LENG) ; -- print header, specify character
93 N OFF
94 S OFF=$S($G(IBDTIN):0,1:2)
95 W !?(1+OFF),"Insurance",?(13+OFF),"COB",?(17+OFF),"Subscriber ID",?(35+OFF),"Group",?(47+OFF),"Holder",?(55+OFF),"Effect"_$S('OFF:"",1:"i")_"ve",?(65+OFF+$S('OFF:0,1:1)),"Expires" W:'OFF ?75,"Only"
96 I $G(CHAR)'="",LENG S X="",$P(X,CHAR,LENG)="" W !?(1+OFF),X
97 Q
98 ;
99D1 ; If IBDTIN is defined, this date is used for displaying insurance
100 ; coverage if plan does not provide not full coverage for all categories
101 N X,Y,Z,CAT,OFF Q:'$D(IBINS)
102 S OFF=$S($G(IBDTIN):0,1:2)
103 W !?(1+OFF),$S($D(^DIC(36,+IBINS,0)):$E($P(^(0),"^",1),1,10),1:"UNKNOWN")
104 S X=$P(IBINS,U,20) I X'="" S X=$S(X=1:"p",X=2:"s",X=3:"t",1:"")
105 W ?(14+OFF),X
106 W ?(17+OFF),$E($P(IBINS,"^",2),1,16)
107 ;W ?40,$E($S($P(IBINS,"^",15)'="":$P(IBINS,"^",15),1:$P(IBINS,"^",3)),1,10)
108 W ?(35+OFF),$E($$GRP($P(IBINS,"^",18)),1,10)
109 S X=$P(IBINS,"^",6) W ?(47+OFF),$S(X="v":"SELF",X="s":"SPOUSE",1:"OTHER")
110 W ?(55+OFF),$$DAT1^IBOUTL($P(IBINS,"^",8)),?(65+OFF+$S(OFF:1,1:0)),$$DAT1^IBOUTL($P(IBINS,"^",4))
111 I 'OFF D
112 .I $P($G(^DIC(36,+IBINS,0)),U,2)="N" W ?75,"*WNR*" Q
113 .S X="" F CAT="INPATIENT","OUTPATIENT","PHARMACY","MENTAL HEALTH","DENTAL" D
114 .. S Y=$$PLCOV^IBCNSU3(+$P(IBINS,"^",18),$G(IBDTIN),+$O(^IBE(355.31,"B",CAT,"")))
115 .. I +Y S Z=$S(CAT="PHARMACY":"R",1:$E(CAT)) S:Y>1 Z=$C($A(Z)+32) S X=X_Z
116 .S:X="" X="no CV" I X'?5U W ?75,X
117 Q
118 ;
119GRP(IBCPOL) ; -- return group name/group policy
120 ; input: IBCPOL = pointer to entry in 355.3
121 ; output: group name or group number, if both group NUMBER
122 ; if neither 'Individual PLAN'
123 ;
124 N X,Y S X=""
125 S X=$G(^IBA(355.3,+$G(IBCPOL),0))
126 S Y=$S($P(X,"^",4)'="":$P(X,"^",4),1:$P(X,"^",3))
127 I $P(X,"^",10) S Y="Ind. Plan "_Y
128GRPQ Q Y
129 ;
130D2EXT ; display Conditional Coverage Comments and Riders (DFN,IBINS,X required)
131 N Y,CAT,IBX,IBY,IBZ,ARR,IBCDFN S IBCDFN=X,IBZ=0 N X
132 F CAT="INPATIENT","OUTPATIENT","PHARMACY","MENTAL HEALTH","DENTAL" D
133 . S Y=$$PLCOV^IBCNSU3(+$P(IBINS,"^",18),$G(IBDTIN),+$O(^IBE(355.31,"B",CAT,"")),.ARR)
134 . S IBY=CAT_" Conditional: "
135 . I +Y>1 S IBX=0 F S IBX=$O(ARR(IBX)) Q:'IBX W !,?17,IBY,?47,ARR(IBX) S IBY="",IBZ=1
136 ;
137 K ARR D RIDERS^IBCNSU3(DFN,IBCDFN,.ARR)
138 S IBY="Policy Riders: " S IBX=0 F S IBX=$O(ARR(IBX)) Q:'IBX W !,?17,IBY,?35,ARR(IBX) S IBY="",IBZ=1
139 I +IBZ W !
140 Q
Note: See TracBrowser for help on using the repository browser.