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
