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