MPIFA43 ;BIR/DLR-Utility for processing an ADT-A43 Un-link ID ; 5/4/20 11:01am
;;1.0;MASTER PATIENT INDEX VISTA;**22,41,46,54,75**;30 Apr 99;Build 1
DBIA ; Supported IA's
;
;IA: 2796 - EXC, START, and STOP^RGHLLOG
;IA: 2988 - $$DELALLTF and $$DELETETF^VAFCTFU
;IA: 3767 - PIDP^RGADTP1
;
IN ;Entry point for processing ADT-A43 - Move patient information
;Called from the MPIF ADT-A43 CLIENT protocol processing routine
;There are no inputs or outputs
;
N MPIF,STATN,MPIFI,MSG,SG,MPIFARR,PDFN,INST,MFUPT,PDLT,TFIEN,ICNAUTH,MPISITE,MRG
N ICN,HLCOMP,CNT,X,MPIFERR,MPIFX,MPIDFN,MPISSN,ERROR,DFN,NODE,CMOR2,PID,ARRAY
S MPISSN="",MPIDFN="",ICN="",ERROR=""
INIT ;Process in the ADT-A43 Move Patient Identifier msg
F MPII=1:1 X HLNEXT Q:HLQUIT'>0 S MSG=HLNODE D
.S MPIJ=0 F S MPIJ=$O(HLNODE(MPIJ)) Q:'MPIJ S MSG(MPIJ)=HLNODE(MPIJ)
.S SG=$E(HLNODE,1,3),MPIF(MPII)=HLNODE D:SG?2A1(1A,1N) PICK
.;**45 ABOVE TO REPLACE COMMENTED LINE BELOW
;F MPIFI=1:1 X HLNEXT Q:HLQUIT'>0 S (MSG,MPIF(MPIFI))=HLNODE,SG=$E(HLNODE,1,3) D:SG?2A1(1A,1N) PICK
D MOVE(.ARRAY,.ERROR)
;create response message
S CNT=1
S HLA("HLA",1)="MSA"_HL("FS")_$S($G(ERROR)=0:"AA",1:"AE")_HL("FS")_HL("MID")_HL("FS")_$S($G(ERROR)=0:"",1:$P(ERROR,"^",2)) S CNT=CNT+1
D ROUTE
;Send back the appl. ack (ACK) with the ADT-A43 transaction status
D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.MPIFERR,"",.HLP)
Q
PICK ;check routine for segment entry point
I $T(@SG)]"" D @SG
I $T(@SG)="" Q
Q
MSH ;;MSH
;process the MSH segment
S (HLFS,HL("FS"))=$E(MSG,4),(HLECH,HL("ECH"))=$E(MSG,5,8)
S HLCOMP=$E(HL("ECH"),1)
S MPIFARR("SENDING SITE")=$P(MSG,HL("FS"),4)
Q
EVN ;;EVN
;process the EVN segment
S STATN=+$$SITE^VASITE()_"^"_$$FMDATE^HLFNC($P(MSG,HL("FS"),3))
Q
PID ;;PID
;process the PID segment
N COMP,REP,SUBCOMP,AUTH,IDTYP,LOC,AUTHTYP,MPIJ
S COMP=$E(HL("ECH"),1),SUBCOMP=$E(HL("ECH"),4),REP=$E(HL("ECH"),2)
S MPIJ=$P(MSG,HL("FS"),2)
D PIDP^RGADTP1(.MSG,.ARRAY,.HL)
;ARRAY("ICN") = NEW ICN and ARRAY("DFN") = mismatched record to be corrected
Q
PD1 ;processing PD1 fields for new CMOR
N COMP
S COMP=$E(HL("ECH"),1)
S ARRAY("CMOR")=$P($P(HLNODE,HL("FS"),4),COMP,3)
Q
MRG ;
N COMP,REP,SUBCOMP,AUTH,IDTYP,LOC,AUTHTYP,FID,ID
S COMP=$E(HL("ECH"),1),SUBCOMP=$E(HL("ECH"),4),REP=$E(HL("ECH"),2)
N MPIFX,ID,AUTH
S FID=$P(MSG,HL("FS"),2)
F MPIFX=1:1:$L(FID,REP)+1 S ID=$P(FID,REP,MPIFX),PID=$P(ID,COMP),AUTH=$P($P(ID,COMP,4),SUBCOMP),AUTHTYP=$P($P(ID,COMP,4),SUBCOMP,2),IDTYP=$P(ID,COMP,5),LOC=$P($P(ID,COMP,6),SUBCOMP,2) D
. I AUTH="USSSA" S MPISSN=PID
. ;capture the old or mismatched ICN in ARRAY("ICNMISMATCH")
. I AUTH="USVHA" I IDTYP="NI" S (ARRAY("ICNMISMATCH"),ICN)=PID S ARRAY("ICNMISMATCHLOC")=LOC
. I AUTH="USVHA" I IDTYP="PI" S MPIDFN=PID S ARRAY("DFNLOC")=LOC
Q
RSP ;response process logic entry point
Q
ROUTE ;routing logic entry point
N MPI S MPI=$$MPILINK^MPIFAPI() D
.;**75 - Story - 1260465 (ckn) - Include 200M in HLL links for HAC
.I $P($G(MPI),U)'=-1 S HLL("LINKS",1)="MPIF ADT-A43 CLIENT"_"^"_MPI_$S($P($$SITE^VASITE(),"^",3)=741:"^200M",1:"")
.I $P($G(MPI),U)=-1 D
..N RGLOG D START^RGHLLOG(HLMTIEN,"","")
..D EXC^RGHLLOG(224,"No MPI link identified ",$G(PDFN))
..D STOP^RGHLLOG(0)
Q
MOVE(ARRAY,ERROR) ;
;replace ARRAY("ICNMISMATCHED") with ARRAY("ICN")
N MPIARR
S ERROR=0
;I ARRAY("DFNLOC")="" OLD MESSAGING SO USE ARRAY("ICNMISMATCHLOC")
I $G(ARRAY("DFNLOC"))="" S ARRAY("DFNLOC")=ARRAY("ICNMISMATCHLOC")
I $G(ARRAY("CMOR"))="" S ARRAY("CMOR")=ARRAY("DFNLOC")
;if assigning authority'= site station# then Quit because this is not the mismatched site so MFN-M05 sent as a result of site removal on MPI will remove it from all sites TF list
;**75 - Story 1260465 (ckn) - specific to HAC Site (741)
I ARRAY("DFNLOC")="741MM" S ARRAY("DFNLOC")=741
I ARRAY("DFNLOC")'=$P($$SITE^VASITE,"^",3) D Q
.;if assigning authority '= site station# then remove assigning authority from TF list for the given ICN
.N MPISITE S MPISITE=$$IEN^XUAF4(ARRAY("DFNLOC"))
. I ARRAY("DFNLOC")'>0 S ERROR="-1^Unable to remove station#"_ARRAY("DFNLOC")_" from TF list" Q
.;**54 - MVI_1009 (ckn) - Do not call DELETETF
.; I +ARRAY("DFNLOC")>0 S ERROR=$$DELETETF^VAFCTFU(+ARRAY("ICNMISMATCH"),MPISITE)
;delete all TF's for this mismatched record
S ERROR=$$DELALLTF^VAFCTFU(ARRAY("ICNMISMATCH"))
;if ARRAY("DFN")="" assume this is old message format and use ARRAY("ICNMISMATCHED") to get the DFN that was mismatched
I $G(ARRAY("DFN"))="" D Q
. S ARRAY("DFN")=$$GETDFN^MPIF001(ARRAY("ICNMISMATCH")) I +ARRAY("DFN")'>0 S ERROR="-1^Unable to break ICN "_ARRAY("ICNMISMATCH")_" because that ICN is unknown"
. Q:+$G(ERROR)=-1
. S MPIARR(991.01)="@",MPIARR(991.02)="@",MPIARR(991.03)="@",MPIARR(991.05)="@",MPIARR(992)=$P(ARRAY("ICNMISMATCH"),"V"),MPIARR(993)=$P($$SITE^VASITE,"^")
. S ERROR=$$UPDATE^MPIFAPI(ARRAY("DFN"),"MPIARR",1)
;if new messaging
I ARRAY("ICN")'="""" D
. ;delete the entry first to prevent the ICN from going into history
. S MPIARR(991.01)="@",MPIARR(991.02)="@",MPIARR(991.03)="@",MPIARR(991.05)="@",MPIARR(992)=$P(ARRAY("ICNMISMATCH"),"V"),MPIARR(993)=$P($$SITE^VASITE,"^")
. S ERROR=$$UPDATE^MPIFAPI(ARRAY("DFN"),"MPIARR",1)
. ;update the record with the new ICN
. S MPIARR(991.01)=$P(ARRAY("ICN"),"V"),MPIARR(991.02)=$P(ARRAY("ICN"),"V",2),MPIARR(991.03)=$$IEN^XUAF4(ARRAY("CMOR")),MPIARR(991.05)="@",MPIARR(992)=$P(ARRAY("ICNMISMATCH"),"V"),MPIARR(993)=$P($$SITE^VASITE,"^")
;move the mismatched record from ARRAY("ICNMISMATCH") to ARRAY("ICN")
S ERROR=$$UPDATE^MPIFAPI(ARRAY("DFN"),"MPIARR",1)
;add LOCAL site to TF, if CMOR is different it will be auto added
D FILE^VAFCTFU(ARRAY("DFN"),+$$SITE^VASITE,1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMPIFA43 5793 printed Apr 09, 2024@21:12:59 Page 2
MPIFA43 ;BIR/DLR-Utility for processing an ADT-A43 Un-link ID ; 5/4/20 11:01am
+1 ;;1.0;MASTER PATIENT INDEX VISTA;**22,41,46,54,75**;30 Apr 99;Build 1
DBIA ; Supported IA's
+1 ;
+2 ;IA: 2796 - EXC, START, and STOP^RGHLLOG
+3 ;IA: 2988 - $$DELALLTF and $$DELETETF^VAFCTFU
+4 ;IA: 3767 - PIDP^RGADTP1
+5 ;
IN ;Entry point for processing ADT-A43 - Move patient information
+1 ;Called from the MPIF ADT-A43 CLIENT protocol processing routine
+2 ;There are no inputs or outputs
+3 ;
+4 NEW MPIF,STATN,MPIFI,MSG,SG,MPIFARR,PDFN,INST,MFUPT,PDLT,TFIEN,ICNAUTH,MPISITE,MRG
+5 NEW ICN,HLCOMP,CNT,X,MPIFERR,MPIFX,MPIDFN,MPISSN,ERROR,DFN,NODE,CMOR2,PID,ARRAY
+6 SET MPISSN=""
SET MPIDFN=""
SET ICN=""
SET ERROR=""
INIT ;Process in the ADT-A43 Move Patient Identifier msg
+1 FOR MPII=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
SET MSG=HLNODE
Begin DoDot:1
+2 SET MPIJ=0
FOR
SET MPIJ=$ORDER(HLNODE(MPIJ))
if 'MPIJ
QUIT
SET MSG(MPIJ)=HLNODE(MPIJ)
+3 SET SG=$EXTRACT(HLNODE,1,3)
SET MPIF(MPII)=HLNODE
if SG?2A1(1A,1N)
DO PICK
+4 ;**45 ABOVE TO REPLACE COMMENTED LINE BELOW
End DoDot:1
+5 ;F MPIFI=1:1 X HLNEXT Q:HLQUIT'>0 S (MSG,MPIF(MPIFI))=HLNODE,SG=$E(HLNODE,1,3) D:SG?2A1(1A,1N) PICK
+6 DO MOVE(.ARRAY,.ERROR)
+7 ;create response message
+8 SET CNT=1
+9 SET HLA("HLA",1)="MSA"_HL("FS")_$SELECT($GET(ERROR)=0:"AA",1:"AE")_HL("FS")_HL("MID")_HL("FS")_$SELECT($GET(ERROR)=0:"",1:$PIECE(ERROR,"^",2))
SET CNT=CNT+1
+10 DO ROUTE
+11 ;Send back the appl. ack (ACK) with the ADT-A43 transaction status
+12 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.MPIFERR,"",.HLP)
+13 QUIT
PICK ;check routine for segment entry point
+1 IF $TEXT(@SG)]""
DO @SG
+2 IF $TEXT(@SG)=""
QUIT
+3 QUIT
MSH ;;MSH
+1 ;process the MSH segment
+2 SET (HLFS,HL("FS"))=$EXTRACT(MSG,4)
SET (HLECH,HL("ECH"))=$EXTRACT(MSG,5,8)
+3 SET HLCOMP=$EXTRACT(HL("ECH"),1)
+4 SET MPIFARR("SENDING SITE")=$PIECE(MSG,HL("FS"),4)
+5 QUIT
EVN ;;EVN
+1 ;process the EVN segment
+2 SET STATN=+$$SITE^VASITE()_"^"_$$FMDATE^HLFNC($PIECE(MSG,HL("FS"),3))
+3 QUIT
PID ;;PID
+1 ;process the PID segment
+2 NEW COMP,REP,SUBCOMP,AUTH,IDTYP,LOC,AUTHTYP,MPIJ
+3 SET COMP=$EXTRACT(HL("ECH"),1)
SET SUBCOMP=$EXTRACT(HL("ECH"),4)
SET REP=$EXTRACT(HL("ECH"),2)
+4 SET MPIJ=$PIECE(MSG,HL("FS"),2)
+5 DO PIDP^RGADTP1(.MSG,.ARRAY,.HL)
+6 ;ARRAY("ICN") = NEW ICN and ARRAY("DFN") = mismatched record to be corrected
+7 QUIT
PD1 ;processing PD1 fields for new CMOR
+1 NEW COMP
+2 SET COMP=$EXTRACT(HL("ECH"),1)
+3 SET ARRAY("CMOR")=$PIECE($PIECE(HLNODE,HL("FS"),4),COMP,3)
+4 QUIT
MRG ;
+1 NEW COMP,REP,SUBCOMP,AUTH,IDTYP,LOC,AUTHTYP,FID,ID
+2 SET COMP=$EXTRACT(HL("ECH"),1)
SET SUBCOMP=$EXTRACT(HL("ECH"),4)
SET REP=$EXTRACT(HL("ECH"),2)
+3 NEW MPIFX,ID,AUTH
+4 SET FID=$PIECE(MSG,HL("FS"),2)
+5 FOR MPIFX=1:1:$LENGTH(FID,REP)+1
SET ID=$PIECE(FID,REP,MPIFX)
SET PID=$PIECE(ID,COMP)
SET AUTH=$PIECE($PIECE(ID,COMP,4),SUBCOMP)
SET AUTHTYP=$PIECE($PIECE(ID,COMP,4),SUBCOMP,2)
SET IDTYP=$PIECE(ID,COMP,5)
SET LOC=$PIECE($PIECE(ID,COMP,6),SUBCOMP,2)
Begin DoDot:1
+6 IF AUTH="USSSA"
SET MPISSN=PID
+7 ;capture the old or mismatched ICN in ARRAY("ICNMISMATCH")
+8 IF AUTH="USVHA"
IF IDTYP="NI"
SET (ARRAY("ICNMISMATCH"),ICN)=PID
SET ARRAY("ICNMISMATCHLOC")=LOC
+9 IF AUTH="USVHA"
IF IDTYP="PI"
SET MPIDFN=PID
SET ARRAY("DFNLOC")=LOC
End DoDot:1
+10 QUIT
RSP ;response process logic entry point
+1 QUIT
ROUTE ;routing logic entry point
+1 NEW MPI
SET MPI=$$MPILINK^MPIFAPI()
Begin DoDot:1
+2 ;**75 - Story - 1260465 (ckn) - Include 200M in HLL links for HAC
+3 IF $PIECE($GET(MPI),U)'=-1
SET HLL("LINKS",1)="MPIF ADT-A43 CLIENT"_"^"_MPI_$SELECT($PIECE($$SITE^VASITE(),"^",3)=741:"^200M",1:"")
+4 IF $PIECE($GET(MPI),U)=-1
Begin DoDot:2
+5 NEW RGLOG
DO START^RGHLLOG(HLMTIEN,"","")
+6 DO EXC^RGHLLOG(224,"No MPI link identified ",$GET(PDFN))
+7 DO STOP^RGHLLOG(0)
End DoDot:2
End DoDot:1
+8 QUIT
MOVE(ARRAY,ERROR) ;
+1 ;replace ARRAY("ICNMISMATCHED") with ARRAY("ICN")
+2 NEW MPIARR
+3 SET ERROR=0
+4 ;I ARRAY("DFNLOC")="" OLD MESSAGING SO USE ARRAY("ICNMISMATCHLOC")
+5 IF $GET(ARRAY("DFNLOC"))=""
SET ARRAY("DFNLOC")=ARRAY("ICNMISMATCHLOC")
+6 IF $GET(ARRAY("CMOR"))=""
SET ARRAY("CMOR")=ARRAY("DFNLOC")
+7 ;if assigning authority'= site station# then Quit because this is not the mismatched site so MFN-M05 sent as a result of site removal on MPI will remove it from all sites TF list
+8 ;**75 - Story 1260465 (ckn) - specific to HAC Site (741)
+9 IF ARRAY("DFNLOC")="741MM"
SET ARRAY("DFNLOC")=741
+10 IF ARRAY("DFNLOC")'=$PIECE($$SITE^VASITE,"^",3)
Begin DoDot:1
+11 ;if assigning authority '= site station# then remove assigning authority from TF list for the given ICN
+12 NEW MPISITE
SET MPISITE=$$IEN^XUAF4(ARRAY("DFNLOC"))
+13 IF ARRAY("DFNLOC")'>0
SET ERROR="-1^Unable to remove station#"_ARRAY("DFNLOC")_" from TF list"
QUIT
+14 ;**54 - MVI_1009 (ckn) - Do not call DELETETF
+15 ; I +ARRAY("DFNLOC")>0 S ERROR=$$DELETETF^VAFCTFU(+ARRAY("ICNMISMATCH"),MPISITE)
End DoDot:1
QUIT
+16 ;delete all TF's for this mismatched record
+17 SET ERROR=$$DELALLTF^VAFCTFU(ARRAY("ICNMISMATCH"))
+18 ;if ARRAY("DFN")="" assume this is old message format and use ARRAY("ICNMISMATCHED") to get the DFN that was mismatched
+19 IF $GET(ARRAY("DFN"))=""
Begin DoDot:1
+20 SET ARRAY("DFN")=$$GETDFN^MPIF001(ARRAY("ICNMISMATCH"))
IF +ARRAY("DFN")'>0
SET ERROR="-1^Unable to break ICN "_ARRAY("ICNMISMATCH")_" because that ICN is unknown"
+21 if +$GET(ERROR)=-1
QUIT
+22 SET MPIARR(991.01)="@"
SET MPIARR(991.02)="@"
SET MPIARR(991.03)="@"
SET MPIARR(991.05)="@"
SET MPIARR(992)=$PIECE(ARRAY("ICNMISMATCH"),"V")
SET MPIARR(993)=$PIECE($$SITE^VASITE,"^")
+23 SET ERROR=$$UPDATE^MPIFAPI(ARRAY("DFN"),"MPIARR",1)
End DoDot:1
QUIT
+24 ;if new messaging
+25 IF ARRAY("ICN")'=""""
Begin DoDot:1
+26 ;delete the entry first to prevent the ICN from going into history
+27 SET MPIARR(991.01)="@"
SET MPIARR(991.02)="@"
SET MPIARR(991.03)="@"
SET MPIARR(991.05)="@"
SET MPIARR(992)=$PIECE(ARRAY("ICNMISMATCH"),"V")
SET MPIARR(993)=$PIECE($$SITE^VASITE,"^")
+28 SET ERROR=$$UPDATE^MPIFAPI(ARRAY("DFN"),"MPIARR",1)
+29 ;update the record with the new ICN
+30 SET MPIARR(991.01)=$PIECE(ARRAY("ICN"),"V")
SET MPIARR(991.02)=$PIECE(ARRAY("ICN"),"V",2)
SET MPIARR(991.03)=$$IEN^XUAF4(ARRAY("CMOR"))
SET MPIARR(991.05)="@"
SET MPIARR(992)=$PIECE(ARRAY("ICNMISMATCH"),"V")
SET MPIARR(993)=$PIECE($$SITE^VASITE,"^")
End DoDot:1
+31 ;move the mismatched record from ARRAY("ICNMISMATCH") to ARRAY("ICN")
+32 SET ERROR=$$UPDATE^MPIFAPI(ARRAY("DFN"),"MPIARR",1)
+33 ;add LOCAL site to TF, if CMOR is different it will be auto added
+34 DO FILE^VAFCTFU(ARRAY("DFN"),+$$SITE^VASITE,1)
+35 QUIT
