- 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 Jan 18, 2025@02:42:54 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