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

IBCNS ;ALB/AAS - IS INSURANCE ACTIVE ; 22-JULY-91

 ;;2.0;INTEGRATED BILLING;**28,43,80,82,133**;21-MAR-94

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

 ;MAP TO DGCRNS

 ;

 ;Input   -  DFN       = patient

 ;        -  IBINDT  = (optional) date to check ins active for or today if not defined

 ;        -  IBOUTP  = (optional) 1 if want active insurance returned in IBDD(insurance company)=node in patient file

 ;        -            = 2 if want all ins returned

 ;

 ;Output  -  IBINS   = 1 if has active ins., 0 if no active ins.

 ;        -  IBDD()  = internal node in patient file of valid ins.

 ;        -  IBDDI() = internal node in patient file of invalid ins.

 ;

% N J,X S IBINS=0 K IBDD,IBDDI

 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

 Q

 ;

CHK ;

 ;Input   -  IBI  = entry in insurance multiple

 ;

 S Z=$S($D(IBINDT):IBINDT,1:DT),Z1=$S($D(IBOUTP):IBOUTP,1:0)

 G:'$D(^DIC(36,+X,0)) CHKQ S X1=^(0) ;insurance company entry doesn't exist

 I $P(X,"^",8) G:Z<$P(X,"^",8) CHKQ ;effective date later than care

 I $P(X,"^",4) G:Z>$P(X,"^",4) CHKQ ;care after expiration date

 I $P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",11) G CHKQ ;plan is inactive

 G:$P(X1,"^",5) CHKQ ;insurance company inactive

 I '$G(IBWNR) G:$P(X1,"^",2)="N" CHKQ ;insurance company will not reimburse

 S IBINS=1 I Z1 D

 .S IBDD(+X)=X

 .Q:'$P(IBDD(+X),"^",18)

 .S Y=$G(^IBA(355.3,+$P(IBDD(+X),"^",18),0))

 .I $P(Y,"^",4)'="" S $P(IBDD(+X),"^",3)=$P(Y,"^",4) ; move group number

 .I $P(Y,"^",3)'="" S $P(IBDD(+X),"^",15)=$P(Y,"^",3) ; move group name

CHKQ I Z1=2&('$D(IBDD(+X))) D

 .S IBDDI(+X)=X

 .Q:'$P(IBDDI(+X),"^",18)

 .S Y=$G(^IBA(355.3,+$P(IBDDI(+X),"^",18),0))

 .I $P(Y,"^",4)'="" S $P(IBDDI(+X),"^",3)=$P(Y,"^",4) ; move group number

 .I $P(Y,"^",3)'="" S $P(IBDDI(+X),"^",15)=$P(Y,"^",3) ; move group name

 K X,X1,Z,Z1,Y Q

 ;

DD ;  - called from input transform and x-refs for field 101,102,103

 ;  - input requires da=internal entry number in 399

 ;  - outputs IBdd(ins co.) array

 ; patch 80 - Companies that Will Not Reimburse should be included so they can be added to the bill

 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

 D %

DDQ K IBOUTP,IBINDT Q

 ;

 ;

DISP ;  -Display all insurance company information

 ;  -input DFN

 ;

 N IBDTIN

DISPDT ; Entrypoint if IBDTIN is to be used to display coverage

 Q:'$D(DFN)  D:'$D(IOF) HOME^%ZIS

 N X,IBINS,IBX

 D ALL^IBCNS1(DFN,"IBINS")

 ;

 D HDR

 I '$D(IBINS) W !,"    No Insurance Information" G DISPQ

 ;

 S X=0 F  S X=$O(IBINS(X)) Q:'X  S IBINS=IBINS(X,0) D D1 I +$G(IBCOVEXT) D D2EXT ; display

 ;

DISPQ W ! S X=+$G(^IBA(354,DFN,60)) I +X W !,?16,"*** Verification of No Coverage ",$$FMTE^XLFDT(X)," ***"

 I $$BUFFER^IBCNBU1(DFN) W !,?17,"***  Patient has Insurance Buffer entries  ***"

 Q

 ;

OLDISP ;  -Display all insurance company information

 ;  -input DFN

 ;

 Q:'$D(DFN)  D:'$D(IOF) HOME^%ZIS

 ;

 S IBOUTP=2 D IBCNS

 ;

 N IBDTIN

 D HDR

 I '$D(IBDD),'$D(IBDDI) W !,"    No Insurance Information" G DISPQ

 ;

 S X="" F  S X=$O(IBDD(X)) Q:X=""  S IBINS=IBDD(X) D D1 ;active insurance

 S X="" F  S X=$O(IBDDI(X)) Q:X=""  S IBINS=IBDDI(X) D D1 ;inactive ins

 ;

OLDISPQ K IBDD,IBDDI,IBX

 Q

 ;

HDR ; -- print standard header

 D HDR1("=",IOM-$S($G(IBDTIN):1,1:4))

 Q

 ;

HDR1(CHAR,LENG) ; -- print header, specify character

 N OFF

 S OFF=$S($G(IBDTIN):0,1:2)

 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"

 I $G(CHAR)'="",LENG S X="",$P(X,CHAR,LENG)="" W !?(1+OFF),X

 Q

 ;

D1 ; If IBDTIN is defined, this date is used for displaying insurance

 ; coverage if plan does not provide not full coverage for all categories

 N X,Y,Z,CAT,OFF Q:'$D(IBINS)

 S OFF=$S($G(IBDTIN):0,1:2)

 W !?(1+OFF),$S($D(^DIC(36,+IBINS,0)):$E($P(^(0),"^",1),1,10),1:"UNKNOWN")

 S X=$P(IBINS,U,20) I X'="" S X=$S(X=1:"p",X=2:"s",X=3:"t",1:"")

 W ?(14+OFF),X

 W ?(17+OFF),$E($P(IBINS,"^",2),1,16)

 ;W ?40,$E($S($P(IBINS,"^",15)'="":$P(IBINS,"^",15),1:$P(IBINS,"^",3)),1,10)

 W ?(35+OFF),$E($$GRP($P(IBINS,"^",18)),1,10)

 S X=$P(IBINS,"^",6) W ?(47+OFF),$S(X="v":"SELF",X="s":"SPOUSE",1:"OTHER")

 W ?(55+OFF),$$DAT1^IBOUTL($P(IBINS,"^",8)),?(65+OFF+$S(OFF:1,1:0)),$$DAT1^IBOUTL($P(IBINS,"^",4))

 I 'OFF D

 .I $P($G(^DIC(36,+IBINS,0)),U,2)="N" W ?75,"*WNR*" Q

 .S X="" F CAT="INPATIENT","OUTPATIENT","PHARMACY","MENTAL HEALTH","DENTAL" D

 .. S Y=$$PLCOV^IBCNSU3(+$P(IBINS,"^",18),$G(IBDTIN),+$O(^IBE(355.31,"B",CAT,"")))

 .. I +Y S Z=$S(CAT="PHARMACY":"R",1:$E(CAT)) S:Y>1 Z=$C($A(Z)+32) S X=X_Z

 .S:X="" X="no CV" I X'?5U W ?75,X

 Q

 ;

GRP(IBCPOL) ; -- return group name/group policy

 ;     input:   IBCPOL = pointer to entry in 355.3

 ;    output:   group name or group number, if both group NUMBER

 ;              if neither 'Individual PLAN'

 ;

 N X,Y S X=""

 S X=$G(^IBA(355.3,+$G(IBCPOL),0))

 S Y=$S($P(X,"^",4)'="":$P(X,"^",4),1:$P(X,"^",3))

 I $P(X,"^",10) S Y="Ind. Plan "_Y

GRPQ Q Y

 ;

D2EXT ; display Conditional Coverage Comments and Riders (DFN,IBINS,X required)

 N Y,CAT,IBX,IBY,IBZ,ARR,IBCDFN S IBCDFN=X,IBZ=0 N X

 F CAT="INPATIENT","OUTPATIENT","PHARMACY","MENTAL HEALTH","DENTAL" D

 . S Y=$$PLCOV^IBCNSU3(+$P(IBINS,"^",18),$G(IBDTIN),+$O(^IBE(355.31,"B",CAT,"")),.ARR)

 . S IBY=CAT_" Conditional: "

 . I +Y>1 S IBX=0 F  S IBX=$O(ARR(IBX)) Q:'IBX  W !,?17,IBY,?47,ARR(IBX) S IBY="",IBZ=1

 ;

 K ARR D RIDERS^IBCNSU3(DFN,IBCDFN,.ARR)

 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

 I +IBZ W !

 Q