- 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 Jan 18, 2025@02:42:37 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 ;