- 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 Feb 18, 2025@23:19:36 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"