VPRDPT ;SLC/MKB -- Patient demographics extract ;8/11/11 15:29
;;1.0;VIRTUAL PATIENT RECORD;**1,4,5,7**;Sep 01, 2011;Build 3
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^AUPNVSIT 2028
; ^DGSL(38.1 767
; ^DIC(4 10090
; ^DIC(31 733
; ^DIC(42 723,10039
; ^DPT 3581,5597,10035
; ^VA(200 10060
; DGCV 4156
; DGMSTAPI 2716
; DGNTAPI 3457
; DGPFAPI 3860
; DGRPDB 4807
; DIC 2051
; DILFD 2055
; DIQ 2056
; MPIF001 2701
; SCAPMC 1916
; SCAPMCA 2848
; SDUTL3 1252
; VADPT 10061
; VAFCTFU1 2990
; VASITE 10112
; XUAF4 2171
;
; ------------ Get data from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find current patient demographics
; [BEG,END,MAX,ID not currently used]
S DFN=+$G(DFN) Q:DFN<1 ;invalid patient
N PAT,SYS S SYS=$$SITE^VASITE
D DEM,SVC,PRF,ATC,SUPP,ALIAS,FAC,INPT,PC
I $D(PAT)>9 D XML(.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("id")=DFN
S:$D(VA("BID")) PAT("bid")=$E(X)_VA("BID")
S PAT("dob")=+$P($P(VADM(3),U),".")
S PAT("gender")=$P(VADM(5),U)
S PAT("lrdfn")=+$G(^DPT(DFN,"LR"))
S X=+$P($P(VADM(6),U),".") S:X PAT("died")=X
S X=$$GET1^DIQ(38.1,DFN_",",2,"I") S:$L(X) PAT("sensitive")=X
S X=+VADM(9) S:X PAT("religion")=X
S X=$P(VADM(10),U,2) S:$L(X) PAT("maritalStatus")=$E(X)
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("ethnicity",X)=$$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("race",X)=$$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("language")=$$GET1^DIQ(.85,I_",",.02)_U_X
Q
SVC ;-service data
N VAEL,VASV,VAERR,X,Y,I,AO,IR,PGF,HNC,MST,CV
D 7^VADPT
S PAT("veteran")=VAEL(4)
S PAT("sc")=+VAEL(3) S:VAEL(3) PAT("scPercent")=+$P(VAEL(3),U,2)
S:VAEL(2) PAT("servicePeriod")=$P(VAEL(2),U,2)
I VAEL(1) D
. S PAT("eligibility",+VAEL(1))=$P(VAEL(1),U,2)_"^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 PAT("exposures")=AO_U_IR_U_PGF_U_HNC_U_MST_U_CV
;
; rated disabilities [DGRPDB]
N VPRDIS,DIS,NM,DX
D RDIS^DGRPDB(DFN,.VPRDIS)
S I=0 F S I=$O(VPRDIS(I)) Q:I<1 D
. S DIS=VPRDIS(I)
. S NM=$$GET1^DIQ(31,+DIS_",",.01),DX=$$GET1^DIQ(31,+DIS_",",2)
. S PAT("disability",+DX)=NM_U_$P(DIS,U,3)_U_$P(DIS,U,2) ;name^sc^%
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("flag",I)=NAME_U_$$STRING^VPRD(.TEXT)
Q
ATC ;-address & telecom
N VAPA,I,X
S VAPA("P")="" D ADD^VADPT ;permanent address
S X="" F I=1:1:4 S X=X_VAPA(I)_U
S X=X_$P(VAPA(5),U,2)_U_$P(VAPA(11),U,2)
S PAT("address")=X ;street1^st2^st3^city^state^zip
S X=$$FORMAT(VAPA(8))_U_$$FORMAT($$GET1^DIQ(2,DFN_",",.134))_U_$$FORMAT($$GET1^DIQ(2,DFN_",",.132))
S PAT("telecom")=X ;home^cell^work phones
Q
SUPP ;-support contacts
N VAOA,A,I,X,TYPE
F A="",1 K VAOA D
. S:A VAOA("A")=A D OAD^VADPT Q:'$L($G(VAOA(9)))
. S TYPE=$S(A=1:"ECON",1:"NOK")
. S PAT("support",TYPE)=VAOA(9)_U_VAOA(10) ;name^relationship
. S X="" F I=1:1:4 S X=X_VAOA(I)_U
. S X=X_$P(VAOA(5),U,2)_U_$P(VAOA(11),U,2)
. S PAT("support",TYPE,"address")=X ;street1^st2^st3^city^state^zip
. S I=$S(A=1:.33011,1:.21011),X=$$FORMAT(VAOA(8))_U_U_$$FORMAT($$GET1^DIQ(2,DFN_",",I))
. S PAT("support",TYPE,"telecom")=X ;home^cell^work phones
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("alias",I)=X_U_$P(X,",")_U_$P(X,",",2,99)
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
FAC ;-treating facilities [see FACLIST^ORWCIRN]
N IFN S DFN=+$G(DFN) Q:DFN<1
N VPRY,HOME,LAST,I,X,IEN
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 Q ;not setup
. S X=$O(^AUPNVSIT("AA",DFN,0)),LAST=$S(X:9999999-$P(X,"."),1:"")
. S X=$$SITE^VASITE
. S PAT("facility",+X)=$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("facility",IEN)=$P(X,U,1,2)_U_$P($P(X,U,3),".")
. ; = stn# ^ name ^ last date ^ VistA domain
. S $P(PAT("facility",IEN),U,4)=$$GET1^DIQ(4,IEN_",",60)
. I IEN=HOME S $P(PAT("facility",IEN),U,5)=1
Q
INPT ;-current inpt status
N ADM,X,VAIN,VAERR,HLOC,SVC
S ADM=+$G(^DPT(DFN,.105)) I ADM D
. D INP^VADPT S PAT("admitted")=ADM_U_+VAIN(7)
. S PAT("ward")=VAIN(4),PAT("roomBed")=VAIN(5)
. S HLOC=+$G(^DIC(42,+VAIN(4),44)),SVC=$P($G(^(0)),U,3)
. S PAT("location")=HLOC_U_$P(VAIN(4),U,2)
. S:$L(SVC) PAT("locSvc")=SVC_U_$$EXTERNAL^DILFD(42,.03,,SVC)
. S PAT("specialty")=VAIN(3)
. S PAT("attending")=VAIN(11)
. S X=$$FAC^VPRD(HLOC),PAT("site")=X
S PAT("inpatient")=$S(ADM:"true",1:"false")
Q
ZPC ;-primary care [not used: GETALL not returning team members]
N TEAM,VPRPC,VPRI,VPRTM,PCPR,FAC,X,ST
S TEAM=$$INSTPCTM^SCAPMC(DFN) Q:'TEAM ;teamIEN^name^instIEN^name
S PAT("pcTeam")=$P(TEAM,U,1,2)
D GETALL^SCAPMCA(DFN,,.VPRPC)
S VPRI=+$O(@VPRPC@(DFN,"TM",+TEAM,0)),VPRTM=$G(^(VPRI))
S:$P(VPRTM,U,4) PAT("pcAssigned")=$P(VPRTM,U,4)
S PCPR=$G(@VPRPC@(DFN,"PCPR",1)) I PCPR D
. S PAT("pcProvider")=$P(PCPR,U,1,2)_U_$$PROVSPC^VPRD(+PCPR)
. S FAC=$P(TEAM,U,3,4) S:FAC<1 FAC=$$SITE^VASITE
. S X=$$PADD^XUAF4(+FAC) ;street^city^st^zip
. S ST=$$GET1^DIQ(4,+FAC_",",.02) S:ST="" ST=$P(X,U,3) ;get state name
. S PAT("pcProvider","address")=$P(X,U)_"^^^"_$P(X,U,2)_U_ST_U_$P(X,U,4)
; get team members
S VPRI=0 F S VPRI=$O(@VPRPC@(DFN,"TM",+VPRTM,+$P(VPRTM,U,3),"POS",VPRI)) Q:VPRI<1 I +$G(^(VPRI))'=$P(PCPR,U,3) D
. S I=+$O(@VPRPC@(DFN,"TM",+VPRTM,+$P(VPRTM,U,3),"POS",VPRI,"PROV",0)),X=$G(^(I)) Q:X=""
. S POS=$S($L($P(X,U,8)):$P(X,U,8),1:$P(X,U,4))
. S PAT("pcTeamMember",I)=$P(X,U,1,2)_U_POS_U_$$PROVSPC^VPRD(+X)
K @VPRPC
Q
;
PC ;-primary care
N TEAM,X,VPRT,PRV,POS,FAC,ST,I
S TEAM=$$INSTPCTM^SCAPMC(DFN) I TEAM D ;PC teamIEN^name^instIEN^name
. S PAT("pcTeam")=$P(TEAM,U,1,2)
. S X=$$TMPT^SCAPMC(DFN,,,.VPRT) I X S I=0 F S I=$O(@VPRT@(I)) Q:I<1 I +$G(@VPRT@(I))=+TEAM S PAT("pcAssigned")=$P(@VPRT@(I),U,4) Q
. K @VPRT,VPRT,X
. S X=$$PRTM^SCAPMC(+TEAM,,,,.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))
.. S X=PRV_U_$P($G(^VA(200,PRV,0)),U)
.. S POS=$$GET1^DIQ(404.57,POS_",",.01)
.. S I=I+1,PAT("pcTeamMember",I)=X_U_POS_U_$$PROVSPC^VPRD(+X)
. K @VPRT,VPRT,X
S X=$$OUTPTPR^SDUTL3(DFN) I X D
. S PAT("pcProvider")=X_U_$$PROVSPC^VPRD(+X)
. S FAC=$P(TEAM,U,3,4) S:FAC<1 FAC=$$SITE^VASITE
. S X=$$PADD^XUAF4(+FAC) ;street^city^st^zip
. S ST=$$GET1^DIQ(4,+FAC_",",.02) S:ST="" ST=$P(X,U,3) ;get state name
. S PAT("pcProvider","address")=$P(X,U)_"^^^"_$P(X,U,2)_U_ST_U_$P(X,U,4)
Q
;
; ------------ Return data to middle tier ------------
;
XML(ITEM) ; -- Return patient data as XML in @VPR@(n)
; as <element code='123' displayName='ABC' />
N ATT,X,Y,NAMES,I,ID
D ADD("<patient>") S VPRTOTL=$G(VPRTOTL)+1
S ATT="" F S ATT=$O(ITEM(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
. S X=$G(ITEM(ATT)),NAMES=$$LABELS(ATT),Y=""
. I ATT="pcProvider" D Q
.. S Y="<"_ATT_" "_$$LOOP_">" D ADD(Y)
.. S X=$G(ITEM(ATT,"address")) I $L(X) D ADDR(X)
.. D ADD("</"_ATT_">") S Y=""
. ;
. I $L($O(ITEM(ATT,""))) D Q ;multiples
.. S ID=$S($E(ATT,$L(ATT))="s":ATT_"es",$E(ATT,$L(ATT))="y":$E(ATT,1,$L(ATT)-1)_"ies",1:ATT_"s")
.. D ADD("<"_ID_">")
.. S I="" F S I=$O(ITEM(ATT,I)) Q:I="" D
... S X=ITEM(ATT,I),Y="<"_ATT_" "
... I ATT="support" D S Y="" Q
.... S Y=Y_"contactType='"_I_"' "_$$LOOP_">" D ADD(Y)
.... S X=$G(ITEM(ATT,I,"address")) I $L(X) D ADDR(X)
.... S X=$G(ITEM(ATT,I,"telecom")) I $L(X) D PHONE(X)
.... D ADD("</support>")
... I ATT="disability" S Y=Y_"vaCode='"_I_"' "
... S Y=Y_$$LOOP_"/>" D ADD(Y)
.. D ADD("</"_ID_">") S Y=""
. ;
. I ATT="exposures" D:X["1" S Y="" Q
.. S I=0,Y="<exposures>" D ADD(Y)
.. F ID="AO","IR","PG","HNC","MST","CV" S I=I+1 I $P(X,U,I) S Y="<exposure value='"_ID_"' />" D ADD(Y)
.. D ADD("</exposures>")
. ;
. I ATT="address" D ADDR(X) S Y="" Q
. I ATT="telecom" D PHONE(X) S Y="" Q
. ;
. Q:X="" ;no data
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />" Q
. I $L(X)>1 S Y="<"_ATT_" "_$$LOOP_"/>"
D ADD("</patient>")
Q
;
ADDR(X) ; -- XML address node from X=street1^st2^st3^city^state^zip
N I,Y Q:$L(X)'>5 ;no data
S Y="<address"
F I=1,2,3 I $L($P(X,U,I)) S Y=Y_" streetLine"_I_"='"_$$ESC^VPRD($P(X,U,I))_"'"
I $L($P(X,U,4)) S Y=Y_" city='"_$$ESC^VPRD($P(X,U,4))_"'"
I $L($P(X,U,5)) S Y=Y_" stateProvince='"_$P(X,U,5)_"'"
I $L($P(X,U,6)) S Y=Y_" postalCode='"_$P(X,U,6)_"'"
S Y=Y_" />" D ADD(Y)
Q
;
PHONE(X) ; -- XML telecom node from X=home^cell^work numbers
N I,Y Q:$L(X)'>2 ;no data
D ADD("<telecomList>")
I $L($P(X,U,1)) S Y="<telecom usageType='H' value='"_$P(X,U,1)_"' />" D ADD(Y)
I $L($P(X,U,2)) S Y="<telecom usageType='MC' value='"_$P(X,U,2)_"' />" D ADD(Y)
I $L($P(X,U,3)) S Y="<telecom usageType='WP' value='"_$P(X,U,3)_"' />" D ADD(Y)
D ADD("</telecomList>")
Q
;
LOOP() ; -- build sub-items string from NAMES and X
N STR,P,TAG S STR=""
F P=1:1 S TAG=$P(NAMES,U,P) Q:TAG="Z" I $L($P(X,U,P)) S STR=STR_TAG_"='"_$$ESC^VPRD($P(X,U,P))_"' "
Q STR
;
ADD(X) ; Add a line @VPR@(n)=X
S VPRI=$G(VPRI)+1
S @VPR@(VPRI)=X
Q
;
LABELS(X) ; -- return string of attribute labels for element X
N Y S Y="code^name^Z"
I X="pcProvider" S Y="code^name^"_$$PROVTAGS^VPRD_"^Z"
I X="support" S Y="name^relationship^Z"
I X="eligibility" S Y="name^primary^Z"
I X="disability" S Y="printName^sc^scPercent^Z"
I X="alias" S Y="fullName^familyName^givenNames^Z"
I X="flag" S Y="name^text^Z"
I X="facility" S Y="code^name^latestDate^domain^homeSite^Z"
I X="pcTeamMember" S Y="code^name^role^"_$$PROVTAGS^VPRD_"^Z"
I X="ethnicity"!(X="race") S Y="value^Z"
I X="admitted" S Y="id^date^Z"
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDPT 11688 printed Apr 09, 2024@21:47:31 Page 2
VPRDPT ;SLC/MKB -- Patient demographics extract ;8/11/11 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**1,4,5,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 ; ^DGSL(38.1 767
+8 ; ^DIC(4 10090
+9 ; ^DIC(31 733
+10 ; ^DIC(42 723,10039
+11 ; ^DPT 3581,5597,10035
+12 ; ^VA(200 10060
+13 ; DGCV 4156
+14 ; DGMSTAPI 2716
+15 ; DGNTAPI 3457
+16 ; DGPFAPI 3860
+17 ; DGRPDB 4807
+18 ; DIC 2051
+19 ; DILFD 2055
+20 ; DIQ 2056
+21 ; MPIF001 2701
+22 ; SCAPMC 1916
+23 ; SCAPMCA 2848
+24 ; SDUTL3 1252
+25 ; VADPT 10061
+26 ; VAFCTFU1 2990
+27 ; VASITE 10112
+28 ; XUAF4 2171
+29 ;
+30 ; ------------ Get data from VistA ------------
+31 ;
EN(DFN,BEG,END,MAX,ID) ; -- find current patient demographics
+1 ; [BEG,END,MAX,ID not currently used]
+2 ;invalid patient
SET DFN=+$GET(DFN)
if DFN<1
QUIT
+3 NEW PAT,SYS
SET SYS=$$SITE^VASITE
+4 DO DEM
DO SVC
DO PRF
DO ATC
DO SUPP
DO ALIAS
DO FAC
DO INPT
DO PC
+5 IF $DATA(PAT)>9
DO XML(.PAT)
+6 QUIT
+7 ;
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("id")=DFN
+6 if $DATA(VA("BID"))
SET PAT("bid")=$EXTRACT(X)_VA("BID")
+7 SET PAT("dob")=+$PIECE($PIECE(VADM(3),U),".")
+8 SET PAT("gender")=$PIECE(VADM(5),U)
+9 SET PAT("lrdfn")=+$GET(^DPT(DFN,"LR"))
+10 SET X=+$PIECE($PIECE(VADM(6),U),".")
if X
SET PAT("died")=X
+11 SET X=$$GET1^DIQ(38.1,DFN_",",2,"I")
if $LENGTH(X)
SET PAT("sensitive")=X
+12 SET X=+VADM(9)
if X
SET PAT("religion")=X
+13 SET X=$PIECE(VADM(10),U,2)
if $LENGTH(X)
SET PAT("maritalStatus")=$EXTRACT(X)
+14 IF VADM(11)
Begin DoDot:1
+15 NEW I
SET I=0
+16 FOR
SET I=$ORDER(VADM(11,I))
if I<1
QUIT
SET X=+VADM(11,I)
SET PAT("ethnicity",X)=$$GET1^DIQ(2.06,X_","_DFN_",",".01:3")
End DoDot:1
+17 IF VADM(12)
Begin DoDot:1
+18 NEW I
SET I=0
+19 FOR
SET I=$ORDER(VADM(12,I))
if I<1
QUIT
SET X=+VADM(12,I)
SET PAT("race",X)=$$GET1^DIQ(2.02,X_","_DFN_",",".01:3")
End DoDot:1
+20 IF $GET(VADM(13))
Begin DoDot:1
+21 NEW I
SET I=+$ORDER(VADM(13,0))
SET X=$PIECE($GET(VADM(13,I)),U,2)
+22 SET I=$$FIND1^DIC(.85,,"X",X)
+23 SET PAT("language")=$$GET1^DIQ(.85,I_",",.02)_U_X
End DoDot:1
+24 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")=VAEL(4)
+4 SET PAT("sc")=+VAEL(3)
if VAEL(3)
SET PAT("scPercent")=+$PIECE(VAEL(3),U,2)
+5 if VAEL(2)
SET PAT("servicePeriod")=$PIECE(VAEL(2),U,2)
+6 IF VAEL(1)
Begin DoDot:1
+7 SET PAT("eligibility",+VAEL(1))=$PIECE(VAEL(1),U,2)_"^1"
SET I=0
+8 FOR
SET I=$ORDER(VAEL(1,I))
if I<1
QUIT
SET PAT("eligibility",I)=$PIECE(VAEL(1,I),U,2)
End DoDot:1
+9 if $LENGTH(VAEL(8))
SET PAT("eligibilityStatus")=$PIECE(VAEL(8),U,2)
+10 if $LENGTH(VAEL(9))
SET PAT("meansTest")=$PIECE(VAEL(9),U,2)
+11 ;
+12 ; exposures
+13 SET AO=VASV(2)
SET IR=VASV(3)
+14 ;OIF/OEF
SET PGF=VASV(11)!VASV(12)!VASV(13)
+15 SET X=$$GETCUR^DGNTAPI(DFN,"HNC")
SET X=+($GET(HNC("STAT")))
+16 SET HNC=$SELECT(X=4:1,X=5:1,X=1:0,X=6:0,1:"")
+17 SET X=$PIECE($$GETSTAT^DGMSTAPI(DFN),U,2)
SET MST=$SELECT(X="Y":1,X="N":0,1:"")
+18 SET X=$$CVEDT^DGCV(DFN)
SET CV=$SELECT(+X<0:"",+X=0:0,$PIECE(X,U,3):1,1:0)
+19 SET PAT("exposures")=AO_U_IR_U_PGF_U_HNC_U_MST_U_CV
+20 ;
+21 ; rated disabilities [DGRPDB]
+22 NEW VPRDIS,DIS,NM,DX
+23 DO RDIS^DGRPDB(DFN,.VPRDIS)
+24 SET I=0
FOR
SET I=$ORDER(VPRDIS(I))
if I<1
QUIT
Begin DoDot:1
+25 SET DIS=VPRDIS(I)
+26 SET NM=$$GET1^DIQ(31,+DIS_",",.01)
SET DX=$$GET1^DIQ(31,+DIS_",",2)
+27 ;name^sc^%
SET PAT("disability",+DX)=NM_U_$PIECE(DIS,U,3)_U_$PIECE(DIS,U,2)
End DoDot:1
+28 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("flag",I)=NAME_U_$$STRING^VPRD(.TEXT)
End DoDot:1
+7 QUIT
ATC ;-address & telecom
+1 NEW VAPA,I,X
+2 ;permanent address
SET VAPA("P")=""
DO ADD^VADPT
+3 SET X=""
FOR I=1:1:4
SET X=X_VAPA(I)_U
+4 SET X=X_$PIECE(VAPA(5),U,2)_U_$PIECE(VAPA(11),U,2)
+5 ;street1^st2^st3^city^state^zip
SET PAT("address")=X
+6 SET X=$$FORMAT(VAPA(8))_U_$$FORMAT($$GET1^DIQ(2,DFN_",",.134))_U_$$FORMAT($$GET1^DIQ(2,DFN_",",.132))
+7 ;home^cell^work phones
SET PAT("telecom")=X
+8 QUIT
SUPP ;-support contacts
+1 NEW VAOA,A,I,X,TYPE
+2 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 TYPE=$SELECT(A=1:"ECON",1:"NOK")
+5 ;name^relationship
SET PAT("support",TYPE)=VAOA(9)_U_VAOA(10)
+6 SET X=""
FOR I=1:1:4
SET X=X_VAOA(I)_U
+7 SET X=X_$PIECE(VAOA(5),U,2)_U_$PIECE(VAOA(11),U,2)
+8 ;street1^st2^st3^city^state^zip
SET PAT("support",TYPE,"address")=X
+9 SET I=$SELECT(A=1:.33011,1:.21011)
SET X=$$FORMAT(VAOA(8))_U_U_$$FORMAT($$GET1^DIQ(2,DFN_",",I))
+10 ;home^cell^work phones
SET PAT("support",TYPE,"telecom")=X
End DoDot:1
+11 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("alias",I)=X_U_$PIECE(X,",")_U_$PIECE(X,",",2,99)
End DoDot:1
+4 QUIT
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
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
+3 IF $LENGTH($TEXT(TFL^VAFCTFU1))
DO TFL^VAFCTFU1(.VPRY,DFN)
+4 ;home facility
SET HOME=+$PIECE($GET(^DPT(DFN,"MPI")),U,3)
+5 ;not setup
IF $PIECE($GET(VPRY(1)),U)<0
Begin DoDot:1
+6 SET X=$ORDER(^AUPNVSIT("AA",DFN,0))
SET LAST=$SELECT(X:9999999-$PIECE(X,"."),1:"")
+7 SET X=$$SITE^VASITE
+8 SET PAT("facility",+X)=$PIECE(X,U,3)_U_$PIECE(X,U,2)_U_LAST_U_$$GET1^DIQ(4,+X_",",60)
End DoDot:1
QUIT
+9 SET I=0
FOR
SET I=$ORDER(VPRY(I))
if I<1
QUIT
Begin DoDot:1
+10 ;unknown
SET X=VPRY(I)
if $PIECE(X,U)=""
QUIT
+11 SET IEN=+$$IEN^XUAF4($PIECE(X,U))
+12 IF +X=776!(+X=200)
SET $PIECE(X,U,2)="DEPT. OF DEFENSE"
+13 SET PAT("facility",IEN)=$PIECE(X,U,1,2)_U_$PIECE($PIECE(X,U,3),".")
+14 ; = stn# ^ name ^ last date ^ VistA domain
+15 SET $PIECE(PAT("facility",IEN),U,4)=$$GET1^DIQ(4,IEN_",",60)
+16 IF IEN=HOME
SET $PIECE(PAT("facility",IEN),U,5)=1
End DoDot:1
+17 QUIT
INPT ;-current inpt status
+1 NEW ADM,X,VAIN,VAERR,HLOC,SVC
+2 SET ADM=+$GET(^DPT(DFN,.105))
IF ADM
Begin DoDot:1
+3 DO INP^VADPT
SET PAT("admitted")=ADM_U_+VAIN(7)
+4 SET PAT("ward")=VAIN(4)
SET PAT("roomBed")=VAIN(5)
+5 SET HLOC=+$GET(^DIC(42,+VAIN(4),44))
SET SVC=$PIECE($GET(^(0)),U,3)
+6 SET PAT("location")=HLOC_U_$PIECE(VAIN(4),U,2)
+7 if $LENGTH(SVC)
SET PAT("locSvc")=SVC_U_$$EXTERNAL^DILFD(42,.03,,SVC)
+8 SET PAT("specialty")=VAIN(3)
+9 SET PAT("attending")=VAIN(11)
+10 SET X=$$FAC^VPRD(HLOC)
SET PAT("site")=X
End DoDot:1
+11 SET PAT("inpatient")=$SELECT(ADM:"true",1:"false")
+12 QUIT
ZPC ;-primary care [not used: GETALL not returning team members]
+1 NEW TEAM,VPRPC,VPRI,VPRTM,PCPR,FAC,X,ST
+2 ;teamIEN^name^instIEN^name
SET TEAM=$$INSTPCTM^SCAPMC(DFN)
if 'TEAM
QUIT
+3 SET PAT("pcTeam")=$PIECE(TEAM,U,1,2)
+4 DO GETALL^SCAPMCA(DFN,,.VPRPC)
+5 SET VPRI=+$ORDER(@VPRPC@(DFN,"TM",+TEAM,0))
SET VPRTM=$GET(^(VPRI))
+6 if $PIECE(VPRTM,U,4)
SET PAT("pcAssigned")=$PIECE(VPRTM,U,4)
+7 SET PCPR=$GET(@VPRPC@(DFN,"PCPR",1))
IF PCPR
Begin DoDot:1
+8 SET PAT("pcProvider")=$PIECE(PCPR,U,1,2)_U_$$PROVSPC^VPRD(+PCPR)
+9 SET FAC=$PIECE(TEAM,U,3,4)
if FAC<1
SET FAC=$$SITE^VASITE
+10 ;street^city^st^zip
SET X=$$PADD^XUAF4(+FAC)
+11 ;get state name
SET ST=$$GET1^DIQ(4,+FAC_",",.02)
if ST=""
SET ST=$PIECE(X,U,3)
+12 SET PAT("pcProvider","address")=$PIECE(X,U)_"^^^"_$PIECE(X,U,2)_U_ST_U_$PIECE(X,U,4)
End DoDot:1
+13 ; get team members
+14 SET VPRI=0
FOR
SET VPRI=$ORDER(@VPRPC@(DFN,"TM",+VPRTM,+$PIECE(VPRTM,U,3),"POS",VPRI))
if VPRI<1
QUIT
IF +$GET(^(VPRI))'=$PIECE(PCPR,U,3)
Begin DoDot:1
+15 SET I=+$ORDER(@VPRPC@(DFN,"TM",+VPRTM,+$PIECE(VPRTM,U,3),"POS",VPRI,"PROV",0))
SET X=$GET(^(I))
if X=""
QUIT
+16 SET POS=$SELECT($LENGTH($PIECE(X,U,8)):$PIECE(X,U,8),1:$PIECE(X,U,4))
+17 SET PAT("pcTeamMember",I)=$PIECE(X,U,1,2)_U_POS_U_$$PROVSPC^VPRD(+X)
End DoDot:1
+18 KILL @VPRPC
+19 QUIT
+20 ;
PC ;-primary care
+1 NEW TEAM,X,VPRT,PRV,POS,FAC,ST,I
+2 ;PC teamIEN^name^instIEN^name
SET TEAM=$$INSTPCTM^SCAPMC(DFN)
IF TEAM
Begin DoDot:1
+3 SET PAT("pcTeam")=$PIECE(TEAM,U,1,2)
+4 SET X=$$TMPT^SCAPMC(DFN,,,.VPRT)
IF X
SET I=0
FOR
SET I=$ORDER(@VPRT@(I))
if I<1
QUIT
IF +$GET(@VPRT@(I))=+TEAM
SET PAT("pcAssigned")=$PIECE(@VPRT@(I),U,4)
QUIT
+5 KILL @VPRT,VPRT,X
+6 SET X=$$PRTM^SCAPMC(+TEAM,,,,.VPRT)
if 'X
QUIT
+7 SET (I,PRV)=0
FOR
SET PRV=+$ORDER(@VPRT@("SCPR",PRV))
if PRV<1
QUIT
Begin DoDot:2
+8 SET POS=$ORDER(@VPRT@("SCPR",PRV,0))
+9 SET X=PRV_U_$PIECE($GET(^VA(200,PRV,0)),U)
+10 SET POS=$$GET1^DIQ(404.57,POS_",",.01)
+11 SET I=I+1
SET PAT("pcTeamMember",I)=X_U_POS_U_$$PROVSPC^VPRD(+X)
End DoDot:2
+12 KILL @VPRT,VPRT,X
End DoDot:1
+13 SET X=$$OUTPTPR^SDUTL3(DFN)
IF X
Begin DoDot:1
+14 SET PAT("pcProvider")=X_U_$$PROVSPC^VPRD(+X)
+15 SET FAC=$PIECE(TEAM,U,3,4)
if FAC<1
SET FAC=$$SITE^VASITE
+16 ;street^city^st^zip
SET X=$$PADD^XUAF4(+FAC)
+17 ;get state name
SET ST=$$GET1^DIQ(4,+FAC_",",.02)
if ST=""
SET ST=$PIECE(X,U,3)
+18 SET PAT("pcProvider","address")=$PIECE(X,U)_"^^^"_$PIECE(X,U,2)_U_ST_U_$PIECE(X,U,4)
End DoDot:1
+19 QUIT
+20 ;
+21 ; ------------ Return data to middle tier ------------
+22 ;
XML(ITEM) ; -- Return patient data as XML in @VPR@(n)
+1 ; as <element code='123' displayName='ABC' />
+2 NEW ATT,X,Y,NAMES,I,ID
+3 DO ADD("<patient>")
SET VPRTOTL=$GET(VPRTOTL)+1
+4 SET ATT=""
FOR
SET ATT=$ORDER(ITEM(ATT))
if ATT=""
QUIT
Begin DoDot:1
+5 SET X=$GET(ITEM(ATT))
SET NAMES=$$LABELS(ATT)
SET Y=""
+6 IF ATT="pcProvider"
Begin DoDot:2
+7 SET Y="<"_ATT_" "_$$LOOP_">"
DO ADD(Y)
+8 SET X=$GET(ITEM(ATT,"address"))
IF $LENGTH(X)
DO ADDR(X)
+9 DO ADD("</"_ATT_">")
SET Y=""
End DoDot:2
QUIT
+10 ;
+11 ;multiples
IF $LENGTH($ORDER(ITEM(ATT,"")))
Begin DoDot:2
+12 SET ID=$SELECT($EXTRACT(ATT,$LENGTH(ATT))="s":ATT_"es",$EXTRACT(ATT,$LENGTH(ATT))="y":$EXTRACT(ATT,1,$LENGTH(ATT)-1)_"ies",1:ATT_"s")
+13 DO ADD("<"_ID_">")
+14 SET I=""
FOR
SET I=$ORDER(ITEM(ATT,I))
if I=""
QUIT
Begin DoDot:3
+15 SET X=ITEM(ATT,I)
SET Y="<"_ATT_" "
+16 IF ATT="support"
Begin DoDot:4
+17 SET Y=Y_"contactType='"_I_"' "_$$LOOP_">"
DO ADD(Y)
+18 SET X=$GET(ITEM(ATT,I,"address"))
IF $LENGTH(X)
DO ADDR(X)
+19 SET X=$GET(ITEM(ATT,I,"telecom"))
IF $LENGTH(X)
DO PHONE(X)
+20 DO ADD("</support>")
End DoDot:4
SET Y=""
QUIT
+21 IF ATT="disability"
SET Y=Y_"vaCode='"_I_"' "
+22 SET Y=Y_$$LOOP_"/>"
DO ADD(Y)
End DoDot:3
+23 DO ADD("</"_ID_">")
SET Y=""
End DoDot:2
QUIT
+24 ;
+25 IF ATT="exposures"
if X["1"
Begin DoDot:2
+26 SET I=0
SET Y="<exposures>"
DO ADD(Y)
+27 FOR ID="AO","IR","PG","HNC","MST","CV"
SET I=I+1
IF $PIECE(X,U,I)
SET Y="<exposure value='"_ID_"' />"
DO ADD(Y)
+28 DO ADD("</exposures>")
End DoDot:2
SET Y=""
QUIT
+29 ;
+30 IF ATT="address"
DO ADDR(X)
SET Y=""
QUIT
+31 IF ATT="telecom"
DO PHONE(X)
SET Y=""
QUIT
+32 ;
+33 ;no data
if X=""
QUIT
+34 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />"
QUIT
+35 IF $LENGTH(X)>1
SET Y="<"_ATT_" "_$$LOOP_"/>"
End DoDot:1
if $LENGTH(Y)
DO ADD(Y)
+36 DO ADD("</patient>")
+37 QUIT
+38 ;
ADDR(X) ; -- XML address node from X=street1^st2^st3^city^state^zip
+1 ;no data
NEW I,Y
if $LENGTH(X)'>5
QUIT
+2 SET Y="<address"
+3 FOR I=1,2,3
IF $LENGTH($PIECE(X,U,I))
SET Y=Y_" streetLine"_I_"='"_$$ESC^VPRD($PIECE(X,U,I))_"'"
+4 IF $LENGTH($PIECE(X,U,4))
SET Y=Y_" city='"_$$ESC^VPRD($PIECE(X,U,4))_"'"
+5 IF $LENGTH($PIECE(X,U,5))
SET Y=Y_" stateProvince='"_$PIECE(X,U,5)_"'"
+6 IF $LENGTH($PIECE(X,U,6))
SET Y=Y_" postalCode='"_$PIECE(X,U,6)_"'"
+7 SET Y=Y_" />"
DO ADD(Y)
+8 QUIT
+9 ;
PHONE(X) ; -- XML telecom node from X=home^cell^work numbers
+1 ;no data
NEW I,Y
if $LENGTH(X)'>2
QUIT
+2 DO ADD("<telecomList>")
+3 IF $LENGTH($PIECE(X,U,1))
SET Y="<telecom usageType='H' value='"_$PIECE(X,U,1)_"' />"
DO ADD(Y)
+4 IF $LENGTH($PIECE(X,U,2))
SET Y="<telecom usageType='MC' value='"_$PIECE(X,U,2)_"' />"
DO ADD(Y)
+5 IF $LENGTH($PIECE(X,U,3))
SET Y="<telecom usageType='WP' value='"_$PIECE(X,U,3)_"' />"
DO ADD(Y)
+6 DO ADD("</telecomList>")
+7 QUIT
+8 ;
LOOP() ; -- build sub-items string from NAMES and X
+1 NEW STR,P,TAG
SET STR=""
+2 FOR P=1:1
SET TAG=$PIECE(NAMES,U,P)
if TAG="Z"
QUIT
IF $LENGTH($PIECE(X,U,P))
SET STR=STR_TAG_"='"_$$ESC^VPRD($PIECE(X,U,P))_"' "
+3 QUIT STR
+4 ;
ADD(X) ; Add a line @VPR@(n)=X
+1 SET VPRI=$GET(VPRI)+1
+2 SET @VPR@(VPRI)=X
+3 QUIT
+4 ;
LABELS(X) ; -- return string of attribute labels for element X
+1 NEW Y
SET Y="code^name^Z"
+2 IF X="pcProvider"
SET Y="code^name^"_$$PROVTAGS^VPRD_"^Z"
+3 IF X="support"
SET Y="name^relationship^Z"
+4 IF X="eligibility"
SET Y="name^primary^Z"
+5 IF X="disability"
SET Y="printName^sc^scPercent^Z"
+6 IF X="alias"
SET Y="fullName^familyName^givenNames^Z"
+7 IF X="flag"
SET Y="name^text^Z"
+8 IF X="facility"
SET Y="code^name^latestDate^domain^homeSite^Z"
+9 IF X="pcTeamMember"
SET Y="code^name^role^"_$$PROVTAGS^VPRD_"^Z"
+10 IF X="ethnicity"!(X="race")
SET Y="value^Z"
+11 IF X="admitted"
SET Y="id^date^Z"
+12 QUIT Y
