RGADTP ;BIR/DLR-ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS ;2/18/22 10:22
;;1.0;CLINICAL INFO RESOURCE NETWORK;**26,27,20,34,35,40,45,44,47,59,60,61,62,63,65,68,69,70,74,76,77**;30 Apr 99;Build 3
;
;Reference to BLDEVN^VAFCQRY and BLDPID^VAFCQRY supported by IA #3630
;Reference to EN1^VAFHLZEL is supported by IA #752
;Reference to Patient file (#2) PREFERRED FACILITY (#27.02) is supported by IA #1850
;Reference to $$PV2, $$PHARA, $$LABE, $$RADE ^VAFCSB is supported by IA #4921
;
INIT ;
N RGER,RGSITE,ARRAY,MSH,RGLOCAL,RGEVNT,REP,DIC,DR,DIE,DA,DLAYGO
S RGER=""
D IN
D PROCIN
D GENACK
Q
;
PROC ;processing entry point
N HLA,RGADT,PV1,DIC,ARRAY,RGEVNT,RGLOCAL,REP,ICN,RGSITE
S RGEVNT=HL("ETN")
I $G(HL("MID"))'="" S RGADT=HL("MID")
I $G(HL("MID"))="" S RGADT=999
D IN
S ICN=$G(ARRAY("ICN"))
I +$G(ICN)<1 Q ;quit if no ICN
I $E($G(ICN),1,3)=$P($$SITE^VASITE,"^",3) Q ;quit if ICN is a local
S ZTSAVE("DFN")="",ZTSAVE("RGEVNT")="",ZTSAVE("HLA(""HLS"",")="",ZTRTN="SEND^RGADTPC",ZTDESC="Sending HL7 Patient Update...",ZTIO="RG QUEUE",ZTDTH=$H D ^%ZTLOAD
K ZTSAVE,ZTRTN,ZTDESC,ZTIO,ZTDTH
Q
;
IN ;Process in the ADT A04/A08 (routing logic)
N RGI,MSG,RG,SG,DFN,EVN,SITE,RGC,RGJ,DIC,PV1,PID,COMP,ENT,EN,THLA,LAB,RAD,PHARM,TMP,SIG,OBXDONE,OLD,NAMECOMP,DODF,DODD,DODNP,DODDISDT,DODOPT,SECLVL,SEXOR,SEXORD,PRON,PROND
S ENT=1,REP=$E(HL("ECH"),2),COMP=$E(HL("ECH"),1)
;set local flag to indicate the processing of an outbound for reformatting
I $P($G(HL("SAF")),COMP)=$P($$SITE^VASITE,"^",3) S RGLOCAL=1
I $P($G(HL("SAF")),COMP)'=$P($$SITE^VASITE,"^",3) S RGLOCAL=0
S RGC=$E($G(HL("ECH")),1)
F RGI=1:1 X HLNEXT Q:HLQUIT'>0 S MSG=HLNODE,SG=$E(HLNODE,1,3) D
.S RGJ=0 F S RGJ=$O(HLNODE(RGJ)) Q:'RGJ S MSG(RGJ)=HLNODE(RGJ)
.D:SG?2A1(1A,1N) PICK
.K MSG
;if message MSH sending facility matches the PID assigning authority update
S ENT=0,EN=1,OBXDONE=0 F S ENT=$O(THLA("HLS",ENT)) Q:ENT="" D
.;**61, MVI_3714 (ckn) - No need to send OBX segment previously built in 2.3v to MPI - Only add new OBX for 2.4v
.I $E($G(THLA("HLS",ENT)),1,3)="OBX" D Q
..I OBXDONE Q ;**61 - MVI_3714 (ckn) - OBX was added in previous loop
..S RAD=$$RADE I RAD'="" S HLA("HLS",EN)=RAD,EN=EN+1
..S LAB=$$LABE I LAB'="" S HLA("HLS",EN)=LAB,EN=EN+1
..S PHARM=$$PHARA I PHARM'="" S HLA("HLS",EN)=PHARM,EN=EN+1
..S OLD=$$OLD I OLD'="" S HLA("HLS",EN)=OLD,EN=EN+1 ;**59,MVI_914: Pass OLDER RECORD in OBX if flagged as such
..S SIG=$$SIG^VAFCSB(DFN) I SIG'="" S HLA("HLS",EN)=SIG,EN=EN+1 ;**61,MVI_3714: Add Self Identified Gender in OBX
..S NAMECOMP=$$NAMEOBX^VAFCSB(DFN) I NAMECOMP'="" S HLA("HLS",EN)=NAMECOMP,EN=EN+1 ;**61,MVI_3976 (mko): Add Name Components in OBX
..S DODF=$$DODF^VAFCSB(DFN) I $G(DODF)'="" S HLA("HLS",EN)=DODF,EN=EN+1 ;**62 MVI_4899 (ckn): Add DOD fields in OBX
..;**65 Story 323009 (ckn) : OBX for additional DOD fields
..S DODD=$$DODD^VAFCSB(DFN) I $G(DODD)'="" S HLA("HLS",EN)=DODD,EN=EN+1 ;Date Of Death Documents
..S DODOPT=$$DODOPT^VAFCSB(DFN) I $G(DODOPT)'="" S HLA("HLS",EN)=DODOPT,EN=EN+1 ;Date Of Death Option Used
..;**69 Story 603856 (ckn) - No more OBX for Notification Provider from VistA
..;S DODNP=$$DODNTPRV^VAFCSB(DFN) I $G(DODNP)'="" S HLA("HLS",EN)=DODNP,EN=EN+1 ;Date Of Death Notify Provider
..S SECLVL=$$SECLOG^VAFCSB(DFN) I $G(SECLVL)'="" S HLA("HLS",EN)=SECLVL,EN=EN+1 ;**70 - Story 783361 (ckn) - Build OBX for Security Level
..D SEXOR^VAFCSB(DFN,.SEXOR) 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 ;**76, VAMPI-11114 (dri)
..D SEXORD^VAFCSB(DFN,.SEXORD) I $O(SEXORD(0)) D S EN=EN+1 ;**76, VAMPI-11114 (dri)
...N CNT,LVL
...S LVL=1,CNT=0 F S CNT=$O(SEXORD(CNT)) Q:'CNT D
....I CNT=1 S HLA("HLS",EN)=SEXORD(CNT)
....I CNT>1 S HLA("HLS",EN,LVL)=SEXORD(CNT),LVL=LVL+1
..D PRON^VAFCSB(DFN,.PRON) 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 ;**76, VAMPI-11118 (dri)
..D PROND^VAFCSB(DFN,.PROND) I $O(PROND(0)) D S EN=EN+1 ;**76, VAMPI-11118 (dri)
...N CNT,LVL
...S LVL=1,CNT=0 F S CNT=$O(PROND(CNT)) Q:'CNT D
....I CNT=1 S HLA("HLS",EN)=PROND(CNT)
....I CNT>1 S HLA("HLS",EN,LVL)=PROND(CNT),LVL=LVL+1
..S OBXDONE=1 ;**61 - MVI_3714 (ckn) - flag for all OBX added
.S HLA("HLS",EN)=THLA("HLS",ENT),EN=EN+1
.I $E($G(THLA("HLS",ENT)),1,3)="PID"!($E($G(THLA("HLS",ENT)),1,3)="ZEL") D
..;**47 handle if ZEL is over 245 as well
..I $O(THLA("HLS",ENT,""))'="" D
...S CNT="" F S CNT=$O(THLA("HLS",ENT,CNT)) Q:CNT="" S HLA("HLS",EN-1,CNT)=THLA("HLS",ENT,CNT)
.I $E($G(THLA("HLS",ENT)),1,3)="PV1" I RGLOCAL S TMP=$$PV2B I TMP'="" S HLA("HLS",EN)=$$PV2B,EN=EN+1 ;**47
.;**61 MVI_3714 (ckn) Add Self Identified Gender in OBX
.;I $E($G(THLA("HLS",ENT)),1,3)="ZPD" I RGLOCAL D
.;.S RAD=$$RADE I RAD'="" S HLA("HLS",EN)=RAD,EN=EN+1
.;.S LAB=$$LABE I LAB'="" S HLA("HLS",EN)=LAB,EN=EN+1
.;.S PHARM=$$PHARA I PHARM'="" S HLA("HLS",EN)=PHARM,EN=EN+1
.;.S OLD=$$OLD I OLD'="" S HLA("HLS",EN)=OLD,EN=EN+1 ;**59,MVI_914: Pass OLDER RECORD in OBX if flagged as such
QUIT Q
;
ROUTE ;
N RGERR
I $G(RGEVNT)="" S RGEVNT=$G(HL("ETN"))
N MPI S MPI=$$MPILINK^MPIFAPI() D
.;**74 - Story - 1260465 (ckn) - Include 200M in HLL links for HAC
.I $P($G(MPI),U)'=-1 S HLL("LINKS",1)="RG ADT-"_HL("ETN")_" 2.4 CLIENT^"_MPI_$S($P($$SITE^VASITE(),"^",3)=741:"^200M",1:"")
.I $P($G(MPI),U)=-1 D
..N RGLOG,RGMTXT D START^RGHLLOG(HLMTIEN,"","") S RGMTXT="for DFN#"_$G(DFN)
..D EXC^RGHLLOG(224,"No MPI link identified"_RGMTXT,$G(DFN)) S RGERR=1
;**60 MVI_1837(rjh): to catch undefined dfn
;I $G(RGERR)'=1 S ^XTMP("RG"_HL("ETN")_"%"_DFN,0)=$$FMADD^XLFDT(DT,5)_"^"_DT_"^"_"RG"_HL("ETN")_" msg to MPI for DFN "_DFN S ^XTMP("RG"_HL("ETN")_"%"_DFN,"MPI",0)="A"
I $G(RGERR)'=1,$D(^DPT(+$G(DFN),0)) D
.S ^XTMP("RG"_HL("ETN")_"%"_DFN,0)=$$FMADD^XLFDT(DT,5)_"^"_DT_"^"_"RG"_HL("ETN")_" msg to MPI for DFN "_DFN
.S ^XTMP("RG"_HL("ETN")_"%"_DFN,"MPI",0)="A"
Q
;
RESP ;
N RGER,RGSITE,ARRAY,MSH,RGLOCAL,RGEVNT,RGI,MSG,RG,SG,DFN,EVN,SITE,RGC,RGJ,DIC,PV1,PID
D IN
Q
;
PICK ;check routine for segment entry point
I $T(@SG)]"" D @SG
I $T(@SG)="" Q
Q
;
MSA ;process the MSA segment
N ARRAY,CNT,DFN,EXIT,HLCOMP,RGAA,RGERR,RGEVNT,RGMSG,RETURN,RGX,RGY,RGCODE
I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1
S RGAA=MSG,EXIT=0,RGCODE=$P(RGAA,HL("FS"),2),RGMSG=$P(RGAA,HL("FS"),3),RGERR=$P(RGAA,HL("FS"),4),RGMSG=$$MSG^HLCSUTL(RGMSG,"RETURN(1)") K RGMSG
S CNT=1,RGX=0 F S RGX=$O(RETURN(1,RGX)) Q:'RGX!(EXIT=1) D
.I RETURN(1,RGX)'="" D
..I $D(RGMSG) S RGMSG(CNT)=RETURN(1,RGX),CNT=CNT+1
..I '$D(RGMSG) S RGMSG=RETURN(1,RGX),RGY=RGX
.I RETURN(1,RGX)="" D S CNT=1 K RGMSG
..I $E(RETURN(1,RGY),1,3)="MSH" D MSH
..I $E(RETURN(1,RGY),1,3)="PID" D PIDP^RGADTP1(.RGMSG,.ARRAY,.HL) S EXIT=1
S DFN=$G(ARRAY("DFN"))
;**45 Log Exception ONLY if AR is returned in MSA segment
I RGCODE="AR" D
.D START^RGHLLOG(HLMTIEN,"","")
.D EXC^RGHLLOG(234,RGERR,DFN) ;**44
.D STOP^RGHLLOG(0)
K:$G(DFN)>0 ^XTMP("MPIF OLD RECORDS",DFN) ;**59,MVI_914: Delete the old record designation
I $D(^XTMP("RG"_HL("ETN")_"%"_DFN,0)) K ^XTMP("RG"_HL("ETN")_"%"_DFN)
Q
;
MSH ;
S MSH=1
I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1
I 'RGLOCAL S RGC=$E(HL("ECH"),1)
S RGSITE=$P($P(MSG,HL("FS"),4),RGC),RGEVNT=$P($P(MSG,HL("FS"),9),RGC,2)
Q
;
PV2 ;processor of PV2 segment ;**47
Q
;
PV2B() ;builder of PV2 segment ;**47
N RET S RET=""
I 'RGLOCAL Q RET
N X S X="VAFCSB" X ^%ZOSF("TEST") Q:'$T RET
;**45 VAFCSB coming in with DG*5.3*707
Q $$PV2^VAFCSB
;
PHARA() ;build obx to show active prescriptions
N RET S RET=""
I 'RGLOCAL Q RET
I '$$PATCH^XPDUTL("PSS*1.0*101") Q RET
N X S X="VAFCSB" X ^%ZOSF("TEST") Q:'$T RET
;**45 VAFCSB coming in with DG*5.3*707
Q $$PHARA^VAFCSB
;
LABE() ;BUILD OBX FOR LAST LAB TEST DATE
N RET S RET=""
I 'RGLOCAL Q RET
I '$$PATCH^XPDUTL("LR*5.2*295") Q RET
N X S X="VAFCSB" X ^%ZOSF("TEST") Q:'$T RET
;**45 VAFCSB coming in with DG*5.3*707
Q $$LABE^VAFCSB
;
RADE() ;BUILD OBX FOR LAST RADIOLOGY TEST DATE
N RET S RET=""
I 'RGLOCAL Q RET
I '$$PATCH^XPDUTL("RA*5.0*76") Q RET
N X S X="VAFCSB" X ^%ZOSF("TEST") Q:'$T RET
;**45 VAFCSB coming in with DG*5.3*707
Q $$RADE^VAFCSB
;
EVN ;;
N CNT,ERR S EVN=RGI
I RGLOCAL S (EVN(1),THLA("HLS",ENT))=MSG,ENT=ENT+1
I 'RGLOCAL D
.S ARRAY("EVR")=$P(MSG,HL("FS"),2),ARRAY("DLT")=$$FMDATE^HLFNC($P(MSG,HL("FS"),3))
.S ARRAY("EVNAME")=$$FMNAME^XLFNAME($P(MSG,HL("FS"),2),"",$E(HL("ECH"),1)),ARRAY("SENDING SITE")=$P(MSG,HL("FS"),8)
Q
;
EVNP ;
N EVNX
I $G(DFN)'="" D BLDEVN^VAFCQRY(DFN,"1,2,4,5,6,7",.EVN,.HL,$G(HL("ETN")),.ERR) S CNT=0,EVNX=0 F S EVNX=$O(EVN(EVNX)) Q:'EVNX D
.I CNT>0 S THLA("HLS",EVN,CNT)=EVN(EVNX),CNT=CNT+1
.I CNT'>0 S THLA("HLS",EVN)=EVN(EVNX),CNT=CNT+1
Q
;
PID ;;
N CNT,PIDX
I RGLOCAL D
.N HLCOMP S HLCOMP=$E(HL("ECH"),1),THLA("HLS",ENT)=MSG,DFN=$P($P(MSG,HL("FS"),4),HLCOMP) ;**45 REMOVED +
.D EVNP
.D BLDPID^VAFCQRY(DFN,1,"ALL",.PID,.HL)
.;get ICN value in the PID segment
.S ARRAY("ICN")=+$P($P(PID(1),HL("FS"),4),HLCOMP)
.S CNT=0,PIDX=0 F S PIDX=$O(PID(PIDX)) Q:'PIDX D
..I CNT>0 S THLA("HLS",ENT,CNT)=PID(PIDX),CNT=CNT+1
..I CNT'>0 S THLA("HLS",ENT)=PID(PIDX),CNT=CNT+1
.S ENT=ENT+1
I 'RGLOCAL D PIDP^RGADTP1(.MSG,.ARRAY,.HL)
Q
;
PD1 ;SET PD1 SEQ 3 TO BE PREFERRED FACILITY INSTEAD OF CMOR PATCH **45
N PD1
I RGLOCAL D
.;S PD1=$$PD1^VAFCSB
.;I PD1'="" S THLA("HLS",ENT)=PD1,ENT=ENT+1
I 'RGLOCAL S (ARRAY(991.03),ARRAY("CMOR"))=$P($P(MSG,HL("FS"),4),RGC) ;PUTTING BACK TO DO NEED FOR PATCH 40 ON MPI SIDE
;- NO LONGER DEALING WITH CMOR
Q
;
PV1 ;;
I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1
Q
;
OBX ;;
N COMP,SUBCOMP
S COMP=$E(HL("ECH"),1),SUBCOMP=$E(HL("ECH"),4)
;
I RGLOCAL D
.S THLA("HLS",ENT)=MSG
.N CNT,MSGX S CNT=1,MSGX=0 F S MSGX=$O(MSG(MSGX)) Q:'MSGX S THLA("HLS",ENT,CNT)=MSG(MSGX),CNT=CNT+1
.S ENT=ENT+1
;
I 'RGLOCAL D
.I $$FREE^RGRSPARS($P($P(MSG,HL("FS"),4),COMP,2))="SECURITY LEVEL" D
..S ARRAY("SENSITIVITY")=$$SENSTIVE^RGRSPARS($P(MSG,HL("FS"),6),COMP),ARRAY("SENSITIVITY DATE")=$$FREE^RGRSPARS($$FMDATE^HLFNC($P(MSG,HL("FS"),15)))
..S ARRAY("SENSITIVITY USER")=$$FREE^RGRSPARS($P($P(MSG,HL("FS"),17),COMP,2))_","_$$FREE^RGRSPARS($P($P(MSG,HL("FS"),17),COMP,3))
.;
.;**45 Get SSN VERIFICATION STATUS out of OBX if message is from the MPI
.;I $P(HL("SFN"),COMP)="200M" I $P($P(MSG,HL("FS"),4),COMP)="SSN VERIFICATION STATUS" N SSNV S SSNV=$P($P(MSG,HL("FS"),6),COMP,2),ARRAY(.0907)=$S(SSNV="VERIFIED":4,SSNV="INVALID":2,1:"@")
.;**47 use SSN Verification status code and not words since they have changed since this code was first written
.;only update values to valid or invalid other statuses aren't stored in VistA
.I $P(HL("SFN"),COMP)="200M",($P($P(MSG,HL("FS"),4),COMP)="SSN VERIFICATION STATUS") N SSNV S SSNV=$P($P(MSG,HL("FS"),6),COMP,1),ARRAY(.0907)=$S(SSNV=4:4,SSNV=2:2,1:"@")
.;
.;**63 Story 174247 (mko): Get Self-ID Gender
.I $P($P(MSG,HL("FS"),4),COMP)="SELF ID GENDER" S ARRAY(.024)=$$FREE^RGRSPARS($P($P(MSG,HL("FS"),6),COMP))
.;
.;**65 Story 323009 (ckn) : parse OBX for additional DOD fields
.I $P($P(MSG,HL("FS"),4),COMP)="DATE OF DEATH DATA" D
..N DODLEB,DODLUPD
..S ARRAY("DODSource")=$$FREE^RGRSPARS($P($P(MSG,HL("FS"),6),COMP)),ARRAY(.353)=ARRAY("DODSource")
..S DODLUPD=$$FMDATE^HLFNC($P(MSG,HL("FS"),15))
..S ARRAY("DODLastUpdated")=$$FREE^RGRSPARS(DODLUPD),ARRAY(.354)=ARRAY("DODLastUpdated")
..S DODLEB=$$FREE^RGRSPARS($P(MSG,HL("FS"),17))
..I DODLEB'="",(DODLEB'=HL("Q")) D
...S ARRAY("DODEnteredBy")=$$FMNAME^XLFNAME($P(DODLEB,COMP,2,4),"L",COMP),ARRAY(.352)=ARRAY("DODEnteredBy")
...S ARRAY("DODLastEditedBy")=$P(DODLEB,COMP)_COMP_$P(DODLEB,COMP,13)_COMP_$P($P(DODLEB,COMP,9),SUBCOMP)_COMP_$P($P(DODLEB,COMP,14),SUBCOMP,2),ARRAY(.355)=ARRAY("DODLastEditedBy")
.;
.;I $P($P(MSG,HL("FS"),4),COMP)="DATE OF DEATH DOCUMENTS" S ARRAY("DODDocType")=$$FREE^RGRSPARS($P($P(MSG,HL("FS"),6),COMP)),ARRAY(.357)=ARRAY("DODDocType")
.;
.;**68 - Story 500735 (ckn) : Parse OBX to set a flag if deletion of
.;Date of Death occurred through TK OVR
.I $P($P(MSG,HL("FS"),4),COMP)="TK OVERRIDE DOD" S ARRAY("TKOVRDOD")=$P($P(MSG,HL("FS"),6),COMP)
.;
.;**76, VAMPI-11114 (dri) - add sexual orientation and sexual orientation description
.;**77, VAMPI-13755 (dri) - include status, date created, date last updated
.I $P($P(MSG,HL("FS"),4),COMP)="Sexual Orientation" D
..S ARRAY("SexOr",$O(ARRAY("SexOr",""),-1)+1)=$$FREE^RGRSPARS($P($P(MSG,HL("FS"),6),COMP))_"^"_$P(MSG,HL("FS"),12)_"^"_$$FMDATE^HLFNC($P(MSG,HL("FS"),15))_"^"_$$FMDATE^HLFNC($P(MSG,HL("FS"),13))
.I $P($P(MSG,HL("FS"),4),COMP)="Sexual Or Description" D
..S ARRAY("SexOrDes")=$P($P(MSG,HL("FS"),6),COMP,2) I ARRAY("SexOrDes")=HL("Q") S ARRAY("SexOrDes")="@" Q
..N MSGX S MSGX=0 F S MSGX=$O(MSG(MSGX)) Q:'MSGX S ARRAY("SexOrDes")=ARRAY("SexOrDes")_$P($P(MSG(MSGX),HL("FS"),1),COMP,1)
.;
.;**76, VAMPI-11118 (dri) - add pronoun and pronoun description
.I $P($P(MSG,HL("FS"),4),COMP)="Pronoun" S ARRAY("Pronoun",$O(ARRAY("Pronoun",""),-1)+1)=$$FREE^RGRSPARS($P($P(MSG,HL("FS"),6),COMP))
.I $P($P(MSG,HL("FS"),4),COMP)="Pronoun Description" D
..S ARRAY("PronounDes")=$P($P(MSG,HL("FS"),6),COMP,2) I ARRAY("PronounDes")=HL("Q") S ARRAY("PronounDes")="@" Q
..N MSGX S MSGX=0 F S MSGX=$O(MSG(MSGX)) Q:'MSGX S ARRAY("PronounDes")=ARRAY("PronounDes")_$P($P(MSG(MSGX),HL("FS"),1),COMP,1)
Q
;
ZPD ;;
I RGLOCAL S THLA("HLS",ENT)=$$EN1^VAFHLZPD(DFN,"1,17,21,34"),ENT=ENT+1 ;**45 to build new ZPD
I 'RGLOCAL S ARRAY(.0906)=$P(MSG,HL("FS"),35) I ARRAY(.0906)=HL("Q") S ARRAY(.0906)="@" ;**45 Pull out pseudo ssn reason
Q
;
ZSP ;;
I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1
I 'RGLOCAL S ARRAY(.301)=$$YESNO^RGRSPARS($P(MSG,HL("FS"),3)),ARRAY(.302)=$$FREE^RGRSPARS($P(MSG,HL("FS"),4)),ARRAY(.323)=$$POS^RGRSPARS($P(MSG,HL("FS"),5))
Q
;
ZEL ;;
I RGLOCAL D
.;**40 to rebuild ZEL segment
.I '$D(DFN) S THLA("HLS",ENT)=MSG,ENT=ENT+1 Q ;don't know DFN pass back original ZEL segment
.N VAFZEL D EN1^VAFHLZEL(DFN,"1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22",2,.VAFZEL) ;build a complete ZEL segment
.;need to take into account may be more than 1 array entry and that each entry could go over 245 so there would be another subscript
.N CNT,ZELX S (CNT,ZELX)=0 F S ZELX=$O(VAFZEL(ZELX)) Q:'ZELX D
..I CNT>0 S THLA("HLS",ENT,CNT)=VAFZEL(ZELX),CNT=CNT+1
..I CNT'>0 S THLA("HLS",ENT)=VAFZEL(ZELX),ENT=ENT+1
I 'RGLOCAL D
. S ARRAY(.361)=$$ELIG^RGRSPARS($P(MSG,HL("FS"),3)),ARRAY(.3612)=$$FREE^RGRSPARS($P(MSG,HL("FS"),12))
. S ARRAY(.3615)=$$FREE^RGRSPARS($P(MSG,HL("FS"),14)),ARRAY(391)=$$TYPE^RGRSPARS($P(MSG,HL("FS"),10)),ARRAY(1901)=$$VETERAN^RGRSPARS($P(MSG,HL("FS"),9))
Q
;
ZCT ;;
I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1
I 'RGLOCAL S ARRAY(.211)=$$FREE^RGRSPARS($P(MSG,HL("FS"),4)),ARRAY(.219)=$$FREE^RGRSPARS($P(MSG,HL("FS"),7))
Q
;
ZEM ;;
I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1
I 'RGLOCAL S ARRAY(.31115)=$$EMP^RGRSPARS($P(MSG,HL("FS"),4))
Q
;
ZFF ;;
I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1
I 'RGLOCAL S ARRAY("FLD")=$P(MSG,HL("FS"),3)
Q
;
PROCIN ;
D PROCIN^RGADTP2(.ARRAY,.RGLOCAL,.RGER,.DFN,.HL)
Q
;
GENACK ;
N RGCNT,IEN,RG,ERRSEG
I $G(ARRAY("DFN"))'>0 S RGER="-1^Unknown ICN#"_$G(ARRAY("ICN"))_" and SSN#"_$G(ARRAY(.09))
;**65 - Story 323009 - (ckn) : If DOD did not get updated due to
;imprecise date OR invalid value, create ERR segment
E I HL("ETN")="A31",RGSITE="200M" D
. I $G(DODIMPF) S RGER="-1^IMPRECISE DOD - "_$$HLDATE^HLFNC($P(DODIMPF,"^",2))
. S ERRSEG=$$NAMEERR^VAFCSB(ARRAY("DFN")) ;**61,MVI_3976 (mko): Get Name Components
;E I HL("ETN")="A31",RGSITE="200M" S ERRSEG=$$NAMEERR^VAFCSB(ARRAY("DFN")) ;**61,MVI_3976 (mko): Get Name Components
;send mas parameter 'process mvi dod update?' in 'aa' segment ;**65 - STORY_339759 (dri)
S RGCNT=1,HLA("HLA",RGCNT)="MSA"_HL("FS")_"AA"_HL("FS")_HL("MID")_HL("FS")_$S(+$G(RGER)<0:$P(RGER,"^",2,3),1:(+$$CHK^VAFCDODA_"-"_$$GET1^DID(43,1401,,"LABEL"))),RGCNT=RGCNT+1
S:$G(ERRSEG)]"" HLA("HLA",RGCNT)=ERRSEG,RGCNT=RGCNT+1 ;**61,MVI_3976 (mko): Put name component in ERR segment
S RGSITE=$$LKUP^XUAF4(RGSITE)
;**74 - Story - 1260465 (ckn) - Include 200M in HLL links for HAC
D LINK^HLUTIL3(RGSITE,.RG) S IEN=$O(RG(0)) S HLL("LINKS",1)="^"_RG(IEN)_$S($P($$SITE^VASITE(),"^",3)=741:"^200M",1:"")
D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.HLRESLTA,"",.HL)
K HLA,DODIMPF
Q
;
RSP ;
Q
;
OLD() ; Return OBX segment to flag a record as "old"
;**59,MVI_914: New subroutine
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:"")
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGADTP 16947 printed Apr 09, 2024@20:47:52 Page 2
RGADTP ;BIR/DLR-ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS ;2/18/22 10:22
+1 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**26,27,20,34,35,40,45,44,47,59,60,61,62,63,65,68,69,70,74,76,77**;30 Apr 99;Build 3
+2 ;
+3 ;Reference to BLDEVN^VAFCQRY and BLDPID^VAFCQRY supported by IA #3630
+4 ;Reference to EN1^VAFHLZEL is supported by IA #752
+5 ;Reference to Patient file (#2) PREFERRED FACILITY (#27.02) is supported by IA #1850
+6 ;Reference to $$PV2, $$PHARA, $$LABE, $$RADE ^VAFCSB is supported by IA #4921
+7 ;
INIT ;
+1 NEW RGER,RGSITE,ARRAY,MSH,RGLOCAL,RGEVNT,REP,DIC,DR,DIE,DA,DLAYGO
+2 SET RGER=""
+3 DO IN
+4 DO PROCIN
+5 DO GENACK
+6 QUIT
+7 ;
PROC ;processing entry point
+1 NEW HLA,RGADT,PV1,DIC,ARRAY,RGEVNT,RGLOCAL,REP,ICN,RGSITE
+2 SET RGEVNT=HL("ETN")
+3 IF $GET(HL("MID"))'=""
SET RGADT=HL("MID")
+4 IF $GET(HL("MID"))=""
SET RGADT=999
+5 DO IN
+6 SET ICN=$GET(ARRAY("ICN"))
+7 ;quit if no ICN
IF +$GET(ICN)<1
QUIT
+8 ;quit if ICN is a local
IF $EXTRACT($GET(ICN),1,3)=$PIECE($$SITE^VASITE,"^",3)
QUIT
+9 SET ZTSAVE("DFN")=""
SET ZTSAVE("RGEVNT")=""
SET ZTSAVE("HLA(""HLS"",")=""
SET ZTRTN="SEND^RGADTPC"
SET ZTDESC="Sending HL7 Patient Update..."
SET ZTIO="RG QUEUE"
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
+10 KILL ZTSAVE,ZTRTN,ZTDESC,ZTIO,ZTDTH
+11 QUIT
+12 ;
IN ;Process in the ADT A04/A08 (routing logic)
+1 NEW RGI,MSG,RG,SG,DFN,EVN,SITE,RGC,RGJ,DIC,PV1,PID,COMP,ENT,EN,THLA,LAB,RAD,PHARM,TMP,SIG,OBXDONE,OLD,NAMECOMP,DODF,DODD,DODNP,DODDISDT,DODOPT,SECLVL,SEXOR,SEXORD,PRON,PROND
+2 SET ENT=1
SET REP=$EXTRACT(HL("ECH"),2)
SET COMP=$EXTRACT(HL("ECH"),1)
+3 ;set local flag to indicate the processing of an outbound for reformatting
+4 IF $PIECE($GET(HL("SAF")),COMP)=$PIECE($$SITE^VASITE,"^",3)
SET RGLOCAL=1
+5 IF $PIECE($GET(HL("SAF")),COMP)'=$PIECE($$SITE^VASITE,"^",3)
SET RGLOCAL=0
+6 SET RGC=$EXTRACT($GET(HL("ECH")),1)
+7 FOR RGI=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
SET MSG=HLNODE
SET SG=$EXTRACT(HLNODE,1,3)
Begin DoDot:1
+8 SET RGJ=0
FOR
SET RGJ=$ORDER(HLNODE(RGJ))
if 'RGJ
QUIT
SET MSG(RGJ)=HLNODE(RGJ)
+9 if SG?2A1(1A,1N)
DO PICK
+10 KILL MSG
End DoDot:1
+11 ;if message MSH sending facility matches the PID assigning authority update
+12 SET ENT=0
SET EN=1
SET OBXDONE=0
FOR
SET ENT=$ORDER(THLA("HLS",ENT))
if ENT=""
QUIT
Begin DoDot:1
+13 ;**61, MVI_3714 (ckn) - No need to send OBX segment previously built in 2.3v to MPI - Only add new OBX for 2.4v
+14 IF $EXTRACT($GET(THLA("HLS",ENT)),1,3)="OBX"
Begin DoDot:2
+15 ;**61 - MVI_3714 (ckn) - OBX was added in previous loop
IF OBXDONE
QUIT
+16 SET RAD=$$RADE
IF RAD'=""
SET HLA("HLS",EN)=RAD
SET EN=EN+1
+17 SET LAB=$$LABE
IF LAB'=""
SET HLA("HLS",EN)=LAB
SET EN=EN+1
+18 SET PHARM=$$PHARA
IF PHARM'=""
SET HLA("HLS",EN)=PHARM
SET EN=EN+1
+19 ;**59,MVI_914: Pass OLDER RECORD in OBX if flagged as such
SET OLD=$$OLD
IF OLD'=""
SET HLA("HLS",EN)=OLD
SET EN=EN+1
+20 ;**61,MVI_3714: Add Self Identified Gender in OBX
SET SIG=$$SIG^VAFCSB(DFN)
IF SIG'=""
SET HLA("HLS",EN)=SIG
SET EN=EN+1
+21 ;**61,MVI_3976 (mko): Add Name Components in OBX
SET NAMECOMP=$$NAMEOBX^VAFCSB(DFN)
IF NAMECOMP'=""
SET HLA("HLS",EN)=NAMECOMP
SET EN=EN+1
+22 ;**62 MVI_4899 (ckn): Add DOD fields in OBX
SET DODF=$$DODF^VAFCSB(DFN)
IF $GET(DODF)'=""
SET HLA("HLS",EN)=DODF
SET EN=EN+1
+23 ;**65 Story 323009 (ckn) : OBX for additional DOD fields
+24 ;Date Of Death Documents
SET DODD=$$DODD^VAFCSB(DFN)
IF $GET(DODD)'=""
SET HLA("HLS",EN)=DODD
SET EN=EN+1
+25 ;Date Of Death Option Used
SET DODOPT=$$DODOPT^VAFCSB(DFN)
IF $GET(DODOPT)'=""
SET HLA("HLS",EN)=DODOPT
SET EN=EN+1
+26 ;**69 Story 603856 (ckn) - No more OBX for Notification Provider from VistA
+27 ;S DODNP=$$DODNTPRV^VAFCSB(DFN) I $G(DODNP)'="" S HLA("HLS",EN)=DODNP,EN=EN+1 ;Date Of Death Notify Provider
+28 ;**70 - Story 783361 (ckn) - Build OBX for Security Level
SET SECLVL=$$SECLOG^VAFCSB(DFN)
IF $GET(SECLVL)'=""
SET HLA("HLS",EN)=SECLVL
SET EN=EN+1
+29 ;**76, VAMPI-11114 (dri)
DO SEXOR^VAFCSB(DFN,.SEXOR)
IF $ORDER(SEXOR(0))
NEW CNT
SET CNT=0
FOR
SET CNT=$ORDER(SEXOR(CNT))
if 'CNT
QUIT
SET HLA("HLS",EN)=SEXOR(CNT)
SET EN=EN+1
+30 ;**76, VAMPI-11114 (dri)
DO SEXORD^VAFCSB(DFN,.SEXORD)
IF $ORDER(SEXORD(0))
Begin DoDot:3
+31 NEW CNT,LVL
+32 SET LVL=1
SET CNT=0
FOR
SET CNT=$ORDER(SEXORD(CNT))
if 'CNT
QUIT
Begin DoDot:4
+33 IF CNT=1
SET HLA("HLS",EN)=SEXORD(CNT)
+34 IF CNT>1
SET HLA("HLS",EN,LVL)=SEXORD(CNT)
SET LVL=LVL+1
End DoDot:4
End DoDot:3
SET EN=EN+1
+35 ;**76, VAMPI-11118 (dri)
DO PRON^VAFCSB(DFN,.PRON)
IF $ORDER(PRON(0))
NEW CNT
SET CNT=0
FOR
SET CNT=$ORDER(PRON(CNT))
if 'CNT
QUIT
SET HLA("HLS",EN)=PRON(CNT)
SET EN=EN+1
+36 ;**76, VAMPI-11118 (dri)
DO PROND^VAFCSB(DFN,.PROND)
IF $ORDER(PROND(0))
Begin DoDot:3
+37 NEW CNT,LVL
+38 SET LVL=1
SET CNT=0
FOR
SET CNT=$ORDER(PROND(CNT))
if 'CNT
QUIT
Begin DoDot:4
+39 IF CNT=1
SET HLA("HLS",EN)=PROND(CNT)
+40 IF CNT>1
SET HLA("HLS",EN,LVL)=PROND(CNT)
SET LVL=LVL+1
End DoDot:4
End DoDot:3
SET EN=EN+1
+41 ;**61 - MVI_3714 (ckn) - flag for all OBX added
SET OBXDONE=1
End DoDot:2
QUIT
+42 SET HLA("HLS",EN)=THLA("HLS",ENT)
SET EN=EN+1
+43 IF $EXTRACT($GET(THLA("HLS",ENT)),1,3)="PID"!($EXTRACT($GET(THLA("HLS",ENT)),1,3)="ZEL")
Begin DoDot:2
+44 ;**47 handle if ZEL is over 245 as well
+45 IF $ORDER(THLA("HLS",ENT,""))'=""
Begin DoDot:3
+46 SET CNT=""
FOR
SET CNT=$ORDER(THLA("HLS",ENT,CNT))
if CNT=""
QUIT
SET HLA("HLS",EN-1,CNT)=THLA("HLS",ENT,CNT)
End DoDot:3
End DoDot:2
+47 ;**47
IF $EXTRACT($GET(THLA("HLS",ENT)),1,3)="PV1"
IF RGLOCAL
SET TMP=$$PV2B
IF TMP'=""
SET HLA("HLS",EN)=$$PV2B
SET EN=EN+1
+48 ;**61 MVI_3714 (ckn) Add Self Identified Gender in OBX
+49 ;I $E($G(THLA("HLS",ENT)),1,3)="ZPD" I RGLOCAL D
+50 ;.S RAD=$$RADE I RAD'="" S HLA("HLS",EN)=RAD,EN=EN+1
+51 ;.S LAB=$$LABE I LAB'="" S HLA("HLS",EN)=LAB,EN=EN+1
+52 ;.S PHARM=$$PHARA I PHARM'="" S HLA("HLS",EN)=PHARM,EN=EN+1
+53 ;.S OLD=$$OLD I OLD'="" S HLA("HLS",EN)=OLD,EN=EN+1 ;**59,MVI_914: Pass OLDER RECORD in OBX if flagged as such
End DoDot:1
QUIT QUIT
+1 ;
ROUTE ;
+1 NEW RGERR
+2 IF $GET(RGEVNT)=""
SET RGEVNT=$GET(HL("ETN"))
+3 NEW MPI
SET MPI=$$MPILINK^MPIFAPI()
Begin DoDot:1
+4 ;**74 - Story - 1260465 (ckn) - Include 200M in HLL links for HAC
+5 IF $PIECE($GET(MPI),U)'=-1
SET HLL("LINKS",1)="RG ADT-"_HL("ETN")_" 2.4 CLIENT^"_MPI_$SELECT($PIECE($$SITE^VASITE(),"^",3)=741:"^200M",1:"")
+6 IF $PIECE($GET(MPI),U)=-1
Begin DoDot:2
+7 NEW RGLOG,RGMTXT
DO START^RGHLLOG(HLMTIEN,"","")
SET RGMTXT="for DFN#"_$GET(DFN)
+8 DO EXC^RGHLLOG(224,"No MPI link identified"_RGMTXT,$GET(DFN))
SET RGERR=1
End DoDot:2
End DoDot:1
+9 ;**60 MVI_1837(rjh): to catch undefined dfn
+10 ;I $G(RGERR)'=1 S ^XTMP("RG"_HL("ETN")_"%"_DFN,0)=$$FMADD^XLFDT(DT,5)_"^"_DT_"^"_"RG"_HL("ETN")_" msg to MPI for DFN "_DFN S ^XTMP("RG"_HL("ETN")_"%"_DFN,"MPI",0)="A"
+11 IF $GET(RGERR)'=1
IF $DATA(^DPT(+$GET(DFN),0))
Begin DoDot:1
+12 SET ^XTMP("RG"_HL("ETN")_"%"_DFN,0)=$$FMADD^XLFDT(DT,5)_"^"_DT_"^"_"RG"_HL("ETN")_" msg to MPI for DFN "_DFN
+13 SET ^XTMP("RG"_HL("ETN")_"%"_DFN,"MPI",0)="A"
End DoDot:1
+14 QUIT
+15 ;
RESP ;
+1 NEW RGER,RGSITE,ARRAY,MSH,RGLOCAL,RGEVNT,RGI,MSG,RG,SG,DFN,EVN,SITE,RGC,RGJ,DIC,PV1,PID
+2 DO IN
+3 QUIT
+4 ;
PICK ;check routine for segment entry point
+1 IF $TEXT(@SG)]""
DO @SG
+2 IF $TEXT(@SG)=""
QUIT
+3 QUIT
+4 ;
MSA ;process the MSA segment
+1 NEW ARRAY,CNT,DFN,EXIT,HLCOMP,RGAA,RGERR,RGEVNT,RGMSG,RETURN,RGX,RGY,RGCODE
+2 IF RGLOCAL
SET THLA("HLS",ENT)=MSG
SET ENT=ENT+1
+3 SET RGAA=MSG
SET EXIT=0
SET RGCODE=$PIECE(RGAA,HL("FS"),2)
SET RGMSG=$PIECE(RGAA,HL("FS"),3)
SET RGERR=$PIECE(RGAA,HL("FS"),4)
SET RGMSG=$$MSG^HLCSUTL(RGMSG,"RETURN(1)")
KILL RGMSG
+4 SET CNT=1
SET RGX=0
FOR
SET RGX=$ORDER(RETURN(1,RGX))
if 'RGX!(EXIT=1)
QUIT
Begin DoDot:1
+5 IF RETURN(1,RGX)'=""
Begin DoDot:2
+6 IF $DATA(RGMSG)
SET RGMSG(CNT)=RETURN(1,RGX)
SET CNT=CNT+1
+7 IF '$DATA(RGMSG)
SET RGMSG=RETURN(1,RGX)
SET RGY=RGX
End DoDot:2
+8 IF RETURN(1,RGX)=""
Begin DoDot:2
+9 IF $EXTRACT(RETURN(1,RGY),1,3)="MSH"
DO MSH
+10 IF $EXTRACT(RETURN(1,RGY),1,3)="PID"
DO PIDP^RGADTP1(.RGMSG,.ARRAY,.HL)
SET EXIT=1
End DoDot:2
SET CNT=1
KILL RGMSG
End DoDot:1
+11 SET DFN=$GET(ARRAY("DFN"))
+12 ;**45 Log Exception ONLY if AR is returned in MSA segment
+13 IF RGCODE="AR"
Begin DoDot:1
+14 DO START^RGHLLOG(HLMTIEN,"","")
+15 ;**44
DO EXC^RGHLLOG(234,RGERR,DFN)
+16 DO STOP^RGHLLOG(0)
End DoDot:1
+17 ;**59,MVI_914: Delete the old record designation
if $GET(DFN)>0
KILL ^XTMP("MPIF OLD RECORDS",DFN)
+18 IF $DATA(^XTMP("RG"_HL("ETN")_"%"_DFN,0))
KILL ^XTMP("RG"_HL("ETN")_"%"_DFN)
+19 QUIT
+20 ;
MSH ;
+1 SET MSH=1
+2 IF RGLOCAL
SET THLA("HLS",ENT)=MSG
SET ENT=ENT+1
+3 IF 'RGLOCAL
SET RGC=$EXTRACT(HL("ECH"),1)
+4 SET RGSITE=$PIECE($PIECE(MSG,HL("FS"),4),RGC)
SET RGEVNT=$PIECE($PIECE(MSG,HL("FS"),9),RGC,2)
+5 QUIT
+6 ;
PV2 ;processor of PV2 segment ;**47
+1 QUIT
+2 ;
PV2B() ;builder of PV2 segment ;**47
+1 NEW RET
SET RET=""
+2 IF 'RGLOCAL
QUIT RET
+3 NEW X
SET X="VAFCSB"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT RET
+4 ;**45 VAFCSB coming in with DG*5.3*707
+5 QUIT $$PV2^VAFCSB
+6 ;
PHARA() ;build obx to show active prescriptions
+1 NEW RET
SET RET=""
+2 IF 'RGLOCAL
QUIT RET
+3 IF '$$PATCH^XPDUTL("PSS*1.0*101")
QUIT RET
+4 NEW X
SET X="VAFCSB"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT RET
+5 ;**45 VAFCSB coming in with DG*5.3*707
+6 QUIT $$PHARA^VAFCSB
+7 ;
LABE() ;BUILD OBX FOR LAST LAB TEST DATE
+1 NEW RET
SET RET=""
+2 IF 'RGLOCAL
QUIT RET
+3 IF '$$PATCH^XPDUTL("LR*5.2*295")
QUIT RET
+4 NEW X
SET X="VAFCSB"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT RET
+5 ;**45 VAFCSB coming in with DG*5.3*707
+6 QUIT $$LABE^VAFCSB
+7 ;
RADE() ;BUILD OBX FOR LAST RADIOLOGY TEST DATE
+1 NEW RET
SET RET=""
+2 IF 'RGLOCAL
QUIT RET
+3 IF '$$PATCH^XPDUTL("RA*5.0*76")
QUIT RET
+4 NEW X
SET X="VAFCSB"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT RET
+5 ;**45 VAFCSB coming in with DG*5.3*707
+6 QUIT $$RADE^VAFCSB
+7 ;
EVN ;;
+1 NEW CNT,ERR
SET EVN=RGI
+2 IF RGLOCAL
SET (EVN(1),THLA("HLS",ENT))=MSG
SET ENT=ENT+1
+3 IF 'RGLOCAL
Begin DoDot:1
+4 SET ARRAY("EVR")=$PIECE(MSG,HL("FS"),2)
SET ARRAY("DLT")=$$FMDATE^HLFNC($PIECE(MSG,HL("FS"),3))
+5 SET ARRAY("EVNAME")=$$FMNAME^XLFNAME($PIECE(MSG,HL("FS"),2),"",$EXTRACT(HL("ECH"),1))
SET ARRAY("SENDING SITE")=$PIECE(MSG,HL("FS"),8)
End DoDot:1
+6 QUIT
+7 ;
EVNP ;
+1 NEW EVNX
+2 IF $GET(DFN)'=""
DO BLDEVN^VAFCQRY(DFN,"1,2,4,5,6,7",.EVN,.HL,$GET(HL("ETN")),.ERR)
SET CNT=0
SET EVNX=0
FOR
SET EVNX=$ORDER(EVN(EVNX))
if 'EVNX
QUIT
Begin DoDot:1
+3 IF CNT>0
SET THLA("HLS",EVN,CNT)=EVN(EVNX)
SET CNT=CNT+1
+4 IF CNT'>0
SET THLA("HLS",EVN)=EVN(EVNX)
SET CNT=CNT+1
End DoDot:1
+5 QUIT
+6 ;
PID ;;
+1 NEW CNT,PIDX
+2 IF RGLOCAL
Begin DoDot:1
+3 ;**45 REMOVED +
NEW HLCOMP
SET HLCOMP=$EXTRACT(HL("ECH"),1)
SET THLA("HLS",ENT)=MSG
SET DFN=$PIECE($PIECE(MSG,HL("FS"),4),HLCOMP)
+4 DO EVNP
+5 DO BLDPID^VAFCQRY(DFN,1,"ALL",.PID,.HL)
+6 ;get ICN value in the PID segment
+7 SET ARRAY("ICN")=+$PIECE($PIECE(PID(1),HL("FS"),4),HLCOMP)
+8 SET CNT=0
SET PIDX=0
FOR
SET PIDX=$ORDER(PID(PIDX))
if 'PIDX
QUIT
Begin DoDot:2
+9 IF CNT>0
SET THLA("HLS",ENT,CNT)=PID(PIDX)
SET CNT=CNT+1
+10 IF CNT'>0
SET THLA("HLS",ENT)=PID(PIDX)
SET CNT=CNT+1
End DoDot:2
+11 SET ENT=ENT+1
End DoDot:1
+12 IF 'RGLOCAL
DO PIDP^RGADTP1(.MSG,.ARRAY,.HL)
+13 QUIT
+14 ;
PD1 ;SET PD1 SEQ 3 TO BE PREFERRED FACILITY INSTEAD OF CMOR PATCH **45
+1 NEW PD1
+2 IF RGLOCAL
Begin DoDot:1
+3 ;S PD1=$$PD1^VAFCSB
+4 ;I PD1'="" S THLA("HLS",ENT)=PD1,ENT=ENT+1
End DoDot:1
+5 ;PUTTING BACK TO DO NEED FOR PATCH 40 ON MPI SIDE
IF 'RGLOCAL
SET (ARRAY(991.03),ARRAY("CMOR"))=$PIECE($PIECE(MSG,HL("FS"),4),RGC)
+6 ;- NO LONGER DEALING WITH CMOR
+7 QUIT
+8 ;
PV1 ;;
+1 IF RGLOCAL
SET THLA("HLS",ENT)=MSG
SET ENT=ENT+1
+2 QUIT
+3 ;
OBX ;;
+1 NEW COMP,SUBCOMP
+2 SET COMP=$EXTRACT(HL("ECH"),1)
SET SUBCOMP=$EXTRACT(HL("ECH"),4)
+3 ;
+4 IF RGLOCAL
Begin DoDot:1
+5 SET THLA("HLS",ENT)=MSG
+6 NEW CNT,MSGX
SET CNT=1
SET MSGX=0
FOR
SET MSGX=$ORDER(MSG(MSGX))
if 'MSGX
QUIT
SET THLA("HLS",ENT,CNT)=MSG(MSGX)
SET CNT=CNT+1
+7 SET ENT=ENT+1
End DoDot:1
+8 ;
+9 IF 'RGLOCAL
Begin DoDot:1
+10 IF $$FREE^RGRSPARS($PIECE($PIECE(MSG,HL("FS"),4),COMP,2))="SECURITY LEVEL"
Begin DoDot:2
+11 SET ARRAY("SENSITIVITY")=$$SENSTIVE^RGRSPARS($PIECE(MSG,HL("FS"),6),COMP)
SET ARRAY("SENSITIVITY DATE")=$$FREE^RGRSPARS($$FMDATE^HLFNC($PIECE(MSG,HL("FS"),15)))
+12 SET ARRAY("SENSITIVITY USER")=$$FREE^RGRSPARS($PIECE($PIECE(MSG,HL("FS"),17),COMP,2))_","_$$FREE^RGRSPARS($PIECE($PIECE(MSG,HL("FS"),17),COMP,3))
End DoDot:2
+13 ;
+14 ;**45 Get SSN VERIFICATION STATUS out of OBX if message is from the MPI
+15 ;I $P(HL("SFN"),COMP)="200M" I $P($P(MSG,HL("FS"),4),COMP)="SSN VERIFICATION STATUS" N SSNV S SSNV=$P($P(MSG,HL("FS"),6),COMP,2),ARRAY(.0907)=$S(SSNV="VERIFIED":4,SSNV="INVALID":2,1:"@")
+16 ;**47 use SSN Verification status code and not words since they have changed since this code was first written
+17 ;only update values to valid or invalid other statuses aren't stored in VistA
+18 IF $PIECE(HL("SFN"),COMP)="200M"
IF ($PIECE($PIECE(MSG,HL("FS"),4),COMP)="SSN VERIFICATION STATUS")
NEW SSNV
SET SSNV=$PIECE($PIECE(MSG,HL("FS"),6),COMP,1)
SET ARRAY(.0907)=$SELECT(SSNV=4:4,SSNV=2:2,1:"@")
+19 ;
+20 ;**63 Story 174247 (mko): Get Self-ID Gender
+21 IF $PIECE($PIECE(MSG,HL("FS"),4),COMP)="SELF ID GENDER"
SET ARRAY(.024)=$$FREE^RGRSPARS($PIECE($PIECE(MSG,HL("FS"),6),COMP))
+22 ;
+23 ;**65 Story 323009 (ckn) : parse OBX for additional DOD fields
+24 IF $PIECE($PIECE(MSG,HL("FS"),4),COMP)="DATE OF DEATH DATA"
Begin DoDot:2
+25 NEW DODLEB,DODLUPD
+26 SET ARRAY("DODSource")=$$FREE^RGRSPARS($PIECE($PIECE(MSG,HL("FS"),6),COMP))
SET ARRAY(.353)=ARRAY("DODSource")
+27 SET DODLUPD=$$FMDATE^HLFNC($PIECE(MSG,HL("FS"),15))
+28 SET ARRAY("DODLastUpdated")=$$FREE^RGRSPARS(DODLUPD)
SET ARRAY(.354)=ARRAY("DODLastUpdated")
+29 SET DODLEB=$$FREE^RGRSPARS($PIECE(MSG,HL("FS"),17))
+30 IF DODLEB'=""
IF (DODLEB'=HL("Q"))
Begin DoDot:3
+31 SET ARRAY("DODEnteredBy")=$$FMNAME^XLFNAME($PIECE(DODLEB,COMP,2,4),"L",COMP)
SET ARRAY(.352)=ARRAY("DODEnteredBy")
+32 SET ARRAY("DODLastEditedBy")=$PIECE(DODLEB,COMP)_COMP_$PIECE(DODLEB,COMP,13)_COMP_$PIECE($PIECE(DODLEB,COMP,9),SUBCOMP)_COMP_$PIECE($PIECE(DODLEB,COMP,14),SUBCOMP,2)
SET ARRAY(.355)=ARRAY("DODLastEditedBy")
End DoDot:3
End DoDot:2
+33 ;
+34 ;I $P($P(MSG,HL("FS"),4),COMP)="DATE OF DEATH DOCUMENTS" S ARRAY("DODDocType")=$$FREE^RGRSPARS($P($P(MSG,HL("FS"),6),COMP)),ARRAY(.357)=ARRAY("DODDocType")
+35 ;
+36 ;**68 - Story 500735 (ckn) : Parse OBX to set a flag if deletion of
+37 ;Date of Death occurred through TK OVR
+38 IF $PIECE($PIECE(MSG,HL("FS"),4),COMP)="TK OVERRIDE DOD"
SET ARRAY("TKOVRDOD")=$PIECE($PIECE(MSG,HL("FS"),6),COMP)
+39 ;
+40 ;**76, VAMPI-11114 (dri) - add sexual orientation and sexual orientation description
+41 ;**77, VAMPI-13755 (dri) - include status, date created, date last updated
+42 IF $PIECE($PIECE(MSG,HL("FS"),4),COMP)="Sexual Orientation"
Begin DoDot:2
+43 SET ARRAY("SexOr",$ORDER(ARRAY("SexOr",""),-1)+1)=$$FREE^RGRSPARS($PIECE($PIECE(MSG,HL("FS"),6),COMP))_"^"_$PIECE(MSG,HL("FS"),12)_"^"_$$FMDATE^HLFNC($PIECE(MSG,HL("FS"),15))_"^"_$$FMDATE^HLFNC($PIECE(MSG,HL("FS"),13))
End DoDot:2
+44 IF $PIECE($PIECE(MSG,HL("FS"),4),COMP)="Sexual Or Description"
Begin DoDot:2
+45 SET ARRAY("SexOrDes")=$PIECE($PIECE(MSG,HL("FS"),6),COMP,2)
IF ARRAY("SexOrDes")=HL("Q")
SET ARRAY("SexOrDes")="@"
QUIT
+46 NEW MSGX
SET MSGX=0
FOR
SET MSGX=$ORDER(MSG(MSGX))
if 'MSGX
QUIT
SET ARRAY("SexOrDes")=ARRAY("SexOrDes")_$PIECE($PIECE(MSG(MSGX),HL("FS"),1),COMP,1)
End DoDot:2
+47 ;
+48 ;**76, VAMPI-11118 (dri) - add pronoun and pronoun description
+49 IF $PIECE($PIECE(MSG,HL("FS"),4),COMP)="Pronoun"
SET ARRAY("Pronoun",$ORDER(ARRAY("Pronoun",""),-1)+1)=$$FREE^RGRSPARS($PIECE($PIECE(MSG,HL("FS"),6),COMP))
+50 IF $PIECE($PIECE(MSG,HL("FS"),4),COMP)="Pronoun Description"
Begin DoDot:2
+51 SET ARRAY("PronounDes")=$PIECE($PIECE(MSG,HL("FS"),6),COMP,2)
IF ARRAY("PronounDes")=HL("Q")
SET ARRAY("PronounDes")="@"
QUIT
+52 NEW MSGX
SET MSGX=0
FOR
SET MSGX=$ORDER(MSG(MSGX))
if 'MSGX
QUIT
SET ARRAY("PronounDes")=ARRAY("PronounDes")_$PIECE($PIECE(MSG(MSGX),HL("FS"),1),COMP,1)
End DoDot:2
End DoDot:1
+53 QUIT
+54 ;
ZPD ;;
+1 ;**45 to build new ZPD
IF RGLOCAL
SET THLA("HLS",ENT)=$$EN1^VAFHLZPD(DFN,"1,17,21,34")
SET ENT=ENT+1
+2 ;**45 Pull out pseudo ssn reason
IF 'RGLOCAL
SET ARRAY(.0906)=$PIECE(MSG,HL("FS"),35)
IF ARRAY(.0906)=HL("Q")
SET ARRAY(.0906)="@"
+3 QUIT
+4 ;
ZSP ;;
+1 IF RGLOCAL
SET THLA("HLS",ENT)=MSG
SET ENT=ENT+1
+2 IF 'RGLOCAL
SET ARRAY(.301)=$$YESNO^RGRSPARS($PIECE(MSG,HL("FS"),3))
SET ARRAY(.302)=$$FREE^RGRSPARS($PIECE(MSG,HL("FS"),4))
SET ARRAY(.323)=$$POS^RGRSPARS($PIECE(MSG,HL("FS"),5))
+3 QUIT
+4 ;
ZEL ;;
+1 IF RGLOCAL
Begin DoDot:1
+2 ;**40 to rebuild ZEL segment
+3 ;don't know DFN pass back original ZEL segment
IF '$DATA(DFN)
SET THLA("HLS",ENT)=MSG
SET ENT=ENT+1
QUIT
+4 ;build a complete ZEL segment
NEW VAFZEL
DO EN1^VAFHLZEL(DFN,"1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22",2,.VAFZEL)
+5 ;need to take into account may be more than 1 array entry and that each entry could go over 245 so there would be another subscript
+6 NEW CNT,ZELX
SET (CNT,ZELX)=0
FOR
SET ZELX=$ORDER(VAFZEL(ZELX))
if 'ZELX
QUIT
Begin DoDot:2
+7 IF CNT>0
SET THLA("HLS",ENT,CNT)=VAFZEL(ZELX)
SET CNT=CNT+1
+8 IF CNT'>0
SET THLA("HLS",ENT)=VAFZEL(ZELX)
SET ENT=ENT+1
End DoDot:2
End DoDot:1
+9 IF 'RGLOCAL
Begin DoDot:1
+10 SET ARRAY(.361)=$$ELIG^RGRSPARS($PIECE(MSG,HL("FS"),3))
SET ARRAY(.3612)=$$FREE^RGRSPARS($PIECE(MSG,HL("FS"),12))
+11 SET ARRAY(.3615)=$$FREE^RGRSPARS($PIECE(MSG,HL("FS"),14))
SET ARRAY(391)=$$TYPE^RGRSPARS($PIECE(MSG,HL("FS"),10))
SET ARRAY(1901)=$$VETERAN^RGRSPARS($PIECE(MSG,HL("FS"),9))
End DoDot:1
+12 QUIT
+13 ;
ZCT ;;
+1 IF RGLOCAL
SET THLA("HLS",ENT)=MSG
SET ENT=ENT+1
+2 IF 'RGLOCAL
SET ARRAY(.211)=$$FREE^RGRSPARS($PIECE(MSG,HL("FS"),4))
SET ARRAY(.219)=$$FREE^RGRSPARS($PIECE(MSG,HL("FS"),7))
+3 QUIT
+4 ;
ZEM ;;
+1 IF RGLOCAL
SET THLA("HLS",ENT)=MSG
SET ENT=ENT+1
+2 IF 'RGLOCAL
SET ARRAY(.31115)=$$EMP^RGRSPARS($PIECE(MSG,HL("FS"),4))
+3 QUIT
+4 ;
ZFF ;;
+1 IF RGLOCAL
SET THLA("HLS",ENT)=MSG
SET ENT=ENT+1
+2 IF 'RGLOCAL
SET ARRAY("FLD")=$PIECE(MSG,HL("FS"),3)
+3 QUIT
+4 ;
PROCIN ;
+1 DO PROCIN^RGADTP2(.ARRAY,.RGLOCAL,.RGER,.DFN,.HL)
+2 QUIT
+3 ;
GENACK ;
+1 NEW RGCNT,IEN,RG,ERRSEG
+2 IF $GET(ARRAY("DFN"))'>0
SET RGER="-1^Unknown ICN#"_$GET(ARRAY("ICN"))_" and SSN#"_$GET(ARRAY(.09))
+3 ;**65 - Story 323009 - (ckn) : If DOD did not get updated due to
+4 ;imprecise date OR invalid value, create ERR segment
+5 IF '$TEST
IF HL("ETN")="A31"
IF RGSITE="200M"
Begin DoDot:1
+6 IF $GET(DODIMPF)
SET RGER="-1^IMPRECISE DOD - "_$$HLDATE^HLFNC($PIECE(DODIMPF,"^",2))
+7 ;**61,MVI_3976 (mko): Get Name Components
SET ERRSEG=$$NAMEERR^VAFCSB(ARRAY("DFN"))
End DoDot:1
+8 ;E I HL("ETN")="A31",RGSITE="200M" S ERRSEG=$$NAMEERR^VAFCSB(ARRAY("DFN")) ;**61,MVI_3976 (mko): Get Name Components
+9 ;send mas parameter 'process mvi dod update?' in 'aa' segment ;**65 - STORY_339759 (dri)
+10 SET RGCNT=1
SET HLA("HLA",RGCNT)="MSA"_HL("FS")_"AA"_HL("FS")_HL("MID")_HL("FS")_$SELECT(+$GET(RGER)<0:$PIECE(RGER,"^",2,3),1:(+$$CHK^VAFCDODA_"-"_$$GET1^DID(43,1401,,"LABEL")))
SET RGCNT=RGCNT+1
+11 ;**61,MVI_3976 (mko): Put name component in ERR segment
if $GET(ERRSEG)]""
SET HLA("HLA",RGCNT)=ERRSEG
SET RGCNT=RGCNT+1
+12 SET RGSITE=$$LKUP^XUAF4(RGSITE)
+13 ;**74 - Story - 1260465 (ckn) - Include 200M in HLL links for HAC
+14 DO LINK^HLUTIL3(RGSITE,.RG)
SET IEN=$ORDER(RG(0))
SET HLL("LINKS",1)="^"_RG(IEN)_$SELECT($PIECE($$SITE^VASITE(),"^",3)=741:"^200M",1:"")
+15 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.HLRESLTA,"",.HL)
+16 KILL HLA,DODIMPF
+17 QUIT
+18 ;
RSP ;
+1 QUIT
+2 ;
OLD() ; Return OBX segment to flag a record as "old"
+1 ;**59,MVI_914: New subroutine
+2 QUIT $SELECT($DATA(^XTMP("MPIF OLD RECORDS",DFN))#2:"OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"OLDER RECORD"_HL("FS")_HL("FS")_"Y",1:"")
+3 ;
