VPRDJ00 ;SLC/MKB -- Patient demographics ;8/11/11 15:29
;;1.0;VIRTUAL PATIENT RECORD;**2,7**;Sep 01, 2011;Build 3
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^AUPNVSIT 2028
; ^DPT 10035
; ^VA(200 10060
; DGCV 4156
; DGMSTAPI 2716
; DGNTAPI 3457
; DGPFAPI 3860
; DGRPDB 4807
; DIC 2051
; DIQ 2056
; MPIF001 2701
; SCAPMC 1916
; SDUTL3 1252
; VADPT 10061
; VAFCTFU1 2990
; VASITE 10112
; XUAF4 2171
;
; All tags expect DFN, VPRID, [VPRSTART, VPRSTOP, VPRMAX, VPRTEXT]
;
DPT1 ; -- Demographics [VPRSTART,VPRSTOP,VPRMAX,VPRID not currently used here]
N PAT,SYS S SYS=$$SITE^VASITE
D DEM,SVC,PRF,ATC,SUPP,ALIAS,FAC,PC
I $D(PAT)>9 D ADD^VPRDJ("PAT")
Q
;
DEM ;-demographic data
N VADM,VA,VAERR,X
S X=+$$GETICN^MPIF001(DFN) S:X>1 PAT("icn")=X
D DEM^VADPT S X=VADM(1),PAT("fullName")=X
S PAT("familyName")=$P(X,","),PAT("givenNames")=$P(X,",",2,99)
S PAT("ssn")=$P(VADM(2),U),PAT("localId")=DFN
S PAT("uid")=$$SETUID^VPRUTILS("patient",DFN,DFN)
S:$D(VA("BID")) PAT("briefId")=$E(X)_VA("BID")
S X=+$P($P(VADM(3),U),"."),PAT("dateOfBirth")=$$JSONDT^VPRUTILS(X)
S X=$P(VADM(5),U),PAT("genderCode")="urn:va:pat-gender:"_X,PAT("genderName")=$$NAME(X,"gender")
S X=+$P($P(VADM(6),U),".") S:X PAT("died")=$$JSONDT^VPRUTILS(X)
S X=$$GET1^DIQ(38.1,DFN_",",2,"I") S:$L(X) PAT("sensitive")=$$BOOL(X)
S X=+VADM(9) S:X PAT("religionCode")="urn:va:pat-religion:"_X,PAT("religionName")=$$NAME(X,"religion")
S X=$P(VADM(10),U,2) I $L(X) D ;PAT("maritalStatus")=$E(X)
. S X=$E(X),X=$S(X="S":"L",X="N":"S",1:X)
. S PAT("maritalStatuses",1,"code")="urn:va:pat-maritalStatus:"_X
. S PAT("maritalStatuses",1,"name")=$$NAME(X,"maritalStatus")
I VADM(11) D
. N I S I=0
. F S I=$O(VADM(11,I)) Q:I<1 S X=+VADM(11,I),PAT("ethnicities",X,"ethnicity")=$$GET1^DIQ(2.06,X_","_DFN_",",".01:3")
I VADM(12) D
. N I S I=0
. F S I=$O(VADM(12,I)) Q:I<1 S X=+VADM(12,I),PAT("races",X,"race")=$$GET1^DIQ(2.02,X_","_DFN_",",".01:3")
I $G(VADM(13)) D
. N I S I=+$O(VADM(13,0)),X=$P($G(VADM(13,I)),U,2)
. S I=$$FIND1^DIC(.85,,"X",X)
. S PAT("languageCode")=$$GET1^DIQ(.85,I_",",.02)
. S PAT("languageName")=X
Q
SVC ;-service data
N VAEL,VASV,VAERR,X,Y,I,AO,IR,PGF,HNC,MST,CV
D 7^VADPT
S PAT("veteran","isVet")=VAEL(4)
S PAT("veteran","serviceConnected")=$$BOOL(+VAEL(3))
S:VAEL(3) PAT("veteran","serviceConnectionPercent")=+$P(VAEL(3),U,2)
S X=+$G(^DPT(DFN,"LR")) S:X PAT("veteran","lrdfn")=X
S:VAEL(2) PAT("servicePeriod")=$P(VAEL(2),U,2)
I VAEL(1) D
. S PAT("eligibility",+VAEL(1),"name")=$P(VAEL(1),U,2)
. S PAT("eligibility",+VAEL(1),"primary")="1",I=0
. F S I=$O(VAEL(1,I)) Q:I<1 S PAT("eligibility",I)=$P(VAEL(1,I),U,2)
S:$L(VAEL(8)) PAT("eligibilityStatus")=$P(VAEL(8),U,2)
S:$L(VAEL(9)) PAT("meansTest")=$P(VAEL(9),U,2)
;
; exposures
S AO=VASV(2),IR=VASV(3)
S PGF=VASV(11)!VASV(12)!VASV(13) ;OIF/OEF
S X=$$GETCUR^DGNTAPI(DFN,"HNC"),X=+($G(HNC("STAT")))
S HNC=$S(X=4:1,X=5:1,X=1:0,X=6:0,1:"")
S X=$P($$GETSTAT^DGMSTAPI(DFN),U,2),MST=$S(X="Y":1,X="N":0,1:"")
S X=$$CVEDT^DGCV(DFN),CV=$S(+X<0:"",+X=0:0,$P(X,U,3):1,1:0)
S X=AO_U_IR_U_PGF_U_HNC_U_MST_U_CV
F P=1:1:6 S I=$P(X,U,P),$P(X,U,P)=$S(I:"Yes",I=0:"No",1:"Unknown")
S NM="agent-orange^ionizing-radiation^sw-asia^head-neck-cancer^mst^combat-vet"
F P=1:1:6 S PAT("exposures",P,"uid")="urn:va:"_$P(NM,U,P)_":"_$E($P(X,U,P)),PAT("exposures",P,"name")=$P(X,U,P)
;
; rated disabilities [DGRPDB]
N VPRDIS,DIS
D RDIS^DGRPDB(DFN,.VPRDIS)
S I=0 F S I=$O(VPRDIS(I)) Q:I<1 D
. S DIS=VPRDIS(I) ;ien^%^sc
. S PAT("disability",I,"name")=$$GET1^DIQ(31,+DIS_",",.01)
. S PAT("disability",I,"sc")=+$P(DIS,U,3)
. S PAT("disability",I,"disPercent")=+$P(DIS,U,2)
. S PAT("disability",I,"vaCode")=+$$GET1^DIQ(31,+DIS_",",2)
Q
PRF ;-patient record flags
N VPRPF,I,NAME,TEXT
Q:'$$GETACT^DGPFAPI(DFN,"VPRPF")
S I=0 F S I=$O(VPRPF(I)) Q:I<1 D
. S NAME=$P(VPRPF(I,"FLAG"),U,2)
. M TEXT=VPRPF(I,"NARR")
. S PAT("flags",I,"name")=NAME
. S PAT("flags",I,"text")=$$STRING^VPRD(.TEXT)
Q
ATC ;-address & telecom
N VAPA,I,X,P,NM
S VAPA("P")="" D ADD^VADPT ;permanent address
S:$L(VAPA(1)) PAT("addresses",1,"streetLine1")=VAPA(1)
S X=VAPA(2) I $L(X),$L(VAPA(3)) S X=X_" "_VAPA(3)
S:$L(X) PAT("addresses",1,"streetLine2")=X
S:$L(VAPA(4)) PAT("addresses",1,"city")=VAPA(4)
S X=$P(VAPA(5),U,2) S:$L(X) PAT("addresses",1,"stateProvince")=X
S X=$P(VAPA(11),U,2) S:$L(X) PAT("addresses",1,"postalCode")=X
;
; X=home^cell^work phones
S X=$$FORMAT(VAPA(8))_U_$$FORMAT($$GET1^DIQ(2,DFN_",",.134))_U_$$FORMAT($$GET1^DIQ(2,DFN_",",.132))
S NM="H^MC^WP" F P=1:1:3 I $L($P(X,U,P)) D
. S I=$P(NM,U,P),PAT("telecoms",P,"usageCode")=I
. S PAT("telecoms",P,"usageName")=$S(I="WP":"work place",I="MC":"mobile contact",1:"home address")
. S PAT("telecoms",P,"telecom")=$P(X,U,P)
Q
SUPP ;-support contacts
N VAOA,A,I,X,TYPE,S
S S=0 F A="",1 K VAOA D
. S:A VAOA("A")=A D OAD^VADPT Q:'$L($G(VAOA(9)))
. S S=S+1,TYPE=$S(A=1:"ECON^Emergency Contact",1:"NOK^Next of Kin")
. S PAT("supports",S,"contactTypeCode")="urn:va:pat-contact:"_$P(TYPE,U)
. S PAT("supports",S,"contactTypeName")=$P(TYPE,U,2)
. S:$L(VAOA(9)) PAT("supports",S,"name")=VAOA(9)
. S:$L(VAOA(10)) PAT("supports",S,"relationship")=VAOA(10)
. S:$L(VAOA(1)) PAT("supports",S,"addresses",1,"streetLine1")=VAOA(1)
. S X=VAOA(2) I $L(X),$L(VAOA(3)) S X=X_" "_VAOA(3)
. S:$L(X) PAT("supports",S,"addresses",1,"streetLine2")=X
. S:$L(VAOA(4)) PAT("supports",S,"addresses",1,"city")=VAOA(4)
. S X=$P(VAOA(5),U,2) S:$L(X) PAT("supports",S,"addresses",1,"stateProvince")=X
. S X=$P(VAOA(11),U,2) S:$L(X) PAT("supports",S,"addresses",1,"postalCode")=X
. S I=$S(A=1:.33011,1:.21011),X=$$FORMAT(VAOA(8))_U_U_$$FORMAT($$GET1^DIQ(2,DFN_",",I))
. ; X=home^cell^work phones
. S NM="H^MC^WP" F P=1:1:3 I $L($P(X,U,P)) D
.. S I=$P(NM,U,P),PAT("supports",S,"telecomList",P,"usageCode")=I
.. S PAT("supports",S,"telecomList",P,"usageName")=$S(I="WP":"work place",I="MC":"mobile contact",1:"home address")
.. S PAT("supports",S,"telecomList",P,"telecom")=$P(X,U,P)
Q
ALIAS ;-other names used
N I,X
S I=0 F S I=$O(^DPT(DFN,.01,I)) Q:I<1 S X=$P($G(^(I,0)),U) D
. S PAT("aliases",I,"fullName")=X
. S PAT("aliases",I,"familyName")=$P(X,",")
. S PAT("aliases",I,"givenNames")=$P(X,",",2,99)
Q
FAC ;-treating facilities [see FACLIST^ORWCIRN]
N IFN S DFN=+$G(DFN) Q:DFN<1
N VPRY,HOME,LAST,I,X,IEN,VASITE
S X=$$ALL^VASITE ;VASITE(stn#)=stn# for all local
I $L($T(TFL^VAFCTFU1)) D TFL^VAFCTFU1(.VPRY,DFN)
S HOME=+$P($G(^DPT(DFN,"MPI")),U,3) ;home facility
I $P($G(VPRY(1)),U)<0 D ;not setup
. S X=$O(^AUPNVSIT("AA",DFN,0)),LAST=$S(X:9999999-$P(X,"."),1:"")
. S X=$$SITE^VASITE
. S VPRY(1)=$P(X,U,3)_U_$P(X,U,2)_U_LAST_U_$$GET1^DIQ(4,+X_",",60)
S I=0 F S I=$O(VPRY(I)) Q:I<1 D
. S X=VPRY(I) Q:$P(X,U)="" ;unknown
. S IEN=+$$IEN^XUAF4($P(X,U))
. I +X=776!(+X=200) S $P(X,U,2)="DEPT. OF DEFENSE"
. S PAT("facilities",I,"code")=$P(X,U) ;stn#
. S PAT("facilities",I,"name")=$P(X,U,2) ;name
. S:IEN=HOME PAT("facilities",I,"homeSite")="true"
. S:$L($P(X,U,3)) PAT("facilities",I,"latestDate")=$$JSONDT^VPRUTILS($P($P(X,U,3),"."))
. I $D(VASITE(+X)) D
.. S PAT("facilities",I,"localPatientId")=DFN
.. S PAT("facilities",I,"systemId")=VPRSYS
Q
PC ;-primary care assignments
N X,I,VPRT,PRV,POS
S X=$$OUTPTPR^SDUTL3(DFN) I X D
. S PAT("pcProviderUid")=$$SETUID^VPRUTILS("user",,+X)
. S PAT("pcProviderName")=$P(X,U,2)
S X=$$OUTPTTM^SDUTL3(DFN) I X D
. S PAT("pcTeamUid")=$$SETUID^VPRUTILS("team",,+X)
. S PAT("pcTeamName")=$$GET1^DIQ(404.51,+X_",",.01)
. S X=$$PRTM^SCAPMC(+X,,,,.VPRT) Q:'X
. S (I,PRV)=0 F S PRV=+$O(@VPRT@("SCPR",PRV)) Q:PRV<1 D
.. S POS=$O(@VPRT@("SCPR",PRV,0)),I=I+1
.. S PAT("pcTeamMembers",I,"uid")=$$SETUID^VPRUTILS("user",,PRV)
.. S PAT("pcTeamMembers",I,"name")=$P($G(^VA(200,PRV,0)),U)
.. S PAT("pcTeamMembers",I,"position")=$$GET1^DIQ(404.57,POS_",",.01)
I $G(^DPT(DFN,.105)) S PAT("inpatient")="true"
Q
;
FORMAT(X) ; -- enforce (xxx)xxx-xxxx phone format
S X=$G(X) I X?1"("3N1")"3N1"-"4N.E Q X
N P,N,I,Y S P=""
F I=1:1:$L(X) S N=$E(X,I) I N=+N S P=P_N
S:$L(P)<10 P=$E("0000000000",1,10-$L(P))_P
S Y=$S(P:"("_$E(P,1,3)_")"_$E(P,4,6)_"-"_$E(P,7,10),1:"")
Q Y
;
NAME(CODE,SET) ; -- Return expanded name for code set
N Y S Y="",CODE=$G(CODE)
I $G(SET)="gender" S Y=$S(CODE="F":"Female",CODE="M":"Male",1:"Unknown")
I $G(SET)="maritalStatus" S Y=$S(CODE="D":"Divorced",CODE="M":"Married",CODE="W":"Widowed",CODE="L":"Legally Separated",CODE="S":"Never Married",1:"Unknown")
I $G(SET)="religion" S Y=$$GET1^DIQ(13,CODE_",",.01)
Q Y
;
BOOL(X) ;
Q $S(X>0:"true",1:"false")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDJ00 9289 printed Sep 23, 2025@20:20:55 Page 2
VPRDJ00 ;SLC/MKB -- Patient demographics ;8/11/11 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**2,7**;Sep 01, 2011;Build 3
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^AUPNVSIT 2028
+7 ; ^DPT 10035
+8 ; ^VA(200 10060
+9 ; DGCV 4156
+10 ; DGMSTAPI 2716
+11 ; DGNTAPI 3457
+12 ; DGPFAPI 3860
+13 ; DGRPDB 4807
+14 ; DIC 2051
+15 ; DIQ 2056
+16 ; MPIF001 2701
+17 ; SCAPMC 1916
+18 ; SDUTL3 1252
+19 ; VADPT 10061
+20 ; VAFCTFU1 2990
+21 ; VASITE 10112
+22 ; XUAF4 2171
+23 ;
+24 ; All tags expect DFN, VPRID, [VPRSTART, VPRSTOP, VPRMAX, VPRTEXT]
+25 ;
DPT1 ; -- Demographics [VPRSTART,VPRSTOP,VPRMAX,VPRID not currently used here]
+1 NEW PAT,SYS
SET SYS=$$SITE^VASITE
+2 DO DEM
DO SVC
DO PRF
DO ATC
DO SUPP
DO ALIAS
DO FAC
DO PC
+3 IF $DATA(PAT)>9
DO ADD^VPRDJ("PAT")
+4 QUIT
+5 ;
DEM ;-demographic data
+1 NEW VADM,VA,VAERR,X
+2 SET X=+$$GETICN^MPIF001(DFN)
if X>1
SET PAT("icn")=X
+3 DO DEM^VADPT
SET X=VADM(1)
SET PAT("fullName")=X
+4 SET PAT("familyName")=$PIECE(X,",")
SET PAT("givenNames")=$PIECE(X,",",2,99)
+5 SET PAT("ssn")=$PIECE(VADM(2),U)
SET PAT("localId")=DFN
+6 SET PAT("uid")=$$SETUID^VPRUTILS("patient",DFN,DFN)
+7 if $DATA(VA("BID"))
SET PAT("briefId")=$EXTRACT(X)_VA("BID")
+8 SET X=+$PIECE($PIECE(VADM(3),U),".")
SET PAT("dateOfBirth")=$$JSONDT^VPRUTILS(X)
+9 SET X=$PIECE(VADM(5),U)
SET PAT("genderCode")="urn:va:pat-gender:"_X
SET PAT("genderName")=$$NAME(X,"gender")
+10 SET X=+$PIECE($PIECE(VADM(6),U),".")
if X
SET PAT("died")=$$JSONDT^VPRUTILS(X)
+11 SET X=$$GET1^DIQ(38.1,DFN_",",2,"I")
if $LENGTH(X)
SET PAT("sensitive")=$$BOOL(X)
+12 SET X=+VADM(9)
if X
SET PAT("religionCode")="urn:va:pat-religion:"_X
SET PAT("religionName")=$$NAME(X,"religion")
+13 ;PAT("maritalStatus")=$E(X)
SET X=$PIECE(VADM(10),U,2)
IF $LENGTH(X)
Begin DoDot:1
+14 SET X=$EXTRACT(X)
SET X=$SELECT(X="S":"L",X="N":"S",1:X)
+15 SET PAT("maritalStatuses",1,"code")="urn:va:pat-maritalStatus:"_X
+16 SET PAT("maritalStatuses",1,"name")=$$NAME(X,"maritalStatus")
End DoDot:1
+17 IF VADM(11)
Begin DoDot:1
+18 NEW I
SET I=0
+19 FOR
SET I=$ORDER(VADM(11,I))
if I<1
QUIT
SET X=+VADM(11,I)
SET PAT("ethnicities",X,"ethnicity")=$$GET1^DIQ(2.06,X_","_DFN_",",".01:3")
End DoDot:1
+20 IF VADM(12)
Begin DoDot:1
+21 NEW I
SET I=0
+22 FOR
SET I=$ORDER(VADM(12,I))
if I<1
QUIT
SET X=+VADM(12,I)
SET PAT("races",X,"race")=$$GET1^DIQ(2.02,X_","_DFN_",",".01:3")
End DoDot:1
+23 IF $GET(VADM(13))
Begin DoDot:1
+24 NEW I
SET I=+$ORDER(VADM(13,0))
SET X=$PIECE($GET(VADM(13,I)),U,2)
+25 SET I=$$FIND1^DIC(.85,,"X",X)
+26 SET PAT("languageCode")=$$GET1^DIQ(.85,I_",",.02)
+27 SET PAT("languageName")=X
End DoDot:1
+28 QUIT
SVC ;-service data
+1 NEW VAEL,VASV,VAERR,X,Y,I,AO,IR,PGF,HNC,MST,CV
+2 DO 7^VADPT
+3 SET PAT("veteran","isVet")=VAEL(4)
+4 SET PAT("veteran","serviceConnected")=$$BOOL(+VAEL(3))
+5 if VAEL(3)
SET PAT("veteran","serviceConnectionPercent")=+$PIECE(VAEL(3),U,2)
+6 SET X=+$GET(^DPT(DFN,"LR"))
if X
SET PAT("veteran","lrdfn")=X
+7 if VAEL(2)
SET PAT("servicePeriod")=$PIECE(VAEL(2),U,2)
+8 IF VAEL(1)
Begin DoDot:1
+9 SET PAT("eligibility",+VAEL(1),"name")=$PIECE(VAEL(1),U,2)
+10 SET PAT("eligibility",+VAEL(1),"primary")="1"
SET I=0
+11 FOR
SET I=$ORDER(VAEL(1,I))
if I<1
QUIT
SET PAT("eligibility",I)=$PIECE(VAEL(1,I),U,2)
End DoDot:1
+12 if $LENGTH(VAEL(8))
SET PAT("eligibilityStatus")=$PIECE(VAEL(8),U,2)
+13 if $LENGTH(VAEL(9))
SET PAT("meansTest")=$PIECE(VAEL(9),U,2)
+14 ;
+15 ; exposures
+16 SET AO=VASV(2)
SET IR=VASV(3)
+17 ;OIF/OEF
SET PGF=VASV(11)!VASV(12)!VASV(13)
+18 SET X=$$GETCUR^DGNTAPI(DFN,"HNC")
SET X=+($GET(HNC("STAT")))
+19 SET HNC=$SELECT(X=4:1,X=5:1,X=1:0,X=6:0,1:"")
+20 SET X=$PIECE($$GETSTAT^DGMSTAPI(DFN),U,2)
SET MST=$SELECT(X="Y":1,X="N":0,1:"")
+21 SET X=$$CVEDT^DGCV(DFN)
SET CV=$SELECT(+X<0:"",+X=0:0,$PIECE(X,U,3):1,1:0)
+22 SET X=AO_U_IR_U_PGF_U_HNC_U_MST_U_CV
+23 FOR P=1:1:6
SET I=$PIECE(X,U,P)
SET $PIECE(X,U,P)=$SELECT(I:"Yes",I=0:"No",1:"Unknown")
+24 SET NM="agent-orange^ionizing-radiation^sw-asia^head-neck-cancer^mst^combat-vet"
+25 FOR P=1:1:6
SET PAT("exposures",P,"uid")="urn:va:"_$PIECE(NM,U,P)_":"_$EXTRACT($PIECE(X,U,P))
SET PAT("exposures",P,"name")=$PIECE(X,U,P)
+26 ;
+27 ; rated disabilities [DGRPDB]
+28 NEW VPRDIS,DIS
+29 DO RDIS^DGRPDB(DFN,.VPRDIS)
+30 SET I=0
FOR
SET I=$ORDER(VPRDIS(I))
if I<1
QUIT
Begin DoDot:1
+31 ;ien^%^sc
SET DIS=VPRDIS(I)
+32 SET PAT("disability",I,"name")=$$GET1^DIQ(31,+DIS_",",.01)
+33 SET PAT("disability",I,"sc")=+$PIECE(DIS,U,3)
+34 SET PAT("disability",I,"disPercent")=+$PIECE(DIS,U,2)
+35 SET PAT("disability",I,"vaCode")=+$$GET1^DIQ(31,+DIS_",",2)
End DoDot:1
+36 QUIT
PRF ;-patient record flags
+1 NEW VPRPF,I,NAME,TEXT
+2 if '$$GETACT^DGPFAPI(DFN,"VPRPF")
QUIT
+3 SET I=0
FOR
SET I=$ORDER(VPRPF(I))
if I<1
QUIT
Begin DoDot:1
+4 SET NAME=$PIECE(VPRPF(I,"FLAG"),U,2)
+5 MERGE TEXT=VPRPF(I,"NARR")
+6 SET PAT("flags",I,"name")=NAME
+7 SET PAT("flags",I,"text")=$$STRING^VPRD(.TEXT)
End DoDot:1
+8 QUIT
ATC ;-address & telecom
+1 NEW VAPA,I,X,P,NM
+2 ;permanent address
SET VAPA("P")=""
DO ADD^VADPT
+3 if $LENGTH(VAPA(1))
SET PAT("addresses",1,"streetLine1")=VAPA(1)
+4 SET X=VAPA(2)
IF $LENGTH(X)
IF $LENGTH(VAPA(3))
SET X=X_" "_VAPA(3)
+5 if $LENGTH(X)
SET PAT("addresses",1,"streetLine2")=X
+6 if $LENGTH(VAPA(4))
SET PAT("addresses",1,"city")=VAPA(4)
+7 SET X=$PIECE(VAPA(5),U,2)
if $LENGTH(X)
SET PAT("addresses",1,"stateProvince")=X
+8 SET X=$PIECE(VAPA(11),U,2)
if $LENGTH(X)
SET PAT("addresses",1,"postalCode")=X
+9 ;
+10 ; X=home^cell^work phones
+11 SET X=$$FORMAT(VAPA(8))_U_$$FORMAT($$GET1^DIQ(2,DFN_",",.134))_U_$$FORMAT($$GET1^DIQ(2,DFN_",",.132))
+12 SET NM="H^MC^WP"
FOR P=1:1:3
IF $LENGTH($PIECE(X,U,P))
Begin DoDot:1
+13 SET I=$PIECE(NM,U,P)
SET PAT("telecoms",P,"usageCode")=I
+14 SET PAT("telecoms",P,"usageName")=$SELECT(I="WP":"work place",I="MC":"mobile contact",1:"home address")
+15 SET PAT("telecoms",P,"telecom")=$PIECE(X,U,P)
End DoDot:1
+16 QUIT
SUPP ;-support contacts
+1 NEW VAOA,A,I,X,TYPE,S
+2 SET S=0
FOR A="",1
KILL VAOA
Begin DoDot:1
+3 if A
SET VAOA("A")=A
DO OAD^VADPT
if '$LENGTH($GET(VAOA(9)))
QUIT
+4 SET S=S+1
SET TYPE=$SELECT(A=1:"ECON^Emergency Contact",1:"NOK^Next of Kin")
+5 SET PAT("supports",S,"contactTypeCode")="urn:va:pat-contact:"_$PIECE(TYPE,U)
+6 SET PAT("supports",S,"contactTypeName")=$PIECE(TYPE,U,2)
+7 if $LENGTH(VAOA(9))
SET PAT("supports",S,"name")=VAOA(9)
+8 if $LENGTH(VAOA(10))
SET PAT("supports",S,"relationship")=VAOA(10)
+9 if $LENGTH(VAOA(1))
SET PAT("supports",S,"addresses",1,"streetLine1")=VAOA(1)
+10 SET X=VAOA(2)
IF $LENGTH(X)
IF $LENGTH(VAOA(3))
SET X=X_" "_VAOA(3)
+11 if $LENGTH(X)
SET PAT("supports",S,"addresses",1,"streetLine2")=X
+12 if $LENGTH(VAOA(4))
SET PAT("supports",S,"addresses",1,"city")=VAOA(4)
+13 SET X=$PIECE(VAOA(5),U,2)
if $LENGTH(X)
SET PAT("supports",S,"addresses",1,"stateProvince")=X
+14 SET X=$PIECE(VAOA(11),U,2)
if $LENGTH(X)
SET PAT("supports",S,"addresses",1,"postalCode")=X
+15 SET I=$SELECT(A=1:.33011,1:.21011)
SET X=$$FORMAT(VAOA(8))_U_U_$$FORMAT($$GET1^DIQ(2,DFN_",",I))
+16 ; X=home^cell^work phones
+17 SET NM="H^MC^WP"
FOR P=1:1:3
IF $LENGTH($PIECE(X,U,P))
Begin DoDot:2
+18 SET I=$PIECE(NM,U,P)
SET PAT("supports",S,"telecomList",P,"usageCode")=I
+19 SET PAT("supports",S,"telecomList",P,"usageName")=$SELECT(I="WP":"work place",I="MC":"mobile contact",1:"home address")
+20 SET PAT("supports",S,"telecomList",P,"telecom")=$PIECE(X,U,P)
End DoDot:2
End DoDot:1
+21 QUIT
ALIAS ;-other names used
+1 NEW I,X
+2 SET I=0
FOR
SET I=$ORDER(^DPT(DFN,.01,I))
if I<1
QUIT
SET X=$PIECE($GET(^(I,0)),U)
Begin DoDot:1
+3 SET PAT("aliases",I,"fullName")=X
+4 SET PAT("aliases",I,"familyName")=$PIECE(X,",")
+5 SET PAT("aliases",I,"givenNames")=$PIECE(X,",",2,99)
End DoDot:1
+6 QUIT
FAC ;-treating facilities [see FACLIST^ORWCIRN]
+1 NEW IFN
SET DFN=+$GET(DFN)
if DFN<1
QUIT
+2 NEW VPRY,HOME,LAST,I,X,IEN,VASITE
+3 ;VASITE(stn#)=stn# for all local
SET X=$$ALL^VASITE
+4 IF $LENGTH($TEXT(TFL^VAFCTFU1))
DO TFL^VAFCTFU1(.VPRY,DFN)
+5 ;home facility
SET HOME=+$PIECE($GET(^DPT(DFN,"MPI")),U,3)
+6 ;not setup
IF $PIECE($GET(VPRY(1)),U)<0
Begin DoDot:1
+7 SET X=$ORDER(^AUPNVSIT("AA",DFN,0))
SET LAST=$SELECT(X:9999999-$PIECE(X,"."),1:"")
+8 SET X=$$SITE^VASITE
+9 SET VPRY(1)=$PIECE(X,U,3)_U_$PIECE(X,U,2)_U_LAST_U_$$GET1^DIQ(4,+X_",",60)
End DoDot:1
+10 SET I=0
FOR
SET I=$ORDER(VPRY(I))
if I<1
QUIT
Begin DoDot:1
+11 ;unknown
SET X=VPRY(I)
if $PIECE(X,U)=""
QUIT
+12 SET IEN=+$$IEN^XUAF4($PIECE(X,U))
+13 IF +X=776!(+X=200)
SET $PIECE(X,U,2)="DEPT. OF DEFENSE"
+14 ;stn#
SET PAT("facilities",I,"code")=$PIECE(X,U)
+15 ;name
SET PAT("facilities",I,"name")=$PIECE(X,U,2)
+16 if IEN=HOME
SET PAT("facilities",I,"homeSite")="true"
+17 if $LENGTH($PIECE(X,U,3))
SET PAT("facilities",I,"latestDate")=$$JSONDT^VPRUTILS($PIECE($PIECE(X,U,3),"."))
+18 IF $DATA(VASITE(+X))
Begin DoDot:2
+19 SET PAT("facilities",I,"localPatientId")=DFN
+20 SET PAT("facilities",I,"systemId")=VPRSYS
End DoDot:2
End DoDot:1
+21 QUIT
PC ;-primary care assignments
+1 NEW X,I,VPRT,PRV,POS
+2 SET X=$$OUTPTPR^SDUTL3(DFN)
IF X
Begin DoDot:1
+3 SET PAT("pcProviderUid")=$$SETUID^VPRUTILS("user",,+X)
+4 SET PAT("pcProviderName")=$PIECE(X,U,2)
End DoDot:1
+5 SET X=$$OUTPTTM^SDUTL3(DFN)
IF X
Begin DoDot:1
+6 SET PAT("pcTeamUid")=$$SETUID^VPRUTILS("team",,+X)
+7 SET PAT("pcTeamName")=$$GET1^DIQ(404.51,+X_",",.01)
+8 SET X=$$PRTM^SCAPMC(+X,,,,.VPRT)
if 'X
QUIT
+9 SET (I,PRV)=0
FOR
SET PRV=+$ORDER(@VPRT@("SCPR",PRV))
if PRV<1
QUIT
Begin DoDot:2
+10 SET POS=$ORDER(@VPRT@("SCPR",PRV,0))
SET I=I+1
+11 SET PAT("pcTeamMembers",I,"uid")=$$SETUID^VPRUTILS("user",,PRV)
+12 SET PAT("pcTeamMembers",I,"name")=$PIECE($GET(^VA(200,PRV,0)),U)
+13 SET PAT("pcTeamMembers",I,"position")=$$GET1^DIQ(404.57,POS_",",.01)
End DoDot:2
End DoDot:1
+14 IF $GET(^DPT(DFN,.105))
SET PAT("inpatient")="true"
+15 QUIT
+16 ;
FORMAT(X) ; -- enforce (xxx)xxx-xxxx phone format
+1 SET X=$GET(X)
IF X?1"("3N1")"3N1"-"4N.E
QUIT X
+2 NEW P,N,I,Y
SET P=""
+3 FOR I=1:1:$LENGTH(X)
SET N=$EXTRACT(X,I)
IF N=+N
SET P=P_N
+4 if $LENGTH(P)<10
SET P=$EXTRACT("0000000000",1,10-$LENGTH(P))_P
+5 SET Y=$SELECT(P:"("_$EXTRACT(P,1,3)_")"_$EXTRACT(P,4,6)_"-"_$EXTRACT(P,7,10),1:"")
+6 QUIT Y
+7 ;
NAME(CODE,SET) ; -- Return expanded name for code set
+1 NEW Y
SET Y=""
SET CODE=$GET(CODE)
+2 IF $GET(SET)="gender"
SET Y=$SELECT(CODE="F":"Female",CODE="M":"Male",1:"Unknown")
+3 IF $GET(SET)="maritalStatus"
SET Y=$SELECT(CODE="D":"Divorced",CODE="M":"Married",CODE="W":"Widowed",CODE="L":"Legally Separated",CODE="S":"Never Married",1:"Unknown")
+4 IF $GET(SET)="religion"
SET Y=$$GET1^DIQ(13,CODE_",",.01)
+5 QUIT Y
+6 ;
BOOL(X) ;
+1 QUIT $SELECT(X>0:"true",1:"false")
