Routine: IBCNSOK

IBCNSOK	;ALB/AAS - Patient Insurance consistency checker ; 2/22/93

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

	;;Per VHA Directive 10-93-142, 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

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

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

ERR1	; -- no group plan pointer

	S NODE="IBCNS-ERR1" D FIX

ERR2	; -- wrong insurance pointer

	S NODE="IBCNS-ERR2" D FIX

ERR3	; -- dangle insurance node left

	S NODE="IBCNS-ERR3" D SET

	I IBUPDAT K ^DPT(DFN,.312,IBCDFN) W:'$D(ZTQUEUED) "+"

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

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

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))

	I +IBCPOLD W ?68,$E($P(IBCPOLD,"^",4)_"("_$P($G(^DIC(36,+IBCPOLD,0)),"^"),1,33)_")"

	S IBCPOLD=$G(^IBA(355.3,$P(IBDATA,"^",2),0))

	I +IBCPOLD W ?105,$E($P(IBCPOLD,"^",4)_"("_$P($G(^DIC(36,+IBCPOLD,0)),"^"),1,20)_")"

	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")

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

IBCNSOK   ;ALB/AAS - Patient Insurance consistency checker ; 2/22/93

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, 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        IF +IBCPOLD

               WRITE ?68,$EXTRACT($PIECE(IBCPOLD,"^",4)_"("_$PIECE($GET(^DIC(36,+IBCPOLD,0)),"^"),1,33)_")"

 +8        SET IBCPOLD=$GET(^IBA(355.3,$PIECE(IBDATA,"^",2),0))

 +9        IF +IBCPOLD

               WRITE ?105,$EXTRACT($PIECE(IBCPOLD,"^",4)_"("_$PIECE($GET(^DIC(36,+IBCPOLD,0)),"^"),1,20)_")"

 +10       WRITE ?127,$SELECT($GET(IBUPDAT):"YES",1:"NO")

 +11       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")

 +12       QUIT

 +13      ;

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

IBCNSOK.m