- 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 Jan 18, 2025@03:17:54 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