MPIFDUP ;BIRM/CMC-RESOLVE DUP ACTION ;DEC 2, 2005
;;1.0; MASTER PATIENT INDEX VISTA ;**43,46,48,53**;30 Apr 99;Build 1
;
POT ;EXCEPTION HANDLER CALLS HERE ;**53 MPIC_1853 The POT module is obsolete and is no longer being called.
;Potential Match on MPI, Query MPI, resolve duplicate if needed. **43 Added this entry point
; Only available when Exception Being Reviewed is Potential Match
;N PELV,PTEN
;S PTEN=$P(DATA,"^",10)
;I '$D(^RGHL7(991.1,"ADFN",218,DFN)) W !,"Potential Match Review Option is Only Available for Potential Match Exceptions" H 5 S VALMBCK="R" Q
;I $D(^RGHL7(991.1,"ADFN",218,DFN,PTEN)) S SUB=$O(^RGHL7(991.1,"ADFN",218,DFN,PTEN,"")) I $P($G(^RGHL7(991.1,PTEN,SUB,1,0)),"^",5)=1 W !,"Potential Match Review is Only Available for Exceptions still pending." H 5 S VALMBCK="R" Q
;S PTEN=$P(DATA,"^",10) ;IEN IN 991.1
;S PELV=$P(DATA,"^",11) ;IEN IN 991.12
;I $P($G(^RGHL7(991.1,PTEN,1,PELV,0)),"^",3)'=218 S VALMSG="Action is ONLY for POTENTIAL MATCH exceptions!",VALMBCK="R" Q
; ^**46 changed check to ensure exception is Potential Match exception
;I $E($$GETICN^MPIF001(DFN),1,3)=$P($$SITE^VASITE,"^",3) W !,"Messaging outstanding please try again in a few minutes." H 5 Q
;S VALMBCK="",MPIFRES="",MPIFINT=""
;D FULL^VALM1
;D EXC
;D PAUSE^VALM1
;K MPIFRES,MPIFINT
;N X,Y,DIR,DIE,DA,DR,IEN,IEN2,PROCDT,%,X,%I,%H
;I '$D(PROCESS) D
;.S DIR("A")="Do you want to mark this exception as processed? ",DIR(0)="YA",DIR("B")="NO" D ^DIR K DIR(0),DIR("A")
;.I Y S PROCESS=1 K X,Y
;I $D(PROCESS) D
;.;**48 CAPTURE DATE/TIME AND WHO MARKED AS PROCESSED
;.D NOW^%DTC S PROCDT=%
;.S IEN="",IEN2="",IEN=$P(DATA,"^",10),IEN2=$P(DATA,"^",11)
;.L +^RGHL7(991.1,IEN):10
;.S DA(1)=IEN,DA=IEN2,DR="6///"_1_";7///"_PROCDT_";8///"_$G(DUZ),DIE="^RGHL7(991.1,"_DA(1)_",1," D ^DIE K DIE,DA,DR
;.L -^RGHL7(991.1,IEN)
;.S $P(DATA,"^",9)=1
;K PROCESS
Q
EXC ; Exception Entry Point
N LOCDATA ;Data Returned from GETDATA in ICN array
D GETDATA("^DPT(",DFN,"LOCDATA",".01;.02;.03;.09;.301;391;1901")
S LOCDATA(2,DFN,991.01)=$P($$MPINODE^MPIFAPI(DFN),"^"),TSSN=LOCDATA(2,DFN,.09)
S HLP("ACKTIME")=300,MPIQRYNM="POTENTIAL_DUP_RES"
N TIME,% D NOW^%DTC S TIME=%
N HL,MPIINM,MPIOUT,MPIIN,MPIMCNT,MPICNT,MPICS,HEADER,TEST,SITE,MPIDC,SSN
S HL("ECH")="^~\&",HL("FS")="|"
S MPIIN="",MPIMCNT=DFN,MPICNT=1,MPICS=$E(HL("ECH"),1),MPIFRES=1
D VTQ1^MPIFVTQ(DFN,.MPIOUT,.HL,.MPIQRYNM)
I +MPIOUT(0)=-1 D G EXIT
.S ^TMP($J,"MPIFQ0-ERROR-LOG",DFN,TIME)=$G(MPIOUT(0)),MPIFRTN="CONTINUE"
;Create MSH
S SITE=$$SITE^VASITE,SITE=$P(SITE,"^",3),SITE=SITE\1,HEADER="MSH"_HL("FS")_HL("ECH")_HL("FS")_"MPI_LOAD"_HL("FS")_SITE_HL("FS")
S HEADER=HEADER_"MPI-ICN"_HL("FS")_HL("FS")_HL("FS")_HL("FS")_"VQQ"_MPICS_"Q02"_HL("FS")_MPIMCNT_"-"_MPICNT_HL("FS") ;**38 changed VTQ to VQQ
S MPIOUT(1)=HEADER K MPIOUT(0)
W !!,"Attempting to connect to the Master Patient Index in Austin...",!,"If no SSN or inexact DOB or common name, this request",!,"may take some time, please be patient...",!
S TEST=$$EN^HLCSAC("MPIVA DIR","MPIOUT","MPIDC")
K HLP("ACKTIME") ;kill the HLP array set for the ack timeout
I +TEST=-1 D G EXIT
.S ^TMP($J,"MPIFQ0-ERROR-LOG",DFN,TIME)=TEST
.I '$D(MPIFS) W:'$D(MPIFRPC) !!,"Could not connect to MPI or Timed Out. Try again later."
K ^TMP("MPIFVQQ",$J),^TMP("MPIFQ0",$J) ;array data is parsed into for display in LM
INIPARS ;
N SEG,INDEX,SKIP,CHECK,AL,TTF2,TFLL,TF,TF2,MPIREP,MPICOMP
S INDEX=0 K CHECK
LOOP1 ;
;process in ADT type messages
N MPIX S MPIX=0 N REP,SG,MSG,MPIQUIT,MPINODE
K TWODFN S MPIQUIT=0
F MPIX=0:1 X "D LOOP2" D K MPINODE,MSG Q:MPIQUIT'>0
. I $D(MPINODE(1)) S SG=$E(MPINODE(1),1,3) S MSG(1)=MPINODE(1) D
.. S MPIJ=1 F S MPIJ=$O(MPINODE(MPIJ)) Q:'MPIJ S MSG(MPIJ)=MPINODE(MPIJ)
.. D:SG?2A1(1A,1N) @SG
DECIDE ;If no data in ^TMP that means the patient was not found in the MPI w/VTQ Query. So we go to A28 to add the patient to the MPI.
N EXC,TEXT,EXACT,EXACT2,DATA,NODE2,ICN,CHKSUM,MORE,COMMON
I '$D(^TMP("MPIFVQQ",$J)) W !,"No Potential Matches Found.",!!,"Exception has been marked automatically as processed." S PROCESS=1 G EXIT
I INDEX=1 D
.;need to check if exact match was returned.
.S DATA=^TMP("MPIFVQQ",$J,INDEX,"DATA")
.S NODE2=$G(^TMP("MPIFVQQ",$J,INDEX,"INDICATOR"))
.S DATA(.01)=$P(DATA,"^",1) I $E(DATA(.01),$L(DATA(.01)))=" " S DATA(.01)=$E(DATA(.01),1,$L(DATA(.01))-1) ;NAME
.S DATA(.03)=$P(DATA,"^",4),DATA(.09)=$P(DATA,"^",3),DATA(.02)=$P(DATA,"^",11) ;DOB, SSN, SEX
.S ICN=$P(DATA,"^",6),CHKSUM=$P(ICN,"V",2),ICN=$P(ICN,"V",1),DATA(991.01)=ICN,DATA(991.02)=CHKSUM,DATA(991.03)=$$LKUP^XUAF4($P(DATA,"^",5))
.Q:NODE2["*"
.;^ ICN is already known at this site
.;check if this patient has another VISTA site now OR tfs in common
.S (MORE,COMMON)=0
.D COMPARE^MPIF002(DFN,INDEX,.COMMON,.MORE)
.Q:COMMON!(MORE)
.; check that now have an exact match returned
.N MPIFD,SSN,NAME,SEX,NAME3,BIR K COMMON,MORE
.D GETDATA^MPIFQ0("^DPT(",DFN,"MPIFD",".01;.09;.02;.03","EI")
.S SSN=$G(MPIFD(2,DFN,.09,"E")),NAME=$G(MPIFD(2,DFN,.01,"E")),SEX=$G(MPIFD(2,DFN,.02,"I"))
.S BIR=$G(MPIFD(2,DFN,.03,"I")) I BIR]"" S BIR=$TR($$FMTE^XLFDT(BIR,"5D"),"/","-")
.; if dob doesn't match -- not allowed to update ICN automatically
.Q:DATA(.03)'=BIR
.; if sex doesn't match -- not allowed to update ICN automatically
.Q:DATA(.02)'=SEX
.;if dob doesn't match -- not allowed to update ICN automatically
.I SSN["P" S SSN=""
.Q:DATA(.09)'=SSN
.D NAME^VAFCPID2(0,.NAME,0) ;reformat name into DG 149 format
.S NAME3=DATA(.01) D NAME^VAFCPID2(0,.NAME3,0) S DATA(.01)=NAME3 ;reformat name into DG 149 format
.; check if Last, First MATCH if so is it a middle name vs middle initial
.I $P(DATA(.01),",")=$P(NAME,",")&($P($P(NAME,",",2)," ")=$P($P(DATA(.01),",",2)," ")) D
..N MPIMID,NMMN S MPIMID=$P($P(DATA(.01),",",2)," ",2)
..S NMMN=$P($P(NAME,",",2)," ",2)
..I $L(NMMN)>1&($L(MPIMID)=1),($E(NMMN,1)=MPIMID) S EXACT=1
..I $L(MPIMID)>1&($L(NMMN)=1),($E(MPIMID,1)=NMMN) S EXACT=1
.I DATA(.01)=NAME!($D(EXACT)) K DATA(.09),DATA(.01),DATA(.03) D Q
..N PID2,ERR
..D INIT^HLFNC2("MPIF ADT-A24 SERVER",.HL)
..D BLDPID^VAFCQRY(DFN,2,"ALL",.PID2,.HL,.ERR)
..;**48 want to resolve an reject exceptions for "current" ICN
..D RESEX(DFN)
..D EDIT^MPIFQED(DFN,"DATA"),MSG3^MPIFQ3,PROMPT^MPIFQ3
..S RESLT=$$A24^MPIFA24B(DFN,.PID2) ;send a24 link icns
..S PROCESS=1
I $G(PROCESS)=1 G END
D START^MPIFD1(INDEX) G END
EXIT I $D(MPIFINT) K MPIFINT,MPIFRES,MPIQRYNM,TSSN,TWODFN,SDFN
K VALMCNT,VALMLST,CCMOR,FICN H 3 W:'$D(MPIFRPC) !!
END K ^TMP("MPIFVQQ",$J),^TMP("MPIFQ0",$J) Q
;
GETDATA(DIC,DA,MPIFAR,DR,EI) ;
;This function returns the values stored in the fields via FM call DIQ1
;DIC=file reference, DA=IEN in file, ARRAY=array for the values to be stored in, DR=fields requested, EI=external/internal values
N DIQ S DIQ=MPIFAR
I $G(EI)]"" S DIQ(0)=EI
D EN^DIQ1
Q
LOOP2 ;
N MPIDONE,MPII,MPIJ
S MPII=0,MPIDONE=0
F S MPIQUIT=$O(MPIDC(MPIQUIT)) Q:'MPIQUIT D Q:MPIDONE
. I MPIDC(MPIQUIT)="" S MPIDONE=1 Q
. S MPII=MPII+1,MPINODE(MPII)=$G(MPIDC(MPIQUIT)) Q
Q
MSH ;
S MPIREP=$E(HL("ECH"),2),MPICOMP=$E(HL("ECH"),1)
Q
MSA ;
Q
RDF ;
Q
QAK ;**43 added check for potential matches
K MPIPOT S MPIPOT=0
I MSG(1)["POTENTIAL MATCHES" S MPIPOT=1
S SDFN=$P(MSG(1),HL("FS"),2)
Q
RDT ;
N NAME,ICN,BIRTHDAY,CMOR,IEN,SEG,HEREICN,STRING,LASTNAME,FRSTNAME,MIDDLE,SUFF,SEX,THISGUY
S STRING="",INDEX=$G(INDEX)+1
D RDT^MPIFSA3(.INDEX,.HL,.MSG)
S SEG=^TMP("MPIFVQQ",$J,INDEX,"DATA")
S FRSTNAME=$P(SEG,"^",7),LASTNAME=$P(SEG,"^",2),MIDDLE=$P(SEG,"^",10),SUFF=$P(SEG,"^",15)
S SSN=$P(SEG,"^",3),NAME=LASTNAME_","_FRSTNAME
I MIDDLE'="" S NAME=NAME_" "_MIDDLE
I SUFF'="" S NAME=NAME_" "_SUFF
S SEX=$P(SEG,"^",11)
S ICN=$P(SEG,"^",6)
S THISGUY=$$GETDFN^MPIF001(+ICN) I THISGUY=DFN Q
S BIRTHDAY=$P(SEG,"^",4)
S CMOR=$P(SEG,"^",5),IEN=$$IEN^XUAF4(CMOR)
S CMOR=$P($$NS^XUAF4(IEN),"^")
S HEREICN=$$HEREICN^MPIFQ3($P(ICN,"V",1))
I HEREICN S STRING=$$SETSTR^VALM1("*",STRING,1,1),^TMP("MPIFVQQ",$J,INDEX,"INDICATOR")="*"_"^"_HEREICN
S STRING=$$SETSTR^VALM1(INDEX,STRING,2,4),STRING=$$SETSTR^VALM1($E(NAME,1,23),STRING,6,23)
S STRING=$$SETSTR^VALM1(SSN,STRING,30,9),STRING=$$SETSTR^VALM1(BIRTHDAY,STRING,41,10)
S STRING=$$SETSTR^VALM1(CMOR,STRING,54,20)
S ^TMP("MPIFVQQ",$J,INDEX,0)=STRING,^TMP("MPIFVQQ",$J,"IDX",INDEX,INDEX)=""
Q
RESEX(DFN,POT) ;look for any pv reject (234) exceptions and resolve them for this DFN
;IF POT IS SET TO 2 LOOK FOR ANY POTENTIAL MATCH (218) EXCEPTIONS AND RESOLVE THEM FOR THIS DFN
;**48 CREATED THIS API
N IEN,DA,DR,PROCDT,DIE,IEN2
S IEN=0
F S IEN=$O(^RGHL7(991.1,"ADFN",234,DFN,IEN)) Q:IEN="" D
.S IEN2=$O(^RGHL7(991.1,"ADFN",234,DFN,IEN,""))
.Q:$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",5)=1 ;**ALREADY MARKED AS PROCESSED
.D NOW^%DTC S PROCDT=%
.L +^RGHL7(991.1,IEN):10
.S DA(1)=IEN,DA=IEN2,DR="6///"_1_";7///"_PROCDT_";8///"_$G(DUZ),DIE="^RGHL7(991.1,"_DA(1)_",1," D ^DIE K DIE,DA,DR
.L -^RGHL7(991.1,IEN)
;
;I $G(POT)=2 D ;**53 MPIC_1853 Remove 218 references
;.S IEN=0
;.F S IEN=$O(^RGHL7(991.1,"ADFN",218,DFN,IEN)) Q:IEN="" D
;..S IEN2=$O(^RGHL7(991.1,"ADFN",218,DFN,IEN,""))
;..Q:$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",5)=1 ;**ALREADY MARKED AS PROCESSED
;..D NOW^%DTC S PROCDT=%
;..L +^RGHL7(991.1,IEN):10
;..S DA(1)=IEN,DA=IEN2,DR="6///"_1_";7///"_PROCDT_";8///"_$G(DUZ),DIE="^RGHL7(991.1,"_DA(1)_",1," D ^DIE K DIE,DA,DR
;..L -^RGHL7(991.1,IEN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMPIFDUP 9581 printed Apr 09, 2024@21:13:50 Page 2
MPIFDUP ;BIRM/CMC-RESOLVE DUP ACTION ;DEC 2, 2005
+1 ;;1.0; MASTER PATIENT INDEX VISTA ;**43,46,48,53**;30 Apr 99;Build 1
+2 ;
POT ;EXCEPTION HANDLER CALLS HERE ;**53 MPIC_1853 The POT module is obsolete and is no longer being called.
+1 ;Potential Match on MPI, Query MPI, resolve duplicate if needed. **43 Added this entry point
+2 ; Only available when Exception Being Reviewed is Potential Match
+3 ;N PELV,PTEN
+4 ;S PTEN=$P(DATA,"^",10)
+5 ;I '$D(^RGHL7(991.1,"ADFN",218,DFN)) W !,"Potential Match Review Option is Only Available for Potential Match Exceptions" H 5 S VALMBCK="R" Q
+6 ;I $D(^RGHL7(991.1,"ADFN",218,DFN,PTEN)) S SUB=$O(^RGHL7(991.1,"ADFN",218,DFN,PTEN,"")) I $P($G(^RGHL7(991.1,PTEN,SUB,1,0)),"^",5)=1 W !,"Potential Match Review is Only Available for Exceptions still pending." H 5 S VALMBCK="R" Q
+7 ;S PTEN=$P(DATA,"^",10) ;IEN IN 991.1
+8 ;S PELV=$P(DATA,"^",11) ;IEN IN 991.12
+9 ;I $P($G(^RGHL7(991.1,PTEN,1,PELV,0)),"^",3)'=218 S VALMSG="Action is ONLY for POTENTIAL MATCH exceptions!",VALMBCK="R" Q
+10 ; ^**46 changed check to ensure exception is Potential Match exception
+11 ;I $E($$GETICN^MPIF001(DFN),1,3)=$P($$SITE^VASITE,"^",3) W !,"Messaging outstanding please try again in a few minutes." H 5 Q
+12 ;S VALMBCK="",MPIFRES="",MPIFINT=""
+13 ;D FULL^VALM1
+14 ;D EXC
+15 ;D PAUSE^VALM1
+16 ;K MPIFRES,MPIFINT
+17 ;N X,Y,DIR,DIE,DA,DR,IEN,IEN2,PROCDT,%,X,%I,%H
+18 ;I '$D(PROCESS) D
+19 ;.S DIR("A")="Do you want to mark this exception as processed? ",DIR(0)="YA",DIR("B")="NO" D ^DIR K DIR(0),DIR("A")
+20 ;.I Y S PROCESS=1 K X,Y
+21 ;I $D(PROCESS) D
+22 ;.;**48 CAPTURE DATE/TIME AND WHO MARKED AS PROCESSED
+23 ;.D NOW^%DTC S PROCDT=%
+24 ;.S IEN="",IEN2="",IEN=$P(DATA,"^",10),IEN2=$P(DATA,"^",11)
+25 ;.L +^RGHL7(991.1,IEN):10
+26 ;.S DA(1)=IEN,DA=IEN2,DR="6///"_1_";7///"_PROCDT_";8///"_$G(DUZ),DIE="^RGHL7(991.1,"_DA(1)_",1," D ^DIE K DIE,DA,DR
+27 ;.L -^RGHL7(991.1,IEN)
+28 ;.S $P(DATA,"^",9)=1
+29 ;K PROCESS
+30 QUIT
EXC ; Exception Entry Point
+1 ;Data Returned from GETDATA in ICN array
NEW LOCDATA
+2 DO GETDATA("^DPT(",DFN,"LOCDATA",".01;.02;.03;.09;.301;391;1901")
+3 SET LOCDATA(2,DFN,991.01)=$PIECE($$MPINODE^MPIFAPI(DFN),"^")
SET TSSN=LOCDATA(2,DFN,.09)
+4 SET HLP("ACKTIME")=300
SET MPIQRYNM="POTENTIAL_DUP_RES"
+5 NEW TIME,%
DO NOW^%DTC
SET TIME=%
+6 NEW HL,MPIINM,MPIOUT,MPIIN,MPIMCNT,MPICNT,MPICS,HEADER,TEST,SITE,MPIDC,SSN
+7 SET HL("ECH")="^~\&"
SET HL("FS")="|"
+8 SET MPIIN=""
SET MPIMCNT=DFN
SET MPICNT=1
SET MPICS=$EXTRACT(HL("ECH"),1)
SET MPIFRES=1
+9 DO VTQ1^MPIFVTQ(DFN,.MPIOUT,.HL,.MPIQRYNM)
+10 IF +MPIOUT(0)=-1
Begin DoDot:1
+11 SET ^TMP($JOB,"MPIFQ0-ERROR-LOG",DFN,TIME)=$GET(MPIOUT(0))
SET MPIFRTN="CONTINUE"
End DoDot:1
GOTO EXIT
+12 ;Create MSH
+13 SET SITE=$$SITE^VASITE
SET SITE=$PIECE(SITE,"^",3)
SET SITE=SITE\1
SET HEADER="MSH"_HL("FS")_HL("ECH")_HL("FS")_"MPI_LOAD"_HL("FS")_SITE_HL("FS")
+14 ;**38 changed VTQ to VQQ
SET HEADER=HEADER_"MPI-ICN"_HL("FS")_HL("FS")_HL("FS")_HL("FS")_"VQQ"_MPICS_"Q02"_HL("FS")_MPIMCNT_"-"_MPICNT_HL("FS")
+15 SET MPIOUT(1)=HEADER
KILL MPIOUT(0)
+16 WRITE !!,"Attempting to connect to the Master Patient Index in Austin...",!,"If no SSN or inexact DOB or common name, this request",!,"may take some time, please be patient...",!
+17 SET TEST=$$EN^HLCSAC("MPIVA DIR","MPIOUT","MPIDC")
+18 ;kill the HLP array set for the ack timeout
KILL HLP("ACKTIME")
+19 IF +TEST=-1
Begin DoDot:1
+20 SET ^TMP($JOB,"MPIFQ0-ERROR-LOG",DFN,TIME)=TEST
+21 IF '$DATA(MPIFS)
if '$DATA(MPIFRPC)
WRITE !!,"Could not connect to MPI or Timed Out. Try again later."
End DoDot:1
GOTO EXIT
+22 ;array data is parsed into for display in LM
KILL ^TMP("MPIFVQQ",$JOB),^TMP("MPIFQ0",$JOB)
INIPARS ;
+1 NEW SEG,INDEX,SKIP,CHECK,AL,TTF2,TFLL,TF,TF2,MPIREP,MPICOMP
+2 SET INDEX=0
KILL CHECK
LOOP1 ;
+1 ;process in ADT type messages
+2 NEW MPIX
SET MPIX=0
NEW REP,SG,MSG,MPIQUIT,MPINODE
+3 KILL TWODFN
SET MPIQUIT=0
+4 FOR MPIX=0:1
XECUTE "D LOOP2"
Begin DoDot:1
+5 IF $DATA(MPINODE(1))
SET SG=$EXTRACT(MPINODE(1),1,3)
SET MSG(1)=MPINODE(1)
Begin DoDot:2
+6 SET MPIJ=1
FOR
SET MPIJ=$ORDER(MPINODE(MPIJ))
if 'MPIJ
QUIT
SET MSG(MPIJ)=MPINODE(MPIJ)
+7 if SG?2A1(1A,1N)
DO @SG
End DoDot:2
End DoDot:1
KILL MPINODE,MSG
if MPIQUIT'>0
QUIT
DECIDE ;If no data in ^TMP that means the patient was not found in the MPI w/VTQ Query. So we go to A28 to add the patient to the MPI.
+1 NEW EXC,TEXT,EXACT,EXACT2,DATA,NODE2,ICN,CHKSUM,MORE,COMMON
+2 IF '$DATA(^TMP("MPIFVQQ",$JOB))
WRITE !,"No Potential Matches Found.",!!,"Exception has been marked automatically as processed."
SET PROCESS=1
GOTO EXIT
+3 IF INDEX=1
Begin DoDot:1
+4 ;need to check if exact match was returned.
+5 SET DATA=^TMP("MPIFVQQ",$JOB,INDEX,"DATA")
+6 SET NODE2=$GET(^TMP("MPIFVQQ",$JOB,INDEX,"INDICATOR"))
+7 ;NAME
SET DATA(.01)=$PIECE(DATA,"^",1)
IF $EXTRACT(DATA(.01),$LENGTH(DATA(.01)))=" "
SET DATA(.01)=$EXTRACT(DATA(.01),1,$LENGTH(DATA(.01))-1)
+8 ;DOB, SSN, SEX
SET DATA(.03)=$PIECE(DATA,"^",4)
SET DATA(.09)=$PIECE(DATA,"^",3)
SET DATA(.02)=$PIECE(DATA,"^",11)
+9 SET ICN=$PIECE(DATA,"^",6)
SET CHKSUM=$PIECE(ICN,"V",2)
SET ICN=$PIECE(ICN,"V",1)
SET DATA(991.01)=ICN
SET DATA(991.02)=CHKSUM
SET DATA(991.03)=$$LKUP^XUAF4($PIECE(DATA,"^",5))
+10 if NODE2["*"
QUIT
+11 ;^ ICN is already known at this site
+12 ;check if this patient has another VISTA site now OR tfs in common
+13 SET (MORE,COMMON)=0
+14 DO COMPARE^MPIF002(DFN,INDEX,.COMMON,.MORE)
+15 if COMMON!(MORE)
QUIT
+16 ; check that now have an exact match returned
+17 NEW MPIFD,SSN,NAME,SEX,NAME3,BIR
KILL COMMON,MORE
+18 DO GETDATA^MPIFQ0("^DPT(",DFN,"MPIFD",".01;.09;.02;.03","EI")
+19 SET SSN=$GET(MPIFD(2,DFN,.09,"E"))
SET NAME=$GET(MPIFD(2,DFN,.01,"E"))
SET SEX=$GET(MPIFD(2,DFN,.02,"I"))
+20 SET BIR=$GET(MPIFD(2,DFN,.03,"I"))
IF BIR]""
SET BIR=$TRANSLATE($$FMTE^XLFDT(BIR,"5D"),"/","-")
+21 ; if dob doesn't match -- not allowed to update ICN automatically
+22 if DATA(.03)'=BIR
QUIT
+23 ; if sex doesn't match -- not allowed to update ICN automatically
+24 if DATA(.02)'=SEX
QUIT
+25 ;if dob doesn't match -- not allowed to update ICN automatically
+26 IF SSN["P"
SET SSN=""
+27 if DATA(.09)'=SSN
QUIT
+28 ;reformat name into DG 149 format
DO NAME^VAFCPID2(0,.NAME,0)
+29 ;reformat name into DG 149 format
SET NAME3=DATA(.01)
DO NAME^VAFCPID2(0,.NAME3,0)
SET DATA(.01)=NAME3
+30 ; check if Last, First MATCH if so is it a middle name vs middle initial
+31 IF $PIECE(DATA(.01),",")=$PIECE(NAME,",")&($PIECE($PIECE(NAME,",",2)," ")=$PIECE($PIECE(DATA(.01),",",2)," "))
Begin DoDot:2
+32 NEW MPIMID,NMMN
SET MPIMID=$PIECE($PIECE(DATA(.01),",",2)," ",2)
+33 SET NMMN=$PIECE($PIECE(NAME,",",2)," ",2)
+34 IF $LENGTH(NMMN)>1&($LENGTH(MPIMID)=1)
IF ($EXTRACT(NMMN,1)=MPIMID)
SET EXACT=1
+35 IF $LENGTH(MPIMID)>1&($LENGTH(NMMN)=1)
IF ($EXTRACT(MPIMID,1)=NMMN)
SET EXACT=1
End DoDot:2
+36 IF DATA(.01)=NAME!($DATA(EXACT))
KILL DATA(.09),DATA(.01),DATA(.03)
Begin DoDot:2
+37 NEW PID2,ERR
+38 DO INIT^HLFNC2("MPIF ADT-A24 SERVER",.HL)
+39 DO BLDPID^VAFCQRY(DFN,2,"ALL",.PID2,.HL,.ERR)
+40 ;**48 want to resolve an reject exceptions for "current" ICN
+41 DO RESEX(DFN)
+42 DO EDIT^MPIFQED(DFN,"DATA")
DO MSG3^MPIFQ3
DO PROMPT^MPIFQ3
+43 ;send a24 link icns
SET RESLT=$$A24^MPIFA24B(DFN,.PID2)
+44 SET PROCESS=1
End DoDot:2
QUIT
End DoDot:1
+45 IF $GET(PROCESS)=1
GOTO END
+46 DO START^MPIFD1(INDEX)
GOTO END
EXIT IF $DATA(MPIFINT)
KILL MPIFINT,MPIFRES,MPIQRYNM,TSSN,TWODFN,SDFN
+1 KILL VALMCNT,VALMLST,CCMOR,FICN
HANG 3
if '$DATA(MPIFRPC)
WRITE !!
END KILL ^TMP("MPIFVQQ",$JOB),^TMP("MPIFQ0",$JOB)
QUIT
+1 ;
GETDATA(DIC,DA,MPIFAR,DR,EI) ;
+1 ;This function returns the values stored in the fields via FM call DIQ1
+2 ;DIC=file reference, DA=IEN in file, ARRAY=array for the values to be stored in, DR=fields requested, EI=external/internal values
+3 NEW DIQ
SET DIQ=MPIFAR
+4 IF $GET(EI)]""
SET DIQ(0)=EI
+5 DO EN^DIQ1
+6 QUIT
LOOP2 ;
+1 NEW MPIDONE,MPII,MPIJ
+2 SET MPII=0
SET MPIDONE=0
+3 FOR
SET MPIQUIT=$ORDER(MPIDC(MPIQUIT))
if 'MPIQUIT
QUIT
Begin DoDot:1
+4 IF MPIDC(MPIQUIT)=""
SET MPIDONE=1
QUIT
+5 SET MPII=MPII+1
SET MPINODE(MPII)=$GET(MPIDC(MPIQUIT))
QUIT
End DoDot:1
if MPIDONE
QUIT
+6 QUIT
MSH ;
+1 SET MPIREP=$EXTRACT(HL("ECH"),2)
SET MPICOMP=$EXTRACT(HL("ECH"),1)
+2 QUIT
MSA ;
+1 QUIT
RDF ;
+1 QUIT
QAK ;**43 added check for potential matches
+1 KILL MPIPOT
SET MPIPOT=0
+2 IF MSG(1)["POTENTIAL MATCHES"
SET MPIPOT=1
+3 SET SDFN=$PIECE(MSG(1),HL("FS"),2)
+4 QUIT
RDT ;
+1 NEW NAME,ICN,BIRTHDAY,CMOR,IEN,SEG,HEREICN,STRING,LASTNAME,FRSTNAME,MIDDLE,SUFF,SEX,THISGUY
+2 SET STRING=""
SET INDEX=$GET(INDEX)+1
+3 DO RDT^MPIFSA3(.INDEX,.HL,.MSG)
+4 SET SEG=^TMP("MPIFVQQ",$JOB,INDEX,"DATA")
+5 SET FRSTNAME=$PIECE(SEG,"^",7)
SET LASTNAME=$PIECE(SEG,"^",2)
SET MIDDLE=$PIECE(SEG,"^",10)
SET SUFF=$PIECE(SEG,"^",15)
+6 SET SSN=$PIECE(SEG,"^",3)
SET NAME=LASTNAME_","_FRSTNAME
+7 IF MIDDLE'=""
SET NAME=NAME_" "_MIDDLE
+8 IF SUFF'=""
SET NAME=NAME_" "_SUFF
+9 SET SEX=$PIECE(SEG,"^",11)
+10 SET ICN=$PIECE(SEG,"^",6)
+11 SET THISGUY=$$GETDFN^MPIF001(+ICN)
IF THISGUY=DFN
QUIT
+12 SET BIRTHDAY=$PIECE(SEG,"^",4)
+13 SET CMOR=$PIECE(SEG,"^",5)
SET IEN=$$IEN^XUAF4(CMOR)
+14 SET CMOR=$PIECE($$NS^XUAF4(IEN),"^")
+15 SET HEREICN=$$HEREICN^MPIFQ3($PIECE(ICN,"V",1))
+16 IF HEREICN
SET STRING=$$SETSTR^VALM1("*",STRING,1,1)
SET ^TMP("MPIFVQQ",$JOB,INDEX,"INDICATOR")="*"_"^"_HEREICN
+17 SET STRING=$$SETSTR^VALM1(INDEX,STRING,2,4)
SET STRING=$$SETSTR^VALM1($EXTRACT(NAME,1,23),STRING,6,23)
+18 SET STRING=$$SETSTR^VALM1(SSN,STRING,30,9)
SET STRING=$$SETSTR^VALM1(BIRTHDAY,STRING,41,10)
+19 SET STRING=$$SETSTR^VALM1(CMOR,STRING,54,20)
+20 SET ^TMP("MPIFVQQ",$JOB,INDEX,0)=STRING
SET ^TMP("MPIFVQQ",$JOB,"IDX",INDEX,INDEX)=""
+21 QUIT
RESEX(DFN,POT) ;look for any pv reject (234) exceptions and resolve them for this DFN
+1 ;IF POT IS SET TO 2 LOOK FOR ANY POTENTIAL MATCH (218) EXCEPTIONS AND RESOLVE THEM FOR THIS DFN
+2 ;**48 CREATED THIS API
+3 NEW IEN,DA,DR,PROCDT,DIE,IEN2
+4 SET IEN=0
+5 FOR
SET IEN=$ORDER(^RGHL7(991.1,"ADFN",234,DFN,IEN))
if IEN=""
QUIT
Begin DoDot:1
+6 SET IEN2=$ORDER(^RGHL7(991.1,"ADFN",234,DFN,IEN,""))
+7 ;**ALREADY MARKED AS PROCESSED
if $PIECE(^RGHL7(991.1,IEN,1,IEN2,0),"^",5)=1
QUIT
+8 DO NOW^%DTC
SET PROCDT=%
+9 LOCK +^RGHL7(991.1,IEN):10
+10 SET DA(1)=IEN
SET DA=IEN2
SET DR="6///"_1_";7///"_PROCDT_";8///"_$GET(DUZ)
SET DIE="^RGHL7(991.1,"_DA(1)_",1,"
DO ^DIE
KILL DIE,DA,DR
+11 LOCK -^RGHL7(991.1,IEN)
End DoDot:1
+12 ;
+13 ;I $G(POT)=2 D ;**53 MPIC_1853 Remove 218 references
+14 ;.S IEN=0
+15 ;.F S IEN=$O(^RGHL7(991.1,"ADFN",218,DFN,IEN)) Q:IEN="" D
+16 ;..S IEN2=$O(^RGHL7(991.1,"ADFN",218,DFN,IEN,""))
+17 ;..Q:$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",5)=1 ;**ALREADY MARKED AS PROCESSED
+18 ;..D NOW^%DTC S PROCDT=%
+19 ;..L +^RGHL7(991.1,IEN):10
+20 ;..S DA(1)=IEN,DA=IEN2,DR="6///"_1_";7///"_PROCDT_";8///"_$G(DUZ),DIE="^RGHL7(991.1,"_DA(1)_",1," D ^DIE K DIE,DA,DR
+21 ;..L -^RGHL7(991.1,IEN)
+22 QUIT
