IBCNS ;ALB/AAS - IS INSURANCE ACTIVE ; 22-JULY-91
;;2.0;INTEGRATED BILLING;**28,43,80,82,133,399,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, 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
;IB*2.0*516/TAZ - Retrieve Insurance data with HIPAA compliant Fields
;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
S J=0 F S J=$O(^DPT(DFN,.312,J)) Q:'J I $D(^DPT(DFN,.312,J,0)) S X=$$ZND^IBCNS1(DFN,J) 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
;IB*2.0*516/TAZ - Return Valid Insurance with HIPAA compliant fields
S IBINS=1 I Z1 S IBDD(+X)=X
;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 ;
;IB*2.0*516/TAZ - Return Invalid Insurance with HIPAA compliant Fields
I Z1=2&('$D(IBDD(+X))) S IBDDI(+X)=X
;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 ?74,"*WNR*" Q
.S X="" F CAT="INPATIENT","OUTPATIENT","PHARMACY","MENTAL HEALTH","DENTAL","LONG TERM CARE" 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'?6U W ?74,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'
;
;IB*2.0*516/TAZ Get HIPAA Compliant Fields
;original code:
;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
;
N Y
S Y=$$GET1^DIQ(355.3,+$G(IBCPOL)_",",2.02) ;Group Number
I Y="" S Y=$$GET1^DIQ(355.3,+$G(IBCPOL)_",",2.01) ;Group Name
I $$GET1^DIQ(355.3,+$G(IBCPOL)_",",.1) 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","LONG TERM CARE" 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNS 6485 printed Sep 23, 2025@19:52:55 Page 2
IBCNS ;ALB/AAS - IS INSURANCE ACTIVE ; 22-JULY-91
+1 ;;2.0;INTEGRATED BILLING;**28,43,80,82,133,399,516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRNS
+5 ;
+6 ;Input - DFN = patient
+7 ; - IBINDT = (optional) date to check ins active for or today if not defined
+8 ; - IBOUTP = (optional) 1 if want active insurance returned in IBDD(insurance company)=node in patient file
+9 ; - = 2 if want all ins returned
+10 ;
+11 ;Output - IBINS = 1 if has active ins., 0 if no active ins.
+12 ; - IBDD() = internal node in patient file of valid ins.
+13 ; - IBDDI() = internal node in patient file of invalid ins.
+14 ;
% NEW J,X
SET IBINS=0
KILL IBDD,IBDDI
+1 ;IB*2.0*516/TAZ - Retrieve Insurance data with HIPAA compliant Fields
+2 ;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
+3 SET J=0
FOR
SET J=$ORDER(^DPT(DFN,.312,J))
if 'J
QUIT
IF $DATA(^DPT(DFN,.312,J,0))
SET X=$$ZND^IBCNS1(DFN,J)
DO CHK
+4 QUIT
+5 ;
CHK ;
+1 ;Input - IBI = entry in insurance multiple
+2 ;
+3 SET Z=$SELECT($DATA(IBINDT):IBINDT,1:DT)
SET Z1=$SELECT($DATA(IBOUTP):IBOUTP,1:0)
+4 ;insurance company entry doesn't exist
if '$DATA(^DIC(36,+X,0))
GOTO CHKQ
SET X1=^(0)
+5 ;effective date later than care
IF $PIECE(X,"^",8)
if Z<$PIECE(X,"^",8)
GOTO CHKQ
+6 ;care after expiration date
IF $PIECE(X,"^",4)
if Z>$PIECE(X,"^",4)
GOTO CHKQ
+7 ;plan is inactive
IF $PIECE($GET(^IBA(355.3,+$PIECE(X,"^",18),0)),"^",11)
GOTO CHKQ
+8 ;insurance company inactive
if $PIECE(X1,"^",5)
GOTO CHKQ
+9 ;insurance company will not reimburse
IF '$GET(IBWNR)
if $PIECE(X1,"^",2)="N"
GOTO CHKQ
+10 ;IB*2.0*516/TAZ - Return Valid Insurance with HIPAA compliant fields
+11 SET IBINS=1
IF Z1
SET IBDD(+X)=X
+12 ;S IBINS=1 I Z1 D
+13 ;.S IBDD(+X)=X
+14 ;.Q:'$P(IBDD(+X),"^",18)
+15 ;.S Y=$G(^IBA(355.3,+$P(IBDD(+X),"^",18),0))
+16 ;.I $P(Y,"^",4)'="" S $P(IBDD(+X),"^",3)=$P(Y,"^",4) ; move group number
+17 ;.I $P(Y,"^",3)'="" S $P(IBDD(+X),"^",15)=$P(Y,"^",3) ; move group name
CHKQ ;
+1 ;IB*2.0*516/TAZ - Return Invalid Insurance with HIPAA compliant Fields
+2 IF Z1=2&('$DATA(IBDD(+X)))
SET IBDDI(+X)=X
+3 ;I Z1=2&('$D(IBDD(+X))) D
+4 ;.S IBDDI(+X)=X
+5 ;.Q:'$P(IBDDI(+X),"^",18)
+6 ;.S Y=$G(^IBA(355.3,+$P(IBDDI(+X),"^",18),0))
+7 ;.I $P(Y,"^",4)'="" S $P(IBDDI(+X),"^",3)=$P(Y,"^",4) ; move group number
+8 ;.I $P(Y,"^",3)'="" S $P(IBDDI(+X),"^",15)=$P(Y,"^",3) ; move group name
+9 KILL X,X1,Z,Z1,Y
QUIT
+10 ;
DD ; - called from input transform and x-refs for field 101,102,103
+1 ; - input requires da=internal entry number in 399
+2 ; - outputs IBdd(ins co.) array
+3 ; patch 80 - Companies that Will Not Reimburse should be included so they can be added to the bill
+4 NEW DFN,IBWNR
SET DFN=$PIECE(^DGCR(399,DA,0),"^",2)
SET IBOUTP=1
SET IBINDT=$SELECT(+$GET(^DGCR(399,DA,"U")):+$GET(^("U")),1:DT)
SET IBWNR=1
+5 DO %
DDQ KILL IBOUTP,IBINDT
QUIT
+1 ;
+2 ;
DISP ; -Display all insurance company information
+1 ; -input DFN
+2 ;
+3 NEW IBDTIN
DISPDT ; Entrypoint if IBDTIN is to be used to display coverage
+1 if '$DATA(DFN)
QUIT
if '$DATA(IOF)
DO HOME^%ZIS
+2 NEW X,IBINS,IBX
+3 DO ALL^IBCNS1(DFN,"IBINS")
+4 ;
+5 DO HDR
+6 IF '$DATA(IBINS)
WRITE !," No Insurance Information"
GOTO DISPQ
+7 ;
+8 ; display
SET X=0
FOR
SET X=$ORDER(IBINS(X))
if 'X
QUIT
SET IBINS=IBINS(X,0)
DO D1
IF +$GET(IBCOVEXT)
DO D2EXT
+9 ;
DISPQ WRITE !
SET X=+$GET(^IBA(354,DFN,60))
IF +X
WRITE !,?16,"*** Verification of No Coverage ",$$FMTE^XLFDT(X)," ***"
+1 IF $$BUFFER^IBCNBU1(DFN)
WRITE !,?17,"*** Patient has Insurance Buffer entries ***"
+2 QUIT
+3 ;
OLDISP ; -Display all insurance company information
+1 ; -input DFN
+2 ;
+3 if '$DATA(DFN)
QUIT
if '$DATA(IOF)
DO HOME^%ZIS
+4 ;
+5 SET IBOUTP=2
DO IBCNS
+6 ;
+7 NEW IBDTIN
+8 DO HDR
+9 IF '$DATA(IBDD)
IF '$DATA(IBDDI)
WRITE !," No Insurance Information"
GOTO DISPQ
+10 ;
+11 ;active insurance
SET X=""
FOR
SET X=$ORDER(IBDD(X))
if X=""
QUIT
SET IBINS=IBDD(X)
DO D1
+12 ;inactive ins
SET X=""
FOR
SET X=$ORDER(IBDDI(X))
if X=""
QUIT
SET IBINS=IBDDI(X)
DO D1
+13 ;
OLDISPQ KILL IBDD,IBDDI,IBX
+1 QUIT
+2 ;
HDR ; -- print standard header
+1 DO HDR1("=",IOM-$SELECT($GET(IBDTIN):1,1:4))
+2 QUIT
+3 ;
HDR1(CHAR,LENG) ; -- print header, specify character
+1 NEW OFF
+2 SET OFF=$SELECT($GET(IBDTIN):0,1:2)
+3 WRITE !?(1+OFF),"Insurance",?(13+OFF),"COB",?(17+OFF),"Subscriber ID",?(35+OFF),"Group",?(47+OFF),"Holder",?(55+OFF),"Effect"_$SELECT('OFF:"",1:"i")_"ve",?(65+OFF+$SELECT('OFF:0,1:1)),"Expires"
if 'OFF
WRITE ?75,"Only"
+4 IF $GET(CHAR)'=""
IF LENG
SET X=""
SET $PIECE(X,CHAR,LENG)=""
WRITE !?(1+OFF),X
+5 QUIT
+6 ;
D1 ; If IBDTIN is defined, this date is used for displaying insurance
+1 ; coverage if plan does not provide not full coverage for all categories
+2 NEW X,Y,Z,CAT,OFF
if '$DATA(IBINS)
QUIT
+3 SET OFF=$SELECT($GET(IBDTIN):0,1:2)
+4 WRITE !?(1+OFF),$SELECT($DATA(^DIC(36,+IBINS,0)):$EXTRACT($PIECE(^(0),"^",1),1,10),1:"UNKNOWN")
+5 SET X=$PIECE(IBINS,U,20)
IF X'=""
SET X=$SELECT(X=1:"p",X=2:"s",X=3:"t",1:"")
+6 WRITE ?(14+OFF),X
+7 WRITE ?(17+OFF),$EXTRACT($PIECE(IBINS,"^",2),1,16)
+8 ;W ?40,$E($S($P(IBINS,"^",15)'="":$P(IBINS,"^",15),1:$P(IBINS,"^",3)),1,10)
+9 WRITE ?(35+OFF),$EXTRACT($$GRP($PIECE(IBINS,"^",18)),1,10)
+10 SET X=$PIECE(IBINS,"^",6)
WRITE ?(47+OFF),$SELECT(X="v":"SELF",X="s":"SPOUSE",1:"OTHER")
+11 WRITE ?(55+OFF),$$DAT1^IBOUTL($PIECE(IBINS,"^",8)),?(65+OFF+$SELECT(OFF:1,1:0)),$$DAT1^IBOUTL($PIECE(IBINS,"^",4))
+12 IF 'OFF
Begin DoDot:1
+13 IF $PIECE($GET(^DIC(36,+IBINS,0)),U,2)="N"
WRITE ?74,"*WNR*"
QUIT
+14 SET X=""
FOR CAT="INPATIENT","OUTPATIENT","PHARMACY","MENTAL HEALTH","DENTAL","LONG TERM CARE"
Begin DoDot:2
+15 SET Y=$$PLCOV^IBCNSU3(+$PIECE(IBINS,"^",18),$GET(IBDTIN),+$ORDER(^IBE(355.31,"B",CAT,"")))
+16 IF +Y
SET Z=$SELECT(CAT="PHARMACY":"R",1:$EXTRACT(CAT))
if Y>1
SET Z=$CHAR($ASCII(Z)+32)
SET X=X_Z
End DoDot:2
+17 if X=""
SET X="no CV"
IF X'?6U
WRITE ?74,X
End DoDot:1
+18 QUIT
+19 ;
GRP(IBCPOL) ; -- return group name/group policy
+1 ; input: IBCPOL = pointer to entry in 355.3
+2 ; output: group name or group number, if both group NUMBER
+3 ; if neither 'Individual PLAN'
+4 ;
+5 ;IB*2.0*516/TAZ Get HIPAA Compliant Fields
+6 ;original code:
+7 ;N X,Y S X=""
+8 ;S X=$G(^IBA(355.3,+$G(IBCPOL),0))
+9 ;S Y=$S($P(X,"^",4)'="":$P(X,"^",4),1:$P(X,"^",3))
+10 ;I $P(X,"^",10) S Y="Ind. Plan "_Y
+11 ;
+12 NEW Y
+13 ;Group Number
SET Y=$$GET1^DIQ(355.3,+$GET(IBCPOL)_",",2.02)
+14 ;Group Name
IF Y=""
SET Y=$$GET1^DIQ(355.3,+$GET(IBCPOL)_",",2.01)
+15 IF $$GET1^DIQ(355.3,+$GET(IBCPOL)_",",.1)
SET Y="Ind. Plan "_Y
GRPQ ;
+1 QUIT Y
+2 ;
D2EXT ; display Conditional Coverage Comments and Riders (DFN,IBINS,X required)
+1 NEW Y,CAT,IBX,IBY,IBZ,ARR,IBCDFN
SET IBCDFN=X
SET IBZ=0
NEW X
+2 FOR CAT="INPATIENT","OUTPATIENT","PHARMACY","MENTAL HEALTH","DENTAL","LONG TERM CARE"
Begin DoDot:1
+3 SET Y=$$PLCOV^IBCNSU3(+$PIECE(IBINS,"^",18),$GET(IBDTIN),+$ORDER(^IBE(355.31,"B",CAT,"")),.ARR)
+4 SET IBY=CAT_" Conditional: "
+5 IF +Y>1
SET IBX=0
FOR
SET IBX=$ORDER(ARR(IBX))
if 'IBX
QUIT
WRITE !,?17,IBY,?47,ARR(IBX)
SET IBY=""
SET IBZ=1
End DoDot:1
+6 ;
+7 KILL ARR
DO RIDERS^IBCNSU3(DFN,IBCDFN,.ARR)
+8 SET IBY="Policy Riders: "
SET IBX=0
FOR
SET IBX=$ORDER(ARR(IBX))
if 'IBX
QUIT
WRITE !,?17,IBY,?35,ARR(IBX)
SET IBY=""
SET IBZ=1
+9 IF +IBZ
WRITE !
+10 QUIT
