Index: WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEVPRG.m
===================================================================
--- WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEVPRG.m	(revision 613)
+++ WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEVPRG.m	(revision 623)
@@ -1,188 +1,228 @@
-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
Index: WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX01.m
===================================================================
--- WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX01.m	(revision 613)
+++ WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX01.m	(revision 623)
@@ -1,157 +1,156 @@
-RGEX01	;BAY/ALS-LIST MANAGER FOR MPI/PD EXCEPTIONS ;10/07/99
-	;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45,47,48,52**;30 Apr 99;Build 2
-	;
-	;Reference to MAIN^VAFCPDAT supported by IA #3299
-EN	; -- main entry point for RG EXCPT SUMMARY
-	N STDT,ENDDT,PRGSTAT,XFLAG,NOW,%,X,%H,%I,INDT,RUN,INDTT
-	S XFLAG=0 D NOW^%DTC S NOW=%
-	S STDT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",1),INDT=STDT
-	I $D(STDT) S STDT=$$FMTE^XLFDT(STDT,1)
-	S PRGSTAT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",3)
-	;status shows 'running' but lock shows 'not running';**47
-	I PRGSTAT="R" D
-	.L +^RGHL7(991.1,"RG PURGE EXCEPTION"):0 I $T D  ;can get lock
-	..L +^RGSITE(991.8):10
-	..S DIE="^RGSITE(991.8,",DA=1,DR="42///@"
-	..D ^DIE K DA,DIE,DR ;delete old status
-	..L -^RGSITE(991.8)
-	..S PRGSTAT=""
-	.L -^RGHL7(991.1,"RG PURGE EXCEPTION")
-	I PRGSTAT="" D
-	. W $C(7)
-	. W !!,"The MPI/PD Exception Purge process has not been run."
-	. ;**48 NO LONGER A CHOICE
-	. W !!,"The MPI/PD Exception Purge process will now run."
-	. W !,"Please come back to this option in five minutes."
-	. W !!,"Please contact IRM to schedule the MPI/PD EXCEPTION PURGE"
-	. W !,"[RG EXCEPTION PURGE] option via TaskMan with a frequency of once an hour."
-	. S XFLAG=1 D QUEPRG
-	L +^RGHL7(991.1,"RG PURGE EXCEPTION"):0 I '$T W $C(7),!!,"The MPI/PD Exception Purge process is currently running.",!,"Please try this option again in five minutes." S XFLAG=1 G EXIT
-	L -^RGHL7(991.1,"RG PURGE EXCEPTION")
-	S RUN=0
-	I $G(PRGSTAT)="C" D
-	. I $P(INDT,".")<$P(NOW,".") S RUN=1 ;RAN A PREVIOUS DAY
-	. I $P(INDT,".")=$P(NOW,".") D
-	.. S INDTT=$E($P(INDT,".",2),1,4),INDTT=INDTT+101
-	.. I INDTT<$E($P(NOW,".",2),1,4) S RUN=1
-	. Q:RUN=0
-	. ;** if job ran more than 1 hour ago, run it now.
-	. W !!,"The MPI/PD Exception Purge process last ran "_STDT_"."
-	. W !!,"The MPI/PD Exception Purge process will now run."
-	. W !,"Please come back to this option in five minutes."
-	. W !!,"Please contact IRM to verify that the MPI/PD EXCEPTION PURGE "
-	. W !,"[RG EXCEPTION PURGE] option is scheduled to run via TaskMan"
-	. W !,"with a frequency of once an hour."
-	. S XFLAG=1 D QUEPRG
-	I XFLAG=1 G EXIT
-	K RGANS
-	D WAIT^DICD
-	D EN^VALM("RG EXCPT SUMMARY")
-	Q
-	;
-HDR	; -- header code
-	S VALMHDR(1)="MPI/PD Exception Handling"
-	S VALMHDR(2)=""
-	Q
-	;
-INIT	; -- init variables and list array
-	I '$D(RGSORT) S RGSORT="SD"
-	K @VALMAR
-	I RGSORT="SD" D DTLIST^RGEXHND1
-	E  I RGSORT="ST" D EXCLST^RGEXHND1
-	E  I RGSORT="SN" D PATLST^RGEXHND1
-	E  I RGSORT="VT" D SELTYP^RGEXHND1
-	Q
-	;
-SORT	;
-	D INIT
-	S VALMBCK="R"
-	Q
-HELP	; -- help code
-	S X="?" D DISP^XQORM1 W !!
-	Q
-HLPPRG	;
-	W !,"Enter Y(YES) to run the MPI/PD Exception Purge process now."
-	W !!,"Enter N(NO) to go directly into the MPI/PD Exception Handling option."
-	Q
-	;
-EXIT	; -- exit code
-	K VADM,RGDFN,RGNM,RGSORT,RGSSN,STAT,STRING,NDX,NM,IEN,IEN2,X,DATA,CNT,EXCTYPE,ETYPE,^TMP("RGEXC",$J),^TMP("RGEX01",$J)
-	Q
-QUEPRG	S ZTRTN="MAIN^RGEVPRG",ZTDESC="PURGE ZZ*, OVER 30 DAY AND DUPLICATE RECORDS FROM THE CIRN HL7 EXCEPTION LOG FILE"
-	D NOW^%DTC
-	S ZTIO="",ZTDTH=%
-	I $D(DUZ) S ZTSAVE("DUZ")=DUZ
-	D ^%ZTLOAD
-	D HOME^%ZIS K IO("Q")
-	K ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,%
-	Q
-	;
-EXPND	; -- expand code
-	Q
-	;
-CUREX()	;Are there any patients in the CIRN HL7 EXCEPTION LOG file (#991.1)
-	;that are NOT PROCESSED for specific exception types?
-	;     Return RGEX:
-	;If RGEX=3 both unprocessed and Primary View Reject exceptions exist
-	;If RGEX=2 only Primary View Reject exceptions exist
-	;If RGEX=1 only unprocessed exceptions exist
-	;If RGEX=0 no unprocessed exceptions exist
-	;
-	N EXCTYP,RG1,RG2,RGEX
-	S EXCTYP="",(RG1,RG2,RGEX)=0
-	F  S EXCTYP=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP)) Q:'EXCTYP  D
-	.I (EXCTYP=234)!(EXCTYP=218) S RG1=1 ;MPIC_772; **52 remove 215, 216, and 217
-	.I (EXCTYP=234) S RG2=1 ;Primary View Reject
-	I (RG1=1),(RG2=1) S RGEX=3 ;Send both messages
-	I (RG1=1),(RG2=0) S RGEX=1 ;Only unresolved exceptions exist
-	I (RG1=0),(RG2=1) S RGEX=2 ;Only Primary View Reject exceptions exist
-	Q RGEX
-	;
-PROC	; For a given patient, set exceptions STATUS to PROCESSED.
-	;**52 The PROC module is obsolete and is no longer being called.
-	; DFN must be defined
-	;Q:'$D(DFN)
-	;S EXCTYP=""
-	;S HOME=$$SITE^VASITE()
-	;F  S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP  D
-	;. S RGDFN="",ICN=""
-	;. F  S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN  D
-	;.. I DFN=RGDFN D
-	;... S ICN=+$$GETICN^MPIF001(DFN)
-	;... ;Only set to PROCESSED if patient has national ICN.
-	;... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
-	;.... ;Exclude Death exceptions (215-217); they must be processed manually.
-	;.... ;Exclude 218 Potential Matches Returned exception **43
-	;.... I (EXCTYP>218)!(EXCTYP<215) 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
-	;....... 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 IEN,IEN2,RGDFN,EXCTYP,ICN
-	Q
-PDAT	;
-	K DIRUT
-	W !,"This report prints MPI/PD Data for a selected patient.  The"
-	W !,"information displayed includes the Integration Control Number"
-	W !,"(ICN), patient identity information, and Treating Facility list."
-	W !!,"The information is pulled from the Patient (#2) file and the"
-	W !,"Treating Facility List (#391.91) file."
-	;
-ASK	;Ask for PATIENT
-	I $D(DIRUT) G QUIT
-	W !!,"Patient lookup can be done by Patient Name/SSN or by ICN.",!
-	N DFN,ICN
-	S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: ",D="SSN^AICN^B^BS^BS5"
-	D MIX^DIC1 K DIC
-	G:Y<0 QUIT
-	S DFN=+Y
-	D MAIN^VAFCPDAT
-	G ASK
-	Q
-QUIT	;
-	K DFN,ICN,D,Y,HOME
+RGEX01 ;BAY/ALS-LIST MANAGER FOR MPI/PD EXCEPTIONS ;10/07/99
+ ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45,47,48**;30 Apr 99;Build 3
+ ;
+ ;Reference to MAIN^VAFCPDAT supported by IA #3299
+EN ; -- main entry point for RG EXCPT SUMMARY
+ N STDT,ENDDT,PRGSTAT,XFLAG,NOW,%,X,%H,%I,INDT,RUN,INDTT
+ S XFLAG=0 D NOW^%DTC S NOW=%
+ S STDT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",1),INDT=STDT
+ I $D(STDT) S STDT=$$FMTE^XLFDT(STDT,1)
+ S PRGSTAT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",3)
+ ;status shows 'running' but lock shows 'not running';**47
+ I PRGSTAT="R" D
+ .L +^RGHL7(991.1,"RG PURGE EXCEPTION"):0 I $T D  ;can get lock
+ ..L +^RGSITE(991.8):10
+ ..S DIE="^RGSITE(991.8,",DA=1,DR="42///@"
+ ..D ^DIE K DA,DIE,DR ;delete old status
+ ..L -^RGSITE(991.8)
+ ..S PRGSTAT=""
+ .L -^RGHL7(991.1,"RG PURGE EXCEPTION")
+ I PRGSTAT="" D
+ . W $C(7)
+ . W !!,"The MPI/PD Exception Purge process has not been run."
+ . ;**48 NO LONGER A CHOICE
+ . W !!,"The MPI/PD Exception Purge process will now run."
+ . W !,"Please come back to this option in five minutes."
+ . W !!,"Please contact IRM to schedule the MPI/PD EXCEPTION PURGE"
+ . W !,"[RG EXCEPTION PURGE] option via TaskMan with a frequency of once an hour."
+ . S XFLAG=1 D QUEPRG
+ L +^RGHL7(991.1,"RG PURGE EXCEPTION"):0 I '$T W $C(7),!!,"The MPI/PD Exception Purge process is currently running.",!,"Please try this option again in five minutes." S XFLAG=1 G EXIT
+ L -^RGHL7(991.1,"RG PURGE EXCEPTION")
+ S RUN=0
+ I $G(PRGSTAT)="C" D
+ . I $P(INDT,".")<$P(NOW,".") S RUN=1 ;RAN A PREVIOUS DAY
+ . I $P(INDT,".")=$P(NOW,".") D
+ .. S INDTT=$E($P(INDT,".",2),1,4),INDTT=INDTT+101
+ .. I INDTT<$E($P(NOW,".",2),1,4) S RUN=1
+ . Q:RUN=0
+ . ;** if job ran more than 1 hour ago, run it now.
+ . W !!,"The MPI/PD Exception Purge process last ran "_STDT_"."
+ . W !!,"The MPI/PD Exception Purge process will now run."
+ . W !,"Please come back to this option in five minutes."
+ . W !!,"Please contact IRM to verify that the MPI/PD EXCEPTION PURGE "
+ . W !,"[RG EXCEPTION PURGE] option is scheduled to run via TaskMan"
+ . W !,"with a frequency of once an hour."
+ . S XFLAG=1 D QUEPRG
+ I XFLAG=1 G EXIT
+ K RGANS
+ D WAIT^DICD
+ D EN^VALM("RG EXCPT SUMMARY")
+ Q
+ ;
+HDR ; -- header code
+ S VALMHDR(1)="MPI/PD Exception Handling"
+ S VALMHDR(2)=""
+ Q
+ ;
+INIT ; -- init variables and list array
+ I '$D(RGSORT) S RGSORT="SD"
+ K @VALMAR
+ I RGSORT="SD" D DTLIST^RGEXHND1
+ E  I RGSORT="ST" D EXCLST^RGEXHND1
+ E  I RGSORT="SN" D PATLST^RGEXHND1
+ E  I RGSORT="VT" D SELTYP^RGEXHND1
+ Q
+ ;
+SORT ;
+ D INIT
+ S VALMBCK="R"
+ Q
+HELP ; -- help code
+ S X="?" D DISP^XQORM1 W !!
+ Q
+HLPPRG ;
+ W !,"Enter Y(YES) to run the MPI/PD Exception Purge process now."
+ W !!,"Enter N(NO) to go directly into the MPI/PD Exception Handling option."
+ Q
+ ;
+EXIT ; -- exit code
+ K VADM,RGDFN,RGNM,RGSORT,RGSSN,STAT,STRING,NDX,NM,IEN,IEN2,X,DATA,CNT,EXCTYPE,ETYPE,^TMP("RGEXC",$J),^TMP("RGEX01",$J)
+ Q
+QUEPRG S ZTRTN="MAIN^RGEVPRG",ZTDESC="PURGE ZZ*, OVER 30 DAY AND DUPLICATE RECORDS FROM THE CIRN HL7 EXCEPTION LOG FILE"
+ D NOW^%DTC
+ S ZTIO="",ZTDTH=%
+ I $D(DUZ) S ZTSAVE("DUZ")=DUZ
+ D ^%ZTLOAD
+ D HOME^%ZIS K IO("Q")
+ K ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,%
+ Q
+ ;
+EXPND ; -- expand code
+ Q
+ ;
+CUREX() ;Are there any patients in the CIRN HL7 EXCEPTION LOG file (#991.1)
+ ;that are NOT PROCESSED for specific exception types?
+ ;     Return RGEX:
+ ;If RGEX=3 both unprocessed and Primary View Reject exceptions exist
+ ;If RGEX=2 only Primary View Reject exceptions exist
+ ;If RGEX=1 only unprocessed exceptions exist
+ ;If RGEX=0 no unprocessed exceptions exist
+ ;
+ N EXCTYP,RG1,RG2,RGEX
+ S EXCTYP="",(RG1,RG2,RGEX)=0
+ F  S EXCTYP=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP)) Q:'EXCTYP  D
+ .I ((EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219))) S RG1=1
+ .I (EXCTYP=234) S RG2=1 ;Primary View Reject
+ I (RG1=1),(RG2=1) S RGEX=3 ;Send both messages
+ I (RG1=1),(RG2=0) S RGEX=1 ;Only unresolved exceptions exist
+ I (RG1=0),(RG2=1) S RGEX=2 ;Only Primary View Reject exceptions exist
+ Q RGEX
+ ;
+PROC ; For a given patient, set exceptions STATUS to PROCESSED.
+ ; DFN must be defined
+ Q:'$D(DFN)
+ S EXCTYP=""
+ S HOME=$$SITE^VASITE()
+ F  S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP  D
+ . S RGDFN="",ICN=""
+ . F  S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN  D
+ .. I DFN=RGDFN D
+ ... S ICN=+$$GETICN^MPIF001(DFN)
+ ... ;Only set to PROCESSED if patient has national ICN.
+ ... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
+ .... ;Exclude Death exceptions (215-217); they must be processed manually.
+ .... ;Exclude 218 Potential Matches Returned exception **43
+ .... I (EXCTYP>218)!(EXCTYP<215) 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
+ ....... 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 IEN,IEN2,RGDFN,EXCTYP,ICN
+ Q
+PDAT ;
+ K DIRUT
+ W !,"This report prints MPI/PD Data for a selected patient.  The"
+ W !,"information displayed includes the Integration Control Number"
+ W !,"(ICN), patient identity information, and Treating Facility list."
+ W !!,"The information is pulled from the Patient (#2) file and the"
+ W !,"Treating Facility List (#391.91) file."
+ ;
+ASK ;Ask for PATIENT
+ I $D(DIRUT) G QUIT
+ W !!,"Patient lookup can be done by Patient Name/SSN or by ICN.",!
+ N DFN,ICN
+ S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: ",D="SSN^AICN^B^BS^BS5"
+ D MIX^DIC1 K DIC
+ G:Y<0 QUIT
+ S DFN=+Y
+ D MAIN^VAFCPDAT
+ G ASK
+ Q
+QUIT ;
+ K DFN,ICN,D,Y,HOME
Index: WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX06.m
===================================================================
--- WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX06.m	(revision 613)
+++ WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX06.m	(revision 623)
@@ -1,63 +1,63 @@
-RGEX06	;BIR/PTD-LIST MANAGER ROUTINE FOR REMOTE MPI PRIMARY VIEW PDAT ;5/17/07
-	;;1.0;CLINICAL INFO RESOURCE NETWORK;**48,53**;30 Apr 99;Build 2
-	;
-	;Reference to ^XWB2HL7 supported by IA #3144
-	;Reference to ^XWBDRPC supported by IA #3149
-	;
-EN(ICN)	;Entry point calling List Template for primary view PDAT display
-	D EN^VALM("RG EXCPT PV MPI PDAT")
-	Q
-	;
-HDR	; -- header code
-	S VALMHDR(1)="MPI PRIMARY VIEW PATIENT DATA DISPLAY"
-	Q
-	;
-INIT	;Display the MPI Primary View Patient Data (PDAT)
-	K ^TMP("RGEXC6",$J)
-	K @VALMAR
-	I '$D(ICN) G EXIT
-	S LIN=1,X=0,STR="",TXT=""
-	I '$D(^XTMP("RGPVMPI"_ICN,"DATA")) S TXT=" - No MPI Primary View data exists for this patient." D ADDTMP
-	N STATUS,R,RETURN,RESULT,RET
-	I $D(^XTMP("RGPVMPI"_ICN,"DATA")) S RETURN(0)=$P(^XTMP("RGPVMPI"_ICN,"DATA"),"^") D
-	.D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D
-	..;Retrieve the data
-	..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D
-	...I $G(RET(0))<0 S TXT="No Data Returned Due To: "_$P(RET(0),"^",2,99) S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP Q
-	...I $G(RET)'="",$D(@RET) S GLO=RET F  S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J  S TXT=@GLO S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP
-	...S R="" F  S R=$O(RET(R)) Q:R=""  S TXT=RET(R) S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP
-	K GLO,L,R,SL
-	S VALMCNT=LIN-1
-	Q
-	;
-ADDTMP	;Set string into the array.
-	S ^TMP("RGEXC6",$J,LIN,0)=STR
-	S ^TMP("RGEXC6",$J,"IDX",LIN,LIN)=""
-	S LIN=LIN+1,STR=""
-	Q
-	;
-HELP	; -- help code
-	S X="?" D DISP^XQORM1 W !!
-	Q
-	;
-EXIT	; -- exit code
-	S VALMBCK=""
-	K ^TMP("RGEXC6",$J),GLO,L,LIN,R,RESULT,RET,RETURN,SL,STATUS,STR,TXT,X
-	S VALMBCK="R"
-	Q
-	;
-EXPND	; -- expand code
-	Q
-	;
-SAPV(ICN)	;Print stand alone Primary View display
-	I '$D(^XTMP("RGPVMPI"_ICN,"DATA")) W !," - No MPI Primary View data exists for this patient." Q
-	N STATUS,R,RETURN,RESULT,RET
-	I $D(^XTMP("RGPVMPI"_ICN,"DATA")) S RETURN(0)=$P(^XTMP("RGPVMPI"_ICN,"DATA"),"^") D
-	.D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D
-	..;Retrieve the data
-	..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D
-	...I $D(RET(0)) I RET(0)<0 W !!,"No data returned due to: "_$P(RET(0),"^",2) Q
-	...I $G(RET)'="",$D(@RET) S GLO=RET F  S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J  S TXT=@GLO W !,TXT I $Y>22 S DIR(0)="E" D ^DIR K DIR W @IOF S $Y=1
-	...S R="" F  S R=$O(RET(R)) Q:R=""  W !,RET(R) I $Y>22 S DIR(0)="E" D ^DIR K DIR Q:'Y  W @IOF S $Y=1
-	Q
-	;
+RGEX06 ;BIR/PTD-LIST MANAGER ROUTINE FOR REMOTE MPI PRIMARY VIEW PDAT ;5/17/07
+ ;;1.0;CLINICAL INFO RESOURCE NETWORK;**48**;30 Apr 99;Build 3
+ ;
+ ;Reference to ^XWB2HL7 supported by IA #3144
+ ;Reference to ^XWBDRPC supported by IA #3149
+ ;
+EN(ICN) ;Entry point calling List Template for primary view PDAT display
+ D EN^VALM("RG EXCPT PV MPI PDAT")
+ Q
+ ;
+HDR ; -- header code
+ S VALMHDR(1)="MPI PRIMARY VIEW PATIENT DATA DISPLAY"
+ Q
+ ;
+INIT ;Display the MPI Primary View Patient Data (PDAT)
+ K ^TMP("RGEXC6",$J)
+ K @VALMAR
+ I '$D(ICN) G EXIT
+ S LIN=1,X=0,STR="",TXT=""
+ I '$D(^XTMP("RGPVMPI",ICN)) S TXT=" - No MPI Primary View data exists for this patient." D ADDTMP
+ N STATUS,R,RETURN,RESULT,RET
+ I $D(^XTMP("RGPVMPI",ICN)) S RETURN(0)=$P(^XTMP("RGPVMPI",ICN),"^") D
+ .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D
+ ..;Retrieve the data
+ ..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D
+ ...I $G(RET(0))<0 S TXT="No Data Returned Due To: "_$P(RET(0),"^",2,99) S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP Q
+ ...I $G(RET)'="",$D(@RET) S GLO=RET F  S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J  S TXT=@GLO S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP
+ ...S R="" F  S R=$O(RET(R)) Q:R=""  S TXT=RET(R) S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP
+ K GLO,L,R,SL
+ S VALMCNT=LIN-1
+ Q
+ ;
+ADDTMP ;Set string into the array.
+ S ^TMP("RGEXC6",$J,LIN,0)=STR
+ S ^TMP("RGEXC6",$J,"IDX",LIN,LIN)=""
+ S LIN=LIN+1,STR=""
+ Q
+ ;
+HELP ; -- help code
+ S X="?" D DISP^XQORM1 W !!
+ Q
+ ;
+EXIT ; -- exit code
+ S VALMBCK=""
+ K ^TMP("RGEXC6",$J),GLO,L,LIN,R,RESULT,RET,RETURN,SL,STATUS,STR,TXT,X
+ S VALMBCK="R"
+ Q
+ ;
+EXPND ; -- expand code
+ Q
+ ;
+SAPV(ICN) ;Print stand alone Primary View display
+ I '$D(^XTMP("RGPVMPI",ICN)) W !," - No MPI Primary View data exists for this patient." Q
+ N STATUS,R,RETURN,RESULT,RET
+ I $D(^XTMP("RGPVMPI",ICN)) S RETURN(0)=$P(^XTMP("RGPVMPI",ICN),"^") D
+ .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D
+ ..;Retrieve the data
+ ..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D
+ ...I $D(RET(0)) I RET(0)<0 W !!,"No data returned due to: "_$P(RET(0),"^",2) Q
+ ...I $G(RET)'="",$D(@RET) S GLO=RET F  S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J  S TXT=@GLO W !,TXT I $Y>22 S DIR(0)="E" D ^DIR K DIR W @IOF S $Y=1
+ ...S R="" F  S R=$O(RET(R)) Q:R=""  W !,RET(R) I $Y>22 S DIR(0)="E" D ^DIR K DIR Q:'Y  W @IOF S $Y=1
+ Q
+ ;
Index: WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX07.m
===================================================================
--- WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX07.m	(revision 613)
+++ WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX07.m	(revision 623)
@@ -1,52 +1,52 @@
-RGEX07	;BIR/PTD-LIST MANAGER ROUTINE FOR REMOTE PRIMARY VIEW DISPLAY ;10/17/06
-	;;1.0;CLINICAL INFO RESOURCE NETWORK;**44,53**;30 Apr 99;Build 2
-	;
-	;Reference to ^XWB2HL7 supported by IA #3144
-	;Reference to ^XWBDRPC supported by IA #3149
-	;
-EN(ICN,EXCDT)	;Entry point calling List Template for primary view reject display
-	D EN^VALM("RG EXCPT PV REJECT RDISPLAY")
-	Q
-	;
-HDR	; -- header code
-	S VALMHDR(1)="MPI PRIMARY VIEW REJECT DISPLAY"
-	Q
-	;
-INIT	;Display the MPI Primary View Rejected Data Report
-	K ^TMP("RGEXC7",$J)
-	K @VALMAR
-	I '$D(ICN) G EXIT
-	I '$D(EXCDT) G EXIT
-	S LIN=1,X=0,STR="",TXT=""
-	I '$D(^XTMP("RGPVREJ"_ICN,EXCDT)) S TXT=" - No Primary View Reject data exists for this patient/exception date." D ADDTMP
-	N STATUS,R,RETURN,RESULT,RET
-	I $D(^XTMP("RGPVREJ"_ICN,EXCDT)) S RETURN(0)=$P(^XTMP("RGPVREJ"_ICN,EXCDT),"^") D
-	.D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D
-	..;Retrieve the data
-	..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D
-	...I $G(RET(0))<0 S TXT="No Data Returned Due To: "_$P(RET(0),"^",2,99) S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP Q
-	...I $G(RET)'="",$D(@RET) S GLO=RET F  S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J  S TXT=@GLO S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP
-	...S R="" F  S R=$O(RET(R)) Q:R=""  S TXT=RET(R) S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP
-	K GLO,L,R,SL
-	S VALMCNT=LIN-1
-	Q
-	;
-ADDTMP	;Set string into the array.
-	S ^TMP("RGEXC7",$J,LIN,0)=STR
-	S ^TMP("RGEXC7",$J,"IDX",LIN,LIN)=""
-	S LIN=LIN+1,STR=""
-	Q
-	;
-HELP	; -- help code
-	S X="?" D DISP^XQORM1 W !!
-	Q
-	;
-EXIT	; -- exit code
-	S VALMBCK=""
-	K ^TMP("RGEXC7",$J),GLO,L,LIN,R,RESULT,RET,RETURN,SL,STATUS,STR,TXT,X
-	S VALMBCK="R"
-	Q
-	;
-EXPND	; -- expand code
-	Q
-	;
+RGEX07 ;BIR/PTD-LIST MANAGER ROUTINE FOR REMOTE PRIMARY VIEW DISPLAY ;10/17/06
+ ;;1.0;CLINICAL INFO RESOURCE NETWORK;**44**;30 Apr 99;Build 8
+ ;
+ ;Reference to ^XWB2HL7 supported by IA #3144
+ ;Reference to ^XWBDRPC supported by IA #3149
+ ;
+EN(ICN,EXCDT) ;Entry point calling List Template for primary view reject display
+ D EN^VALM("RG EXCPT PV REJECT RDISPLAY")
+ Q
+ ;
+HDR ; -- header code
+ S VALMHDR(1)="MPI PRIMARY VIEW REJECT DISPLAY"
+ Q
+ ;
+INIT ;Display the MPI Primary View Rejected Data Report
+ K ^TMP("RGEXC7",$J)
+ K @VALMAR
+ I '$D(ICN) G EXIT
+ I '$D(EXCDT) G EXIT
+ S LIN=1,X=0,STR="",TXT=""
+ I '$D(^XTMP("RGPVREJ",ICN,EXCDT)) S TXT=" - No Primary View Reject data exists for this patient/exception date." D ADDTMP
+ N STATUS,R,RETURN,RESULT,RET
+ I $D(^XTMP("RGPVREJ",ICN,EXCDT)) S RETURN(0)=$P(^XTMP("RGPVREJ",ICN,EXCDT),"^") D
+ .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D
+ ..;Retrieve the data
+ ..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D
+ ...I $G(RET(0))<0 S TXT="No Data Returned Due To: "_$P(RET(0),"^",2,99) S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP Q
+ ...I $G(RET)'="",$D(@RET) S GLO=RET F  S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J  S TXT=@GLO S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP
+ ...S R="" F  S R=$O(RET(R)) Q:R=""  S TXT=RET(R) S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP
+ K GLO,L,R,SL
+ S VALMCNT=LIN-1
+ Q
+ ;
+ADDTMP ;Set string into the array.
+ S ^TMP("RGEXC7",$J,LIN,0)=STR
+ S ^TMP("RGEXC7",$J,"IDX",LIN,LIN)=""
+ S LIN=LIN+1,STR=""
+ Q
+ ;
+HELP ; -- help code
+ S X="?" D DISP^XQORM1 W !!
+ Q
+ ;
+EXIT ; -- exit code
+ S VALMBCK=""
+ K ^TMP("RGEXC7",$J),GLO,L,LIN,R,RESULT,RET,RETURN,SL,STATUS,STR,TXT,X
+ S VALMBCK="R"
+ Q
+ ;
+EXPND ; -- expand code
+ Q
+ ;
Index: WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEXHND1.m
===================================================================
--- WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEXHND1.m	(revision 613)
+++ WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEXHND1.m	(revision 623)
@@ -1,172 +1,175 @@
-RGEXHND1	;BAY/ALS-MPI/PD EXCEPTION HANDLING UTILITY ;10/08/99
-	;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45,52**;30 Apr 99;Build 2
-DTLIST	;List exceptions by date
-	K ^TMP("RGEXC",$J)
-	I '$D(RGBG) S VALMBG=1
-	;**45 list exception 234 first regardless of date - Primary View Reject
-	S EXCDT="",EXCTYP=234,(CNT,IEN)=0
-	F  S IEN=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP,IEN)) Q:'IEN  D
-	.S IEN2=0
-	.F  S IEN2=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP,IEN,IEN2)) Q:'IEN2  D
-	..S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3)
-	..D ADDREC
-	S EXCDT="",EXCTYP=""
-	F  S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT  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  D
-	... S IEN2=0
-	... F  S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2  D
-	.... S EXCTYP=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",3)
-	....;don't include 234 below; those were done first (above).
-	.... I EXCTYP=218 D ADDREC  ;**45;MPIC_772; **52 remove 215, 216, and 217
-	K I,NUM,EXCDT,EXCTYP,RGBG
-	IF CNT<1 D NDATA
-	Q
-	;
-NDATA	; There is no data matching the criteria
-	S CNT=CNT+1,STRING=""
-	S STRING=$$SETSTR^VALM1("There were no exceptions found.",STRING,5,35)
-	S ^TMP("RGEXC",$J,CNT,0)=STRING
-	S ^TMP("RGEXC",$J,"IDX",CNT,CNT)=""
-	S VALMCNT=CNT
-	Q
-EXCLST	;List exceptions by type
-	K ^TMP("RGEXC",$J)
-	S CNT=0,EXCDT="",EXCTYP=""
-	I '$D(RGBG) S VALMBG=1
-	F  S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP  D
-	. I (EXCTYP=234)!(EXCTYP=218) D  ;**45;MPIC_772; **52 remove 215, 216, and 217
-	.. S IEN=0
-	.. F  S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN  D
-	... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1  D
-	.... S IEN2=0
-	.... F  S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2  D
-	..... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT
-	..... D ADDREC
-	IF CNT<1 D NDATA
-	K RGBG
-	Q
-PATLST	;List exceptions by patient
-	K ^TMP("RGEXC",$J),^TMP("RGEX01",$J)
-	S CNT=0,EXCDT="",EXCTYP="",NDX=0,NAME=""
-	I '$D(RGBG) S VALMBG=1
-	F  S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP  D
-	. I (EXCTYP=234)!(EXCTYP=218) D  ;**45;MPIC_772; **52 remove 215, 216, and 217
-	.. S DFN=""
-	.. F  S DFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN)) Q:'DFN  D
-	... S IEN=0
-	... F  S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN,IEN)) Q:'IEN  D
-	.... S IEN2=0
-	.... F  S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN,IEN,IEN2)) Q:'IEN2  D
-	..... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT
-	..... D DEM^VADPT S NAME=VADM(1) Q:NAME=""
-	..... S NDX=NDX+1
-	..... S ^TMP("RGEX01",$J,NAME,NDX)=$G(VADM(1))_"^"_IEN_"^"_IEN2_"^"_EXCTYP_"^"_EXCDT
-	D PATTMP
-	IF CNT<1 D NDATA
-	K DFN,RGBG
-	Q
-PATTMP	;
-	S NM=""
-	F  S NM=$O(^TMP("RGEX01",$J,NM)) Q:NM=""  D
-	. S NDX=0
-	. F  S NDX=$O(^TMP("RGEX01",$J,NM,NDX)) Q:'NDX  D
-	.. S IEN=$P(^TMP("RGEX01",$J,NM,NDX),"^",2)
-	.. S IEN2=$P(^TMP("RGEX01",$J,NM,NDX),"^",3)
-	.. S EXCTYP=$P(^TMP("RGEX01",$J,NM,NDX),"^",4)
-	.. S EXCDT=$P(^TMP("RGEX01",$J,NM,NDX),"^",5)
-	.. D ADDREC
-	K NDX,NM,NAME
-	Q
-SELTYP	; List all exceptions of type selected by user
-	S EXCTYPE="",FLAG=0,ETYPE=""
-	I '$D(RGBG) S VALMBG=1
-	K DIR,Y,DIC
-	S DIR("A")="Enter an exception type to view: "
-	S DIR(0)="SAM^218:Potential Matches Returned;234:Primary View Reject" ;**43;**45;MPIC_772; **52 remove 215, 216, and 217
-	S DIR("?")="^D HLPSEL^RGEXHND1"
-	D ^DIR
-	I Y<1 S RGSORT="SD" D SORT^RGEX01  Q
-	Q:$D(DUOUT)!$D(DTOUT)
-	S EXCTYPE=+Y,ETYPE=$P(^RGHL7(991.11,EXCTYPE,10),"^",1)
-	I (EXCTYPE=234)!(EXCTYPE=218) S FLAG=1 ;**43;**45;MPIC_772; **52 remove 215, 216, and 217
-	I FLAG=1 D ADDSEL
-	E  I FLAG=0 D
-	. W !,"Not a valid selection."
-	. D SELTYP
-	K FLAG,Y,DIR,DIC,DTOUT,DUOUT,RGBG
-	Q
-ADDSEL	;called by SELTYP
-	K ^TMP("RGEXC",$J)
-	S CNT=0,EXCDT="",EXCTYP=""
-	F  S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP  D
-	. I EXCTYP=EXCTYPE D
-	.. S IEN=0
-	.. 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 EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT  ;**43
-	.... D ADDREC
-	I CNT<1 D
-	. W !,"There are no "_ETYPE
-	. W !,"exceptions that need processing."
-	. D SELTYP
-	Q
-HLPSEL	;
-	D FULL^VALM1
-	;W !,"The following exception types are handled by this option:"
-	;W !,"Potential Matches Returned",?50,"(218)"
-	;W !,"Primary View Reject",?50,"(234)"
-	S VALMBCK="R"
-	Q
-ADDREC	;
-	S ETEXT="",RGDFN="",ICN="",RGNM="",STAT="",DOD=""
-	S ETEXT=$P($G(^RGHL7(991.11,EXCTYP,10)),"^",1)
-	S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN
-	S STAT=$P($G(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5)
-	S ICN=+$$GETICN^MPIF001(RGDFN)
-	S HOME=$$SITE^VASITE()
-	I (STAT<1)!(STAT="") D
-	.;Only list exceptions that are Not Processed
-	.; only list patients with local ICN, or for exceptions 234 or 218;MPIC_772; **52 remove 215, 216, and 217
-	. I $E(ICN,1,3)=$E($P(HOME,"^",3),1,3)!(ICN<0)!(EXCTYP=234)!(EXCTYP=218) D  ;**43,**45,**52
-	.. S DFN=RGDFN D DEM^VADPT
-	.. S RGNM=VADM(1)
-	.. S RGSSN=$P($G(VADM(2)),"^",1)
-	.. S DOB=$G(VADM(3)) I DOB="" S DOB="^"
-	.. S DOD=$P($P($G(VADM(6)),"^",2),"@",1)
-	.. S EXDATE=$P($$FMTE^XLFDT(EXCDT,2),"@",1)
-	.. S CNT=CNT+1
-	.. S STRING=""
-	.. I ICN<0 S ICN=""
-	.. S STRING=$$SETSTR^VALM1(CNT,STRING,1,4)
-	.. S STRING=$$SETSTR^VALM1($E(RGNM,1,22),STRING,6,21)
-	.. S STRING=$$SETSTR^VALM1(RGSSN,STRING,28,10)
-	.. S STRING=$$SETSTR^VALM1(EXDATE,STRING,39,8)
-	.. S STRING=$$SETSTR^VALM1(ETEXT,STRING,49,32)
-	.. S ^TMP("RGEXC",$J,CNT,0)=STRING
-	.. S ^TMP("RGEXC",$J,"IDX",CNT,CNT)=""
-	.. S ^TMP("RGEXC",$J,CNT,"DATA")=RGNM_"^"_RGSSN_"^"_$P($$FMTE^XLFDT(EXCDT),"@",1)_"^"_ETEXT_"^"_DFN_"^"_ICN_"^"_DOB_"^"_STAT_"^"_IEN_"^"_IEN2_"^"_CNT_"^"_DOD
-	S VALMCNT=CNT
-	K RGDFN,RGNM,RGSSN,EXDATE,ETEXT,ICN,DOB,STAT,VADM,HOME,STRING,DOD
-	Q
-SELECT	;
-	I $G(STRING)["no exceptions found" D SORT^RGEX01  Q
-	N VALMY
-	D EN^VALM2(XQORNOD(0),"OS")
-	I '$D(VALMY) Q
-	S VALMCNT=CNT
-	S DATA="",CNT=""
-	S CNT=$O(VALMY(0))
-	S DATA=$G(^TMP("RGEXC",$J,CNT,"DATA"))
-	I '$D(DATA) S CNT=0 Q
-	D CLEAN^VALM10
-	D EN^RGEX03(DATA)
-	I RGSORT="VT" D
-	. K @VALMAR
-	. D ADDSEL
-	E  I RGSORT'="VT" D SORT^RGEX01
-	;
-	Q
-QUIT	;
+RGEXHND1 ;BAY/ALS-MPI/PD EXCEPTION HANDLING UTILITY ;10/08/99
+ ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45**;30 Apr 99;Build 9
+DTLIST ;List exceptions by date
+ K ^TMP("RGEXC",$J)
+ I '$D(RGBG) S VALMBG=1
+ ;**45 list exception 234 first regardless of date - Primary View Reject
+ S EXCDT="",EXCTYP=234,(CNT,IEN)=0
+ F  S IEN=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP,IEN)) Q:'IEN  D
+ .S IEN2=0
+ .F  S IEN2=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP,IEN,IEN2)) Q:'IEN2  D
+ ..S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3)
+ ..D ADDREC
+ S EXCDT="",EXCTYP=""
+ F  S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT  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  D
+ ... S IEN2=0
+ ... F  S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2  D
+ .... S EXCTYP=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",3)
+ ....;don't include 234 below; those were done first (above).
+ .... I ((EXCTYP>214)&(EXCTYP<219)) D ADDREC  ;**45
+ K I,NUM,EXCDT,EXCTYP,RGBG
+ IF CNT<1 D NDATA
+ Q
+ ;
+NDATA ; There is no data matching the criteria
+ S CNT=CNT+1,STRING=""
+ S STRING=$$SETSTR^VALM1("There were no exceptions found.",STRING,5,35)
+ S ^TMP("RGEXC",$J,CNT,0)=STRING
+ S ^TMP("RGEXC",$J,"IDX",CNT,CNT)=""
+ S VALMCNT=CNT
+ Q
+EXCLST ;List exceptions by type
+ K ^TMP("RGEXC",$J)
+ S CNT=0,EXCDT="",EXCTYP=""
+ I '$D(RGBG) S VALMBG=1
+ F  S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP  D
+ . I (EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219)) D  ;**45
+ .. S IEN=0
+ .. F  S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN  D
+ ... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1  D
+ .... S IEN2=0
+ .... F  S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2  D
+ ..... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT
+ ..... D ADDREC
+ IF CNT<1 D NDATA
+ K RGBG
+ Q
+PATLST ;List exceptions by patient
+ K ^TMP("RGEXC",$J),^TMP("RGEX01",$J)
+ S CNT=0,EXCDT="",EXCTYP="",NDX=0,NAME=""
+ I '$D(RGBG) S VALMBG=1
+ F  S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP  D
+ . I (EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219)) D  ;**45
+ .. S DFN=""
+ .. F  S DFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN)) Q:'DFN  D
+ ... S IEN=0
+ ... F  S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN,IEN)) Q:'IEN  D
+ .... S IEN2=0
+ .... F  S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN,IEN,IEN2)) Q:'IEN2  D
+ ..... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT
+ ..... D DEM^VADPT S NAME=VADM(1) Q:NAME=""
+ ..... S NDX=NDX+1
+ ..... S ^TMP("RGEX01",$J,NAME,NDX)=$G(VADM(1))_"^"_IEN_"^"_IEN2_"^"_EXCTYP_"^"_EXCDT
+ D PATTMP
+ IF CNT<1 D NDATA
+ K DFN,RGBG
+ Q
+PATTMP ;
+ S NM=""
+ F  S NM=$O(^TMP("RGEX01",$J,NM)) Q:NM=""  D
+ . S NDX=0
+ . F  S NDX=$O(^TMP("RGEX01",$J,NM,NDX)) Q:'NDX  D
+ .. S IEN=$P(^TMP("RGEX01",$J,NM,NDX),"^",2)
+ .. S IEN2=$P(^TMP("RGEX01",$J,NM,NDX),"^",3)
+ .. S EXCTYP=$P(^TMP("RGEX01",$J,NM,NDX),"^",4)
+ .. S EXCDT=$P(^TMP("RGEX01",$J,NM,NDX),"^",5)
+ .. D ADDREC
+ K NDX,NM,NAME
+ Q
+SELTYP ; List all exceptions of type selected by user
+ S EXCTYPE="",FLAG=0,ETYPE=""
+ I '$D(RGBG) S VALMBG=1
+ K DIR,Y,DIC
+ S DIR("A")="Enter an exception type to view: "
+ S DIR(0)="SAM^215:Death Entry on MPI not VISTA;216:Death Entry on Vista not MPI;217:Death Entries on MPI and Vista DON'T MATCH;218:Potential Matches Returned;234:Primary View Reject" ;**43,45
+ S DIR("?")="^D HLPSEL^RGEXHND1"
+ D ^DIR
+ I Y<1 S RGSORT="SD" D SORT^RGEX01  Q
+ Q:$D(DUOUT)!$D(DTOUT)
+ S EXCTYPE=+Y,ETYPE=$P(^RGHL7(991.11,EXCTYPE,10),"^",1)
+ I (EXCTYPE=234)!((EXCTYPE>214)&(EXCTYPE<219)) S FLAG=1 ;**43,45
+ I FLAG=1 D ADDSEL
+ E  I FLAG=0 D
+ . W !,"Not a valid selection."
+ . D SELTYP
+ K FLAG,Y,DIR,DIC,DTOUT,DUOUT,RGBG
+ Q
+ADDSEL ;called by SELTYP
+ K ^TMP("RGEXC",$J)
+ S CNT=0,EXCDT="",EXCTYP=""
+ F  S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP  D
+ . I EXCTYP=EXCTYPE D
+ .. S IEN=0
+ .. 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 EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT  ;**43
+ .... D ADDREC
+ I CNT<1 D
+ . W !,"There are no "_ETYPE
+ . W !,"exceptions that need processing."
+ . D SELTYP
+ Q
+HLPSEL ;
+ D FULL^VALM1
+ ;W !,"The following exception types are handled by this option:"
+ ;W !!,"Death Entry on MPI not in VISTA",?50,"(215)"
+ ;W !,"Death Entry on Vista not in MPI",?50,"(216)"
+ ;W !,"Death Entries on MPI and Vista DO NOT MATCH",?50,"(217)"
+ ;W !,"Potential Matches Returned",?50,"(218)"
+ ;W !,"Primary View Reject",?50,"(234)"
+ S VALMBCK="R"
+ Q
+ADDREC ;
+ S ETEXT="",RGDFN="",ICN="",RGNM="",STAT="",DOD=""
+ S ETEXT=$P($G(^RGHL7(991.11,EXCTYP,10)),"^",1)
+ S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN
+ S STAT=$P($G(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5)
+ S ICN=+$$GETICN^MPIF001(RGDFN)
+ S HOME=$$SITE^VASITE()
+ I (STAT<1)!(STAT="") D
+ .;Only list exceptions that are Not Processed
+ .; only list patients with local ICN, or for exceptions 234, 215 - 218
+ . I $E(ICN,1,3)=$E($P(HOME,"^",3),1,3)!(ICN<0)!(EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219)) D  ;**43,45
+ .. S DFN=RGDFN D DEM^VADPT
+ .. S RGNM=VADM(1)
+ .. S RGSSN=$P($G(VADM(2)),"^",1)
+ .. S DOB=$G(VADM(3)) I DOB="" S DOB="^"
+ .. S DOD=$P($P($G(VADM(6)),"^",2),"@",1)
+ .. S EXDATE=$P($$FMTE^XLFDT(EXCDT,2),"@",1)
+ .. S CNT=CNT+1
+ .. S STRING=""
+ .. I ICN<0 S ICN=""
+ .. S STRING=$$SETSTR^VALM1(CNT,STRING,1,4)
+ .. S STRING=$$SETSTR^VALM1($E(RGNM,1,22),STRING,6,21)
+ .. S STRING=$$SETSTR^VALM1(RGSSN,STRING,28,10)
+ .. S STRING=$$SETSTR^VALM1(EXDATE,STRING,39,8)
+ .. S STRING=$$SETSTR^VALM1(ETEXT,STRING,49,32)
+ .. S ^TMP("RGEXC",$J,CNT,0)=STRING
+ .. S ^TMP("RGEXC",$J,"IDX",CNT,CNT)=""
+ .. S ^TMP("RGEXC",$J,CNT,"DATA")=RGNM_"^"_RGSSN_"^"_$P($$FMTE^XLFDT(EXCDT),"@",1)_"^"_ETEXT_"^"_DFN_"^"_ICN_"^"_DOB_"^"_STAT_"^"_IEN_"^"_IEN2_"^"_CNT_"^"_DOD
+ S VALMCNT=CNT
+ K RGDFN,RGNM,RGSSN,EXDATE,ETEXT,ICN,DOB,STAT,VADM,HOME,STRING,DOD
+ Q
+SELECT ;
+ I $G(STRING)["no exceptions found" D SORT^RGEX01  Q
+ N VALMY
+ D EN^VALM2(XQORNOD(0),"OS")
+ I '$D(VALMY) Q
+ S VALMCNT=CNT
+ S DATA="",CNT=""
+ S CNT=$O(VALMY(0))
+ S DATA=$G(^TMP("RGEXC",$J,CNT,"DATA"))
+ I '$D(DATA) S CNT=0 Q
+ D CLEAN^VALM10
+ D EN^RGEX03(DATA)
+ I RGSORT="VT" D
+ . K @VALMAR
+ . D ADDSEL
+ E  I RGSORT'="VT" D SORT^RGEX01
+ ;
+ Q
+QUIT ;