DPTLK7A ;OAK/MKO-MAS PATIENT LOOKUP ENTERPRISE SEARCH (cont) ;13 May 2020 1:13 PM
;;5.3;Registration;**1024,1139**;Aug 13, 1993;Build 2
;**1024,Story 1258907 (mko): Routine created with subroutines ADDTF and CHKSRCID
Q
;
ADDTF(DFN,IDS) ;Add the Treating Facility returned from the Enterprise Search
;In: DFN = DFN of patient
; IDS(seq#,"ID")=Source ID
; IDS(seq#,"IDTYPE")=Source ID Type (e.g., "PI")
; IDS(seq#,"ISSUER")=Assigning Authority (e.g., "USVHA")
; IDS(seq#,"SOURCE")=Facility (e.g., 500M, "200ESR")
; IDS(seq#,"STATUS")=ID Status (e.g., "A", "H")
N AA,IDSTAT,IDTYPE,SEQ,SRCID,STAIEN,STANUM
D FILE^VAFCTFU(DFN,+$$SITE^VASITE,1,1,,,DFN,"A","USVHA","PI")
S SEQ="" F S SEQ=$O(IDS(SEQ)) Q:SEQ="" D
. S STANUM=$G(IDS(SEQ,"SOURCE"))
. S STAIEN=$$IEN^XUAF4($G(IDS(SEQ,"SOURCE"))) Q:STAIEN'>0
. S SRCID=$$CHKSRCID($G(IDS(SEQ,"ID")),STANUM) Q:SRCID=""
. S IDSTAT=$G(IDS(SEQ,"STATUS"))
. S AA=$G(IDS(SEQ,"ISSUER"))
. S IDTYPE=$G(IDS(SEQ,"IDTYPE"))
. D FILE^VAFCTFU(DFN,STAIEN,1,1,,,SRCID,IDSTAT,AA,IDTYPE)
Q
;
CHKSRCID(SRCID,FCLTY) ;Strip leading and trailing 0s from 200ESR source IDs
N CNT
Q:$G(FCLTY)'="200ESR"!($G(SRCID)="") $G(SRCID)
F CNT=1:1 Q:$E(SRCID,CNT)'=0
S SRCID=$E(SRCID,CNT,999)
S:SRCID?10N1"V"6N1."0" SRCID=$E(SRCID,1,17)
Q SRCID
;
;**1139 VAMPI-26417 (jfw) - Routine DPTLK7 exceeded Max size after updates
; moved FORMATR and new Tag GETCNTY to free up space!
FORMATR(DGF,DGM,DG20NAME) ; - merge MPI and user input (MPI authorative)
N DGX,DGY,DGZ
S DGX=$O(DGM(0)) Q:'DGX
S DG20NAME("FAMILY")=$G(DGM(DGX,"Surname"))
S DG20NAME("GIVEN")=$G(DGM(DGX,"FirstName"))
S DG20NAME("MIDDLE")=$G(DGM(DGX,"MiddleName"))
S DG20NAME("PREFIX")=$G(DGM(DGX,"Prefix"))
S DG20NAME("SUFFIX")=$G(DGM(DGX,"Suffix"))
S DG20NAME("DEGREE")=$G(DGM(DGX,"Degree"))
;Reconstruct name
S DG20NAME=$$NAMEFMT^XLFNAME(.DG20NAME,"F","CFL30")
;Format the .01 value
M DGY=DG20NAME
S DGF(.01)=$$FORMAT^XLFNAME7(.DGY,3,30,,2)
S DGF(.02)=$G(DGM(DGX,"Gender"))
S DGF(.03)=$G(DGM(DGX,"DOB"))
S DGF(.09)=$G(DGM(DGX,"SSN"))
S DGF(.2403)=$G(DGM(DGX,"MMN"))
S DGF(.092)=$G(DGM(DGX,"POBCity"))
S DGY=$S($G(DGM(DGX,"POBState"))]"":$O(^DIC(5,"C",DGM(DGX,"POBState"),0)),1:"")
S DGF(.093)=DGY
;**1139 VAMPI-26417 (jfw) - Convert to new RESIDENTIAL address fields
S:$G(DGM(DGX,"ResAddL1"))]"" DGF(.1151)=DGM(DGX,"ResAddL1")
S:$G(DGM(DGX,"ResAddL2"))]"" DGF(.1152)=DGM(DGX,"ResAddL2")
S:$G(DGM(DGX,"ResAddL3"))]"" DGF(.1153)=DGM(DGX,"ResAddL3")
S:$G(DGM(DGX,"City"))]"" DGF(.1154)=DGM(DGX,"City")
S:$G(DGM(DGX,"ResAddCity"))]"" DGF(.1154)=DGM(DGX,"ResAddCity")
;
S DGY=$S($G(DGM(DGX,"ResAddState"))]"":$O(^DIC(5,"C",DGM(DGX,"ResAddState"),0)),1:"")
S:DGY DGF(.1155)=DGY
S DGY=$S($G(DGM(DGX,"Country"))]"":$O(^HL(779.004,"B",DGM(DGX,"Country"),0)),1:"")
S:DGY DGF(.11573)=DGY
S DGY=$S($G(DGM(DGX,"ResAddCountry"))]"":$O(^HL(779.004,"B",DGM(DGX,"ResAddCountry"),0)),1:"")
S:DGY DGF(.11573)=DGY
S:$G(DGM(DGX,"PCode"))]"" DGF(.11572)=DGM(DGX,"PCode")
S:$G(DGM(DGX,"ResAddPCode"))]"" DGF(.11572)=DGM(DGX,"ResAddPCode")
S:$G(DGM(DGX,"Province"))]"" DGF(.11571)=DGM(DGX,"Province")
S:$G(DGM(DGX,"ResAddProvince"))]"" DGF(.11571)=DGM(DGX,"ResAddProvince")
;**967, Story 827326 (jfw) - Ensure Dash is removed if exists
S:$G(DGM(DGX,"ResAddZip4"))]"" DGF(.1156)=$TR(DGM(DGX,"ResAddZip4"),"-","")
S:$G(DGM(DGX,"ResPhone"))]"" DGF(.131)=DGM(DGX,"ResPhone")
;**1139 VAMPI-26417 (jfw) - Added CORRESPONDENCE address fields
S:$G(DGM(DGX,"CorAddL1"))]"" DGF(.111)=DGM(DGX,"CorAddL1")
S:$G(DGM(DGX,"CorAddL2"))]"" DGF(.112)=DGM(DGX,"CorAddL2")
S:$G(DGM(DGX,"CorAddL3"))]"" DGF(.113)=DGM(DGX,"CorAddL3")
S:$G(DGM(DGX,"CorAddCity"))]"" DGF(.114)=DGM(DGX,"CorAddCity")
S DGY=$S($G(DGM(DGX,"CorAddState"))]"":$O(^DIC(5,"C",DGM(DGX,"CorAddState"),0)),1:"")
S:DGY DGF(.115)=DGY
S DGY=$S($G(DGM(DGX,"CorAddCountry"))]"":$O(^HL(779.004,"B",DGM(DGX,"CorAddCountry"),0)),1:"")
S:DGY DGF(.1173)=DGY
S:$G(DGM(DGX,"CorAddPCode"))]"" DGF(.1172)=DGM(DGX,"CorAddPCode")
S:$G(DGM(DGX,"CorAddProvince"))]"" DGF(.1171)=DGM(DGX,"CorAddProvince")
S:$G(DGM(DGX,"CorAddZip4"))]"" DGF(.1112)=$TR(DGM(DGX,"CorAddZip4"),"-","")
N DGI F DGI=.1112,.1156 D
.Q:'$G(DGF(DGI))
.N DGCNTY S DGCNTY=$$GETCNTY(DGF(DGI))
.I DGCNTY]"" S DGF($S(DGI=.1112:.117,1:.1157))=DGCNTY
;**1139 VAMPI-26417 (jfw) - End Changes
; alias loop
S DGZ=0 F S DGZ=$O(DGM(DGX,"ALIAS",DGZ)) Q:'DGZ D
. N DGY,DG20NAME
. I $G(DGM(DGX,"ALIAS",DGZ,"Surname"))]"" D
.. S DG20NAME("FAMILY")=$G(DGM(DGX,"ALIAS",DGZ,"Surname"))
.. S DG20NAME("GIVEN")=$G(DGM(DGX,"ALIAS",DGZ,"FirstName"))
.. S DG20NAME("MIDDLE")=$G(DGM(DGX,"ALIAS",DGZ,"MiddleName"))
.. S DG20NAME("PREFIX")=$G(DGM(DGX,"ALIAS",DGZ,"Prefix"))
.. S DG20NAME("SUFFIX")=$G(DGM(DGX,"ALIAS",DGZ,"Suffix"))
.. S DG20NAME("DEGREE")=$G(DGM(DGX,"ALIAS",DGZ,"Degree"))
.. ;Reconstruct name
.. S DG20NAME=$$NAMEFMT^XLFNAME(.DG20NAME,"F","CFL30")
.. ;Format the .01 value
.. M DGY=DG20NAME
.. S DGF("ALIAS",DGZ,.01)=$$FORMAT^XLFNAME7(.DGY,3,30,,2)
. I $G(DGM(DGX,"ALIAS",DGZ,"SSN"))]"" S DGF("ALIAS",DGZ,1)=DGM(DGX,"ALIAS",DGZ,"SSN")
S:$G(DGM(DGX,"ICN"))]"" DGF("ICN")=DGM(DGX,"ICN")
;
; - Story 338378 (elz) handle pseudo SSN
I $G(DGF(.09))'?9N S DGF(.09)=$$PSEUDO^DPTLK7($G(DGF(.01)),$G(DGF(.03)))
E K DGF(.0906) ; remove pseudo reason if we have a ssn
;
Q
;
;**1139 VAMPI-26417 (jfw) - Pulled logic from FORMATR to be reuseable
;Input: DGVAL - Zip+4 or Residential Zip+4
;Output: Code that identifies the County for the Zip+4
GETCNTY(DGVAL) ;
N DGX,DGCNTY S DGCNTY=""
D POSTAL^XIPUTIL(DGVAL,.DGX)
I $G(DGX("FIPS CODE"))]"",$G(DGX("STATE POINTER")) D
.S DGCNTY=$$FIND1^DIC(5.01,","_DGX("STATE POINTER")_",","MOXQ",$E($G(DGX("FIPS CODE")),3,5),"C")
Q DGCNTY
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDPTLK7A 5890 printed May 22, 2025@00:19:42 Page 2
DPTLK7A ;OAK/MKO-MAS PATIENT LOOKUP ENTERPRISE SEARCH (cont) ;13 May 2020 1:13 PM
+1 ;;5.3;Registration;**1024,1139**;Aug 13, 1993;Build 2
+2 ;**1024,Story 1258907 (mko): Routine created with subroutines ADDTF and CHKSRCID
+3 QUIT
+4 ;
ADDTF(DFN,IDS) ;Add the Treating Facility returned from the Enterprise Search
+1 ;In: DFN = DFN of patient
+2 ; IDS(seq#,"ID")=Source ID
+3 ; IDS(seq#,"IDTYPE")=Source ID Type (e.g., "PI")
+4 ; IDS(seq#,"ISSUER")=Assigning Authority (e.g., "USVHA")
+5 ; IDS(seq#,"SOURCE")=Facility (e.g., 500M, "200ESR")
+6 ; IDS(seq#,"STATUS")=ID Status (e.g., "A", "H")
+7 NEW AA,IDSTAT,IDTYPE,SEQ,SRCID,STAIEN,STANUM
+8 DO FILE^VAFCTFU(DFN,+$$SITE^VASITE,1,1,,,DFN,"A","USVHA","PI")
+9 SET SEQ=""
FOR
SET SEQ=$ORDER(IDS(SEQ))
if SEQ=""
QUIT
Begin DoDot:1
+10 SET STANUM=$GET(IDS(SEQ,"SOURCE"))
+11 SET STAIEN=$$IEN^XUAF4($GET(IDS(SEQ,"SOURCE")))
if STAIEN'>0
QUIT
+12 SET SRCID=$$CHKSRCID($GET(IDS(SEQ,"ID")),STANUM)
if SRCID=""
QUIT
+13 SET IDSTAT=$GET(IDS(SEQ,"STATUS"))
+14 SET AA=$GET(IDS(SEQ,"ISSUER"))
+15 SET IDTYPE=$GET(IDS(SEQ,"IDTYPE"))
+16 DO FILE^VAFCTFU(DFN,STAIEN,1,1,,,SRCID,IDSTAT,AA,IDTYPE)
End DoDot:1
+17 QUIT
+18 ;
CHKSRCID(SRCID,FCLTY) ;Strip leading and trailing 0s from 200ESR source IDs
+1 NEW CNT
+2 if $GET(FCLTY)'="200ESR"!($GET(SRCID)="")
QUIT $GET(SRCID)
+3 FOR CNT=1:1
if $EXTRACT(SRCID,CNT)'=0
QUIT
+4 SET SRCID=$EXTRACT(SRCID,CNT,999)
+5 if SRCID?10N1"V"6N1."0"
SET SRCID=$EXTRACT(SRCID,1,17)
+6 QUIT SRCID
+7 ;
+8 ;**1139 VAMPI-26417 (jfw) - Routine DPTLK7 exceeded Max size after updates
+9 ; moved FORMATR and new Tag GETCNTY to free up space!
FORMATR(DGF,DGM,DG20NAME) ; - merge MPI and user input (MPI authorative)
+1 NEW DGX,DGY,DGZ
+2 SET DGX=$ORDER(DGM(0))
if 'DGX
QUIT
+3 SET DG20NAME("FAMILY")=$GET(DGM(DGX,"Surname"))
+4 SET DG20NAME("GIVEN")=$GET(DGM(DGX,"FirstName"))
+5 SET DG20NAME("MIDDLE")=$GET(DGM(DGX,"MiddleName"))
+6 SET DG20NAME("PREFIX")=$GET(DGM(DGX,"Prefix"))
+7 SET DG20NAME("SUFFIX")=$GET(DGM(DGX,"Suffix"))
+8 SET DG20NAME("DEGREE")=$GET(DGM(DGX,"Degree"))
+9 ;Reconstruct name
+10 SET DG20NAME=$$NAMEFMT^XLFNAME(.DG20NAME,"F","CFL30")
+11 ;Format the .01 value
+12 MERGE DGY=DG20NAME
+13 SET DGF(.01)=$$FORMAT^XLFNAME7(.DGY,3,30,,2)
+14 SET DGF(.02)=$GET(DGM(DGX,"Gender"))
+15 SET DGF(.03)=$GET(DGM(DGX,"DOB"))
+16 SET DGF(.09)=$GET(DGM(DGX,"SSN"))
+17 SET DGF(.2403)=$GET(DGM(DGX,"MMN"))
+18 SET DGF(.092)=$GET(DGM(DGX,"POBCity"))
+19 SET DGY=$SELECT($GET(DGM(DGX,"POBState"))]"":$ORDER(^DIC(5,"C",DGM(DGX,"POBState"),0)),1:"")
+20 SET DGF(.093)=DGY
+21 ;**1139 VAMPI-26417 (jfw) - Convert to new RESIDENTIAL address fields
+22 if $GET(DGM(DGX,"ResAddL1"))]""
SET DGF(.1151)=DGM(DGX,"ResAddL1")
+23 if $GET(DGM(DGX,"ResAddL2"))]""
SET DGF(.1152)=DGM(DGX,"ResAddL2")
+24 if $GET(DGM(DGX,"ResAddL3"))]""
SET DGF(.1153)=DGM(DGX,"ResAddL3")
+25 if $GET(DGM(DGX,"City"))]""
SET DGF(.1154)=DGM(DGX,"City")
+26 if $GET(DGM(DGX,"ResAddCity"))]""
SET DGF(.1154)=DGM(DGX,"ResAddCity")
+27 ;
+28 SET DGY=$SELECT($GET(DGM(DGX,"ResAddState"))]"":$ORDER(^DIC(5,"C",DGM(DGX,"ResAddState"),0)),1:"")
+29 if DGY
SET DGF(.1155)=DGY
+30 SET DGY=$SELECT($GET(DGM(DGX,"Country"))]"":$ORDER(^HL(779.004,"B",DGM(DGX,"Country"),0)),1:"")
+31 if DGY
SET DGF(.11573)=DGY
+32 SET DGY=$SELECT($GET(DGM(DGX,"ResAddCountry"))]"":$ORDER(^HL(779.004,"B",DGM(DGX,"ResAddCountry"),0)),1:"")
+33 if DGY
SET DGF(.11573)=DGY
+34 if $GET(DGM(DGX,"PCode"))]""
SET DGF(.11572)=DGM(DGX,"PCode")
+35 if $GET(DGM(DGX,"ResAddPCode"))]""
SET DGF(.11572)=DGM(DGX,"ResAddPCode")
+36 if $GET(DGM(DGX,"Province"))]""
SET DGF(.11571)=DGM(DGX,"Province")
+37 if $GET(DGM(DGX,"ResAddProvince"))]""
SET DGF(.11571)=DGM(DGX,"ResAddProvince")
+38 ;**967, Story 827326 (jfw) - Ensure Dash is removed if exists
+39 if $GET(DGM(DGX,"ResAddZip4"))]""
SET DGF(.1156)=$TRANSLATE(DGM(DGX,"ResAddZip4"),"-","")
+40 if $GET(DGM(DGX,"ResPhone"))]""
SET DGF(.131)=DGM(DGX,"ResPhone")
+41 ;**1139 VAMPI-26417 (jfw) - Added CORRESPONDENCE address fields
+42 if $GET(DGM(DGX,"CorAddL1"))]""
SET DGF(.111)=DGM(DGX,"CorAddL1")
+43 if $GET(DGM(DGX,"CorAddL2"))]""
SET DGF(.112)=DGM(DGX,"CorAddL2")
+44 if $GET(DGM(DGX,"CorAddL3"))]""
SET DGF(.113)=DGM(DGX,"CorAddL3")
+45 if $GET(DGM(DGX,"CorAddCity"))]""
SET DGF(.114)=DGM(DGX,"CorAddCity")
+46 SET DGY=$SELECT($GET(DGM(DGX,"CorAddState"))]"":$ORDER(^DIC(5,"C",DGM(DGX,"CorAddState"),0)),1:"")
+47 if DGY
SET DGF(.115)=DGY
+48 SET DGY=$SELECT($GET(DGM(DGX,"CorAddCountry"))]"":$ORDER(^HL(779.004,"B",DGM(DGX,"CorAddCountry"),0)),1:"")
+49 if DGY
SET DGF(.1173)=DGY
+50 if $GET(DGM(DGX,"CorAddPCode"))]""
SET DGF(.1172)=DGM(DGX,"CorAddPCode")
+51 if $GET(DGM(DGX,"CorAddProvince"))]""
SET DGF(.1171)=DGM(DGX,"CorAddProvince")
+52 if $GET(DGM(DGX,"CorAddZip4"))]""
SET DGF(.1112)=$TRANSLATE(DGM(DGX,"CorAddZip4"),"-","")
+53 NEW DGI
FOR DGI=.1112,.1156
Begin DoDot:1
+54 if '$GET(DGF(DGI))
QUIT
+55 NEW DGCNTY
SET DGCNTY=$$GETCNTY(DGF(DGI))
+56 IF DGCNTY]""
SET DGF($SELECT(DGI=.1112:.117,1:.1157))=DGCNTY
End DoDot:1
+57 ;**1139 VAMPI-26417 (jfw) - End Changes
+58 ; alias loop
+59 SET DGZ=0
FOR
SET DGZ=$ORDER(DGM(DGX,"ALIAS",DGZ))
if 'DGZ
QUIT
Begin DoDot:1
+60 NEW DGY,DG20NAME
+61 IF $GET(DGM(DGX,"ALIAS",DGZ,"Surname"))]""
Begin DoDot:2
+62 SET DG20NAME("FAMILY")=$GET(DGM(DGX,"ALIAS",DGZ,"Surname"))
+63 SET DG20NAME("GIVEN")=$GET(DGM(DGX,"ALIAS",DGZ,"FirstName"))
+64 SET DG20NAME("MIDDLE")=$GET(DGM(DGX,"ALIAS",DGZ,"MiddleName"))
+65 SET DG20NAME("PREFIX")=$GET(DGM(DGX,"ALIAS",DGZ,"Prefix"))
+66 SET DG20NAME("SUFFIX")=$GET(DGM(DGX,"ALIAS",DGZ,"Suffix"))
+67 SET DG20NAME("DEGREE")=$GET(DGM(DGX,"ALIAS",DGZ,"Degree"))
+68 ;Reconstruct name
+69 SET DG20NAME=$$NAMEFMT^XLFNAME(.DG20NAME,"F","CFL30")
+70 ;Format the .01 value
+71 MERGE DGY=DG20NAME
+72 SET DGF("ALIAS",DGZ,.01)=$$FORMAT^XLFNAME7(.DGY,3,30,,2)
End DoDot:2
+73 IF $GET(DGM(DGX,"ALIAS",DGZ,"SSN"))]""
SET DGF("ALIAS",DGZ,1)=DGM(DGX,"ALIAS",DGZ,"SSN")
End DoDot:1
+74 if $GET(DGM(DGX,"ICN"))]""
SET DGF("ICN")=DGM(DGX,"ICN")
+75 ;
+76 ; - Story 338378 (elz) handle pseudo SSN
+77 IF $GET(DGF(.09))'?9N
SET DGF(.09)=$$PSEUDO^DPTLK7($GET(DGF(.01)),$GET(DGF(.03)))
+78 ; remove pseudo reason if we have a ssn
IF '$TEST
KILL DGF(.0906)
+79 ;
+80 QUIT
+81 ;
+82 ;**1139 VAMPI-26417 (jfw) - Pulled logic from FORMATR to be reuseable
+83 ;Input: DGVAL - Zip+4 or Residential Zip+4
+84 ;Output: Code that identifies the County for the Zip+4
GETCNTY(DGVAL) ;
+1 NEW DGX,DGCNTY
SET DGCNTY=""
+2 DO POSTAL^XIPUTIL(DGVAL,.DGX)
+3 IF $GET(DGX("FIPS CODE"))]""
IF $GET(DGX("STATE POINTER"))
Begin DoDot:1
+4 SET DGCNTY=$$FIND1^DIC(5.01,","_DGX("STATE POINTER")_",","MOXQ",$EXTRACT($GET(DGX("FIPS CODE")),3,5),"C")
End DoDot:1
+5 QUIT DGCNTY
+6 ;
