- 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 Feb 18, 2025@23:37:21 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