AGTMIMRG.m

AGTMIMRG ; IHS/ASDS/EFG - MERGE INSURERS ; 

 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005

 ;

SEL W !

 S AG("MODE")="SEL"

 S AG("XIT")=0,DIC="^AUTNINS(",DIC(0)="QEAM",DIC("A")="Select INSURER (to Search against): " S DIC("S")="I $D(^(1)),$P(^(1),U,7)'=0,$D(^(2)),""DRN""'[$P(^(2),U)"

 D ^DIC

 I X="" G XIT

 I +Y<1 G SEL

 S AG("X")=+Y,AG("X0")=^AUTNINS(+Y,0)

 D CHK

 G XIT:AG("XIT"),SEL

CHK W !!,"Dup-Check for: ",$P(AG("X0"),U),!?15,$P(AG("X0"),U,2)

 I $P(AG("X0"),U,3)]"",$P(AG("X0"),U,4)]"" W !?15,$P(AG("X0"),U,3),", "

 I  W $P(^DIC(5,$P(AG("X0"),U,4),0),U,2)," ",$P(AG("X0"),U,5)

 W !,"================================================"

 S DIC="^AUTNINS(",DIC(0)="QEAM",DIC("S")="I Y'=AG(""X""),$D(^(1)),$P(^(1),U,7)'=0,$D(^(2)),""DNR""'[$P(^(2),U)",DIC("A")="Select (SEARCH) for Duplicate INSURER: " D ^DIC

 I +Y<1 G CONT

 S AG("Y")=+Y,AG("Y0")=^AUTNINS(+Y,0)

 W !,"_______________________________________________________________________________"

 W !,"[1]  ",$P(AG("X0"),U),?39,"| [2]  ",$P(AG("Y0"),U)

 W !,"     ",$P(AG("X0"),U,2),?39,"|      ",$P(AG("Y0"),U,2)

 W ! I $P(AG("X0"),U,3)]"",$P(AG("X0"),U,4)]"" W "     ",$P(AG("X0"),U,3),", "

 I  W $P(^DIC(5,$P(AG("X0"),U,4),0),U,2)," ",$P(AG("X0"),U,5)

 W ?39,"|      " I $P(AG("Y0"),U,3)]"",$P(AG("Y0"),U,4)]"" W $P(AG("Y0"),U,3),", ",$P(^DIC(5,$P(AG("Y0"),U,4),0),U,2)," ",$P(AG("Y0"),U,5)

 W !,"-------------------------------------------------------------------------------"

 W ! K DIR S DIR(0)="Y",DIR("A")="     Are the two Insurers duplicates (Y/N)" D ^DIR K DIR I Y'=1 G CONT

 W ! K DIR S DIR(0)="SO^1:"_$P(AG("X0"),U)_";2:"_$P(AG("Y0"),U),DIR("A")="     Which of the two is most accurate" D ^DIR K DIR

 I Y=1!(Y=2) G MOVE

CONT W !! K DIR S DIR(0)="Y",DIR("A")="Do you want to dup-check "_$P(AG("X0"),U)_" any more",DIR("B")="Y" D ^DIR K DIR I Y=1 S AG("XIT")=0 Q

VERF W !! K DIR S DIR(0)="Y",DIR("A")="Do you wish to continue running this program",DIR("B")="Y" D ^DIR K DIR I Y'=1 S AG("XIT")=1

 Q

MOVE K AG("ADD")

 I Y=1 S AG=AG("X"),AG("X")=AG("Y"),AG("Y")=AG

 W !,"OK, MERGING.." D PTR G VERF ;X TO Y

 I $D(^AUTNINS(AG("X"),1)),$P(^(1),U)]"",$P(^(1),U,2)]"",$P(^(1),U,3)]"",$P(^(1),U,4)]"",$P(^(1),U,5)]"" G MV1

 I $P(^AUTNINS(AG("X"),0),U,2)]"",$P(^(0),U,3)]"",$P(^(0),U,4)]"",$P(^(0),U,5)]"" F AG("I")=1:1:5 S AG("ADD",AG("I"))=$P(^(0),U,AG("I"))

MV1 S %X="^AUTNINS("_AG("X")_","

 S %Y="^AUTNINS("_AG("Y")_"," D %XY^%RCR

 I $D(AG("ADD")) F AG("I")=1:1:5 Q:'$D(AG("ADD",AG("I")))  S $P(^AUTNINS(AG("Y"),1),U,AG("I"))=AG("ADD",AG("I"))

 S DA=AG("X"),DIK="^AUTNINS(" D IX1^DIK

PTR S DIE="^AUTNINS(",DA=AG("X"),DR=".17////0;.27////"_AG("Y")_";.41////MERGED TO IEN: "_AG("Y") D ^DIE K DR

 W !!,"Re-directing Pointers..."

 S DA(1)="" F AGZ("I")=1:1 S DA(1)=$O(^AUPNPRVT("I",AG("X"),DA(1))) Q:'+DA(1)  D

 .S DA="" F AGZ("I")=1:1 S DA=$O(^AUPNPRVT("I",AG("X"),DA(1),DA)) Q:'+DA  S DIE="^AUPNPRVT("_DA(1)_",11,",DR=".01///"_AG("Y") D ^DIE K DR

 S DA="" F AGZ("I")=1:1 S DA=$O(^AUPN3PPH("E",AG("X"),DA)) Q:'+DA  S DIE="^AUPN3PPH(",DR=".03////"_AG("Y") D ^DIE K DR

 S DA="" F  S DA=$O(^ABMDBILL("AJ",AG("X"),DA)) Q:'DA  S DIE="^ABMDBILL(",DR=".08////"_AG("Y") D ^DIE K DR

 S DA="" F  S DA=$O(^AUTNEMPL("AI",AG("X"),DA)) Q:'DA  S DIE="^AUTNEMPL(",DR=".08////"_AG("Y") D ^DIE K DR

 S DA="" F AGZ("I")=1:1 S DA=$O(^AUTTPIC("C",AG("X"),DA)) Q:'+DA  S DIE="^AUTTPIC(",DR=".02////"_AG("Y") D ^DIE K DR

 S DA="" F AGZ("I")=1:1 S DA=$O(^ABPVFAC("I",AG("X"),DA)) Q:'+DA  S DIE="^ABPVFAC(",DR="7////"_AG("Y") D ^DIE K DR

 S DA(1)="" F AGZ("I")=1:1 S DA(1)=$O(^ABMDERR("AB",AG("X"),DA(1))) Q:'+DA(1)  D

 .S (DIC,DIK)="^ABMDERR("_DA(1)_",11,",DA=AG("X") D ^DIK

 .S (DINUM,X)=AG("Y"),DIC(0)="L" K DD,D0 D FILE^DICN

 Q

XIT K AG

 Q

AGTMIMRG  ; IHS/ASDS/EFG - MERGE INSURERS ; 

 +1       ;;7.1;PATIENT REGISTRATION;;AUG 25,2005

 +2       ;

SEL        WRITE !

 +1        SET AG("MODE")="SEL"

 +2        SET AG("XIT")=0

           SET DIC="^AUTNINS("

           SET DIC(0)="QEAM"

           SET DIC("A")="Select INSURER (to Search against): "

           SET DIC("S")="I $D(^(1)),$P(^(1),U,7)'=0,$D(^(2)),""DRN""'[$P(^(2),U)"

 +3        DO ^DIC

 +4        IF X=""

               GOTO XIT

 +5        IF +Y<1

               GOTO SEL

 +6        SET AG("X")=+Y

           SET AG("X0")=^AUTNINS(+Y,0)

 +7        DO CHK

 +8        IF AG("XIT")

               GOTO XIT

           GOTO SEL

CHK        WRITE !!,"Dup-Check for: ",$PIECE(AG("X0"),U),!?15,$PIECE(AG("X0"),U,2)

 +1        IF $PIECE(AG("X0"),U,3)]""

               IF $PIECE(AG("X0"),U,4)]""

                   WRITE !?15,$PIECE(AG("X0"),U,3),", "

 +2       IF $TEST

               WRITE $PIECE(^DIC(5,$PIECE(AG("X0"),U,4),0),U,2)," ",$PIECE(AG("X0"),U,5)

 +3        WRITE !,"================================================"

 +4        SET DIC="^AUTNINS("

           SET DIC(0)="QEAM"

           SET DIC("S")="I Y'=AG(""X""),$D(^(1)),$P(^(1),U,7)'=0,$D(^(2)),""DNR""'[$P(^(2),U)"

           SET DIC("A")="Select (SEARCH) for Duplicate INSURER: "

           DO ^DIC

 +5        IF +Y<1

               GOTO CONT

 +6        SET AG("Y")=+Y

           SET AG("Y0")=^AUTNINS(+Y,0)

 +7        WRITE !,"_______________________________________________________________________________"

 +8        WRITE !,"[1]  ",$PIECE(AG("X0"),U),?39,"| [2]  ",$PIECE(AG("Y0"),U)

 +9        WRITE !,"     ",$PIECE(AG("X0"),U,2),?39,"|      ",$PIECE(AG("Y0"),U,2)

 +10       WRITE !

           IF $PIECE(AG("X0"),U,3)]""

               IF $PIECE(AG("X0"),U,4)]""

                   WRITE "     ",$PIECE(AG("X0"),U,3),", "

 +11      IF $TEST

               WRITE $PIECE(^DIC(5,$PIECE(AG("X0"),U,4),0),U,2)," ",$PIECE(AG("X0"),U,5)

 +12       WRITE ?39,"|      "

           IF $PIECE(AG("Y0"),U,3)]""

               IF $PIECE(AG("Y0"),U,4)]""

                   WRITE $PIECE(AG("Y0"),U,3),", ",$PIECE(^DIC(5,$PIECE(AG("Y0"),U,4),0),U,2)," ",$PIECE(AG("Y0"),U,5)

 +13       WRITE !,"-------------------------------------------------------------------------------"

 +14       WRITE !

           KILL DIR

           SET DIR(0)="Y"

           SET DIR("A")="     Are the two Insurers duplicates (Y/N)"

           DO ^DIR

           KILL DIR

           IF Y'=1

               GOTO CONT

 +15       WRITE !

           KILL DIR

           SET DIR(0)="SO^1:"_$PIECE(AG("X0"),U)_";2:"_$PIECE(AG("Y0"),U)

           SET DIR("A")="     Which of the two is most accurate"

           DO ^DIR

           KILL DIR

 +16       IF Y=1!(Y=2)

               GOTO MOVE

CONT       WRITE !!

           KILL DIR

           SET DIR(0)="Y"

           SET DIR("A")="Do you want to dup-check "_$PIECE(AG("X0"),U)_" any more"

           SET DIR("B")="Y"

           DO ^DIR

           KILL DIR

           IF Y=1

               SET AG("XIT")=0

               QUIT 

VERF       WRITE !!

           KILL DIR

           SET DIR(0)="Y"

           SET DIR("A")="Do you wish to continue running this program"

           SET DIR("B")="Y"

           DO ^DIR

           KILL DIR

           IF Y'=1

               SET AG("XIT")=1

 +1        QUIT 

MOVE       KILL AG("ADD")

 +1        IF Y=1

               SET AG=AG("X")

               SET AG("X")=AG("Y")

               SET AG("Y")=AG

 +2       ;X TO Y

           WRITE !,"OK, MERGING.."

           DO PTR

           GOTO VERF

 +3        IF $DATA(^AUTNINS(AG("X"),1))

               IF $PIECE(^(1),U)]""

                   IF $PIECE(^(1),U,2)]""

                       IF $PIECE(^(1),U,3)]""

                           IF $PIECE(^(1),U,4)]""

                               IF $PIECE(^(1),U,5)]""

                                   GOTO MV1

 +4        IF $PIECE(^AUTNINS(AG("X"),0),U,2)]""

               IF $PIECE(^(0),U,3)]""

                   IF $PIECE(^(0),U,4)]""

                       IF $PIECE(^(0),U,5)]""

                           FOR AG("I")=1:1:5

                               SET AG("ADD",AG("I"))=$PIECE(^(0),U,AG("I"))

MV1        SET %X="^AUTNINS("_AG("X")_","

 +1        SET %Y="^AUTNINS("_AG("Y")_","

           DO %XY^%RCR

 +2        IF $DATA(AG("ADD"))

               FOR AG("I")=1:1:5

                   IF '$DATA(AG("ADD",AG("I")))

                       QUIT 

                   SET $PIECE(^AUTNINS(AG("Y"),1),U,AG("I"))=AG("ADD",AG("I"))

 +3        SET DA=AG("X")

           SET DIK="^AUTNINS("

           DO IX1^DIK

PTR        SET DIE="^AUTNINS("

           SET DA=AG("X")

           SET DR=".17////0;.27////"_AG("Y")_";.41////MERGED TO IEN: "_AG("Y")

           DO ^DIE

           KILL DR

 +1        WRITE !!,"Re-directing Pointers..."

 +2        SET DA(1)=""

           FOR AGZ("I")=1:1

               SET DA(1)=$ORDER(^AUPNPRVT("I",AG("X"),DA(1)))

               IF '+DA(1)

                   QUIT 

               Begin DoDot:1

 +3                SET DA=""

                   FOR AGZ("I")=1:1

                       SET DA=$ORDER(^AUPNPRVT("I",AG("X"),DA(1),DA))

                       IF '+DA

                           QUIT 

                       SET DIE="^AUPNPRVT("_DA(1)_",11,"

                       SET DR=".01///"_AG("Y")

                       DO ^DIE

                       KILL DR

               End DoDot:1

 +4        SET DA=""

           FOR AGZ("I")=1:1

               SET DA=$ORDER(^AUPN3PPH("E",AG("X"),DA))

               IF '+DA

                   QUIT 

               SET DIE="^AUPN3PPH("

               SET DR=".03////"_AG("Y")

               DO ^DIE

               KILL DR

 +5        SET DA=""

           FOR 

               SET DA=$ORDER(^ABMDBILL("AJ",AG("X"),DA))

               IF 'DA

                   QUIT 

               SET DIE="^ABMDBILL("

               SET DR=".08////"_AG("Y")

               DO ^DIE

               KILL DR

 +6        SET DA=""

           FOR 

               SET DA=$ORDER(^AUTNEMPL("AI",AG("X"),DA))

               IF 'DA

                   QUIT 

               SET DIE="^AUTNEMPL("

               SET DR=".08////"_AG("Y")

               DO ^DIE

               KILL DR

 +7        SET DA=""

           FOR AGZ("I")=1:1

               SET DA=$ORDER(^AUTTPIC("C",AG("X"),DA))

               IF '+DA

                   QUIT 

               SET DIE="^AUTTPIC("

               SET DR=".02////"_AG("Y")

               DO ^DIE

               KILL DR

 +8        SET DA=""

           FOR AGZ("I")=1:1

               SET DA=$ORDER(^ABPVFAC("I",AG("X"),DA))

               IF '+DA

                   QUIT 

               SET DIE="^ABPVFAC("

               SET DR="7////"_AG("Y")

               DO ^DIE

               KILL DR

 +9        SET DA(1)=""

           FOR AGZ("I")=1:1

               SET DA(1)=$ORDER(^ABMDERR("AB",AG("X"),DA(1)))

               IF '+DA(1)

                   QUIT 

               Begin DoDot:1

 +10               SET (DIC,DIK)="^ABMDERR("_DA(1)_",11,"

                   SET DA=AG("X")

                   DO ^DIK

 +11               SET (DINUM,X)=AG("Y")

                   SET DIC(0)="L"

                   KILL DD,D0

                   DO FILE^DICN

               End DoDot:1

 +12       QUIT 

XIT        KILL AG

 +1        QUIT