VAFCTFIN ;BIR/DR-TREATING FACILTIY MFU PROCESSING ROUTINE ;4/29/21 12:57
;;5.3;Registration;**428,474,520,639,707,800,821,837,863,1013,1042,1050**;Aug 13, 1993;Build 2
;Reference to EXC, START, and STOP^RGHLLOG supported by IA #2796
;Reference to GETDFN^MPIF001 supported by IA #2701
;Reference to MPILINK^MPIFAPI supported by IA #2702
;
IN ;This entry point is used to process the Treating Facility Master File Update Message.
;It is called by the VAFC MFN-M05 CLIENT processing routine when a MFN
;message is received.
;There are no inputs or outputs
;
;Initial check whether incoming MFN message is old format or new. If it is old format, go to old routine (VAFCOFIN) to process. **821
I HL("MTN")="MFK" D RSP Q
N VAFC,SG,MSG
F VAFCI=1:1 X HLNEXT Q:HLQUIT'>0 I $E(HLNODE,1,3)="MFE" S MSG=HLNODE
I $P($G(MSG),"^",3)'["-" D IN^VAFCOFIN Q
K VAFCI,HLNODE,SG,HLQUIT,HLDONE,MSG
S HLQUIT=0
;
N VAFC,STATN,VAFCI,MSG,SG,VAFCARR,PDFN,INST,MFUPT,PDLT,TFIEN
N ICN,MFI,MFE,MFA,HLCOMP,CNT,X,VAFCERR,VAFCX,VAFCJ
;quit if Master Patient Index (MPI) is not installed
S X="MPIF001" X ^%ZOSF("TEST") Q:'$T
S X="MPIFQ0" X ^%ZOSF("TEST") Q:'$T
S X="RGRSBUL1" X ^%ZOSF("TEST") Q:'$T
S X="RGRSBULL" X ^%ZOSF("TEST") Q:'$T
INIT ;Process in the Treating Facility MFN msg
;**837 - MVI_791 (ckn)
;F VAFCI=1:1 X HLNEXT Q:HLQUIT'>0 S (MSG,VAFC(VAFCI))=HLNODE,SG=$E(HLNODE,1,3) D:SG?2A1(1A,1N) PICK
F VAFCI=1:1 X HLNEXT Q:HLQUIT'>0 D
.K MSG S MSG=HLNODE
.S VAFCJ=0 F S VAFCJ=$O(HLNODE(VAFCJ)) Q:'VAFCJ S MSG(VAFCJ)=HLNODE(VAFCJ)
.S SG=$E(HLNODE,1,3)
.I SG="MFE" D MFE(.MSG) Q
.D PICK
;
;**1042, VAMPI-8215 (dri)
;**1050, VAMPI-9501 (dri)
;If the icn in the tf update is NOT known to the Patient (#2) file then
;we know we're dealing with a tf update for someone who is ONLY known to
;New Person (#200) file so we file their inbound tf list in the New Person
;Treating Facility List (#391.92) file instead of the Treating Facility
;List (#391.91) file.
;If this New Person later also becomes a Patient then the tf list is
;deleted from #391.92 and the incoming tf list is filed into #391.91.
I $$GETDFN^MPIF001(ICN)<0 D EN^VAFCTFNP(.MFI,.MFA) ;file tf list into #391.92
I $$GETDFN^MPIF001(ICN)>0,$O(^DGCN(391.92,"AISS",ICN,"NI","USVHA",$$IEN^XUAF4("200M"),0)) D CLEANUP^VAFCTFNP(ICN) ;delete tf list from #391.92
I '$D(MFA) D RECONCIL ;file tf list into #391.91
;
;create response message
S CNT=1
S HLA("HLA",1)="MSA"_HL("FS")_"AA"_HL("FS")_HL("MID")_HL("FS") S CNT=CNT+1
S HLA("HLA",CNT)=MFI S CNT=CNT+1
;S VAFCX=0 F S VAFCX=$O(MFE(VAFCX)) Q:'VAFCX S HLA("HLA",CNT)=MFE(VAFCX),CNT=CNT+1,HLA("HLA",CNT)=MFA(VAFCX),CNT=CNT+1
;S VAFCX=0 F S VAFCX=$O(MFE(VAFCX)) Q:'VAFCX D
;. S VAFCN=0 F S VAFCN=$O(MFE(VAFCX,VAFCN)) Q:'VAFCN D
;.. S HLA("HLA",CNT)=MFE(VAFCX,VAFCN),CNT=CNT+1,HLA("HLA",CNT)=MFA(VAFCX,VAFCN),CNT=CNT+1
;**837 - MVI_791 (ckn)
S VAFCX=0 F S VAFCX=$O(MFE(VAFCX)) Q:'VAFCX D
. S VAFCN=0 F S VAFCN=$O(MFE(VAFCX,VAFCN)) Q:'VAFCN D
.. S ZCNT=0 F S ZCNT=$O(MFE(VAFCX,VAFCN,ZCNT)) Q:'ZCNT D
... I ZCNT=1 S HLA("HLA",CNT)=MFE(VAFCX,VAFCN,ZCNT)
... I ZCNT>1 S HLA("HLA",CNT,ZCNT-1)=MFE(VAFCX,VAFCN,ZCNT)
...; S HLA("HLA",CNT)=MFE(VAFCX,VAFCN,ZCNT),CNT=CNT+1
.. S CNT=CNT+1
.. S HLA("HLA",CNT)=MFA(VAFCX,VAFCN),CNT=CNT+1
;generate an application level ack (MFK) identifying the status of the adds/edits/deletes of TF's passed in
D ROUTE
D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.VAFCERR,"",.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 VAFCARR("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
S PDFN=+$P(MSG,HL("FS"),4)
Q
MFI ;;MFI
;process the MFI segment
S MFI=MSG
S MFUPT=$P(MSG,HL("FS"),4)
S VAFCARR("CMOR")=$P($P(MSG,HL("FS"),8),$E(HL("ECH"),1))
Q
MFE(MSG) ;;MFE
;process the MFE segment
N HLCOMP,NXTSGMT,TYPE,REP,MFE4,DFNATST,IDENSTAT
;**837 - MVI_791 (ckn)
N LNGTH,SUBCOMP,TMFE,SEQ,SEQ1,X,NXT,Y,LNGTH2,LNGTH1
N LASTID,IDCNT,X,IDS,ACNT,AA,IDTYP,AATYP,MCNT,MFE5
S HLCOMP=$E(HL("ECH"),1),REP=$E(HL("ECH"),2),SUBCOMP=$E(HL("ECH"),4)
S LNGTH=$L(MSG,HL("FS")) F SEQ=1:1:LNGTH S TMFE(SEQ)=$P(MSG,HL("FS"),SEQ)
S SEQ1=1,X=0 F S X=$O(MSG(X)) Q:'X S LNGTH=$L(MSG(X),HL("FS")) D
. F Y=1:1:LNGTH S:Y'=1 SEQ=SEQ+1 D
.. S NXT=$P(MSG(X),HL("FS"),Y) D
... I $L($G(TMFE(SEQ)))=245 D Q
.... I $L(NXT_$G(TMFE(SEQ,SEQ1)))>245 S LNGTH1=$L(TMFE(SEQ,SEQ1)) S LNGTH2=245-LNGTH1,TMFE(SEQ,SEQ1)=$G(TMFE(SEQ,SEQ1))_$E(NXT,1,LNGTH2),LNGTH2=LNGTH2+1,NXT=$E(NXT,LNGTH2,$L(NXT)),SEQ1=SEQ1+1
.... I $L(NXT_$G(TMFE(SEQ,SEQ1)))'>245 S TMFE(SEQ,SEQ1)=$G(TMFE(SEQ,SEQ1))_NXT
... I $L(NXT_$G(TMFE(SEQ)))>245 S LNGTH1=$L($G(TMFE(SEQ))) S LNGTH2=245-LNGTH1,TMFE(SEQ)=$G(TMFE(SEQ))_$E(NXT,1,LNGTH2),LNGTH2=LNGTH2+1,NXT=$E(NXT,LNGTH2,$L(NXT)) S TMFE(SEQ,SEQ1)=NXT
... I $L(NXT_$G(TMFE(SEQ)))'>245 S TMFE(SEQ)=$G(TMFE(SEQ))_NXT Q
S MFE5=$G(TMFE(5))
S LASTID=$L(MFE5,REP),IDCNT=1,ACNT=0
F X=1:1:LASTID S ACNT=ACNT+1,IDS(ACNT)=$P(MFE5,REP,X) D
.;if this is the last entry check for an extension of the message and reset the key variables
.I X=LASTID I $D(TMFE(5,IDCNT)) D
..S IDS(ACNT)=IDS(ACNT)_$P(TMFE(5,IDCNT),REP)
..S MFE5=$P(TMFE(5,IDCNT),REP,2,99) I MFE5="" Q
..S IDCNT=IDCNT+1,X=0,LASTID=$L(MFE5,REP)
S PDLT=$$FMDATE^HLFNC($G(TMFE(4)))
S INST=$P($G(TMFE(3)),"-")
S ZCNT=$P($G(TMFE(3)),"-",2)
S TYPE=$G(TMFE(2))
S IDENSTAT=$S(TYPE="MDC":"H",1:"A")
S ICN=$P($G(IDS(1)),HLCOMP)
S AATYP=$P($P($G(IDS(2)),HLCOMP,4),SUBCOMP,3)
S AA=$S(AATYP="ISO":$P($P($G(IDS(2)),HLCOMP,4),SUBCOMP,2),1:$P($P($G(IDS(2)),HLCOMP,4),SUBCOMP))
S IDTYP=$P($G(IDS(2)),HLCOMP,5)
;We do not have facility to map ID type from OID in VistA so default "NI" value to Id type if site is 200N*
I $E(INST,1,4)="200N",AATYP="ISO" S IDTYP="NI"
S DFNATST=$P($G(IDS(2)),HLCOMP)
S MFE(INST,ZCNT,1)=MSG
I $D(MSG(1)) D
.S MCNT=0 F S MCNT=$O(MSG(MCNT)) Q:+MCNT=0 S MFE(INST,ZCNT,MCNT+1)=MSG(MCNT)
S MFI(ICN,INST,ZCNT)=PDLT_"^^"_TYPE_"^^^^"_DFNATST_"^"_IDENSTAT_"^"_AA_"^"_IDTYP
Q
ZET ;;ZET
;process Patient's Date Last Treated Event Type, ZET segment
N PDLTET,IPP
S PDLTET=$P(MSG,HL("FS"),2)
S $P(MFI(ICN,INST,ZCNT),"^",2)=PDLTET
;DG*5.3*800 - Process In-Person Proofed
S IPP=$P(MSG,HL("FS"),3) ;In-Person Proofed
S $P(MFI(ICN,INST,ZCNT),"^",6)=IPP
Q
RSP ;response process logic entry point
Q
ROUTE ;routing logic entry point
N MPI
S MPI=$$MPILINK^MPIFAPI() D
.;**1013 - Story - 1260465 (ckn) - Include 200M in HLL links for HAC
.I $P($G(MPI),U)'=-1 S HLL("LINKS",1)="VAFC MFN-M05 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 in CIRN SITE PARAMETER file (#991.8)",$G(PDFN))
.. D STOP^RGHLLOG(0)
Q
TEST ;
W $$REPROC^HLUTIL(39266,"D IN^VAFCTFIN")
Q
RECONCIL ;
N DFN,MFIC,VAFCX,VAFCY,TFL,CNFLT,LOCCMOR,VAFCTYPE,VAFCN,IDSTAT,SID
S CNFLT=0
S DFN=$$GETDFN^MPIF001(ICN)
I DFN'>0 S CNFLT=1_"^"_$P($G(DFN),"^",2)
;CHANGED TFL^VAFCTFU1 to TFL^VAFCTFU3 to get ALL tf entries
I MFUPT="REP" I +CNFLT=0 D TFL^VAFCTFU3(.TFL,DFN) S VAFCX=0 F S VAFCX=$O(TFL(VAFCX)) Q:'VAFCX D
.; S MFIC($P(TFL(VAFCX),"^"))=TFL(VAFCX) I '$D(MFI(ICN,$P(TFL(VAFCX),"^"))) D DEL(ICN,$P(TFL(VAFCX),"^"))
. N EXTFIEN,STIEN,STEXT
. S MFIC($P(TFL(VAFCX),"^"))=TFL(VAFCX),STIEN=$$LKUP^XUAF4($P(TFL(VAFCX),"^")),STEXT=$P(TFL(VAFCX),"^")
. S EXTFIEN=0 F S EXTFIEN=$O(^DGCN(391.91,"APAT",DFN,STIEN,EXTFIEN)) Q:+EXTFIEN=0 D
. . N NODE0,NODE2,EXIDTYP,EXAA,EXSID,EXIDST,ZCNT,MATCH
. .; Existing AA, ID type, Source ID, Identifier Status
. . S NODE0=$G(^DGCN(391.91,EXTFIEN,0)),NODE2=$G(^DGCN(391.91,EXTFIEN,2))
. . S EXIDTYP=$P(NODE0,"^",9),EXAA=$P(NODE2,"^"),EXSID=$P(NODE2,"^",2),EXIDST=$P(NODE2,"^",3)
. . ;Loop through MFI (incoming data) and compare the values
. . S ZCNT=0,MATCH=0 F S ZCNT=$O(MFI(ICN,STEXT,ZCNT)) Q:+ZCNT=0!(MATCH) D
. . . N TMPNODE,INIDST,INAA,INIDTYP,INSID
. . . S TMPNODE=$G(MFI(ICN,STEXT,ZCNT))
. . . S INSID=$P(TMPNODE,"^",7),INIDST=$P(TMPNODE,"^",8),INAA=$P(TMPNODE,"^",9),INIDTYP=$P(TMPNODE,"^",10)
. . . I INSID=EXSID,INIDST=EXIDST,INAA=EXAA,INIDTYP=EXIDTYP S MATCH=1 Q
. . . I 'MATCH,$E(STEXT,1,4)="200N" D ;For 200N* only check Source ID and Idtype if no match for all matching criteria
. . . . I INSID=EXSID,INIDTYP=EXIDTYP S MATCH=1
. . I 'MATCH S DELTFARR(EXTFIEN)=""
. I $D(DELTFARR) S DTIEN=0 F S DTIEN=$O(DELTFARR(DTIEN)) Q:+DTIEN=0 D DEL(ICN,STEXT,DTIEN)
. K DELTFARR
;VAFCX=ICN and VAFCY=INSTITUTION
S VAFCX=0 F S VAFCX=$O(MFI(VAFCX)) Q:'VAFCX D
. S VAFCY=0 F S VAFCY=$O(MFI(VAFCX,VAFCY)) Q:'VAFCY D
.. S VAFCN=0 F S VAFCN=$O(MFI(VAFCX,VAFCY,VAFCN)) Q:'VAFCN D
... S VAFCTYPE=$P(MFI(VAFCX,VAFCY,VAFCN),"^",3)
... S SID=$P(MFI(VAFCX,VAFCY,VAFCN),"^",7)
... S IDSTAT=$P(MFI(VAFCX,VAFCY,VAFCN),"^",8)
...;**837 - MVI_791 (ckn)
... S AA=$P(MFI(VAFCX,VAFCY,VAFCN),"^",9),IDTYP=$P(MFI(VAFCX,VAFCY,VAFCN),"^",10)
... I +CNFLT=1 D
....S MFA(VAFCY,VAFCN)="MFA"_HL("FS")_VAFCTYPE_HL("FS")_VAFCY_"-"_VAFCN_HL("FS")_$$HLDATE^HLFNC($$NOW^XLFDT)_HL("FS")_"U"_HLCOMP_$S(VAFCTYPE="MDL":"Delete of ",1:"Update of ")
....S MFA(VAFCY,VAFCN)=$G(MFA(VAFCY,VAFCN))_VAFCY_" Failed at "_$P($$SITE^VASITE,"^",3)_" due to "_$P(CNFLT,"^",2)
... I +CNFLT=0 I VAFCTYPE="MAD"!(VAFCTYPE="MUP")!(VAFCTYPE="MDC") D ADDUPD(DFN,VAFCY,$P(MFI(VAFCX,VAFCY,VAFCN),"^"),$P(MFI(VAFCX,VAFCY,VAFCN),"^",2),$P(MFI(VAFCX,VAFCY,VAFCN),"^",6),$G(SID),$G(IDSTAT),VAFCN,VAFCTYPE,AA,IDTYP)
...; I +CNFLT=0 I VAFCTYPE="MDL" D DEL(ICN,VAFCY,VAFCN)
... I +CNFLT=0 I VAFCTYPE="MDL" D
.... N EXTFIEN,STIEN
.... S STIEN=$$LKUP^XUAF4(VAFCY)
.... S EXTFIEN=0 F S EXTFIEN=$O(^DGCN(391.91,"APAT",DFN,STIEN,EXTFIEN)) Q:+EXTFIEN=0 D
..... N NODE0,NODE2,EXIDTYP,EXAA,EXSID,EXIDST
.....; Existing AA, ID type, Source ID, Identifier Status
..... S NODE0=$G(^DGCN(391.91,EXTFIEN,0)),NODE2=$G(^DGCN(391.91,EXTFIEN,2))
..... S EXIDTYP=$P(NODE0,"^",9),EXAA=$P(NODE2,"^"),EXSID=$P(NODE2,"^",2),EXIDST=$P(NODE2,"^",3)
..... I EXIDTYP=IDTYP,EXAA=AA,EXSID=SID,EXIDST=IDSTAT D DEL(ICN,VAFCY,EXTFIEN) Q
..... I $E(VAFCY,1,4)="200N" D ;Check only Source iD and IdType for 200N*
...... I EXIDTYP=IDTYP,EXSID=SID D DEL(ICN,VAFCY,EXTFIEN)
Q
ADDUPD(DFN,INST,PDLT,PDLRTET,IPP,DFNATST,IDENSTAT,ZCNT,VAFCTYPE,AA,IDTYP) ;add or update TF entry
N ERROR,STA
S STA=INST
S INST=$$LKUP^XUAF4(INST)
I INST=0 S ERROR(STA)="Update of "_STA_" Failed at "_$P($$SITE^VASITE,"^",3)_" due to unknown Institution IEN "_INST_" passed into TF update."
I '$D(ERROR(STA)) D FILE^VAFCTFU(DFN,INST_"^"_$G(PDLT)_"^"_$G(PDLRTET),1,1,.ERROR,$G(IPP),DFNATST,IDENSTAT,AA,IDTYP)
S MFA(STA,ZCNT)="MFA"_HL("FS")_VAFCTYPE_HL("FS")_STA_"-"_ZCNT_HL("FS")_$$HLDATE^HLFNC($$NOW^XLFDT)_HL("FS")
I '$D(ERROR(STA)) S MFA(STA,ZCNT)=MFA(STA,ZCNT)_"S"
I $D(ERROR(STA)) S MFA(STA,ZCNT)=MFA(STA,ZCNT)_"U"_HLCOMP_ERROR(STA)_HL("FS")
Q
DEL(ICN,INST,DTIEN) ;delete a TF entry
N ERROR,STA
S STA=INST
S INST=$$LKUP^XUAF4(INST)
S ERROR=$$DELETETF^VAFCTFU(ICN,INST,DTIEN)
;**821 - No need to send MFA for entries that are deleted locally
;S MFA(STA,ZCNT)="MFA"_HL("FS")_"MDL"_HL("FS")_STA_"-"_ZCNT_HL("FS")_$$HLDATE^HLFNC($$NOW^XLFDT)_HL("FS")
;I +ERROR'=1 S MFA(STA,ZCNT)=MFA(STA,ZCNT)_"S"
;I +ERROR=1 S MFA(STA,ZCNT)=MFA(STA,ZCNT)_"U"_HLCOMP_"Delete Failed: "_$P(ERROR,"^",2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFCTFIN 11752 printed Oct 16, 2024@19:02:57 Page 2
VAFCTFIN ;BIR/DR-TREATING FACILTIY MFU PROCESSING ROUTINE ;4/29/21 12:57
+1 ;;5.3;Registration;**428,474,520,639,707,800,821,837,863,1013,1042,1050**;Aug 13, 1993;Build 2
+2 ;Reference to EXC, START, and STOP^RGHLLOG supported by IA #2796
+3 ;Reference to GETDFN^MPIF001 supported by IA #2701
+4 ;Reference to MPILINK^MPIFAPI supported by IA #2702
+5 ;
IN ;This entry point is used to process the Treating Facility Master File Update Message.
+1 ;It is called by the VAFC MFN-M05 CLIENT processing routine when a MFN
+2 ;message is received.
+3 ;There are no inputs or outputs
+4 ;
+5 ;Initial check whether incoming MFN message is old format or new. If it is old format, go to old routine (VAFCOFIN) to process. **821
+6 IF HL("MTN")="MFK"
DO RSP
QUIT
+7 NEW VAFC,SG,MSG
+8 FOR VAFCI=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
IF $EXTRACT(HLNODE,1,3)="MFE"
SET MSG=HLNODE
+9 IF $PIECE($GET(MSG),"^",3)'["-"
DO IN^VAFCOFIN
QUIT
+10 KILL VAFCI,HLNODE,SG,HLQUIT,HLDONE,MSG
+11 SET HLQUIT=0
+12 ;
+13 NEW VAFC,STATN,VAFCI,MSG,SG,VAFCARR,PDFN,INST,MFUPT,PDLT,TFIEN
+14 NEW ICN,MFI,MFE,MFA,HLCOMP,CNT,X,VAFCERR,VAFCX,VAFCJ
+15 ;quit if Master Patient Index (MPI) is not installed
+16 SET X="MPIF001"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+17 SET X="MPIFQ0"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+18 SET X="RGRSBUL1"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+19 SET X="RGRSBULL"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
INIT ;Process in the Treating Facility MFN msg
+1 ;**837 - MVI_791 (ckn)
+2 ;F VAFCI=1:1 X HLNEXT Q:HLQUIT'>0 S (MSG,VAFC(VAFCI))=HLNODE,SG=$E(HLNODE,1,3) D:SG?2A1(1A,1N) PICK
+3 FOR VAFCI=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+4 KILL MSG
SET MSG=HLNODE
+5 SET VAFCJ=0
FOR
SET VAFCJ=$ORDER(HLNODE(VAFCJ))
if 'VAFCJ
QUIT
SET MSG(VAFCJ)=HLNODE(VAFCJ)
+6 SET SG=$EXTRACT(HLNODE,1,3)
+7 IF SG="MFE"
DO MFE(.MSG)
QUIT
+8 DO PICK
End DoDot:1
+9 ;
+10 ;**1042, VAMPI-8215 (dri)
+11 ;**1050, VAMPI-9501 (dri)
+12 ;If the icn in the tf update is NOT known to the Patient (#2) file then
+13 ;we know we're dealing with a tf update for someone who is ONLY known to
+14 ;New Person (#200) file so we file their inbound tf list in the New Person
+15 ;Treating Facility List (#391.92) file instead of the Treating Facility
+16 ;List (#391.91) file.
+17 ;If this New Person later also becomes a Patient then the tf list is
+18 ;deleted from #391.92 and the incoming tf list is filed into #391.91.
+19 ;file tf list into #391.92
IF $$GETDFN^MPIF001(ICN)<0
DO EN^VAFCTFNP(.MFI,.MFA)
+20 ;delete tf list from #391.92
IF $$GETDFN^MPIF001(ICN)>0
IF $ORDER(^DGCN(391.92,"AISS",ICN,"NI","USVHA",$$IEN^XUAF4("200M"),0))
DO CLEANUP^VAFCTFNP(ICN)
+21 ;file tf list into #391.91
IF '$DATA(MFA)
DO RECONCIL
+22 ;
+23 ;create response message
+24 SET CNT=1
+25 SET HLA("HLA",1)="MSA"_HL("FS")_"AA"_HL("FS")_HL("MID")_HL("FS")
SET CNT=CNT+1
+26 SET HLA("HLA",CNT)=MFI
SET CNT=CNT+1
+27 ;S VAFCX=0 F S VAFCX=$O(MFE(VAFCX)) Q:'VAFCX S HLA("HLA",CNT)=MFE(VAFCX),CNT=CNT+1,HLA("HLA",CNT)=MFA(VAFCX),CNT=CNT+1
+28 ;S VAFCX=0 F S VAFCX=$O(MFE(VAFCX)) Q:'VAFCX D
+29 ;. S VAFCN=0 F S VAFCN=$O(MFE(VAFCX,VAFCN)) Q:'VAFCN D
+30 ;.. S HLA("HLA",CNT)=MFE(VAFCX,VAFCN),CNT=CNT+1,HLA("HLA",CNT)=MFA(VAFCX,VAFCN),CNT=CNT+1
+31 ;**837 - MVI_791 (ckn)
+32 SET VAFCX=0
FOR
SET VAFCX=$ORDER(MFE(VAFCX))
if 'VAFCX
QUIT
Begin DoDot:1
+33 SET VAFCN=0
FOR
SET VAFCN=$ORDER(MFE(VAFCX,VAFCN))
if 'VAFCN
QUIT
Begin DoDot:2
+34 SET ZCNT=0
FOR
SET ZCNT=$ORDER(MFE(VAFCX,VAFCN,ZCNT))
if 'ZCNT
QUIT
Begin DoDot:3
+35 IF ZCNT=1
SET HLA("HLA",CNT)=MFE(VAFCX,VAFCN,ZCNT)
+36 IF ZCNT>1
SET HLA("HLA",CNT,ZCNT-1)=MFE(VAFCX,VAFCN,ZCNT)
+37 ; S HLA("HLA",CNT)=MFE(VAFCX,VAFCN,ZCNT),CNT=CNT+1
End DoDot:3
+38 SET CNT=CNT+1
+39 SET HLA("HLA",CNT)=MFA(VAFCX,VAFCN)
SET CNT=CNT+1
End DoDot:2
End DoDot:1
+40 ;generate an application level ack (MFK) identifying the status of the adds/edits/deletes of TF's passed in
+41 DO ROUTE
+42 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.VAFCERR,"",.HLP)
+43 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 VAFCARR("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 SET PDFN=+$PIECE(MSG,HL("FS"),4)
+3 QUIT
MFI ;;MFI
+1 ;process the MFI segment
+2 SET MFI=MSG
+3 SET MFUPT=$PIECE(MSG,HL("FS"),4)
+4 SET VAFCARR("CMOR")=$PIECE($PIECE(MSG,HL("FS"),8),$EXTRACT(HL("ECH"),1))
+5 QUIT
MFE(MSG) ;;MFE
+1 ;process the MFE segment
+2 NEW HLCOMP,NXTSGMT,TYPE,REP,MFE4,DFNATST,IDENSTAT
+3 ;**837 - MVI_791 (ckn)
+4 NEW LNGTH,SUBCOMP,TMFE,SEQ,SEQ1,X,NXT,Y,LNGTH2,LNGTH1
+5 NEW LASTID,IDCNT,X,IDS,ACNT,AA,IDTYP,AATYP,MCNT,MFE5
+6 SET HLCOMP=$EXTRACT(HL("ECH"),1)
SET REP=$EXTRACT(HL("ECH"),2)
SET SUBCOMP=$EXTRACT(HL("ECH"),4)
+7 SET LNGTH=$LENGTH(MSG,HL("FS"))
FOR SEQ=1:1:LNGTH
SET TMFE(SEQ)=$PIECE(MSG,HL("FS"),SEQ)
+8 SET SEQ1=1
SET X=0
FOR
SET X=$ORDER(MSG(X))
if 'X
QUIT
SET LNGTH=$LENGTH(MSG(X),HL("FS"))
Begin DoDot:1
+9 FOR Y=1:1:LNGTH
if Y'=1
SET SEQ=SEQ+1
Begin DoDot:2
+10 SET NXT=$PIECE(MSG(X),HL("FS"),Y)
Begin DoDot:3
+11 IF $LENGTH($GET(TMFE(SEQ)))=245
Begin DoDot:4
+12 IF $LENGTH(NXT_$GET(TMFE(SEQ,SEQ1)))>245
SET LNGTH1=$LENGTH(TMFE(SEQ,SEQ1))
SET LNGTH2=245-LNGTH1
SET TMFE(SEQ,SEQ1)=$GET(TMFE(SEQ,SEQ1))_$EXTRACT(NXT,1,LNGTH2)
SET LNGTH2=LNGTH2+1
SET NXT=$EXTRACT(NXT,LNGTH2,$LENGTH(NXT))
SET SEQ1=SEQ1+1
+13 IF $LENGTH(NXT_$GET(TMFE(SEQ,SEQ1)))'>245
SET TMFE(SEQ,SEQ1)=$GET(TMFE(SEQ,SEQ1))_NXT
End DoDot:4
QUIT
+14 IF $LENGTH(NXT_$GET(TMFE(SEQ)))>245
SET LNGTH1=$LENGTH($GET(TMFE(SEQ)))
SET LNGTH2=245-LNGTH1
SET TMFE(SEQ)=$GET(TMFE(SEQ))_$EXTRACT(NXT,1,LNGTH2)
SET LNGTH2=LNGTH2+1
SET NXT=$EXTRACT(NXT,LNGTH2,$LENGTH(NXT))
SET TMFE(SEQ,SEQ1)=NXT
+15 IF $LENGTH(NXT_$GET(TMFE(SEQ)))'>245
SET TMFE(SEQ)=$GET(TMFE(SEQ))_NXT
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+16 SET MFE5=$GET(TMFE(5))
+17 SET LASTID=$LENGTH(MFE5,REP)
SET IDCNT=1
SET ACNT=0
+18 FOR X=1:1:LASTID
SET ACNT=ACNT+1
SET IDS(ACNT)=$PIECE(MFE5,REP,X)
Begin DoDot:1
+19 ;if this is the last entry check for an extension of the message and reset the key variables
+20 IF X=LASTID
IF $DATA(TMFE(5,IDCNT))
Begin DoDot:2
+21 SET IDS(ACNT)=IDS(ACNT)_$PIECE(TMFE(5,IDCNT),REP)
+22 SET MFE5=$PIECE(TMFE(5,IDCNT),REP,2,99)
IF MFE5=""
QUIT
+23 SET IDCNT=IDCNT+1
SET X=0
SET LASTID=$LENGTH(MFE5,REP)
End DoDot:2
End DoDot:1
+24 SET PDLT=$$FMDATE^HLFNC($GET(TMFE(4)))
+25 SET INST=$PIECE($GET(TMFE(3)),"-")
+26 SET ZCNT=$PIECE($GET(TMFE(3)),"-",2)
+27 SET TYPE=$GET(TMFE(2))
+28 SET IDENSTAT=$SELECT(TYPE="MDC":"H",1:"A")
+29 SET ICN=$PIECE($GET(IDS(1)),HLCOMP)
+30 SET AATYP=$PIECE($PIECE($GET(IDS(2)),HLCOMP,4),SUBCOMP,3)
+31 SET AA=$SELECT(AATYP="ISO":$PIECE($PIECE($GET(IDS(2)),HLCOMP,4),SUBCOMP,2),1:$PIECE($PIECE($GET(IDS(2)),HLCOMP,4),SUBCOMP))
+32 SET IDTYP=$PIECE($GET(IDS(2)),HLCOMP,5)
+33 ;We do not have facility to map ID type from OID in VistA so default "NI" value to Id type if site is 200N*
+34 IF $EXTRACT(INST,1,4)="200N"
IF AATYP="ISO"
SET IDTYP="NI"
+35 SET DFNATST=$PIECE($GET(IDS(2)),HLCOMP)
+36 SET MFE(INST,ZCNT,1)=MSG
+37 IF $DATA(MSG(1))
Begin DoDot:1
+38 SET MCNT=0
FOR
SET MCNT=$ORDER(MSG(MCNT))
if +MCNT=0
QUIT
SET MFE(INST,ZCNT,MCNT+1)=MSG(MCNT)
End DoDot:1
+39 SET MFI(ICN,INST,ZCNT)=PDLT_"^^"_TYPE_"^^^^"_DFNATST_"^"_IDENSTAT_"^"_AA_"^"_IDTYP
+40 QUIT
ZET ;;ZET
+1 ;process Patient's Date Last Treated Event Type, ZET segment
+2 NEW PDLTET,IPP
+3 SET PDLTET=$PIECE(MSG,HL("FS"),2)
+4 SET $PIECE(MFI(ICN,INST,ZCNT),"^",2)=PDLTET
+5 ;DG*5.3*800 - Process In-Person Proofed
+6 ;In-Person Proofed
SET IPP=$PIECE(MSG,HL("FS"),3)
+7 SET $PIECE(MFI(ICN,INST,ZCNT),"^",6)=IPP
+8 QUIT
RSP ;response process logic entry point
+1 QUIT
ROUTE ;routing logic entry point
+1 NEW MPI
+2 SET MPI=$$MPILINK^MPIFAPI()
Begin DoDot:1
+3 ;**1013 - Story - 1260465 (ckn) - Include 200M in HLL links for HAC
+4 IF $PIECE($GET(MPI),U)'=-1
SET HLL("LINKS",1)="VAFC MFN-M05 CLIENT"_"^"_MPI_$SELECT($PIECE($$SITE^VASITE(),"^",3)=741:"^200M",1:"")
+5 IF $PIECE($GET(MPI),U)=-1
Begin DoDot:2
+6 NEW RGLOG
DO START^RGHLLOG(HLMTIEN,"","")
+7 DO EXC^RGHLLOG(224,"No MPI link identified in CIRN SITE PARAMETER file (#991.8)",$GET(PDFN))
+8 DO STOP^RGHLLOG(0)
End DoDot:2
End DoDot:1
+9 QUIT
TEST ;
+1 WRITE $$REPROC^HLUTIL(39266,"D IN^VAFCTFIN")
+2 QUIT
RECONCIL ;
+1 NEW DFN,MFIC,VAFCX,VAFCY,TFL,CNFLT,LOCCMOR,VAFCTYPE,VAFCN,IDSTAT,SID
+2 SET CNFLT=0
+3 SET DFN=$$GETDFN^MPIF001(ICN)
+4 IF DFN'>0
SET CNFLT=1_"^"_$PIECE($GET(DFN),"^",2)
+5 ;CHANGED TFL^VAFCTFU1 to TFL^VAFCTFU3 to get ALL tf entries
+6 IF MFUPT="REP"
IF +CNFLT=0
DO TFL^VAFCTFU3(.TFL,DFN)
SET VAFCX=0
FOR
SET VAFCX=$ORDER(TFL(VAFCX))
if 'VAFCX
QUIT
Begin DoDot:1
+7 ; S MFIC($P(TFL(VAFCX),"^"))=TFL(VAFCX) I '$D(MFI(ICN,$P(TFL(VAFCX),"^"))) D DEL(ICN,$P(TFL(VAFCX),"^"))
+8 NEW EXTFIEN,STIEN,STEXT
+9 SET MFIC($PIECE(TFL(VAFCX),"^"))=TFL(VAFCX)
SET STIEN=$$LKUP^XUAF4($PIECE(TFL(VAFCX),"^"))
SET STEXT=$PIECE(TFL(VAFCX),"^")
+10 SET EXTFIEN=0
FOR
SET EXTFIEN=$ORDER(^DGCN(391.91,"APAT",DFN,STIEN,EXTFIEN))
if +EXTFIEN=0
QUIT
Begin DoDot:2
+11 NEW NODE0,NODE2,EXIDTYP,EXAA,EXSID,EXIDST,ZCNT,MATCH
+12 ; Existing AA, ID type, Source ID, Identifier Status
+13 SET NODE0=$GET(^DGCN(391.91,EXTFIEN,0))
SET NODE2=$GET(^DGCN(391.91,EXTFIEN,2))
+14 SET EXIDTYP=$PIECE(NODE0,"^",9)
SET EXAA=$PIECE(NODE2,"^")
SET EXSID=$PIECE(NODE2,"^",2)
SET EXIDST=$PIECE(NODE2,"^",3)
+15 ;Loop through MFI (incoming data) and compare the values
+16 SET ZCNT=0
SET MATCH=0
FOR
SET ZCNT=$ORDER(MFI(ICN,STEXT,ZCNT))
if +ZCNT=0!(MATCH)
QUIT
Begin DoDot:3
+17 NEW TMPNODE,INIDST,INAA,INIDTYP,INSID
+18 SET TMPNODE=$GET(MFI(ICN,STEXT,ZCNT))
+19 SET INSID=$PIECE(TMPNODE,"^",7)
SET INIDST=$PIECE(TMPNODE,"^",8)
SET INAA=$PIECE(TMPNODE,"^",9)
SET INIDTYP=$PIECE(TMPNODE,"^",10)
+20 IF INSID=EXSID
IF INIDST=EXIDST
IF INAA=EXAA
IF INIDTYP=EXIDTYP
SET MATCH=1
QUIT
+21 ;For 200N* only check Source ID and Idtype if no match for all matching criteria
IF 'MATCH
IF $EXTRACT(STEXT,1,4)="200N"
Begin DoDot:4
+22 IF INSID=EXSID
IF INIDTYP=EXIDTYP
SET MATCH=1
End DoDot:4
End DoDot:3
+23 IF 'MATCH
SET DELTFARR(EXTFIEN)=""
End DoDot:2
+24 IF $DATA(DELTFARR)
SET DTIEN=0
FOR
SET DTIEN=$ORDER(DELTFARR(DTIEN))
if +DTIEN=0
QUIT
DO DEL(ICN,STEXT,DTIEN)
+25 KILL DELTFARR
End DoDot:1
+26 ;VAFCX=ICN and VAFCY=INSTITUTION
+27 SET VAFCX=0
FOR
SET VAFCX=$ORDER(MFI(VAFCX))
if 'VAFCX
QUIT
Begin DoDot:1
+28 SET VAFCY=0
FOR
SET VAFCY=$ORDER(MFI(VAFCX,VAFCY))
if 'VAFCY
QUIT
Begin DoDot:2
+29 SET VAFCN=0
FOR
SET VAFCN=$ORDER(MFI(VAFCX,VAFCY,VAFCN))
if 'VAFCN
QUIT
Begin DoDot:3
+30 SET VAFCTYPE=$PIECE(MFI(VAFCX,VAFCY,VAFCN),"^",3)
+31 SET SID=$PIECE(MFI(VAFCX,VAFCY,VAFCN),"^",7)
+32 SET IDSTAT=$PIECE(MFI(VAFCX,VAFCY,VAFCN),"^",8)
+33 ;**837 - MVI_791 (ckn)
+34 SET AA=$PIECE(MFI(VAFCX,VAFCY,VAFCN),"^",9)
SET IDTYP=$PIECE(MFI(VAFCX,VAFCY,VAFCN),"^",10)
+35 IF +CNFLT=1
Begin DoDot:4
+36 SET MFA(VAFCY,VAFCN)="MFA"_HL("FS")_VAFCTYPE_HL("FS")_VAFCY_"-"_VAFCN_HL("FS")_$$HLDATE^HLFNC($$NOW^XLFDT)_HL("FS")_"U"_HLCOMP_$SELECT(VAFCTYPE="MDL":"Delete of ",1:"Update of ")
+37 SET MFA(VAFCY,VAFCN)=$GET(MFA(VAFCY,VAFCN))_VAFCY_" Failed at "_$PIECE($$SITE^VASITE,"^",3)_" due to "_$PIECE(CNFLT,"^",2)
End DoDot:4
+38 IF +CNFLT=0
IF VAFCTYPE="MAD"!(VAFCTYPE="MUP")!(VAFCTYPE="MDC")
DO ADDUPD(DFN,VAFCY,$PIECE(MFI(VAFCX,VAFCY,VAFCN),"^"),$PIECE(MFI(VAFCX,VAFCY,VAFCN),"^",2),$PIECE(MFI(VAFCX,VAFCY,VAFCN),"^",6),$GET(SID),$GET(IDSTAT),VAFCN,VAFCTYPE,AA,IDTYP)
+39 ; I +CNFLT=0 I VAFCTYPE="MDL" D DEL(ICN,VAFCY,VAFCN)
+40 IF +CNFLT=0
IF VAFCTYPE="MDL"
Begin DoDot:4
+41 NEW EXTFIEN,STIEN
+42 SET STIEN=$$LKUP^XUAF4(VAFCY)
+43 SET EXTFIEN=0
FOR
SET EXTFIEN=$ORDER(^DGCN(391.91,"APAT",DFN,STIEN,EXTFIEN))
if +EXTFIEN=0
QUIT
Begin DoDot:5
+44 NEW NODE0,NODE2,EXIDTYP,EXAA,EXSID,EXIDST
+45 ; Existing AA, ID type, Source ID, Identifier Status
+46 SET NODE0=$GET(^DGCN(391.91,EXTFIEN,0))
SET NODE2=$GET(^DGCN(391.91,EXTFIEN,2))
+47 SET EXIDTYP=$PIECE(NODE0,"^",9)
SET EXAA=$PIECE(NODE2,"^")
SET EXSID=$PIECE(NODE2,"^",2)
SET EXIDST=$PIECE(NODE2,"^",3)
+48 IF EXIDTYP=IDTYP
IF EXAA=AA
IF EXSID=SID
IF EXIDST=IDSTAT
DO DEL(ICN,VAFCY,EXTFIEN)
QUIT
+49 ;Check only Source iD and IdType for 200N*
IF $EXTRACT(VAFCY,1,4)="200N"
Begin DoDot:6
+50 IF EXIDTYP=IDTYP
IF EXSID=SID
DO DEL(ICN,VAFCY,EXTFIEN)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+51 QUIT
ADDUPD(DFN,INST,PDLT,PDLRTET,IPP,DFNATST,IDENSTAT,ZCNT,VAFCTYPE,AA,IDTYP) ;add or update TF entry
+1 NEW ERROR,STA
+2 SET STA=INST
+3 SET INST=$$LKUP^XUAF4(INST)
+4 IF INST=0
SET ERROR(STA)="Update of "_STA_" Failed at "_$PIECE($$SITE^VASITE,"^",3)_" due to unknown Institution IEN "_INST_" passed into TF update."
+5 IF '$DATA(ERROR(STA))
DO FILE^VAFCTFU(DFN,INST_"^"_$GET(PDLT)_"^"_$GET(PDLRTET),1,1,.ERROR,$GET(IPP),DFNATST,IDENSTAT,AA,IDTYP)
+6 SET MFA(STA,ZCNT)="MFA"_HL("FS")_VAFCTYPE_HL("FS")_STA_"-"_ZCNT_HL("FS")_$$HLDATE^HLFNC($$NOW^XLFDT)_HL("FS")
+7 IF '$DATA(ERROR(STA))
SET MFA(STA,ZCNT)=MFA(STA,ZCNT)_"S"
+8 IF $DATA(ERROR(STA))
SET MFA(STA,ZCNT)=MFA(STA,ZCNT)_"U"_HLCOMP_ERROR(STA)_HL("FS")
+9 QUIT
DEL(ICN,INST,DTIEN) ;delete a TF entry
+1 NEW ERROR,STA
+2 SET STA=INST
+3 SET INST=$$LKUP^XUAF4(INST)
+4 SET ERROR=$$DELETETF^VAFCTFU(ICN,INST,DTIEN)
+5 ;**821 - No need to send MFA for entries that are deleted locally
+6 ;S MFA(STA,ZCNT)="MFA"_HL("FS")_"MDL"_HL("FS")_STA_"-"_ZCNT_HL("FS")_$$HLDATE^HLFNC($$NOW^XLFDT)_HL("FS")
+7 ;I +ERROR'=1 S MFA(STA,ZCNT)=MFA(STA,ZCNT)_"S"
+8 ;I +ERROR=1 S MFA(STA,ZCNT)=MFA(STA,ZCNT)_"U"_HLCOMP_"Delete Failed: "_$P(ERROR,"^",2)
+9 QUIT
