MPIFA37 ;BIR/DLR-Utility for processing an ADT-A37 Un-link ID ;DEC 11, 2001
;;1.0; MASTER PATIENT INDEX VISTA ;**22**;30 Apr 99
DBIA ; Supported IA's
;
;IA: 2796 - EXC, START, and STOP^RGHLLOG
;IA: 2988 - $$DELALLTF and $$DELETETF^VAFCTFU
;
IN ;Entry point for processing ADT-A37 - unlink patient information
;Called from the MPIF ADT-A37 CLIENT protocol processing routine
;There are no inputs or outputs
;
N MPIF,STATN,MPIFI,MSG,SG,MPIFARR,PDFN,INST,MFUPT,PDLT,TFIEN,ICNAUTH,MPISITE
N ICN,HLCOMP,CNT,X,MPIFERR,MPIFX,MPIDFN,MPISSN,ERROR,DFN,NODE,CMOR2,PID
S MPISSN="",MPIDFN="",ICN="",ERROR=""
INIT ;Process in the Treating Facility MFN msg
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
;replace/remove/unlink the mismatched ICN in PID(2) as well as the old CMOR from the patients record
S CMOR2="",DFN=$$GETDFN^MPIF001(+PID(2)) I +DFN>0 S NODE=$$MPINODE^MPIFAPI(DFN) I NODE'="" S CMOR2=$P(NODE,"^",3)
;if assigning authority = site station# then remove the ICN from site
I $P(PID(2),"^",2)=$P($$SITE^VASITE,"^",3) D REPLACE("@","",PID(2),CMOR2,.ERROR)
;if assigning authority '= site station# then remove assigning authority from TF list for the given ICN
I $P(PID(2),"^",2)'=$P($$SITE^VASITE,"^",3) S MPISITE=$$IEN^XUAF4($P(PID(2),"^",2)) D
. I $P(PID(2),"^",2)'>0 S ERROR="-1^Unable to remove station#"_$P(PID(2),"^",2)_" from TF list" Q
. I +$P(PID(2),"^",2)>0 S ERROR=$$DELETETF^VAFCTFU(ICN,MPISITE)
S ERROR=$S(+ERROR=0:"",1:$P(ERROR,"^",2))
;create response message
S CNT=1
S HLA("HLA",1)="MSA"_HL("FS")_"AA"_HL("FS")_HL("MID")_HL("FS")_$G(ERROR) S CNT=CNT+1
;Send back the appl. ack (ACK) with the ADT-A37 transaction status
D ROUTE
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 ARRAY,MPIJ
D PIDP^RGADTP1(.MSG,.ARRAY,.HL)
S MPIJ=$P(MSG,HL("FS"),2)
S MPISSN=$G(ARRAY("SSN")),MPIDFN=$G(ARRAY("DFN")),ICN=$G(ARRAY("ICN"))
S PID(MPIJ)=+ICN_"^"_$G(ARRAY("MPISSITE"))
Q
RESP ;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-A37 CLIENT"_"^"_MPI
.I $P($G(MPI),U)=-1 D
.. N RGLOG D START^RGHLLOG(HLMTIEN,"","")
.. D EXC^RGHLLOG(224,"Unable to send ADT-A37 for DFN"_$G(DFN)_" : No MPI link identified",$G(PDFN))
.. D STOP^RGHLLOG(0)
Q
REPLACE(ICN1,CMOR1,ICN2,CMOR2,ERROR) ;
;replace icn1 with icn2 and cmor1 with cmor2
N MPIARR
S ERROR=0
I $G(ICN2)'="" S DFN=$$GETDFN^MPIF001(+ICN2) I +DFN'>0 S ERROR="-1^Unable to break ICN "_+ICN2_" 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(ICN2,"V"),MPIARR(993)=CMOR2
S ERROR=$$DELALLTF^VAFCTFU(+ICN2)
S ERROR=$$UPDATE^MPIFAPI(DFN,"MPIARR",1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMPIFA37 3283 printed Dec 13, 2024@02:10:50 Page 2
MPIFA37 ;BIR/DLR-Utility for processing an ADT-A37 Un-link ID ;DEC 11, 2001
+1 ;;1.0; MASTER PATIENT INDEX VISTA ;**22**;30 Apr 99
DBIA ; Supported IA's
+1 ;
+2 ;IA: 2796 - EXC, START, and STOP^RGHLLOG
+3 ;IA: 2988 - $$DELALLTF and $$DELETETF^VAFCTFU
+4 ;
IN ;Entry point for processing ADT-A37 - unlink patient information
+1 ;Called from the MPIF ADT-A37 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
+5 NEW ICN,HLCOMP,CNT,X,MPIFERR,MPIFX,MPIDFN,MPISSN,ERROR,DFN,NODE,CMOR2,PID
+6 SET MPISSN=""
SET MPIDFN=""
SET ICN=""
SET ERROR=""
INIT ;Process in the Treating Facility MFN msg
+1 FOR MPIFI=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
SET (MSG,MPIF(MPIFI))=HLNODE
SET SG=$EXTRACT(HLNODE,1,3)
if SG?2A1(1A,1N)
DO PICK
+2 ;replace/remove/unlink the mismatched ICN in PID(2) as well as the old CMOR from the patients record
+3 SET CMOR2=""
SET DFN=$$GETDFN^MPIF001(+PID(2))
IF +DFN>0
SET NODE=$$MPINODE^MPIFAPI(DFN)
IF NODE'=""
SET CMOR2=$PIECE(NODE,"^",3)
+4 ;if assigning authority = site station# then remove the ICN from site
+5 IF $PIECE(PID(2),"^",2)=$PIECE($$SITE^VASITE,"^",3)
DO REPLACE("@","",PID(2),CMOR2,.ERROR)
+6 ;if assigning authority '= site station# then remove assigning authority from TF list for the given ICN
+7 IF $PIECE(PID(2),"^",2)'=$PIECE($$SITE^VASITE,"^",3)
SET MPISITE=$$IEN^XUAF4($PIECE(PID(2),"^",2))
Begin DoDot:1
+8 IF $PIECE(PID(2),"^",2)'>0
SET ERROR="-1^Unable to remove station#"_$PIECE(PID(2),"^",2)_" from TF list"
QUIT
+9 IF +$PIECE(PID(2),"^",2)>0
SET ERROR=$$DELETETF^VAFCTFU(ICN,MPISITE)
End DoDot:1
+10 SET ERROR=$SELECT(+ERROR=0:"",1:$PIECE(ERROR,"^",2))
+11 ;create response message
+12 SET CNT=1
+13 SET HLA("HLA",1)="MSA"_HL("FS")_"AA"_HL("FS")_HL("MID")_HL("FS")_$GET(ERROR)
SET CNT=CNT+1
+14 ;Send back the appl. ack (ACK) with the ADT-A37 transaction status
+15 DO ROUTE
+16 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.MPIFERR,"",.HLP)
+17 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 ARRAY,MPIJ
+3 DO PIDP^RGADTP1(.MSG,.ARRAY,.HL)
+4 SET MPIJ=$PIECE(MSG,HL("FS"),2)
+5 SET MPISSN=$GET(ARRAY("SSN"))
SET MPIDFN=$GET(ARRAY("DFN"))
SET ICN=$GET(ARRAY("ICN"))
+6 SET PID(MPIJ)=+ICN_"^"_$GET(ARRAY("MPISSITE"))
+7 QUIT
RESP ;response process logic entry point
+1 QUIT
ROUTE ;routing logic entry point
+1 NEW MPI
SET MPI=$$MPILINK^MPIFAPI()
Begin DoDot:1
+2 IF $PIECE($GET(MPI),U)'=-1
SET HLL("LINKS",1)="MPIF ADT-A37 CLIENT"_"^"_MPI
+3 IF $PIECE($GET(MPI),U)=-1
Begin DoDot:2
+4 NEW RGLOG
DO START^RGHLLOG(HLMTIEN,"","")
+5 DO EXC^RGHLLOG(224,"Unable to send ADT-A37 for DFN"_$GET(DFN)_" : No MPI link identified",$GET(PDFN))
+6 DO STOP^RGHLLOG(0)
End DoDot:2
End DoDot:1
+7 QUIT
REPLACE(ICN1,CMOR1,ICN2,CMOR2,ERROR) ;
+1 ;replace icn1 with icn2 and cmor1 with cmor2
+2 NEW MPIARR
+3 SET ERROR=0
+4 IF $GET(ICN2)'=""
SET DFN=$$GETDFN^MPIF001(+ICN2)
IF +DFN'>0
SET ERROR="-1^Unable to break ICN "_+ICN2_" because that ICN is unknown"
+5 if +$GET(ERROR)=-1
QUIT
+6 SET MPIARR(991.01)="@"
SET MPIARR(991.02)="@"
SET MPIARR(991.03)="@"
SET MPIARR(991.05)="@"
SET MPIARR(992)=$PIECE(ICN2,"V")
SET MPIARR(993)=CMOR2
+7 SET ERROR=$$DELALLTF^VAFCTFU(+ICN2)
+8 SET ERROR=$$UPDATE^MPIFAPI(DFN,"MPIARR",1)
+9 QUIT
