111 lines
5.3 KiB
Mathematica
111 lines
5.3 KiB
Mathematica
MPIFA43 ;BIR/DLR-Utility for processing an ADT-A43 Un-link ID ;MAR 18, 2002
|
|
;;1.0; MASTER PATIENT INDEX VISTA ;**22,41,46**;30 Apr 99;Build 5
|
|
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
|
|
.I $P($G(MPI),U)'=-1 S HLL("LINKS",1)="MPIF ADT-A43 CLIENT"_"^"_MPI
|
|
.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
|
|
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
|
|
. 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
|