ABMDTEMR ; IHS/ASDST/DMJ - MERGE EMPLOYER DATA ;
;;2.6;IHS 3P BILLING SYSTEM;**21**;NOV 12, 2009;Build 379
;IHS/SD/SDR - 2.6*21 - HEAT184392 - Correction to Policy Holder repoint to use ^AUPN3PPH instead of ^AUPNPAT
;
S U="^"
SEL W !
K DUOUT,DTOUT
K DIC S ABM("MODE")="SEL"
S ABM("XIT")=0,DIC="^AUTNEMPL(",DIC(0)="QEAM",DIC("A")="Select EMPLOYER (to Search against): " D ^DIC K DIC
G XIT:X=""!$D(DUOUT)!$D(DTOUT)
I +Y<1 G SEL
I '$D(^AUTNEMPL(+Y,0)) W *7 K ^AUTNEMPL("B",$P(Y,U,2),+Y) G SEL
S ABM("X")=+Y,ABM("X0")=^AUTNEMPL(+Y,0)
D CHK
G XIT:ABM("XIT"),SEL
;
CHK W !!,"Dup-Check for: ",$P(ABM("X0"),U),!?15,$P(ABM("X0"),U,2)
I $P(ABM("X0"),U,3)]"",$P(ABM("X0"),U,4)]"" W !?15,$P(ABM("X0"),U,3),", "
I W $P(^DIC(5,$P(ABM("X0"),U,4),0),U,2)," ",$P(ABM("X0"),U,5)
W !,"================================================"
S DIC="^AUTNEMPL(",DIC(0)="QEAM",DIC("S")="I Y'=ABM(""X"")",DIC("A")="Select (SEARCH) for Duplicate EMPLOYER: " D ^DIC K DIC
Q:$D(DUOUT)!$D(DTOUT)
I +Y<1 G CONT
S ABM("Y")=+Y,ABM("Y0")=^AUTNEMPL(+Y,0)
W !,"_______________________________________________________________________________"
W !,"[1] ",$P(ABM("X0"),U),?39,"| [2] ",$P(ABM("Y0"),U)
W !," ",$P(ABM("X0"),U,2),?39,"| ",$P(ABM("Y0"),U,2)
W ! I $P(ABM("X0"),U,3)]"",$P(ABM("X0"),U,4)]"" W " ",$P(ABM("X0"),U,3),", "
I W $P(^DIC(5,$P(ABM("X0"),U,4),0),U,2)," ",$P(ABM("X0"),U,5)
W ?39,"| " I $P(ABM("Y0"),U,3)]"",$P(ABM("Y0"),U,4)]"" W $P(ABM("Y0"),U,3),", ",$P(^DIC(5,$P(ABM("Y0"),U,4),0),U,2)," ",$P(ABM("Y0"),U,5)
W !,"-------------------------------------------------------------------------------"
K DUOUT,DTOUT
W ! K DIR S DIR(0)="Y",DIR("A")=" Are the two Employers duplicates (Y/N)" D ^DIR K DIR
I $D(DUOUT) G VERF
I $D(DTOUT) S ABM("XIT")=1 Q
I Y'=1 G CONT
W ! K DIR S DIR(0)="SO^1:"_$P(ABM("X0"),U)_";2:"_$P(ABM("Y0"),U),DIR("A")=" Which of the two is most accurate" D ^DIR K DIR
I $D(DUOUT) G VERF
I $D(DTOUT) S ABM("XIT")=1 Q
I Y=1!(Y=2) G MOVE
;
CONT W !! K DIR S DIR(0)="Y",DIR("A")="Do you want to dup-check "_$P(ABM("X0"),U)_" any more",DIR("B")="Y" D ^DIR K DIR I Y=1 G CHK
;
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 ABM("XIT")=1
Q
;
;
MOVE W !,"OK, MERGING.." ; X TO Y
I Y=1 S ABM=ABM("X"),ABM("X")=ABM("Y"),ABM("Y")=ABM
D MV2 G VERF
;
MV1 ;merge
M ^AUTNEMPL(ABM("Y"))=^AUTNEMPL(ABM("X"))
S DA=ABM("Y"),DIK="^AUTNEMPL(" D IX1^DIK
MV2 S DIK="^AUTNEMPL(",DA=ABM("X") D ^DIK
W !!,"Re-directing Pointers..."
S DA="" F ABMZ("I")=1:1 S DA=$O(^AUPNPAT("AF",ABM("X"),DA)) Q:'DA S DIE="^AUPNPAT(",DR=".19////"_ABM("Y") D ^ABMDDIE K DR
S DA="" F ABMZ("I")=1:1 S DA=$O(^AUPNPAT("AG",ABM("X"),DA)) Q:'DA S DIE="^AUPNPAT(",DR=".22////"_ABM("Y") D ^ABMDDIE K DR
;S DA="" F ABMZ("I")=1:1 S DA=$O(^AUPN3PPH("AE",ABM("X"),DA)) Q:'DA S DIE="^AUPNPAT(",DR=".16////"_ABM("Y") D ^ABMDDIE K DR ;abm*2.6*21 IHS/SD/SDR HEAT184392
S DA="" F ABMZ("I")=1:1 S DA=$O(^AUPN3PPH("AE",ABM("X"),DA)) Q:'DA S DIE="^AUPN3PPH(",DR=".16////"_ABM("Y") D ^ABMDDIE K DR ;abm*2.6*21 IHS/SD/SDR HEAT184392
Q
;
XIT K ABM
Q
ABMDTEMR ; IHS/ASDST/DMJ - MERGE EMPLOYER DATA ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**21**;NOV 12, 2009;Build 379
+2 ;IHS/SD/SDR - 2.6*21 - HEAT184392 - Correction to Policy Holder repoint to use ^AUPN3PPH instead of ^AUPNPAT
+3 ;
+4 SET U="^"
SEL WRITE !
+1 KILL DUOUT,DTOUT
+2 KILL DIC
SET ABM("MODE")="SEL"
+3 SET ABM("XIT")=0
SET DIC="^AUTNEMPL("
SET DIC(0)="QEAM"
SET DIC("A")="Select EMPLOYER (to Search against): "
DO ^DIC
KILL DIC
+4 IF X=""!$DATA(DUOUT)!$DATA(DTOUT)
GOTO XIT
+5 IF +Y<1
GOTO SEL
+6 IF '$DATA(^AUTNEMPL(+Y,0))
WRITE *7
KILL ^AUTNEMPL("B",$PIECE(Y,U,2),+Y)
GOTO SEL
+7 SET ABM("X")=+Y
SET ABM("X0")=^AUTNEMPL(+Y,0)
+8 DO CHK
+9 IF ABM("XIT")
GOTO XIT
GOTO SEL
+10 ;
CHK WRITE !!,"Dup-Check for: ",$PIECE(ABM("X0"),U),!?15,$PIECE(ABM("X0"),U,2)
+1 IF $PIECE(ABM("X0"),U,3)]""
IF $PIECE(ABM("X0"),U,4)]""
WRITE !?15,$PIECE(ABM("X0"),U,3),", "
+2 IF $TEST
WRITE $PIECE(^DIC(5,$PIECE(ABM("X0"),U,4),0),U,2)," ",$PIECE(ABM("X0"),U,5)
+3 WRITE !,"================================================"
+4 SET DIC="^AUTNEMPL("
SET DIC(0)="QEAM"
SET DIC("S")="I Y'=ABM(""X"")"
SET DIC("A")="Select (SEARCH) for Duplicate EMPLOYER: "
DO ^DIC
KILL DIC
+5 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+6 IF +Y<1
GOTO CONT
+7 SET ABM("Y")=+Y
SET ABM("Y0")=^AUTNEMPL(+Y,0)
+8 WRITE !,"_______________________________________________________________________________"
+9 WRITE !,"[1] ",$PIECE(ABM("X0"),U),?39,"| [2] ",$PIECE(ABM("Y0"),U)
+10 WRITE !," ",$PIECE(ABM("X0"),U,2),?39,"| ",$PIECE(ABM("Y0"),U,2)
+11 WRITE !
IF $PIECE(ABM("X0"),U,3)]""
IF $PIECE(ABM("X0"),U,4)]""
WRITE " ",$PIECE(ABM("X0"),U,3),", "
+12 IF $TEST
WRITE $PIECE(^DIC(5,$PIECE(ABM("X0"),U,4),0),U,2)," ",$PIECE(ABM("X0"),U,5)
+13 WRITE ?39,"| "
IF $PIECE(ABM("Y0"),U,3)]""
IF $PIECE(ABM("Y0"),U,4)]""
WRITE $PIECE(ABM("Y0"),U,3),", ",$PIECE(^DIC(5,$PIECE(ABM("Y0"),U,4),0),U,2)," ",$PIECE(ABM("Y0"),U,5)
+14 WRITE !,"-------------------------------------------------------------------------------"
+15 KILL DUOUT,DTOUT
+16 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("A")=" Are the two Employers duplicates (Y/N)"
DO ^DIR
KILL DIR
+17 IF $DATA(DUOUT)
GOTO VERF
+18 IF $DATA(DTOUT)
SET ABM("XIT")=1
QUIT
+19 IF Y'=1
GOTO CONT
+20 WRITE !
KILL DIR
SET DIR(0)="SO^1:"_$PIECE(ABM("X0"),U)_";2:"_$PIECE(ABM("Y0"),U)
SET DIR("A")=" Which of the two is most accurate"
DO ^DIR
KILL DIR
+21 IF $DATA(DUOUT)
GOTO VERF
+22 IF $DATA(DTOUT)
SET ABM("XIT")=1
QUIT
+23 IF Y=1!(Y=2)
GOTO MOVE
+24 ;
CONT WRITE !!
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you want to dup-check "_$PIECE(ABM("X0"),U)_" any more"
SET DIR("B")="Y"
DO ^DIR
KILL DIR
IF Y=1
GOTO CHK
+1 ;
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 ABM("XIT")=1
+1 QUIT
+2 ;
+3 ;
MOVE ; X TO Y
WRITE !,"OK, MERGING.."
+1 IF Y=1
SET ABM=ABM("X")
SET ABM("X")=ABM("Y")
SET ABM("Y")=ABM
+2 DO MV2
GOTO VERF
+3 ;
MV1 ;merge
+1 MERGE ^AUTNEMPL(ABM("Y"))=^AUTNEMPL(ABM("X"))
+2 SET DA=ABM("Y")
SET DIK="^AUTNEMPL("
DO IX1^DIK
MV2 SET DIK="^AUTNEMPL("
SET DA=ABM("X")
DO ^DIK
+1 WRITE !!,"Re-directing Pointers..."
+2 SET DA=""
FOR ABMZ("I")=1:1
SET DA=$ORDER(^AUPNPAT("AF",ABM("X"),DA))
IF 'DA
QUIT
SET DIE="^AUPNPAT("
SET DR=".19////"_ABM("Y")
DO ^ABMDDIE
KILL DR
+3 SET DA=""
FOR ABMZ("I")=1:1
SET DA=$ORDER(^AUPNPAT("AG",ABM("X"),DA))
IF 'DA
QUIT
SET DIE="^AUPNPAT("
SET DR=".22////"_ABM("Y")
DO ^ABMDDIE
KILL DR
+4 ;S DA="" F ABMZ("I")=1:1 S DA=$O(^AUPN3PPH("AE",ABM("X"),DA)) Q:'DA S DIE="^AUPNPAT(",DR=".16////"_ABM("Y") D ^ABMDDIE K DR ;abm*2.6*21 IHS/SD/SDR HEAT184392
+5 ;abm*2.6*21 IHS/SD/SDR HEAT184392
SET DA=""
FOR ABMZ("I")=1:1
SET DA=$ORDER(^AUPN3PPH("AE",ABM("X"),DA))
IF 'DA
QUIT
SET DIE="^AUPN3PPH("
SET DR=".16////"_ABM("Y")
DO ^ABMDDIE
KILL DR
+6 QUIT
+7 ;
XIT KILL ABM
+1 QUIT
