- IBCNS1 ;ALB/AAS - INSURANCE MANAGEMENT SUPPORTED FUNCTIONS ;22-JULY-91
- ;;2.0;INTEGRATED BILLING;**28,60,52,85,107,51,137,240,371,516**;21-MAR-94;Build 123
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- INSURED(DFN,IBINDT) ; -- Is patient insured
- ; --Input DFN = patient
- ; IBINDT = (optional) date insured (default = today)
- ; -- Output = 0 - not insured
- ; = 1 - insured
- ;
- N J,X,IBINS S IBINS=0,J=0
- I '$G(DFN) G INSQ
- I '$G(IBINDT) S IBINDT=DT
- F S J=$O(^DPT(DFN,.312,J)) Q:'J S X=$G(^(J,0)) S IBINS=$$CHK(X,IBINDT) Q:IBINS
- INSQ Q IBINS
- ;
- PRE(DFN,IBINDT) ; -- is pre-certification required for patient
- N X,Y,J,IBPRE
- S IBPRE=0,J=0
- S:'$G(IBINDT) IBINDT=DT
- F S J=$O(^DPT(DFN,.312,J)) Q:'J S X=$G(^(J,0)) I $$CHK(X,IBINDT),$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",6) S IBPRE=1 Q
- PREQ Q IBPRE
- ;
- UR(DFN,IBINDT) ; -- is ur required for patient
- N X,Y,J,IBPRE
- S IBUR=0,J=0
- S:'$G(IBINDT) IBINDT=DT
- F S J=$O(^DPT(DFN,.312,J)) Q:'J S X=$G(^(J,0)) I $$CHK(X,IBINDT),$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",5) S IBUR=1 Q
- URQ Q IBUR
- ;
- CHK(X,Z,Y) ; -- check one entry for active
- ; -- Input X = Zeroth node of entry in insurance multiple (2.312)
- ; Z = date to check
- ; Y = 2 if want will not reimburse
- ; = 3 if want will not reimburse AND indemnity plans
- ; = 4 if want will not reimburse, but only if it's
- ; MEDICARE
- ; -- Output 1 = Insurance Active
- ; 0 = Inactive
- ;
- N Z1,X1
- S Z1=0,Y=$G(Y)
- I Y'=3,$$INDEM(X) G CHKQ ; is an indemnity policy or company
- S X1=$G(^DIC(36,+X,0)) G:X1="" CHKQ ;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 Y<2 G:$P(X1,"^",2)="N" CHKQ ;insurance company will not reimburse
- I Y=4,$P(X1,"^",2)="N",'$$MCRWNR^IBEFUNC(+X) G CHKQ ;only MEDICARE WNR
- S Z1=1
- CHKQ Q Z1
- ;
- ACTIVE(IBCIFN) ; -- is this company active for this patient for this date
- ; -- called from input transform and x-refs for fields 101,102,103
- ; -- input
- N ACTIVE,DFN,IBINDT
- S DFN=$P(^DGCR(399,DA,0),"^",2),IBINDT=$S(+$G(^DGCR(399,DA,"U")):+$G(^("U")),1:DT)
- ;
- ACTIVEQ Q ACTIVE
- ;
- 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
- N DFN S DFN=$P(^DGCR(399,DA,0),"^",2),IBINDT=$S(+$G(^DGCR(399,DA,"U")):+$G(^("U")),1:DT)
- D ALLACT
- DDQ K IBINDT Q
- ;
- ;
- ALLACT ; -- return active insurance zeroth nodes in ibdd(ins co,entry in mult)
- N X,X1
- S (X1,IBDD)=0
- F S X1=$O(^DPT(DFN,.312,X1)) Q:'X1 S X=$G(^(X,0)) I $$CHK(X,IBINDT) S IBDD(+X,X1)=X
- ;
- ALLACTQ Q
- ;
- HDR W !?4,"Insurance Co.",?22,"Policy #",?40,"Group",?52,"Holder",?60,"Effective",?70,"Expires" S X="",$P(X,"=",IOM-4)="" W !?4,X
- Q
- ;
- ;
- D1 N X Q:'$D(IBINS)
- W !?4,$S($D(^DIC(36,+IBINS,0)):$E($P(^(0),"^",1),1,16),1:"UNKNOWN")
- W ?22,$E($P(IBINS,"^",2),1,16)
- W ?40,$E($$GRP^IBCNS($P(IBINS,"^",18)),1,10)
- S X=$P(IBINS,"^",6) W ?52,$S(X="v":"SELF",X="s":"SPOUSE",1:"OTHER")
- W ?60,$$DAT1^IBOUTL($P(IBINS,"^",8)),?70,$$DAT1^IBOUTL($P(IBINS,"^",4))
- Q
- ;
- ALL(DFN,VAR,ACT,ADT,SOP) ; -- find all insurance data on a patient
- ;
- ; -- input DFN = patient
- ; VAR = variable to output in format of abc
- ; or abc(dfn)
- ; or ^tmp($j,"Insurance")
- ; ACT = 1 if only active ins. desired
- ; = 2 if active and will not reimburse desired
- ; = 3 if active, will not reimburse, and indemnity are
- ; all desired (for the $$INSTYP function below)
- ; = 4 if only active and MEDICARE WNR only desired
- ; ADT = if ACT=1 or 4, then ADT is the internal date to check
- ; active for, default = dt
- ; SOP = if SOP=1, then sort policies in COB order
- ;
- ; -- output var(0) =: number of entries insurance multiple
- ; var(x,0) =: ^dpt(dfn,.312,x,0)
- ; var(x,1) =: ^dpt(dfn,.312,x,1)
- ; var(x,2) =: ^dpt(dfn,.312,x,2)
- ; var(x,3) =: ^dpt(dfn,.312,x,3)
- ; var(x,4) =: ^dpt(dfn,.312,x,4)
- ; var(x,5) =: ^dpt(dfn,.312,x,5)
- ; var(x,7) =: ^dpt(dfn,.312,x,7)
- ; var(x,355.3) =: ^iba(355.3,$p(var(x,0),"^",18),0)
- ; var("S",COB sequence,x) =: (null) as an xref for COB
- ;
- N X,IBMRA,IBSP,IBIENS
- S X=0 I $G(ACT),$E($G(ADT),1,7)'?7N S ADT=DT
- S (IBMRA,IBSP)=0 ;Flag to say if pt has medicare wnr, spouse has policy
- F S X=$O(^DPT(DFN,.312,X)) Q:'X I $D(^(X,0)) D
- .I $G(ACT),'$$CHK(^DPT(DFN,.312,X,0),ADT,$G(ACT)) Q
- .S @VAR@(0)=$G(@VAR@(0))+1
- .S @VAR@(X,0)=$$ZND(DFN,X)
- .S @VAR@(X,1)=$G(^DPT(DFN,.312,X,1))
- .S @VAR@(X,2)=$G(^DPT(DFN,.312,X,2))
- .S @VAR@(X,3)=$G(^DPT(DFN,.312,X,3))
- .S @VAR@(X,4)=$G(^DPT(DFN,.312,X,4))
- .S @VAR@(X,5)=$G(^DPT(DFN,.312,X,5))
- .S @VAR@(X,7)=$G(^DPT(DFN,.312,X,7))
- .S IBIENS=+$P($G(^DPT(DFN,.312,X,0)),"^",18)
- .S @VAR@(X,355.3)=$G(^IBA(355.3,IBIENS,0))
- .;IB*2.0*516/TAZ - Place HIPAA compliant fields in original location.
- .S $P(@VAR@(X,355.3),U,3)=$$GET1^DIQ(355.3,IBIENS_",",2.01),$P(@VAR@(X,355.3),U,4)=$$GET1^DIQ(355.3,IBIENS_",",2.02)
- .I $G(SOP) D
- ..N COB,WHO
- ..S COB=$P(@VAR@(X,0),U,20)
- ..S WHO=$P(@VAR@(X,0),U,6) S:WHO="s" IBSP=1
- ..I $$MCRWNR^IBEFUNC(+@VAR@(X,0)) D
- ... S COB=.5,IBMRA=1
- ..S COB=$S(COB'="":COB,WHO="v":1,WHO="s":$S(IBMRA:1,1:2),1:3)
- ..S @VAR@("S",COB,X)=""
- ..Q
- ; Ck for spouse's insurance, move it before any MEDICARE WNR if sorting
- I $G(SOP),IBMRA,IBSP D
- . ; Shuffle Medicare WNR, if necessary
- . S X=0 F S X=$O(@VAR@("S",.5,X)) Q:'X S @VAR@("S",2,X)="" K @VAR@("S",.5,X)
- . S X=0 F S X=$O(@VAR@("S",2,X)) Q:'X I $P(@VAR@(X,0),U,6)="s",'$P(@VAR@(X,0),U,20) S @VAR@("S",1,X)="" K @VAR@("S",2,X)
- ALLQ Q
- ;
- ALLWNR(DFN,VAR,ADT) ; Returns 'all active and MEDICARE WNR'
- D ALL(DFN,VAR,4,ADT)
- Q
- ;
- ZND(DFN,NODE,ZNDFILE) ; -- Pull zeroth node from Patient's Insurance Type
- ; subfile. This function returns the zeroth node of the Insurance Type
- ; subfile of the Patient file, i.e. ^DPT(DFN,.312,NODE,0). Both DFN
- ; and NODE must be passed in. Pieces 3 (Group Number) and 15 (Group
- ; Name) will be pulled from file# 355.3, Group Insurance Plan, based
- ; on the Group Plan field on the zeroth node (piece 18). If the
- ; ZNDFILE/399 flag is not set to '399', then the Subscriber ID and Name
- ; of Insured will be overwritten with the values in the new HIPAA-
- ; compliant fields, which are on the seven node.
- ;
- ;IB*2.0*516/TAZ - Original code:
- ;N X,Y S (X,Y)=""
- ;I '$G(DFN)!('$G(NODE)) G ZNDQ
- ;S X=$G(^DPT(+DFN,.312,+NODE,0))
- ;S Y=$G(^IBA(355.3,+$P(X,"^",18),0)) I Y="" G ZNDQ
- ;S $P(X,"^",3)=$P(Y,"^",4) ; move group number
- ;S $P(X,"^",15)=$P(Y,"^",3) ; move group name
- ;
- N X,IBIENS
- S X=""
- I '$G(DFN)!('$G(NODE)) G ZNDQ
- S X=$G(^DPT(+DFN,.312,+NODE,0))
- ; IB*2.0*516/TAZ - If the ZNDFILE flag is set to '399', then the data
- ; returned is going to be filed on a Bill/Claim in file# 399. In that
- ; case, we do not wish to overwrite the Subscriber ID and Name of
- ; Insured because that data will be stored on the Bill/Claim in
- ; another place (^DGCR(399,IEN,"I?7").
- I $G(ZNDFILE)'=399 D
- . S IBIENS=+NODE_","_DFN
- . S $P(X,U,2)=$$GET1^DIQ(2.312,IBIENS_",",7.02) ; Subscriber ID
- . S $P(X,U,17)=$$GET1^DIQ(2.312,IBIENS_",",7.01) ;Name of Insured
- S IBIENS=+$P(X,U,18) I 'IBIENS G ZNDQ
- S $P(X,U,3)=$$GET1^DIQ(355.3,IBIENS_",",2.02) ;group number
- S $P(X,U,15)=$$GET1^DIQ(355.3,IBIENS_",",2.01) ;group name
- ;
- ZNDQ Q X
- ;
- INDEM(X) ; -- is this an indemnity plan
- ; -- input zeroth node if insurance type field
- N IBINDEM,IBCTP
- S IBINDEM=1
- I $P($G(^DIC(36,+X,0)),"^",13)=15 G INDEMQ ; company is indemnity co.
- S IBCTP=$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",9)
- I IBCTP,$P($G(^IBE(355.1,+IBCTP,0)),"^",3)=9 G INDEMQ ; plan is an indemnity plan
- S IBINDEM=0
- INDEMQ Q IBINDEM
- ;
- ;
- INSTYP(DFN,DATE) ; -- return type of insurance policy for patient
- ;
- ; -- input dfn := pointer to patient file (required)
- ; date := date of insurance (optional, default = today)
- ;
- ; -- output Major Category of type of Plan (file 355.1, field .03)
- ; for policy which would be billed first (cob)
- ; null no insurance found
- ; 1 MAJOR MEDICAL (default)
- ; 2 DENTAL
- ; 3 HMO
- ; 4 PPO
- ; 5 MEDICARE
- ; 6 MEDICAID
- ; 7 TRICARE
- ; 8 WORKMANS COMP
- ; 9 INDEMNITY
- ; 10 PRESCRIPTION
- ; 11 MEDICARE SUPPLEMENTAL
- ; 12 ALL OTHER
- ;
- N TYPE,POL,IBCPOL
- S TYPE=""
- I '$G(DFN) G INSTYPQ
- I '$G(DATE) S DATE=DT
- D ALL(DFN,"POL",3,DATE)
- I $G(POL(0))<1 G INSTYPQ
- I $G(POL(0))=1 S IBCPOL=+$O(POL(0))
- I $G(POL(0))>1 S IBCPOL=$$COB(.POL)
- ;
- I IBCPOL S TYPE=$P($G(^IBE(355.1,+$P($G(POL(IBCPOL,355.3)),"^",9),0)),"^",3)
- I TYPE="" S TYPE=1 ;default is major medical
- ;
- INSTYPQ Q TYPE
- ;
- COB(POL) ; -- find policy with high coordination of benefits
- N I,X,IBC,COB,WHO,IBCOB
- ;
- S IBC=""
- S I=0 F S I=$O(POL(I)) Q:'I D
- .S WHO=$P($G(POL(I,0)),"^",6),COB=$P($G(POL(I,0)),"^",20)
- .S X=$S(COB'="":COB,WHO="v":1,WHO="s":2,1:3)
- .I 'IBC S IBC=I,IBCOB=X Q
- .I X<IBCOB S IBC=I,IBCOB=X
- Q IBC
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNS1 9767 printed Jan 18, 2025@03:17:55 Page 2
- IBCNS1 ;ALB/AAS - INSURANCE MANAGEMENT SUPPORTED FUNCTIONS ;22-JULY-91
- +1 ;;2.0;INTEGRATED BILLING;**28,60,52,85,107,51,137,240,371,516**;21-MAR-94;Build 123
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- INSURED(DFN,IBINDT) ; -- Is patient insured
- +1 ; --Input DFN = patient
- +2 ; IBINDT = (optional) date insured (default = today)
- +3 ; -- Output = 0 - not insured
- +4 ; = 1 - insured
- +5 ;
- +6 NEW J,X,IBINS
- SET IBINS=0
- SET J=0
- +7 IF '$GET(DFN)
- GOTO INSQ
- +8 IF '$GET(IBINDT)
- SET IBINDT=DT
- +9 FOR
- SET J=$ORDER(^DPT(DFN,.312,J))
- if 'J
- QUIT
- SET X=$GET(^(J,0))
- SET IBINS=$$CHK(X,IBINDT)
- if IBINS
- QUIT
- INSQ QUIT IBINS
- +1 ;
- PRE(DFN,IBINDT) ; -- is pre-certification required for patient
- +1 NEW X,Y,J,IBPRE
- +2 SET IBPRE=0
- SET J=0
- +3 if '$GET(IBINDT)
- SET IBINDT=DT
- +4 FOR
- SET J=$ORDER(^DPT(DFN,.312,J))
- if 'J
- QUIT
- SET X=$GET(^(J,0))
- IF $$CHK(X,IBINDT)
- IF $PIECE($GET(^IBA(355.3,+$PIECE(X,"^",18),0)),"^",6)
- SET IBPRE=1
- QUIT
- PREQ QUIT IBPRE
- +1 ;
- UR(DFN,IBINDT) ; -- is ur required for patient
- +1 NEW X,Y,J,IBPRE
- +2 SET IBUR=0
- SET J=0
- +3 if '$GET(IBINDT)
- SET IBINDT=DT
- +4 FOR
- SET J=$ORDER(^DPT(DFN,.312,J))
- if 'J
- QUIT
- SET X=$GET(^(J,0))
- IF $$CHK(X,IBINDT)
- IF $PIECE($GET(^IBA(355.3,+$PIECE(X,"^",18),0)),"^",5)
- SET IBUR=1
- QUIT
- URQ QUIT IBUR
- +1 ;
- CHK(X,Z,Y) ; -- check one entry for active
- +1 ; -- Input X = Zeroth node of entry in insurance multiple (2.312)
- +2 ; Z = date to check
- +3 ; Y = 2 if want will not reimburse
- +4 ; = 3 if want will not reimburse AND indemnity plans
- +5 ; = 4 if want will not reimburse, but only if it's
- +6 ; MEDICARE
- +7 ; -- Output 1 = Insurance Active
- +8 ; 0 = Inactive
- +9 ;
- +10 NEW Z1,X1
- +11 SET Z1=0
- SET Y=$GET(Y)
- +12 ; is an indemnity policy or company
- IF Y'=3
- IF $$INDEM(X)
- GOTO CHKQ
- +13 ;insurance company entry doesn't exist
- SET X1=$GET(^DIC(36,+X,0))
- if X1=""
- GOTO CHKQ
- +14 ;effective date later than care
- IF $PIECE(X,"^",8)
- if Z<$PIECE(X,"^",8)
- GOTO CHKQ
- +15 ;care after expiration date
- IF $PIECE(X,"^",4)
- if Z>$PIECE(X,"^",4)
- GOTO CHKQ
- +16 ;plan is inactive
- IF $PIECE($GET(^IBA(355.3,+$PIECE(X,"^",18),0)),"^",11)
- GOTO CHKQ
- +17 ;insurance company inactive
- if $PIECE(X1,"^",5)
- GOTO CHKQ
- +18 ;insurance company will not reimburse
- IF Y<2
- if $PIECE(X1,"^",2)="N"
- GOTO CHKQ
- +19 ;only MEDICARE WNR
- IF Y=4
- IF $PIECE(X1,"^",2)="N"
- IF '$$MCRWNR^IBEFUNC(+X)
- GOTO CHKQ
- +20 SET Z1=1
- CHKQ QUIT Z1
- +1 ;
- ACTIVE(IBCIFN) ; -- is this company active for this patient for this date
- +1 ; -- called from input transform and x-refs for fields 101,102,103
- +2 ; -- input
- +3 NEW ACTIVE,DFN,IBINDT
- +4 SET DFN=$PIECE(^DGCR(399,DA,0),"^",2)
- SET IBINDT=$SELECT(+$GET(^DGCR(399,DA,"U")):+$GET(^("U")),1:DT)
- +5 ;
- ACTIVEQ QUIT ACTIVE
- +1 ;
- 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 NEW DFN
- SET DFN=$PIECE(^DGCR(399,DA,0),"^",2)
- SET IBINDT=$SELECT(+$GET(^DGCR(399,DA,"U")):+$GET(^("U")),1:DT)
- +4 DO ALLACT
- DDQ KILL IBINDT
- QUIT
- +1 ;
- +2 ;
- ALLACT ; -- return active insurance zeroth nodes in ibdd(ins co,entry in mult)
- +1 NEW X,X1
- +2 SET (X1,IBDD)=0
- +3 FOR
- SET X1=$ORDER(^DPT(DFN,.312,X1))
- if 'X1
- QUIT
- SET X=$GET(^(X,0))
- IF $$CHK(X,IBINDT)
- SET IBDD(+X,X1)=X
- +4 ;
- ALLACTQ QUIT
- +1 ;
- HDR WRITE !?4,"Insurance Co.",?22,"Policy #",?40,"Group",?52,"Holder",?60,"Effective",?70,"Expires"
- SET X=""
- SET $PIECE(X,"=",IOM-4)=""
- WRITE !?4,X
- +1 QUIT
- +2 ;
- +3 ;
- D1 NEW X
- if '$DATA(IBINS)
- QUIT
- +1 WRITE !?4,$SELECT($DATA(^DIC(36,+IBINS,0)):$EXTRACT($PIECE(^(0),"^",1),1,16),1:"UNKNOWN")
- +2 WRITE ?22,$EXTRACT($PIECE(IBINS,"^",2),1,16)
- +3 WRITE ?40,$EXTRACT($$GRP^IBCNS($PIECE(IBINS,"^",18)),1,10)
- +4 SET X=$PIECE(IBINS,"^",6)
- WRITE ?52,$SELECT(X="v":"SELF",X="s":"SPOUSE",1:"OTHER")
- +5 WRITE ?60,$$DAT1^IBOUTL($PIECE(IBINS,"^",8)),?70,$$DAT1^IBOUTL($PIECE(IBINS,"^",4))
- +6 QUIT
- +7 ;
- ALL(DFN,VAR,ACT,ADT,SOP) ; -- find all insurance data on a patient
- +1 ;
- +2 ; -- input DFN = patient
- +3 ; VAR = variable to output in format of abc
- +4 ; or abc(dfn)
- +5 ; or ^tmp($j,"Insurance")
- +6 ; ACT = 1 if only active ins. desired
- +7 ; = 2 if active and will not reimburse desired
- +8 ; = 3 if active, will not reimburse, and indemnity are
- +9 ; all desired (for the $$INSTYP function below)
- +10 ; = 4 if only active and MEDICARE WNR only desired
- +11 ; ADT = if ACT=1 or 4, then ADT is the internal date to check
- +12 ; active for, default = dt
- +13 ; SOP = if SOP=1, then sort policies in COB order
- +14 ;
- +15 ; -- output var(0) =: number of entries insurance multiple
- +16 ; var(x,0) =: ^dpt(dfn,.312,x,0)
- +17 ; var(x,1) =: ^dpt(dfn,.312,x,1)
- +18 ; var(x,2) =: ^dpt(dfn,.312,x,2)
- +19 ; var(x,3) =: ^dpt(dfn,.312,x,3)
- +20 ; var(x,4) =: ^dpt(dfn,.312,x,4)
- +21 ; var(x,5) =: ^dpt(dfn,.312,x,5)
- +22 ; var(x,7) =: ^dpt(dfn,.312,x,7)
- +23 ; var(x,355.3) =: ^iba(355.3,$p(var(x,0),"^",18),0)
- +24 ; var("S",COB sequence,x) =: (null) as an xref for COB
- +25 ;
- +26 NEW X,IBMRA,IBSP,IBIENS
- +27 SET X=0
- IF $GET(ACT)
- IF $EXTRACT($GET(ADT),1,7)'?7N
- SET ADT=DT
- +28 ;Flag to say if pt has medicare wnr, spouse has policy
- SET (IBMRA,IBSP)=0
- +29 FOR
- SET X=$ORDER(^DPT(DFN,.312,X))
- if 'X
- QUIT
- IF $DATA(^(X,0))
- Begin DoDot:1
- +30 IF $GET(ACT)
- IF '$$CHK(^DPT(DFN,.312,X,0),ADT,$GET(ACT))
- QUIT
- +31 SET @VAR@(0)=$GET(@VAR@(0))+1
- +32 SET @VAR@(X,0)=$$ZND(DFN,X)
- +33 SET @VAR@(X,1)=$GET(^DPT(DFN,.312,X,1))
- +34 SET @VAR@(X,2)=$GET(^DPT(DFN,.312,X,2))
- +35 SET @VAR@(X,3)=$GET(^DPT(DFN,.312,X,3))
- +36 SET @VAR@(X,4)=$GET(^DPT(DFN,.312,X,4))
- +37 SET @VAR@(X,5)=$GET(^DPT(DFN,.312,X,5))
- +38 SET @VAR@(X,7)=$GET(^DPT(DFN,.312,X,7))
- +39 SET IBIENS=+$PIECE($GET(^DPT(DFN,.312,X,0)),"^",18)
- +40 SET @VAR@(X,355.3)=$GET(^IBA(355.3,IBIENS,0))
- +41 ;IB*2.0*516/TAZ - Place HIPAA compliant fields in original location.
- +42 SET $PIECE(@VAR@(X,355.3),U,3)=$$GET1^DIQ(355.3,IBIENS_",",2.01)
- SET $PIECE(@VAR@(X,355.3),U,4)=$$GET1^DIQ(355.3,IBIENS_",",2.02)
- +43 IF $GET(SOP)
- Begin DoDot:2
- +44 NEW COB,WHO
- +45 SET COB=$PIECE(@VAR@(X,0),U,20)
- +46 SET WHO=$PIECE(@VAR@(X,0),U,6)
- if WHO="s"
- SET IBSP=1
- +47 IF $$MCRWNR^IBEFUNC(+@VAR@(X,0))
- Begin DoDot:3
- +48 SET COB=.5
- SET IBMRA=1
- End DoDot:3
- +49 SET COB=$SELECT(COB'="":COB,WHO="v":1,WHO="s":$SELECT(IBMRA:1,1:2),1:3)
- +50 SET @VAR@("S",COB,X)=""
- +51 QUIT
- End DoDot:2
- End DoDot:1
- +52 ; Ck for spouse's insurance, move it before any MEDICARE WNR if sorting
- +53 IF $GET(SOP)
- IF IBMRA
- IF IBSP
- Begin DoDot:1
- +54 ; Shuffle Medicare WNR, if necessary
- +55 SET X=0
- FOR
- SET X=$ORDER(@VAR@("S",.5,X))
- if 'X
- QUIT
- SET @VAR@("S",2,X)=""
- KILL @VAR@("S",.5,X)
- +56 SET X=0
- FOR
- SET X=$ORDER(@VAR@("S",2,X))
- if 'X
- QUIT
- IF $PIECE(@VAR@(X,0),U,6)="s"
- IF '$PIECE(@VAR@(X,0),U,20)
- SET @VAR@("S",1,X)=""
- KILL @VAR@("S",2,X)
- End DoDot:1
- ALLQ QUIT
- +1 ;
- ALLWNR(DFN,VAR,ADT) ; Returns 'all active and MEDICARE WNR'
- +1 DO ALL(DFN,VAR,4,ADT)
- +2 QUIT
- +3 ;
- ZND(DFN,NODE,ZNDFILE) ; -- Pull zeroth node from Patient's Insurance Type
- +1 ; subfile. This function returns the zeroth node of the Insurance Type
- +2 ; subfile of the Patient file, i.e. ^DPT(DFN,.312,NODE,0). Both DFN
- +3 ; and NODE must be passed in. Pieces 3 (Group Number) and 15 (Group
- +4 ; Name) will be pulled from file# 355.3, Group Insurance Plan, based
- +5 ; on the Group Plan field on the zeroth node (piece 18). If the
- +6 ; ZNDFILE/399 flag is not set to '399', then the Subscriber ID and Name
- +7 ; of Insured will be overwritten with the values in the new HIPAA-
- +8 ; compliant fields, which are on the seven node.
- +9 ;
- +10 ;IB*2.0*516/TAZ - Original code:
- +11 ;N X,Y S (X,Y)=""
- +12 ;I '$G(DFN)!('$G(NODE)) G ZNDQ
- +13 ;S X=$G(^DPT(+DFN,.312,+NODE,0))
- +14 ;S Y=$G(^IBA(355.3,+$P(X,"^",18),0)) I Y="" G ZNDQ
- +15 ;S $P(X,"^",3)=$P(Y,"^",4) ; move group number
- +16 ;S $P(X,"^",15)=$P(Y,"^",3) ; move group name
- +17 ;
- +18 NEW X,IBIENS
- +19 SET X=""
- +20 IF '$GET(DFN)!('$GET(NODE))
- GOTO ZNDQ
- +21 SET X=$GET(^DPT(+DFN,.312,+NODE,0))
- +22 ; IB*2.0*516/TAZ - If the ZNDFILE flag is set to '399', then the data
- +23 ; returned is going to be filed on a Bill/Claim in file# 399. In that
- +24 ; case, we do not wish to overwrite the Subscriber ID and Name of
- +25 ; Insured because that data will be stored on the Bill/Claim in
- +26 ; another place (^DGCR(399,IEN,"I?7").
- +27 IF $GET(ZNDFILE)'=399
- Begin DoDot:1
- +28 SET IBIENS=+NODE_","_DFN
- +29 ; Subscriber ID
- SET $PIECE(X,U,2)=$$GET1^DIQ(2.312,IBIENS_",",7.02)
- +30 ;Name of Insured
- SET $PIECE(X,U,17)=$$GET1^DIQ(2.312,IBIENS_",",7.01)
- End DoDot:1
- +31 SET IBIENS=+$PIECE(X,U,18)
- IF 'IBIENS
- GOTO ZNDQ
- +32 ;group number
- SET $PIECE(X,U,3)=$$GET1^DIQ(355.3,IBIENS_",",2.02)
- +33 ;group name
- SET $PIECE(X,U,15)=$$GET1^DIQ(355.3,IBIENS_",",2.01)
- +34 ;
- ZNDQ QUIT X
- +1 ;
- INDEM(X) ; -- is this an indemnity plan
- +1 ; -- input zeroth node if insurance type field
- +2 NEW IBINDEM,IBCTP
- +3 SET IBINDEM=1
- +4 ; company is indemnity co.
- IF $PIECE($GET(^DIC(36,+X,0)),"^",13)=15
- GOTO INDEMQ
- +5 SET IBCTP=$PIECE($GET(^IBA(355.3,+$PIECE(X,"^",18),0)),"^",9)
- +6 ; plan is an indemnity plan
- IF IBCTP
- IF $PIECE($GET(^IBE(355.1,+IBCTP,0)),"^",3)=9
- GOTO INDEMQ
- +7 SET IBINDEM=0
- INDEMQ QUIT IBINDEM
- +1 ;
- +2 ;
- INSTYP(DFN,DATE) ; -- return type of insurance policy for patient
- +1 ;
- +2 ; -- input dfn := pointer to patient file (required)
- +3 ; date := date of insurance (optional, default = today)
- +4 ;
- +5 ; -- output Major Category of type of Plan (file 355.1, field .03)
- +6 ; for policy which would be billed first (cob)
- +7 ; null no insurance found
- +8 ; 1 MAJOR MEDICAL (default)
- +9 ; 2 DENTAL
- +10 ; 3 HMO
- +11 ; 4 PPO
- +12 ; 5 MEDICARE
- +13 ; 6 MEDICAID
- +14 ; 7 TRICARE
- +15 ; 8 WORKMANS COMP
- +16 ; 9 INDEMNITY
- +17 ; 10 PRESCRIPTION
- +18 ; 11 MEDICARE SUPPLEMENTAL
- +19 ; 12 ALL OTHER
- +20 ;
- +21 NEW TYPE,POL,IBCPOL
- +22 SET TYPE=""
- +23 IF '$GET(DFN)
- GOTO INSTYPQ
- +24 IF '$GET(DATE)
- SET DATE=DT
- +25 DO ALL(DFN,"POL",3,DATE)
- +26 IF $GET(POL(0))<1
- GOTO INSTYPQ
- +27 IF $GET(POL(0))=1
- SET IBCPOL=+$ORDER(POL(0))
- +28 IF $GET(POL(0))>1
- SET IBCPOL=$$COB(.POL)
- +29 ;
- +30 IF IBCPOL
- SET TYPE=$PIECE($GET(^IBE(355.1,+$PIECE($GET(POL(IBCPOL,355.3)),"^",9),0)),"^",3)
- +31 ;default is major medical
- IF TYPE=""
- SET TYPE=1
- +32 ;
- INSTYPQ QUIT TYPE
- +1 ;
- COB(POL) ; -- find policy with high coordination of benefits
- +1 NEW I,X,IBC,COB,WHO,IBCOB
- +2 ;
- +3 SET IBC=""
- +4 SET I=0
- FOR
- SET I=$ORDER(POL(I))
- if 'I
- QUIT
- Begin DoDot:1
- +5 SET WHO=$PIECE($GET(POL(I,0)),"^",6)
- SET COB=$PIECE($GET(POL(I,0)),"^",20)
- +6 SET X=$SELECT(COB'="":COB,WHO="v":1,WHO="s":2,1:3)
- +7 IF 'IBC
- SET IBC=I
- SET IBCOB=X
- QUIT
- +8 IF X<IBCOB
- SET IBC=I
- SET IBCOB=X
- End DoDot:1
- +9 QUIT IBC