IBCNSOK ;ALB/AAS - Patient Insurance consistency checker ; 2/22/93
;;2.0;INTEGRATED BILLING;**497**;21-MAR-94;Build 120
;;Per VHA Directive 2004-038, this routine should not be modified.
;
% I '$D(DT) D DT^DICRW
K ^TMP("IBCNS-ERR",$J)
;
W !!,"Check Patient file Insurance Type Group Plan consistency"
W !!,"I'm going to check the Insurance company for each patient policy with the",!,"Insurance company in the associated Group Plan file."
W !!,"This will take a while, please queue this job to a device. I'll print",!,"a report when I'm done.",!!
;
UP S IBUPDAT=0
S DIR(0)="Y",DIR("A")="Update any Inconsistencies",DIR("B")="NO"
S DIR("?")="Enter YES if you want any inconsistencies updated, enter NO if you just want the report."
D ^DIR K DIR
S IBUPDAT=+Y I $D(DIRUT) G END
;
DEV W !! S %ZIS="QM" D ^%ZIS G:POP END
I $D(IO("Q")) K IO("Q") D G END
.S ZTRTN="DQ^IBCNSOK",ZTDESC="IB - v2 PATIENT FILE DOUBLE CHECK",ZTIO="",ZTSAVE("IB*")=""
.W ! D ^%ZTLOAD D HOME^%ZIS
.I $D(ZTSK) W !," Patient file update queued as task ",ZTSK K ZTSK Q
;
D DQ G END
Q
;
END K ^TMP("IBCNS-ERR",$J)
I $D(ZTQUEUED) S ZTREQ="@" Q
D ^%ZISC
K %ZIS,DIRUT,I,J,X,Y,DA,DR,DIC,DIE,DIR,IBCPOL,IBCOPOL2,IBCDFND,NODE,IBI,IBCNTI,IBCNTP,IBCNTPP,IBUPDT,IBCDFN
Q
;
DQ ; -- entry point from task man
U IO
S IBQUIT=0
D NOW^%DTC S IBSPDT=%
I '$D(ZTQUEUED) D
.W !!," I'll write a dot for each 100 entries"
.W:IBUPDAT !," and a + for each entry updated"
.W !," Start time: " S Y=IBSPDT D DT^DIQ
N DFN,IBI,IBCPOL,IBCDFND,DA,DR,DIE,DIC,IBCNT,IBCNTP,IBCNTPP,IBCNTI,IBCDFN
S (IBCNT,IBCNTP,IBCNTPP,IBCNTI,DFN)=0
;
F S DFN=$O(^DPT(DFN)) Q:'DFN S IBCNT=IBCNT+1,IBCDFN=0 S:$O(^DPT(DFN,.312,IBCDFN)) IBCNTI=IBCNTI+1 F S IBCDFN=$O(^DPT(DFN,.312,IBCDFN)) Q:'IBCDFN D
.I '$D(ZTQUEUED) W:'(IBCNTPP#100) "."
.S IBCNTPP=IBCNTPP+1
.S IBCDFND=$G(^DPT(DFN,.312,IBCDFN,0))
.I IBCDFND="",$D(^DPT(DFN,.312,IBCDFN)) D ERR3
.;
.S IBCPOL=+$G(^IBA(355.3,+$P(IBCDFND,"^",18),0))
.I '$P(IBCDFND,"^",18) D ERR1 Q ; no group plan field
.I +IBCPOL'=+IBCDFND D ERR2 Q ; ins. companies don't match
.Q
;
D REPORT G END
Q
;
ERR1 ; -- no group plan pointer
S NODE="IBCNS-ERR1" D FIX
Q
;
ERR2 ; -- wrong insurance pointer
S NODE="IBCNS-ERR2" D FIX
Q
;
ERR3 ; -- dangle insurance node left
S NODE="IBCNS-ERR3" D SET
I IBUPDAT K ^DPT(DFN,.312,IBCDFN) W:'$D(ZTQUEUED) "+"
Q
;
FIX ; -- reset pointer correctly
S IBCPOL2=IBCPOL
;
S IBCPOL=$$CHIP^IBCNSU(IBCDFND)
Q:'IBCPOL
Q:+IBCDFND'=+$G(^IBA(355.3,+IBCPOL,0)) ; patient ins. and policy must have same ins. company file.
S DA=IBCDFN,DA(1)=DFN,DIE="^DPT("_DFN_",.312,"
S DR="1.09////1;.18////"_IBCPOL
D:IBUPDAT ^DIE K DA,DR,DIE,DIC W:'$D(ZTQUEUED) "+"
SET S ^TMP("IBCNS-ERR",$J,$P(^DPT(DFN,0),"^"),DFN,IBCDFN)=IBCPOL2_"^"_IBCPOL_"^"_NODE
Q
;
REPORT ; -- Okay now tell us about the errors
D NOW^%DTC S IBHDT=$$FMTE^XLFDT(%),IBPAG=0
D HDR
S NAME="",NODE="IBCNS-ERR"
I '$D(^TMP(NODE,$J)) W !!,"No Errors Found!" Q
F S NAME=$O(^TMP(NODE,$J,NAME)) Q:NAME="" D
.S DFN=0 F S DFN=$O(^TMP(NODE,$J,NAME,DFN)) Q:'DFN D
..S IBCDFN=0 F S IBCDFN=$O(^TMP(NODE,$J,NAME,DFN,IBCDFN)) Q:'IBCDFN S IBDATA=^(IBCDFN) D ONE
Q
;
ONE ; -- print one line
D PID^VADPT
W !,$E($P($G(^DPT(DFN,0)),"^"),1,16)_" ("_DFN_")"
W ?25,VA("PID")
S IBCDFND=$G(^DPT(DFN,.312,IBCDFN,0))
W ?39,$E($P($G(^DIC(36,+IBCDFND,0)),"^"),1,25)
S IBCPOLD=$G(^IBA(355.3,+IBDATA,0))
N IBCPOLD2 ;WCJ;IB*2*497
S IBCPOLD2=$G(^IBA(355.3,+IBDATA,2)) ;WCJ;IB*2*497
I +IBCPOLD W ?68,$E($P(IBCPOLD2,"^",2)_"("_$P($G(^DIC(36,+IBCPOLD,0)),"^"),1,33)_")" ;WCJ;IB*2*497
S IBCPOLD=$G(^IBA(355.3,$P(IBDATA,"^",2),0))
S IBCPOLD2=$G(^IBA(355.3,$P(IBDATA,"^",2),2)) ;WCJ;IB*2*497
I +IBCPOLD W ?105,$E($P(IBCPOLD2,"^",2)_"("_$P($G(^DIC(36,+IBCPOLD,0)),"^"),1,20)_")" ;WCJ;IB*2*497
W ?127,$S($G(IBUPDAT):"YES",1:"NO")
W !?5,"Error: ",$S($P(IBDATA,"^",3)="IBCNS-ERR1":"Policy is missing group Plan",$P(IBDATA,"^",3)="IBCNS-ERR3":"Dangling insurance node detected",1:"Group Plan is with different insurance company")
Q
;
HDR ; -- Print header
Q:IBQUIT
I $E(IOST,1,2)="C-",IBPAG D PAUSE^VALM1 I $D(DIRUT) S IBQUIT=1 Q
I $E(IOST,1,2)="C-"!(IBPAG) W @IOF
S IBPAG=IBPAG+1
W !,"Patients with Incorrect Group Plans",?(IOM-33),"Page ",IBPAG," ",IBHDT
W !,"PATIENT",?25,"PATIENT ID",?39,"INSURANCE CO.",?68,"OLD PLAN",?105,"NEW PLAN",?127,"UPDATED"
W !,$TR($J(" ",IOM)," ","-")
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1,IBQUIT=1 W !!,"....task stoped at user request" Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSOK 4605 printed Sep 23, 2025@19:54:01 Page 2
IBCNSOK ;ALB/AAS - Patient Insurance consistency checker ; 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 ;
% IF '$DATA(DT)
DO DT^DICRW
+1 KILL ^TMP("IBCNS-ERR",$JOB)
+2 ;
+3 WRITE !!,"Check Patient file Insurance Type Group Plan consistency"
+4 WRITE !!,"I'm going to check the Insurance company for each patient policy with the",!,"Insurance company in the associated Group Plan file."
+5 WRITE !!,"This will take a while, please queue this job to a device. I'll print",!,"a report when I'm done.",!!
+6 ;
UP SET IBUPDAT=0
+1 SET DIR(0)="Y"
SET DIR("A")="Update any Inconsistencies"
SET DIR("B")="NO"
+2 SET DIR("?")="Enter YES if you want any inconsistencies updated, enter NO if you just want the report."
+3 DO ^DIR
KILL DIR
+4 SET IBUPDAT=+Y
IF $DATA(DIRUT)
GOTO END
+5 ;
DEV WRITE !!
SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO END
+1 IF $DATA(IO("Q"))
KILL IO("Q")
Begin DoDot:1
+2 SET ZTRTN="DQ^IBCNSOK"
SET ZTDESC="IB - v2 PATIENT FILE DOUBLE CHECK"
SET ZTIO=""
SET ZTSAVE("IB*")=""
+3 WRITE !
DO ^%ZTLOAD
DO HOME^%ZIS
+4 IF $DATA(ZTSK)
WRITE !," Patient file update queued as task ",ZTSK
KILL ZTSK
QUIT
End DoDot:1
GOTO END
+5 ;
+6 DO DQ
GOTO END
+7 QUIT
+8 ;
END KILL ^TMP("IBCNS-ERR",$JOB)
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+2 DO ^%ZISC
+3 KILL %ZIS,DIRUT,I,J,X,Y,DA,DR,DIC,DIE,DIR,IBCPOL,IBCOPOL2,IBCDFND,NODE,IBI,IBCNTI,IBCNTP,IBCNTPP,IBUPDT,IBCDFN
+4 QUIT
+5 ;
DQ ; -- entry point from task man
+1 USE IO
+2 SET IBQUIT=0
+3 DO NOW^%DTC
SET IBSPDT=%
+4 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+5 WRITE !!," I'll write a dot for each 100 entries"
+6 if IBUPDAT
WRITE !," and a + for each entry updated"
+7 WRITE !," Start time: "
SET Y=IBSPDT
DO DT^DIQ
End DoDot:1
+8 NEW DFN,IBI,IBCPOL,IBCDFND,DA,DR,DIE,DIC,IBCNT,IBCNTP,IBCNTPP,IBCNTI,IBCDFN
+9 SET (IBCNT,IBCNTP,IBCNTPP,IBCNTI,DFN)=0
+10 ;
+11 FOR
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
SET IBCNT=IBCNT+1
SET IBCDFN=0
if $ORDER(^DPT(DFN,.312,IBCDFN))
SET IBCNTI=IBCNTI+1
FOR
SET IBCDFN=$ORDER(^DPT(DFN,.312,IBCDFN))
if 'IBCDFN
QUIT
Begin DoDot:1
+12 IF '$DATA(ZTQUEUED)
if '(IBCNTPP#100)
WRITE "."
+13 SET IBCNTPP=IBCNTPP+1
+14 SET IBCDFND=$GET(^DPT(DFN,.312,IBCDFN,0))
+15 IF IBCDFND=""
IF $DATA(^DPT(DFN,.312,IBCDFN))
DO ERR3
+16 ;
+17 SET IBCPOL=+$GET(^IBA(355.3,+$PIECE(IBCDFND,"^",18),0))
+18 ; no group plan field
IF '$PIECE(IBCDFND,"^",18)
DO ERR1
QUIT
+19 ; ins. companies don't match
IF +IBCPOL'=+IBCDFND
DO ERR2
QUIT
+20 QUIT
End DoDot:1
+21 ;
+22 DO REPORT
GOTO END
+23 QUIT
+24 ;
ERR1 ; -- no group plan pointer
+1 SET NODE="IBCNS-ERR1"
DO FIX
+2 QUIT
+3 ;
ERR2 ; -- wrong insurance pointer
+1 SET NODE="IBCNS-ERR2"
DO FIX
+2 QUIT
+3 ;
ERR3 ; -- dangle insurance node left
+1 SET NODE="IBCNS-ERR3"
DO SET
+2 IF IBUPDAT
KILL ^DPT(DFN,.312,IBCDFN)
if '$DATA(ZTQUEUED)
WRITE "+"
+3 QUIT
+4 ;
FIX ; -- reset pointer correctly
+1 SET IBCPOL2=IBCPOL
+2 ;
+3 SET IBCPOL=$$CHIP^IBCNSU(IBCDFND)
+4 if 'IBCPOL
QUIT
+5 ; patient ins. and policy must have same ins. company file.
if +IBCDFND'=+$GET(^IBA(355.3,+IBCPOL,0))
QUIT
+6 SET DA=IBCDFN
SET DA(1)=DFN
SET DIE="^DPT("_DFN_",.312,"
+7 SET DR="1.09////1;.18////"_IBCPOL
+8 if IBUPDAT
DO ^DIE
KILL DA,DR,DIE,DIC
if '$DATA(ZTQUEUED)
WRITE "+"
SET SET ^TMP("IBCNS-ERR",$JOB,$PIECE(^DPT(DFN,0),"^"),DFN,IBCDFN)=IBCPOL2_"^"_IBCPOL_"^"_NODE
+1 QUIT
+2 ;
REPORT ; -- Okay now tell us about the errors
+1 DO NOW^%DTC
SET IBHDT=$$FMTE^XLFDT(%)
SET IBPAG=0
+2 DO HDR
+3 SET NAME=""
SET NODE="IBCNS-ERR"
+4 IF '$DATA(^TMP(NODE,$JOB))
WRITE !!,"No Errors Found!"
QUIT
+5 FOR
SET NAME=$ORDER(^TMP(NODE,$JOB,NAME))
if NAME=""
QUIT
Begin DoDot:1
+6 SET DFN=0
FOR
SET DFN=$ORDER(^TMP(NODE,$JOB,NAME,DFN))
if 'DFN
QUIT
Begin DoDot:2
+7 SET IBCDFN=0
FOR
SET IBCDFN=$ORDER(^TMP(NODE,$JOB,NAME,DFN,IBCDFN))
if 'IBCDFN
QUIT
SET IBDATA=^(IBCDFN)
DO ONE
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
ONE ; -- print one line
+1 DO PID^VADPT
+2 WRITE !,$EXTRACT($PIECE($GET(^DPT(DFN,0)),"^"),1,16)_" ("_DFN_")"
+3 WRITE ?25,VA("PID")
+4 SET IBCDFND=$GET(^DPT(DFN,.312,IBCDFN,0))
+5 WRITE ?39,$EXTRACT($PIECE($GET(^DIC(36,+IBCDFND,0)),"^"),1,25)
+6 SET IBCPOLD=$GET(^IBA(355.3,+IBDATA,0))
+7 ;WCJ;IB*2*497
NEW IBCPOLD2
+8 ;WCJ;IB*2*497
SET IBCPOLD2=$GET(^IBA(355.3,+IBDATA,2))
+9 ;WCJ;IB*2*497
IF +IBCPOLD
WRITE ?68,$EXTRACT($PIECE(IBCPOLD2,"^",2)_"("_$PIECE($GET(^DIC(36,+IBCPOLD,0)),"^"),1,33)_")"
+10 SET IBCPOLD=$GET(^IBA(355.3,$PIECE(IBDATA,"^",2),0))
+11 ;WCJ;IB*2*497
SET IBCPOLD2=$GET(^IBA(355.3,$PIECE(IBDATA,"^",2),2))
+12 ;WCJ;IB*2*497
IF +IBCPOLD
WRITE ?105,$EXTRACT($PIECE(IBCPOLD2,"^",2)_"("_$PIECE($GET(^DIC(36,+IBCPOLD,0)),"^"),1,20)_")"
+13 WRITE ?127,$SELECT($GET(IBUPDAT):"YES",1:"NO")
+14 WRITE !?5,"Error: ",$SELECT($PIECE(IBDATA,"^",3)="IBCNS-ERR1":"Policy is missing group Plan",$PIECE(IBDATA,"^",3)="IBCNS-ERR3":"Dangling insurance node detected",1:"Group Plan is with different insurance company")
+15 QUIT
+16 ;
HDR ; -- Print header
+1 if IBQUIT
QUIT
+2 IF $EXTRACT(IOST,1,2)="C-"
IF IBPAG
DO PAUSE^VALM1
IF $DATA(DIRUT)
SET IBQUIT=1
QUIT
+3 IF $EXTRACT(IOST,1,2)="C-"!(IBPAG)
WRITE @IOF
+4 SET IBPAG=IBPAG+1
+5 WRITE !,"Patients with Incorrect Group Plans",?(IOM-33),"Page ",IBPAG," ",IBHDT
+6 WRITE !,"PATIENT",?25,"PATIENT ID",?39,"INSURANCE CO.",?68,"OLD PLAN",?105,"NEW PLAN",?127,"UPDATED"
+7 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")
+8 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
SET IBQUIT=1
WRITE !!,"....task stoped at user request"
QUIT
+9 QUIT
