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

MPIFA31B.m

Go to the documentation of this file.
  1. MPIFA31B ;BP/CMC-BUILD A31 MSGS ;7/15/21 15:04
  1. ;;1.0;MASTER PATIENT INDEX VISTA;**22,24,27,28,31,25,44,46,54,59,60,64,68,75,78**;30 Apr 99;Build 1
  1. ;
  1. ; Integration Agreements Utilized:
  1. ; START, EXC, STOP^RGHLLOG - #2796
  1. ; BLDEVN, BLDPD1, BLDPID^VAFCQRY - #3630
  1. ; $$PV1^VAFCSB, $$RADE^VAFCSB, $$LABE^VAFCSB, $$PHARA^VAFCSB, $$PV2^VAFCSB - #4921
  1. ;
  1. TA31 ; Tasked entry point
  1. N TMP
  1. S TMP=$$A31(DFN)
  1. Q
  1. ;
  1. A31(DFN) ;BUILD AND SEND A31
  1. I $P($$SITE^VASITE,"^",3)=200 Q 1
  1. ; ^ PATCH 25 IF this is the FHIE Host system, don't build A31 messages
  1. N RESLT,CNT,MPI,EVN,TCNT,ERR,PD1,PID,EN,LAB,PV1,PV2,RAD,PRE,OLD,ZPD
  1. N ZEL,ZSP,SIDG,NAMECOMP,DODF,DODD,DODNP,DODOPT,DODDISDT,SECLVL,SEXOR,SEXORD,PRON,PROND
  1. K HLA("HLA"),HLA("HLS")
  1. Q:$E($$GETICN^MPIF001(DFN),1,3)=$P($$SITE^VASITE(),"^",3) 0
  1. ; ^ LOCAL ICN DON'T SEND
  1. Q:+$$GETICN^MPIF001(DFN)=-1 0
  1. ; ^ NO ICN DON'T SEND
  1. S CNT=1
  1. D INIT^HLFNC2("MPIF ADT-A31 SERVER",.HL)
  1. I $O(HL(""))="" Q "-1^"_$P(HL,"^",2)
  1. S HLECH=HL("ECH"),HLFS=HL("FS"),COMP=$E(HL("ECH"),1),REP=$E(HL("ECH"),2),SUBCOMP=$E(HL("ECH"),4)
  1. S ERR="",TCNT=0
  1. D BLDEVN^VAFCQRY(DFN,"1,2",.EVN,.HL,"A31",.ERR)
  1. Q:ERR'="" ERR
  1. D BLDPID^VAFCQRY(DFN,1,"ALL",.PID,.HL,.ERR) ;**25
  1. Q:ERR'="" ERR
  1. D BLDPD1^VAFCQRY(DFN,"3",.PD1,.HL,.ERR) ;**44 NEW PD1 SEGMENT VALUES -- SENDING CMOR AGAIN AS WITHOUT 40 ON THE MPI SIDE THIS IS A PROBLEM.
  1. ;S PD1=$$PD1^VAFCSB ;**44 NEW PD1 SEGMENT VALUES -- IMDQ DECIDED NOT TO SEND PREFERRED FACILITY 9/7/06
  1. N X S X="VAFCSB" X ^%ZOSF("TEST") I $T D
  1. .;**44 VAFCSB coming in with DG*5.3*707
  1. .S PV1=$$PV1^VAFCSB ;**44 PV1 segment
  1. .S RAD=$$RADE^VAFCSB ;**44 OBX FOR LAST RADIOLOGY EXAM
  1. .S LAB=$$LABE^VAFCSB ;**44 OBX FOR LAST LAB EXAM
  1. .S PRE=$$PHARA^VAFCSB ;**44 OBX FOR ACTIVE PRESCRIPTIONS
  1. .S SIDG=$$SIG^VAFCSB(DFN) ;**59 OBX FOR SELF ID GENDER
  1. .S NAMECOMP=$$NAMEOBX^VAFCSB(DFN) ;**59,MVI_3975 (mko): OBX for Patient .01 and Name Components
  1. .S SECLVL=$$SECLOG^VAFCSB(DFN) ;**68 Story 783361 (ckn) - OBX for Security Level
  1. .D SEXOR^VAFCSB(DFN,.SEXOR) ;**78, VAMPI-11114 (dri)
  1. .D SEXORD^VAFCSB(DFN,.SEXORD) ;**78, VAMPI-11114 (dri)
  1. .D PRON^VAFCSB(DFN,.PRON) ;**78, VAMPI-11118 (dri)
  1. .D PROND^VAFCSB(DFN,.PROND) ;**78, VAMPI-11118 (dri)
  1. .S PV2=$$PV2^VAFCSB ;**44 PV2 segment
  1. S DODF=$$DODF^VAFCSB(DFN) ;**60 OBX for DOD fields
  1. ;**64 Story 323009 (ckn) : OBX for Additional DOD fields
  1. S DODD=$$DODD^VAFCSB(DFN) ;Date Of Death Documents
  1. S DODOPT=$$DODOPT^VAFCSB(DFN) ; Date Of Death Option used
  1. S DODNP=$$DODNTPRV^VAFCSB(DFN) ; Date Of Death Notification provider
  1. S OLD=$$OLD ;**54,MVI_913: OBX to mark an older record
  1. S ZPD=$$EN1^VAFHLZPD(DFN,"1,17,21,34") ;25 ;**44 ADDED PSEUDO SSN REASON (34), 1 and 21 TO ZPD SEGMENT
  1. S ZSP=$$EN^VAFHLZSP(DFN) ;**59
  1. S ZEL=$$EN^VAFHLZEL(DFN,"1,8,9",1) ;**59
  1. S EN=1
  1. S HLA("HLS",EN)=EVN(1),EN=EN+1
  1. S CNT=0 F S CNT=$O(PID(CNT)) Q:CNT="" D
  1. .I CNT=1 S HLA("HLS",EN)=PID(CNT)
  1. .I CNT>1 S HLA("HLS",EN,CNT-1)=PID(CNT)
  1. S EN=EN+1
  1. I $G(PD1(1))'="" S HLA("HLS",EN)=PD1(1),EN=EN+1 ;**44 only pass PD1 segment if has values -- SENDING CMOR AGAIN AS WITHOUT 40 ON MPI SIDE THIS IS A PROBLEM.
  1. I $G(PV1)'="" S HLA("HLS",EN)=PV1,EN=EN+1 ;**44 only pass PV1 segment if has values
  1. I $G(PV2)'="" S HLA("HLS",EN)=PV2,EN=EN+1 ;**44 only pass PV2 segment if has values
  1. I $G(RAD)'="" S HLA("HLS",EN)=RAD,EN=EN+1 ;**44 only pass RADIOLOGY IN OBX segment if has values
  1. I $G(LAB)'="" S HLA("HLS",EN)=LAB,EN=EN+1 ;**44 only pass LAB IN OBX segment if has values
  1. I $G(PRE)'="" S HLA("HLS",EN)=PRE,EN=EN+1 ;**44 only pass PRESCRIPTION IN OBX segment if has values
  1. I $G(OLD)'="" S HLA("HLS",EN)=OLD,EN=EN+1 ;**54,MVI_913: pass OLDER RECORD in OBX if flagged as such
  1. I $G(SIDG)'="" S HLA("HLS",EN)=SIDG,EN=EN+1 ;**59
  1. I $G(DODF)'="" S HLA("HLS",EN)=DODF,EN=EN+1 ;**60 MVI_4733 (ckn) Pass DOD fields in OBX
  1. ;**64 Story 323009 (ckn) : Pass additional DOD fields in OBX
  1. I $G(DODD)'="" S HLA("HLS",EN)=DODD,EN=EN+1
  1. I $G(DODOPT)'="" S HLA("HLS",EN)=DODOPT,EN=EN+1
  1. I $G(DODNP)'="" S HLA("HLS",EN)=DODNP,EN=EN+1
  1. I $G(NAMECOMP)'="" S HLA("HLS",EN)=NAMECOMP,EN=EN+1 ;**59,MVI_3975 (mko): pass NAME COMPONENTS in OBX
  1. I $G(SECLVL)'="" S HLA("HLS",EN)=SECLVL,EN=EN+1 ;**68,Story 783361 (ckn)- Security
  1. I $O(SEXOR(0)) N CNT S CNT=0 F S CNT=$O(SEXOR(CNT)) Q:'CNT S HLA("HLS",EN)=SEXOR(CNT),EN=EN+1 ;**78, VAMPI-11114 (dri)
  1. I $O(SEXORD(0)) D S EN=EN+1 ;**78, VAMPI-11114 (dri)
  1. .N CNT,LVL
  1. .S LVL=1,CNT=0 F S CNT=$O(SEXORD(CNT)) Q:'CNT D
  1. ..I CNT=1 S HLA("HLS",EN)=SEXORD(CNT)
  1. ..I CNT>1 S HLA("HLS",EN,LVL)=SEXORD(CNT),LVL=LVL+1
  1. I $O(PRON(0)) N CNT S CNT=0 F S CNT=$O(PRON(CNT)) Q:'CNT S HLA("HLS",EN)=PRON(CNT),EN=EN+1 ;**78, VAMPI-11118 (dri)
  1. I $O(PROND(0)) D S EN=EN+1 ;**78, VAMPI-11118 (dri)
  1. .N CNT,LVL
  1. .S LVL=1,CNT=0 F S CNT=$O(PROND(CNT)) Q:'CNT D
  1. ..I CNT=1 S HLA("HLS",EN)=PROND(CNT)
  1. ..I CNT>1 S HLA("HLS",EN,LVL)=PROND(CNT),LVL=LVL+1
  1. S HLA("HLS",EN)=ZPD,EN=EN+1 ;**44 ZPD SEGMENT
  1. I $G(ZSP)'="" S HLA("HLS",EN)=ZSP,EN=EN+1 ;**59 ZSP segment
  1. I $G(ZEL)'="" S HLA("HLS",EN)=ZEL,EN=EN+1 ;**59 ZEL segment
  1. S MPI=$$MPILINK^MPIFAPI()
  1. Q:$P($G(MPI),"^")=-1 "-1^No logical link defined for the MPI"
  1. ;**75 - Story - 1260465 (ckn) - Include 200M in HLL links for HAC
  1. S HLL("LINKS",1)="MPIF ADT-A31 CLIENT^"_MPI_$S($P($$SITE^VASITE(),"^",3)=741:"^200M",1:"")
  1. D GENERATE^HLMA("MPIF ADT-A31 SERVER","LM",1,.MPIFRSLT,"","")
  1. S RESLT=$S(+MPIFRSLT:MPIFRSLT,1:"-1^"_$P(MPIFRSLT,"^",3)) ;**68 Story 827754 (jfw) - Make Error Data Consistent (-1^msg)
  1. S ^XTMP("MPIFA31%"_DFN,0)=$$FMADD^XLFDT(DT,5)_"^"_DT_"^"_"MPIA31 msg to MPI for DFN "_DFN
  1. I +RESLT<0 S ^XTMP("MPIFA31%"_DFN,"MPI",0)="A" ;**68 Story 827754 (jfw) - Check for value < 0 instead of '+RESLT
  1. K HLA,HLL("LINKS"),COMP,REP,SUBCOMP,HLA("HLA"),HLA("HLS"),MPIFRSLT
  1. ;**44 REMOVED HLEID, HLECH AND HLFS from Kill line above
  1. Q RESLT
  1. ;
  1. RES ;
  1. N NXT,DFN,ERROR,CODE S CODE=""
  1. F NXT=1:1 X HLNEXT Q:HLQUIT'>0 D
  1. .I $E(HLNODE,1,3)="MSA" S DFN=$P($P(HLNODE,HL("FS"),7),"=",2),ERROR=$P(HLNODE,HL("FS"),4),CODE=$P(HLNODE,HL("FS"),2)
  1. .I $E(HLNODE,1,3)="MSA"&(CODE="AR") D
  1. ..; ERROR RETURNED IN MSA - LOG EXCEPTION
  1. ..D START^RGHLLOG(HLMTIEN,"","")
  1. ..;**44 check which type of exception to be logged
  1. ..D EXC^RGHLLOG(234,ERROR,DFN) ;**46
  1. ..D STOP^RGHLLOG(0)
  1. K:$G(DFN)>0 ^XTMP("MPIF OLD RECORDS",DFN) ;**54,MVI_913: Delete the old record designation
  1. K ^XTMP("MPIFA31%"_DFN)
  1. Q
  1. ;
  1. OLD() ; Return OBX segment to flag a record as "old"
  1. ;**54,MVI_913: New subroutine
  1. Q $S($D(^XTMP("MPIF OLD RECORDS",DFN))#2:"OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"OLDER RECORD"_HL("FS")_HL("FS")_"Y",1:"")
  1. ;