Released RG*1*77 SEQ #75 Extracted from mail message **KIDS**:RG*1.0*77^ **INSTALL NAME** RG*1.0*77 "BLD",3762,0) RG*1.0*77^CLINICAL INFO RESOURCE NETWORK^0^3220505^y "BLD",3762,1,0) ^9.61A^3^3^3220427^^ "BLD",3762,1,1,0) MASTER VETERAN INDEX VISTA ENHANCEMENT - SEXUAL ORIENTATION UPDATES "BLD",3762,1,2,0) Refer to patch RG*1.0*77 in the FORUM Patch Module for a complete "BLD",3762,1,3,0) description. "BLD",3762,4,0) ^9.64PA^^ "BLD",3762,6) 3 "BLD",3762,6.3) 3 "BLD",3762,"KRN",0) ^9.67PA^1.5^25 "BLD",3762,"KRN",.4,0) .4 "BLD",3762,"KRN",.401,0) .401 "BLD",3762,"KRN",.402,0) .402 "BLD",3762,"KRN",.403,0) .403 "BLD",3762,"KRN",.5,0) .5 "BLD",3762,"KRN",.84,0) .84 "BLD",3762,"KRN",1.5,0) 1.5 "BLD",3762,"KRN",1.6,0) 1.6 "BLD",3762,"KRN",1.61,0) 1.61 "BLD",3762,"KRN",1.62,0) 1.62 "BLD",3762,"KRN",3.6,0) 3.6 "BLD",3762,"KRN",3.8,0) 3.8 "BLD",3762,"KRN",9.2,0) 9.2 "BLD",3762,"KRN",9.8,0) 9.8 "BLD",3762,"KRN",9.8,"NM",0) ^9.68A^2^2 "BLD",3762,"KRN",9.8,"NM",1,0) RGADTP^^0^B204647665 "BLD",3762,"KRN",9.8,"NM",2,0) RGADTP3^^0^B50146380 "BLD",3762,"KRN",9.8,"NM","B","RGADTP",1) "BLD",3762,"KRN",9.8,"NM","B","RGADTP3",2) "BLD",3762,"KRN",19,0) 19 "BLD",3762,"KRN",19.1,0) 19.1 "BLD",3762,"KRN",101,0) 101 "BLD",3762,"KRN",409.61,0) 409.61 "BLD",3762,"KRN",771,0) 771 "BLD",3762,"KRN",779.2,0) 779.2 "BLD",3762,"KRN",870,0) 870 "BLD",3762,"KRN",8989.51,0) 8989.51 "BLD",3762,"KRN",8989.52,0) 8989.52 "BLD",3762,"KRN",8993,0) 8993 "BLD",3762,"KRN",8994,0) 8994 "BLD",3762,"KRN","B",.4,.4) "BLD",3762,"KRN","B",.401,.401) "BLD",3762,"KRN","B",.402,.402) "BLD",3762,"KRN","B",.403,.403) "BLD",3762,"KRN","B",.5,.5) "BLD",3762,"KRN","B",.84,.84) "BLD",3762,"KRN","B",1.5,1.5) "BLD",3762,"KRN","B",1.6,1.6) "BLD",3762,"KRN","B",1.61,1.61) "BLD",3762,"KRN","B",1.62,1.62) "BLD",3762,"KRN","B",3.6,3.6) "BLD",3762,"KRN","B",3.8,3.8) "BLD",3762,"KRN","B",9.2,9.2) "BLD",3762,"KRN","B",9.8,9.8) "BLD",3762,"KRN","B",19,19) "BLD",3762,"KRN","B",19.1,19.1) "BLD",3762,"KRN","B",101,101) "BLD",3762,"KRN","B",409.61,409.61) "BLD",3762,"KRN","B",771,771) "BLD",3762,"KRN","B",779.2,779.2) "BLD",3762,"KRN","B",870,870) "BLD",3762,"KRN","B",8989.51,8989.51) "BLD",3762,"KRN","B",8989.52,8989.52) "BLD",3762,"KRN","B",8993,8993) "BLD",3762,"KRN","B",8994,8994) "BLD",3762,"QDEF") ^^^^NO^^^^NO^^YES "BLD",3762,"QUES",0) ^9.62^^ "BLD",3762,"REQB",0) ^9.611^2^2 "BLD",3762,"REQB",1,0) RG*1.0*76^2 "BLD",3762,"REQB",2,0) DG*5.3*1071^2 "BLD",3762,"REQB","B","DG*5.3*1071",2) "BLD",3762,"REQB","B","RG*1.0*76",1) "MBREQ") 0 "PKG",272,-1) 1^1 "PKG",272,0) CLINICAL INFO RESOURCE NETWORK^RG^CIRN "PKG",272,22,0) ^9.49I^1^1 "PKG",272,22,1,0) 1.0^2990430^2990601^12555 "PKG",272,22,1,"PAH",1,0) 77^3220505 "PKG",272,22,1,"PAH",1,1,0) ^^3^3^3220505 "PKG",272,22,1,"PAH",1,1,1,0) MASTER VETERAN INDEX VISTA ENHANCEMENT - SEXUAL ORIENTATION UPDATES "PKG",272,22,1,"PAH",1,1,2,0) Refer to patch RG*1.0*77 in the FORUM Patch Module for a complete "PKG",272,22,1,"PAH",1,1,3,0) description. "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 2 "RTN","RGADTP") 0^1^B204647665^B197081874 "RTN","RGADTP",1,0) RGADTP ;BIR/DLR-ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS ;2/18/22 10:22 "RTN","RGADTP",2,0) ;;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 "RTN","RGADTP",3,0) ; "RTN","RGADTP",4,0) ;Reference to BLDEVN^VAFCQRY and BLDPID^VAFCQRY supported by IA #3630 "RTN","RGADTP",5,0) ;Reference to EN1^VAFHLZEL is supported by IA #752 "RTN","RGADTP",6,0) ;Reference to Patient file (#2) PREFERRED FACILITY (#27.02) is supported by IA #1850 "RTN","RGADTP",7,0) ;Reference to $$PV2, $$PHARA, $$LABE, $$RADE ^VAFCSB is supported by IA #4921 "RTN","RGADTP",8,0) ; "RTN","RGADTP",9,0) INIT ; "RTN","RGADTP",10,0) N RGER,RGSITE,ARRAY,MSH,RGLOCAL,RGEVNT,REP,DIC,DR,DIE,DA,DLAYGO "RTN","RGADTP",11,0) S RGER="" "RTN","RGADTP",12,0) D IN "RTN","RGADTP",13,0) D PROCIN "RTN","RGADTP",14,0) D GENACK "RTN","RGADTP",15,0) Q "RTN","RGADTP",16,0) ; "RTN","RGADTP",17,0) PROC ;processing entry point "RTN","RGADTP",18,0) N HLA,RGADT,PV1,DIC,ARRAY,RGEVNT,RGLOCAL,REP,ICN,RGSITE "RTN","RGADTP",19,0) S RGEVNT=HL("ETN") "RTN","RGADTP",20,0) I $G(HL("MID"))'="" S RGADT=HL("MID") "RTN","RGADTP",21,0) I $G(HL("MID"))="" S RGADT=999 "RTN","RGADTP",22,0) D IN "RTN","RGADTP",23,0) S ICN=$G(ARRAY("ICN")) "RTN","RGADTP",24,0) I +$G(ICN)<1 Q ;quit if no ICN "RTN","RGADTP",25,0) I $E($G(ICN),1,3)=$P($$SITE^VASITE,"^",3) Q ;quit if ICN is a local "RTN","RGADTP",26,0) S ZTSAVE("DFN")="",ZTSAVE("RGEVNT")="",ZTSAVE("HLA(""HLS"",")="",ZTRTN="SEND^RGADTPC",ZTDESC="Sending HL7 Patient Update...",ZTIO="RG QUEUE",ZTDTH=$H D ^%ZTLOAD "RTN","RGADTP",27,0) K ZTSAVE,ZTRTN,ZTDESC,ZTIO,ZTDTH "RTN","RGADTP",28,0) Q "RTN","RGADTP",29,0) ; "RTN","RGADTP",30,0) IN ;Process in the ADT A04/A08 (routing logic) "RTN","RGADTP",31,0) 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 "RTN","RGADTP",32,0) S ENT=1,REP=$E(HL("ECH"),2),COMP=$E(HL("ECH"),1) "RTN","RGADTP",33,0) ;set local flag to indicate the processing of an outbound for reformatting "RTN","RGADTP",34,0) I $P($G(HL("SAF")),COMP)=$P($$SITE^VASITE,"^",3) S RGLOCAL=1 "RTN","RGADTP",35,0) I $P($G(HL("SAF")),COMP)'=$P($$SITE^VASITE,"^",3) S RGLOCAL=0 "RTN","RGADTP",36,0) S RGC=$E($G(HL("ECH")),1) "RTN","RGADTP",37,0) F RGI=1:1 X HLNEXT Q:HLQUIT'>0 S MSG=HLNODE,SG=$E(HLNODE,1,3) D "RTN","RGADTP",38,0) .S RGJ=0 F S RGJ=$O(HLNODE(RGJ)) Q:'RGJ S MSG(RGJ)=HLNODE(RGJ) "RTN","RGADTP",39,0) .D:SG?2A1(1A,1N) PICK "RTN","RGADTP",40,0) .K MSG "RTN","RGADTP",41,0) ;if message MSH sending facility matches the PID assigning authority update "RTN","RGADTP",42,0) S ENT=0,EN=1,OBXDONE=0 F S ENT=$O(THLA("HLS",ENT)) Q:ENT="" D "RTN","RGADTP",43,0) .;**61, MVI_3714 (ckn) - No need to send OBX segment previously built in 2.3v to MPI - Only add new OBX for 2.4v "RTN","RGADTP",44,0) .I $E($G(THLA("HLS",ENT)),1,3)="OBX" D Q "RTN","RGADTP",45,0) ..I OBXDONE Q ;**61 - MVI_3714 (ckn) - OBX was added in previous loop "RTN","RGADTP",46,0) ..S RAD=$$RADE I RAD'="" S HLA("HLS",EN)=RAD,EN=EN+1 "RTN","RGADTP",47,0) ..S LAB=$$LABE I LAB'="" S HLA("HLS",EN)=LAB,EN=EN+1 "RTN","RGADTP",48,0) ..S PHARM=$$PHARA I PHARM'="" S HLA("HLS",EN)=PHARM,EN=EN+1 "RTN","RGADTP",49,0) ..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 "RTN","RGADTP",50,0) ..S SIG=$$SIG^VAFCSB(DFN) I SIG'="" S HLA("HLS",EN)=SIG,EN=EN+1 ;**61,MVI_3714: Add Self Identified Gender in OBX "RTN","RGADTP",51,0) ..S NAMECOMP=$$NAMEOBX^VAFCSB(DFN) I NAMECOMP'="" S HLA("HLS",EN)=NAMECOMP,EN=EN+1 ;**61,MVI_3976 (mko): Add Name Components in OBX "RTN","RGADTP",52,0) ..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 "RTN","RGADTP",53,0) ..;**65 Story 323009 (ckn) : OBX for additional DOD fields "RTN","RGADTP",54,0) ..S DODD=$$DODD^VAFCSB(DFN) I $G(DODD)'="" S HLA("HLS",EN)=DODD,EN=EN+1 ;Date Of Death Documents "RTN","RGADTP",55,0) ..S DODOPT=$$DODOPT^VAFCSB(DFN) I $G(DODOPT)'="" S HLA("HLS",EN)=DODOPT,EN=EN+1 ;Date Of Death Option Used "RTN","RGADTP",56,0) ..;**69 Story 603856 (ckn) - No more OBX for Notification Provider from VistA "RTN","RGADTP",57,0) ..;S DODNP=$$DODNTPRV^VAFCSB(DFN) I $G(DODNP)'="" S HLA("HLS",EN)=DODNP,EN=EN+1 ;Date Of Death Notify Provider "RTN","RGADTP",58,0) ..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 "RTN","RGADTP",59,0) ..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) "RTN","RGADTP",60,0) ..D SEXORD^VAFCSB(DFN,.SEXORD) I $O(SEXORD(0)) D S EN=EN+1 ;**76, VAMPI-11114 (dri) "RTN","RGADTP",61,0) ...N CNT,LVL "RTN","RGADTP",62,0) ...S LVL=1,CNT=0 F S CNT=$O(SEXORD(CNT)) Q:'CNT D "RTN","RGADTP",63,0) ....I CNT=1 S HLA("HLS",EN)=SEXORD(CNT) "RTN","RGADTP",64,0) ....I CNT>1 S HLA("HLS",EN,LVL)=SEXORD(CNT),LVL=LVL+1 "RTN","RGADTP",65,0) ..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) "RTN","RGADTP",66,0) ..D PROND^VAFCSB(DFN,.PROND) I $O(PROND(0)) D S EN=EN+1 ;**76, VAMPI-11118 (dri) "RTN","RGADTP",67,0) ...N CNT,LVL "RTN","RGADTP",68,0) ...S LVL=1,CNT=0 F S CNT=$O(PROND(CNT)) Q:'CNT D "RTN","RGADTP",69,0) ....I CNT=1 S HLA("HLS",EN)=PROND(CNT) "RTN","RGADTP",70,0) ....I CNT>1 S HLA("HLS",EN,LVL)=PROND(CNT),LVL=LVL+1 "RTN","RGADTP",71,0) ..S OBXDONE=1 ;**61 - MVI_3714 (ckn) - flag for all OBX added "RTN","RGADTP",72,0) .S HLA("HLS",EN)=THLA("HLS",ENT),EN=EN+1 "RTN","RGADTP",73,0) .I $E($G(THLA("HLS",ENT)),1,3)="PID"!($E($G(THLA("HLS",ENT)),1,3)="ZEL") D "RTN","RGADTP",74,0) ..;**47 handle if ZEL is over 245 as well "RTN","RGADTP",75,0) ..I $O(THLA("HLS",ENT,""))'="" D "RTN","RGADTP",76,0) ...S CNT="" F S CNT=$O(THLA("HLS",ENT,CNT)) Q:CNT="" S HLA("HLS",EN-1,CNT)=THLA("HLS",ENT,CNT) "RTN","RGADTP",77,0) .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 "RTN","RGADTP",78,0) .;**61 MVI_3714 (ckn) Add Self Identified Gender in OBX "RTN","RGADTP",79,0) .;I $E($G(THLA("HLS",ENT)),1,3)="ZPD" I RGLOCAL D "RTN","RGADTP",80,0) .;.S RAD=$$RADE I RAD'="" S HLA("HLS",EN)=RAD,EN=EN+1 "RTN","RGADTP",81,0) .;.S LAB=$$LABE I LAB'="" S HLA("HLS",EN)=LAB,EN=EN+1 "RTN","RGADTP",82,0) .;.S PHARM=$$PHARA I PHARM'="" S HLA("HLS",EN)=PHARM,EN=EN+1 "RTN","RGADTP",83,0) .;.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 "RTN","RGADTP",84,0) QUIT Q "RTN","RGADTP",85,0) ; "RTN","RGADTP",86,0) ROUTE ; "RTN","RGADTP",87,0) N RGERR "RTN","RGADTP",88,0) I $G(RGEVNT)="" S RGEVNT=$G(HL("ETN")) "RTN","RGADTP",89,0) N MPI S MPI=$$MPILINK^MPIFAPI() D "RTN","RGADTP",90,0) .;**74 - Story - 1260465 (ckn) - Include 200M in HLL links for HAC "RTN","RGADTP",91,0) .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:"") "RTN","RGADTP",92,0) .I $P($G(MPI),U)=-1 D "RTN","RGADTP",93,0) ..N RGLOG,RGMTXT D START^RGHLLOG(HLMTIEN,"","") S RGMTXT="for DFN#"_$G(DFN) "RTN","RGADTP",94,0) ..D EXC^RGHLLOG(224,"No MPI link identified"_RGMTXT,$G(DFN)) S RGERR=1 "RTN","RGADTP",95,0) ;**60 MVI_1837(rjh): to catch undefined dfn "RTN","RGADTP",96,0) ;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" "RTN","RGADTP",97,0) I $G(RGERR)'=1,$D(^DPT(+$G(DFN),0)) D "RTN","RGADTP",98,0) .S ^XTMP("RG"_HL("ETN")_"%"_DFN,0)=$$FMADD^XLFDT(DT,5)_"^"_DT_"^"_"RG"_HL("ETN")_" msg to MPI for DFN "_DFN "RTN","RGADTP",99,0) .S ^XTMP("RG"_HL("ETN")_"%"_DFN,"MPI",0)="A" "RTN","RGADTP",100,0) Q "RTN","RGADTP",101,0) ; "RTN","RGADTP",102,0) RESP ; "RTN","RGADTP",103,0) N RGER,RGSITE,ARRAY,MSH,RGLOCAL,RGEVNT,RGI,MSG,RG,SG,DFN,EVN,SITE,RGC,RGJ,DIC,PV1,PID "RTN","RGADTP",104,0) D IN "RTN","RGADTP",105,0) Q "RTN","RGADTP",106,0) ; "RTN","RGADTP",107,0) PICK ;check routine for segment entry point "RTN","RGADTP",108,0) I $T(@SG)]"" D @SG "RTN","RGADTP",109,0) I $T(@SG)="" Q "RTN","RGADTP",110,0) Q "RTN","RGADTP",111,0) ; "RTN","RGADTP",112,0) MSA ;process the MSA segment "RTN","RGADTP",113,0) N ARRAY,CNT,DFN,EXIT,HLCOMP,RGAA,RGERR,RGEVNT,RGMSG,RETURN,RGX,RGY,RGCODE "RTN","RGADTP",114,0) I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1 "RTN","RGADTP",115,0) 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 "RTN","RGADTP",116,0) S CNT=1,RGX=0 F S RGX=$O(RETURN(1,RGX)) Q:'RGX!(EXIT=1) D "RTN","RGADTP",117,0) .I RETURN(1,RGX)'="" D "RTN","RGADTP",118,0) ..I $D(RGMSG) S RGMSG(CNT)=RETURN(1,RGX),CNT=CNT+1 "RTN","RGADTP",119,0) ..I '$D(RGMSG) S RGMSG=RETURN(1,RGX),RGY=RGX "RTN","RGADTP",120,0) .I RETURN(1,RGX)="" D S CNT=1 K RGMSG "RTN","RGADTP",121,0) ..I $E(RETURN(1,RGY),1,3)="MSH" D MSH "RTN","RGADTP",122,0) ..I $E(RETURN(1,RGY),1,3)="PID" D PIDP^RGADTP1(.RGMSG,.ARRAY,.HL) S EXIT=1 "RTN","RGADTP",123,0) S DFN=$G(ARRAY("DFN")) "RTN","RGADTP",124,0) ;**45 Log Exception ONLY if AR is returned in MSA segment "RTN","RGADTP",125,0) I RGCODE="AR" D "RTN","RGADTP",126,0) .D START^RGHLLOG(HLMTIEN,"","") "RTN","RGADTP",127,0) .D EXC^RGHLLOG(234,RGERR,DFN) ;**44 "RTN","RGADTP",128,0) .D STOP^RGHLLOG(0) "RTN","RGADTP",129,0) K:$G(DFN)>0 ^XTMP("MPIF OLD RECORDS",DFN) ;**59,MVI_914: Delete the old record designation "RTN","RGADTP",130,0) I $D(^XTMP("RG"_HL("ETN")_"%"_DFN,0)) K ^XTMP("RG"_HL("ETN")_"%"_DFN) "RTN","RGADTP",131,0) Q "RTN","RGADTP",132,0) ; "RTN","RGADTP",133,0) MSH ; "RTN","RGADTP",134,0) S MSH=1 "RTN","RGADTP",135,0) I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1 "RTN","RGADTP",136,0) I 'RGLOCAL S RGC=$E(HL("ECH"),1) "RTN","RGADTP",137,0) S RGSITE=$P($P(MSG,HL("FS"),4),RGC),RGEVNT=$P($P(MSG,HL("FS"),9),RGC,2) "RTN","RGADTP",138,0) Q "RTN","RGADTP",139,0) ; "RTN","RGADTP",140,0) PV2 ;processor of PV2 segment ;**47 "RTN","RGADTP",141,0) Q "RTN","RGADTP",142,0) ; "RTN","RGADTP",143,0) PV2B() ;builder of PV2 segment ;**47 "RTN","RGADTP",144,0) N RET S RET="" "RTN","RGADTP",145,0) I 'RGLOCAL Q RET "RTN","RGADTP",146,0) N X S X="VAFCSB" X ^%ZOSF("TEST") Q:'$T RET "RTN","RGADTP",147,0) ;**45 VAFCSB coming in with DG*5.3*707 "RTN","RGADTP",148,0) Q $$PV2^VAFCSB "RTN","RGADTP",149,0) ; "RTN","RGADTP",150,0) PHARA() ;build obx to show active prescriptions "RTN","RGADTP",151,0) N RET S RET="" "RTN","RGADTP",152,0) I 'RGLOCAL Q RET "RTN","RGADTP",153,0) I '$$PATCH^XPDUTL("PSS*1.0*101") Q RET "RTN","RGADTP",154,0) N X S X="VAFCSB" X ^%ZOSF("TEST") Q:'$T RET "RTN","RGADTP",155,0) ;**45 VAFCSB coming in with DG*5.3*707 "RTN","RGADTP",156,0) Q $$PHARA^VAFCSB "RTN","RGADTP",157,0) ; "RTN","RGADTP",158,0) LABE() ;BUILD OBX FOR LAST LAB TEST DATE "RTN","RGADTP",159,0) N RET S RET="" "RTN","RGADTP",160,0) I 'RGLOCAL Q RET "RTN","RGADTP",161,0) I '$$PATCH^XPDUTL("LR*5.2*295") Q RET "RTN","RGADTP",162,0) N X S X="VAFCSB" X ^%ZOSF("TEST") Q:'$T RET "RTN","RGADTP",163,0) ;**45 VAFCSB coming in with DG*5.3*707 "RTN","RGADTP",164,0) Q $$LABE^VAFCSB "RTN","RGADTP",165,0) ; "RTN","RGADTP",166,0) RADE() ;BUILD OBX FOR LAST RADIOLOGY TEST DATE "RTN","RGADTP",167,0) N RET S RET="" "RTN","RGADTP",168,0) I 'RGLOCAL Q RET "RTN","RGADTP",169,0) I '$$PATCH^XPDUTL("RA*5.0*76") Q RET "RTN","RGADTP",170,0) N X S X="VAFCSB" X ^%ZOSF("TEST") Q:'$T RET "RTN","RGADTP",171,0) ;**45 VAFCSB coming in with DG*5.3*707 "RTN","RGADTP",172,0) Q $$RADE^VAFCSB "RTN","RGADTP",173,0) ; "RTN","RGADTP",174,0) EVN ;; "RTN","RGADTP",175,0) N CNT,ERR S EVN=RGI "RTN","RGADTP",176,0) I RGLOCAL S (EVN(1),THLA("HLS",ENT))=MSG,ENT=ENT+1 "RTN","RGADTP",177,0) I 'RGLOCAL D "RTN","RGADTP",178,0) .S ARRAY("EVR")=$P(MSG,HL("FS"),2),ARRAY("DLT")=$$FMDATE^HLFNC($P(MSG,HL("FS"),3)) "RTN","RGADTP",179,0) .S ARRAY("EVNAME")=$$FMNAME^XLFNAME($P(MSG,HL("FS"),2),"",$E(HL("ECH"),1)),ARRAY("SENDING SITE")=$P(MSG,HL("FS"),8) "RTN","RGADTP",180,0) Q "RTN","RGADTP",181,0) ; "RTN","RGADTP",182,0) EVNP ; "RTN","RGADTP",183,0) N EVNX "RTN","RGADTP",184,0) 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 "RTN","RGADTP",185,0) .I CNT>0 S THLA("HLS",EVN,CNT)=EVN(EVNX),CNT=CNT+1 "RTN","RGADTP",186,0) .I CNT'>0 S THLA("HLS",EVN)=EVN(EVNX),CNT=CNT+1 "RTN","RGADTP",187,0) Q "RTN","RGADTP",188,0) ; "RTN","RGADTP",189,0) PID ;; "RTN","RGADTP",190,0) N CNT,PIDX "RTN","RGADTP",191,0) I RGLOCAL D "RTN","RGADTP",192,0) .N HLCOMP S HLCOMP=$E(HL("ECH"),1),THLA("HLS",ENT)=MSG,DFN=$P($P(MSG,HL("FS"),4),HLCOMP) ;**45 REMOVED + "RTN","RGADTP",193,0) .D EVNP "RTN","RGADTP",194,0) .D BLDPID^VAFCQRY(DFN,1,"ALL",.PID,.HL) "RTN","RGADTP",195,0) .;get ICN value in the PID segment "RTN","RGADTP",196,0) .S ARRAY("ICN")=+$P($P(PID(1),HL("FS"),4),HLCOMP) "RTN","RGADTP",197,0) .S CNT=0,PIDX=0 F S PIDX=$O(PID(PIDX)) Q:'PIDX D "RTN","RGADTP",198,0) ..I CNT>0 S THLA("HLS",ENT,CNT)=PID(PIDX),CNT=CNT+1 "RTN","RGADTP",199,0) ..I CNT'>0 S THLA("HLS",ENT)=PID(PIDX),CNT=CNT+1 "RTN","RGADTP",200,0) .S ENT=ENT+1 "RTN","RGADTP",201,0) I 'RGLOCAL D PIDP^RGADTP1(.MSG,.ARRAY,.HL) "RTN","RGADTP",202,0) Q "RTN","RGADTP",203,0) ; "RTN","RGADTP",204,0) PD1 ;SET PD1 SEQ 3 TO BE PREFERRED FACILITY INSTEAD OF CMOR PATCH **45 "RTN","RGADTP",205,0) N PD1 "RTN","RGADTP",206,0) I RGLOCAL D "RTN","RGADTP",207,0) .;S PD1=$$PD1^VAFCSB "RTN","RGADTP",208,0) .;I PD1'="" S THLA("HLS",ENT)=PD1,ENT=ENT+1 "RTN","RGADTP",209,0) 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 "RTN","RGADTP",210,0) ;- NO LONGER DEALING WITH CMOR "RTN","RGADTP",211,0) Q "RTN","RGADTP",212,0) ; "RTN","RGADTP",213,0) PV1 ;; "RTN","RGADTP",214,0) I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1 "RTN","RGADTP",215,0) Q "RTN","RGADTP",216,0) ; "RTN","RGADTP",217,0) OBX ;; "RTN","RGADTP",218,0) N COMP,SUBCOMP "RTN","RGADTP",219,0) S COMP=$E(HL("ECH"),1),SUBCOMP=$E(HL("ECH"),4) "RTN","RGADTP",220,0) ; "RTN","RGADTP",221,0) I RGLOCAL D "RTN","RGADTP",222,0) .S THLA("HLS",ENT)=MSG "RTN","RGADTP",223,0) .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 "RTN","RGADTP",224,0) .S ENT=ENT+1 "RTN","RGADTP",225,0) ; "RTN","RGADTP",226,0) I 'RGLOCAL D "RTN","RGADTP",227,0) .I $$FREE^RGRSPARS($P($P(MSG,HL("FS"),4),COMP,2))="SECURITY LEVEL" D "RTN","RGADTP",228,0) ..S ARRAY("SENSITIVITY")=$$SENSTIVE^RGRSPARS($P(MSG,HL("FS"),6),COMP),ARRAY("SENSITIVITY DATE")=$$FREE^RGRSPARS($$FMDATE^HLFNC($P(MSG,HL("FS"),15))) "RTN","RGADTP",229,0) ..S ARRAY("SENSITIVITY USER")=$$FREE^RGRSPARS($P($P(MSG,HL("FS"),17),COMP,2))_","_$$FREE^RGRSPARS($P($P(MSG,HL("FS"),17),COMP,3)) "RTN","RGADTP",230,0) .; "RTN","RGADTP",231,0) .;**45 Get SSN VERIFICATION STATUS out of OBX if message is from the MPI "RTN","RGADTP",232,0) .;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:"@") "RTN","RGADTP",233,0) .;**47 use SSN Verification status code and not words since they have changed since this code was first written "RTN","RGADTP",234,0) .;only update values to valid or invalid other statuses aren't stored in VistA "RTN","RGADTP",235,0) .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:"@") "RTN","RGADTP",236,0) .; "RTN","RGADTP",237,0) .;**63 Story 174247 (mko): Get Self-ID Gender "RTN","RGADTP",238,0) .I $P($P(MSG,HL("FS"),4),COMP)="SELF ID GENDER" S ARRAY(.024)=$$FREE^RGRSPARS($P($P(MSG,HL("FS"),6),COMP)) "RTN","RGADTP",239,0) .; "RTN","RGADTP",240,0) .;**65 Story 323009 (ckn) : parse OBX for additional DOD fields "RTN","RGADTP",241,0) .I $P($P(MSG,HL("FS"),4),COMP)="DATE OF DEATH DATA" D "RTN","RGADTP",242,0) ..N DODLEB,DODLUPD "RTN","RGADTP",243,0) ..S ARRAY("DODSource")=$$FREE^RGRSPARS($P($P(MSG,HL("FS"),6),COMP)),ARRAY(.353)=ARRAY("DODSource") "RTN","RGADTP",244,0) ..S DODLUPD=$$FMDATE^HLFNC($P(MSG,HL("FS"),15)) "RTN","RGADTP",245,0) ..S ARRAY("DODLastUpdated")=$$FREE^RGRSPARS(DODLUPD),ARRAY(.354)=ARRAY("DODLastUpdated") "RTN","RGADTP",246,0) ..S DODLEB=$$FREE^RGRSPARS($P(MSG,HL("FS"),17)) "RTN","RGADTP",247,0) ..I DODLEB'="",(DODLEB'=HL("Q")) D "RTN","RGADTP",248,0) ...S ARRAY("DODEnteredBy")=$$FMNAME^XLFNAME($P(DODLEB,COMP,2,4),"L",COMP),ARRAY(.352)=ARRAY("DODEnteredBy") "RTN","RGADTP",249,0) ...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") "RTN","RGADTP",250,0) .; "RTN","RGADTP",251,0) .;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") "RTN","RGADTP",252,0) .; "RTN","RGADTP",253,0) .;**68 - Story 500735 (ckn) : Parse OBX to set a flag if deletion of "RTN","RGADTP",254,0) .;Date of Death occurred through TK OVR "RTN","RGADTP",255,0) .I $P($P(MSG,HL("FS"),4),COMP)="TK OVERRIDE DOD" S ARRAY("TKOVRDOD")=$P($P(MSG,HL("FS"),6),COMP) "RTN","RGADTP",256,0) .; "RTN","RGADTP",257,0) .;**76, VAMPI-11114 (dri) - add sexual orientation and sexual orientation description "RTN","RGADTP",258,0) .;**77, VAMPI-13755 (dri) - include status, date created, date last updated "RTN","RGADTP",259,0) .I $P($P(MSG,HL("FS"),4),COMP)="Sexual Orientation" D "RTN","RGADTP",260,0) ..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)) "RTN","RGADTP",261,0) .I $P($P(MSG,HL("FS"),4),COMP)="Sexual Or Description" D "RTN","RGADTP",262,0) ..S ARRAY("SexOrDes")=$P($P(MSG,HL("FS"),6),COMP,2) I ARRAY("SexOrDes")=HL("Q") S ARRAY("SexOrDes")="@" Q "RTN","RGADTP",263,0) ..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) "RTN","RGADTP",264,0) .; "RTN","RGADTP",265,0) .;**76, VAMPI-11118 (dri) - add pronoun and pronoun description "RTN","RGADTP",266,0) .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)) "RTN","RGADTP",267,0) .I $P($P(MSG,HL("FS"),4),COMP)="Pronoun Description" D "RTN","RGADTP",268,0) ..S ARRAY("PronounDes")=$P($P(MSG,HL("FS"),6),COMP,2) I ARRAY("PronounDes")=HL("Q") S ARRAY("PronounDes")="@" Q "RTN","RGADTP",269,0) ..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) "RTN","RGADTP",270,0) Q "RTN","RGADTP",271,0) ; "RTN","RGADTP",272,0) ZPD ;; "RTN","RGADTP",273,0) I RGLOCAL S THLA("HLS",ENT)=$$EN1^VAFHLZPD(DFN,"1,17,21,34"),ENT=ENT+1 ;**45 to build new ZPD "RTN","RGADTP",274,0) I 'RGLOCAL S ARRAY(.0906)=$P(MSG,HL("FS"),35) I ARRAY(.0906)=HL("Q") S ARRAY(.0906)="@" ;**45 Pull out pseudo ssn reason "RTN","RGADTP",275,0) Q "RTN","RGADTP",276,0) ; "RTN","RGADTP",277,0) ZSP ;; "RTN","RGADTP",278,0) I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1 "RTN","RGADTP",279,0) 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)) "RTN","RGADTP",280,0) Q "RTN","RGADTP",281,0) ; "RTN","RGADTP",282,0) ZEL ;; "RTN","RGADTP",283,0) I RGLOCAL D "RTN","RGADTP",284,0) .;**40 to rebuild ZEL segment "RTN","RGADTP",285,0) .I '$D(DFN) S THLA("HLS",ENT)=MSG,ENT=ENT+1 Q ;don't know DFN pass back original ZEL segment "RTN","RGADTP",286,0) .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 "RTN","RGADTP",287,0) .;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 "RTN","RGADTP",288,0) .N CNT,ZELX S (CNT,ZELX)=0 F S ZELX=$O(VAFZEL(ZELX)) Q:'ZELX D "RTN","RGADTP",289,0) ..I CNT>0 S THLA("HLS",ENT,CNT)=VAFZEL(ZELX),CNT=CNT+1 "RTN","RGADTP",290,0) ..I CNT'>0 S THLA("HLS",ENT)=VAFZEL(ZELX),ENT=ENT+1 "RTN","RGADTP",291,0) I 'RGLOCAL D "RTN","RGADTP",292,0) . S ARRAY(.361)=$$ELIG^RGRSPARS($P(MSG,HL("FS"),3)),ARRAY(.3612)=$$FREE^RGRSPARS($P(MSG,HL("FS"),12)) "RTN","RGADTP",293,0) . 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)) "RTN","RGADTP",294,0) Q "RTN","RGADTP",295,0) ; "RTN","RGADTP",296,0) ZCT ;; "RTN","RGADTP",297,0) I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1 "RTN","RGADTP",298,0) I 'RGLOCAL S ARRAY(.211)=$$FREE^RGRSPARS($P(MSG,HL("FS"),4)),ARRAY(.219)=$$FREE^RGRSPARS($P(MSG,HL("FS"),7)) "RTN","RGADTP",299,0) Q "RTN","RGADTP",300,0) ; "RTN","RGADTP",301,0) ZEM ;; "RTN","RGADTP",302,0) I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1 "RTN","RGADTP",303,0) I 'RGLOCAL S ARRAY(.31115)=$$EMP^RGRSPARS($P(MSG,HL("FS"),4)) "RTN","RGADTP",304,0) Q "RTN","RGADTP",305,0) ; "RTN","RGADTP",306,0) ZFF ;; "RTN","RGADTP",307,0) I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1 "RTN","RGADTP",308,0) I 'RGLOCAL S ARRAY("FLD")=$P(MSG,HL("FS"),3) "RTN","RGADTP",309,0) Q "RTN","RGADTP",310,0) ; "RTN","RGADTP",311,0) PROCIN ; "RTN","RGADTP",312,0) D PROCIN^RGADTP2(.ARRAY,.RGLOCAL,.RGER,.DFN,.HL) "RTN","RGADTP",313,0) Q "RTN","RGADTP",314,0) ; "RTN","RGADTP",315,0) GENACK ; "RTN","RGADTP",316,0) N RGCNT,IEN,RG,ERRSEG "RTN","RGADTP",317,0) I $G(ARRAY("DFN"))'>0 S RGER="-1^Unknown ICN#"_$G(ARRAY("ICN"))_" and SSN#"_$G(ARRAY(.09)) "RTN","RGADTP",318,0) ;**65 - Story 323009 - (ckn) : If DOD did not get updated due to "RTN","RGADTP",319,0) ;imprecise date OR invalid value, create ERR segment "RTN","RGADTP",320,0) E I HL("ETN")="A31",RGSITE="200M" D "RTN","RGADTP",321,0) . I $G(DODIMPF) S RGER="-1^IMPRECISE DOD - "_$$HLDATE^HLFNC($P(DODIMPF,"^",2)) "RTN","RGADTP",322,0) . S ERRSEG=$$NAMEERR^VAFCSB(ARRAY("DFN")) ;**61,MVI_3976 (mko): Get Name Components "RTN","RGADTP",323,0) ;E I HL("ETN")="A31",RGSITE="200M" S ERRSEG=$$NAMEERR^VAFCSB(ARRAY("DFN")) ;**61,MVI_3976 (mko): Get Name Components "RTN","RGADTP",324,0) ;send mas parameter 'process mvi dod update?' in 'aa' segment ;**65 - STORY_339759 (dri) "RTN","RGADTP",325,0) 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 "RTN","RGADTP",326,0) S:$G(ERRSEG)]"" HLA("HLA",RGCNT)=ERRSEG,RGCNT=RGCNT+1 ;**61,MVI_3976 (mko): Put name component in ERR segment "RTN","RGADTP",327,0) S RGSITE=$$LKUP^XUAF4(RGSITE) "RTN","RGADTP",328,0) ;**74 - Story - 1260465 (ckn) - Include 200M in HLL links for HAC "RTN","RGADTP",329,0) D LINK^HLUTIL3(RGSITE,.RG) S IEN=$O(RG(0)) S HLL("LINKS",1)="^"_RG(IEN)_$S($P($$SITE^VASITE(),"^",3)=741:"^200M",1:"") "RTN","RGADTP",330,0) D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.HLRESLTA,"",.HL) "RTN","RGADTP",331,0) K HLA,DODIMPF "RTN","RGADTP",332,0) Q "RTN","RGADTP",333,0) ; "RTN","RGADTP",334,0) RSP ; "RTN","RGADTP",335,0) Q "RTN","RGADTP",336,0) ; "RTN","RGADTP",337,0) OLD() ; Return OBX segment to flag a record as "old" "RTN","RGADTP",338,0) ;**59,MVI_914: New subroutine "RTN","RGADTP",339,0) 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:"") "RTN","RGADTP",340,0) ; "RTN","RGADTP3") 0^2^B50146380^B49259679 "RTN","RGADTP3",1,0) RGADTP3 ;BIR/CMC-RGADTP2 - CONTINUED ;4/21/22 10:52 "RTN","RGADTP3",2,0) ;;1.0;CLINICAL INFO RESOURCE NETWORK;**48,59,63,65,67,68,71,73,76,77**;30 Apr 99;Build 3 "RTN","RGADTP3",3,0) ; "RTN","RGADTP3",4,0) ;MOVED CHKPVT AND DIFF FROM RGADTP2 DUE TO ROUTINE SIZE ISSUE "RTN","RGADTP3",5,0) Q "RTN","RGADTP3",6,0) CHKPVT(ARRAY) ;CHECKS TO SEE IF OUTSTANDING IDENTITY EDIT IS WAITING TO BE SENT IN THE ADT/HL7 PIVOT FILE "RTN","RGADTP3",7,0) ;**44 CREATED - ARRAY CONTAINS THE ARRAY ELEMENTS NEEDED TO FIND THE PATIENT IN THE ADT/HL7 PIVOT FILE "RTN","RGADTP3",8,0) ;RETURNED IS -1^EDIT PENDING IN PIVOT FILE OR 0 IF THERE ISN'T ONE "RTN","RGADTP3",9,0) I '$D(^VAT(391.71,"C",ARRAY("DFN"))) Q 0 "RTN","RGADTP3",10,0) N PIV,FIELDS "RTN","RGADTP3",11,0) S PIV=$O(^VAT(391.71,"C",ARRAY("DFN"),"A"),-1) ;get last entry in the pivot file for this patient "RTN","RGADTP3",12,0) I '$D(^VAT(391.71,"AXMIT",4,PIV))&('$D(^VAT(391.71,"AXMIT",3,PIV))) Q 0 "RTN","RGADTP3",13,0) S FIELDS=$$GET1^DIQ(391.71,PIV_",",2.1,"I") "RTN","RGADTP3",14,0) I FIELDS[".01;"!(FIELDS[".02;")!(FIELDS[".03;")!(FIELDS[".09;")!(FIELDS[".0906;")!(FIELDS[".2403;")!(FIELDS["994;") Q "-1^DFN "_ARRAY("DFN")_": Edits made to identity fields waiting to come to MPI, MPI update not processed as of yet." "RTN","RGADTP3",15,0) Q 0 "RTN","RGADTP3",16,0) ; "RTN","RGADTP3",17,0) DIFF(ARRAY,RGRSDFN,DR,ARAY) ; are there fields to update? **47 "RTN","RGADTP3",18,0) N NAME,SSN,PDOB,SEX,SID,MMN,OLDNAME,OLDHLNAM,OLDMMN,OLDHLMMN,HLNAME,HLMMN,SSNV,MBI,PSNR,PREFNAME,TIN,FIN,ITIN,SEXORDES,PRONOUNDES "RTN","RGADTP3",19,0) S DR="",NAME=$$GET1^DIQ(2,+RGRSDFN_",",.01,"I"),HLNAME=ARRAY("NAME") "RTN","RGADTP3",20,0) ;**48 remove name standardization check "RTN","RGADTP3",21,0) ;D STDNAME^XLFNAME(.NAME,"F",.OLDNAME) S HLNAME=ARRAY("NAME") D STDNAME^XLFNAME(.HLNAME,"F",.OLDHLNAM) "RTN","RGADTP3",22,0) ;**71,Story 841921 (mko): If the Name Components flag is not set, and the incoming name is > 30 chars, "RTN","RGADTP3",23,0) ; use the name components to build a truncated name "RTN","RGADTP3",24,0) ; If the flag is set, then we need to update the Name Components entry rather than the Patient Name. "RTN","RGADTP3",25,0) ; Save the incoming components in ARAY(20), when different from existing values "RTN","RGADTP3",26,0) I '$$GETFLAG^MPIFNAMC D "RTN","RGADTP3",27,0) .S:$L(HLNAME)>30 (HLNAME,ARRAY("NAME"))=$$FMTNAME(.ARRAY,30) "RTN","RGADTP3",28,0) .S:NAME'=$G(HLNAME) DR=DR_".01;",ARAY(2,.01)=ARRAY("NAME") "RTN","RGADTP3",29,0) E D "RTN","RGADTP3",30,0) .N DIERR,DIMSG,DIHELP,MSG,NCIENS,TARG "RTN","RGADTP3",31,0) .S NCIENS=$$GET1^DIQ(2,+RGRSDFN_",",1.01,"I","","MSG")_"," "RTN","RGADTP3",32,0) .D:NCIENS>0 GETS^DIQ(20,NCIENS,"1;2;3;5","I","TARG","MSG") "RTN","RGADTP3",33,0) .S:$G(TARG(20,NCIENS,1,"I"))'=$G(ARRAY("SURNAME")) ARAY(2,1.01,"FAMILY")=$G(ARRAY("SURNAME")) "RTN","RGADTP3",34,0) .S:$G(TARG(20,NCIENS,2,"I"))'=$G(ARRAY("FIRST")) ARAY(2,1.01,"GIVEN")=$G(ARRAY("FIRST")) "RTN","RGADTP3",35,0) .S:$G(TARG(20,NCIENS,3,"I"))'=$G(ARRAY("MIDDLE")) ARAY(2,1.01,"MIDDLE")=$G(ARRAY("MIDDLE")) "RTN","RGADTP3",36,0) .S:$G(TARG(20,NCIENS,5,"I"))'=$G(ARRAY("SUFFIX")) ARAY(2,1.01,"SUFFIX")=$G(ARRAY("SUFFIX")) "RTN","RGADTP3",37,0) .S:$D(ARAY(2,1.01)) DR=DR_"1.01;" "RTN","RGADTP3",38,0) ;**67 - Story 455460 (ckn) - Update Preferred Name "RTN","RGADTP3",39,0) S PREFNAME=$$GET1^DIQ(2,+RGRSDFN_",",.2405,"I") D "RTN","RGADTP3",40,0) .I PREFNAME="",$G(ARRAY("PREFERREDNAME"))="@" Q "RTN","RGADTP3",41,0) .I PREFNAME'=$G(ARRAY("PREFERREDNAME")) S DR=DR_".2405;",ARAY(2,.2405)=$G(ARRAY("PREFERREDNAME")) "RTN","RGADTP3",42,0) S PDOB=$$GET1^DIQ(2,+RGRSDFN_",",.03,"I") I PDOB'=ARRAY("MPIDOB") S DR=DR_".03;",ARAY(2,.03)=ARRAY("MPIDOB") "RTN","RGADTP3",43,0) S SSN=$$GET1^DIQ(2,+RGRSDFN_",",.09,"I") D "RTN","RGADTP3",44,0) .I SSN["P",ARRAY("SSN")=""!(ARRAY("SSN")="@") Q "RTN","RGADTP3",45,0) .; **47 if incoming SSN value is null/@ and existing SSN isn't a pseudo create a new pseudo SSN "RTN","RGADTP3",46,0) .I SSN'["P" I ARRAY("SSN")="@"!(ARRAY("SSN")="") S ARRAY("SSN")="P" "RTN","RGADTP3",47,0) .I SSN'=ARRAY("SSN"),ARRAY("SSN")'="" S DR=DR_".09;",ARAY(2,.09)=ARRAY("SSN") "RTN","RGADTP3",48,0) S SEX=$$GET1^DIQ(2,+RGRSDFN_",",.02,"I") D "RTN","RGADTP3",49,0) .I SEX=""&(ARRAY("SEX")="@") Q "RTN","RGADTP3",50,0) .I SEX'=ARRAY("SEX") S DR=DR_".02;",ARAY(2,.02)=ARRAY("SEX") "RTN","RGADTP3",51,0) ;**63 Story 174247: Self-ID Gender "RTN","RGADTP3",52,0) S SID=$$GET1^DIQ(2,+RGRSDFN_",",.024,"I") D "RTN","RGADTP3",53,0) .I SID="",$G(ARRAY(.024))="@" Q "RTN","RGADTP3",54,0) .I SID'=$G(ARRAY(.024)) S DR=DR_".024;",ARAY(2,.024)=$G(ARRAY(".024")) "RTN","RGADTP3",55,0) ;S SSNV=$$GET1^DIQ(2,+RGRSDFN_",",.0907,"I") I SSNV="" S SSNV="@" "RTN","RGADTP3",56,0) ;I SSNV'=$G(ARRAY(.0907)) S ARAY(2,.0907)=$G(ARRAY(.0907)),DR=DR_".0907;" ;**76 don't file until after ssn is filed by EDIT^VAFCPTED in ^RGADTP2 "RTN","RGADTP3",57,0) ;S PSNR=$$GET1^DIQ(2,+RGRSDFN_",",.0906,"I") I PSNR="" S PSNR="@" "RTN","RGADTP3",58,0) ;I PSNR'=ARRAY(.0906) S ARAY(2,.0906)=$G(ARRAY(.0906)),DR=DR_".0906;" ;**76 don't file until after ssn is filed by EDIT^VAFCPTED in ^RGADTP2 "RTN","RGADTP3",59,0) I $G(ARRAY("MBI"))'="" D ;**59, MVI_881 "RTN","RGADTP3",60,0) . S MBI=$$GET1^DIQ(2,+RGRSDFN_",",994,"I") S:MBI="" MBI="@" "RTN","RGADTP3",61,0) . I MBI'=ARRAY("MBI") S DR=DR_"994;",ARAY(2,994)=ARRAY("MBI") "RTN","RGADTP3",62,0) S HLMMN=$G(ARRAY("MMN")) ;**59, MVI_881 "RTN","RGADTP3",63,0) I HLMMN'="" D "RTN","RGADTP3",64,0) . S MMN=$$GET1^DIQ(2,+RGRSDFN_",",.2403,"I") S:MMN="" MMN="@" "RTN","RGADTP3",65,0) . I MMN'="@" D STDNAME^XLFNAME(.MMN,"F",.OLDMMN) "RTN","RGADTP3",66,0) . I HLMMN'="@" D STDNAME^XLFNAME(.HLMMN,"F",.OLDHLMMN) "RTN","RGADTP3",67,0) . I MMN'=HLMMN S DR=DR_".2403;",ARAY(2,.2403)=ARRAY("MMN") "RTN","RGADTP3",68,0) I $G(ARRAY("TIN"))'="" D "RTN","RGADTP3",69,0) . S TIN=$$GET1^DIQ(2,+RGRSDFN_",",991.08,"I") S:TIN="" TIN="@" "RTN","RGADTP3",70,0) . I TIN'=ARRAY("TIN") S DR=DR_"991.08;",ARAY(2,991.08)=ARRAY("TIN") "RTN","RGADTP3",71,0) I $G(ARRAY("FIN"))'="" D "RTN","RGADTP3",72,0) . S FIN=$$GET1^DIQ(2,+RGRSDFN_",",991.09,"I") S:FIN="" FIN="@" "RTN","RGADTP3",73,0) . I FIN'=ARRAY("FIN") S DR=DR_"991.09;",ARAY(2,991.09)=ARRAY("FIN") "RTN","RGADTP3",74,0) I $G(ARRAY("ITIN"))'="" D ;**76, VAMPI-11120 (dri) update ITIN field "RTN","RGADTP3",75,0) . S ITIN=$$GET1^DIQ(2,+RGRSDFN_",",991.11,"I") S:ITIN="" ITIN="@" "RTN","RGADTP3",76,0) . I ITIN'=ARRAY("ITIN") S DR=DR_"991.11;",ARAY(2,991.11)=ARRAY("ITIN") "RTN","RGADTP3",77,0) I $S($O(ARRAY("SexOr",0)):1,$O(^DPT(+RGRSDFN,.025,0)):1,1:0) S DR=DR_".025;" ;**76, VAMPI-11114 (dri) check in ^vafcpted whether to update sexual orientation "RTN","RGADTP3",78,0) I $G(ARRAY("SexOrDes"))'="" D ;**76, VAMPI-11114 (dri) update sexual orientation description ;**77, VAMPI-13755 (dri) - file after "SexOr" for "AHIST" x-ref "RTN","RGADTP3",79,0) . S SEXORDES=$$GET1^DIQ(2,+RGRSDFN_",",.0251,"I") S:SEXORDES="" SEXORDES="@" "RTN","RGADTP3",80,0) . I SEXORDES'=ARRAY("SexOrDes") S DR=DR_".0251;",ARAY(2,.0251)=ARRAY("SexOrDes") "RTN","RGADTP3",81,0) I $S($O(ARRAY("Pronoun",0)):1,$O(^DPT(+RGRSDFN,.2406,0)):1,1:0) S DR=DR_".2406;" ;**76, VAMPI-11118 (dri) check in vafcpted whether to update pronoun "RTN","RGADTP3",82,0) I $G(ARRAY("PronounDes"))'="" D ;**76, VAMPI-11118 (dri) update pronoun description "RTN","RGADTP3",83,0) . S PRONOUNDES=$$GET1^DIQ(2,+RGRSDFN_",",.24061,"I") S:PRONOUNDES="" PRONOUNDES="@" "RTN","RGADTP3",84,0) . I PRONOUNDES'=ARRAY("PronounDes") S DR=DR_".24061;",ARAY(2,.24061)=ARRAY("PronounDes") "RTN","RGADTP3",85,0) I $S($O(ARRAY("ALIAS",0)):1,$O(^DPT(+RGRSDFN,.01,0)):1,1:0) S DR=DR_"1;" "RTN","RGADTP3",86,0) ;**65 - Story 323009 (ckn): Update DOD fields "RTN","RGADTP3",87,0) N ODOD,ODODP,ODODLUP,ODODSRC,ODODARY,ODODD,ANSWER,DUPDFLG "RTN","RGADTP3",88,0) S DUPDFLG=$$CHK^VAFCDODA() ;Date of Death update flag "RTN","RGADTP3",89,0) ; check for validation of Date of Death- if imprecise date of "RTN","RGADTP3",90,0) ; death - remove all Date of Death if no existin date of death "RTN","RGADTP3",91,0) D VAL^DIE(2,+RGRSDFN_",",.351,"R",$G(ARRAY("MPIDOD")),.ANSWER) "RTN","RGADTP3",92,0) I DUPDFLG D "RTN","RGADTP3",93,0) . I $G(ARRAY("MPIDOD"))="""@"""!($G(ARRAY("MPIDOD"))="") D Q "RTN","RGADTP3",94,0) ..;**68 - Story 500735 (ckn) : Only Delete Date of Death data if "RTN","RGADTP3",95,0) ..; deletion through PSIM TK OVERRIDE "RTN","RGADTP3",96,0) .. I '$G(ARRAY("TKOVRDOD")) Q "RTN","RGADTP3",97,0) .. I $$GET1^DIQ(2,+RGRSDFN_",",.351,"I")="" Q "RTN","RGADTP3",98,0) .. S DR=DR_".354;",ARAY(2,.354)=$G(ARRAY(.354)) ;Date of death last updated date "RTN","RGADTP3",99,0) .. ;Remove rest of the DOD fields "RTN","RGADTP3",100,0) .. S DR=DR_".351;.352;.353;.355;.357;.358;",(ARAY(2,.351),ARAY(2,.352),ARAY(2,.353),ARAY(2,.355),ARAY(2,.357),ARAY(2,.358))="@" "RTN","RGADTP3",101,0) . I ANSWER="^" S DODIMPF=1_"^"_$G(ARRAY("MPIDOD")) Q ;Date of Death Imprecise Flag - No update on VistA "RTN","RGADTP3",102,0) . I $G(ARRAY("MPIDOD"))>0 D Q "RTN","RGADTP3",103,0) .. N TUPD S TUPD=0 "RTN","RGADTP3",104,0) .. D GETS^DIQ(2,+RGRSDFN_",",".351;.353;.354;.357","I","ODODARY") "RTN","RGADTP3",105,0) .. S ODOD=ODODARY(2,+RGRSDFN_",",.351,"I") "RTN","RGADTP3",106,0) ..; S ODODD=ODODARY(2,+RGRSDFN_",",.357,"I") "RTN","RGADTP3",107,0) .. S ODODLUP=ODODARY(2,+RGRSDFN_",",.354,"I") "RTN","RGADTP3",108,0) .. S ODODSRC=ODODARY(2,+RGRSDFN_",",.353,"I") "RTN","RGADTP3",109,0) ..; I ODOD=ARRAY("MPIDOD") Q ;No update if no change in Date of Death "RTN","RGADTP3",110,0) ..;**71 - Story 841797 (ckn) "RTN","RGADTP3",111,0) ..;DOD metadata update allowed if update is from PSIM TK OVERRIDE even "RTN","RGADTP3",112,0) ..;if no change in Date of Death "RTN","RGADTP3",113,0) ..;**131 - Story 1125116 (ckn) DOD metadata update is allowed now regardless "RTN","RGADTP3",114,0) ..; I ODOD=ARRAY("MPIDOD"),'$G(ARRAY("TKOVRDOD")) Q "RTN","RGADTP3",115,0) .. I ODOD'=ARRAY("MPIDOD") S DR=DR_".351;",ARAY(2,.351)=$G(ARRAY(.351)),TUPD=1 "RTN","RGADTP3",116,0) ..; I ODODD'=$G(ARRAY("DODDocType")) S DR=DR_".357;",ARAY(2,.357)=$G(ARRAY(.357)) "RTN","RGADTP3",117,0) .. I ODODLUP'=$G(ARRAY("DODLastUpdated")),(ODOD'=ARRAY("MPIDOD")) S DR=DR_".354;",ARAY(2,.354)=$G(ARRAY(.354)) "RTN","RGADTP3",118,0) .. I ODODSRC'=$G(ARRAY("DODSource")) S DR=DR_".353;",ARAY(2,.353)=$G(ARRAY(.353)),TUPD=1 "RTN","RGADTP3",119,0) .. ;S DR=DR_".353;",ARAY(2,.353)=$G(ARRAY(.353)) "RTN","RGADTP3",120,0) .. ;Remove rest of the DOD fields if Date Of Death is getting updated "RTN","RGADTP3",121,0) .. S DR=DR_".352;.357;.358",ARAY(2,.352)="@",ARAY(2,.358)="@",ARAY(2,.357)="@" "RTN","RGADTP3",122,0) .. I TUPD S DR=DR_";.355",ARAY(2,.355)="@" "RTN","RGADTP3",123,0) Q "RTN","RGADTP3",124,0) ; "RTN","RGADTP3",125,0) FMTNAME(ARRAY,LEN) ;Return a formatted name from cleaned Name Components that doesn't exceed LEN characters in length. "RTN","RGADTP3",126,0) ;**71,Story 841921 (mko): New function "RTN","RGADTP3",127,0) N NC "RTN","RGADTP3",128,0) S:'$G(LEN) LEN=30 "RTN","RGADTP3",129,0) ; "RTN","RGADTP3",130,0) ;If ARRAY is passed as a string and doesn't have descendants assume it equals "surname^first^middle^suffix" "RTN","RGADTP3",131,0) D:$D(ARRAY)=1 "RTN","RGADTP3",132,0) . S ARRAY("SURNAME")=$P(ARRAY,"^") "RTN","RGADTP3",133,0) . S ARRAY("FIRST")=$P(ARRAY,"^",2) "RTN","RGADTP3",134,0) . S ARRAY("MIDDLE")=$P(ARRAY,"^",3) "RTN","RGADTP3",135,0) . S ARRAY("SUFFIX")=$P(ARRAY,"^",4) "RTN","RGADTP3",136,0) ; "RTN","RGADTP3",137,0) ;Clean the components "RTN","RGADTP3",138,0) S NC("FAMILY")=$$CLEANC^XLFNAME($G(ARRAY("SURNAME"))) "RTN","RGADTP3",139,0) S NC("GIVEN")=$$CLEANC^XLFNAME($G(ARRAY("FIRST"))) "RTN","RGADTP3",140,0) S NC("MIDDLE")=$$CLEANC^XLFNAME($G(ARRAY("MIDDLE"))) "RTN","RGADTP3",141,0) S NC("SUFFIX")=$$CLEANC^XLFNAME($G(ARRAY("SUFFIX"))) "RTN","RGADTP3",142,0) ; "RTN","RGADTP3",143,0) ;Build a full name, maximum length LEN "RTN","RGADTP3",144,0) Q $$NAMEFMT^XLFNAME(.NC,"F","CL"_LEN) "RTN","RGADTP3",145,0) ; "VER") 8.0^22.2 "BLD",3762,6) ^75 **END** **END**