Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RGEVPRG

RGEVPRG.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. MAIN ;
  1. ;Q:($D(^TMP("RGEXC")))!($D(^TMP("RGEXC2")))
  1. L +^RGHL7(991.1):0 I '$T Q
  1. L -^RGHL7(991.1)
  1. L +^RGHL7(991.1,"RG PURGE EXCEPTION"):5 E Q
  1. I $D(ZTQUEUED) S ZTREQ="@"
  1. S $P(^RGSITE(991.8,1,"EXCPRG"),"^",1)=$$NOW^XLFDT
  1. S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="R"
  1. ;D PROC ;**52 Module is obsolete
  1. D PRGDUP
  1. D PRG30
  1. D PRGZZ
  1. S $P(^RGSITE(991.8,1,"EXCPRG"),"^",2)=$$NOW^XLFDT
  1. S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="C"
  1. L -^RGHL7(991.1,"RG PURGE EXCEPTION")
  1. Q
  1. PRGPAT ;Purge by Patient
  1. W !
  1. S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: "
  1. D ^DIC K DIC G:Y<0 QUIT S RGDFN=+Y
  1. S EXCT="",FLAG=0
  1. F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:EXCT="" D
  1. . I $D(^RGHL7(991.1,"ADFN",EXCT,RGDFN)) S FLAG=1 Q
  1. I FLAG=0 W !,"There are no exceptions on file for this patient." G PRGPAT
  1. I $$IFLOCAL^MPIF001(RGDFN) W !,"This patient does not have a national ICN assigned, do not purge." Q
  1. S DFN=RGDFN D DEM^VADPT
  1. S DIR(0)="YA",DIR("B")="YES"
  1. S DIR("A")="Are you sure you want to purge all exceptions on file for "_VADM(1)_"? YES// "
  1. D ^DIR Q:$D(DIRUT) I Y>0 D
  1. . S EXCT="",CNT=0
  1. . F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:'EXCT D
  1. .. S IEN=0
  1. .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN)) Q:'IEN D
  1. ... S IEN2=0
  1. ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN,IEN2)) Q:'IEN2 D
  1. .... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
  1. .... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1
  1. .... E I NUM>1 D DEL
  1. . W !,"All exceptions purged for "_VADM(1)_" DFN: "_RGDFN
  1. K EXCT,DFN,FLAG,VADM,CNT,IEN,IEN2,NUM,RGDFN,Y
  1. QUIT Q
  1. ;
  1. PRGDT ; Purge by Date
  1. W !!,"Enter a date for the purge. All exceptions on file, on or before that date, will be deleted."
  1. K DIR,DIRUT,DTOUT,DUOUT
  1. S DIR(0)="DA^:DT:EPX",DIR("A")="Enter Date for Purge: "
  1. D ^DIR K DIR Q:$D(DIRUT)
  1. S PURDT=Y
  1. S PDATE=$$FMTE^XLFDT(PURDT)
  1. S DIR(0)="YA",DIR("B")="YES"
  1. S DIR("A")="Are you sure you want to purge all exceptions on file dated on or before "_PDATE_"? YES// "
  1. D ^DIR Q:$D(DIRUT) I Y>0 D
  1. . S EXCDT="",CNT=0
  1. . F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D
  1. .. I ($P(EXCDT,".",1)=PURDT)!($P(EXCDT,".",1)<PURDT) D
  1. ... S IEN=0
  1. ... F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D
  1. .... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1
  1. .... S CNT=CNT+NUM
  1. .... S DIK="^RGHL7(991.1,",DA=IEN
  1. .... D ^DIK K DIK,DA
  1. I CNT=0 W !,"There are no exceptions dated on or before "_PDATE_", no data to purge."
  1. E I CNT>0 W !,CNT_" exceptions, dated on or before "_PDATE_" have been purged!"
  1. K PDATE,PURDT,EXCDT,CNT,IEN,NUM,Y
  1. Q
  1. PRG30 ; Purge Exceptions over 30 days old
  1. S TODAY=""
  1. S TODAY=$$NOW^XLFDT D
  1. . S EXCDT="",CNT=0,DIFF=""
  1. . F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D
  1. .. S DIFF=$$FMDIFF^XLFDT(TODAY,EXCDT)
  1. .. I DIFF>30 D
  1. ... S IEN=0
  1. ... F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D
  1. .... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:'NUM
  1. .... S IEN2=0
  1. .... F S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2 D
  1. ..... S STAT=""
  1. ..... S STAT=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",5)
  1. ..... ; Only delete PROCESSED exceptions
  1. ..... I (STAT>0)!(STAT="") D
  1. ...... I NUM>1 D DEL
  1. ...... E I NUM=1 D
  1. ....... S CNT=CNT+NUM
  1. ....... S DIK="^RGHL7(991.1,",DA=IEN
  1. ....... D ^DIK K DIK,DA
  1. K DIFF,TODAY,EXCDT,CNT,IEN,IEN2,NUM,STAT
  1. Q
  1. PRGEXC ; Purge by Exception Type
  1. ;**52 This module was obsolete before 52; just adding comment
  1. ;S DIC="^RGHL7(991.11,",DIC(0)="QEAM"
  1. ;S DIC("A")="Enter an exception type to purge: "
  1. ;D ^DIC K DIC G:Y<200 QUIT S EXCTYP=+Y,ETYPE=X
  1. ;S DIR(0)="YA",DIR("B")="YES"
  1. ;S DIR("A")="*WARNING* This will permanently delete all "_ETYPE_" exceptions. Are you sure you want to do this? YES// "
  1. ;D ^DIR Q:$D(DIRUT) I Y>0 D
  1. ;. S CNT=0,IEN=""
  1. ;. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
  1. ;.. S IEN2=0
  1. ;.. F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
  1. ;... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
  1. ;... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1
  1. ;... E I NUM>1 D DEL
  1. ;I CNT=0 W !,"There are no "_ETYPE_" exceptions on file."
  1. ;E I CNT>0 W !,CNT_" "_ETYPE_" Exceptions purged!"
  1. ;K ETYPE,CNT,IEN,IEN2,NUM,X,Y
  1. Q ;**52;if module accidentally called, should quit instead of falling into next module.
  1. PRGDUP ;Purge Duplicate Entries; retain most recent for all except types.
  1. ;**50 through remainder of module.
  1. S EXCTYP="",CNT=0
  1. K ^TMP("RGEVDUP",$J)
  1. F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
  1. . S RGDFN=""
  1. . F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
  1. .. S IEN=0
  1. .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
  1. ... S IEN2=0
  1. ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
  1. .... I $P($G(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5)=1 K ^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2) Q ;exception processed
  1. .... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) ;incoming date
  1. .... I '$D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D Q
  1. ..... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
  1. .... I $D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D ;duplicate exists; compare incoming to previous.
  1. ..... S OLDNODE=^TMP("RGEVDUP",$J,RGDFN,EXCTYP)
  1. ..... S OLDDT=$P(OLDNODE,"^"),OLDIEN=$P(OLDNODE,"^",2),OLDIEN2=$P(OLDNODE,"^",3)
  1. ..... I EXCDT>OLDDT D Q ;incoming date greater than previous? purge old, keep new.
  1. ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
  1. ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=OLDIEN D ^DIK K DIK,DA
  1. ...... I NUM>1 D
  1. ....... S DA(1)=OLDIEN,DA=OLDIEN2
  1. ....... S DIK="^RGHL7(991.1,"_DA(1)_",1," D ^DIK K DIK,DA
  1. ...... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
  1. ..... ;
  1. ..... I OLDDT>EXCDT!(OLDDT=EXCDT) D ;previous date greater or equal incoming? purge new, keep old.
  1. ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
  1. ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA
  1. ...... I NUM>1 D DEL
  1. ...... ;
  1. K CNT,EXCDT,EXCTYP,IEN,IEN2,NUM,OLDDT,OLDIEN,OLDIEN2,OLDNODE,RGDFN,RGDT,^TMP("RGEVDUP")
  1. Q
  1. ;
  1. PRGZZ ;Purge if name field is null (incomplete record)
  1. ;Purge if -9 node exists, this indicates the record has been merged.
  1. S EXCTYP="",CNT=""
  1. F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
  1. . S RGDFN=""
  1. . F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
  1. .. S IEN=0
  1. .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
  1. ... S IEN2=0
  1. ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
  1. .... S DFN=RGDFN D DEM^VADPT
  1. .... I VADM(1)=""!($D(^DPT(RGDFN,-9))) D
  1. ..... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
  1. ..... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA
  1. ..... E I NUM>1 D DEL
  1. K EXCTYP,RGDFN,DFN,IEN,IEN2,NUM,VADM
  1. Q
  1. DEL ;
  1. S CNT=CNT+1
  1. S DA(1)=IEN,DA=IEN2
  1. S DIK="^RGHL7(991.1,"_DA(1)_",1,"
  1. D ^DIK K DIK,DA
  1. Q
  1. 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.
  1. ;209 - Required field(s) missing for patient sent to MPI,
  1. ;227 - Multiple ICNs, 213 - SSN Match Failed, 214 - Name Doesn't Match
  1. ;S EXCTYP=""
  1. ;S HOME=$$SITE^VASITE()
  1. ;F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D
  1. ;. I (EXCTYP=209)!(EXCTYP=227)!(EXCTYP=213)!(EXCTYP=214) D ;**43
  1. ;.. S IEN=0
  1. ;.. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
  1. ;... S IEN2=0,ICN="",RGDFN=""
  1. ;... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
  1. ;.... S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN
  1. ;.... S ICN=+$$GETICN^MPIF001(RGDFN)
  1. ;.... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
  1. ;..... L +^RGHL7(991.1,IEN):10
  1. ;..... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
  1. ;..... D ^DIE K DIE,DA,DR
  1. ;..... L -^RGHL7(991.1,IEN)
  1. ;K EXCTYP,HOME,ICN,IEN,IEN2,RGDFN
  1. Q