HMPCRPC1 ;SLC/AGP,ASMR/RRB,CK,JD - Patient and User routine;Aug 10, 2016 11:10:07
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,3**;May 15, 2016;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DPT 10035
; GET1^DIQ(2,...,.121 4080 ;DE6363
; GETS^DIQ(200 10060
;
;DE4474 - JD - 8/10/16: If there are KEYS that don't exist, instead of returning nothing,
; return the KEYS that do exist.
;
Q
;
GETADD(VALUES,DFN) ;
K VAPA
D ADD^VADPT
N INC,NUM,TEMP
I VAPA(12)=1 D
.I $L(VAPA(13))>0 S VALUES("confidentIalAddress","street",0)=VAPA(13)
.I $L(VAPA(14))>0 S VALUES("confidentIalAddress","street",1)=VAPA(14)
.I $L(VAPA(15))>0 S VALUES("confidentIalAddress","street",2)=VAPA(15)
.I $L(VAPA(16))>0 S VALUES("confidentIalAddress","city")=VAPA(16)
.I $L(VAPA(17))>0 S VALUES("confidentIalAddress","state")=$P(VAPA(17),U,2)
.I $L(VAPA(18))>0 S VALUES("confidentIalAddress","zip")=VAPA(18)
.I $L(VAPA(20))>0 S VALUES("confidentIalAddress","startDate")=$P(VAPA(20),U,2)
.I $L(VAPA(21))>0 S VALUES("confidentIalAddress","stopDate")=$P(VAPA(21),U,2)
.S INC=0,NUM=0 F S INC=$O(VAPA(22,INC)) Q:INC="" D
..S NUM=NUM+1,VALUES("confidentIalAddress","catgories",NUM,"category")=$P(VAPA(22,INC),U,2)
..S VALUES("confidentIalAddress","catgories",NUM,"status")=$S($P(VAPA(22,INC),U,3)="Y":"true",1:"false")
;
;I $L(VAPA(1))>0 S VALUES("address","street",0)=VAPA(1)
;I $L(VAPA(2))>0 S VALUES("address","street",1)=VAPA(2)
;I $L(VAPA(3))>0 S VALUES("address","street",2)=VAPA(3)
;I $L(VAPA(4))>0 S VALUES("address","city")=VAPA(4)
;I $L(VAPA(5))>0 S VALUES("address","state")=$P(VAPA(5),U,2)
;I $L(VAPA(6))>0 S VALUES("address","zip")=VAPA(6)
I VAPA(9)]"" S VALUES("temporaryAddress","startDate")=$P(VAPA(9),U,2)
I VAPA(10)]"" S VALUES("temporaryAddress","stopDate")=$P(VAPA(10),U,2)
ADDX ;
;I $L(VAPA(8))>0 S VALUES("address","phone")=VAPA(8)
I $P($G(^DPT(DFN,.13)),U,3)'="" S VALUES("email")=$P($G(^DPT(DFN,.13)),U,3) ;ICR 10035
I +$P($G(^DPT(DFN,.11)),U,16)>0 S VALUES("badAddress")=$$GET1^DIQ(2,DFN_",",.121) ;ICR 4080
D KVAR^VADPT
Q
;
GETBSA(DFN) ;
N DATE,DATA,NFOUND,TEST,TEXT
S TEST=""
D BSA^PXRMBMI(DFN,1,0,DT,.NFOUND,.TEST,.DATE,.DATA,.TEXT)
Q +$G(DATA(1,"BSA"))
;
GETBMI(DFN) ;
; BMI(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT)
N DATE,DATA,NFOUND,TEST,TEXT
D BMI^PXRMBMI(DFN,1,0,DT,.NFOUND,.TEST,.DATE,.DATA,.TEXT)
Q +$G(DATA(1,"BMI"))
;
GETDEM(VALUES,DFN) ;
D DEM^VADPT
S VALUES("name")=VADM(1)
I VADM(2)]"" S VALUES("ssn")=$P(VADM(2),U,2)
I VADM(3)]"" S VALUES("dob")=$P(VADM(3),U,2)
I VADM(4)]"" S VALUES("age")=VADM(4)
I VADM(5)]"" S VALUES("gender")=$P(VADM(5),U,2)
I VADM(6)]"" S VALUES("dateDeath")=$P(VADM(6),U,2)
I VADM(7)]"" S VALUES("remarks")=VADM(7)
I VADM(8)]"" S VALUES("race")=$P(VADM(8),U,2)
D KVAR^VADPT
Q
;
GETKEYS(VALUES,USER) ;
N NAME,HMPERR,HMPLIST,CNT
; DE4474 - Replaced LIST^DIC with GETS^DIQ since the former would kill the output array if
; there were any errors. Therefore, NO keys would have been extracted even if there were
; only one non-existent key.
; The "N" flag will signal the API not to create an entry in HMPLIST array if the value of
; the field is null. So, if there is a non-existent key, it will NOT have a description
; and therefore will NOT have an entry in HMPLIST. This way, the existent keys will be
; extracted and the non-existent keys will be skipped.
D GETS^DIQ(200,USER_",","51*","EN","HMPLIST","HMPERR") ;ICR 10060
S CNT=0 F S CNT=$O(HMPLIST(200.051,CNT)) Q:CNT'>0 D
. S NAME=$G(HMPLIST(200.051,CNT,.01,"E")) Q:NAME=""
. S VALUES("vistaKeys",NAME)="TRUE"
Q
;
GETNOK(VALUES,DFN,TYPE) ;
K VAOA
S VAOA("A")=TYPE
N CNT,CONTACT
S CONTACT=$S(TYPE=3:"secondary",1:"primary")
S CNT=$S(TYPE=3:2,1:1)
D OAD^VADPT
;
I VAOA(9)]"" S VALUES("nok",CNT,"name")=VAOA(9)
I VAOA(10)]"" S VALUES("nok",CNT,"relationship")=VAOA(10)
I VAOA(1)]"" S VALUES("nok",CNT,"address","street",1)=VAOA(1)
I VAOA(2)]"" S VALUES("nok",CNT,"address","street",2)=VAOA(2)
I VAOA(3)]"" S VALUES("nok",CNT,"address","street",3)=VAOA(3)
I VAOA(4)]"" S VALUES("nok",CNT,"address","city")=VAOA(4)
I VAOA(5)]"" S VALUES("nok",CNT,"address","state")=$P(VAOA(5),U,2)
I VAOA(6)]"" S VALUES("nok",CNT,"address","zip")=VAOA(6)
I VAOA(8)]"" S VALUES("nok",CNT,"address","phone")=VAOA(8)
D KVAR^VADPT
Q
;
GETMEANS(VALUES,DFN) ;
K VAEL
D ELIG^VADPT
I VAEL(9)]"" S VALUES("meanStatus")=$P(VAEL(9),U,2)
D KVAR^VADPT
Q
;
GETPATI(RESULT,DFN) ;
N TYPE,VALUES,HMPERR,Y,HMPODEM,HMPSYS
S HMPSYS=$$SYS^HMPUTILS
D DPT1OD^HMPDJ00(.VALUES)
G GPQ
S VALUES("pid")=$$PID^HMPDJFS(DFN)
;D BUILDUID^HMPPARAM(.VALUES,"patient",DFN)
;D GETDEM(.VALUES,DFN)
D GETADD(.VALUES,DFN)
;F TYPE=1,3 D GETNOK(.VALUES,DFN,TYPE)
D GETPATTM(.VALUES,DFN)
;D GETPATVI(.VALUES,DFN)
D GETPATIP(.VALUES,DFN)
D GETMEANS(.VALUES,DFN)
D PRF^HMPFPTC(DFN,.VALUES)
S Y=$$CWAD^ORQPT2(DFN)
I Y]"" S VALUES("cwad")=Y
I $D(VALUES("patientRecordFlags")) S VALUES("cwad")=$G(VALUES("cwad"))_"F"
;D PTINQ^ORWPT(.DEM,DFN)
;S NUM=5,STR=""
;F S NUM=$O(@DEM@(NUM)) Q:NUM'>0 D
;.S VALUES("patDemDetails","text","\",NUM)=@DEM@(NUM)_$C(13,10)
S VALUES("success")="true"
GPQ D ENCODE^HMPJSON("VALUES","RESULT","HMPERR")
I $D(HMPERR) D
.K RESULT N TEMP,TXT
.S TXT(1)="Problem encoding json output."
.D SETERROR^HMPUTILS(.TEMP,.HMPERR,.TXT,.VALUES)
.K HMPERR D ENCODE^HMPJSON("TEMP","RESULT","HMPERR")
Q
;
GETPATIP(VALUES,DFN) ;
N HMPDATA
D INPLOC^ORWPT(.HMPDATA,DFN)
I +HMPDATA D
. S VALUES("shortInpatientLocation")=$P($G(^SC(+HMPDATA,0)),U,2)
. S VALUES("inpatientLocation")=$P(HMPDATA,U,2)
I $P($G(^DPT(DFN,.101)),U)'="" S VALUES("roomBed")=$P($G(^DPT(DFN,.101)),U)
Q
;
GETPATVI(VALUES,DFN) ; DE2818 - PB - Code commented out during SQA review/modifications
;N BMI,DAS,HT,LDATE,HMPTEMP,WT,BSA
;;get weight
;S LDATE=$O(^PXRMINDX(120.5,"PI",DFN,9,""),-1)
;I LDATE>0 D
;.S DAS=$O(^PXRMINDX(120.5,"PI",DFN,9,LDATE,""))
;.I DAS']"" Q
;.D GETDATA^PXRMVITL(DAS,.HMPTEMP)
;.S WT=HMPTEMP("VALUE")
;.S VALUES("lastVitals","weight","value")=WT
;.S VALUES("lastVitals","weight","lastDone")=$$FMTE^XLFDT(LDATE,"D")
;;get height
;K LDATE,DAS
;S LDATE=$O(^PXRMINDX(120.5,"PI",DFN,8,""),-1)
;I LDATE>0 D
;.S DAS=$O(^PXRMINDX(120.5,"PI",DFN,8,LDATE,""))
;.I DAS']"" Q
;.D GETDATA^PXRMVITL(DAS,.HMPTEMP)
;.S HT=HMPTEMP("VALUE")
;.S VALUES("lastVitals","height","value")=HT
;.S VALUES("lastVitals","height","lastDone")=$$FMTE^XLFDT(LDATE,"D")
;S BMI=$$GETBMI(DFN)
;I BMI>0 S VALUES("lastVitals","bmi")=BMI
;S BSA=$$GETBSA(DFN)
;I BSA>0 S VALUES("lastVitals","bsa")=BSA
;Q
;
GETPATTM(VALUES,DFN) ; -- returns treating team info
N CNT,PROV,TEAM,MH,HMPTEAM,MHTEAM
S PROV=$$OUTPTPR^SDUTL3(DFN) D NP(+PROV,"primaryProvider")
S PROV=$$OUTPTAP^SDUTL3(DFN) D NP(+PROV,"associateProvider")
S PROV=$G(^DPT(DFN,.1041)) D NP(+PROV,"attendingProvider")
S PROV=$G(^DPT(DFN,.104)) D NP(+PROV,"inpatientProvider")
;
S TEAM=$$OUTPTTM^SDUTL3(DFN) I TEAM D
. S VALUES("teamInfo","team","uid")=$$SETUID^HMPUTILS("team",,+TEAM)
. S VALUES("teamInfo","team","name")=$P(TEAM,U,2)
. S VALUES("teamInfo","team","phone")=$P($G(^SCTM(404.51,+TEAM,0)),U,2)
I 'TEAM S VALUES("teamInfo","team","name")="unassigned"
;
S MH=$$START^SCMCMHTC(DFN) D NP(+MH,"mhCoordinator")
S VALUES("teamInfo","mhCoordinator","mhPosition")=$S(MH:$P(MH,U,3),1:"unassigned")
S VALUES("teamInfo","mhCoordinator","mhTeam")=$S(MH:$P(MH,U,5),1:"unassigned")
;US5234 - Add Mental Health Team Office Phone - TW
I $P($G(MH),U,5)'="" D
. S MHTEAM=$O(^SCTM(404.51,"B",$P(MH,U,5),""))
. S VALUES("teamInfo","mhCoordinator","mhTeamOfficePhone")=$$GET1^DIQ(404.51,MHTEAM_",",.02)
;
D PCDETAIL^ORWPT1(.HMPTEAM,DFN)
S CNT=0 F S CNT=$O(HMPTEAM(CNT)) Q:CNT'>0 D
. S VALUES("teamInfo","text","\",CNT)=HMPTEAM(CNT)_$C(13,10)
Q
NP(X,TYPE) ; -- add New Person data to teamInfo array
Q:$G(TYPE)=""
I $G(X)'>0 S VALUES("teamInfo",TYPE,"name")="unassigned" Q
S VALUES("teamInfo",TYPE,"uid")=$$SETUID^HMPUTILS("user",,+X)
S VALUES("teamInfo",TYPE,"name")=$P($G(^VA(200,+X,0)),U)
S VALUES("teamInfo",TYPE,"analogPager")=$P($G(^VA(200,+X,.13)),U,7)
S VALUES("teamInfo",TYPE,"digitalPager")=$P($G(^VA(200,+X,.13)),U,8)
S VALUES("teamInfo",TYPE,"officePhone")=$P($G(^VA(200,+X,.13)),U,2)
Q
;
GETPOS(VALUES,USER) ;
; this returns the list of position for an user
N CNT,NODE,NUM,ROLEIEN,ROLE,TEAM,TEAMIEN,TEAMPHN,HMPLIST,HMPERR
;$$TPPR^SCAPMC(DUZ,SCDATES,SCPURPA,SCROLEA,"LIST",HMPERR)
S NUM=$$TPPR^SCAPMC(USER,"","","","",.HMPERR)
F CNT=1:1:NUM D
.S NODE=$G(^TMP("SC TMP LIST",$J,CNT))
.S VALUES("vistaPositions",CNT,"position")=$P(NODE,U,2)
.S VALUES("vistaPositions",CNT,"effectiveDate")=$P(NODE,U,5)
.S VALUES("vistaPositions",CNT,"inactiveDate")=$P(NODE,U,6)
.S TEAMIEN=$P(NODE,U,3)
.S TEAM=$$GET1^DIQ(404.51,(+TEAMIEN_","),.01)
.S TEAMPHN=$$GET1^DIQ(404.51,(+TEAMIEN_","),.02)
.S VALUES("vistaPositions",CNT,"teamName")=TEAM
.S VALUES("vistaPositions",CNT,"teamPhone")=TEAMPHN
.I $P(NODE,U,9)>0 D
.S VALUES("vistaPositions",CNT,"role")=$$GET1^DIQ(8930,($P(NODE,U,9)_","),.01)
Q
;
GETUSERC(VALUES,USER) ;
N ARRAY,CNT,EFFDATE,EXPDATE,ID,IND,LIST,NODE
D WHATIS^USRLM(USER,"LIST",1)
;LIST(Uppername_indicator)=UserClassIEN^MembershipIEN^name^EffectDt^ExpireDt
S IND=0,CNT=0 F S IND=$O(LIST(IND)) Q:IND="" D
.S NODE=LIST(IND)
.S EFFDATE=$P(NODE,U,4),EXPDATE=$P(NODE,U,5)
.I EFFDATE>0,EFFDATE>DT Q
.I EXPDATE>0,EXPDATE<DT Q
.S CNT=CNT+1
.S ID=$P(NODE,U)
.S ARRAY(ID)=""
.S VALUES("vistaUserClass",CNT,"role")=$P(NODE,U,3)
.S VALUES("vistaUserClass",CNT,"uid")=$$SETUID^HMPUTILS("asu-class","",ID,"")
.S VALUES("vistaUserClass",CNT,"effectiveDate")=EFFDATE
.S VALUES("vistaUserClass",CNT,"expirationDate")=EXPDATE
.I $D(^USR(8930,"AD",ID)) D GETUCPAR(.VALUES,ID,.CNT,.ARRAY)
I CNT=0 D
.S ID=$O(^USR(8930,"B","USER","")) I +ID'>0 Q
.S CNT=CNT+1
.S VALUES("vistaUserClass",CNT,"role")=$P($G(^USR(8930,ID,0)),U)
.S VALUES("vistaUserClass",CNT,"uid")=$$SETUID^HMPUTILS("asu-class","",ID,"")
Q
GETUCPAR(VALUES,ID,CNT,ARRAY) ;
N IEN,ROLE
S IEN=0 F S IEN=$O(^USR(8930,"AD",ID,IEN)) Q:IEN'>0 D
.I $D(ARRAY(IEN)) Q
.S ARRAY(IEN)=""
.S ROLE=$P($G(^USR(8930,IEN,0)),U)
.S CNT=CNT+1
.S VALUES("vistaUserClass",CNT,"role")=ROLE
.S VALUES("vistaUserClass",CNT,"uid")=$$SETUID^HMPUTILS("asu-class","",IEN,"")
.I $D(^USR(8930,"AD",ID)) D GETUCPAR(.VALUES,IEN,.CNT,.ARRAY)
Q
;
GETUSERI(RESULT,USER) ;
N RPCOPT,VALUES,HMPERR,HMPLIST,CPRSPATH
D BUILDUID^HMPPARAM(.VALUES,"user",USER)
S VALUES("timeout")=$$GET^XPAR("USR^SYS","ORWOR TIMEOUT CHART",1,"I")
S VALUES("timeoutCounter")=$$GET^XPAR("USR^SYS^PKG","ORWOR TIMEOUT COUNTDOWN",1,"I")
S CPRSPATH=$$GET^XPAR("USR^SYS","HMP CPRS PATH",1,"I")
S VALUES("cprsPath")=$S($L($G(CPRSPATH))>0:CPRSPATH,1:"")
D FIND^DIC(19,"",1,"X","HMP UI CONTEXT",1,,,,"HMPLIST")
S RPCOPT=$S($D(^HMPLIST("DILIST",0)):-1,1:$P(HMPLIST("DILIST","ID",1,1),"version ",2))
;S VALUES("signingPriv")=$S($D(^XUSEC("ORES",DUZ)):3,$D(^XUSEC("ORELSE",DUZ)):2,$D(^XUSEC("OREMAS",DUZ)):1,1:0)
S VALUES("orderingRole")=$$ORDROLE(USER)
S VALUES("hmpVersion")=RPCOPT
S VALUES("domain")=$$KSP^XUPARAM("WHERE") ; domain
S VALUES("service")=+$G(^VA(200,USER,5)) ; service/section
D GETUSERC(.VALUES,USER)
D GETPOS(.VALUES,USER)
D GETKEYS(.VALUES,USER)
S VALUES("productionAccount")=$S($$PROD^XUPROD=1:"true",1:"false")
;S RESULT=$$ENCODE^HMPJSON("VALUES","HMPERR")
D ENCODE^HMPJSON("VALUES","RESULT","HMPERR")
Q
;
ORDROLE(USER) ; returns the role a person takes in ordering
; VAL: 0=nokey, 1=clerk, 2=nurse, 3=physician, 4=student, 5=bad keys
;I '$G(ORWCLVER) Q 0 ; version of client is to old for ordering
I ($D(^XUSEC("OREMAS",USER))+$D(^XUSEC("ORELSE",USER))+$D(^XUSEC("ORES",USER)))>1 Q 5
I $D(^XUSEC("OREMAS",USER)) Q 1 ; clerk
I $D(^XUSEC("ORELSE",USER)) Q 2 ; nurse
I $D(^XUSEC("ORES",USER)),$D(^XUSEC("PROVIDER",USER)) Q 3 ; doctor
I $D(^XUSEC("PROVIDER",USER)) Q 4 ; student
Q 0
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPCRPC1 12474 printed Oct 16, 2024@17:53:47 Page 2
HMPCRPC1 ;SLC/AGP,ASMR/RRB,CK,JD - Patient and User routine;Aug 10, 2016 11:10:07
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,3**;May 15, 2016;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DPT 10035
+7 ; GET1^DIQ(2,...,.121 4080 ;DE6363
+8 ; GETS^DIQ(200 10060
+9 ;
+10 ;DE4474 - JD - 8/10/16: If there are KEYS that don't exist, instead of returning nothing,
+11 ; return the KEYS that do exist.
+12 ;
+13 QUIT
+14 ;
GETADD(VALUES,DFN) ;
+1 KILL VAPA
+2 DO ADD^VADPT
+3 NEW INC,NUM,TEMP
+4 IF VAPA(12)=1
Begin DoDot:1
+5 IF $LENGTH(VAPA(13))>0
SET VALUES("confidentIalAddress","street",0)=VAPA(13)
+6 IF $LENGTH(VAPA(14))>0
SET VALUES("confidentIalAddress","street",1)=VAPA(14)
+7 IF $LENGTH(VAPA(15))>0
SET VALUES("confidentIalAddress","street",2)=VAPA(15)
+8 IF $LENGTH(VAPA(16))>0
SET VALUES("confidentIalAddress","city")=VAPA(16)
+9 IF $LENGTH(VAPA(17))>0
SET VALUES("confidentIalAddress","state")=$PIECE(VAPA(17),U,2)
+10 IF $LENGTH(VAPA(18))>0
SET VALUES("confidentIalAddress","zip")=VAPA(18)
+11 IF $LENGTH(VAPA(20))>0
SET VALUES("confidentIalAddress","startDate")=$PIECE(VAPA(20),U,2)
+12 IF $LENGTH(VAPA(21))>0
SET VALUES("confidentIalAddress","stopDate")=$PIECE(VAPA(21),U,2)
+13 SET INC=0
SET NUM=0
FOR
SET INC=$ORDER(VAPA(22,INC))
if INC=""
QUIT
Begin DoDot:2
+14 SET NUM=NUM+1
SET VALUES("confidentIalAddress","catgories",NUM,"category")=$PIECE(VAPA(22,INC),U,2)
+15 SET VALUES("confidentIalAddress","catgories",NUM,"status")=$SELECT($PIECE(VAPA(22,INC),U,3)="Y":"true",1:"false")
End DoDot:2
End DoDot:1
+16 ;
+17 ;I $L(VAPA(1))>0 S VALUES("address","street",0)=VAPA(1)
+18 ;I $L(VAPA(2))>0 S VALUES("address","street",1)=VAPA(2)
+19 ;I $L(VAPA(3))>0 S VALUES("address","street",2)=VAPA(3)
+20 ;I $L(VAPA(4))>0 S VALUES("address","city")=VAPA(4)
+21 ;I $L(VAPA(5))>0 S VALUES("address","state")=$P(VAPA(5),U,2)
+22 ;I $L(VAPA(6))>0 S VALUES("address","zip")=VAPA(6)
+23 IF VAPA(9)]""
SET VALUES("temporaryAddress","startDate")=$PIECE(VAPA(9),U,2)
+24 IF VAPA(10)]""
SET VALUES("temporaryAddress","stopDate")=$PIECE(VAPA(10),U,2)
ADDX ;
+1 ;I $L(VAPA(8))>0 S VALUES("address","phone")=VAPA(8)
+2 ;ICR 10035
IF $PIECE($GET(^DPT(DFN,.13)),U,3)'=""
SET VALUES("email")=$PIECE($GET(^DPT(DFN,.13)),U,3)
+3 ;ICR 4080
IF +$PIECE($GET(^DPT(DFN,.11)),U,16)>0
SET VALUES("badAddress")=$$GET1^DIQ(2,DFN_",",.121)
+4 DO KVAR^VADPT
+5 QUIT
+6 ;
GETBSA(DFN) ;
+1 NEW DATE,DATA,NFOUND,TEST,TEXT
+2 SET TEST=""
+3 DO BSA^PXRMBMI(DFN,1,0,DT,.NFOUND,.TEST,.DATE,.DATA,.TEXT)
+4 QUIT +$GET(DATA(1,"BSA"))
+5 ;
GETBMI(DFN) ;
+1 ; BMI(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT)
+2 NEW DATE,DATA,NFOUND,TEST,TEXT
+3 DO BMI^PXRMBMI(DFN,1,0,DT,.NFOUND,.TEST,.DATE,.DATA,.TEXT)
+4 QUIT +$GET(DATA(1,"BMI"))
+5 ;
GETDEM(VALUES,DFN) ;
+1 DO DEM^VADPT
+2 SET VALUES("name")=VADM(1)
+3 IF VADM(2)]""
SET VALUES("ssn")=$PIECE(VADM(2),U,2)
+4 IF VADM(3)]""
SET VALUES("dob")=$PIECE(VADM(3),U,2)
+5 IF VADM(4)]""
SET VALUES("age")=VADM(4)
+6 IF VADM(5)]""
SET VALUES("gender")=$PIECE(VADM(5),U,2)
+7 IF VADM(6)]""
SET VALUES("dateDeath")=$PIECE(VADM(6),U,2)
+8 IF VADM(7)]""
SET VALUES("remarks")=VADM(7)
+9 IF VADM(8)]""
SET VALUES("race")=$PIECE(VADM(8),U,2)
+10 DO KVAR^VADPT
+11 QUIT
+12 ;
GETKEYS(VALUES,USER) ;
+1 NEW NAME,HMPERR,HMPLIST,CNT
+2 ; DE4474 - Replaced LIST^DIC with GETS^DIQ since the former would kill the output array if
+3 ; there were any errors. Therefore, NO keys would have been extracted even if there were
+4 ; only one non-existent key.
+5 ; The "N" flag will signal the API not to create an entry in HMPLIST array if the value of
+6 ; the field is null. So, if there is a non-existent key, it will NOT have a description
+7 ; and therefore will NOT have an entry in HMPLIST. This way, the existent keys will be
+8 ; extracted and the non-existent keys will be skipped.
+9 ;ICR 10060
DO GETS^DIQ(200,USER_",","51*","EN","HMPLIST","HMPERR")
+10 SET CNT=0
FOR
SET CNT=$ORDER(HMPLIST(200.051,CNT))
if CNT'>0
QUIT
Begin DoDot:1
+11 SET NAME=$GET(HMPLIST(200.051,CNT,.01,"E"))
if NAME=""
QUIT
+12 SET VALUES("vistaKeys",NAME)="TRUE"
End DoDot:1
+13 QUIT
+14 ;
GETNOK(VALUES,DFN,TYPE) ;
+1 KILL VAOA
+2 SET VAOA("A")=TYPE
+3 NEW CNT,CONTACT
+4 SET CONTACT=$SELECT(TYPE=3:"secondary",1:"primary")
+5 SET CNT=$SELECT(TYPE=3:2,1:1)
+6 DO OAD^VADPT
+7 ;
+8 IF VAOA(9)]""
SET VALUES("nok",CNT,"name")=VAOA(9)
+9 IF VAOA(10)]""
SET VALUES("nok",CNT,"relationship")=VAOA(10)
+10 IF VAOA(1)]""
SET VALUES("nok",CNT,"address","street",1)=VAOA(1)
+11 IF VAOA(2)]""
SET VALUES("nok",CNT,"address","street",2)=VAOA(2)
+12 IF VAOA(3)]""
SET VALUES("nok",CNT,"address","street",3)=VAOA(3)
+13 IF VAOA(4)]""
SET VALUES("nok",CNT,"address","city")=VAOA(4)
+14 IF VAOA(5)]""
SET VALUES("nok",CNT,"address","state")=$PIECE(VAOA(5),U,2)
+15 IF VAOA(6)]""
SET VALUES("nok",CNT,"address","zip")=VAOA(6)
+16 IF VAOA(8)]""
SET VALUES("nok",CNT,"address","phone")=VAOA(8)
+17 DO KVAR^VADPT
+18 QUIT
+19 ;
GETMEANS(VALUES,DFN) ;
+1 KILL VAEL
+2 DO ELIG^VADPT
+3 IF VAEL(9)]""
SET VALUES("meanStatus")=$PIECE(VAEL(9),U,2)
+4 DO KVAR^VADPT
+5 QUIT
+6 ;
GETPATI(RESULT,DFN) ;
+1 NEW TYPE,VALUES,HMPERR,Y,HMPODEM,HMPSYS
+2 SET HMPSYS=$$SYS^HMPUTILS
+3 DO DPT1OD^HMPDJ00(.VALUES)
+4 GOTO GPQ
+5 SET VALUES("pid")=$$PID^HMPDJFS(DFN)
+6 ;D BUILDUID^HMPPARAM(.VALUES,"patient",DFN)
+7 ;D GETDEM(.VALUES,DFN)
+8 DO GETADD(.VALUES,DFN)
+9 ;F TYPE=1,3 D GETNOK(.VALUES,DFN,TYPE)
+10 DO GETPATTM(.VALUES,DFN)
+11 ;D GETPATVI(.VALUES,DFN)
+12 DO GETPATIP(.VALUES,DFN)
+13 DO GETMEANS(.VALUES,DFN)
+14 DO PRF^HMPFPTC(DFN,.VALUES)
+15 SET Y=$$CWAD^ORQPT2(DFN)
+16 IF Y]""
SET VALUES("cwad")=Y
+17 IF $DATA(VALUES("patientRecordFlags"))
SET VALUES("cwad")=$GET(VALUES("cwad"))_"F"
+18 ;D PTINQ^ORWPT(.DEM,DFN)
+19 ;S NUM=5,STR=""
+20 ;F S NUM=$O(@DEM@(NUM)) Q:NUM'>0 D
+21 ;.S VALUES("patDemDetails","text","\",NUM)=@DEM@(NUM)_$C(13,10)
+22 SET VALUES("success")="true"
GPQ DO ENCODE^HMPJSON("VALUES","RESULT","HMPERR")
+1 IF $DATA(HMPERR)
Begin DoDot:1
+2 KILL RESULT
NEW TEMP,TXT
+3 SET TXT(1)="Problem encoding json output."
+4 DO SETERROR^HMPUTILS(.TEMP,.HMPERR,.TXT,.VALUES)
+5 KILL HMPERR
DO ENCODE^HMPJSON("TEMP","RESULT","HMPERR")
End DoDot:1
+6 QUIT
+7 ;
GETPATIP(VALUES,DFN) ;
+1 NEW HMPDATA
+2 DO INPLOC^ORWPT(.HMPDATA,DFN)
+3 IF +HMPDATA
Begin DoDot:1
+4 SET VALUES("shortInpatientLocation")=$PIECE($GET(^SC(+HMPDATA,0)),U,2)
+5 SET VALUES("inpatientLocation")=$PIECE(HMPDATA,U,2)
End DoDot:1
+6 IF $PIECE($GET(^DPT(DFN,.101)),U)'=""
SET VALUES("roomBed")=$PIECE($GET(^DPT(DFN,.101)),U)
+7 QUIT
+8 ;
GETPATVI(VALUES,DFN) ; DE2818 - PB - Code commented out during SQA review/modifications
+1 ;N BMI,DAS,HT,LDATE,HMPTEMP,WT,BSA
+2 ;;get weight
+3 ;S LDATE=$O(^PXRMINDX(120.5,"PI",DFN,9,""),-1)
+4 ;I LDATE>0 D
+5 ;.S DAS=$O(^PXRMINDX(120.5,"PI",DFN,9,LDATE,""))
+6 ;.I DAS']"" Q
+7 ;.D GETDATA^PXRMVITL(DAS,.HMPTEMP)
+8 ;.S WT=HMPTEMP("VALUE")
+9 ;.S VALUES("lastVitals","weight","value")=WT
+10 ;.S VALUES("lastVitals","weight","lastDone")=$$FMTE^XLFDT(LDATE,"D")
+11 ;;get height
+12 ;K LDATE,DAS
+13 ;S LDATE=$O(^PXRMINDX(120.5,"PI",DFN,8,""),-1)
+14 ;I LDATE>0 D
+15 ;.S DAS=$O(^PXRMINDX(120.5,"PI",DFN,8,LDATE,""))
+16 ;.I DAS']"" Q
+17 ;.D GETDATA^PXRMVITL(DAS,.HMPTEMP)
+18 ;.S HT=HMPTEMP("VALUE")
+19 ;.S VALUES("lastVitals","height","value")=HT
+20 ;.S VALUES("lastVitals","height","lastDone")=$$FMTE^XLFDT(LDATE,"D")
+21 ;S BMI=$$GETBMI(DFN)
+22 ;I BMI>0 S VALUES("lastVitals","bmi")=BMI
+23 ;S BSA=$$GETBSA(DFN)
+24 ;I BSA>0 S VALUES("lastVitals","bsa")=BSA
+25 ;Q
+26 ;
GETPATTM(VALUES,DFN) ; -- returns treating team info
+1 NEW CNT,PROV,TEAM,MH,HMPTEAM,MHTEAM
+2 SET PROV=$$OUTPTPR^SDUTL3(DFN)
DO NP(+PROV,"primaryProvider")
+3 SET PROV=$$OUTPTAP^SDUTL3(DFN)
DO NP(+PROV,"associateProvider")
+4 SET PROV=$GET(^DPT(DFN,.1041))
DO NP(+PROV,"attendingProvider")
+5 SET PROV=$GET(^DPT(DFN,.104))
DO NP(+PROV,"inpatientProvider")
+6 ;
+7 SET TEAM=$$OUTPTTM^SDUTL3(DFN)
IF TEAM
Begin DoDot:1
+8 SET VALUES("teamInfo","team","uid")=$$SETUID^HMPUTILS("team",,+TEAM)
+9 SET VALUES("teamInfo","team","name")=$PIECE(TEAM,U,2)
+10 SET VALUES("teamInfo","team","phone")=$PIECE($GET(^SCTM(404.51,+TEAM,0)),U,2)
End DoDot:1
+11 IF 'TEAM
SET VALUES("teamInfo","team","name")="unassigned"
+12 ;
+13 SET MH=$$START^SCMCMHTC(DFN)
DO NP(+MH,"mhCoordinator")
+14 SET VALUES("teamInfo","mhCoordinator","mhPosition")=$SELECT(MH:$PIECE(MH,U,3),1:"unassigned")
+15 SET VALUES("teamInfo","mhCoordinator","mhTeam")=$SELECT(MH:$PIECE(MH,U,5),1:"unassigned")
+16 ;US5234 - Add Mental Health Team Office Phone - TW
+17 IF $PIECE($GET(MH),U,5)'=""
Begin DoDot:1
+18 SET MHTEAM=$ORDER(^SCTM(404.51,"B",$PIECE(MH,U,5),""))
+19 SET VALUES("teamInfo","mhCoordinator","mhTeamOfficePhone")=$$GET1^DIQ(404.51,MHTEAM_",",.02)
End DoDot:1
+20 ;
+21 DO PCDETAIL^ORWPT1(.HMPTEAM,DFN)
+22 SET CNT=0
FOR
SET CNT=$ORDER(HMPTEAM(CNT))
if CNT'>0
QUIT
Begin DoDot:1
+23 SET VALUES("teamInfo","text","\",CNT)=HMPTEAM(CNT)_$CHAR(13,10)
End DoDot:1
+24 QUIT
NP(X,TYPE) ; -- add New Person data to teamInfo array
+1 if $GET(TYPE)=""
QUIT
+2 IF $GET(X)'>0
SET VALUES("teamInfo",TYPE,"name")="unassigned"
QUIT
+3 SET VALUES("teamInfo",TYPE,"uid")=$$SETUID^HMPUTILS("user",,+X)
+4 SET VALUES("teamInfo",TYPE,"name")=$PIECE($GET(^VA(200,+X,0)),U)
+5 SET VALUES("teamInfo",TYPE,"analogPager")=$PIECE($GET(^VA(200,+X,.13)),U,7)
+6 SET VALUES("teamInfo",TYPE,"digitalPager")=$PIECE($GET(^VA(200,+X,.13)),U,8)
+7 SET VALUES("teamInfo",TYPE,"officePhone")=$PIECE($GET(^VA(200,+X,.13)),U,2)
+8 QUIT
+9 ;
GETPOS(VALUES,USER) ;
+1 ; this returns the list of position for an user
+2 NEW CNT,NODE,NUM,ROLEIEN,ROLE,TEAM,TEAMIEN,TEAMPHN,HMPLIST,HMPERR
+3 ;$$TPPR^SCAPMC(DUZ,SCDATES,SCPURPA,SCROLEA,"LIST",HMPERR)
+4 SET NUM=$$TPPR^SCAPMC(USER,"","","","",.HMPERR)
+5 FOR CNT=1:1:NUM
Begin DoDot:1
+6 SET NODE=$GET(^TMP("SC TMP LIST",$JOB,CNT))
+7 SET VALUES("vistaPositions",CNT,"position")=$PIECE(NODE,U,2)
+8 SET VALUES("vistaPositions",CNT,"effectiveDate")=$PIECE(NODE,U,5)
+9 SET VALUES("vistaPositions",CNT,"inactiveDate")=$PIECE(NODE,U,6)
+10 SET TEAMIEN=$PIECE(NODE,U,3)
+11 SET TEAM=$$GET1^DIQ(404.51,(+TEAMIEN_","),.01)
+12 SET TEAMPHN=$$GET1^DIQ(404.51,(+TEAMIEN_","),.02)
+13 SET VALUES("vistaPositions",CNT,"teamName")=TEAM
+14 SET VALUES("vistaPositions",CNT,"teamPhone")=TEAMPHN
+15 IF $PIECE(NODE,U,9)>0
Begin DoDot:2
End DoDot:2
+16 SET VALUES("vistaPositions",CNT,"role")=$$GET1^DIQ(8930,($PIECE(NODE,U,9)_","),.01)
End DoDot:1
+17 QUIT
+18 ;
GETUSERC(VALUES,USER) ;
+1 NEW ARRAY,CNT,EFFDATE,EXPDATE,ID,IND,LIST,NODE
+2 DO WHATIS^USRLM(USER,"LIST",1)
+3 ;LIST(Uppername_indicator)=UserClassIEN^MembershipIEN^name^EffectDt^ExpireDt
+4 SET IND=0
SET CNT=0
FOR
SET IND=$ORDER(LIST(IND))
if IND=""
QUIT
Begin DoDot:1
+5 SET NODE=LIST(IND)
+6 SET EFFDATE=$PIECE(NODE,U,4)
SET EXPDATE=$PIECE(NODE,U,5)
+7 IF EFFDATE>0
IF EFFDATE>DT
QUIT
+8 IF EXPDATE>0
IF EXPDATE<DT
QUIT
+9 SET CNT=CNT+1
+10 SET ID=$PIECE(NODE,U)
+11 SET ARRAY(ID)=""
+12 SET VALUES("vistaUserClass",CNT,"role")=$PIECE(NODE,U,3)
+13 SET VALUES("vistaUserClass",CNT,"uid")=$$SETUID^HMPUTILS("asu-class","",ID,"")
+14 SET VALUES("vistaUserClass",CNT,"effectiveDate")=EFFDATE
+15 SET VALUES("vistaUserClass",CNT,"expirationDate")=EXPDATE
+16 IF $DATA(^USR(8930,"AD",ID))
DO GETUCPAR(.VALUES,ID,.CNT,.ARRAY)
End DoDot:1
+17 IF CNT=0
Begin DoDot:1
+18 SET ID=$ORDER(^USR(8930,"B","USER",""))
IF +ID'>0
QUIT
+19 SET CNT=CNT+1
+20 SET VALUES("vistaUserClass",CNT,"role")=$PIECE($GET(^USR(8930,ID,0)),U)
+21 SET VALUES("vistaUserClass",CNT,"uid")=$$SETUID^HMPUTILS("asu-class","",ID,"")
End DoDot:1
+22 QUIT
GETUCPAR(VALUES,ID,CNT,ARRAY) ;
+1 NEW IEN,ROLE
+2 SET IEN=0
FOR
SET IEN=$ORDER(^USR(8930,"AD",ID,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+3 IF $DATA(ARRAY(IEN))
QUIT
+4 SET ARRAY(IEN)=""
+5 SET ROLE=$PIECE($GET(^USR(8930,IEN,0)),U)
+6 SET CNT=CNT+1
+7 SET VALUES("vistaUserClass",CNT,"role")=ROLE
+8 SET VALUES("vistaUserClass",CNT,"uid")=$$SETUID^HMPUTILS("asu-class","",IEN,"")
+9 IF $DATA(^USR(8930,"AD",ID))
DO GETUCPAR(.VALUES,IEN,.CNT,.ARRAY)
End DoDot:1
+10 QUIT
+11 ;
GETUSERI(RESULT,USER) ;
+1 NEW RPCOPT,VALUES,HMPERR,HMPLIST,CPRSPATH
+2 DO BUILDUID^HMPPARAM(.VALUES,"user",USER)
+3 SET VALUES("timeout")=$$GET^XPAR("USR^SYS","ORWOR TIMEOUT CHART",1,"I")
+4 SET VALUES("timeoutCounter")=$$GET^XPAR("USR^SYS^PKG","ORWOR TIMEOUT COUNTDOWN",1,"I")
+5 SET CPRSPATH=$$GET^XPAR("USR^SYS","HMP CPRS PATH",1,"I")
+6 SET VALUES("cprsPath")=$SELECT($LENGTH($GET(CPRSPATH))>0:CPRSPATH,1:"")
+7 DO FIND^DIC(19,"",1,"X","HMP UI CONTEXT",1,,,,"HMPLIST")
+8 SET RPCOPT=$SELECT($DATA(^HMPLIST("DILIST",0)):-1,1:$PIECE(HMPLIST("DILIST","ID",1,1),"version ",2))
+9 ;S VALUES("signingPriv")=$S($D(^XUSEC("ORES",DUZ)):3,$D(^XUSEC("ORELSE",DUZ)):2,$D(^XUSEC("OREMAS",DUZ)):1,1:0)
+10 SET VALUES("orderingRole")=$$ORDROLE(USER)
+11 SET VALUES("hmpVersion")=RPCOPT
+12 ; domain
SET VALUES("domain")=$$KSP^XUPARAM("WHERE")
+13 ; service/section
SET VALUES("service")=+$GET(^VA(200,USER,5))
+14 DO GETUSERC(.VALUES,USER)
+15 DO GETPOS(.VALUES,USER)
+16 DO GETKEYS(.VALUES,USER)
+17 SET VALUES("productionAccount")=$SELECT($$PROD^XUPROD=1:"true",1:"false")
+18 ;S RESULT=$$ENCODE^HMPJSON("VALUES","HMPERR")
+19 DO ENCODE^HMPJSON("VALUES","RESULT","HMPERR")
+20 QUIT
+21 ;
ORDROLE(USER) ; returns the role a person takes in ordering
+1 ; VAL: 0=nokey, 1=clerk, 2=nurse, 3=physician, 4=student, 5=bad keys
+2 ;I '$G(ORWCLVER) Q 0 ; version of client is to old for ordering
+3 IF ($DATA(^XUSEC("OREMAS",USER))+$DATA(^XUSEC("ORELSE",USER))+$DATA(^XUSEC("ORES",USER)))>1
QUIT 5
+4 ; clerk
IF $DATA(^XUSEC("OREMAS",USER))
QUIT 1
+5 ; nurse
IF $DATA(^XUSEC("ORELSE",USER))
QUIT 2
+6 ; doctor
IF $DATA(^XUSEC("ORES",USER))
IF $DATA(^XUSEC("PROVIDER",USER))
QUIT 3
+7 ; student
IF $DATA(^XUSEC("PROVIDER",USER))
QUIT 4
+8 QUIT 0
+9 ;
