AGTMPMRG ; IHS/ASDS/EFG - MERGE POLICY HOLDERS ;
;;7.1;PATIENT REGISTRATION;;AUG 25,2005
;
S U="^"
SEL W !
K DTOUT,DUOUT
K DIC S AG("MODE")="SEL"
S AG("XIT")=0,DIC="^AUPN3PPH(",DIC(0)="QEA",DIC("A")="Select POLICY HOLDER (to Search against): ",D="B^C^D" D MIX^DIC1 K DIC
G XIT:X=""!$D(DTOUT)!$D(DUOUT)
I +Y<1 G SEL
I '$D(^AUPN3PPH(+Y,0)) W *7 K ^AUPN3PPH("B",$P(Y,U,2),+Y) G SEL
S AG("X")=+Y,AG("X0")=^AUPN3PPH(+Y,0)
D CHK
G XIT:AG("XIT"),SEL
CHK W !!,"Dup-Check for: ",$P(AG("X0"),U),!?15
S AG("PDFN")=$P(AG("X0"),U,2) D HRN
W !?15,$P($G(^AUTNINS($P(AG("X0"),U,3),0)),U)
W !,"================================================"
S DIC="^AUPN3PPH(",DIC(0)="QEAM",DIC("S")="I Y'=AG(""X""),$P(^(0),U,3)=$P(AG(""X0""),U,3)",DIC("A")="Select (SEARCH) for Duplicate POLICY HOLDER: " D ^DIC K DIC
I $D(DTOUT)!$D(DUOUT) S AG("XIT")=1 Q
I +Y<1 W *7,!,"No other Policy Holders having the same insurer found.",! G CONT
S AG("Y")=+Y,AG("Y0")=^AUPN3PPH(+Y,0)
DISP W !,"_______________________________________________________________________________"
W !,"[1] ",$P(AG("X0"),U),?39,"| [2] ",$P(AG("Y0"),U)
W !," " S AG("PDFN")=$P(AG("X0"),U,2) D HRN
W ?39,"| " S AG("PDFN")=$P(AG("Y0"),U,2) D HRN
W !,"-------------------------------------------------------------------------------"
W !!,"The CRT Screen will display each of the Policy Holders in turn ",!,"until you enter an ""^"" to end the displays.",!
S DIR(0)="E" D ^DIR
G:($G(DUOUT)!$G(DTOUT)!$G(DIROUT)) CONT
K DTOUT,DUOUT,DROUT,DIROUT
F D Q:($G(DUOUT)!$G(DTOUT)!$G(DIROUT))
.S AGELP("PH")=AG("X"),AGELP("INS")=$P(AG("X0"),U,3) D ^AGELA
.W !!!,"Above Information for [1] ",$P(AG("X0"),U)," ",$P(AG("X0"),U,4),!!
.S DIR(0)="E" D ^DIR
.Q:($G(DUOUT)!$G(DTOUT)!$G(DIROUT))
.S AGELP("PH")=AG("Y"),AGELP("INS")=$P(AG("Y0"),U,3) D ^AGELA
.Q:($G(DUOUT)!$G(DTOUT)!$G(DIROUT))
.W !!!,"Above Information for [2] ",$P(AG("Y0"),U)," ",$P(AG("Y0"),U,4),!!
.S DIR(0)="E" D ^DIR
K AGELP
W ! K DIR S DIR(0)="Y",DIR("A")=" Are the two POLICY HOLDERS duplicates (Y/N)" D ^DIR K DIR I Y'=1 G CONT
W ! K DIR S DIR(0)="SO^1:"_$P(AG("X0"),U)_" "_$P(AG("X0"),U,4)_";2:"_$P(AG("Y0"),U)_" "_$P(AG("Y0"),U,4),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 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 AG("XIT")=1
Q
MOVE ;
I Y=1 S AG=AG("X"),AG("X")=AG("Y"),AG("Y")=AG
D MV2 G VERF
MV1 S %X="^AUPN3PPH("_AG("X")_","
S %Y="^AUPN3PPH("_AG("Y")_","
D %XY^%RCR
S DA=AG("Y"),DIK="^AUPN3PPH(" D IX1^DIK
MV2 S DIK="^AUPN3PPH(",DA=AG("X") D ^DIK
W !!,"Re-directing Pointers..."
S DA(1)=0 F S DA(1)=$O(^AUPNPRVT("C",AG("X"),DA(1))) Q:'DA(1) D
.S DA=0 F S DA=$O(^AUPNPRVT("C",AG("X"),DA(1),DA)) Q:'DA D
..S DIE="^AUPNPRVT("_DA(1)_",11,"
..I $D(^AUPNPRVT("C",AG("Y"),DA(1))) S DIK=DIE D ^DIK Q
..S DR=".08////"_AG("Y") D ^DIE K DR
Q
HRN W "(HRN: ",$S('$G(AG("PDFN")):"not Registered",'$G(DUZ(2)):"DUZ(2) undefined",$P($G(^AUPNPAT(AG("PDFN"),41,DUZ(2),0)),U,2):$P(^(0),U,2),1:"no HRN at "_$P(^AUTTLOC(DUZ(2),0),U,2)),")"
Q
XIT K AG
Q
AGTMPMRG ; IHS/ASDS/EFG - MERGE POLICY HOLDERS ;
+1 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
+2 ;
+3 SET U="^"
SEL WRITE !
+1 KILL DTOUT,DUOUT
+2 KILL DIC
SET AG("MODE")="SEL"
+3 SET AG("XIT")=0
SET DIC="^AUPN3PPH("
SET DIC(0)="QEA"
SET DIC("A")="Select POLICY HOLDER (to Search against): "
SET D="B^C^D"
DO MIX^DIC1
KILL DIC
+4 IF X=""!$DATA(DTOUT)!$DATA(DUOUT)
GOTO XIT
+5 IF +Y<1
GOTO SEL
+6 IF '$DATA(^AUPN3PPH(+Y,0))
WRITE *7
KILL ^AUPN3PPH("B",$PIECE(Y,U,2),+Y)
GOTO SEL
+7 SET AG("X")=+Y
SET AG("X0")=^AUPN3PPH(+Y,0)
+8 DO CHK
+9 IF AG("XIT")
GOTO XIT
GOTO SEL
CHK WRITE !!,"Dup-Check for: ",$PIECE(AG("X0"),U),!?15
+1 SET AG("PDFN")=$PIECE(AG("X0"),U,2)
DO HRN
+2 WRITE !?15,$PIECE($GET(^AUTNINS($PIECE(AG("X0"),U,3),0)),U)
+3 WRITE !,"================================================"
+4 SET DIC="^AUPN3PPH("
SET DIC(0)="QEAM"
SET DIC("S")="I Y'=AG(""X""),$P(^(0),U,3)=$P(AG(""X0""),U,3)"
SET DIC("A")="Select (SEARCH) for Duplicate POLICY HOLDER: "
DO ^DIC
KILL DIC
+5 IF $DATA(DTOUT)!$DATA(DUOUT)
SET AG("XIT")=1
QUIT
+6 IF +Y<1
WRITE *7,!,"No other Policy Holders having the same insurer found.",!
GOTO CONT
+7 SET AG("Y")=+Y
SET AG("Y0")=^AUPN3PPH(+Y,0)
DISP WRITE !,"_______________________________________________________________________________"
+1 WRITE !,"[1] ",$PIECE(AG("X0"),U),?39,"| [2] ",$PIECE(AG("Y0"),U)
+2 WRITE !," "
SET AG("PDFN")=$PIECE(AG("X0"),U,2)
DO HRN
+3 WRITE ?39,"| "
SET AG("PDFN")=$PIECE(AG("Y0"),U,2)
DO HRN
+4 WRITE !,"-------------------------------------------------------------------------------"
+5 WRITE !!,"The CRT Screen will display each of the Policy Holders in turn ",!,"until you enter an ""^"" to end the displays.",!
+6 SET DIR(0)="E"
DO ^DIR
+7 IF ($GET(DUOUT)!$GET(DTOUT)!$GET(DIROUT))
GOTO CONT
+8 KILL DTOUT,DUOUT,DROUT,DIROUT
+9 FOR
Begin DoDot:1
+10 SET AGELP("PH")=AG("X")
SET AGELP("INS")=$PIECE(AG("X0"),U,3)
DO ^AGELA
+11 WRITE !!!,"Above Information for [1] ",$PIECE(AG("X0"),U)," ",$PIECE(AG("X0"),U,4),!!
+12 SET DIR(0)="E"
DO ^DIR
+13 IF ($GET(DUOUT)!$GET(DTOUT)!$GET(DIROUT))
QUIT
+14 SET AGELP("PH")=AG("Y")
SET AGELP("INS")=$PIECE(AG("Y0"),U,3)
DO ^AGELA
+15 IF ($GET(DUOUT)!$GET(DTOUT)!$GET(DIROUT))
QUIT
+16 WRITE !!!,"Above Information for [2] ",$PIECE(AG("Y0"),U)," ",$PIECE(AG("Y0"),U,4),!!
+17 SET DIR(0)="E"
DO ^DIR
End DoDot:1
IF ($GET(DUOUT)!$GET(DTOUT)!$GET(DIROUT))
QUIT
+18 KILL AGELP
+19 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("A")=" Are the two POLICY HOLDERS duplicates (Y/N)"
DO ^DIR
KILL DIR
IF Y'=1
GOTO CONT
+20 WRITE !
KILL DIR
SET DIR(0)="SO^1:"_$PIECE(AG("X0"),U)_" "_$PIECE(AG("X0"),U,4)_";2:"_$PIECE(AG("Y0"),U)_" "_$PIECE(AG("Y0"),U,4)
SET DIR("A")=" Which of the two is most accurate"
DO ^DIR
KILL DIR
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
GOTO CHK
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 ;
+1 IF Y=1
SET AG=AG("X")
SET AG("X")=AG("Y")
SET AG("Y")=AG
+2 DO MV2
GOTO VERF
MV1 SET %X="^AUPN3PPH("_AG("X")_","
+1 SET %Y="^AUPN3PPH("_AG("Y")_","
+2 DO %XY^%RCR
+3 SET DA=AG("Y")
SET DIK="^AUPN3PPH("
DO IX1^DIK
MV2 SET DIK="^AUPN3PPH("
SET DA=AG("X")
DO ^DIK
+1 WRITE !!,"Re-directing Pointers..."
+2 SET DA(1)=0
FOR
SET DA(1)=$ORDER(^AUPNPRVT("C",AG("X"),DA(1)))
IF 'DA(1)
QUIT
Begin DoDot:1
+3 SET DA=0
FOR
SET DA=$ORDER(^AUPNPRVT("C",AG("X"),DA(1),DA))
IF 'DA
QUIT
Begin DoDot:2
+4 SET DIE="^AUPNPRVT("_DA(1)_",11,"
+5 IF $DATA(^AUPNPRVT("C",AG("Y"),DA(1)))
SET DIK=DIE
DO ^DIK
QUIT
+6 SET DR=".08////"_AG("Y")
DO ^DIE
KILL DR
End DoDot:2
End DoDot:1
+7 QUIT
HRN WRITE "(HRN: ",$SELECT('$GET(AG("PDFN")):"not Registered",'$GET(DUZ(2)):"DUZ(2) undefined",$PIECE($GET(^AUPNPAT(AG("PDFN"),41,DUZ(2),0)),U,2):$PIECE(^(0),U,2),1:"no HRN at "_$PIECE(^AUTTLOC(DUZ(2),0),U,2)),")"
+1 QUIT
XIT KILL AG
+1 QUIT
