Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VPRDJ00

VPRDJ00.m

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