Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HMPCRPC1

HMPCRPC1.m

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