RGEVPRG ;BAY/ALS-OPTIONS TO PURGE MPI/PD EXCEPTIONS ;08/23/99
;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,32,35,43,44,50,52**;30 Apr 99;Build 2
;
MAIN ;
;Q:($D(^TMP("RGEXC")))!($D(^TMP("RGEXC2")))
L +^RGHL7(991.1):0 I '$T Q
L -^RGHL7(991.1)
L +^RGHL7(991.1,"RG PURGE EXCEPTION"):5 E Q
I $D(ZTQUEUED) S ZTREQ="@"
S $P(^RGSITE(991.8,1,"EXCPRG"),"^",1)=$$NOW^XLFDT
S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="R"
;D PROC ;**52 Module is obsolete
D PRGDUP
D PRG30
D PRGZZ
S $P(^RGSITE(991.8,1,"EXCPRG"),"^",2)=$$NOW^XLFDT
S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="C"
L -^RGHL7(991.1,"RG PURGE EXCEPTION")
Q
PRGPAT ;Purge by Patient
W !
S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: "
D ^DIC K DIC G:Y<0 QUIT S RGDFN=+Y
S EXCT="",FLAG=0
F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:EXCT="" D
. I $D(^RGHL7(991.1,"ADFN",EXCT,RGDFN)) S FLAG=1 Q
I FLAG=0 W !,"There are no exceptions on file for this patient." G PRGPAT
I $$IFLOCAL^MPIF001(RGDFN) W !,"This patient does not have a national ICN assigned, do not purge." Q
S DFN=RGDFN D DEM^VADPT
S DIR(0)="YA",DIR("B")="YES"
S DIR("A")="Are you sure you want to purge all exceptions on file for "_VADM(1)_"? YES// "
D ^DIR Q:$D(DIRUT) I Y>0 D
. S EXCT="",CNT=0
. F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:'EXCT D
.. S IEN=0
.. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN)) Q:'IEN D
... S IEN2=0
... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN,IEN2)) Q:'IEN2 D
.... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
.... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1
.... E I NUM>1 D DEL
. W !,"All exceptions purged for "_VADM(1)_" DFN: "_RGDFN
K EXCT,DFN,FLAG,VADM,CNT,IEN,IEN2,NUM,RGDFN,Y
QUIT Q
;
PRGDT ; Purge by Date
W !!,"Enter a date for the purge. All exceptions on file, on or before that date, will be deleted."
K DIR,DIRUT,DTOUT,DUOUT
S DIR(0)="DA^:DT:EPX",DIR("A")="Enter Date for Purge: "
D ^DIR K DIR Q:$D(DIRUT)
S PURDT=Y
S PDATE=$$FMTE^XLFDT(PURDT)
S DIR(0)="YA",DIR("B")="YES"
S DIR("A")="Are you sure you want to purge all exceptions on file dated on or before "_PDATE_"? YES// "
D ^DIR Q:$D(DIRUT) I Y>0 D
. S EXCDT="",CNT=0
. F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D
.. I ($P(EXCDT,".",1)=PURDT)!($P(EXCDT,".",1)<PURDT) D
... S IEN=0
... F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D
.... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1
.... S CNT=CNT+NUM
.... S DIK="^RGHL7(991.1,",DA=IEN
.... D ^DIK K DIK,DA
I CNT=0 W !,"There are no exceptions dated on or before "_PDATE_", no data to purge."
E I CNT>0 W !,CNT_" exceptions, dated on or before "_PDATE_" have been purged!"
K PDATE,PURDT,EXCDT,CNT,IEN,NUM,Y
Q
PRG30 ; Purge Exceptions over 30 days old
S TODAY=""
S TODAY=$$NOW^XLFDT D
. S EXCDT="",CNT=0,DIFF=""
. F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D
.. S DIFF=$$FMDIFF^XLFDT(TODAY,EXCDT)
.. I DIFF>30 D
... S IEN=0
... F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D
.... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:'NUM
.... S IEN2=0
.... F S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2 D
..... S STAT=""
..... S STAT=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",5)
..... ; Only delete PROCESSED exceptions
..... I (STAT>0)!(STAT="") D
...... I NUM>1 D DEL
...... E I NUM=1 D
....... S CNT=CNT+NUM
....... S DIK="^RGHL7(991.1,",DA=IEN
....... D ^DIK K DIK,DA
K DIFF,TODAY,EXCDT,CNT,IEN,IEN2,NUM,STAT
Q
PRGEXC ; Purge by Exception Type
;**52 This module was obsolete before 52; just adding comment
;S DIC="^RGHL7(991.11,",DIC(0)="QEAM"
;S DIC("A")="Enter an exception type to purge: "
;D ^DIC K DIC G:Y<200 QUIT S EXCTYP=+Y,ETYPE=X
;S DIR(0)="YA",DIR("B")="YES"
;S DIR("A")="*WARNING* This will permanently delete all "_ETYPE_" exceptions. Are you sure you want to do this? YES// "
;D ^DIR Q:$D(DIRUT) I Y>0 D
;. S CNT=0,IEN=""
;. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
;.. S IEN2=0
;.. F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
;... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
;... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1
;... E I NUM>1 D DEL
;I CNT=0 W !,"There are no "_ETYPE_" exceptions on file."
;E I CNT>0 W !,CNT_" "_ETYPE_" Exceptions purged!"
;K ETYPE,CNT,IEN,IEN2,NUM,X,Y
Q ;**52;if module accidentally called, should quit instead of falling into next module.
PRGDUP ;Purge Duplicate Entries; retain most recent for all except types.
;**50 through remainder of module.
S EXCTYP="",CNT=0
K ^TMP("RGEVDUP",$J)
F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
. S RGDFN=""
. F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
.. S IEN=0
.. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
... S IEN2=0
... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
.... I $P($G(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5)=1 K ^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2) Q ;exception processed
.... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) ;incoming date
.... I '$D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D Q
..... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
.... I $D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D ;duplicate exists; compare incoming to previous.
..... S OLDNODE=^TMP("RGEVDUP",$J,RGDFN,EXCTYP)
..... S OLDDT=$P(OLDNODE,"^"),OLDIEN=$P(OLDNODE,"^",2),OLDIEN2=$P(OLDNODE,"^",3)
..... I EXCDT>OLDDT D Q ;incoming date greater than previous? purge old, keep new.
...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
...... I NUM=1 S DIK="^RGHL7(991.1,",DA=OLDIEN D ^DIK K DIK,DA
...... I NUM>1 D
....... S DA(1)=OLDIEN,DA=OLDIEN2
....... S DIK="^RGHL7(991.1,"_DA(1)_",1," D ^DIK K DIK,DA
...... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
..... ;
..... I OLDDT>EXCDT!(OLDDT=EXCDT) D ;previous date greater or equal incoming? purge new, keep old.
...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
...... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA
...... I NUM>1 D DEL
...... ;
K CNT,EXCDT,EXCTYP,IEN,IEN2,NUM,OLDDT,OLDIEN,OLDIEN2,OLDNODE,RGDFN,RGDT,^TMP("RGEVDUP")
Q
;
PRGZZ ;Purge if name field is null (incomplete record)
;Purge if -9 node exists, this indicates the record has been merged.
S EXCTYP="",CNT=""
F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
. S RGDFN=""
. F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
.. S IEN=0
.. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
... S IEN2=0
... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
.... S DFN=RGDFN D DEM^VADPT
.... I VADM(1)=""!($D(^DPT(RGDFN,-9))) D
..... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
..... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA
..... E I NUM>1 D DEL
K EXCTYP,RGDFN,DFN,IEN,IEN2,NUM,VADM
Q
DEL ;
S CNT=CNT+1
S DA(1)=IEN,DA=IEN2
S DIK="^RGHL7(991.1,"_DA(1)_",1,"
D ^DIK K DIK,DA
Q
PROC ;Set these exception types to PROCESSED if they have a national ICN
;**52 The PROC module is obsolete and is no longer being called.
;209 - Required field(s) missing for patient sent to MPI,
;227 - Multiple ICNs, 213 - SSN Match Failed, 214 - Name Doesn't Match
;S EXCTYP=""
;S HOME=$$SITE^VASITE()
;F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D
;. I (EXCTYP=209)!(EXCTYP=227)!(EXCTYP=213)!(EXCTYP=214) D ;**43
;.. S IEN=0
;.. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
;... S IEN2=0,ICN="",RGDFN=""
;... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
;.... S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN
;.... S ICN=+$$GETICN^MPIF001(RGDFN)
;.... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
;..... L +^RGHL7(991.1,IEN):10
;..... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
;..... D ^DIE K DIE,DA,DR
;..... L -^RGHL7(991.1,IEN)
;K EXCTYP,HOME,ICN,IEN,IEN2,RGDFN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGEVPRG 8036 printed Apr 09, 2024@20:47:16 Page 2
RGEVPRG ;BAY/ALS-OPTIONS TO PURGE MPI/PD EXCEPTIONS ;08/23/99
+1 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,32,35,43,44,50,52**;30 Apr 99;Build 2
+2 ;
MAIN ;
+1 ;Q:($D(^TMP("RGEXC")))!($D(^TMP("RGEXC2")))
+2 LOCK +^RGHL7(991.1):0
IF '$TEST
QUIT
+3 LOCK -^RGHL7(991.1)
+4 LOCK +^RGHL7(991.1,"RG PURGE EXCEPTION"):5
IF '$TEST
QUIT
+5 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 SET $PIECE(^RGSITE(991.8,1,"EXCPRG"),"^",1)=$$NOW^XLFDT
+7 SET $PIECE(^RGSITE(991.8,1,"EXCPRG"),"^",3)="R"
+8 ;D PROC ;**52 Module is obsolete
+9 DO PRGDUP
+10 DO PRG30
+11 DO PRGZZ
+12 SET $PIECE(^RGSITE(991.8,1,"EXCPRG"),"^",2)=$$NOW^XLFDT
+13 SET $PIECE(^RGSITE(991.8,1,"EXCPRG"),"^",3)="C"
+14 LOCK -^RGHL7(991.1,"RG PURGE EXCEPTION")
+15 QUIT
PRGPAT ;Purge by Patient
+1 WRITE !
+2 SET DIC="^DPT("
SET DIC(0)="QEAM"
SET DIC("A")="Select PATIENT: "
+3 DO ^DIC
KILL DIC
if Y<0
GOTO QUIT
SET RGDFN=+Y
+4 SET EXCT=""
SET FLAG=0
+5 FOR
SET EXCT=$ORDER(^RGHL7(991.1,"ADFN",EXCT))
if EXCT=""
QUIT
Begin DoDot:1
+6 IF $DATA(^RGHL7(991.1,"ADFN",EXCT,RGDFN))
SET FLAG=1
QUIT
End DoDot:1
+7 IF FLAG=0
WRITE !,"There are no exceptions on file for this patient."
GOTO PRGPAT
+8 IF $$IFLOCAL^MPIF001(RGDFN)
WRITE !,"This patient does not have a national ICN assigned, do not purge."
QUIT
+9 SET DFN=RGDFN
DO DEM^VADPT
+10 SET DIR(0)="YA"
SET DIR("B")="YES"
+11 SET DIR("A")="Are you sure you want to purge all exceptions on file for "_VADM(1)_"? YES// "
+12 DO ^DIR
if $DATA(DIRUT)
QUIT
IF Y>0
Begin DoDot:1
+13 SET EXCT=""
SET CNT=0
+14 FOR
SET EXCT=$ORDER(^RGHL7(991.1,"ADFN",EXCT))
if 'EXCT
QUIT
Begin DoDot:2
+15 SET IEN=0
+16 FOR
SET IEN=$ORDER(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN))
if 'IEN
QUIT
Begin DoDot:3
+17 SET IEN2=0
+18 FOR
SET IEN2=$ORDER(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN,IEN2))
if 'IEN2
QUIT
Begin DoDot:4
+19 SET NUM=""
SET NUM=$PIECE(^RGHL7(991.1,IEN,1,0),"^",4)
+20 IF NUM=1
SET DIK="^RGHL7(991.1,"
SET DA=IEN
DO ^DIK
KILL DIK,DA
SET CNT=CNT+1
+21 IF '$TEST
IF NUM>1
DO DEL
End DoDot:4
End DoDot:3
End DoDot:2
+22 WRITE !,"All exceptions purged for "_VADM(1)_" DFN: "_RGDFN
End DoDot:1
+23 KILL EXCT,DFN,FLAG,VADM,CNT,IEN,IEN2,NUM,RGDFN,Y
QUIT QUIT
+1 ;
PRGDT ; Purge by Date
+1 WRITE !!,"Enter a date for the purge. All exceptions on file, on or before that date, will be deleted."
+2 KILL DIR,DIRUT,DTOUT,DUOUT
+3 SET DIR(0)="DA^:DT:EPX"
SET DIR("A")="Enter Date for Purge: "
+4 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+5 SET PURDT=Y
+6 SET PDATE=$$FMTE^XLFDT(PURDT)
+7 SET DIR(0)="YA"
SET DIR("B")="YES"
+8 SET DIR("A")="Are you sure you want to purge all exceptions on file dated on or before "_PDATE_"? YES// "
+9 DO ^DIR
if $DATA(DIRUT)
QUIT
IF Y>0
Begin DoDot:1
+10 SET EXCDT=""
SET CNT=0
+11 FOR
SET EXCDT=$ORDER(^RGHL7(991.1,"AD",EXCDT))
if 'EXCDT
QUIT
Begin DoDot:2
+12 IF ($PIECE(EXCDT,".",1)=PURDT)!($PIECE(EXCDT,".",1)<PURDT)
Begin DoDot:3
+13 SET IEN=0
+14 FOR
SET IEN=$ORDER(^RGHL7(991.1,"AD",EXCDT,IEN))
if 'IEN
QUIT
Begin DoDot:4
+15 SET NUM=""
SET NUM=$PIECE($GET(^RGHL7(991.1,IEN,1,0)),"^",4)
if NUM<1
QUIT
+16 SET CNT=CNT+NUM
+17 SET DIK="^RGHL7(991.1,"
SET DA=IEN
+18 DO ^DIK
KILL DIK,DA
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 IF CNT=0
WRITE !,"There are no exceptions dated on or before "_PDATE_", no data to purge."
+20 IF '$TEST
IF CNT>0
WRITE !,CNT_" exceptions, dated on or before "_PDATE_" have been purged!"
+21 KILL PDATE,PURDT,EXCDT,CNT,IEN,NUM,Y
+22 QUIT
PRG30 ; Purge Exceptions over 30 days old
+1 SET TODAY=""
+2 SET TODAY=$$NOW^XLFDT
Begin DoDot:1
+3 SET EXCDT=""
SET CNT=0
SET DIFF=""
+4 FOR
SET EXCDT=$ORDER(^RGHL7(991.1,"AD",EXCDT))
if 'EXCDT
QUIT
Begin DoDot:2
+5 SET DIFF=$$FMDIFF^XLFDT(TODAY,EXCDT)
+6 IF DIFF>30
Begin DoDot:3
+7 SET IEN=0
+8 FOR
SET IEN=$ORDER(^RGHL7(991.1,"AD",EXCDT,IEN))
if 'IEN
QUIT
Begin DoDot:4
+9 SET NUM=""
SET NUM=$PIECE($GET(^RGHL7(991.1,IEN,1,0)),"^",4)
if 'NUM
QUIT
+10 SET IEN2=0
+11 FOR
SET IEN2=$ORDER(^RGHL7(991.1,IEN,1,IEN2))
if 'IEN2
QUIT
Begin DoDot:5
+12 SET STAT=""
+13 SET STAT=$PIECE(^RGHL7(991.1,IEN,1,IEN2,0),"^",5)
+14 ; Only delete PROCESSED exceptions
+15 IF (STAT>0)!(STAT="")
Begin DoDot:6
+16 IF NUM>1
DO DEL
+17 IF '$TEST
IF NUM=1
Begin DoDot:7
+18 SET CNT=CNT+NUM
+19 SET DIK="^RGHL7(991.1,"
SET DA=IEN
+20 DO ^DIK
KILL DIK,DA
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 KILL DIFF,TODAY,EXCDT,CNT,IEN,IEN2,NUM,STAT
+22 QUIT
PRGEXC ; Purge by Exception Type
+1 ;**52 This module was obsolete before 52; just adding comment
+2 ;S DIC="^RGHL7(991.11,",DIC(0)="QEAM"
+3 ;S DIC("A")="Enter an exception type to purge: "
+4 ;D ^DIC K DIC G:Y<200 QUIT S EXCTYP=+Y,ETYPE=X
+5 ;S DIR(0)="YA",DIR("B")="YES"
+6 ;S DIR("A")="*WARNING* This will permanently delete all "_ETYPE_" exceptions. Are you sure you want to do this? YES// "
+7 ;D ^DIR Q:$D(DIRUT) I Y>0 D
+8 ;. S CNT=0,IEN=""
+9 ;. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
+10 ;.. S IEN2=0
+11 ;.. F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
+12 ;... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
+13 ;... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1
+14 ;... E I NUM>1 D DEL
+15 ;I CNT=0 W !,"There are no "_ETYPE_" exceptions on file."
+16 ;E I CNT>0 W !,CNT_" "_ETYPE_" Exceptions purged!"
+17 ;K ETYPE,CNT,IEN,IEN2,NUM,X,Y
+18 ;**52;if module accidentally called, should quit instead of falling into next module.
QUIT
PRGDUP ;Purge Duplicate Entries; retain most recent for all except types.
+1 ;**50 through remainder of module.
+2 SET EXCTYP=""
SET CNT=0
+3 KILL ^TMP("RGEVDUP",$JOB)
+4 FOR
SET EXCTYP=$ORDER(^RGHL7(991.1,"ADFN",EXCTYP))
if 'EXCTYP
QUIT
Begin DoDot:1
+5 SET RGDFN=""
+6 FOR
SET RGDFN=$ORDER(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN))
if 'RGDFN
QUIT
Begin DoDot:2
+7 SET IEN=0
+8 FOR
SET IEN=$ORDER(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN))
if 'IEN
QUIT
Begin DoDot:3
+9 SET IEN2=0
+10 FOR
SET IEN2=$ORDER(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2))
if 'IEN2
QUIT
Begin DoDot:4
+11 ;exception processed
IF $PIECE($GET(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5)=1
KILL ^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)
QUIT
+12 ;incoming date
SET EXCDT=$PIECE($GET(^RGHL7(991.1,IEN,0)),"^",3)
+13 IF '$DATA(^TMP("RGEVDUP",$JOB,RGDFN,EXCTYP))
Begin DoDot:5
+14 SET ^TMP("RGEVDUP",$JOB,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
End DoDot:5
QUIT
+15 ;duplicate exists; compare incoming to previous.
IF $DATA(^TMP("RGEVDUP",$JOB,RGDFN,EXCTYP))
Begin DoDot:5
+16 SET OLDNODE=^TMP("RGEVDUP",$JOB,RGDFN,EXCTYP)
+17 SET OLDDT=$PIECE(OLDNODE,"^")
SET OLDIEN=$PIECE(OLDNODE,"^",2)
SET OLDIEN2=$PIECE(OLDNODE,"^",3)
+18 ;incoming date greater than previous? purge old, keep new.
IF EXCDT>OLDDT
Begin DoDot:6
+19 SET NUM=""
SET NUM=$PIECE(^RGHL7(991.1,IEN,1,0),"^",4)
+20 IF NUM=1
SET DIK="^RGHL7(991.1,"
SET DA=OLDIEN
DO ^DIK
KILL DIK,DA
+21 IF NUM>1
Begin DoDot:7
+22 SET DA(1)=OLDIEN
SET DA=OLDIEN2
+23 SET DIK="^RGHL7(991.1,"_DA(1)_",1,"
DO ^DIK
KILL DIK,DA
End DoDot:7
+24 SET ^TMP("RGEVDUP",$JOB,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
End DoDot:6
QUIT
+25 ;
+26 ;previous date greater or equal incoming? purge new, keep old.
IF OLDDT>EXCDT!(OLDDT=EXCDT)
Begin DoDot:6
+27 SET NUM=""
SET NUM=$PIECE(^RGHL7(991.1,IEN,1,0),"^",4)
+28 IF NUM=1
SET DIK="^RGHL7(991.1,"
SET DA=IEN
DO ^DIK
KILL DIK,DA
+29 IF NUM>1
DO DEL
+30 ;
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+31 KILL CNT,EXCDT,EXCTYP,IEN,IEN2,NUM,OLDDT,OLDIEN,OLDIEN2,OLDNODE,RGDFN,RGDT,^TMP("RGEVDUP")
+32 QUIT
+33 ;
PRGZZ ;Purge if name field is null (incomplete record)
+1 ;Purge if -9 node exists, this indicates the record has been merged.
+2 SET EXCTYP=""
SET CNT=""
+3 FOR
SET EXCTYP=$ORDER(^RGHL7(991.1,"ADFN",EXCTYP))
if 'EXCTYP
QUIT
Begin DoDot:1
+4 SET RGDFN=""
+5 FOR
SET RGDFN=$ORDER(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN))
if 'RGDFN
QUIT
Begin DoDot:2
+6 SET IEN=0
+7 FOR
SET IEN=$ORDER(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN))
if 'IEN
QUIT
Begin DoDot:3
+8 SET IEN2=0
+9 FOR
SET IEN2=$ORDER(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2))
if 'IEN2
QUIT
Begin DoDot:4
+10 SET DFN=RGDFN
DO DEM^VADPT
+11 IF VADM(1)=""!($DATA(^DPT(RGDFN,-9)))
Begin DoDot:5
+12 SET NUM=""
SET NUM=$PIECE(^RGHL7(991.1,IEN,1,0),"^",4)
+13 IF NUM=1
SET DIK="^RGHL7(991.1,"
SET DA=IEN
DO ^DIK
KILL DIK,DA
+14 IF '$TEST
IF NUM>1
DO DEL
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 KILL EXCTYP,RGDFN,DFN,IEN,IEN2,NUM,VADM
+16 QUIT
DEL ;
+1 SET CNT=CNT+1
+2 SET DA(1)=IEN
SET DA=IEN2
+3 SET DIK="^RGHL7(991.1,"_DA(1)_",1,"
+4 DO ^DIK
KILL DIK,DA
+5 QUIT
PROC ;Set these exception types to PROCESSED if they have a national ICN
+1 ;**52 The PROC module is obsolete and is no longer being called.
+2 ;209 - Required field(s) missing for patient sent to MPI,
+3 ;227 - Multiple ICNs, 213 - SSN Match Failed, 214 - Name Doesn't Match
+4 ;S EXCTYP=""
+5 ;S HOME=$$SITE^VASITE()
+6 ;F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D
+7 ;. I (EXCTYP=209)!(EXCTYP=227)!(EXCTYP=213)!(EXCTYP=214) D ;**43
+8 ;.. S IEN=0
+9 ;.. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
+10 ;... S IEN2=0,ICN="",RGDFN=""
+11 ;... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
+12 ;.... S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN
+13 ;.... S ICN=+$$GETICN^MPIF001(RGDFN)
+14 ;.... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
+15 ;..... L +^RGHL7(991.1,IEN):10
+16 ;..... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
+17 ;..... D ^DIE K DIE,DA,DR
+18 ;..... L -^RGHL7(991.1,IEN)
+19 ;K EXCTYP,HOME,ICN,IEN,IEN2,RGDFN
+20 QUIT
