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 Oct 16, 2024@18:17:22 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
