Changeset 623 for WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- Location:
- WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB
- Files:
-
- 5 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEVPRG.m
r613 r623 1 RGEVPRG ;BAY/ALS-OPTIONS TO PURGE MPI/PD EXCEPTIONS ;08/23/99 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,32,35,43,44,50,52**;30 Apr 99;Build 2 3 ; 4 MAIN ; 5 ;Q:($D(^TMP("RGEXC")))!($D(^TMP("RGEXC2"))) 6 L +^RGHL7(991.1):0 I '$T Q 7 L -^RGHL7(991.1) 8 L +^RGHL7(991.1,"RG PURGE EXCEPTION"):5 E Q 9 I $D(ZTQUEUED) S ZTREQ="@" 10 S $P(^RGSITE(991.8,1,"EXCPRG"),"^",1)=$$NOW^XLFDT 11 S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="R" 12 ;D PROC ;**52 Module is obsolete 13 D PRGDUP 14 D PRG30 15 D PRGZZ 16 S $P(^RGSITE(991.8,1,"EXCPRG"),"^",2)=$$NOW^XLFDT 17 S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="C" 18 L -^RGHL7(991.1,"RG PURGE EXCEPTION") 19 Q 20 PRGPAT ;Purge by Patient 21 W ! 22 S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: " 23 D ^DIC K DIC G:Y<0 QUIT S RGDFN=+Y 24 S EXCT="",FLAG=0 25 F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:EXCT="" D 26 . I $D(^RGHL7(991.1,"ADFN",EXCT,RGDFN)) S FLAG=1 Q 27 I FLAG=0 W !,"There are no exceptions on file for this patient." G PRGPAT 28 I $$IFLOCAL^MPIF001(RGDFN) W !,"This patient does not have a national ICN assigned, do not purge." Q 29 S DFN=RGDFN D DEM^VADPT 30 S DIR(0)="YA",DIR("B")="YES" 31 S DIR("A")="Are you sure you want to purge all exceptions on file for "_VADM(1)_"? YES// " 32 D ^DIR Q:$D(DIRUT) I Y>0 D 33 . S EXCT="",CNT=0 34 . F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:'EXCT D 35 .. S IEN=0 36 .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN)) Q:'IEN D 37 ... S IEN2=0 38 ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN,IEN2)) Q:'IEN2 D 39 .... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) 40 .... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1 41 .... E I NUM>1 D DEL 42 . W !,"All exceptions purged for "_VADM(1)_" DFN: "_RGDFN 43 K EXCT,DFN,FLAG,VADM,CNT,IEN,IEN2,NUM,RGDFN,Y 44 QUIT Q 45 ; 46 PRGDT ; Purge by Date 47 W !!,"Enter a date for the purge. All exceptions on file, on or before that date, will be deleted." 48 K DIR,DIRUT,DTOUT,DUOUT 49 S DIR(0)="DA^:DT:EPX",DIR("A")="Enter Date for Purge: " 50 D ^DIR K DIR Q:$D(DIRUT) 51 S PURDT=Y 52 S PDATE=$$FMTE^XLFDT(PURDT) 53 S DIR(0)="YA",DIR("B")="YES" 54 S DIR("A")="Are you sure you want to purge all exceptions on file dated on or before "_PDATE_"? YES// " 55 D ^DIR Q:$D(DIRUT) I Y>0 D 56 . S EXCDT="",CNT=0 57 . F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D 58 .. I ($P(EXCDT,".",1)=PURDT)!($P(EXCDT,".",1)<PURDT) D 59 ... S IEN=0 60 ... F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D 61 .... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1 62 .... S CNT=CNT+NUM 63 .... S DIK="^RGHL7(991.1,",DA=IEN 64 .... D ^DIK K DIK,DA 65 I CNT=0 W !,"There are no exceptions dated on or before "_PDATE_", no data to purge." 66 E I CNT>0 W !,CNT_" exceptions, dated on or before "_PDATE_" have been purged!" 67 K PDATE,PURDT,EXCDT,CNT,IEN,NUM,Y 68 Q 69 PRG30 ; Purge Exceptions over 30 days old 70 S TODAY="" 71 S TODAY=$$NOW^XLFDT D 72 . S EXCDT="",CNT=0,DIFF="" 73 . F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D 74 .. S DIFF=$$FMDIFF^XLFDT(TODAY,EXCDT) 75 .. I DIFF>30 D 76 ... S IEN=0 77 ... F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D 78 .... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:'NUM 79 .... S IEN2=0 80 .... F S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2 D 81 ..... S STAT="" 82 ..... S STAT=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",5) 83 ..... ; Only delete PROCESSED exceptions 84 ..... I (STAT>0)!(STAT="") D 85 ...... I NUM>1 D DEL 86 ...... E I NUM=1 D 87 ....... S CNT=CNT+NUM 88 ....... S DIK="^RGHL7(991.1,",DA=IEN 89 ....... D ^DIK K DIK,DA 90 K DIFF,TODAY,EXCDT,CNT,IEN,IEN2,NUM,STAT 91 Q 92 PRGEXC ; Purge by Exception Type 93 ;**52 This module was obsolete before 52; just adding comment 94 ;S DIC="^RGHL7(991.11,",DIC(0)="QEAM" 95 ;S DIC("A")="Enter an exception type to purge: " 96 ;D ^DIC K DIC G:Y<200 QUIT S EXCTYP=+Y,ETYPE=X 97 ;S DIR(0)="YA",DIR("B")="YES" 98 ;S DIR("A")="*WARNING* This will permanently delete all "_ETYPE_" exceptions. Are you sure you want to do this? YES// " 99 ;D ^DIR Q:$D(DIRUT) I Y>0 D 100 ;. S CNT=0,IEN="" 101 ;. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D 102 ;.. S IEN2=0 103 ;.. F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D 104 ;... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) 105 ;... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1 106 ;... E I NUM>1 D DEL 107 ;I CNT=0 W !,"There are no "_ETYPE_" exceptions on file." 108 ;E I CNT>0 W !,CNT_" "_ETYPE_" Exceptions purged!" 109 ;K ETYPE,CNT,IEN,IEN2,NUM,X,Y 110 Q ;**52;if module accidentally called, should quit instead of falling into next module. 111 PRGDUP ;Purge Duplicate Entries; retain most recent for all except types. 112 ;**50 through remainder of module. 113 S EXCTYP="",CNT=0 114 K ^TMP("RGEVDUP",$J) 115 F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D 116 . S RGDFN="" 117 . F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D 118 .. S IEN=0 119 .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D 120 ... S IEN2=0 121 ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D 122 .... I $P($G(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5)=1 K ^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2) Q ;exception processed 123 .... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) ;incoming date 124 .... I '$D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D Q 125 ..... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2 126 .... I $D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D ;duplicate exists; compare incoming to previous. 127 ..... S OLDNODE=^TMP("RGEVDUP",$J,RGDFN,EXCTYP) 128 ..... S OLDDT=$P(OLDNODE,"^"),OLDIEN=$P(OLDNODE,"^",2),OLDIEN2=$P(OLDNODE,"^",3) 129 ..... I EXCDT>OLDDT D Q ;incoming date greater than previous? purge old, keep new. 130 ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) 131 ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=OLDIEN D ^DIK K DIK,DA 132 ...... I NUM>1 D 133 ....... S DA(1)=OLDIEN,DA=OLDIEN2 134 ....... S DIK="^RGHL7(991.1,"_DA(1)_",1," D ^DIK K DIK,DA 135 ...... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2 136 ..... ; 137 ..... I OLDDT>EXCDT!(OLDDT=EXCDT) D ;previous date greater or equal incoming? purge new, keep old. 138 ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) 139 ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA 140 ...... I NUM>1 D DEL 141 ...... ; 142 K CNT,EXCDT,EXCTYP,IEN,IEN2,NUM,OLDDT,OLDIEN,OLDIEN2,OLDNODE,RGDFN,RGDT,^TMP("RGEVDUP") 143 Q 144 ; 145 PRGZZ ;Purge if name field is null (incomplete record) 146 ;Purge if -9 node exists, this indicates the record has been merged. 147 S EXCTYP="",CNT="" 148 F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D 149 . S RGDFN="" 150 . F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D 151 .. S IEN=0 152 .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D 153 ... S IEN2=0 154 ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D 155 .... S DFN=RGDFN D DEM^VADPT 156 .... I VADM(1)=""!($D(^DPT(RGDFN,-9))) D 157 ..... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) 158 ..... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA 159 ..... E I NUM>1 D DEL 160 K EXCTYP,RGDFN,DFN,IEN,IEN2,NUM,VADM 161 Q 162 DEL ; 163 S CNT=CNT+1 164 S DA(1)=IEN,DA=IEN2 165 S DIK="^RGHL7(991.1,"_DA(1)_",1," 166 D ^DIK K DIK,DA 167 Q 168 PROC ;Set these exception types to PROCESSED if they have a national ICN 169 ;**52 The PROC module is obsolete and is no longer being called. 170 ;209 - Required field(s) missing for patient sent to MPI, 171 ;227 - Multiple ICNs, 213 - SSN Match Failed, 214 - Name Doesn't Match 172 ;S EXCTYP="" 173 ;S HOME=$$SITE^VASITE() 174 ;F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D 175 ;. I (EXCTYP=209)!(EXCTYP=227)!(EXCTYP=213)!(EXCTYP=214) D ;**43 176 ;.. S IEN=0 177 ;.. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D 178 ;... S IEN2=0,ICN="",RGDFN="" 179 ;... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D 180 ;.... S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN 181 ;.... S ICN=+$$GETICN^MPIF001(RGDFN) 182 ;.... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D 183 ;..... L +^RGHL7(991.1,IEN):10 184 ;..... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1," 185 ;..... D ^DIE K DIE,DA,DR 186 ;..... L -^RGHL7(991.1,IEN) 187 ;K EXCTYP,HOME,ICN,IEN,IEN2,RGDFN 188 Q 1 RGEVPRG ;BAY/ALS-OPTIONS TO PURGE MPI/PD EXCEPTIONS ;08/23/99 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,32,35,43,44**;30 Apr 99;Build 8 3 ; 4 MAIN ; 5 ;Q:($D(^TMP("RGEXC")))!($D(^TMP("RGEXC2"))) 6 L +^RGHL7(991.1):0 I '$T Q 7 L -^RGHL7(991.1) 8 L +^RGHL7(991.1,"RG PURGE EXCEPTION"):5 E Q 9 I $D(ZTQUEUED) S ZTREQ="@" 10 S $P(^RGSITE(991.8,1,"EXCPRG"),"^",1)=$$NOW^XLFDT 11 S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="R" 12 D PROC 13 D PRGDUP 14 D PRG30 15 D PRGZZ 16 S $P(^RGSITE(991.8,1,"EXCPRG"),"^",2)=$$NOW^XLFDT 17 S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="C" 18 L -^RGHL7(991.1,"RG PURGE EXCEPTION") 19 Q 20 PRGPAT ;Purge by Patient 21 W ! 22 S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: " 23 D ^DIC K DIC G:Y<0 QUIT S RGDFN=+Y 24 S EXCT="",FLAG=0 25 F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:EXCT="" D 26 . I $D(^RGHL7(991.1,"ADFN",EXCT,RGDFN)) S FLAG=1 Q 27 I FLAG=0 W !,"There are no exceptions on file for this patient." G PRGPAT 28 I $$IFLOCAL^MPIF001(RGDFN) W !,"This patient does not have a national ICN assigned, do not purge." Q 29 S DFN=RGDFN D DEM^VADPT 30 S DIR(0)="YA",DIR("B")="YES" 31 S DIR("A")="Are you sure you want to purge all exceptions on file for "_VADM(1)_"? YES// " 32 D ^DIR Q:$D(DIRUT) I Y>0 D 33 . S EXCT="",CNT=0 34 . F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:'EXCT D 35 .. S IEN=0 36 .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN)) Q:'IEN D 37 ... S IEN2=0 38 ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN,IEN2)) Q:'IEN2 D 39 .... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) 40 .... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1 41 .... E I NUM>1 D DEL 42 . W !,"All exceptions purged for "_VADM(1)_" DFN: "_RGDFN 43 K EXCT,DFN,FLAG,VADM,CNT,IEN,IEN2,NUM,RGDFN,Y 44 QUIT Q 45 ; 46 PRGDT ; Purge by Date 47 W !!,"Enter a date for the purge. All exceptions on file, on or before that date, will be deleted." 48 K DIR,DIRUT,DTOUT,DUOUT 49 S DIR(0)="DA^:DT:EPX",DIR("A")="Enter Date for Purge: " 50 D ^DIR K DIR Q:$D(DIRUT) 51 S PURDT=Y 52 S PDATE=$$FMTE^XLFDT(PURDT) 53 S DIR(0)="YA",DIR("B")="YES" 54 S DIR("A")="Are you sure you want to purge all exceptions on file dated on or before "_PDATE_"? YES// " 55 D ^DIR Q:$D(DIRUT) I Y>0 D 56 . S EXCDT="",CNT=0 57 . F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D 58 .. I ($P(EXCDT,".",1)=PURDT)!($P(EXCDT,".",1)<PURDT) D 59 ... S IEN=0 60 ... F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D 61 .... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1 62 .... S CNT=CNT+NUM 63 .... S DIK="^RGHL7(991.1,",DA=IEN 64 .... D ^DIK K DIK,DA 65 I CNT=0 W !,"There are no exceptions dated on or before "_PDATE_", no data to purge." 66 E I CNT>0 W !,CNT_" exceptions, dated on or before "_PDATE_" have been purged!" 67 K PDATE,PURDT,EXCDT,CNT,IEN,NUM,Y 68 Q 69 PRG30 ; Purge Exceptions over 30 days old 70 S TODAY="" 71 S TODAY=$$NOW^XLFDT D 72 . S EXCDT="",CNT=0,DIFF="" 73 . F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D 74 .. S DIFF=$$FMDIFF^XLFDT(TODAY,EXCDT) 75 .. I DIFF>30 D 76 ... S IEN=0 77 ... F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D 78 .... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:'NUM 79 .... S IEN2=0 80 .... F S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2 D 81 ..... S STAT="" 82 ..... S STAT=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",5) 83 ..... ; Only delete PROCESSED exceptions 84 ..... I (STAT>0)!(STAT="") D 85 ...... I NUM>1 D DEL 86 ...... E I NUM=1 D 87 ....... S CNT=CNT+NUM 88 ....... S DIK="^RGHL7(991.1,",DA=IEN 89 ....... D ^DIK K DIK,DA 90 K DIFF,TODAY,EXCDT,CNT,IEN,IEN2,NUM,STAT 91 Q 92 PRGEXC ; Purge by Exception Type 93 ;S DIC="^RGHL7(991.11,",DIC(0)="QEAM" 94 ;S DIC("A")="Enter an exception type to purge: " 95 ;D ^DIC K DIC G:Y<200 QUIT S EXCTYP=+Y,ETYPE=X 96 ;S DIR(0)="YA",DIR("B")="YES" 97 ;S DIR("A")="*WARNING* This will permanently delete all "_ETYPE_" exceptions. Are you sure you want to do this? YES// " 98 ;D ^DIR Q:$D(DIRUT) I Y>0 D 99 ;. S CNT=0,IEN="" 100 ;. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D 101 ;.. S IEN2=0 102 ;.. F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D 103 ;... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) 104 ;... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1 105 ;... E I NUM>1 D DEL 106 ;I CNT=0 W !,"There are no "_ETYPE_" exceptions on file." 107 ;E I CNT>0 W !,CNT_" "_ETYPE_" Exceptions purged!" 108 ;K ETYPE,CNT,IEN,IEN2,NUM,X,Y 109 ;Q 110 PRGDUP ; Purge Duplicate Entries; retain most recent for all types except 234. 111 S EXCTYP="",CNT=0 112 K ^TMP("RGEVDUP",$J) 113 F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D 114 . I EXCTYP=234 Q ;**44 process 234s separately below 115 . S RGDFN="" 116 . F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D 117 .. S IEN=0 118 .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D 119 ... S IEN2=0 120 ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D 121 .... S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3) 122 .... I '$D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D Q 123 ..... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2 124 .... I $D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D 125 ..... S OLDNODE=^TMP("RGEVDUP",$J,RGDFN,EXCTYP) 126 ..... S OLDDT=$P(OLDNODE,"^") 127 ..... I EXCDT>OLDDT D Q 128 ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) 129 ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=$P(OLDNODE,"^",2) D ^DIK K DIK,DA 130 ...... E I NUM>1 D 131 ....... S DA(1)=$P(OLDNODE,"^",2),DA=$P(OLDNODE,"^",3) 132 ....... S DIK="^RGHL7(991.1,"_DA(1)_",1," D ^DIK K DIK,DA 133 ...... S CNT=CNT+1 134 ...... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2 135 ..... I OLDDT>EXCDT!(OLDDT=EXCDT) D 136 ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) 137 ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1 138 ...... E I NUM>1 D DEL 139 ; W !,CNT_" Duplicate entries" 140 ;Process PRIMARY VIEW REJECT (234) duplicates; purge if for SAME day. 141 ;**44 through remainder of module. 142 K ^TMP("RGDFNDT",$J) S RGDFN="" 143 F S RGDFN=$O(^RGHL7(991.1,"ADFN",234,RGDFN)) Q:'RGDFN D 144 .S IEN=0 145 .F S IEN=$O(^RGHL7(991.1,"ADFN",234,RGDFN,IEN)) Q:'IEN D 146 ..S IEN2=0 147 ..F S IEN2=$O(^RGHL7(991.1,"ADFN",234,RGDFN,IEN,IEN2)) Q:'IEN2 D 148 ...S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3) 149 ...;How many for each DFN? Store in ^TMP("RGDFNDT") 150 ...I '$D(^TMP("RGDFNDT",$J,RGDFN)) S ^TMP("RGDFNDT",$J,RGDFN)=0 151 ...I $D(^TMP("RGDFNDT",$J,RGDFN)) D 152 ....S ^TMP("RGDFNDT",$J,RGDFN)=^TMP("RGDFNDT",$J,RGDFN)+1 153 ....S ^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2)=$P(EXCDT,".") ;date only/no time 154 ;If RGDFN has more than 1 exception, see if any are for same DAY. 155 ;Process the ^TMP("RGDFNDT",$J global to build LOC array. 156 I $D(^TMP("RGDFNDT",$J)) D 157 .S RGDFN="" 158 .F S RGDFN=$O(^TMP("RGDFNDT",$J,RGDFN)) Q:'RGDFN D 159 ..;If only one 234 exception for DFN ignore it. 160 ..I ^TMP("RGDFNDT",$J,RGDFN)=1 Q 161 ..;More than one for this DFN? How many for same day? 162 ..S IEN=0 K LOC 163 ..F S IEN=$O(^TMP("RGDFNDT",$J,RGDFN,IEN)) Q:'IEN D 164 ...S (IEN2,VAL)=0 165 ...F S IEN2=$O(^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2)) Q:'IEN2 D 166 ....S VAL=$P(^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2),"^") 167 ....I '$D(LOC(VAL)) S LOC(VAL)=0 168 ....I $D(LOC(VAL)) D 169 .....S LOC(VAL)=LOC(VAL)+1 170 .....S LOC(VAL,IEN,IEN2)="" 171 ..;Process the LOC array; contains numbers / day / DFN. 172 ..;If only 1 exception / day, keep it. 173 ..S RGDT=0 K CTR,TOT 174 ..F S RGDT=$O(LOC(RGDT)) Q:'RGDT D 175 ...S TOT=LOC(RGDT) 176 ...I TOT=1 K TOT Q ;only 1. 177 ...;More than 1, delete all except 1. 178 ...S TOT=TOT-1 ;leave 1; doesn't matter which - all are same day. 179 ...S IEN=0,CTR=0 180 ...F S IEN=$O(LOC(RGDT,IEN)) Q:'IEN D 181 ....I CTR=TOT Q 182 ....S CTR=CTR+1,IEN2=0 183 ....F S IEN2=$O(LOC(RGDT,IEN,IEN2)) Q:'IEN2 D DEL ;delete entry 184 K CNT,CTR,EXCDT,IEN,IEN2,LOC,NUM,OLDDT,OLDNODE,RGDFN,RGDT,TOT,VAL,^TMP("RGDFNDT") 185 Q 186 PRGZZ ;Purge if name field is null (incomplete record) 187 ;Purge if -9 node exists, this indicates the record has been merged. 188 S EXCTYP="",CNT="" 189 F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D 190 . S RGDFN="" 191 . F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D 192 .. S IEN=0 193 .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D 194 ... S IEN2=0 195 ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D 196 .... S DFN=RGDFN D DEM^VADPT 197 .... I VADM(1)=""!($D(^DPT(RGDFN,-9))) D 198 ..... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) 199 ..... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA 200 ..... E I NUM>1 D DEL 201 K EXCTYP,RGDFN,DFN,IEN,IEN2,NUM,VADM 202 Q 203 DEL ; 204 S CNT=CNT+1 205 S DA(1)=IEN,DA=IEN2 206 S DIK="^RGHL7(991.1,"_DA(1)_",1," 207 D ^DIK K DIK,DA 208 Q 209 PROC ;Set these exception types to PROCESSED if they have a national ICN 210 ;209 - Required field(s) missing for patient sent to MPI, 211 ;227 - Multiple ICNs, 213 - SSN Match Failed, 214 - Name Doesn't Match 212 S EXCTYP="" 213 S HOME=$$SITE^VASITE() 214 F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D 215 . I (EXCTYP=209)!(EXCTYP=227)!(EXCTYP=213)!(EXCTYP=214) D ;**43 216 .. S IEN=0 217 .. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D 218 ... S IEN2=0,ICN="",RGDFN="" 219 ... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D 220 .... S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN 221 .... S ICN=+$$GETICN^MPIF001(RGDFN) 222 .... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D 223 ..... L +^RGHL7(991.1,IEN):10 224 ..... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1," 225 ..... D ^DIE K DIE,DA,DR 226 ..... L -^RGHL7(991.1,IEN) 227 K EXCTYP,HOME,ICN,IEN,IEN2,RGDFN 228 Q -
WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX01.m
r613 r623 1 RGEX01 ;BAY/ALS-LIST MANAGER FOR MPI/PD EXCEPTIONS ;10/07/99 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45,47,48,52**;30 Apr 99;Build 2 3 ; 4 ;Reference to MAIN^VAFCPDAT supported by IA #3299 5 EN ; -- main entry point for RG EXCPT SUMMARY 6 N STDT,ENDDT,PRGSTAT,XFLAG,NOW,%,X,%H,%I,INDT,RUN,INDTT 7 S XFLAG=0 D NOW^%DTC S NOW=% 8 S STDT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",1),INDT=STDT 9 I $D(STDT) S STDT=$$FMTE^XLFDT(STDT,1) 10 S PRGSTAT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",3) 11 ;status shows 'running' but lock shows 'not running';**47 12 I PRGSTAT="R" D 13 .L +^RGHL7(991.1,"RG PURGE EXCEPTION"):0 I $T D ;can get lock 14 ..L +^RGSITE(991.8):10 15 ..S DIE="^RGSITE(991.8,",DA=1,DR="42///@" 16 ..D ^DIE K DA,DIE,DR ;delete old status 17 ..L -^RGSITE(991.8) 18 ..S PRGSTAT="" 19 .L -^RGHL7(991.1,"RG PURGE EXCEPTION") 20 I PRGSTAT="" D 21 . W $C(7) 22 . W !!,"The MPI/PD Exception Purge process has not been run." 23 . ;**48 NO LONGER A CHOICE 24 . W !!,"The MPI/PD Exception Purge process will now run." 25 . W !,"Please come back to this option in five minutes." 26 . W !!,"Please contact IRM to schedule the MPI/PD EXCEPTION PURGE" 27 . W !,"[RG EXCEPTION PURGE] option via TaskMan with a frequency of once an hour." 28 . S XFLAG=1 D QUEPRG 29 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 30 L -^RGHL7(991.1,"RG PURGE EXCEPTION") 31 S RUN=0 32 I $G(PRGSTAT)="C" D 33 . I $P(INDT,".")<$P(NOW,".") S RUN=1 ;RAN A PREVIOUS DAY 34 . I $P(INDT,".")=$P(NOW,".") D 35 .. S INDTT=$E($P(INDT,".",2),1,4),INDTT=INDTT+101 36 .. I INDTT<$E($P(NOW,".",2),1,4) S RUN=1 37 . Q:RUN=0 38 . ;** if job ran more than 1 hour ago, run it now. 39 . W !!,"The MPI/PD Exception Purge process last ran "_STDT_"." 40 . W !!,"The MPI/PD Exception Purge process will now run." 41 . W !,"Please come back to this option in five minutes." 42 . W !!,"Please contact IRM to verify that the MPI/PD EXCEPTION PURGE " 43 . W !,"[RG EXCEPTION PURGE] option is scheduled to run via TaskMan" 44 . W !,"with a frequency of once an hour." 45 . S XFLAG=1 D QUEPRG 46 I XFLAG=1 G EXIT 47 K RGANS 48 D WAIT^DICD 49 D EN^VALM("RG EXCPT SUMMARY") 50 Q 51 ; 52 HDR ; -- header code 53 S VALMHDR(1)="MPI/PD Exception Handling" 54 S VALMHDR(2)="" 55 Q 56 ; 57 INIT ; -- init variables and list array 58 I '$D(RGSORT) S RGSORT="SD" 59 K @VALMAR 60 I RGSORT="SD" D DTLIST^RGEXHND1 61 E I RGSORT="ST" D EXCLST^RGEXHND1 62 E I RGSORT="SN" D PATLST^RGEXHND1 63 E I RGSORT="VT" D SELTYP^RGEXHND1 64 Q 65 ; 66 SORT ; 67 D INIT 68 S VALMBCK="R" 69 Q 70 HELP ; -- help code 71 S X="?" D DISP^XQORM1 W !! 72 Q 73 HLPPRG ; 74 W !,"Enter Y(YES) to run the MPI/PD Exception Purge process now." 75 W !!,"Enter N(NO) to go directly into the MPI/PD Exception Handling option." 76 Q 77 ; 78 EXIT ; -- exit code 79 K VADM,RGDFN,RGNM,RGSORT,RGSSN,STAT,STRING,NDX,NM,IEN,IEN2,X,DATA,CNT,EXCTYPE,ETYPE,^TMP("RGEXC",$J),^TMP("RGEX01",$J) 80 Q 81 QUEPRG S ZTRTN="MAIN^RGEVPRG",ZTDESC="PURGE ZZ*, OVER 30 DAY AND DUPLICATE RECORDS FROM THE CIRN HL7 EXCEPTION LOG FILE" 82 D NOW^%DTC 83 S ZTIO="",ZTDTH=% 84 I $D(DUZ) S ZTSAVE("DUZ")=DUZ 85 D ^%ZTLOAD 86 D HOME^%ZIS K IO("Q") 87 K ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,% 88 Q 89 ; 90 EXPND ; -- expand code 91 Q 92 ; 93 CUREX() ;Are there any patients in the CIRN HL7 EXCEPTION LOG file (#991.1) 94 ;that are NOT PROCESSED for specific exception types? 95 ; Return RGEX: 96 ;If RGEX=3 both unprocessed and Primary View Reject exceptions exist 97 ;If RGEX=2 only Primary View Reject exceptions exist 98 ;If RGEX=1 only unprocessed exceptions exist 99 ;If RGEX=0 no unprocessed exceptions exist 100 ; 101 N EXCTYP,RG1,RG2,RGEX 102 S EXCTYP="",(RG1,RG2,RGEX)=0 103 F S EXCTYP=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP)) Q:'EXCTYP D 104 .I (EXCTYP=234)!(EXCTYP=218) S RG1=1 ;MPIC_772; **52 remove 215, 216, and 217 105 .I (EXCTYP=234) S RG2=1 ;Primary View Reject 106 I (RG1=1),(RG2=1) S RGEX=3 ;Send both messages 107 I (RG1=1),(RG2=0) S RGEX=1 ;Only unresolved exceptions exist 108 I (RG1=0),(RG2=1) S RGEX=2 ;Only Primary View Reject exceptions exist 109 Q RGEX 110 ; 111 PROC ; For a given patient, set exceptions STATUS to PROCESSED. 112 ;**52 The PROC module is obsolete and is no longer being called. 113 ; DFN must be defined 114 ;Q:'$D(DFN) 115 ;S EXCTYP="" 116 ;S HOME=$$SITE^VASITE() 117 ;F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D 118 ;. S RGDFN="",ICN="" 119 ;. F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D 120 ;.. I DFN=RGDFN D 121 ;... S ICN=+$$GETICN^MPIF001(DFN) 122 ;... ;Only set to PROCESSED if patient has national ICN. 123 ;... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D 124 ;.... ;Exclude Death exceptions (215-217); they must be processed manually. 125 ;.... ;Exclude 218 Potential Matches Returned exception **43 126 ;.... I (EXCTYP>218)!(EXCTYP<215) D 127 ;..... S IEN=0 128 ;..... F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D 129 ;...... S IEN2=0 130 ;...... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D 131 ;....... L +^RGHL7(991.1,IEN):10 132 ;....... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1," 133 ;....... D ^DIE K DIE,DA,DR 134 ;....... L -^RGHL7(991.1,IEN) 135 ;K IEN,IEN2,RGDFN,EXCTYP,ICN 136 Q 137 PDAT ; 138 K DIRUT 139 W !,"This report prints MPI/PD Data for a selected patient. The" 140 W !,"information displayed includes the Integration Control Number" 141 W !,"(ICN), patient identity information, and Treating Facility list." 142 W !!,"The information is pulled from the Patient (#2) file and the" 143 W !,"Treating Facility List (#391.91) file." 144 ; 145 ASK ;Ask for PATIENT 146 I $D(DIRUT) G QUIT 147 W !!,"Patient lookup can be done by Patient Name/SSN or by ICN.",! 148 N DFN,ICN 149 S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: ",D="SSN^AICN^B^BS^BS5" 150 D MIX^DIC1 K DIC 151 G:Y<0 QUIT 152 S DFN=+Y 153 D MAIN^VAFCPDAT 154 G ASK 155 Q 156 QUIT ; 157 K DFN,ICN,D,Y,HOME 1 RGEX01 ;BAY/ALS-LIST MANAGER FOR MPI/PD EXCEPTIONS ;10/07/99 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45,47,48**;30 Apr 99;Build 3 3 ; 4 ;Reference to MAIN^VAFCPDAT supported by IA #3299 5 EN ; -- main entry point for RG EXCPT SUMMARY 6 N STDT,ENDDT,PRGSTAT,XFLAG,NOW,%,X,%H,%I,INDT,RUN,INDTT 7 S XFLAG=0 D NOW^%DTC S NOW=% 8 S STDT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",1),INDT=STDT 9 I $D(STDT) S STDT=$$FMTE^XLFDT(STDT,1) 10 S PRGSTAT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",3) 11 ;status shows 'running' but lock shows 'not running';**47 12 I PRGSTAT="R" D 13 .L +^RGHL7(991.1,"RG PURGE EXCEPTION"):0 I $T D ;can get lock 14 ..L +^RGSITE(991.8):10 15 ..S DIE="^RGSITE(991.8,",DA=1,DR="42///@" 16 ..D ^DIE K DA,DIE,DR ;delete old status 17 ..L -^RGSITE(991.8) 18 ..S PRGSTAT="" 19 .L -^RGHL7(991.1,"RG PURGE EXCEPTION") 20 I PRGSTAT="" D 21 . W $C(7) 22 . W !!,"The MPI/PD Exception Purge process has not been run." 23 . ;**48 NO LONGER A CHOICE 24 . W !!,"The MPI/PD Exception Purge process will now run." 25 . W !,"Please come back to this option in five minutes." 26 . W !!,"Please contact IRM to schedule the MPI/PD EXCEPTION PURGE" 27 . W !,"[RG EXCEPTION PURGE] option via TaskMan with a frequency of once an hour." 28 . S XFLAG=1 D QUEPRG 29 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 30 L -^RGHL7(991.1,"RG PURGE EXCEPTION") 31 S RUN=0 32 I $G(PRGSTAT)="C" D 33 . I $P(INDT,".")<$P(NOW,".") S RUN=1 ;RAN A PREVIOUS DAY 34 . I $P(INDT,".")=$P(NOW,".") D 35 .. S INDTT=$E($P(INDT,".",2),1,4),INDTT=INDTT+101 36 .. I INDTT<$E($P(NOW,".",2),1,4) S RUN=1 37 . Q:RUN=0 38 . ;** if job ran more than 1 hour ago, run it now. 39 . W !!,"The MPI/PD Exception Purge process last ran "_STDT_"." 40 . W !!,"The MPI/PD Exception Purge process will now run." 41 . W !,"Please come back to this option in five minutes." 42 . W !!,"Please contact IRM to verify that the MPI/PD EXCEPTION PURGE " 43 . W !,"[RG EXCEPTION PURGE] option is scheduled to run via TaskMan" 44 . W !,"with a frequency of once an hour." 45 . S XFLAG=1 D QUEPRG 46 I XFLAG=1 G EXIT 47 K RGANS 48 D WAIT^DICD 49 D EN^VALM("RG EXCPT SUMMARY") 50 Q 51 ; 52 HDR ; -- header code 53 S VALMHDR(1)="MPI/PD Exception Handling" 54 S VALMHDR(2)="" 55 Q 56 ; 57 INIT ; -- init variables and list array 58 I '$D(RGSORT) S RGSORT="SD" 59 K @VALMAR 60 I RGSORT="SD" D DTLIST^RGEXHND1 61 E I RGSORT="ST" D EXCLST^RGEXHND1 62 E I RGSORT="SN" D PATLST^RGEXHND1 63 E I RGSORT="VT" D SELTYP^RGEXHND1 64 Q 65 ; 66 SORT ; 67 D INIT 68 S VALMBCK="R" 69 Q 70 HELP ; -- help code 71 S X="?" D DISP^XQORM1 W !! 72 Q 73 HLPPRG ; 74 W !,"Enter Y(YES) to run the MPI/PD Exception Purge process now." 75 W !!,"Enter N(NO) to go directly into the MPI/PD Exception Handling option." 76 Q 77 ; 78 EXIT ; -- exit code 79 K VADM,RGDFN,RGNM,RGSORT,RGSSN,STAT,STRING,NDX,NM,IEN,IEN2,X,DATA,CNT,EXCTYPE,ETYPE,^TMP("RGEXC",$J),^TMP("RGEX01",$J) 80 Q 81 QUEPRG S ZTRTN="MAIN^RGEVPRG",ZTDESC="PURGE ZZ*, OVER 30 DAY AND DUPLICATE RECORDS FROM THE CIRN HL7 EXCEPTION LOG FILE" 82 D NOW^%DTC 83 S ZTIO="",ZTDTH=% 84 I $D(DUZ) S ZTSAVE("DUZ")=DUZ 85 D ^%ZTLOAD 86 D HOME^%ZIS K IO("Q") 87 K ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,% 88 Q 89 ; 90 EXPND ; -- expand code 91 Q 92 ; 93 CUREX() ;Are there any patients in the CIRN HL7 EXCEPTION LOG file (#991.1) 94 ;that are NOT PROCESSED for specific exception types? 95 ; Return RGEX: 96 ;If RGEX=3 both unprocessed and Primary View Reject exceptions exist 97 ;If RGEX=2 only Primary View Reject exceptions exist 98 ;If RGEX=1 only unprocessed exceptions exist 99 ;If RGEX=0 no unprocessed exceptions exist 100 ; 101 N EXCTYP,RG1,RG2,RGEX 102 S EXCTYP="",(RG1,RG2,RGEX)=0 103 F S EXCTYP=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP)) Q:'EXCTYP D 104 .I ((EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219))) S RG1=1 105 .I (EXCTYP=234) S RG2=1 ;Primary View Reject 106 I (RG1=1),(RG2=1) S RGEX=3 ;Send both messages 107 I (RG1=1),(RG2=0) S RGEX=1 ;Only unresolved exceptions exist 108 I (RG1=0),(RG2=1) S RGEX=2 ;Only Primary View Reject exceptions exist 109 Q RGEX 110 ; 111 PROC ; For a given patient, set exceptions STATUS to PROCESSED. 112 ; DFN must be defined 113 Q:'$D(DFN) 114 S EXCTYP="" 115 S HOME=$$SITE^VASITE() 116 F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D 117 . S RGDFN="",ICN="" 118 . F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D 119 .. I DFN=RGDFN D 120 ... S ICN=+$$GETICN^MPIF001(DFN) 121 ... ;Only set to PROCESSED if patient has national ICN. 122 ... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D 123 .... ;Exclude Death exceptions (215-217); they must be processed manually. 124 .... ;Exclude 218 Potential Matches Returned exception **43 125 .... I (EXCTYP>218)!(EXCTYP<215) D 126 ..... S IEN=0 127 ..... F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D 128 ...... S IEN2=0 129 ...... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D 130 ....... L +^RGHL7(991.1,IEN):10 131 ....... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1," 132 ....... D ^DIE K DIE,DA,DR 133 ....... L -^RGHL7(991.1,IEN) 134 K IEN,IEN2,RGDFN,EXCTYP,ICN 135 Q 136 PDAT ; 137 K DIRUT 138 W !,"This report prints MPI/PD Data for a selected patient. The" 139 W !,"information displayed includes the Integration Control Number" 140 W !,"(ICN), patient identity information, and Treating Facility list." 141 W !!,"The information is pulled from the Patient (#2) file and the" 142 W !,"Treating Facility List (#391.91) file." 143 ; 144 ASK ;Ask for PATIENT 145 I $D(DIRUT) G QUIT 146 W !!,"Patient lookup can be done by Patient Name/SSN or by ICN.",! 147 N DFN,ICN 148 S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: ",D="SSN^AICN^B^BS^BS5" 149 D MIX^DIC1 K DIC 150 G:Y<0 QUIT 151 S DFN=+Y 152 D MAIN^VAFCPDAT 153 G ASK 154 Q 155 QUIT ; 156 K DFN,ICN,D,Y,HOME -
WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX06.m
r613 r623 1 RGEX06 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**48,53**;30 Apr 99;Build 2 3 4 5 6 7 EN(ICN) 8 9 10 11 HDR 12 13 14 15 INIT 16 17 18 19 20 I '$D(^XTMP("RGPVMPI"_ICN,"DATA")) S TXT=" - No MPI Primary View data exists for this patient." D ADDTMP21 22 I $D(^XTMP("RGPVMPI"_ICN,"DATA")) S RETURN(0)=$P(^XTMP("RGPVMPI"_ICN,"DATA"),"^") D23 24 25 26 27 28 29 30 31 32 33 ADDTMP 34 35 36 37 38 39 HELP 40 41 42 43 EXIT 44 45 46 47 48 49 EXPND 50 51 52 SAPV(ICN) 53 I '$D(^XTMP("RGPVMPI"_ICN,"DATA")) W !," - No MPI Primary View data exists for this patient." Q54 55 I $D(^XTMP("RGPVMPI"_ICN,"DATA")) S RETURN(0)=$P(^XTMP("RGPVMPI"_ICN,"DATA"),"^") D56 57 58 59 60 61 62 63 1 RGEX06 ;BIR/PTD-LIST MANAGER ROUTINE FOR REMOTE MPI PRIMARY VIEW PDAT ;5/17/07 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**48**;30 Apr 99;Build 3 3 ; 4 ;Reference to ^XWB2HL7 supported by IA #3144 5 ;Reference to ^XWBDRPC supported by IA #3149 6 ; 7 EN(ICN) ;Entry point calling List Template for primary view PDAT display 8 D EN^VALM("RG EXCPT PV MPI PDAT") 9 Q 10 ; 11 HDR ; -- header code 12 S VALMHDR(1)="MPI PRIMARY VIEW PATIENT DATA DISPLAY" 13 Q 14 ; 15 INIT ;Display the MPI Primary View Patient Data (PDAT) 16 K ^TMP("RGEXC6",$J) 17 K @VALMAR 18 I '$D(ICN) G EXIT 19 S LIN=1,X=0,STR="",TXT="" 20 I '$D(^XTMP("RGPVMPI",ICN)) S TXT=" - No MPI Primary View data exists for this patient." D ADDTMP 21 N STATUS,R,RETURN,RESULT,RET 22 I $D(^XTMP("RGPVMPI",ICN)) S RETURN(0)=$P(^XTMP("RGPVMPI",ICN),"^") D 23 .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D 24 ..;Retrieve the data 25 ..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D 26 ...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 27 ...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 28 ...S R="" F S R=$O(RET(R)) Q:R="" S TXT=RET(R) S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP 29 K GLO,L,R,SL 30 S VALMCNT=LIN-1 31 Q 32 ; 33 ADDTMP ;Set string into the array. 34 S ^TMP("RGEXC6",$J,LIN,0)=STR 35 S ^TMP("RGEXC6",$J,"IDX",LIN,LIN)="" 36 S LIN=LIN+1,STR="" 37 Q 38 ; 39 HELP ; -- help code 40 S X="?" D DISP^XQORM1 W !! 41 Q 42 ; 43 EXIT ; -- exit code 44 S VALMBCK="" 45 K ^TMP("RGEXC6",$J),GLO,L,LIN,R,RESULT,RET,RETURN,SL,STATUS,STR,TXT,X 46 S VALMBCK="R" 47 Q 48 ; 49 EXPND ; -- expand code 50 Q 51 ; 52 SAPV(ICN) ;Print stand alone Primary View display 53 I '$D(^XTMP("RGPVMPI",ICN)) W !," - No MPI Primary View data exists for this patient." Q 54 N STATUS,R,RETURN,RESULT,RET 55 I $D(^XTMP("RGPVMPI",ICN)) S RETURN(0)=$P(^XTMP("RGPVMPI",ICN),"^") D 56 .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D 57 ..;Retrieve the data 58 ..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D 59 ...I $D(RET(0)) I RET(0)<0 W !!,"No data returned due to: "_$P(RET(0),"^",2) Q 60 ...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 61 ...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 62 Q 63 ; -
WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX07.m
r613 r623 1 RGEX07 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**44,53**;30 Apr 99;Build 2 3 4 5 6 7 EN(ICN,EXCDT) 8 9 10 11 HDR 12 13 14 15 INIT 16 17 18 19 20 21 I '$D(^XTMP("RGPVREJ"_ICN,EXCDT)) S TXT=" - No Primary View Reject data exists for this patient/exception date." D ADDTMP22 23 I $D(^XTMP("RGPVREJ"_ICN,EXCDT)) S RETURN(0)=$P(^XTMP("RGPVREJ"_ICN,EXCDT),"^") D24 25 26 27 28 29 30 31 32 33 34 ADDTMP 35 36 37 38 39 40 HELP 41 42 43 44 EXIT 45 46 47 48 49 50 EXPND 51 52 1 RGEX07 ;BIR/PTD-LIST MANAGER ROUTINE FOR REMOTE PRIMARY VIEW DISPLAY ;10/17/06 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**44**;30 Apr 99;Build 8 3 ; 4 ;Reference to ^XWB2HL7 supported by IA #3144 5 ;Reference to ^XWBDRPC supported by IA #3149 6 ; 7 EN(ICN,EXCDT) ;Entry point calling List Template for primary view reject display 8 D EN^VALM("RG EXCPT PV REJECT RDISPLAY") 9 Q 10 ; 11 HDR ; -- header code 12 S VALMHDR(1)="MPI PRIMARY VIEW REJECT DISPLAY" 13 Q 14 ; 15 INIT ;Display the MPI Primary View Rejected Data Report 16 K ^TMP("RGEXC7",$J) 17 K @VALMAR 18 I '$D(ICN) G EXIT 19 I '$D(EXCDT) G EXIT 20 S LIN=1,X=0,STR="",TXT="" 21 I '$D(^XTMP("RGPVREJ",ICN,EXCDT)) S TXT=" - No Primary View Reject data exists for this patient/exception date." D ADDTMP 22 N STATUS,R,RETURN,RESULT,RET 23 I $D(^XTMP("RGPVREJ",ICN,EXCDT)) S RETURN(0)=$P(^XTMP("RGPVREJ",ICN,EXCDT),"^") D 24 .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D 25 ..;Retrieve the data 26 ..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D 27 ...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 28 ...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 29 ...S R="" F S R=$O(RET(R)) Q:R="" S TXT=RET(R) S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP 30 K GLO,L,R,SL 31 S VALMCNT=LIN-1 32 Q 33 ; 34 ADDTMP ;Set string into the array. 35 S ^TMP("RGEXC7",$J,LIN,0)=STR 36 S ^TMP("RGEXC7",$J,"IDX",LIN,LIN)="" 37 S LIN=LIN+1,STR="" 38 Q 39 ; 40 HELP ; -- help code 41 S X="?" D DISP^XQORM1 W !! 42 Q 43 ; 44 EXIT ; -- exit code 45 S VALMBCK="" 46 K ^TMP("RGEXC7",$J),GLO,L,LIN,R,RESULT,RET,RETURN,SL,STATUS,STR,TXT,X 47 S VALMBCK="R" 48 Q 49 ; 50 EXPND ; -- expand code 51 Q 52 ; -
WorldVistAEHR/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEXHND1.m
r613 r623 1 RGEXHND1 ;BAY/ALS-MPI/PD EXCEPTION HANDLING UTILITY ;10/08/99 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45,52**;30 Apr 99;Build 2 3 DTLIST ;List exceptions by date 4 K ^TMP("RGEXC",$J) 5 I '$D(RGBG) S VALMBG=1 6 ;**45 list exception 234 first regardless of date - Primary View Reject 7 S EXCDT="",EXCTYP=234,(CNT,IEN)=0 8 F S IEN=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP,IEN)) Q:'IEN D 9 .S IEN2=0 10 .F S IEN2=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP,IEN,IEN2)) Q:'IEN2 D 11 ..S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3) 12 ..D ADDREC 13 S EXCDT="",EXCTYP="" 14 F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D 15 . S IEN=0 16 . F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D 17 .. S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1 D 18 ... S IEN2=0 19 ... F S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2 D 20 .... S EXCTYP=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",3) 21 ....;don't include 234 below; those were done first (above). 22 .... I EXCTYP=218 D ADDREC ;**45;MPIC_772; **52 remove 215, 216, and 217 23 K I,NUM,EXCDT,EXCTYP,RGBG 24 IF CNT<1 D NDATA 25 Q 26 ; 27 NDATA ; There is no data matching the criteria 28 S CNT=CNT+1,STRING="" 29 S STRING=$$SETSTR^VALM1("There were no exceptions found.",STRING,5,35) 30 S ^TMP("RGEXC",$J,CNT,0)=STRING 31 S ^TMP("RGEXC",$J,"IDX",CNT,CNT)="" 32 S VALMCNT=CNT 33 Q 34 EXCLST ;List exceptions by type 35 K ^TMP("RGEXC",$J) 36 S CNT=0,EXCDT="",EXCTYP="" 37 I '$D(RGBG) S VALMBG=1 38 F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D 39 . I (EXCTYP=234)!(EXCTYP=218) D ;**45;MPIC_772; **52 remove 215, 216, and 217 40 .. S IEN=0 41 .. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D 42 ... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1 D 43 .... S IEN2=0 44 .... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D 45 ..... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT 46 ..... D ADDREC 47 IF CNT<1 D NDATA 48 K RGBG 49 Q 50 PATLST ;List exceptions by patient 51 K ^TMP("RGEXC",$J),^TMP("RGEX01",$J) 52 S CNT=0,EXCDT="",EXCTYP="",NDX=0,NAME="" 53 I '$D(RGBG) S VALMBG=1 54 F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D 55 . I (EXCTYP=234)!(EXCTYP=218) D ;**45;MPIC_772; **52 remove 215, 216, and 217 56 .. S DFN="" 57 .. F S DFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN)) Q:'DFN D 58 ... S IEN=0 59 ... F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN,IEN)) Q:'IEN D 60 .... S IEN2=0 61 .... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN,IEN,IEN2)) Q:'IEN2 D 62 ..... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT 63 ..... D DEM^VADPT S NAME=VADM(1) Q:NAME="" 64 ..... S NDX=NDX+1 65 ..... S ^TMP("RGEX01",$J,NAME,NDX)=$G(VADM(1))_"^"_IEN_"^"_IEN2_"^"_EXCTYP_"^"_EXCDT 66 D PATTMP 67 IF CNT<1 D NDATA 68 K DFN,RGBG 69 Q 70 PATTMP ; 71 S NM="" 72 F S NM=$O(^TMP("RGEX01",$J,NM)) Q:NM="" D 73 . S NDX=0 74 . F S NDX=$O(^TMP("RGEX01",$J,NM,NDX)) Q:'NDX D 75 .. S IEN=$P(^TMP("RGEX01",$J,NM,NDX),"^",2) 76 .. S IEN2=$P(^TMP("RGEX01",$J,NM,NDX),"^",3) 77 .. S EXCTYP=$P(^TMP("RGEX01",$J,NM,NDX),"^",4) 78 .. S EXCDT=$P(^TMP("RGEX01",$J,NM,NDX),"^",5) 79 .. D ADDREC 80 K NDX,NM,NAME 81 Q 82 SELTYP ; List all exceptions of type selected by user 83 S EXCTYPE="",FLAG=0,ETYPE="" 84 I '$D(RGBG) S VALMBG=1 85 K DIR,Y,DIC 86 S DIR("A")="Enter an exception type to view: " 87 S DIR(0)="SAM^218:Potential Matches Returned;234:Primary View Reject" ;**43;**45;MPIC_772; **52 remove 215, 216, and 217 88 S DIR("?")="^D HLPSEL^RGEXHND1" 89 D ^DIR 90 I Y<1 S RGSORT="SD" D SORT^RGEX01 Q 91 Q:$D(DUOUT)!$D(DTOUT) 92 S EXCTYPE=+Y,ETYPE=$P(^RGHL7(991.11,EXCTYPE,10),"^",1) 93 I (EXCTYPE=234)!(EXCTYPE=218) S FLAG=1 ;**43;**45;MPIC_772; **52 remove 215, 216, and 217 94 I FLAG=1 D ADDSEL 95 E I FLAG=0 D 96 . W !,"Not a valid selection." 97 . D SELTYP 98 K FLAG,Y,DIR,DIC,DTOUT,DUOUT,RGBG 99 Q 100 ADDSEL ;called by SELTYP 101 K ^TMP("RGEXC",$J) 102 S CNT=0,EXCDT="",EXCTYP="" 103 F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D 104 . I EXCTYP=EXCTYPE D 105 .. S IEN=0 106 .. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D 107 ... S IEN2=0 108 ... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D 109 .... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT ;**43 110 .... D ADDREC 111 I CNT<1 D 112 . W !,"There are no "_ETYPE 113 . W !,"exceptions that need processing." 114 . D SELTYP 115 Q 116 HLPSEL ; 117 D FULL^VALM1 118 ;W !,"The following exception types are handled by this option:" 119 ;W !,"Potential Matches Returned",?50,"(218)" 120 ;W !,"Primary View Reject",?50,"(234)" 121 S VALMBCK="R" 122 Q 123 ADDREC ; 124 S ETEXT="",RGDFN="",ICN="",RGNM="",STAT="",DOD="" 125 S ETEXT=$P($G(^RGHL7(991.11,EXCTYP,10)),"^",1) 126 S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN 127 S STAT=$P($G(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5) 128 S ICN=+$$GETICN^MPIF001(RGDFN) 129 S HOME=$$SITE^VASITE() 130 I (STAT<1)!(STAT="") D 131 .;Only list exceptions that are Not Processed 132 .; only list patients with local ICN, or for exceptions 234 or 218;MPIC_772; **52 remove 215, 216, and 217 133 . I $E(ICN,1,3)=$E($P(HOME,"^",3),1,3)!(ICN<0)!(EXCTYP=234)!(EXCTYP=218) D ;**43,**45,**52 134 .. S DFN=RGDFN D DEM^VADPT 135 .. S RGNM=VADM(1) 136 .. S RGSSN=$P($G(VADM(2)),"^",1) 137 .. S DOB=$G(VADM(3)) I DOB="" S DOB="^" 138 .. S DOD=$P($P($G(VADM(6)),"^",2),"@",1) 139 .. S EXDATE=$P($$FMTE^XLFDT(EXCDT,2),"@",1) 140 .. S CNT=CNT+1 141 .. S STRING="" 142 .. I ICN<0 S ICN="" 143 .. S STRING=$$SETSTR^VALM1(CNT,STRING,1,4) 144 .. S STRING=$$SETSTR^VALM1($E(RGNM,1,22),STRING,6,21) 145 .. S STRING=$$SETSTR^VALM1(RGSSN,STRING,28,10) 146 .. S STRING=$$SETSTR^VALM1(EXDATE,STRING,39,8) 147 .. S STRING=$$SETSTR^VALM1(ETEXT,STRING,49,32) 148 .. S ^TMP("RGEXC",$J,CNT,0)=STRING 149 .. S ^TMP("RGEXC",$J,"IDX",CNT,CNT)="" 150 .. S ^TMP("RGEXC",$J,CNT,"DATA")=RGNM_"^"_RGSSN_"^"_$P($$FMTE^XLFDT(EXCDT),"@",1)_"^"_ETEXT_"^"_DFN_"^"_ICN_"^"_DOB_"^"_STAT_"^"_IEN_"^"_IEN2_"^"_CNT_"^"_DOD 151 S VALMCNT=CNT 152 K RGDFN,RGNM,RGSSN,EXDATE,ETEXT,ICN,DOB,STAT,VADM,HOME,STRING,DOD 153 Q 154 SELECT ; 155 I $G(STRING)["no exceptions found" D SORT^RGEX01 Q 156 N VALMY 157 D EN^VALM2(XQORNOD(0),"OS") 158 I '$D(VALMY) Q 159 S VALMCNT=CNT 160 S DATA="",CNT="" 161 S CNT=$O(VALMY(0)) 162 S DATA=$G(^TMP("RGEXC",$J,CNT,"DATA")) 163 I '$D(DATA) S CNT=0 Q 164 D CLEAN^VALM10 165 D EN^RGEX03(DATA) 166 I RGSORT="VT" D 167 . K @VALMAR 168 . D ADDSEL 169 E I RGSORT'="VT" D SORT^RGEX01 170 ; 171 Q 172 QUIT ; 1 RGEXHND1 ;BAY/ALS-MPI/PD EXCEPTION HANDLING UTILITY ;10/08/99 2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45**;30 Apr 99;Build 9 3 DTLIST ;List exceptions by date 4 K ^TMP("RGEXC",$J) 5 I '$D(RGBG) S VALMBG=1 6 ;**45 list exception 234 first regardless of date - Primary View Reject 7 S EXCDT="",EXCTYP=234,(CNT,IEN)=0 8 F S IEN=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP,IEN)) Q:'IEN D 9 .S IEN2=0 10 .F S IEN2=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP,IEN,IEN2)) Q:'IEN2 D 11 ..S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3) 12 ..D ADDREC 13 S EXCDT="",EXCTYP="" 14 F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D 15 . S IEN=0 16 . F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D 17 .. S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1 D 18 ... S IEN2=0 19 ... F S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2 D 20 .... S EXCTYP=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",3) 21 ....;don't include 234 below; those were done first (above). 22 .... I ((EXCTYP>214)&(EXCTYP<219)) D ADDREC ;**45 23 K I,NUM,EXCDT,EXCTYP,RGBG 24 IF CNT<1 D NDATA 25 Q 26 ; 27 NDATA ; There is no data matching the criteria 28 S CNT=CNT+1,STRING="" 29 S STRING=$$SETSTR^VALM1("There were no exceptions found.",STRING,5,35) 30 S ^TMP("RGEXC",$J,CNT,0)=STRING 31 S ^TMP("RGEXC",$J,"IDX",CNT,CNT)="" 32 S VALMCNT=CNT 33 Q 34 EXCLST ;List exceptions by type 35 K ^TMP("RGEXC",$J) 36 S CNT=0,EXCDT="",EXCTYP="" 37 I '$D(RGBG) S VALMBG=1 38 F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D 39 . I (EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219)) D ;**45 40 .. S IEN=0 41 .. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D 42 ... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1 D 43 .... S IEN2=0 44 .... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D 45 ..... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT 46 ..... D ADDREC 47 IF CNT<1 D NDATA 48 K RGBG 49 Q 50 PATLST ;List exceptions by patient 51 K ^TMP("RGEXC",$J),^TMP("RGEX01",$J) 52 S CNT=0,EXCDT="",EXCTYP="",NDX=0,NAME="" 53 I '$D(RGBG) S VALMBG=1 54 F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D 55 . I (EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219)) D ;**45 56 .. S DFN="" 57 .. F S DFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN)) Q:'DFN D 58 ... S IEN=0 59 ... F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN,IEN)) Q:'IEN D 60 .... S IEN2=0 61 .... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN,IEN,IEN2)) Q:'IEN2 D 62 ..... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT 63 ..... D DEM^VADPT S NAME=VADM(1) Q:NAME="" 64 ..... S NDX=NDX+1 65 ..... S ^TMP("RGEX01",$J,NAME,NDX)=$G(VADM(1))_"^"_IEN_"^"_IEN2_"^"_EXCTYP_"^"_EXCDT 66 D PATTMP 67 IF CNT<1 D NDATA 68 K DFN,RGBG 69 Q 70 PATTMP ; 71 S NM="" 72 F S NM=$O(^TMP("RGEX01",$J,NM)) Q:NM="" D 73 . S NDX=0 74 . F S NDX=$O(^TMP("RGEX01",$J,NM,NDX)) Q:'NDX D 75 .. S IEN=$P(^TMP("RGEX01",$J,NM,NDX),"^",2) 76 .. S IEN2=$P(^TMP("RGEX01",$J,NM,NDX),"^",3) 77 .. S EXCTYP=$P(^TMP("RGEX01",$J,NM,NDX),"^",4) 78 .. S EXCDT=$P(^TMP("RGEX01",$J,NM,NDX),"^",5) 79 .. D ADDREC 80 K NDX,NM,NAME 81 Q 82 SELTYP ; List all exceptions of type selected by user 83 S EXCTYPE="",FLAG=0,ETYPE="" 84 I '$D(RGBG) S VALMBG=1 85 K DIR,Y,DIC 86 S DIR("A")="Enter an exception type to view: " 87 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 88 S DIR("?")="^D HLPSEL^RGEXHND1" 89 D ^DIR 90 I Y<1 S RGSORT="SD" D SORT^RGEX01 Q 91 Q:$D(DUOUT)!$D(DTOUT) 92 S EXCTYPE=+Y,ETYPE=$P(^RGHL7(991.11,EXCTYPE,10),"^",1) 93 I (EXCTYPE=234)!((EXCTYPE>214)&(EXCTYPE<219)) S FLAG=1 ;**43,45 94 I FLAG=1 D ADDSEL 95 E I FLAG=0 D 96 . W !,"Not a valid selection." 97 . D SELTYP 98 K FLAG,Y,DIR,DIC,DTOUT,DUOUT,RGBG 99 Q 100 ADDSEL ;called by SELTYP 101 K ^TMP("RGEXC",$J) 102 S CNT=0,EXCDT="",EXCTYP="" 103 F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D 104 . I EXCTYP=EXCTYPE D 105 .. S IEN=0 106 .. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D 107 ... S IEN2=0 108 ... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D 109 .... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT ;**43 110 .... D ADDREC 111 I CNT<1 D 112 . W !,"There are no "_ETYPE 113 . W !,"exceptions that need processing." 114 . D SELTYP 115 Q 116 HLPSEL ; 117 D FULL^VALM1 118 ;W !,"The following exception types are handled by this option:" 119 ;W !!,"Death Entry on MPI not in VISTA",?50,"(215)" 120 ;W !,"Death Entry on Vista not in MPI",?50,"(216)" 121 ;W !,"Death Entries on MPI and Vista DO NOT MATCH",?50,"(217)" 122 ;W !,"Potential Matches Returned",?50,"(218)" 123 ;W !,"Primary View Reject",?50,"(234)" 124 S VALMBCK="R" 125 Q 126 ADDREC ; 127 S ETEXT="",RGDFN="",ICN="",RGNM="",STAT="",DOD="" 128 S ETEXT=$P($G(^RGHL7(991.11,EXCTYP,10)),"^",1) 129 S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN 130 S STAT=$P($G(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5) 131 S ICN=+$$GETICN^MPIF001(RGDFN) 132 S HOME=$$SITE^VASITE() 133 I (STAT<1)!(STAT="") D 134 .;Only list exceptions that are Not Processed 135 .; only list patients with local ICN, or for exceptions 234, 215 - 218 136 . I $E(ICN,1,3)=$E($P(HOME,"^",3),1,3)!(ICN<0)!(EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219)) D ;**43,45 137 .. S DFN=RGDFN D DEM^VADPT 138 .. S RGNM=VADM(1) 139 .. S RGSSN=$P($G(VADM(2)),"^",1) 140 .. S DOB=$G(VADM(3)) I DOB="" S DOB="^" 141 .. S DOD=$P($P($G(VADM(6)),"^",2),"@",1) 142 .. S EXDATE=$P($$FMTE^XLFDT(EXCDT,2),"@",1) 143 .. S CNT=CNT+1 144 .. S STRING="" 145 .. I ICN<0 S ICN="" 146 .. S STRING=$$SETSTR^VALM1(CNT,STRING,1,4) 147 .. S STRING=$$SETSTR^VALM1($E(RGNM,1,22),STRING,6,21) 148 .. S STRING=$$SETSTR^VALM1(RGSSN,STRING,28,10) 149 .. S STRING=$$SETSTR^VALM1(EXDATE,STRING,39,8) 150 .. S STRING=$$SETSTR^VALM1(ETEXT,STRING,49,32) 151 .. S ^TMP("RGEXC",$J,CNT,0)=STRING 152 .. S ^TMP("RGEXC",$J,"IDX",CNT,CNT)="" 153 .. S ^TMP("RGEXC",$J,CNT,"DATA")=RGNM_"^"_RGSSN_"^"_$P($$FMTE^XLFDT(EXCDT),"@",1)_"^"_ETEXT_"^"_DFN_"^"_ICN_"^"_DOB_"^"_STAT_"^"_IEN_"^"_IEN2_"^"_CNT_"^"_DOD 154 S VALMCNT=CNT 155 K RGDFN,RGNM,RGSSN,EXDATE,ETEXT,ICN,DOB,STAT,VADM,HOME,STRING,DOD 156 Q 157 SELECT ; 158 I $G(STRING)["no exceptions found" D SORT^RGEX01 Q 159 N VALMY 160 D EN^VALM2(XQORNOD(0),"OS") 161 I '$D(VALMY) Q 162 S VALMCNT=CNT 163 S DATA="",CNT="" 164 S CNT=$O(VALMY(0)) 165 S DATA=$G(^TMP("RGEXC",$J,CNT,"DATA")) 166 I '$D(DATA) S CNT=0 Q 167 D CLEAN^VALM10 168 D EN^RGEX03(DATA) 169 I RGSORT="VT" D 170 . K @VALMAR 171 . D ADDSEL 172 E I RGSORT'="VT" D SORT^RGEX01 173 ; 174 Q 175 QUIT ;
Note:
See TracChangeset
for help on using the changeset viewer.
