AGUPCHK ; IHS/ASDS/EFG - Merge Insurer Data ;
;;7.1;PATIENT REGISTRATION;**12**;AUG 25,2005;Build 1
;IHS/OIT/NKD AG*7.1*12 INSURER TYPE
;
S U="^"
D HD
W !!,"This routine will loop the old or unverified Insurers allowing you to check",!,"for a potential duplicate."
W !!," - If you indicate that an insurer is duplicate that the data for the ",!," duplicate insurer will be merged into the old insurer (previous address",!," information will be transfered to the billing address fields)."
W !! K DIR S DIR(0)="Y",DIR("A")="Do you wish to run this program",DIR("B")="Y" D ^DIR K DIR I Y'=1 G XIT
S AG("MODE")="AUTO"
TEMP S (AG("Y"),AG("XIT"))=0 F AGZ("I")=1:1 S AG("Y")=$O(^AUTNINS(AG("Y"))) Q:'+AG("Y") I $P($G(^AUTNINS(AG("Y"),1)),U,7)=""!($P($G(^(1)),U,7)=3) S AG("X0")=^(0) D CHK Q:AG("XIT")
G XIT
SEL D HD 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 $P($G(^(1)),U,7)'=0,""DR""'[$P($G(^(2)),U)"
S AG("XIT")=0,DIC="^AUTNINS(",DIC(0)="QEAM",DIC("A")="Select INSURER (to Search against): " S DIC("S")="I $P($G(^(1)),U,7)'=0,""DR""'[$$INSTYP^AGUTL(Y)" ;IHS/OIT/NKD AG*7.1*12
D ^DIC
I X="" G XIT
I +Y<1 G SEL
S AG("Y")=+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(""Y""),$P($G(^(1)),U,7)'=0,""DR""'[$P($G(^(2)),U)",DIC("A")="Select (SEARCH) for Duplicate INSURER: " D ^DIC
S DIC="^AUTNINS(",DIC(0)="QEAM",DIC("S")="I Y'=AG(""Y""),$P($G(^(1)),U,7)'=0,""DR""'[$$INSTYP^AGUTL(Y)",DIC("A")="Select (SEARCH) for Duplicate INSURER: " D ^DIC ;IHS/OIT/NKD AG*7.1*12
I +Y<1 G CONT
S AG=+Y,AG("Y0")=^AUTNINS(+Y,0)
W !,"_______________________________________________________________________________"
W !,"[1] ",$P(AG("X0"),U),?39,"| [2] ",$P(Y,U,2)
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(^(0),U,4)]"" W $P(^(0),U,3),", ",$P(^DIC(5,$P(^(0),U,4),0),U,2)," ",$P(^AUTNINS(+Y,0),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 !,"OK, MERGING.."
D MOVE G VERF
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 G CHK
VERF S DIE="^AUTNINS(",DA=AG("Y"),DR=".17//1;.41//"_$P(AG("Y0"),U) D ^DIE
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 $D(^AUTNINS(AG("Y"),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("Y"),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 AG("B")="^AUTNINS("_AG("Y")_","
S AG("A")="^AUTNINS("_AG,AG("A1")=AG("A")_")"
F AGZ("I")=1:1 S AG("A1")=$Q(@AG("A1")) Q:AG("A1")'[AG("A") S AG("Z")=AG("B")_$P($P(AG("A1"),"(",2),",",2,99) D
.S AG("C")=$P($P(AG("A1"),"(",2),",",2,99)
.S @AG("Z")=@AG("A1")
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("Y"),DIK="^AUTNINS(" D IX1^DIK
S DIK="^AUTNINS(",DA=AG D ^DIK
W !!,"Re-directing Pointers..."
S DA(1)="" F AGZ("I")=1:1 S DA(1)=$O(^AUPNPRVT("I",AG,DA(1))) Q:'+DA(1) D
.S DA="" F AGZ("I")=1:1 S DA=$O(^AUPNPRVT("I",AG,DA(1),DA)) Q:'+DA S DIE="^AUPNPRVT("_DA(1)_",11,",DR=".01///"_AG("Y") D ^DIE
S DA="" F AGZ("I")=1:1 S DA=$O(^AUPN3PPH("E",AG,DA)) Q:'+DA S DIE="^AUPN3PPH(",DR=".03////"_AG("Y") D ^DIE
S DA="" F AGZ("I")=1:1 S DA=$O(^AUTTPIC("C",AG,DA)) Q:'+DA S DIE="^AUTTPIC(",DR=".02////"_AG("Y") D ^DIE
Q
HD W $$S^AGVDF("IOF")
W !?15,"*******************************************"
W !?15,"* INSURER DUPLICATE CHECKER *"
W !?15,"*******************************************"
Q
XIT K AG
Q
AGUPCHK ; IHS/ASDS/EFG - Merge Insurer Data ;
+1 ;;7.1;PATIENT REGISTRATION;**12**;AUG 25,2005;Build 1
+2 ;IHS/OIT/NKD AG*7.1*12 INSURER TYPE
+3 ;
+4 SET U="^"
+5 DO HD
+6 WRITE !!,"This routine will loop the old or unverified Insurers allowing you to check",!,"for a potential duplicate."
+7 WRITE !!," - If you indicate that an insurer is duplicate that the data for the ",!," duplicate insurer will be merged into the old insurer (previous address",!," information will be transfered to the billing address fields)."
+8 WRITE !!
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you wish to run this program"
SET DIR("B")="Y"
DO ^DIR
KILL DIR
IF Y'=1
GOTO XIT
+9 SET AG("MODE")="AUTO"
TEMP SET (AG("Y"),AG("XIT"))=0
FOR AGZ("I")=1:1
SET AG("Y")=$ORDER(^AUTNINS(AG("Y")))
IF '+AG("Y")
QUIT
IF $PIECE($GET(^AUTNINS(AG("Y"),1)),U,7)=""!($PIECE($GET(^(1)),U,7)=3)
SET AG("X0")=^(0)
DO CHK
IF AG("XIT")
QUIT
+1 GOTO XIT
SEL DO HD
WRITE !
+1 SET AG("MODE")="SEL"
+2 ;S AG("XIT")=0,DIC="^AUTNINS(",DIC(0)="QEAM",DIC("A")="Select INSURER (to Search against): " S DIC("S")="I $P($G(^(1)),U,7)'=0,""DR""'[$P($G(^(2)),U)"
+3 ;IHS/OIT/NKD AG*7.1*12
SET AG("XIT")=0
SET DIC="^AUTNINS("
SET DIC(0)="QEAM"
SET DIC("A")="Select INSURER (to Search against): "
SET DIC("S")="I $P($G(^(1)),U,7)'=0,""DR""'[$$INSTYP^AGUTL(Y)"
+4 DO ^DIC
+5 IF X=""
GOTO XIT
+6 IF +Y<1
GOTO SEL
+7 SET AG("Y")=+Y
SET AG("X0")=^AUTNINS(+Y,0)
+8 DO CHK
+9 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 ;S DIC="^AUTNINS(",DIC(0)="QEAM",DIC("S")="I Y'=AG(""Y""),$P($G(^(1)),U,7)'=0,""DR""'[$P($G(^(2)),U)",DIC("A")="Select (SEARCH) for Duplicate INSURER: " D ^DIC
+5 ;IHS/OIT/NKD AG*7.1*12
SET DIC="^AUTNINS("
SET DIC(0)="QEAM"
SET DIC("S")="I Y'=AG(""Y""),$P($G(^(1)),U,7)'=0,""DR""'[$$INSTYP^AGUTL(Y)"
SET DIC("A")="Select (SEARCH) for Duplicate INSURER: "
DO ^DIC
+6 IF +Y<1
GOTO CONT
+7 SET AG=+Y
SET AG("Y0")=^AUTNINS(+Y,0)
+8 WRITE !,"_______________________________________________________________________________"
+9 WRITE !,"[1] ",$PIECE(AG("X0"),U),?39,"| [2] ",$PIECE(Y,U,2)
+10 WRITE !," ",$PIECE(AG("X0"),U,2),?39,"| ",$PIECE(AG("Y0"),U,2)
+11 WRITE !
IF $PIECE(AG("X0"),U,3)]""
IF $PIECE(AG("X0"),U,4)]""
WRITE " ",$PIECE(AG("X0"),U,3),", "
+12 IF $TEST
WRITE $PIECE(^DIC(5,$PIECE(AG("X0"),U,4),0),U,2)," ",$PIECE(AG("X0"),U,5)
+13 WRITE ?39,"| "
IF $PIECE(AG("Y0"),U,3)]""
IF $PIECE(^(0),U,4)]""
WRITE $PIECE(^(0),U,3),", ",$PIECE(^DIC(5,$PIECE(^(0),U,4),0),U,2)," ",$PIECE(^AUTNINS(+Y,0),U,5)
+14 WRITE !,"-------------------------------------------------------------------------------"
+15 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
+16 WRITE !,"OK, MERGING.."
+17 DO MOVE
GOTO VERF
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
GOTO CHK
VERF SET DIE="^AUTNINS("
SET DA=AG("Y")
SET DR=".17//1;.41//"_$PIECE(AG("Y0"),U)
DO ^DIE
+1 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
+2 QUIT
MOVE KILL AG("ADD")
+1 IF $DATA(^AUTNINS(AG("Y"),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
+2 IF $PIECE(^AUTNINS(AG("Y"),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 AG("B")="^AUTNINS("_AG("Y")_","
+1 SET AG("A")="^AUTNINS("_AG
SET AG("A1")=AG("A")_")"
+2 FOR AGZ("I")=1:1
SET AG("A1")=$QUERY(@AG("A1"))
IF AG("A1")'[AG("A")
QUIT
SET AG("Z")=AG("B")_$PIECE($PIECE(AG("A1"),"(",2),",",2,99)
Begin DoDot:1
+3 SET AG("C")=$PIECE($PIECE(AG("A1"),"(",2),",",2,99)
+4 SET @AG("Z")=@AG("A1")
End DoDot:1
+5 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"))
+6 SET DA=AG("Y")
SET DIK="^AUTNINS("
DO IX1^DIK
+7 SET DIK="^AUTNINS("
SET DA=AG
DO ^DIK
+8 WRITE !!,"Re-directing Pointers..."
+9 SET DA(1)=""
FOR AGZ("I")=1:1
SET DA(1)=$ORDER(^AUPNPRVT("I",AG,DA(1)))
IF '+DA(1)
QUIT
Begin DoDot:1
+10 SET DA=""
FOR AGZ("I")=1:1
SET DA=$ORDER(^AUPNPRVT("I",AG,DA(1),DA))
IF '+DA
QUIT
SET DIE="^AUPNPRVT("_DA(1)_",11,"
SET DR=".01///"_AG("Y")
DO ^DIE
End DoDot:1
+11 SET DA=""
FOR AGZ("I")=1:1
SET DA=$ORDER(^AUPN3PPH("E",AG,DA))
IF '+DA
QUIT
SET DIE="^AUPN3PPH("
SET DR=".03////"_AG("Y")
DO ^DIE
+12 SET DA=""
FOR AGZ("I")=1:1
SET DA=$ORDER(^AUTTPIC("C",AG,DA))
IF '+DA
QUIT
SET DIE="^AUTTPIC("
SET DR=".02////"_AG("Y")
DO ^DIE
+13 QUIT
HD WRITE $$S^AGVDF("IOF")
+1 WRITE !?15,"*******************************************"
+2 WRITE !?15,"* INSURER DUPLICATE CHECKER *"
+3 WRITE !?15,"*******************************************"
+4 QUIT
XIT KILL AG
+1 QUIT
