Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VAFCTFIN

VAFCTFIN.m

Go to the documentation of this file.
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