VAFCTFIN.m

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 ---VAFCTFIN   11752     printed  Feb 19, 2025@00:28:27                                                                                                                                                                                                   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