Changeset 623 for WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEVPRG.m

Timestamp:

Dec 4, 2009, 12:11:15 AM (14 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

File:

• WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEVPRG.m (modified) (1 diff)

WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEVPRG.m

@@ -1 @@
-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
+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**;30 Apr 99;Build 8
+ ;
+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
+ 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
+ ;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
+PRGDUP ; Purge Duplicate Entries; retain most recent for all types except 234.
+ S EXCTYP="",CNT=0
+ K ^TMP("RGEVDUP",$J)
+ F  S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP  D
+ . I EXCTYP=234 Q  ;**44 process 234s separately below
+ . 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 EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3)
+ .... 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
+ ..... S OLDNODE=^TMP("RGEVDUP",$J,RGDFN,EXCTYP)
+ ..... S OLDDT=$P(OLDNODE,"^")
+ ..... I EXCDT>OLDDT D  Q
+ ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
+ ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=$P(OLDNODE,"^",2) D ^DIK K DIK,DA
+ ...... E  I NUM>1 D
+ ....... S DA(1)=$P(OLDNODE,"^",2),DA=$P(OLDNODE,"^",3)
+ ....... S DIK="^RGHL7(991.1,"_DA(1)_",1," D ^DIK K DIK,DA
+ ...... S CNT=CNT+1
+ ...... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
+ ..... I OLDDT>EXCDT!(OLDDT=EXCDT) 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 !,CNT_" Duplicate entries"
+ ;Process PRIMARY VIEW REJECT (234) duplicates; purge if for SAME day.
+ ;**44 through remainder of module.
+ K ^TMP("RGDFNDT",$J) S RGDFN=""
+ F  S RGDFN=$O(^RGHL7(991.1,"ADFN",234,RGDFN)) Q:'RGDFN  D
+ .S IEN=0
+ .F  S IEN=$O(^RGHL7(991.1,"ADFN",234,RGDFN,IEN)) Q:'IEN  D
+ ..S IEN2=0
+ ..F  S IEN2=$O(^RGHL7(991.1,"ADFN",234,RGDFN,IEN,IEN2)) Q:'IEN2  D
+ ...S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3)
+ ...;How many for each DFN? Store in ^TMP("RGDFNDT")
+ ...I '$D(^TMP("RGDFNDT",$J,RGDFN)) S ^TMP("RGDFNDT",$J,RGDFN)=0
+ ...I $D(^TMP("RGDFNDT",$J,RGDFN)) D
+ ....S ^TMP("RGDFNDT",$J,RGDFN)=^TMP("RGDFNDT",$J,RGDFN)+1
+ ....S ^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2)=$P(EXCDT,".") ;date only/no time
+ ;If RGDFN has more than 1 exception, see if any are for same DAY.
+ ;Process the ^TMP("RGDFNDT",$J global to build LOC array.
+ I $D(^TMP("RGDFNDT",$J)) D
+ .S RGDFN=""
+ .F  S RGDFN=$O(^TMP("RGDFNDT",$J,RGDFN)) Q:'RGDFN  D
+ ..;If only one 234 exception for DFN ignore it.
+ ..I ^TMP("RGDFNDT",$J,RGDFN)=1 Q
+ ..;More than one for this DFN?  How many for same day?
+ ..S IEN=0 K LOC
+ ..F  S IEN=$O(^TMP("RGDFNDT",$J,RGDFN,IEN)) Q:'IEN  D
+ ...S (IEN2,VAL)=0
+ ...F  S IEN2=$O(^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2)) Q:'IEN2  D
+ ....S VAL=$P(^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2),"^")
+ ....I '$D(LOC(VAL)) S LOC(VAL)=0
+ ....I $D(LOC(VAL)) D
+ .....S LOC(VAL)=LOC(VAL)+1
+ .....S LOC(VAL,IEN,IEN2)=""
+ ..;Process the LOC array; contains numbers / day / DFN.
+ ..;If only 1 exception / day, keep it.
+ ..S RGDT=0 K CTR,TOT
+ ..F  S RGDT=$O(LOC(RGDT)) Q:'RGDT  D
+ ...S TOT=LOC(RGDT)
+ ...I TOT=1 K TOT Q  ;only 1.
+ ...;More than 1, delete all except 1.
+ ...S TOT=TOT-1 ;leave 1; doesn't matter which - all are same day.
+ ...S IEN=0,CTR=0
+ ...F  S IEN=$O(LOC(RGDT,IEN)) Q:'IEN  D
+ ....I CTR=TOT Q
+ ....S CTR=CTR+1,IEN2=0
+ ....F  S IEN2=$O(LOC(RGDT,IEN,IEN2)) Q:'IEN2  D DEL ;delete entry
+ K CNT,CTR,EXCDT,IEN,IEN2,LOC,NUM,OLDDT,OLDNODE,RGDFN,RGDT,TOT,VAL,^TMP("RGDFNDT")
+ 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
+ ;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