- 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 Jan 18, 2025@03:11: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