MPIFA24 ;BPOFO/CMC-A24 PROCESSING ROUTINE ; 5/4/20 10:58am
;;1.0;MASTER PATIENT INDEX VISTA;**22,24,27,31,25,41,39,48,52,59,75**;30 Apr 99;Build 1
;
; Integration Agreements Utilized:
; START, EXC, STOP^RGHLLOG - #2796
; BLDEVN, BLDPD1, BLDPID^VAFCQRY - #3630
; ^DPT("AICN" - #2070
; DELETETF^VAFCTFU, FILE^VAFCTFU - #2988
;
;PROCESS A24 RESULTING FROM A28 ADD TO MPI MESSAGE OR FROM A40 MERGE
A24 ;
N MPII,MPIJ,ARRY,SEG,CNT,ERR,SITE,MSG,DFN,IEN,LIST,RARRY
S (CNT,ERR,FIRST)=1
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 SEG=$E(HLNODE,1,3)
.I SEG="MSH" D MSH(.ARRY,.MSG) Q
.I SEG="EVN" D EVN(.ARRY,.MSG) Q
.I SEG="PID" D PID(.ARRY,.MSG,FIRST) D:FIRST=1 S FIRST=2 Q
..;preserve the retained ICN values 991.01 and 991.02
.. S RARRY(991.01)=ARRY(991.01),RARRY(991.02)=ARRY(991.02)
.I SEG="PD1" D PD1(.ARRY,.MSG) Q
;
;restore the retained ICN values
S ARRY(991.01)=RARRY(991.01),ARRY(991.02)=RARRY(991.02)
;UPDATE 991.01, 991.02, 991.03
;**41 first check for DFN, if this DFN location is here
I $G(ARRY("DFN",2))'=""&($G(ARRY("DFNLOC"))=$P($$SITE^VASITE,"^",3)) S DFN=ARRY("DFN",2)
;**41 if dfn is not passed set DFN from ICN
I $G(DFN)="" D
. I $G(ARRY("ICN",2))'="" S DFN=$$GETDFN^MPIF001(ARRY("ICN",2))
. I $G(ARRY("ICN",2))=""!(+$G(DFN)'>0) D
.. I $G(ARRY("DFN",2))'="" S DFN=ARRY("DFN",2)
.. I $G(ARRY("DFN",2))="" S DFN=ARRY("DFN",1)
S ARRY(991.03)=$S(ARRY(991.03)="":"@",1:$$LKUP^XUAF4(ARRY(991.03))) ;**59 - MVI_2688 (dri)
I +$G(DFN)'>0 S ERR="-1^Unknown Identifier(s) ICN#"_$G(ARRY("ICN",2))_" and DFN#"_$G(ARRY("DFN",2))
I +$G(DFN)>0 S ERR=$$UPDATE^MPIFAPI(DFN,"ARRY",0) D
.;remove ALL Treating Facilities except your sites and add the CMOR
.D TFL^VAFCTFU1(.LIST,DFN) I $O(LIST(0)) D
.. N LOC,MPINODE,LOCIEN,CMOR,MPIFX,ERROR
.. S (CMOR,MPIFX)=0 F S MPIFX=$O(LIST(MPIFX)) Q:'MPIFX I $P(LIST(MPIFX),"^",5)="VAMC" D
... ;get MPI node
... S MPINODE=$$MPINODE^MPIFAPI(DFN),LOC=$P(LIST(MPIFX),"^"),LOCIEN=$$IEN^XUAF4(LOC)
... I LOC=$P($$SITE^VASITE,"^",3) Q ;do not delete own site
... I LOCIEN=$P(MPINODE,"^",3) S CMOR=LOCIEN Q ;do not delete CMOR site
... S ERROR=$$DELETETF^VAFCTFU($P(MPINODE,"^",1),LOCIEN)
.. ;add CMOR site to TF list if it did not already exist
.. I CMOR'=0 D FILE^VAFCTFU(DFN,CMOR,1)
.; trigger A31 to MPI incase there have been edits since the ICN was created -- tasked off
.; **39 DON'T TASK OFF A31 IF MOVING FROM ONE NATIONAL ICN TO A DIFFERENT NATIONAL ICN
.I ARRY("ICN",1)=ARRY("ICN",2) D
..S ZTRTN="TA31^MPIFA31B",ZTDESC="A31 triggered from A24 for DFN "_DFN ;**39 added DFN to text
..S ZTSAVE("DFN")=DFN,ZTIO="",ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,0,0,1,0)
..D ^%ZTLOAD
.I ARRY("ICN",1)'=ARRY("ICN",2) D RESEX^MPIFDUP(DFN,2) ;**48
.K ZTRTN,ZTDESC,ZTIO,ZTSAVE,ZTDTH,ZTREQ
;
N AA S AA="AA"
I $G(ERR)'>0,$P($G(ERR),"^",2)["is already in use for pt DFN" S AA="AE" ;**52 MPIC_1681/1753
S HLA("HLA",1)="MSA"_HL("FS")_AA_HL("FS")_HL("MID")_HL("FS")_$S(+$G(ERR)'>0:$P(ERR,"^",2),1:"")
S $P(HLA("HLA",1),HL("FS"),7)="ICN="_ARRY("ICN",1)
;**75 - Story - 1260465 (ckn) - Include 200M in HLL links for HAC
D LINK^HLUTIL3(ARRY("SITE"),.LINK) S IEN=$O(LINK(0)),HLL("LINKS",1)="^"_LINK(IEN)_$S($P($$SITE^VASITE(),"^",3)=741:"^200M",1:"")
D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.MPIFRSLT,"",.HL)
K LINK,MPIFRSLT
;PATCH 25
I ARRY("ICN",1)'=ARRY("ICN",2),ARRY("ICN",2)'="" D
.; ^ checking if this is a result of a "merge" of ICNs from the MPI
.; to trigger if this is station 200 the MERGE for the FHIE Framework
.Q:$P($$SITE^VASITE,"^",3)'=200
.N FHIE S FHIE=$$MERGE^OMGPIDMI(ARRY("ICN",2),ARRY("ICN",1))
.; ^^ THIS API IS ONLY AVAILABLE ON THE FHIE HOST SYSTEM
.I +FHIE=-1 D START^RGHLLOG(),EXC^RGHLLOG(208,$P(FHIE,"^",2),DFN),STOP^RGHLLOG()
Q
;
MSH(ARY,MSG) ;processing MSH fields
N COMP
S COMP=$E(HL("ECH"),1)
S ARY("SITE")=$$LKUP^XUAF4($P($P(MSG,HL("FS"),4),COMP))
Q
;
EVN(ARY,MSG) ;processing EVN fields
S ARY("EVTR")=$P(MSG,HL("FS"),2) ;not currently used
S ARY("DLT")=$$FMDATE^HLFNC($P(MSG,HL("FS"),3))
Q
;
PID(ARY,MSG,FIRST) ;processing PID fields
N REP,PID,COMP,SUBCOMP,MPIDFN,MPISSN,ICN
S REP=$E(HL("ECH"),2),COMP=$E(HL("ECH"),1),SUBCOMP=$E(HL("ECH"),4)
S MPISSN="",MPIDFN=""
;**41 replaced with line below D PIDPROC^MPIFA43(.ICN,.MPISSN,.MPIDFN,.PID)
D PIDP^RGADTP1(.MSG,.ARY,.HL)
I FIRST=1 S ARY(991.01)=+ARY("ICN"),ARY(991.02)=$P(ARY("ICN"),"V",2)
S ARY("ICN",FIRST)=ARY("ICN")
S ARY("SSN",FIRST)=ARY("SSN")
S ARY("DFN",FIRST)=ARY("DFN")
Q
;
PD1(ARY,MSG) ;processing PD1 fields
N COMP
S COMP=$E(HL("ECH"),1)
S ARY(991.03)=$P($P(HLNODE,HL("FS"),4),COMP,3)
Q
;
PROC ;
N NXT,DFN
F NXT=1:1 X HLNEXT Q:HLQUIT'>0 D
.I $E(HLNODE,1,3)="MSA" S DFN=$P($P(HLNODE,HL("FS"),7),"=",2)
.I $E(HLNODE,1,3)="MSA"&($P(HLNODE,HL("FS"),4)'="") D
..; ERROR RETURNED IN MSA - LOG EXCEPTION
..D START^RGHLLOG(HLMTIEN,"","")
..D EXC^RGHLLOG(208,$P(HLNODE,HL("FS"),4)_" for HL msg# "_HLMTIEN,DFN)
..D STOP^RGHLLOG(0)
K ^XTMP("MPIFA24%"_DFN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMPIFA24 5170 printed Nov 22, 2024@17:20:48 Page 2
MPIFA24 ;BPOFO/CMC-A24 PROCESSING ROUTINE ; 5/4/20 10:58am
+1 ;;1.0;MASTER PATIENT INDEX VISTA;**22,24,27,31,25,41,39,48,52,59,75**;30 Apr 99;Build 1
+2 ;
+3 ; Integration Agreements Utilized:
+4 ; START, EXC, STOP^RGHLLOG - #2796
+5 ; BLDEVN, BLDPD1, BLDPID^VAFCQRY - #3630
+6 ; ^DPT("AICN" - #2070
+7 ; DELETETF^VAFCTFU, FILE^VAFCTFU - #2988
+8 ;
+9 ;PROCESS A24 RESULTING FROM A28 ADD TO MPI MESSAGE OR FROM A40 MERGE
A24 ;
+1 NEW MPII,MPIJ,ARRY,SEG,CNT,ERR,SITE,MSG,DFN,IEN,LIST,RARRY
+2 SET (CNT,ERR,FIRST)=1
+3 FOR MPII=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
SET MSG=HLNODE
Begin DoDot:1
+4 SET MPIJ=0
FOR
SET MPIJ=$ORDER(HLNODE(MPIJ))
if 'MPIJ
QUIT
SET MSG(MPIJ)=HLNODE(MPIJ)
+5 SET SEG=$EXTRACT(HLNODE,1,3)
+6 IF SEG="MSH"
DO MSH(.ARRY,.MSG)
QUIT
+7 IF SEG="EVN"
DO EVN(.ARRY,.MSG)
QUIT
+8 IF SEG="PID"
DO PID(.ARRY,.MSG,FIRST)
if FIRST=1
Begin DoDot:2
+9 ;preserve the retained ICN values 991.01 and 991.02
+10 SET RARRY(991.01)=ARRY(991.01)
SET RARRY(991.02)=ARRY(991.02)
End DoDot:2
SET FIRST=2
QUIT
+11 IF SEG="PD1"
DO PD1(.ARRY,.MSG)
QUIT
End DoDot:1
+12 ;
+13 ;restore the retained ICN values
+14 SET ARRY(991.01)=RARRY(991.01)
SET ARRY(991.02)=RARRY(991.02)
+15 ;UPDATE 991.01, 991.02, 991.03
+16 ;**41 first check for DFN, if this DFN location is here
+17 IF $GET(ARRY("DFN",2))'=""&($GET(ARRY("DFNLOC"))=$PIECE($$SITE^VASITE,"^",3))
SET DFN=ARRY("DFN",2)
+18 ;**41 if dfn is not passed set DFN from ICN
+19 IF $GET(DFN)=""
Begin DoDot:1
+20 IF $GET(ARRY("ICN",2))'=""
SET DFN=$$GETDFN^MPIF001(ARRY("ICN",2))
+21 IF $GET(ARRY("ICN",2))=""!(+$GET(DFN)'>0)
Begin DoDot:2
+22 IF $GET(ARRY("DFN",2))'=""
SET DFN=ARRY("DFN",2)
+23 IF $GET(ARRY("DFN",2))=""
SET DFN=ARRY("DFN",1)
End DoDot:2
End DoDot:1
+24 ;**59 - MVI_2688 (dri)
SET ARRY(991.03)=$SELECT(ARRY(991.03)="":"@",1:$$LKUP^XUAF4(ARRY(991.03)))
+25 IF +$GET(DFN)'>0
SET ERR="-1^Unknown Identifier(s) ICN#"_$GET(ARRY("ICN",2))_" and DFN#"_$GET(ARRY("DFN",2))
+26 IF +$GET(DFN)>0
SET ERR=$$UPDATE^MPIFAPI(DFN,"ARRY",0)
Begin DoDot:1
+27 ;remove ALL Treating Facilities except your sites and add the CMOR
+28 DO TFL^VAFCTFU1(.LIST,DFN)
IF $ORDER(LIST(0))
Begin DoDot:2
+29 NEW LOC,MPINODE,LOCIEN,CMOR,MPIFX,ERROR
+30 SET (CMOR,MPIFX)=0
FOR
SET MPIFX=$ORDER(LIST(MPIFX))
if 'MPIFX
QUIT
IF $PIECE(LIST(MPIFX),"^",5)="VAMC"
Begin DoDot:3
+31 ;get MPI node
+32 SET MPINODE=$$MPINODE^MPIFAPI(DFN)
SET LOC=$PIECE(LIST(MPIFX),"^")
SET LOCIEN=$$IEN^XUAF4(LOC)
+33 ;do not delete own site
IF LOC=$PIECE($$SITE^VASITE,"^",3)
QUIT
+34 ;do not delete CMOR site
IF LOCIEN=$PIECE(MPINODE,"^",3)
SET CMOR=LOCIEN
QUIT
+35 SET ERROR=$$DELETETF^VAFCTFU($PIECE(MPINODE,"^",1),LOCIEN)
End DoDot:3
+36 ;add CMOR site to TF list if it did not already exist
+37 IF CMOR'=0
DO FILE^VAFCTFU(DFN,CMOR,1)
End DoDot:2
+38 ; trigger A31 to MPI incase there have been edits since the ICN was created -- tasked off
+39 ; **39 DON'T TASK OFF A31 IF MOVING FROM ONE NATIONAL ICN TO A DIFFERENT NATIONAL ICN
+40 IF ARRY("ICN",1)=ARRY("ICN",2)
Begin DoDot:2
+41 ;**39 added DFN to text
SET ZTRTN="TA31^MPIFA31B"
SET ZTDESC="A31 triggered from A24 for DFN "_DFN
+42 SET ZTSAVE("DFN")=DFN
SET ZTIO=""
SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,0,0,1,0)
+43 DO ^%ZTLOAD
End DoDot:2
+44 ;**48
IF ARRY("ICN",1)'=ARRY("ICN",2)
DO RESEX^MPIFDUP(DFN,2)
+45 KILL ZTRTN,ZTDESC,ZTIO,ZTSAVE,ZTDTH,ZTREQ
End DoDot:1
+46 ;
+47 NEW AA
SET AA="AA"
+48 ;**52 MPIC_1681/1753
IF $GET(ERR)'>0
IF $PIECE($GET(ERR),"^",2)["is already in use for pt DFN"
SET AA="AE"
+49 SET HLA("HLA",1)="MSA"_HL("FS")_AA_HL("FS")_HL("MID")_HL("FS")_$SELECT(+$GET(ERR)'>0:$PIECE(ERR,"^",2),1:"")
+50 SET $PIECE(HLA("HLA",1),HL("FS"),7)="ICN="_ARRY("ICN",1)
+51 ;**75 - Story - 1260465 (ckn) - Include 200M in HLL links for HAC
+52 DO LINK^HLUTIL3(ARRY("SITE"),.LINK)
SET IEN=$ORDER(LINK(0))
SET HLL("LINKS",1)="^"_LINK(IEN)_$SELECT($PIECE($$SITE^VASITE(),"^",3)=741:"^200M",1:"")
+53 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.MPIFRSLT,"",.HL)
+54 KILL LINK,MPIFRSLT
+55 ;PATCH 25
+56 IF ARRY("ICN",1)'=ARRY("ICN",2)
IF ARRY("ICN",2)'=""
Begin DoDot:1
+57 ; ^ checking if this is a result of a "merge" of ICNs from the MPI
+58 ; to trigger if this is station 200 the MERGE for the FHIE Framework
+59 if $PIECE($$SITE^VASITE,"^",3)'=200
QUIT
+60 NEW FHIE
SET FHIE=$$MERGE^OMGPIDMI(ARRY("ICN",2),ARRY("ICN",1))
+61 ; ^^ THIS API IS ONLY AVAILABLE ON THE FHIE HOST SYSTEM
+62 IF +FHIE=-1
DO START^RGHLLOG()
DO EXC^RGHLLOG(208,$PIECE(FHIE,"^",2),DFN)
DO STOP^RGHLLOG()
End DoDot:1
+63 QUIT
+64 ;
MSH(ARY,MSG) ;processing MSH fields
+1 NEW COMP
+2 SET COMP=$EXTRACT(HL("ECH"),1)
+3 SET ARY("SITE")=$$LKUP^XUAF4($PIECE($PIECE(MSG,HL("FS"),4),COMP))
+4 QUIT
+5 ;
EVN(ARY,MSG) ;processing EVN fields
+1 ;not currently used
SET ARY("EVTR")=$PIECE(MSG,HL("FS"),2)
+2 SET ARY("DLT")=$$FMDATE^HLFNC($PIECE(MSG,HL("FS"),3))
+3 QUIT
+4 ;
PID(ARY,MSG,FIRST) ;processing PID fields
+1 NEW REP,PID,COMP,SUBCOMP,MPIDFN,MPISSN,ICN
+2 SET REP=$EXTRACT(HL("ECH"),2)
SET COMP=$EXTRACT(HL("ECH"),1)
SET SUBCOMP=$EXTRACT(HL("ECH"),4)
+3 SET MPISSN=""
SET MPIDFN=""
+4 ;**41 replaced with line below D PIDPROC^MPIFA43(.ICN,.MPISSN,.MPIDFN,.PID)
+5 DO PIDP^RGADTP1(.MSG,.ARY,.HL)
+6 IF FIRST=1
SET ARY(991.01)=+ARY("ICN")
SET ARY(991.02)=$PIECE(ARY("ICN"),"V",2)
+7 SET ARY("ICN",FIRST)=ARY("ICN")
+8 SET ARY("SSN",FIRST)=ARY("SSN")
+9 SET ARY("DFN",FIRST)=ARY("DFN")
+10 QUIT
+11 ;
PD1(ARY,MSG) ;processing PD1 fields
+1 NEW COMP
+2 SET COMP=$EXTRACT(HL("ECH"),1)
+3 SET ARY(991.03)=$PIECE($PIECE(HLNODE,HL("FS"),4),COMP,3)
+4 QUIT
+5 ;
PROC ;
+1 NEW NXT,DFN
+2 FOR NXT=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+3 IF $EXTRACT(HLNODE,1,3)="MSA"
SET DFN=$PIECE($PIECE(HLNODE,HL("FS"),7),"=",2)
+4 IF $EXTRACT(HLNODE,1,3)="MSA"&($PIECE(HLNODE,HL("FS"),4)'="")
Begin DoDot:2
+5 ; ERROR RETURNED IN MSA - LOG EXCEPTION
+6 DO START^RGHLLOG(HLMTIEN,"","")
+7 DO EXC^RGHLLOG(208,$PIECE(HLNODE,HL("FS"),4)_" for HL msg# "_HLMTIEN,DFN)
+8 DO STOP^RGHLLOG(0)
End DoDot:2
End DoDot:1
+9 KILL ^XTMP("MPIFA24%"_DFN)
+10 QUIT
