HMPDJ00 ;SLC/MKB,ASMR/RRB,MBS - Patient demographics;Aug 29, 2016 20:06:27
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2,3**;Sep 01, 2011;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^AUPNVSIT 2028
; ^DPT 10035
; DGACT 2248
; DGCV 4156
; DGMSTAPI 2716
; DGNTAPI 3457
; DGPFAPI 3860
; DGRPDB 4807
; DIQ 2056
; IBBAPI 4419
; MPIF001 2701
; SDUTL3 1252
; VADPT 10061
; VAFCTFU1 2990
; VASITE 10112
; XUAF4 2171
; SECURITY/SENSITIVE RECORD ACC 3027
;
; All tags expect DFN
; [HMPID, HMPSTART, HMPSTOP, HMPMAX, HMPTEXT not currently used here]
Q
;
DPT1 ; -- Demographics
N PAT D DPT1OD(.PAT)
I $D(PAT)>9 D ADD^HMPDJ("PAT")
Q
;
DPT1OD(PAT) ; -- Demographics (data array only)
N SYS S SYS=$$SITE^VASITE
N $ES,$ET,ERRPAT,ERRMSG
S $ET="D ERRHDLR^HMPDERRH",ERRPAT=DFN
S ERRMSG="A problem occurred building the patient "_DFN_" demographic extract."
D DEM,SVC,PRF,ATC,SUPP,ALIAS,FAC,PC,INPT,INS
D KVAR^VADPT
S PAT("stampTime")=$S($G(HMPSTMP)]"":HMPSTMP,1:$$EN^HMPSTMP("NOW")) ;US6734
S PAT("lastUpdateTime")=PAT("stampTime")
;US6734 - pre-compile metastamp
I $G(HMPMETA) D ADD^HMPMETA("patient",PAT("uid"),PAT("stampTime")) Q:HMPMETA=1 ;US6734,US11019
Q
;
LKUP ; patient lookup data
; expects HMPSYS,DFN
N X,X0
S X0=$G(^DPT(DFN,0)),X=$P(X0,U) I X="" D LOGDPT^HMPLOG(DFN) Q ;DE4496, 19 August 2016, invalid DFN passed in DE4983
S PAT("fullName")=X
S PAT("familyName")=$P(X,",")
S PAT("givenNames")=$P(X,",",2,99)
S X=$P(X0,U,2)
S PAT("genderCode")="urn:va:pat-gender:"_X
S PAT("genderName")=$$NAME(X,"gender")
S PAT("localId")=DFN
S PAT("pid")=HMPSYS_";"_DFN
S PAT("uid")=$$SETUID^HMPUTILS("pt-select",DFN,DFN)
S X=$$GETICN^MPIF001(DFN)
S:X>0 PAT("icn")=X
S PAT("ssn")=$P(X0,U,9)
S PAT("birthDate")=$$JSONDT^HMPUTILS($P(X0,U,3))
S X=$P($G(^DPT(DFN,.35)),U)
S:X PAT("deceased")=$$JSONDT^HMPUTILS(X)
D PTSEC^DGSEC4(.LST,DFN) ; DBIA 3027 DE2818 - PB 30 Oct 2015 changed to use a global reference covered by an active ICR
S PAT("sensitive")=$$BOOL(LST(1))
;US6734 - pre-compile metastamp for OPD
I $G(HMPMETA),$P($G(HMPFADOM),"#")="pt-select" D ADD^HMPMETA("pt-select",PAT("uid"),$G(HMPSTMP)) Q:HMPMETA=1 ;US6734,US11019
I $G(HMPSTMP)]"" S PAT("stampTime")=HMPSTMP ; US6734 - set stamptime as time of subscription
E S PAT("stampTime")=$$EN^HMPSTMP("NOW") ; DE2616 - must add stampTime to receive OPD freshness update from ADHOC^HMPUTIL1
I $D(PAT)>9 D ADD^HMPDJ("PAT")
Q
;
DEM ;-demographic data
N VADM,VA,VAERR,X,I
S PAT("pid")=$$PID^HMPDJFS(DFN)
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^HMPUTILS("patient",DFN,DFN)
S:$D(VA("BID")) PAT("briefId")=$E(X)_VA("BID")
S X=+$P($P(VADM(3),U),"."),PAT("birthDate")=$$JSONDT^HMPUTILS(X)
S X=$P(VADM(5),U) S:X="" X="UNK"
S PAT("genderCode")="urn:va:pat-gender:"_X,PAT("genderName")=$$NAME(X,"gender")
S X=+$P($P(VADM(6),U),".") S:X PAT("deceased")=$$JSONDT^HMPUTILS(X)
D PTSEC^DGSEC4(.LST,DFN) ; DBIA 3027 DE2818 - PB 30 Oct 2015 changed to use a global reference covered by an active ICR
S PAT("sensitive")=$$BOOL(LST(1))
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
. S X=$E(X),X=$S(X="S":"L",X="N":"S",1:X)
. S PAT("maritalStatusCode")="urn:va:pat-maritalStatus:"_X
. S PAT("maritalStatusName")=$$NAME(X,"maritalStatus")
I VADM(11) S I=0 F S I=$O(VADM(11,I)) Q:I<1 D
. S X=+VADM(11,I)
. S PAT("ethnicity",X,"code")=$$GET1^DIQ(2.06,X_","_DFN_",",".01:3")
I VADM(12) S I=0 F S I=$O(VADM(12,I)) Q:I<1 D
. S X=+VADM(12,I)
. S PAT("race",X,"code")=$$GET1^DIQ(2.02,X_","_DFN_",",".01:3")
Q
;
SVC ;-service data
N VAEL,VASV,VAERR,X,Y,I,P,AO,IR,PGF,HNC,MST,CV,HMPSC
D 7^VADPT
S PAT("veteran")=$$BOOL(VAEL(4))
S PAT("serviceConnected")=$$BOOL(+VAEL(3)) I VAEL(3) D
. S PAT("scPercent")=+$P(VAEL(3),U,2)
. D GETS^DIQ(2,DFN_",",".3731*",,"HMPSC")
. S I="" F S I=$O(HMPSC(2.05,I)) Q:I="" D
.. S PAT("scCondition",+I,"name")=HMPSC(2.05,I,.01)
.. S PAT("scCondition",+I,"scPercent")=HMPSC(2.05,I,.02)
S X=+$G(^DPT(DFN,"LR")) S:X PAT("lrdfn")=X
I VAEL(9)]"" S PAT("meanStatus")=$P(VAEL(9),U,2)
;
; exposures
;Agent Orange
S EXPVAL=$S(VASV(2):"Yes",VASV(2)=0:"No",1:"Unknown"),PAT("exposure",1,"uid")="urn:va:agent-orange:"_$E(EXPVAL),PAT("exposure",1,"name")=EXPVAL
;Ionizing Radiation
S EXPVAL=$S(VASV(3):"Yes",VASV(3)=0:"No",1:"Unknown"),PAT("exposure",2,"uid")="urn:va:ionizing-radiation:"_$E(EXPVAL),PAT("exposure",2,"name")=EXPVAL
;SW Asia/Persian Gulf
;DE3917 - CPRS does not use the OIF/OEF fields to determine PGF/SW Asia exposure, but, instead, per VADPT^GMPLX1
;(called by ORQQPL INIT PT), directly gets the data from the #.32201 (PERSIAN GULF SERVICE?) field in the PATIENT file.
S EXPVAL=$$GET1^DIQ(2,DFN_",",".32201","E") S:EXPVAL="" EXPVAL="Unknown"
S PAT("exposure",3,"uid")="urn:va:sw-asia:"_$E(EXPVAL),PAT("exposure",3,"name")=EXPVAL
;Head-Neck Cancer
S X=$$GETCUR^DGNTAPI(DFN,"HNC"),X=+($G(HNC("STAT"))),X=$S(X=4:1,X=5:1,X=1:0,X=6:0,1:"")
S EXPVAL=$S(X:"Yes",X=0:"No",1:"Unknown"),PAT("exposure",4,"uid")="urn:va:head-neck-cancer:"_$E(EXPVAL),PAT("exposure",4,"name")=EXPVAL
;Military Sexual Trauma
S X=$P($$GETSTAT^DGMSTAPI(DFN),U,2),EXPVAL=$S(X="Y":"Yes",X="N":"No",1:"Unknown")
S PAT("exposure",5,"uid")="urn:va:mst:"_$E(EXPVAL),PAT("exposure",5,"name")=EXPVAL
;Combat Vet
S X=$$CVEDT^DGCV(DFN),X=$S(+X<0:"",+X=0:0,$P(X,U,3):1,1:0)
S EXPVAL=$S(X:"Yes",X=0:"No",1:"Unknown"),PAT("exposure",6,"uid")="urn:va:combat-vet:"_$E(EXPVAL),PAT("exposure",6,"name")=EXPVAL
;Shipboard Hazard And Defense
S EXPVAL=$S(VASV(14):"Yes",VASV(14)=0:"No",1:"Unknown"),PAT("exposure",7,"uid")="urn:va:shipboard-hazard:"_$E(EXPVAL),PAT("exposure",7,"name")=EXPVAL
;
; rated disabilities [DGRPDB]
N HMPDIS,DIS,NM,DX
D RDIS^DGRPDB(DFN,.HMPDIS)
S I=0 F S I=$O(HMPDIS(I)) Q:I<1 D
. S DIS=HMPDIS(I)
. S NM=$$GET1^DIQ(31,+DIS_",",.01),DX=$$GET1^DIQ(31,+DIS_",",2)
. S PAT("disability",+DX,"name")=NM
. S PAT("disability",+DX,"disPercent")=$P(DIS,U,2)
. S PAT("disability",+DX,"serviceConnected")=$$BOOL($P(DIS,U,3))
Q
;
PRF ;-patient record flags
N HMPF,I,N,X
S X=$$GETACT^DGPFAPI(DFN,"HMPF")
S I=0 F S I=$O(HMPF(I)) Q:I<1 D
. S PAT("patientRecordFlag",I,"assignmentStatus")="Active"
. S PAT("patientRecordFlag",I,"assignTS")=$$JSONDT^HMPUTILS($P($G(HMPF(I,"ASSIGNDT")),U))
. S PAT("patientRecordFlag",I,"approved")=$P($G(HMPF(I,"APPRVBY")),U,2)
. S PAT("patientRecordFlag",I,"nextReviewDT")=$$JSONDT^HMPUTILS($P($G(HMPF(I,"REVIEWDT")),U))
. S PAT("patientRecordFlag",I,"name")=$P($G(HMPF(I,"FLAG")),U,2)
. S PAT("patientRecordFlag",I,"type")=$P($G(HMPF(I,"FLAGTYPE")),U,2)
. S PAT("patientRecordFlag",I,"category")=$P($G(HMPF(I,"CATEGORY")),U,2)
. S PAT("patientRecordFlag",I,"ownerSite")=$P($G(HMPF(I,"OWNER")),U,2)
. S PAT("patientRecordFlag",I,"originatingSite")=$P($G(HMPF(I,"ORIGSITE")),U,2)
. S N=1,X=$G(HMPF(I,"NARR",1,0))
. F S N=$O(HMPF(I,"NARR",N)) Q:N<1 S X=X_$C(13,10)_$G(HMPF(I,"NARR",N,0))
. S PAT("patientRecordFlag",I,"text")=X
S X=$$CWAD^ORQPT2(DFN)
I X]"" S PAT("cwadf")=X
I $D(PAT("patientRecordFlag")) S PAT("cwadf")=$G(PAT("cwadf"))_"F"
Q
;
ATC ;-address & telecom
N VAPA,CNT,X,I,P,NM
; VAPA("P")="" ;permanent address
D ADD^VADPT S CNT=0 I $$VAPA(1,5) D
. S CNT=CNT+1
. D ADD(1,2,3,4,5,11,9,10)
. S PAT("address",CNT,"use")=$S($L(VAPA(9)):"TMP",1:"H")
I VAPA(12) D ;confidential address
. S CNT=CNT+1
. D ADD(13,14,15,16,17,18,20,21)
. S PAT("address",CNT,"use")="CONF"
. S I=0 F S I=$O(VAPA(22,I)) Q:I="" S X=VAPA(22,I) D
.. S PAT("address",CNT,"category",I,"name")=$P(X,U,2)
.. S PAT("address",CNT,"category",I,"status")=$$BOOL($P(X,U,3))
;
; 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("telecom",P,"use")=I
. S PAT("telecom",P,"value")=$P(X,U,P)
S X=$P($G(^DPT(DFN,.13)),U,3) S:X'="" PAT("email")=X
I +$P($G(^DPT(DFN,.11)),U,16)>0 S PAT("badAddress")=$$GET1^DIQ(2,DFN_",",.121)
Q
;
ADD(LINE1,LINE2,LINE3,CITY,STATE,ZIP,START,STOP) ; -- address set
S:$L(VAPA(LINE1)) PAT("address",CNT,"line1")=VAPA(LINE1)
S:$L(VAPA(LINE2)) PAT("address",CNT,"line2")=VAPA(LINE2)
S:$L(VAPA(LINE3)) PAT("address",CNT,"line3")=VAPA(LINE3)
S:$L(VAPA(CITY)) PAT("address",CNT,"city")=VAPA(CITY)
S X=$P(VAPA(STATE),U) S:X PAT("address",CNT,"state")=$$GET1^DIQ(5,+X_",",1)
S X=$P(VAPA(ZIP),U,2) S:$L(X) PAT("address",CNT,"zip")=X
S X=+VAPA(START) S:X PAT("address",CNT,"start")=$$JSONDT^HMPUTILS(X)
S X=+VAPA(STOP) S:X PAT("address",CNT,"end")=$$JSONDT^HMPUTILS(X)
Q
;
VAPA(BEG,END) ; -- VAPA nodes have data?
N I,Y S Y=0
F I=BEG:1:END I $L($G(VAPA(I))) S Y=1 Q
Q Y
;
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("contact",S,"typeCode")="urn:va:pat-contact:"_$P(TYPE,U)
. S PAT("contact",S,"typeName")=$P(TYPE,U,2)
. S:$L(VAOA(9)) PAT("contact",S,"name")=VAOA(9)
. S:$L(VAOA(10)) PAT("contact",S,"relationship")=VAOA(10)
. S:$L(VAOA(1)) PAT("contact",S,"address",1,"line1")=VAOA(1)
. S:$L(VAOA(2)) PAT("contact",S,"address",1,"line2")=VAOA(2)
. S:$L(VAOA(3)) PAT("contact",S,"address",1,"line3")=VAOA(3)
. S:$L(VAOA(4)) PAT("contact",S,"address",1,"city")=VAOA(4)
. S X=$P(VAOA(5),U) S:X PAT("contact",S,"address",1,"state")=$$GET1^DIQ(5,+X_",",1)
. S X=$P(VAOA(11),U,2) S:$L(X) PAT("contact",S,"address",1,"zip")=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("contact",S,"telecom",P,"use")=I
.. S PAT("contact",S,"telecom",P,"value")=$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=$G(^(I,0)) D
. S PAT("alias",I,"fullName")=$P(X,U)
Q
;
FAC ;-treating facilities [see FACLIST^ORWCIRN]
N IFN S DFN=+$G(DFN) I '(DFN>0) D LOGDPT^HMPLOG(DFN) Q ;DE4496 19 August 2016
N HMPY,HOME,LAST,I,X,IEN,VASITE
S X=$$ALL^VASITE ;VASITE(stn#)=stn# for all local
I $L($T(TFL^VAFCTFU1)) D TFL^VAFCTFU1(.HMPY,DFN)
S HOME=+$P($G(^DPT(DFN,"MPI")),U,3) ;home facility
I $P($G(HMPY(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 HMPY(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(HMPY(I)) Q:I<1 D
. S X=HMPY(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",I,"code")=$P(X,U) ;stn#
. S PAT("facility",I,"name")=$P(X,U,2) ;name
. S:IEN=HOME PAT("facility",I,"homeSite")="true"
. S:$L($P(X,U,3)) PAT("facility",I,"latestDate")=$$JSONDT^HMPUTILS($P($P(X,U,3),"."))
. I $D(VASITE(+X)) D
.. S PAT("facility",I,"localPatientId")=DFN
.. S PAT("facility",I,"systemId")=HMPSYS
Q
;
PC ;-primary care assignments
D GETPATTM^HMPCRPC1(.PAT,DFN)
Q
N X S X=$$OUTPTPR^SDUTL3(DFN) I X D
. S PAT("pcProviderUid")=$$SETUID^HMPUTILS("user",,+X)
. S PAT("pcProviderName")=$P(X,U,2)
S X=$$OUTPTTM^SDUTL3(DFN) I X D
. S PAT("pcTeamUid")=$$SETUID^HMPUTILS("team",,+X)
. S PAT("pcTeamName")=$P(X,U,2)
Q
;
INPT ;-inpatient information
N ADM,X,Y,Z,I,HL,TS
S ADM=+$G(^DPT(DFN,.105)) Q:ADM<1 ;current admission mvt
S PAT("admissionUid")=$$SETUID^HMPUTILS("visit",DFN,"H"_ADM)
S X=$P($G(^DPT(DFN,.101)),U) S:X]"" PAT("roomBed")=X
S X=$P($G(^DPT(DFN,.1)),U) I X]"" D
. S PAT("inpatientLocation")=X
. S I=+$O(^DIC(42,"B",X,0)),HL=+$G(^DIC(42,I,44)) Q:HL<1
. S X=$P($G(^SC(HL,0)),U,2) S:X]"" PAT("shortInpatientLocation")=X
;
S TS=$G(^DPT(DFN,.103)) I TS D ;treating specialty
. S X=$$TSDATA^DGACT(45.7,+TS,.Y) Q:X<1
. S PAT("specialty")=$G(Y(1)),X=""
. S PAT("specialtyUid")=$$SETUID^HMPUTILS("specialty",,+TS)
. I +$G(Y(2))>0 S X=$$TSDATA^DGACT(42.4,+Y(2),.Z)
. I X>0,$G(Z(3))]"" S PAT("specialtyService")=$P(Z(3),U)
Q
;
INS ;-insurance information
N X,I,HMPX,HMPINS
S X=$$INSUR^IBBAPI(DFN,,,.HMPX,"*") Q:X<1
S I=0 F S I=$O(HMPX("IBBAPI","INSUR",I)) Q:I<1 D
. K HMPINS M HMPINS=HMPX("IBBAPI","INSUR",I)
. S PAT("insurance",I,"id")=DFN_";"_+$G(HMPINS(1))_";"_+$G(HMPINS(8))
. ; = DFN;COMPANY;POLICY
. S PAT("insurance",I,"companyName")=$P(HMPINS(1),U,2)
. ;DE942 - Convert effective and expiration dates to JSON format - TW
. S:$G(HMPINS(10))]"" PAT("insurance",I,"effectiveDate")=$$JSONDT^HMPUTILS(HMPINS(10))
. S:$G(HMPINS(11))]"" PAT("insurance",I,"expirationDate")=$$JSONDT^HMPUTILS(HMPINS(11))
. S:$G(HMPINS(18))]"" PAT("insurance",I,"groupNumber")=HMPINS(18)
. S:$G(HMPINS(21))]"" PAT("insurance",I,"policyType")=$P(HMPINS(21),U,2)
. S X=$P($G(HMPINS(12)),U,2) S:X="PATIENT" X="SELF"
. S:X]"" PAT("insurance",I,"policyHolder")=X
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) ;
I X>0 Q "true"
S X=$E(X) I X="Y"!(X="y") Q "true"
Q "false"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDJ00 14525 printed Oct 16, 2024@17:53:55 Page 2
HMPDJ00 ;SLC/MKB,ASMR/RRB,MBS - Patient demographics;Aug 29, 2016 20:06:27
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2,3**;Sep 01, 2011;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^AUPNVSIT 2028
+7 ; ^DPT 10035
+8 ; DGACT 2248
+9 ; DGCV 4156
+10 ; DGMSTAPI 2716
+11 ; DGNTAPI 3457
+12 ; DGPFAPI 3860
+13 ; DGRPDB 4807
+14 ; DIQ 2056
+15 ; IBBAPI 4419
+16 ; MPIF001 2701
+17 ; SDUTL3 1252
+18 ; VADPT 10061
+19 ; VAFCTFU1 2990
+20 ; VASITE 10112
+21 ; XUAF4 2171
+22 ; SECURITY/SENSITIVE RECORD ACC 3027
+23 ;
+24 ; All tags expect DFN
+25 ; [HMPID, HMPSTART, HMPSTOP, HMPMAX, HMPTEXT not currently used here]
+26 QUIT
+27 ;
DPT1 ; -- Demographics
+1 NEW PAT
DO DPT1OD(.PAT)
+2 IF $DATA(PAT)>9
DO ADD^HMPDJ("PAT")
+3 QUIT
+4 ;
DPT1OD(PAT) ; -- Demographics (data array only)
+1 NEW SYS
SET SYS=$$SITE^VASITE
+2 NEW $ESTACK,$ETRAP,ERRPAT,ERRMSG
+3 SET $ETRAP="D ERRHDLR^HMPDERRH"
SET ERRPAT=DFN
+4 SET ERRMSG="A problem occurred building the patient "_DFN_" demographic extract."
+5 DO DEM
DO SVC
DO PRF
DO ATC
DO SUPP
DO ALIAS
DO FAC
DO PC
DO INPT
DO INS
+6 DO KVAR^VADPT
+7 ;US6734
SET PAT("stampTime")=$SELECT($GET(HMPSTMP)]"":HMPSTMP,1:$$EN^HMPSTMP("NOW"))
+8 SET PAT("lastUpdateTime")=PAT("stampTime")
+9 ;US6734 - pre-compile metastamp
+10 ;US6734,US11019
IF $GET(HMPMETA)
DO ADD^HMPMETA("patient",PAT("uid"),PAT("stampTime"))
if HMPMETA=1
QUIT
+11 QUIT
+12 ;
LKUP ; patient lookup data
+1 ; expects HMPSYS,DFN
+2 NEW X,X0
+3 ;DE4496, 19 August 2016, invalid DFN passed in DE4983
SET X0=$GET(^DPT(DFN,0))
SET X=$PIECE(X0,U)
IF X=""
DO LOGDPT^HMPLOG(DFN)
QUIT
+4 SET PAT("fullName")=X
+5 SET PAT("familyName")=$PIECE(X,",")
+6 SET PAT("givenNames")=$PIECE(X,",",2,99)
+7 SET X=$PIECE(X0,U,2)
+8 SET PAT("genderCode")="urn:va:pat-gender:"_X
+9 SET PAT("genderName")=$$NAME(X,"gender")
+10 SET PAT("localId")=DFN
+11 SET PAT("pid")=HMPSYS_";"_DFN
+12 SET PAT("uid")=$$SETUID^HMPUTILS("pt-select",DFN,DFN)
+13 SET X=$$GETICN^MPIF001(DFN)
+14 if X>0
SET PAT("icn")=X
+15 SET PAT("ssn")=$PIECE(X0,U,9)
+16 SET PAT("birthDate")=$$JSONDT^HMPUTILS($PIECE(X0,U,3))
+17 SET X=$PIECE($GET(^DPT(DFN,.35)),U)
+18 if X
SET PAT("deceased")=$$JSONDT^HMPUTILS(X)
+19 ; DBIA 3027 DE2818 - PB 30 Oct 2015 changed to use a global reference covered by an active ICR
DO PTSEC^DGSEC4(.LST,DFN)
+20 SET PAT("sensitive")=$$BOOL(LST(1))
+21 ;US6734 - pre-compile metastamp for OPD
+22 ;US6734,US11019
IF $GET(HMPMETA)
IF $PIECE($GET(HMPFADOM),"#")="pt-select"
DO ADD^HMPMETA("pt-select",PAT("uid"),$GET(HMPSTMP))
if HMPMETA=1
QUIT
+23 ; US6734 - set stamptime as time of subscription
IF $GET(HMPSTMP)]""
SET PAT("stampTime")=HMPSTMP
+24 ; DE2616 - must add stampTime to receive OPD freshness update from ADHOC^HMPUTIL1
IF '$TEST
SET PAT("stampTime")=$$EN^HMPSTMP("NOW")
+25 IF $DATA(PAT)>9
DO ADD^HMPDJ("PAT")
+26 QUIT
+27 ;
DEM ;-demographic data
+1 NEW VADM,VA,VAERR,X,I
+2 SET PAT("pid")=$$PID^HMPDJFS(DFN)
+3 SET X=$$GETICN^MPIF001(DFN)
if X>1
SET PAT("icn")=X
+4 DO DEM^VADPT
SET X=VADM(1)
SET PAT("fullName")=X
+5 SET PAT("familyName")=$PIECE(X,",")
SET PAT("givenNames")=$PIECE(X,",",2,99)
+6 SET PAT("ssn")=$PIECE(VADM(2),U)
SET PAT("localId")=DFN
+7 SET PAT("uid")=$$SETUID^HMPUTILS("patient",DFN,DFN)
+8 if $DATA(VA("BID"))
SET PAT("briefId")=$EXTRACT(X)_VA("BID")
+9 SET X=+$PIECE($PIECE(VADM(3),U),".")
SET PAT("birthDate")=$$JSONDT^HMPUTILS(X)
+10 SET X=$PIECE(VADM(5),U)
if X=""
SET X="UNK"
+11 SET PAT("genderCode")="urn:va:pat-gender:"_X
SET PAT("genderName")=$$NAME(X,"gender")
+12 SET X=+$PIECE($PIECE(VADM(6),U),".")
if X
SET PAT("deceased")=$$JSONDT^HMPUTILS(X)
+13 ; DBIA 3027 DE2818 - PB 30 Oct 2015 changed to use a global reference covered by an active ICR
DO PTSEC^DGSEC4(.LST,DFN)
+14 SET PAT("sensitive")=$$BOOL(LST(1))
+15 SET X=+VADM(9)
if X
SET PAT("religionCode")="urn:va:pat-religion:"_X
SET PAT("religionName")=$$NAME(X,"religion")
+16 SET X=$PIECE(VADM(10),U,2)
IF $LENGTH(X)
Begin DoDot:1
+17 SET X=$EXTRACT(X)
SET X=$SELECT(X="S":"L",X="N":"S",1:X)
+18 SET PAT("maritalStatusCode")="urn:va:pat-maritalStatus:"_X
+19 SET PAT("maritalStatusName")=$$NAME(X,"maritalStatus")
End DoDot:1
+20 IF VADM(11)
SET I=0
FOR
SET I=$ORDER(VADM(11,I))
if I<1
QUIT
Begin DoDot:1
+21 SET X=+VADM(11,I)
+22 SET PAT("ethnicity",X,"code")=$$GET1^DIQ(2.06,X_","_DFN_",",".01:3")
End DoDot:1
+23 IF VADM(12)
SET I=0
FOR
SET I=$ORDER(VADM(12,I))
if I<1
QUIT
Begin DoDot:1
+24 SET X=+VADM(12,I)
+25 SET PAT("race",X,"code")=$$GET1^DIQ(2.02,X_","_DFN_",",".01:3")
End DoDot:1
+26 QUIT
+27 ;
SVC ;-service data
+1 NEW VAEL,VASV,VAERR,X,Y,I,P,AO,IR,PGF,HNC,MST,CV,HMPSC
+2 DO 7^VADPT
+3 SET PAT("veteran")=$$BOOL(VAEL(4))
+4 SET PAT("serviceConnected")=$$BOOL(+VAEL(3))
IF VAEL(3)
Begin DoDot:1
+5 SET PAT("scPercent")=+$PIECE(VAEL(3),U,2)
+6 DO GETS^DIQ(2,DFN_",",".3731*",,"HMPSC")
+7 SET I=""
FOR
SET I=$ORDER(HMPSC(2.05,I))
if I=""
QUIT
Begin DoDot:2
+8 SET PAT("scCondition",+I,"name")=HMPSC(2.05,I,.01)
+9 SET PAT("scCondition",+I,"scPercent")=HMPSC(2.05,I,.02)
End DoDot:2
End DoDot:1
+10 SET X=+$GET(^DPT(DFN,"LR"))
if X
SET PAT("lrdfn")=X
+11 IF VAEL(9)]""
SET PAT("meanStatus")=$PIECE(VAEL(9),U,2)
+12 ;
+13 ; exposures
+14 ;Agent Orange
+15 SET EXPVAL=$SELECT(VASV(2):"Yes",VASV(2)=0:"No",1:"Unknown")
SET PAT("exposure",1,"uid")="urn:va:agent-orange:"_$EXTRACT(EXPVAL)
SET PAT("exposure",1,"name")=EXPVAL
+16 ;Ionizing Radiation
+17 SET EXPVAL=$SELECT(VASV(3):"Yes",VASV(3)=0:"No",1:"Unknown")
SET PAT("exposure",2,"uid")="urn:va:ionizing-radiation:"_$EXTRACT(EXPVAL)
SET PAT("exposure",2,"name")=EXPVAL
+18 ;SW Asia/Persian Gulf
+19 ;DE3917 - CPRS does not use the OIF/OEF fields to determine PGF/SW Asia exposure, but, instead, per VADPT^GMPLX1
+20 ;(called by ORQQPL INIT PT), directly gets the data from the #.32201 (PERSIAN GULF SERVICE?) field in the PATIENT file.
+21 SET EXPVAL=$$GET1^DIQ(2,DFN_",",".32201","E")
if EXPVAL=""
SET EXPVAL="Unknown"
+22 SET PAT("exposure",3,"uid")="urn:va:sw-asia:"_$EXTRACT(EXPVAL)
SET PAT("exposure",3,"name")=EXPVAL
+23 ;Head-Neck Cancer
+24 SET X=$$GETCUR^DGNTAPI(DFN,"HNC")
SET X=+($GET(HNC("STAT")))
SET X=$SELECT(X=4:1,X=5:1,X=1:0,X=6:0,1:"")
+25 SET EXPVAL=$SELECT(X:"Yes",X=0:"No",1:"Unknown")
SET PAT("exposure",4,"uid")="urn:va:head-neck-cancer:"_$EXTRACT(EXPVAL)
SET PAT("exposure",4,"name")=EXPVAL
+26 ;Military Sexual Trauma
+27 SET X=$PIECE($$GETSTAT^DGMSTAPI(DFN),U,2)
SET EXPVAL=$SELECT(X="Y":"Yes",X="N":"No",1:"Unknown")
+28 SET PAT("exposure",5,"uid")="urn:va:mst:"_$EXTRACT(EXPVAL)
SET PAT("exposure",5,"name")=EXPVAL
+29 ;Combat Vet
+30 SET X=$$CVEDT^DGCV(DFN)
SET X=$SELECT(+X<0:"",+X=0:0,$PIECE(X,U,3):1,1:0)
+31 SET EXPVAL=$SELECT(X:"Yes",X=0:"No",1:"Unknown")
SET PAT("exposure",6,"uid")="urn:va:combat-vet:"_$EXTRACT(EXPVAL)
SET PAT("exposure",6,"name")=EXPVAL
+32 ;Shipboard Hazard And Defense
+33 SET EXPVAL=$SELECT(VASV(14):"Yes",VASV(14)=0:"No",1:"Unknown")
SET PAT("exposure",7,"uid")="urn:va:shipboard-hazard:"_$EXTRACT(EXPVAL)
SET PAT("exposure",7,"name")=EXPVAL
+34 ;
+35 ; rated disabilities [DGRPDB]
+36 NEW HMPDIS,DIS,NM,DX
+37 DO RDIS^DGRPDB(DFN,.HMPDIS)
+38 SET I=0
FOR
SET I=$ORDER(HMPDIS(I))
if I<1
QUIT
Begin DoDot:1
+39 SET DIS=HMPDIS(I)
+40 SET NM=$$GET1^DIQ(31,+DIS_",",.01)
SET DX=$$GET1^DIQ(31,+DIS_",",2)
+41 SET PAT("disability",+DX,"name")=NM
+42 SET PAT("disability",+DX,"disPercent")=$PIECE(DIS,U,2)
+43 SET PAT("disability",+DX,"serviceConnected")=$$BOOL($PIECE(DIS,U,3))
End DoDot:1
+44 QUIT
+45 ;
PRF ;-patient record flags
+1 NEW HMPF,I,N,X
+2 SET X=$$GETACT^DGPFAPI(DFN,"HMPF")
+3 SET I=0
FOR
SET I=$ORDER(HMPF(I))
if I<1
QUIT
Begin DoDot:1
+4 SET PAT("patientRecordFlag",I,"assignmentStatus")="Active"
+5 SET PAT("patientRecordFlag",I,"assignTS")=$$JSONDT^HMPUTILS($PIECE($GET(HMPF(I,"ASSIGNDT")),U))
+6 SET PAT("patientRecordFlag",I,"approved")=$PIECE($GET(HMPF(I,"APPRVBY")),U,2)
+7 SET PAT("patientRecordFlag",I,"nextReviewDT")=$$JSONDT^HMPUTILS($PIECE($GET(HMPF(I,"REVIEWDT")),U))
+8 SET PAT("patientRecordFlag",I,"name")=$PIECE($GET(HMPF(I,"FLAG")),U,2)
+9 SET PAT("patientRecordFlag",I,"type")=$PIECE($GET(HMPF(I,"FLAGTYPE")),U,2)
+10 SET PAT("patientRecordFlag",I,"category")=$PIECE($GET(HMPF(I,"CATEGORY")),U,2)
+11 SET PAT("patientRecordFlag",I,"ownerSite")=$PIECE($GET(HMPF(I,"OWNER")),U,2)
+12 SET PAT("patientRecordFlag",I,"originatingSite")=$PIECE($GET(HMPF(I,"ORIGSITE")),U,2)
+13 SET N=1
SET X=$GET(HMPF(I,"NARR",1,0))
+14 FOR
SET N=$ORDER(HMPF(I,"NARR",N))
if N<1
QUIT
SET X=X_$CHAR(13,10)_$GET(HMPF(I,"NARR",N,0))
+15 SET PAT("patientRecordFlag",I,"text")=X
End DoDot:1
+16 SET X=$$CWAD^ORQPT2(DFN)
+17 IF X]""
SET PAT("cwadf")=X
+18 IF $DATA(PAT("patientRecordFlag"))
SET PAT("cwadf")=$GET(PAT("cwadf"))_"F"
+19 QUIT
+20 ;
ATC ;-address & telecom
+1 NEW VAPA,CNT,X,I,P,NM
+2 ; VAPA("P")="" ;permanent address
+3 DO ADD^VADPT
SET CNT=0
IF $$VAPA(1,5)
Begin DoDot:1
+4 SET CNT=CNT+1
+5 DO ADD(1,2,3,4,5,11,9,10)
+6 SET PAT("address",CNT,"use")=$SELECT($LENGTH(VAPA(9)):"TMP",1:"H")
End DoDot:1
+7 ;confidential address
IF VAPA(12)
Begin DoDot:1
+8 SET CNT=CNT+1
+9 DO ADD(13,14,15,16,17,18,20,21)
+10 SET PAT("address",CNT,"use")="CONF"
+11 SET I=0
FOR
SET I=$ORDER(VAPA(22,I))
if I=""
QUIT
SET X=VAPA(22,I)
Begin DoDot:2
+12 SET PAT("address",CNT,"category",I,"name")=$PIECE(X,U,2)
+13 SET PAT("address",CNT,"category",I,"status")=$$BOOL($PIECE(X,U,3))
End DoDot:2
End DoDot:1
+14 ;
+15 ; X=home^cell^work phones
+16 SET X=$$FORMAT(VAPA(8))_U_$$FORMAT($$GET1^DIQ(2,DFN_",",.134))_U_$$FORMAT($$GET1^DIQ(2,DFN_",",.132))
+17 SET NM="H^MC^WP"
FOR P=1:1:3
IF $LENGTH($PIECE(X,U,P))
Begin DoDot:1
+18 SET I=$PIECE(NM,U,P)
SET PAT("telecom",P,"use")=I
+19 SET PAT("telecom",P,"value")=$PIECE(X,U,P)
End DoDot:1
+20 SET X=$PIECE($GET(^DPT(DFN,.13)),U,3)
if X'=""
SET PAT("email")=X
+21 IF +$PIECE($GET(^DPT(DFN,.11)),U,16)>0
SET PAT("badAddress")=$$GET1^DIQ(2,DFN_",",.121)
+22 QUIT
+23 ;
ADD(LINE1,LINE2,LINE3,CITY,STATE,ZIP,START,STOP) ; -- address set
+1 if $LENGTH(VAPA(LINE1))
SET PAT("address",CNT,"line1")=VAPA(LINE1)
+2 if $LENGTH(VAPA(LINE2))
SET PAT("address",CNT,"line2")=VAPA(LINE2)
+3 if $LENGTH(VAPA(LINE3))
SET PAT("address",CNT,"line3")=VAPA(LINE3)
+4 if $LENGTH(VAPA(CITY))
SET PAT("address",CNT,"city")=VAPA(CITY)
+5 SET X=$PIECE(VAPA(STATE),U)
if X
SET PAT("address",CNT,"state")=$$GET1^DIQ(5,+X_",",1)
+6 SET X=$PIECE(VAPA(ZIP),U,2)
if $LENGTH(X)
SET PAT("address",CNT,"zip")=X
+7 SET X=+VAPA(START)
if X
SET PAT("address",CNT,"start")=$$JSONDT^HMPUTILS(X)
+8 SET X=+VAPA(STOP)
if X
SET PAT("address",CNT,"end")=$$JSONDT^HMPUTILS(X)
+9 QUIT
+10 ;
VAPA(BEG,END) ; -- VAPA nodes have data?
+1 NEW I,Y
SET Y=0
+2 FOR I=BEG:1:END
IF $LENGTH($GET(VAPA(I)))
SET Y=1
QUIT
+3 QUIT Y
+4 ;
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("contact",S,"typeCode")="urn:va:pat-contact:"_$PIECE(TYPE,U)
+6 SET PAT("contact",S,"typeName")=$PIECE(TYPE,U,2)
+7 if $LENGTH(VAOA(9))
SET PAT("contact",S,"name")=VAOA(9)
+8 if $LENGTH(VAOA(10))
SET PAT("contact",S,"relationship")=VAOA(10)
+9 if $LENGTH(VAOA(1))
SET PAT("contact",S,"address",1,"line1")=VAOA(1)
+10 if $LENGTH(VAOA(2))
SET PAT("contact",S,"address",1,"line2")=VAOA(2)
+11 if $LENGTH(VAOA(3))
SET PAT("contact",S,"address",1,"line3")=VAOA(3)
+12 if $LENGTH(VAOA(4))
SET PAT("contact",S,"address",1,"city")=VAOA(4)
+13 SET X=$PIECE(VAOA(5),U)
if X
SET PAT("contact",S,"address",1,"state")=$$GET1^DIQ(5,+X_",",1)
+14 SET X=$PIECE(VAOA(11),U,2)
if $LENGTH(X)
SET PAT("contact",S,"address",1,"zip")=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("contact",S,"telecom",P,"use")=I
+19 SET PAT("contact",S,"telecom",P,"value")=$PIECE(X,U,P)
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
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=$GET(^(I,0))
Begin DoDot:1
+3 SET PAT("alias",I,"fullName")=$PIECE(X,U)
End DoDot:1
+4 QUIT
+5 ;
FAC ;-treating facilities [see FACLIST^ORWCIRN]
+1 ;DE4496 19 August 2016
NEW IFN
SET DFN=+$GET(DFN)
IF '(DFN>0)
DO LOGDPT^HMPLOG(DFN)
QUIT
+2 NEW HMPY,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(.HMPY,DFN)
+5 ;home facility
SET HOME=+$PIECE($GET(^DPT(DFN,"MPI")),U,3)
+6 ;not setup
IF $PIECE($GET(HMPY(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 HMPY(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(HMPY(I))
if I<1
QUIT
Begin DoDot:1
+11 ;unknown
SET X=HMPY(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("facility",I,"code")=$PIECE(X,U)
+15 ;name
SET PAT("facility",I,"name")=$PIECE(X,U,2)
+16 if IEN=HOME
SET PAT("facility",I,"homeSite")="true"
+17 if $LENGTH($PIECE(X,U,3))
SET PAT("facility",I,"latestDate")=$$JSONDT^HMPUTILS($PIECE($PIECE(X,U,3),"."))
+18 IF $DATA(VASITE(+X))
Begin DoDot:2
+19 SET PAT("facility",I,"localPatientId")=DFN
+20 SET PAT("facility",I,"systemId")=HMPSYS
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
PC ;-primary care assignments
+1 DO GETPATTM^HMPCRPC1(.PAT,DFN)
+2 QUIT
+3 NEW X
SET X=$$OUTPTPR^SDUTL3(DFN)
IF X
Begin DoDot:1
+4 SET PAT("pcProviderUid")=$$SETUID^HMPUTILS("user",,+X)
+5 SET PAT("pcProviderName")=$PIECE(X,U,2)
End DoDot:1
+6 SET X=$$OUTPTTM^SDUTL3(DFN)
IF X
Begin DoDot:1
+7 SET PAT("pcTeamUid")=$$SETUID^HMPUTILS("team",,+X)
+8 SET PAT("pcTeamName")=$PIECE(X,U,2)
End DoDot:1
+9 QUIT
+10 ;
INPT ;-inpatient information
+1 NEW ADM,X,Y,Z,I,HL,TS
+2 ;current admission mvt
SET ADM=+$GET(^DPT(DFN,.105))
if ADM<1
QUIT
+3 SET PAT("admissionUid")=$$SETUID^HMPUTILS("visit",DFN,"H"_ADM)
+4 SET X=$PIECE($GET(^DPT(DFN,.101)),U)
if X]""
SET PAT("roomBed")=X
+5 SET X=$PIECE($GET(^DPT(DFN,.1)),U)
IF X]""
Begin DoDot:1
+6 SET PAT("inpatientLocation")=X
+7 SET I=+$ORDER(^DIC(42,"B",X,0))
SET HL=+$GET(^DIC(42,I,44))
if HL<1
QUIT
+8 SET X=$PIECE($GET(^SC(HL,0)),U,2)
if X]""
SET PAT("shortInpatientLocation")=X
End DoDot:1
+9 ;
+10 ;treating specialty
SET TS=$GET(^DPT(DFN,.103))
IF TS
Begin DoDot:1
+11 SET X=$$TSDATA^DGACT(45.7,+TS,.Y)
if X<1
QUIT
+12 SET PAT("specialty")=$GET(Y(1))
SET X=""
+13 SET PAT("specialtyUid")=$$SETUID^HMPUTILS("specialty",,+TS)
+14 IF +$GET(Y(2))>0
SET X=$$TSDATA^DGACT(42.4,+Y(2),.Z)
+15 IF X>0
IF $GET(Z(3))]""
SET PAT("specialtyService")=$PIECE(Z(3),U)
End DoDot:1
+16 QUIT
+17 ;
INS ;-insurance information
+1 NEW X,I,HMPX,HMPINS
+2 SET X=$$INSUR^IBBAPI(DFN,,,.HMPX,"*")
if X<1
QUIT
+3 SET I=0
FOR
SET I=$ORDER(HMPX("IBBAPI","INSUR",I))
if I<1
QUIT
Begin DoDot:1
+4 KILL HMPINS
MERGE HMPINS=HMPX("IBBAPI","INSUR",I)
+5 SET PAT("insurance",I,"id")=DFN_";"_+$GET(HMPINS(1))_";"_+$GET(HMPINS(8))
+6 ; = DFN;COMPANY;POLICY
+7 SET PAT("insurance",I,"companyName")=$PIECE(HMPINS(1),U,2)
+8 ;DE942 - Convert effective and expiration dates to JSON format - TW
+9 if $GET(HMPINS(10))]""
SET PAT("insurance",I,"effectiveDate")=$$JSONDT^HMPUTILS(HMPINS(10))
+10 if $GET(HMPINS(11))]""
SET PAT("insurance",I,"expirationDate")=$$JSONDT^HMPUTILS(HMPINS(11))
+11 if $GET(HMPINS(18))]""
SET PAT("insurance",I,"groupNumber")=HMPINS(18)
+12 if $GET(HMPINS(21))]""
SET PAT("insurance",I,"policyType")=$PIECE(HMPINS(21),U,2)
+13 SET X=$PIECE($GET(HMPINS(12)),U,2)
if X="PATIENT"
SET X="SELF"
+14 if X]""
SET PAT("insurance",I,"policyHolder")=X
End DoDot:1
+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 IF X>0
QUIT "true"
+2 SET X=$EXTRACT(X)
IF X="Y"!(X="y")
QUIT "true"
+3 QUIT "false"
