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,57**;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() ;**57 MPIC_1893 The CUREX module is obsolete and is no longer being called.
;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 ;**52 MPIC_772 remove 215, 216 & 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
S RGEX=0 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGEX01 5949 printed Sep 23, 2025@19:17:40 Page 2
RGEX01 ;BAY/ALS-LIST MANAGER FOR MPI/PD EXCEPTIONS ;10/07/99
+1 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45,47,48,52,57**;30 Apr 99;Build 2
+2 ;
+3 ;Reference to MAIN^VAFCPDAT supported by IA #3299
EN ; -- main entry point for RG EXCPT SUMMARY
+1 NEW STDT,ENDDT,PRGSTAT,XFLAG,NOW,%,X,%H,%I,INDT,RUN,INDTT
+2 SET XFLAG=0
DO NOW^%DTC
SET NOW=%
+3 SET STDT=$PIECE($GET(^RGSITE(991.8,1,"EXCPRG")),"^",1)
SET INDT=STDT
+4 IF $DATA(STDT)
SET STDT=$$FMTE^XLFDT(STDT,1)
+5 SET PRGSTAT=$PIECE($GET(^RGSITE(991.8,1,"EXCPRG")),"^",3)
+6 ;status shows 'running' but lock shows 'not running';**47
+7 IF PRGSTAT="R"
Begin DoDot:1
+8 ;can get lock
LOCK +^RGHL7(991.1,"RG PURGE EXCEPTION"):0
IF $TEST
Begin DoDot:2
+9 LOCK +^RGSITE(991.8):10
+10 SET DIE="^RGSITE(991.8,"
SET DA=1
SET DR="42///@"
+11 ;delete old status
DO ^DIE
KILL DA,DIE,DR
+12 LOCK -^RGSITE(991.8)
+13 SET PRGSTAT=""
End DoDot:2
+14 LOCK -^RGHL7(991.1,"RG PURGE EXCEPTION")
End DoDot:1
+15 IF PRGSTAT=""
Begin DoDot:1
+16 WRITE $CHAR(7)
+17 WRITE !!,"The MPI/PD Exception Purge process has not been run."
+18 ;**48 NO LONGER A CHOICE
+19 WRITE !!,"The MPI/PD Exception Purge process will now run."
+20 WRITE !,"Please come back to this option in five minutes."
+21 WRITE !!,"Please contact IRM to schedule the MPI/PD EXCEPTION PURGE"
+22 WRITE !,"[RG EXCEPTION PURGE] option via TaskMan with a frequency of once an hour."
+23 SET XFLAG=1
DO QUEPRG
End DoDot:1
+24 LOCK +^RGHL7(991.1,"RG PURGE EXCEPTION"):0
IF '$TEST
WRITE $CHAR(7),!!,"The MPI/PD Exception Purge process is currently running.",!,"Please try this option again in five minutes."
SET XFLAG=1
GOTO EXIT
+25 LOCK -^RGHL7(991.1,"RG PURGE EXCEPTION")
+26 SET RUN=0
+27 IF $GET(PRGSTAT)="C"
Begin DoDot:1
+28 ;RAN A PREVIOUS DAY
IF $PIECE(INDT,".")<$PIECE(NOW,".")
SET RUN=1
+29 IF $PIECE(INDT,".")=$PIECE(NOW,".")
Begin DoDot:2
+30 SET INDTT=$EXTRACT($PIECE(INDT,".",2),1,4)
SET INDTT=INDTT+101
+31 IF INDTT<$EXTRACT($PIECE(NOW,".",2),1,4)
SET RUN=1
End DoDot:2
+32 if RUN=0
QUIT
+33 ;** if job ran more than 1 hour ago, run it now.
+34 WRITE !!,"The MPI/PD Exception Purge process last ran "_STDT_"."
+35 WRITE !!,"The MPI/PD Exception Purge process will now run."
+36 WRITE !,"Please come back to this option in five minutes."
+37 WRITE !!,"Please contact IRM to verify that the MPI/PD EXCEPTION PURGE "
+38 WRITE !,"[RG EXCEPTION PURGE] option is scheduled to run via TaskMan"
+39 WRITE !,"with a frequency of once an hour."
+40 SET XFLAG=1
DO QUEPRG
End DoDot:1
+41 IF XFLAG=1
GOTO EXIT
+42 KILL RGANS
+43 DO WAIT^DICD
+44 DO EN^VALM("RG EXCPT SUMMARY")
+45 QUIT
+46 ;
HDR ; -- header code
+1 SET VALMHDR(1)="MPI/PD Exception Handling"
+2 SET VALMHDR(2)=""
+3 QUIT
+4 ;
INIT ; -- init variables and list array
+1 IF '$DATA(RGSORT)
SET RGSORT="SD"
+2 KILL @VALMAR
+3 IF RGSORT="SD"
DO DTLIST^RGEXHND1
+4 IF '$TEST
IF RGSORT="ST"
DO EXCLST^RGEXHND1
+5 IF '$TEST
IF RGSORT="SN"
DO PATLST^RGEXHND1
+6 IF '$TEST
IF RGSORT="VT"
DO SELTYP^RGEXHND1
+7 QUIT
+8 ;
SORT ;
+1 DO INIT
+2 SET VALMBCK="R"
+3 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
HLPPRG ;
+1 WRITE !,"Enter Y(YES) to run the MPI/PD Exception Purge process now."
+2 WRITE !!,"Enter N(NO) to go directly into the MPI/PD Exception Handling option."
+3 QUIT
+4 ;
EXIT ; -- exit code
+1 KILL VADM,RGDFN,RGNM,RGSORT,RGSSN,STAT,STRING,NDX,NM,IEN,IEN2,X,DATA,CNT,EXCTYPE,ETYPE,^TMP("RGEXC",$JOB),^TMP("RGEX01",$JOB)
+2 QUIT
QUEPRG SET ZTRTN="MAIN^RGEVPRG"
SET ZTDESC="PURGE ZZ*, OVER 30 DAY AND DUPLICATE RECORDS FROM THE CIRN HL7 EXCEPTION LOG FILE"
+1 DO NOW^%DTC
+2 SET ZTIO=""
SET ZTDTH=%
+3 IF $DATA(DUZ)
SET ZTSAVE("DUZ")=DUZ
+4 DO ^%ZTLOAD
+5 DO HOME^%ZIS
KILL IO("Q")
+6 KILL ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,%
+7 QUIT
+8 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
CUREX() ;**57 MPIC_1893 The CUREX module is obsolete and is no longer being called.
+1 ;Are there any patients in the CIRN HL7 EXCEPTION LOG file (#991.1)
+2 ;that are NOT PROCESSED for specific exception types?
+3 ; Return RGEX:
+4 ;If RGEX=3 both unprocessed and Primary View Reject exceptions exist
+5 ;If RGEX=2 only Primary View Reject exceptions exist
+6 ;If RGEX=1 only unprocessed exceptions exist
+7 ;If RGEX=0 no unprocessed exceptions exist
+8 ;
+9 ;N EXCTYP,RG1,RG2,RGEX
+10 ;S EXCTYP="",(RG1,RG2,RGEX)=0
+11 ;F S EXCTYP=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP)) Q:'EXCTYP D
+12 ;.I (EXCTYP=234)!(EXCTYP=218) S RG1=1 ;**52 MPIC_772 remove 215, 216 & 217
+13 ;.I (EXCTYP=234) S RG2=1 ;Primary View Reject
+14 ;I (RG1=1),(RG2=1) S RGEX=3 ;Send both messages
+15 ;I (RG1=1),(RG2=0) S RGEX=1 ;Only unresolved exceptions exist
+16 ;I (RG1=0),(RG2=1) S RGEX=2 ;Only Primary View Reject exceptions exist
+17 SET RGEX=0
QUIT RGEX
+18 ;
PROC ; For a given patient, set exceptions STATUS to PROCESSED.
+1 ;**52 The PROC module is obsolete and is no longer being called.
+2 ; DFN must be defined
+3 ;Q:'$D(DFN)
+4 ;S EXCTYP=""
+5 ;S HOME=$$SITE^VASITE()
+6 ;F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
+7 ;. S RGDFN="",ICN=""
+8 ;. F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
+9 ;.. I DFN=RGDFN D
+10 ;... S ICN=+$$GETICN^MPIF001(DFN)
+11 ;... ;Only set to PROCESSED if patient has national ICN.
+12 ;... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
+13 ;.... ;Exclude Death exceptions (215-217); they must be processed manually.
+14 ;.... ;Exclude 218 Potential Matches Returned exception **43
+15 ;.... I (EXCTYP>218)!(EXCTYP<215) D
+16 ;..... S IEN=0
+17 ;..... F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
+18 ;...... S IEN2=0
+19 ;...... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
+20 ;....... L +^RGHL7(991.1,IEN):10
+21 ;....... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
+22 ;....... D ^DIE K DIE,DA,DR
+23 ;....... L -^RGHL7(991.1,IEN)
+24 ;K IEN,IEN2,RGDFN,EXCTYP,ICN
+25 QUIT
PDAT ;
+1 KILL DIRUT
+2 WRITE !,"This report prints MPI/PD Data for a selected patient. The"
+3 WRITE !,"information displayed includes the Integration Control Number"
+4 WRITE !,"(ICN), patient identity information, and Treating Facility list."
+5 WRITE !!,"The information is pulled from the Patient (#2) file and the"
+6 WRITE !,"Treating Facility List (#391.91) file."
+7 ;
ASK ;Ask for PATIENT
+1 IF $DATA(DIRUT)
GOTO QUIT
+2 WRITE !!,"Patient lookup can be done by Patient Name/SSN or by ICN.",!
+3 NEW DFN,ICN
+4 SET DIC="^DPT("
SET DIC(0)="QEAM"
SET DIC("A")="Select PATIENT: "
SET D="SSN^AICN^B^BS^BS5"
+5 DO MIX^DIC1
KILL DIC
+6 if Y<0
GOTO QUIT
+7 SET DFN=+Y
+8 DO MAIN^VAFCPDAT
+9 GOTO ASK
+10 QUIT
QUIT ;
+1 KILL DFN,ICN,D,Y,HOME
