Released RG*1*76 SEQ #74 Extracted from mail message **KIDS**:RG*1.0*76^ **INSTALL NAME** RG*1.0*76 "BLD",3658,0) RG*1.0*76^CLINICAL INFO RESOURCE NETWORK^0^3210823^y "BLD",3658,1,0) ^^3^3^3210823^^ "BLD",3658,1,1,0) MASTER VETERAN INDEX VISTA ENHANCEMENT - NEW DEMOGRAPHIC FIELDS "BLD",3658,1,2,0) Refer to patch RG*1.0*76 in the FORUM Patch Module for a complete "BLD",3658,1,3,0) description. "BLD",3658,4,0) ^9.64PA^^ "BLD",3658,6) 1 "BLD",3658,6.3) 1 "BLD",3658,"KRN",0) ^9.67PA^1.5^25 "BLD",3658,"KRN",.4,0) .4 "BLD",3658,"KRN",.401,0) .401 "BLD",3658,"KRN",.402,0) .402 "BLD",3658,"KRN",.403,0) .403 "BLD",3658,"KRN",.5,0) .5 "BLD",3658,"KRN",.84,0) .84 "BLD",3658,"KRN",1.5,0) 1.5 "BLD",3658,"KRN",1.6,0) 1.6 "BLD",3658,"KRN",1.61,0) 1.61 "BLD",3658,"KRN",1.62,0) 1.62 "BLD",3658,"KRN",3.6,0) 3.6 "BLD",3658,"KRN",3.8,0) 3.8 "BLD",3658,"KRN",9.2,0) 9.2 "BLD",3658,"KRN",9.8,0) 9.8 "BLD",3658,"KRN",9.8,"NM",0) ^9.68A^4^4 "BLD",3658,"KRN",9.8,"NM",1,0) RGADTP^^0^B197081874 "BLD",3658,"KRN",9.8,"NM",2,0) RGADTP1^^0^B65320727 "BLD",3658,"KRN",9.8,"NM",3,0) RGADTP2^^0^B87694121 "BLD",3658,"KRN",9.8,"NM",4,0) RGADTP3^^0^B49259679 "BLD",3658,"KRN",9.8,"NM","B","RGADTP",1) "BLD",3658,"KRN",9.8,"NM","B","RGADTP1",2) "BLD",3658,"KRN",9.8,"NM","B","RGADTP2",3) "BLD",3658,"KRN",9.8,"NM","B","RGADTP3",4) "BLD",3658,"KRN",19,0) 19 "BLD",3658,"KRN",19.1,0) 19.1 "BLD",3658,"KRN",101,0) 101 "BLD",3658,"KRN",409.61,0) 409.61 "BLD",3658,"KRN",771,0) 771 "BLD",3658,"KRN",779.2,0) 779.2 "BLD",3658,"KRN",870,0) 870 "BLD",3658,"KRN",8989.51,0) 8989.51 "BLD",3658,"KRN",8989.52,0) 8989.52 "BLD",3658,"KRN",8993,0) 8993 "BLD",3658,"KRN",8994,0) 8994 "BLD",3658,"KRN","B",.4,.4) "BLD",3658,"KRN","B",.401,.401) "BLD",3658,"KRN","B",.402,.402) "BLD",3658,"KRN","B",.403,.403) "BLD",3658,"KRN","B",.5,.5) "BLD",3658,"KRN","B",.84,.84) "BLD",3658,"KRN","B",1.5,1.5) "BLD",3658,"KRN","B",1.6,1.6) "BLD",3658,"KRN","B",1.61,1.61) "BLD",3658,"KRN","B",1.62,1.62) "BLD",3658,"KRN","B",3.6,3.6) "BLD",3658,"KRN","B",3.8,3.8) "BLD",3658,"KRN","B",9.2,9.2) "BLD",3658,"KRN","B",9.8,9.8) "BLD",3658,"KRN","B",19,19) "BLD",3658,"KRN","B",19.1,19.1) "BLD",3658,"KRN","B",101,101) "BLD",3658,"KRN","B",409.61,409.61) "BLD",3658,"KRN","B",771,771) "BLD",3658,"KRN","B",779.2,779.2) "BLD",3658,"KRN","B",870,870) "BLD",3658,"KRN","B",8989.51,8989.51) "BLD",3658,"KRN","B",8989.52,8989.52) "BLD",3658,"KRN","B",8993,8993) "BLD",3658,"KRN","B",8994,8994) "BLD",3658,"QDEF") ^^^^NO^^^^NO^^YES "BLD",3658,"QUES",0) ^9.62^^ "BLD",3658,"REQB",0) ^9.611^5^5 "BLD",3658,"REQB",1,0) RG*1.0*71^2 "BLD",3658,"REQB",2,0) RG*1.0*72^2 "BLD",3658,"REQB",3,0) RG*1.0*73^2 "BLD",3658,"REQB",4,0) RG*1.0*74^2 "BLD",3658,"REQB",5,0) DG*5.3*1059^2 "BLD",3658,"REQB","B","DG*5.3*1059",5) "BLD",3658,"REQB","B","RG*1.0*71",1) "BLD",3658,"REQB","B","RG*1.0*72",2) "BLD",3658,"REQB","B","RG*1.0*73",3) "BLD",3658,"REQB","B","RG*1.0*74",4) "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) 76^3210823 "PKG",272,22,1,"PAH",1,1,0) ^^3^3^3210823 "PKG",272,22,1,"PAH",1,1,1,0) MASTER VETERAN INDEX VISTA ENHANCEMENT - NEW DEMOGRAPHIC FIELDS "PKG",272,22,1,"PAH",1,1,2,0) Refer to patch RG*1.0*76 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") 4 "RTN","RGADTP") 0^1^B197081874^B131669546 "RTN","RGADTP",1,0) RGADTP ;BIR/DLR-ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS ;7/15/21 16:00 "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**;30 Apr 99;Build 1 "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) "RTN","RGADTP",258,0) .I $P($P(MSG,HL("FS"),4),COMP)="Sexual Orientation" S ARRAY("SexOr",$O(ARRAY("SexOr",""),-1)+1)=$$FREE^RGRSPARS($P($P(MSG,HL("FS"),6),COMP)) "RTN","RGADTP",259,0) .I $P($P(MSG,HL("FS"),4),COMP)="Sexual Or Description" D "RTN","RGADTP",260,0) ..S ARRAY("SexOrDes")=$P($P(MSG,HL("FS"),6),COMP,2) I ARRAY("SexOrDes")=HL("Q") S ARRAY("SexOrDes")="@" Q "RTN","RGADTP",261,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",262,0) .; "RTN","RGADTP",263,0) .;**76, VAMPI-11118 (dri) "RTN","RGADTP",264,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",265,0) .I $P($P(MSG,HL("FS"),4),COMP)="Pronoun Description" D "RTN","RGADTP",266,0) ..S ARRAY("PronounDes")=$P($P(MSG,HL("FS"),6),COMP,2) I ARRAY("PronounDes")=HL("Q") S ARRAY("PronounDes")="@" Q "RTN","RGADTP",267,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",268,0) Q "RTN","RGADTP",269,0) ; "RTN","RGADTP",270,0) ZPD ;; "RTN","RGADTP",271,0) I RGLOCAL S THLA("HLS",ENT)=$$EN1^VAFHLZPD(DFN,"1,17,21,34"),ENT=ENT+1 ;**45 to build new ZPD "RTN","RGADTP",272,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",273,0) Q "RTN","RGADTP",274,0) ; "RTN","RGADTP",275,0) ZSP ;; "RTN","RGADTP",276,0) I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1 "RTN","RGADTP",277,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",278,0) Q "RTN","RGADTP",279,0) ; "RTN","RGADTP",280,0) ZEL ;; "RTN","RGADTP",281,0) I RGLOCAL D "RTN","RGADTP",282,0) .;**40 to rebuild ZEL segment "RTN","RGADTP",283,0) .I '$D(DFN) S THLA("HLS",ENT)=MSG,ENT=ENT+1 Q ;don't know DFN pass back original ZEL segment "RTN","RGADTP",284,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",285,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",286,0) .N CNT,ZELX S (CNT,ZELX)=0 F S ZELX=$O(VAFZEL(ZELX)) Q:'ZELX D "RTN","RGADTP",287,0) ..I CNT>0 S THLA("HLS",ENT,CNT)=VAFZEL(ZELX),CNT=CNT+1 "RTN","RGADTP",288,0) ..I CNT'>0 S THLA("HLS",ENT)=VAFZEL(ZELX),ENT=ENT+1 "RTN","RGADTP",289,0) I 'RGLOCAL D "RTN","RGADTP",290,0) . S ARRAY(.361)=$$ELIG^RGRSPARS($P(MSG,HL("FS"),3)),ARRAY(.3612)=$$FREE^RGRSPARS($P(MSG,HL("FS"),12)) "RTN","RGADTP",291,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",292,0) Q "RTN","RGADTP",293,0) ; "RTN","RGADTP",294,0) ZCT ;; "RTN","RGADTP",295,0) I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1 "RTN","RGADTP",296,0) I 'RGLOCAL S ARRAY(.211)=$$FREE^RGRSPARS($P(MSG,HL("FS"),4)),ARRAY(.219)=$$FREE^RGRSPARS($P(MSG,HL("FS"),7)) "RTN","RGADTP",297,0) Q "RTN","RGADTP",298,0) ; "RTN","RGADTP",299,0) ZEM ;; "RTN","RGADTP",300,0) I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1 "RTN","RGADTP",301,0) I 'RGLOCAL S ARRAY(.31115)=$$EMP^RGRSPARS($P(MSG,HL("FS"),4)) "RTN","RGADTP",302,0) Q "RTN","RGADTP",303,0) ; "RTN","RGADTP",304,0) ZFF ;; "RTN","RGADTP",305,0) I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1 "RTN","RGADTP",306,0) I 'RGLOCAL S ARRAY("FLD")=$P(MSG,HL("FS"),3) "RTN","RGADTP",307,0) Q "RTN","RGADTP",308,0) ; "RTN","RGADTP",309,0) PROCIN ; "RTN","RGADTP",310,0) D PROCIN^RGADTP2(.ARRAY,.RGLOCAL,.RGER,.DFN,.HL) "RTN","RGADTP",311,0) Q "RTN","RGADTP",312,0) ; "RTN","RGADTP",313,0) GENACK ; "RTN","RGADTP",314,0) N RGCNT,IEN,RG,ERRSEG "RTN","RGADTP",315,0) I $G(ARRAY("DFN"))'>0 S RGER="-1^Unknown ICN#"_$G(ARRAY("ICN"))_" and SSN#"_$G(ARRAY(.09)) "RTN","RGADTP",316,0) ;**65 - Story 323009 - (ckn) : If DOD did not get updated due to "RTN","RGADTP",317,0) ;imprecise date OR invalid value, create ERR segment "RTN","RGADTP",318,0) E I HL("ETN")="A31",RGSITE="200M" D "RTN","RGADTP",319,0) . I $G(DODIMPF) S RGER="-1^IMPRECISE DOD - "_$$HLDATE^HLFNC($P(DODIMPF,"^",2)) "RTN","RGADTP",320,0) . S ERRSEG=$$NAMEERR^VAFCSB(ARRAY("DFN")) ;**61,MVI_3976 (mko): Get Name Components "RTN","RGADTP",321,0) ;E I HL("ETN")="A31",RGSITE="200M" S ERRSEG=$$NAMEERR^VAFCSB(ARRAY("DFN")) ;**61,MVI_3976 (mko): Get Name Components "RTN","RGADTP",322,0) ;send mas parameter 'process mvi dod update?' in 'aa' segment ;**65 - STORY_339759 (dri) "RTN","RGADTP",323,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",324,0) S:$G(ERRSEG)]"" HLA("HLA",RGCNT)=ERRSEG,RGCNT=RGCNT+1 ;**61,MVI_3976 (mko): Put name component in ERR segment "RTN","RGADTP",325,0) S RGSITE=$$LKUP^XUAF4(RGSITE) "RTN","RGADTP",326,0) ;**74 - Story - 1260465 (ckn) - Include 200M in HLL links for HAC "RTN","RGADTP",327,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",328,0) D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.HLRESLTA,"",.HL) "RTN","RGADTP",329,0) K HLA,DODIMPF "RTN","RGADTP",330,0) Q "RTN","RGADTP",331,0) ; "RTN","RGADTP",332,0) RSP ; "RTN","RGADTP",333,0) Q "RTN","RGADTP",334,0) ; "RTN","RGADTP",335,0) OLD() ; Return OBX segment to flag a record as "old" "RTN","RGADTP",336,0) ;**59,MVI_914: New subroutine "RTN","RGADTP",337,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",338,0) ; "RTN","RGADTP1") 0^2^B65320727^B62788084 "RTN","RGADTP1",1,0) RGADTP1 ;BIR/DLR-ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS - CONTINUED ;7/19/21 12:43 "RTN","RGADTP1",2,0) ;;1.0;CLINICAL INFO RESOURCE NETWORK;**26,27,42,45,44,47,48,59,61,64,67,71,76**;30 Apr 99;Build 1 "RTN","RGADTP1",3,0) ; "RTN","RGADTP1",4,0) PIDP(MSG,ARRAY,HL) ;process PID segment "RTN","RGADTP1",5,0) N ID,IDS,PIDAA,PIDNTC "RTN","RGADTP1",6,0) ;Since PID can be over 245 characters loop through setting a PID ARRAY "RTN","RGADTP1",7,0) ;sequenced PID(1)="PID"... PID(4 or 5) can be over 245 characters so "RTN","RGADTP1",8,0) ;it will also loop and place it in PID(4,1... "RTN","RGADTP1",9,0) ; "RTN","RGADTP1",10,0) ; Input variables "RTN","RGADTP1",11,0) ; assumes that MSG or MSG(I) will contain the PID segment "RTN","RGADTP1",12,0) ; Output ARRAY ARRAY will contain the following subscripts "RTN","RGADTP1",13,0) ; SSN - patient SSN "RTN","RGADTP1",14,0) ; ICN - patient ICN "RTN","RGADTP1",15,0) ; DFN - sites local identifier "RTN","RGADTP1",16,0) ; MPISSITE - authoritative source (station# of sending site) "RTN","RGADTP1",17,0) ; SEX - patient's SEX "RTN","RGADTP1",18,0) ; MPIDOB - Date of Birth "RTN","RGADTP1",19,0) ; NAME,SURNAME,FIRST,MIDDLE,PREFIX,and SUFFIX - Patient Name "RTN","RGADTP1",20,0) ; MMN - Mother's maiden name "RTN","RGADTP1",21,0) ; POBCITY, POBSTATE - Place of birth city and state "RTN","RGADTP1",22,0) ; "RTN","RGADTP1",23,0) N PID,MPIJ,LNGTH,LNGTH1,PID1,SEQ,SEQ1,COMP,SUBCOMP,REP,HLECH,X,Y,CNT,NXT,ID,IDS,PIDAA,PIDNTC,NAME,LNGTH2,PIDSITE,PIDXDT,HLECH,HLFS "RTN","RGADTP1",24,0) S HLFS=HL("FS"),HLECH=HL("ECH") "RTN","RGADTP1",25,0) S ARRAY("DFN")="",ARRAY("ICN")="",ARRAY("CLAIMN")="",ARRAY("SSN")="" "RTN","RGADTP1",26,0) S COMP=$E(HL("ECH"),1),SUBCOMP=$E(HL("ECH"),4),REP=$E(HL("ECH"),2) "RTN","RGADTP1",27,0) S LNGTH=$L(MSG,HL("FS")) F SEQ=1:1:LNGTH S PID(SEQ)=$P(MSG,HL("FS"),SEQ) "RTN","RGADTP1",28,0) S SEQ1=1,X=0 F S X=$O(MSG(X)) Q:'X S LNGTH=$L(MSG(X),HL("FS")) D "RTN","RGADTP1",29,0) . F Y=1:1:LNGTH S:Y'=1 SEQ=SEQ+1,SEQ1=1 D ;**61 MVI_2970 (dri) "RTN","RGADTP1",30,0) .. S NXT=$P(MSG(X),HL("FS"),Y) D "RTN","RGADTP1",31,0) ... I $L($G(PID(SEQ)))=245 D Q "RTN","RGADTP1",32,0) .... I $L(NXT_$G(PID(SEQ,SEQ1)))>245 S LNGTH1=$L(PID(SEQ,SEQ1)) S LNGTH2=245-LNGTH1,PID(SEQ,SEQ1)=$G(PID(SEQ,SEQ1))_$E(NXT,1,LNGTH2),LNGTH2=LNGTH2+1,NXT=$E(NXT,LNGTH2,$L(NXT)),SEQ1=SEQ1+1 "RTN","RGADTP1",33,0) .... I $L(NXT_$G(PID(SEQ,SEQ1)))'>245 S PID(SEQ,SEQ1)=$G(PID(SEQ,SEQ1))_NXT "RTN","RGADTP1",34,0) ... I $L(NXT_$G(PID(SEQ)))>245 S LNGTH1=$L($G(PID(SEQ))) S LNGTH2=245-LNGTH1,PID(SEQ)=$G(PID(SEQ))_$E(NXT,1,LNGTH2),LNGTH2=LNGTH2+1,NXT=$E(NXT,LNGTH2,$L(NXT)) S PID(SEQ,SEQ1)=NXT "RTN","RGADTP1",35,0) ... I $L(NXT_$G(PID(SEQ)))'>245 S PID(SEQ)=$G(PID(SEQ))_NXT Q "RTN","RGADTP1",36,0) ; "RTN","RGADTP1",37,0) ;get PID-3 Patient Identifier List (three ids should be returned ICN, SSN, and DFN) "RTN","RGADTP1",38,0) I $G(PID(4))'="" D ;**61 MVI_2970 (dri) problem processing volume of name ids "RTN","RGADTP1",39,0) . N A,ACNT,CNT,ID,IDS,IDSWKD,LASTID,PIDAA,PIDNTC,PIDSITE,PIDXDT,X "RTN","RGADTP1",40,0) . S A="",IDSWKD=0,CNT=1,ACNT=1 "RTN","RGADTP1",41,0) . S IDS=$G(PID(4)),LASTID=$L(IDS,REP) D IDSARR "RTN","RGADTP1",42,0) . F S A=$O(PID(4,A)) Q:A="" S IDS=$G(PID(4,A)),LASTID=$L(IDS,REP) D IDSARR "RTN","RGADTP1",43,0) ; "RTN","RGADTP1",44,0) ;get PID-4 alternate ID (ICN History) "RTN","RGADTP1",45,0) I $G(PID(5))'="" D "RTN","RGADTP1",46,0) . S CNT=1 "RTN","RGADTP1",47,0) . F X=1:1:$L(PID(5),REP) S ARRAY("OID",CNT)=$P(PID(5),REP,X),CNT=CNT+1 "RTN","RGADTP1",48,0) . S Y=0 F S Y=$O(PID(5,Y)) Q:'Y D "RTN","RGADTP1",49,0) .. S ARRAY("OID",CNT-1)=ARRAY("OID",CNT-1)_$P(PID(5,Y),REP) "RTN","RGADTP1",50,0) .. F X=2:1:$L(PID(5,Y),REP) S ARRAY("OID",CNT)=$P(PID(5,Y),REP,X),CNT=CNT+1 "RTN","RGADTP1",51,0) . S X=0 F S X=$O(ARRAY("OID",X)) Q:'X D "RTN","RGADTP1",52,0) .. N ID,AA,AL S ID=$P(ARRAY("OID",X),COMP),AA=$P($P(ARRAY("OID",X),COMP,4),SUBCOMP,1),AL=$P($P(ARRAY("OID",X),COMP,6),SUBCOMP,2) S AL=$$IEN^XUAF4(AL) "RTN","RGADTP1",53,0) .. S ARRAY("OID",X)=ID_"^"_AA_"^"_AL "RTN","RGADTP1",54,0) ; "RTN","RGADTP1",55,0) ;get PID-5 Patient Name "RTN","RGADTP1",56,0) I $G(PID(6))'="" D ;**61 MVI_2970 (dri) problem processing volume of aliases "RTN","RGADTP1",57,0) . N A,ALISWKD,IDCNT,LASTNAM,NAME,NAMES,X "RTN","RGADTP1",58,0) . S A="",ALISWKD=0,IDCNT=1 "RTN","RGADTP1",59,0) . S NAMES=$G(PID(6)),LASTNAM=$L(NAMES,REP) D NAMARR "RTN","RGADTP1",60,0) . F S A=$O(PID(6,A)) Q:A="" S NAMES=$G(PID(6,A)),LASTNAM=$L(NAMES,REP) D NAMARR "RTN","RGADTP1",61,0) ; "RTN","RGADTP1",62,0) ;N KK,JJ,TMPJ,IDCNT2 S IDCNT=1 "RTN","RGADTP1",63,0) ;I $G(PID(6))'="" F IDCNT2=1:1:$L(PID(6),REP) S NAME=$P(PID(6),REP,IDCNT2) D "RTN","RGADTP1",64,0) ;.I $P(NAME,COMP,7)="L" S ARRAY("SURNAME")=$P(NAME,COMP),ARRAY("FIRST")=$P(NAME,COMP,2),ARRAY("MIDDLE")=$P(NAME,COMP,3),ARRAY("PREFIX")=$P(NAME,COMP,4),ARRAY("SUFFIX")=$P(NAME,COMP,5),ARRAY("NAME")=$$FMNAME^HLFNC($P(NAME,COMP,1,6)) Q "RTN","RGADTP1",65,0) ;.I $P(NAME,COMP,7)="A" S $P(ARRAY("ALIAS",IDCNT),"^")=$$FMNAME^HLFNC($P(NAME,COMP,1,6)),IDCNT=IDCNT+1 Q ;**48 ALIAS NAMES? "RTN","RGADTP1",66,0) ;.;**48 alias could send PID(6) to second subscript level "RTN","RGADTP1",67,0) ;.S KK=$O(PID(6,"")) I KK'="" S PID(6,KK)=$P(PID(6),REP,IDCNT2)_PID(6,KK) "RTN","RGADTP1",68,0) ;.S JJ=0 F S JJ=$O(PID(6,JJ)) Q:'JJ D "RTN","RGADTP1",69,0) ;..I JJ'=KK S PID(6,JJ)=$P(PID(6,$O(PID(6,JJ),-1)),REP,TMPJ)_PID(6,JJ) "RTN","RGADTP1",70,0) ;..F TMPJ=1:1:$L(PID(6,JJ),REP) S NAME=$P(PID(6,JJ),REP,TMPJ) D "RTN","RGADTP1",71,0) ;...I $P(NAME,COMP,7)="A" S $P(ARRAY("ALIAS",IDCNT),"^")=$$FMNAME^HLFNC($P(NAME,COMP,1,6)),IDCNT=IDCNT+1 "RTN","RGADTP1",72,0) ; "RTN","RGADTP1",73,0) ;get PID-6 Mother's maiden name "RTN","RGADTP1",74,0) S ARRAY("MMN")=$P($G(PID(7)),COMP,1,5) D "RTN","RGADTP1",75,0) . I $P(ARRAY("MMN"),COMP)'=HL("Q") S HLECH=HL("ECH") S ARRAY("MMN")=$$FREE^RGRSPARS($$FMNAME^HLFNC(ARRAY("MMN"))) Q "RTN","RGADTP1",76,0) . I $P(ARRAY("MMN"),COMP)=HL("Q") S ARRAY("MMN")=$$FREE^RGRSPARS($P(ARRAY("MMN"),COMP)) "RTN","RGADTP1",77,0) ; "RTN","RGADTP1",78,0) ;get PID-7 Date of Birth "RTN","RGADTP1",79,0) ;**47 taking HL("Q") into account "RTN","RGADTP1",80,0) I $G(PID(8))=HL("Q") S PID(8)="@",ARRAY("MPIDOB")="@" "RTN","RGADTP1",81,0) I $G(PID(8))'="@" S ARRAY("MPIDOB")=$$FMDATE^HLFNC($G(PID(8))) "RTN","RGADTP1",82,0) ; "RTN","RGADTP1",83,0) ;get PID-8 Sex "RTN","RGADTP1",84,0) ;**47 taking HL("Q") into account "RTN","RGADTP1",85,0) I $G(PID(9))=HL("Q") S PID(9)="@" "RTN","RGADTP1",86,0) S ARRAY("SEX")=$G(PID(9)) "RTN","RGADTP1",87,0) ; "RTN","RGADTP1",88,0) ;get PID-11-3 ADDRESS BOTH "P"rimary and "N" Place of "RTN","RGADTP1",89,0) S CNT=1 "RTN","RGADTP1",90,0) N ADRTYPE,ADDR "RTN","RGADTP1",91,0) F X=1:1:$L(PID(12),REP) D "RTN","RGADTP1",92,0) . S ADDR=$P(PID(12),REP,X),ADRTYPE=$P(ADDR,COMP,7) "RTN","RGADTP1",93,0) . I ADRTYPE="P" D "RTN","RGADTP1",94,0) .. S ADDR=$$FREE^RGRSPARS(ADDR) "RTN","RGADTP1",95,0) .. S ARRAY(.111)=$$FREE^RGRSPARS($P(ADDR,COMP,1)) ;addr [1] "RTN","RGADTP1",96,0) .. S ARRAY(.112)=$$FREE^RGRSPARS($P(ADDR,COMP,2)) ;addr [2] "RTN","RGADTP1",97,0) .. S ARRAY(.113)=$$FREE^RGRSPARS($P(ADDR,COMP,8)) ;addr [3] "RTN","RGADTP1",98,0) .. S ARRAY(.114)=$$FREE^RGRSPARS($P(ADDR,COMP,3)) ;city "RTN","RGADTP1",99,0) .. S ARRAY(.115)=$$STATE^RGRSPARS($P(ADDR,COMP,4)) ;state "RTN","RGADTP1",100,0) .. S ARRAY(.1112)=$$FREE^RGRSPARS($P(ADDR,COMP,5)) ;zip+4 "RTN","RGADTP1",101,0) .. N CNTYCODE S CNTYCODE=PID(13) ;county code "RTN","RGADTP1",102,0) .. S ARRAY(.117)=$$COUNTY^RGRSPARS(ARRAY(.115),CNTYCODE) "RTN","RGADTP1",103,0) .. S ARRAY(.131)=$$FREE^RGRSPARS(PID(14)) "RTN","RGADTP1",104,0) .. S ARRAY(.132)=$$FREE^RGRSPARS(PID(15)) "RTN","RGADTP1",105,0) . I ADRTYPE="N" D "RTN","RGADTP1",106,0) .. S ARRAY("POBCITY")=$$FREE^RGRSPARS($P(ADDR,COMP,3)) ;POB city "RTN","RGADTP1",107,0) .. S ARRAY("POBSTATE")=$$STATE^RGRSPARS($P(ADDR,COMP,4)) ;POB state "RTN","RGADTP1",108,0) ; "RTN","RGADTP1",109,0) ;marital status "RTN","RGADTP1",110,0) S ARRAY(.05)=$$MARITAL^RGRSPARS(PID(17)) "RTN","RGADTP1",111,0) ; "RTN","RGADTP1",112,0) ;multiple birth indicator **47 "RTN","RGADTP1",113,0) S ARRAY("MBI")=$G(PID(25)) I ARRAY("MBI")=HL("Q") S ARRAY("MBI")="@" ;**47 to get MBI and setup as yes/no field change to @ if HL("Q") "RTN","RGADTP1",114,0) ; "RTN","RGADTP1",115,0) ;;REMOVED FROM PATCH 45 DUE TO NEEDING DG707 "RTN","RGADTP1",116,0) ;religious preference "RTN","RGADTP1",117,0) S ARRAY(.08)=$$RELIG^RGRSPARS(PID(18)) "RTN","RGADTP1",118,0) ; "RTN","RGADTP1",119,0) ;address "RTN","RGADTP1",120,0) ; "RTN","RGADTP1",121,0) ;get PID-29 Date of Death "RTN","RGADTP1",122,0) S ARRAY("MPIDOD")=$$FREE^RGRSPARS($$FMDATE^HLFNC($G(PID(30)))),ARRAY(.351)=ARRAY("MPIDOD") "RTN","RGADTP1",123,0) Q "RTN","RGADTP1",124,0) ; "RTN","RGADTP1",125,0) IDSARR ;parse ids ;**61 MVI_2970 (dri) "RTN","RGADTP1",126,0) F X=1:1:LASTID S ID=$P(IDS,REP,X) D "RTN","RGADTP1",127,0) . I IDSWKD=1 S IDSWKD=0 Q ;first repetition of continuation message already worked "RTN","RGADTP1",128,0) . I X=LASTID,$D(PID(4,A+1)) S ID=ID_$P(PID(4,A+1),REP,1),IDSWKD=1 ;if last repetition check for an extension of message "RTN","RGADTP1",129,0) . ;get id, assigning authority, and name type code "RTN","RGADTP1",130,0) . S PIDAA=$P($P(ID,COMP,4),SUBCOMP),PIDNTC=$P(ID,COMP,5),PIDSITE=$P($P(ID,COMP,6),SUBCOMP,2),PIDXDT=$P(ID,COMP,8) "RTN","RGADTP1",131,0) . S ID=$P(ID,COMP) "RTN","RGADTP1",132,0) . ;Q:ID="" **48 "RTN","RGADTP1",133,0) . ;check assigning authority(0363) AND name type code(0203) "RTN","RGADTP1",134,0) . I PIDAA="USVHA" D Q "RTN","RGADTP1",135,0) .. I PIDNTC="NI" D "RTN","RGADTP1",136,0) ... I $G(PIDXDT)="" S ARRAY("ICN")=ID,ARRAY("MPISSITE")=PIDSITE,ARRAY(991.02)=$P(ID,"V",2) ;National unique individual identifier "RTN","RGADTP1",137,0) ... I $G(PIDXDT)'="" S ARRAY("OID",CNT)=ID_"^"_PIDAA_"^"_PIDSITE_"^"_PIDXDT,CNT=CNT+1 ;Deprecated National unique individual identifier "RTN","RGADTP1",138,0) .. I PIDNTC="PI" S ARRAY("DFN")=ID,ARRAY("DFNLOC")=PIDSITE ;Patient internal identifier "RTN","RGADTP1",139,0) . I PIDAA="USSSA" D Q "RTN","RGADTP1",140,0) .. I PIDNTC="SS",PIDXDT="" S ARRAY("SSN")=ID I ID=HL("Q") S ARRAY("SSN")="@" ;Social Security number **44 (new) look out for alias ssns "RTN","RGADTP1",141,0) .. I PIDNTC="SS",PIDXDT'="" S $P(ARRAY("ALIAS",ACNT),"^",2)=ID,ACNT=ACNT+1 ;**48 store alias ssn "RTN","RGADTP1",142,0) .. ;**47 includes HL("Q") check "RTN","RGADTP1",143,0) . I PIDAA="USVBA" D Q "RTN","RGADTP1",144,0) .. I PIDNTC="PN" S ARRAY("CLAIMN")=ID ;VBA CLAIM# "RTN","RGADTP1",145,0) . ;**59,MVI_880: Get TIN and FIN values "RTN","RGADTP1",146,0) . I PIDAA="USDOD" D Q "RTN","RGADTP1",147,0) .. I PIDNTC="TIN" S ARRAY("TIN")=$S(ID=HL("Q"):"@",1:ID) "RTN","RGADTP1",148,0) .. I PIDNTC="FIN" S ARRAY("FIN")=$S(ID=HL("Q"):"@",1:ID) "RTN","RGADTP1",149,0) . ;**76, VAMPI-11120 (dri) Get ITIN value "RTN","RGADTP1",150,0) . I PIDAA="USIRS" D Q "RTN","RGADTP1",151,0) .. I PIDNTC="NI" S ARRAY("ITIN")=$S(ID=HL("Q"):"@",1:ID) "RTN","RGADTP1",152,0) Q "RTN","RGADTP1",153,0) ; "RTN","RGADTP1",154,0) NAMARR ;parse legal and alias names ;**61 MVI_2970 (dri) "RTN","RGADTP1",155,0) F X=1:1:LASTNAM S NAME=$P(NAMES,REP,X) D "RTN","RGADTP1",156,0) . I ALISWKD=1 S ALISWKD=0 Q ;first repetition of continuation message already worked "RTN","RGADTP1",157,0) . I X=LASTNAM,$D(PID(6,A+1)) S NAME=NAME_$P($G(PID(6,A+1)),REP,1),ALISWKD=1 ;if last repetition check for an extension of message "RTN","RGADTP1",158,0) . I $P(NAME,COMP,7)="L" D Q ;legal "RTN","RGADTP1",159,0) .. ;**71,Story 841921 (mko): Take into account two quotes -- convert to null "RTN","RGADTP1",160,0) .. S ARRAY("SURNAME")=$$QTON($P(NAME,COMP)) "RTN","RGADTP1",161,0) .. S ARRAY("FIRST")=$$QTON($P(NAME,COMP,2)) "RTN","RGADTP1",162,0) .. S ARRAY("MIDDLE")=$$QTON($P(NAME,COMP,3)) "RTN","RGADTP1",163,0) .. S ARRAY("PREFIX")=$$QTON($P(NAME,COMP,5)) "RTN","RGADTP1",164,0) .. S ARRAY("SUFFIX")=$$QTON($P(NAME,COMP,4)) "RTN","RGADTP1",165,0) .. S ARRAY("NAME")=$$FMNAME^HLFNC($P(NAME,COMP,1,4)) "RTN","RGADTP1",166,0) .;**67 - Story 455458 (ckn) - Parse Preferred Name "RTN","RGADTP1",167,0) . I $P(NAME,COMP,7)="N" D "RTN","RGADTP1",168,0) ..N PNAME "RTN","RGADTP1",169,0) ..S PNAME=$P(NAME,COMP) S ARRAY("PREFERREDNAME")=$S(PNAME=HL("Q"):"@",1:PNAME) "RTN","RGADTP1",170,0) .;**71,Story 841921 (mko): Put the name components into ARRAY("ALIAS",n,"NC") "RTN","RGADTP1",171,0) . I $P(NAME,COMP,7)="A" D "RTN","RGADTP1",172,0) .. N ALIASNC,ALIASNM "RTN","RGADTP1",173,0) .. S ALIASNC="" F I=1:1:4 S ALIASNC=ALIASNC_$$QTON($P(NAME,COMP,I))_COMP "RTN","RGADTP1",174,0) .. S ALIASNC=$P(ALIASNC,COMP,1,4),ALIASNM=$$FMNAME^HLFNC(ALIASNC) "RTN","RGADTP1",175,0) .. I $L(ALIASNM)>30,'$$GETFLAG^MPIFNAMC D "RTN","RGADTP1",176,0) ... N ALIAS "RTN","RGADTP1",177,0) ... S ALIAS("SURNAME")=$P(ALIASNC,COMP) "RTN","RGADTP1",178,0) ... S ALIAS("FIRST")=$P(ALIASNC,COMP,2) "RTN","RGADTP1",179,0) ... S ALIAS("MIDDLE")=$P(ALIASNC,COMP,3) "RTN","RGADTP1",180,0) ... S ALIAS("SUFFIX")=$P(ALIASNC,COMP,4) "RTN","RGADTP1",181,0) ... S ALIASNM=$$FMTNAME^RGADTP3(.ALIAS,30) "RTN","RGADTP1",182,0) .. S $P(ARRAY("ALIAS",IDCNT),"^")=ALIASNM "RTN","RGADTP1",183,0) .. S ARRAY("ALIAS",IDCNT,"NC")=$TR(ALIASNC,COMP,"^") "RTN","RGADTP1",184,0) .. S IDCNT=IDCNT+1 ;**48 alias "RTN","RGADTP1",185,0) Q "RTN","RGADTP1",186,0) ; "RTN","RGADTP1",187,0) QTON(X) ;**71,Story 841921 (mko): Convert two quotes to null "RTN","RGADTP1",188,0) Q $S(X="""""":"",1:X) "RTN","RGADTP1",189,0) ; "RTN","RGADTP2") 0^3^B87694121^B74906033 "RTN","RGADTP2",1,0) RGADTP2 ;BIR/DLR-ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS - CONTINUED ;8/17/21 15:36 "RTN","RGADTP2",2,0) ;;1.0;CLINICAL INFO RESOURCE NETWORK;**27,20,45,44,47,48,49,52,54,58,59,64,66,67,71,72,76**;30 Apr 99;Build 1 "RTN","RGADTP2",3,0) DBIA ; "RTN","RGADTP2",4,0) ;Reference to $$ADD^VAFCEHU1 supported by IA #2753 "RTN","RGADTP2",5,0) ;Reference to EDIT^VAFCPTED supported by IA #2784 "RTN","RGADTP2",6,0) ;Reference to ^DPT(DFN,.105) supported by IA #10035 "RTN","RGADTP2",7,0) Q "RTN","RGADTP2",8,0) PROCIN(ARRAY,RGLOCAL,RGER,DFN,HL) ; "RTN","RGADTP2",9,0) N RGRSDFN,OTHSITE,NODE,ICN,CMORIEN,CMOR,SENSTVTY,RMTDOD,LOCDOD,VAFCA,VAFCA08,HERE,BOGUS,ARAY,REP "RTN","RGADTP2",10,0) S REP=$E(HL("ECH"),2) "RTN","RGADTP2",11,0) S HERE=$P($$SITE^VASITE,"^",3) "RTN","RGADTP2",12,0) ;if sending site is your site quit "RTN","RGADTP2",13,0) Q:$G(ARRAY("MPISSITE"))=$G(HERE) "RTN","RGADTP2",14,0) S ARRAY(.097)=$P($$NOW^XLFDT,".") "RTN","RGADTP2",15,0) I $G(ARRAY("ICN"))'="" D "RTN","RGADTP2",16,0) .S RGRSDFN=$$GETDFN^MPIF001(+ARRAY("ICN")) I +RGRSDFN<1 S RGER=RGRSDFN_" ICN#"_$G(ARRAY("ICN")) Q ;quit and return error msg "RTN","RGADTP2",17,0) .S OTHSITE=ARRAY("SENDING SITE") ;**40 REMOVED THE PLUS TO KEEP SUFFIX ON STATION# & CHANGED THE SITE TO BE SENDING SITE INSTEAD OF AUTHORITATIVE SOURCE "RTN","RGADTP2",18,0) I $G(RGRSDFN)="" S RGRSDFN=$G(DFN) "RTN","RGADTP2",19,0) I $G(RGRSDFN)="" S RGER="-1^DFN not defined" "RTN","RGADTP2",20,0) I $G(RGER) Q "RTN","RGADTP2",21,0) I $G(OTHSITE)="" S OTHSITE="" "RTN","RGADTP2",22,0) S NODE=$$MPINODE^MPIFAPI(RGRSDFN) "RTN","RGADTP2",23,0) S ICN=$P(NODE,"^") "RTN","RGADTP2",24,0) S CMORIEN=$P(NODE,"^",3) "RTN","RGADTP2",25,0) ; "RTN","RGADTP2",26,0) ;**58,MPIC_2416: If there is no CMOR for the patient, set CMOR to "". "RTN","RGADTP2",27,0) ; Prevents SUBSCRIPT error that occurs if "" is passed to $$NS^XUAF4. "RTN","RGADTP2",28,0) S CMOR=$S(CMORIEN:$P($$NS^XUAF4(CMORIEN),"^",2),1:"") "RTN","RGADTP2",29,0) ; "RTN","RGADTP2",30,0) ;If patient is Sensitive at other site but not here send bulletin "RTN","RGADTP2",31,0) I $G(ARRAY("SENSITIVITY"))'="" S SENSTVTY=$G(ARRAY("SENSITIVITY")) D "RTN","RGADTP2",32,0) .N NAME S NAME=ARRAY("NAME") "RTN","RGADTP2",33,0) .I '$$SENSTIVE^RGRSENS(RGRSDFN),SENSTVTY D "RTN","RGADTP2",34,0) ..S ARAY("SSN")=ARRAY("SSN"),ARAY("SENDING SITE")=ARRAY("SENDING SITE") "RTN","RGADTP2",35,0) ..S ARAY("SENSITIVITY USER")=ARRAY("SENSITIVITY USER"),ARAY("SENSITIVITY DATE")=ARRAY("SENSITIVITY DATE") "RTN","RGADTP2",36,0) ..D SENSTIVE^RGRSBUL1(RGRSDFN,"ARAY",NAME) "RTN","RGADTP2",37,0) ; "RTN","RGADTP2",38,0) ;MPIC_772 - **52; Commented out Remote Date of Death Indicated section. "RTN","RGADTP2",39,0) ;If patient has DATE OF DEATH (DOD) at remote site send bulletin "RTN","RGADTP2",40,0) ;Ignore time if present with date. "RTN","RGADTP2",41,0) ;S RMTDOD=$G(ARRAY("MPIDOD")),RMTDOD=$P(RMTDOD,".") "RTN","RGADTP2",42,0) ;S DFN=RGRSDFN D DEM^VADPT "RTN","RGADTP2",43,0) ;S LOCDOD=$P($P(VADM(6),"^"),".") "RTN","RGADTP2",44,0) ;If there is a remote DOD but no local DOD OR if remote DOD is different from local DOD, send bulletin "RTN","RGADTP2",45,0) ;I RMTDOD D "RTN","RGADTP2",46,0) ;.N NAME S NAME=ARRAY("NAME"),ARAY("SSN")=ARRAY("SSN"),ARAY("SENDING SITE")=ARRAY("SENDING SITE") "RTN","RGADTP2",47,0) ;.D RMTDOD^RGRSBUL1(RGRSDFN,"ARAY",NAME,RMTDOD,LOCDOD) "RTN","RGADTP2",48,0) ;K VADM "RTN","RGADTP2",49,0) ; "RTN","RGADTP2",50,0) NOTLOC I 'RGLOCAL D "RTN","RGADTP2",51,0) .;**45 if sending site is NOT the CMOR and NOT the MPI - log update into PDR if differences exist "RTN","RGADTP2",52,0) .;**49 stop logging entries into PDR "RTN","RGADTP2",53,0) .;I (OTHSITE)'=(CMOR)&(OTHSITE'="200M") D Q "RTN","RGADTP2",54,0) .;.S VAFCA=$P($$NOW^XLFDT,".")_"^"_$$NOW^XLFDT_"^"_$G(ARRAY("SENDING SITE"))_"^"_RGRSDFN "RTN","RGADTP2",55,0) .;.S ARRAY(.01)=$$FREE^RGRSPARS(ARRAY("NAME")),ARRAY(.03)=$$FREE^RGRSPARS($G(ARRAY("MPIDOB"))) "RTN","RGADTP2",56,0) .;.S ARRAY(.09)=$$FREE^RGRSPARS($G(ARRAY("SSN"))),ARRAY(.02)=$$SEX^RGRSPARS($G(ARRAY("SEX"))) "RTN","RGADTP2",57,0) .;.S ARRAY(.2403)=$$FREE^RGRSPARS($G(ARRAY("MMN"))),ARRAY(991.01)=$P($G(ARRAY("ICN")),"V") "RTN","RGADTP2",58,0) .;.N ARAY M ARAY(2)=ARRAY "RTN","RGADTP2",59,0) .;.S VAFCA08=1 ;S BOGUS=$$ADD^VAFCEHU1(VAFCA,"ARAY") ;used by ^DD's to stop add to adt/hl7 pivot (#391.71) file "RTN","RGADTP2",60,0) .; "RTN","RGADTP2",61,0) .;**45 if sending site is the CMOR OR MPI - synchronize data "RTN","RGADTP2",62,0) .I (OTHSITE)=(CMOR)!(OTHSITE="200M") D "RTN","RGADTP2",63,0) ..I HL("ETN")="A31",$G(RGRSDFN)>0 K ^XTMP("MPIF OLD RECORDS",RGRSDFN) ;**59,MVI_914: Delete the old record designation "RTN","RGADTP2",64,0) ..;**66 - Story 349269 (ckn) - Moved below two lines here from below "RTN","RGADTP2",65,0) ..;to check the differences in field values before checking Inpatient "RTN","RGADTP2",66,0) ..;status and outstanding edit in the ADT/HL7 PIVOT file "RTN","RGADTP2",67,0) ..N DR,ARAY2,INPFLG "RTN","RGADTP2",68,0) ..S RGER="",INPFLG=0 "RTN","RGADTP2",69,0) ..D DIFF^RGADTP3(.ARRAY,RGRSDFN,.DR,.ARAY) ;check for differences ;**59, MVI_881 4th parameter to be 'ARAY' "RTN","RGADTP2",70,0) ..; "RTN","RGADTP2",71,0) ..;**RG*1.0*64/Story 220139 (cml): check for inpatient status, stop update if "RTN","RGADTP2",72,0) ..;patient is currently an inpatient, could cause confusion with treatment if "RTN","RGADTP2",73,0) ..;wristband doesn't match VistA "RTN","RGADTP2",74,0) ..;**RG*1.0*66 - Story 349269 (ckn) - Inpatient Edits pending request shall "RTN","RGADTP2",75,0) ..;only be logged in TK if ID traits-Name, DOB, Gender, SSN or Date of Death "RTN","RGADTP2",76,0) ..;is changed. Also, it should not log unless MBI is getting set to "Yes". "RTN","RGADTP2",77,0) ..;By setting RGER the App Ack will contain "is currently an Inpatient," and "RTN","RGADTP2",78,0) ..;the MPI will see that and log a #6230 request type to TK. "RTN","RGADTP2",79,0) ..I $G(^DPT(RGRSDFN,.105)) D ;patient is an inpatient "RTN","RGADTP2",80,0) ...I DR="" Q ;No edit **72 (cmc) story 1104673 changed name from .01 to 1.01 \/ from patch 71 change to name "RTN","RGADTP2",81,0) ...N I F I="1.01",".02",".03",".09",".351" I (";"_DR)[(";"_I_";") S INPFLG=1 Q "RTN","RGADTP2",82,0) ...I ((";"_DR)[(";"_994_";")),($G(ARRAY("MBI"))="Y") S INPFLG=1 Q "RTN","RGADTP2",83,0) ..I INPFLG S RGER="-1^DFN "_RGRSDFN_": is currently an Inpatient, MPI update not processed." I +RGER<0 Q "RTN","RGADTP2",84,0) ..; "RTN","RGADTP2",85,0) ..;**44 is there an outstanding edit in the ADT/HL7 PIVOT file for this patient for an identity element "RTN","RGADTP2",86,0) ..S RGER=$$CHKPVT^RGADTP3(.ARRAY) I +RGER<0 Q "RTN","RGADTP2",87,0) ..; "RTN","RGADTP2",88,0) ..S RGER="" ;**67, Story 445418 (jfw) Set RGER to "" if 0 returned so that error can be returned in AA. "RTN","RGADTP2",89,0) ..I DR'="" D "RTN","RGADTP2",90,0) ...S VAFCA08=1 ;used by ^DD's to stop add to adt/hl7 pivot (#391.71) file "RTN","RGADTP2",91,0) ...S ARAY(2,.01)=ARRAY("NAME") "RTN","RGADTP2",92,0) ...S ARAY(2,.03)=$G(ARRAY("MPIDOB")) "RTN","RGADTP2",93,0) ...I ARRAY("SSN")'="" S ARAY(2,.09)=$G(ARRAY("SSN")) ;**45 only set SSN to update if it isn't null "RTN","RGADTP2",94,0) ...S ARAY(2,.02)=$G(ARRAY("SEX")) "RTN","RGADTP2",95,0) ...S ARAY(2,.2403)=$G(ARRAY("MMN")) "RTN","RGADTP2",96,0) ...S ARAY(2,994)=$G(ARRAY("MBI")) "RTN","RGADTP2",97,0) ...I $D(ARRAY("ALIAS")) M ARAY(2,1)=ARRAY("ALIAS") ;**48 add alias to mix "RTN","RGADTP2",98,0) ...I $D(ARRAY("SexOr")) M ARAY(2,.025)=ARRAY("SexOr") ;**76, VAMPI-11114 (dri) "RTN","RGADTP2",99,0) ...I $D(ARRAY("Pronoun")) M ARAY(2,.2406)=ARRAY("Pronoun") ;**76, VAMPI-11118 (dri) "RTN","RGADTP2",100,0) ...D EDIT^VAFCPTED(RGRSDFN,"ARAY(2)",DR) ;file differences into patient file "RTN","RGADTP2",101,0) ...; "RTN","RGADTP2",102,0) ...;check to see if edits were successful, if not set RGER="why it failed" "RTN","RGADTP2",103,0) ...N NAME,SSN,PDOB,SEX,MMN,OLDNAME,OLDHLNAM,OLDMMN,OLDHLMMN,HLNAME,HLMMN,MBI "RTN","RGADTP2",104,0) ...S NAME=$$GET1^DIQ(2,+RGRSDFN_",",.01,"I") "RTN","RGADTP2",105,0) ...S PDOB=$$GET1^DIQ(2,+RGRSDFN_",",.03,"I") "RTN","RGADTP2",106,0) ...S SSN=$$GET1^DIQ(2,+RGRSDFN_",",.09,"I") "RTN","RGADTP2",107,0) ...S SEX=$$GET1^DIQ(2,+RGRSDFN_",",.02,"I") "RTN","RGADTP2",108,0) ...S MMN=$$GET1^DIQ(2,+RGRSDFN_",",.2403,"I") "RTN","RGADTP2",109,0) ...S MBI=$$GET1^DIQ(2,+RGRSDFN_",",994,"I") "RTN","RGADTP2",110,0) ...; "RTN","RGADTP2",111,0) ...I PDOB'=$G(ARRAY("MPIDOB")) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"DOB field failure" "RTN","RGADTP2",112,0) ...I SEX'=$G(ARRAY("SEX")) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SEX field failure" "RTN","RGADTP2",113,0) ...I MBI'=$G(ARRAY("MBI")) D "RTN","RGADTP2",114,0) ....I MBI=""&($G(ARRAY("MBI"))="@") Q "RTN","RGADTP2",115,0) ....S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"MULTIPLE BIRTH INDICATOR field failure" "RTN","RGADTP2",116,0) ...D STDNAME^XLFNAME(.MMN,"F",.OLDMMN) S HLMMN=ARRAY("MMN") D STDNAME^XLFNAME(.HLMMN,"F",.OLDHLMMN) I MMN'=$G(HLMMN) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"MOTHER'S MAIDEN NAME field failure" "RTN","RGADTP2",117,0) ...; "RTN","RGADTP2",118,0) ...;**71,Story 841921 (mko): Use this STDNAME method of checking that the name was updated only if the new Name Components flag is not set "RTN","RGADTP2",119,0) ...I '$$GETFLAG^MPIFNAMC D "RTN","RGADTP2",120,0) ....D STDNAME^XLFNAME(.NAME,"F",.OLDNAME) S HLNAME=ARRAY("NAME") D STDNAME^XLFNAME(.HLNAME,"F",.OLDHLNAM) "RTN","RGADTP2",121,0) ....I NAME'=$G(HLNAME) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"Name field failure" "RTN","RGADTP2",122,0) ...; "RTN","RGADTP2",123,0) ...I SSN'=$G(ARRAY("SSN")),$G(ARRAY("SSN"))'="",$G(ARRAY("SSN"))'="@" D ;**54 mpic_1556 added array("ssn")'="@" "RTN","RGADTP2",124,0) ....I $G(ARRAY("SSN"))="P",SSN["P" Q ;**47 need to create a pseudo ssn and did create one "RTN","RGADTP2",125,0) ....S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SSN field failure" ;**45 only check if SSN is sent isn't null "RTN","RGADTP2",126,0) ...; "RTN","RGADTP2",127,0) ...;**48 only set ssn verification status and pseudo ssn reason if ssn update successful "RTN","RGADTP2",128,0) ...I SSN["P" D ;either ssn just became a pseudo or it was already a pseudo and the update to a real ssn failed "RTN","RGADTP2",129,0) ....N SSNV S SSNV=$$GET1^DIQ(2,+RGRSDFN_",",.0907,"I") I SSNV'="" K ARAY2 S ARAY2(2,.0907)="@",DR=".0907;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) ;if pseudo ssn then always delete local ssn verification status "RTN","RGADTP2",130,0) ....S SSNV=$$GET1^DIQ(2,+RGRSDFN_",",.0907,"I") I SSNV'="" S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SSN VERIFICATION field failure" ;if delete doesn't occur log failure "RTN","RGADTP2",131,0) ....; "RTN","RGADTP2",132,0) ....I $S(ARRAY("SSN")="":1,ARRAY("SSN")="@":1,ARRAY("SSN")="P":1,1:0) D ;if local pseudo ssn reason different from the incoming then update "RTN","RGADTP2",133,0) .....N PSNR S PSNR=$$GET1^DIQ(2,+RGRSDFN_",",.0906,"I") "RTN","RGADTP2",134,0) .....I PSNR=""&(ARRAY(.0906)="@") Q "RTN","RGADTP2",135,0) .....I PSNR=ARRAY(.0906) Q "RTN","RGADTP2",136,0) .....K ARAY2 S ARAY2(2,.0906)=$G(ARRAY(.0906)),DR=".0906;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) "RTN","RGADTP2",137,0) .....S PSNR=$$GET1^DIQ(2,+RGRSDFN_",",.0906,"I") "RTN","RGADTP2",138,0) .....I PSNR=""&(ARAY2(2,.0906)="@") Q "RTN","RGADTP2",139,0) .....I PSNR'=ARAY2(2,.0906) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"Pseudo SSN Reason field failure" "RTN","RGADTP2",140,0) ...; "RTN","RGADTP2",141,0) ...I SSN=$G(ARRAY("SSN")) D ;we've got a real ssn, real ssn update would only fail if a duplicate ssn already at site, then no updating would occur "RTN","RGADTP2",142,0) ....N PSNR S PSNR=$$GET1^DIQ(2,+RGRSDFN_",",.0906,"I") I PSNR'="" K ARAY2 S ARAY2(2,.0906)="@",DR=".0906;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) ;if real ssn delete local pseudo ssn reason "RTN","RGADTP2",143,0) ....S PSNR=$$GET1^DIQ(2,+RGRSDFN_",",.0906,"I") I PSNR'="" S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"Pseudo SSN Reason field failure" ;if delete doesn't occur log failure "RTN","RGADTP2",144,0) ....; "RTN","RGADTP2",145,0) ....N SSNV S SSNV=$$GET1^DIQ(2,+RGRSDFN_",",.0907,"I") ;update ssnv if different from local "RTN","RGADTP2",146,0) ....I SSNV=""&(ARRAY(.0907)="@") Q "RTN","RGADTP2",147,0) ....I SSNV=ARRAY(.0907) Q "RTN","RGADTP2",148,0) ....K ARAY2 S ARAY2(2,.0907)=$G(ARRAY(.0907)),DR=".0907;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) "RTN","RGADTP2",149,0) ....S SSNV=$$GET1^DIQ(2,+RGRSDFN_",",.0907,"I") "RTN","RGADTP2",150,0) ....I SSNV=""&(ARAY2(2,.0907)="@") Q "RTN","RGADTP2",151,0) ....I SSNV'=$G(ARAY2(2,.0907)) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SSN VERIFICATION field failure" "RTN","RGADTP2",152,0) ...; "RTN","RGADTP2",153,0) ...;**45 don't trigger A31 sync message if A31 was being processed - ack to a31 will sync id elements on MPI "RTN","RGADTP2",154,0) ...;send the updated fields to the MPI to synch the correlation on the MPI when site receives update from cmor "RTN","RGADTP2",155,0) ...I HL("ETN")'="A31" S ZTSAVE("DFN")="",ZTRTN="MPISYN^RGADTPC",ZTDESC="Sending Synchronized Patient Data to MPI...",ZTIO="RG QUEUE",ZTDTH=$H D ^%ZTLOAD "RTN","RGADTP2",156,0) Q "RTN","RGADTP2",157,0) ; "RTN","RGADTP3") 0^4^B49259679^B44827943 "RTN","RGADTP3",1,0) RGADTP3 ;BIR/CMC-RGADTP2 - CONTINUED ; 12/5/19 12:38pm "RTN","RGADTP3",2,0) ;;1.0;CLINICAL INFO RESOURCE NETWORK;**48,59,63,65,67,68,71,73,76**;30 Apr 99;Build 1 "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 $G(ARRAY("SexOrDes"))'="" D ;**76, VAMPI-11114 (dri) update sexual orientation description "RTN","RGADTP3",78,0) . S SEXORDES=$$GET1^DIQ(2,+RGRSDFN_",",.0251,"I") S:SEXORDES="" SEXORDES="@" "RTN","RGADTP3",79,0) . I SEXORDES'=ARRAY("SexOrDes") S DR=DR_".0251;",ARAY(2,.0251)=ARRAY("SexOrDes") "RTN","RGADTP3",80,0) I $G(ARRAY("PronounDes"))'="" D ;**76, VAMPI-11118 (dri) update pronoun description "RTN","RGADTP3",81,0) . S PRONOUNDES=$$GET1^DIQ(2,+RGRSDFN_",",.24061,"I") S:PRONOUNDES="" PRONOUNDES="@" "RTN","RGADTP3",82,0) . I PRONOUNDES'=ARRAY("PronounDes") S DR=DR_".24061;",ARAY(2,.24061)=ARRAY("PronounDes") "RTN","RGADTP3",83,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",84,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",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",3658,6) ^74 **END** **END**