IBCNSOK1 ;ALB/AAS - Insurance consisitency stuff ; 2/22/93
;;2.0;INTEGRATED BILLING;**497**;21-MAR-94;Build 120
;;Per VHA Directive 2004-038, this routine should not be modified.
;
DUPCO(DFN,IBCNS,IBCDFN,IBTALK) ; -- is this a duplicate company for this patient
; -- make this call after selecting a company
; -- input DFN = patient file pointer (required)
; IBCNS = new insurance company selected
; IBCDFN = if added to patient ins type mult is required as enter number in multiple
; IBTALK = (optional) if defined and true will write messages to current device if not queued
; -- output = $p1 - 0 if no other entry 1 if possible dup.
; $p2 - 1 if another active entry for same company
; $p3 - 1 if same co, same subscriber
; $p4 - 1 if same co, same dates
; $p5 - 1 if same co, same plan
; $p6 - 1 if spouse insurer but not listed
; $p7 - 1 if spouse insurer but no employer
N IBI,IBJ,IBX,IBY,I,J,X,Y,Z,IBDUP,IBACT,IBCDFND
S (I,IBDUP)=0
I '$O(^DPT(DFN,.312,0)) G DUPCOQ ; no policies on file, don't bother
;
; -- use b x-ref
F S I=$O(^DPT(DFN,.312,"B",IBCNS,I)) Q:'I S IBX=$G(^DPT(DFN,.312,I,0)) I $S('$G(IBCDFN):1,I=$G(IBCDFN):0,1:1) D
.S IBDUP=1
.S IBACT=$$CHK^IBCNS1(IBX,DT,2) I IBACT S $P(IBDUP,"^",2)=1 ; another active entry
.I '$G(IBCDFN) Q ;quit if not stored in dpt
.I 'IBACT Q
.;
.S IBCDFND=$G(^DPT(DFN,.312,+IBCDFN,0)) I IBCDFND=""!(IBCDFND=+IBCDFND) Q
.I $P(IBX,"^",6)=$P(IBCDFND,"^",6) S $P(IBDUP,"^",3)=1 ; same whose ins.
.I $P(IBX,"^",4)="",$P(IBCDFND,"^",4)="" S $P(IBDUP,"^",4)=1 ; no expiration date
.I $P(IBX,"^",8)="",$P(IBCDFND,"^",8)="" S $P(IBDUP,"^",4)=1 ; no effective date
.; need to figure out overlapping date logic. not simple
.I $P(IBX,"^",18)=$P(IBCDFND,"^",18) S $P(IBDUP,"^",5)=1 ; same plan
.I $P(IBCDFND,"^",6)="s" I $P(^DPT(DFN,0),"^",5)=6!($P(^DPT(DFN,0),"^",5)=7) S $P(IBDUP,"^",6)=1 ; marital status inconsistent
.I $P(IBCDFND,"^",6)="s",$P($G(^DPT(DFN,.25)),"^")="" S $P(IBDUP,"^",7)=1
I 'IBDUP G DUPCOQ
I IBDUP,$G(IBTALK),'$D(ZTQUEUED) D
.W !!,*7,"Warning: Insurance Company selected already on file for this patient."
.I $P(IBDUP,"^",2) W !," The previous entry is active."
.I $P(IBDUP,"^",3) W !," The WHOSE INSURANCE are the same."
.I $P(IBDUP,"^",4) W !," The Effective and Expiration dates may cover overlapping dates."
.I $P(IBDUP,"^",5) W !," The Group Plans are the same."
.I $P(IBDUP,"^",6) W !," WHOSE INSURANCE is Spouse, patient marital Status Inconsistent."
.I $P(IBDUP,"^",7) W !," WHOSE INSURANCE is Spouse but no Employer listed."
.Q
;
DUPCOQ Q IBDUP
;
DUPPOL(IBCPOL,IBTALK) ; -- is this a duplicate policy for this company
N I,J,J2,X,X2,Y,Z,IBDUP,IBCNS ; IB*2.0*497 (vd)
S (I,IBDUP)=0,J=$G(^IBA(366.3,IBCPOL,0)),J2=$G(^(2)),IBCNS=+J ; IB*2.0*497 (vd)
F S I=$O(^IBA(355.3,"B",IBCNS,I)) Q:'I I I'=IBCPOL S X=$G(^IBA(355.3,I,0)),X2=$G(^(2)) D ; IB*2.0*497 (vd)
.Q:'$P(X,"^",2) ;skip individual policies
.I $P(J2,"^",1)'="",$P(J2,"^",1)=$P(X2,"^",1) S $P(IBDUP,"^")=1 ; IB*2.0*497 (vd)
.I $P(J2,"^",2)'="",$P(J2,"^",2)=$P(X2,"^",2) S $P(IBDUP,"^",2)=1 ; IB*2.0*497 (vd)
I IBDUP,$G(IBTALK),'$D(ZTQUEUED) D
.I $P(IBDUP,"^",1) W !!,"Warning: There is another policy with the same Group Name."
.I $P(IBDUP,"^",2) W !!,"Warning: There is another policy with the same Group Number."
;
DUPPOLQ Q IBDUP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSOK1 3596 printed Dec 13, 2024@02:17:47 Page 2
IBCNSOK1 ;ALB/AAS - Insurance consisitency stuff ; 2/22/93
+1 ;;2.0;INTEGRATED BILLING;**497**;21-MAR-94;Build 120
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
DUPCO(DFN,IBCNS,IBCDFN,IBTALK) ; -- is this a duplicate company for this patient
+1 ; -- make this call after selecting a company
+2 ; -- input DFN = patient file pointer (required)
+3 ; IBCNS = new insurance company selected
+4 ; IBCDFN = if added to patient ins type mult is required as enter number in multiple
+5 ; IBTALK = (optional) if defined and true will write messages to current device if not queued
+6 ; -- output = $p1 - 0 if no other entry 1 if possible dup.
+7 ; $p2 - 1 if another active entry for same company
+8 ; $p3 - 1 if same co, same subscriber
+9 ; $p4 - 1 if same co, same dates
+10 ; $p5 - 1 if same co, same plan
+11 ; $p6 - 1 if spouse insurer but not listed
+12 ; $p7 - 1 if spouse insurer but no employer
+13 NEW IBI,IBJ,IBX,IBY,I,J,X,Y,Z,IBDUP,IBACT,IBCDFND
+14 SET (I,IBDUP)=0
+15 ; no policies on file, don't bother
IF '$ORDER(^DPT(DFN,.312,0))
GOTO DUPCOQ
+16 ;
+17 ; -- use b x-ref
+18 FOR
SET I=$ORDER(^DPT(DFN,.312,"B",IBCNS,I))
if 'I
QUIT
SET IBX=$GET(^DPT(DFN,.312,I,0))
IF $SELECT('$GET(IBCDFN):1,I=$GET(IBCDFN):0,1:1)
Begin DoDot:1
+19 SET IBDUP=1
+20 ; another active entry
SET IBACT=$$CHK^IBCNS1(IBX,DT,2)
IF IBACT
SET $PIECE(IBDUP,"^",2)=1
+21 ;quit if not stored in dpt
IF '$GET(IBCDFN)
QUIT
+22 IF 'IBACT
QUIT
+23 ;
+24 SET IBCDFND=$GET(^DPT(DFN,.312,+IBCDFN,0))
IF IBCDFND=""!(IBCDFND=+IBCDFND)
QUIT
+25 ; same whose ins.
IF $PIECE(IBX,"^",6)=$PIECE(IBCDFND,"^",6)
SET $PIECE(IBDUP,"^",3)=1
+26 ; no expiration date
IF $PIECE(IBX,"^",4)=""
IF $PIECE(IBCDFND,"^",4)=""
SET $PIECE(IBDUP,"^",4)=1
+27 ; no effective date
IF $PIECE(IBX,"^",8)=""
IF $PIECE(IBCDFND,"^",8)=""
SET $PIECE(IBDUP,"^",4)=1
+28 ; need to figure out overlapping date logic. not simple
+29 ; same plan
IF $PIECE(IBX,"^",18)=$PIECE(IBCDFND,"^",18)
SET $PIECE(IBDUP,"^",5)=1
+30 ; marital status inconsistent
IF $PIECE(IBCDFND,"^",6)="s"
IF $PIECE(^DPT(DFN,0),"^",5)=6!($PIECE(^DPT(DFN,0),"^",5)=7)
SET $PIECE(IBDUP,"^",6)=1
+31 IF $PIECE(IBCDFND,"^",6)="s"
IF $PIECE($GET(^DPT(DFN,.25)),"^")=""
SET $PIECE(IBDUP,"^",7)=1
End DoDot:1
+32 IF 'IBDUP
GOTO DUPCOQ
+33 IF IBDUP
IF $GET(IBTALK)
IF '$DATA(ZTQUEUED)
Begin DoDot:1
+34 WRITE !!,*7,"Warning: Insurance Company selected already on file for this patient."
+35 IF $PIECE(IBDUP,"^",2)
WRITE !," The previous entry is active."
+36 IF $PIECE(IBDUP,"^",3)
WRITE !," The WHOSE INSURANCE are the same."
+37 IF $PIECE(IBDUP,"^",4)
WRITE !," The Effective and Expiration dates may cover overlapping dates."
+38 IF $PIECE(IBDUP,"^",5)
WRITE !," The Group Plans are the same."
+39 IF $PIECE(IBDUP,"^",6)
WRITE !," WHOSE INSURANCE is Spouse, patient marital Status Inconsistent."
+40 IF $PIECE(IBDUP,"^",7)
WRITE !," WHOSE INSURANCE is Spouse but no Employer listed."
+41 QUIT
End DoDot:1
+42 ;
DUPCOQ QUIT IBDUP
+1 ;
DUPPOL(IBCPOL,IBTALK) ; -- is this a duplicate policy for this company
+1 ; IB*2.0*497 (vd)
NEW I,J,J2,X,X2,Y,Z,IBDUP,IBCNS
+2 ; IB*2.0*497 (vd)
SET (I,IBDUP)=0
SET J=$GET(^IBA(366.3,IBCPOL,0))
SET J2=$GET(^(2))
SET IBCNS=+J
+3 ; IB*2.0*497 (vd)
FOR
SET I=$ORDER(^IBA(355.3,"B",IBCNS,I))
if 'I
QUIT
IF I'=IBCPOL
SET X=$GET(^IBA(355.3,I,0))
SET X2=$GET(^(2))
Begin DoDot:1
+4 ;skip individual policies
if '$PIECE(X,"^",2)
QUIT
+5 ; IB*2.0*497 (vd)
IF $PIECE(J2,"^",1)'=""
IF $PIECE(J2,"^",1)=$PIECE(X2,"^",1)
SET $PIECE(IBDUP,"^")=1
+6 ; IB*2.0*497 (vd)
IF $PIECE(J2,"^",2)'=""
IF $PIECE(J2,"^",2)=$PIECE(X2,"^",2)
SET $PIECE(IBDUP,"^",2)=1
End DoDot:1
+7 IF IBDUP
IF $GET(IBTALK)
IF '$DATA(ZTQUEUED)
Begin DoDot:1
+8 IF $PIECE(IBDUP,"^",1)
WRITE !!,"Warning: There is another policy with the same Group Name."
+9 IF $PIECE(IBDUP,"^",2)
WRITE !!,"Warning: There is another policy with the same Group Number."
End DoDot:1
+10 ;
DUPPOLQ QUIT IBDUP
