source: FOIAVistA/tag/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEVPRG.m@ 636

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