HMPEF ;SLC/MKB,ASMR/BL,RRB,JD,SRG,CK - Serve VistA operational data as JSON via RPC;Aug 29, 2016 20:06:27
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,2,3**;May 15, 2016;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
; DE2818 - SQA findings. Newed L42 and L44 in LOC+1. RRB - 10/30/2015
;
; DE6652 - JD - 9/1/16: Removed code behind synching sign-symptom domain for operational data.
; SIGNS tag.
;
; ^SC references - IA 10040, HOSPITAL LOCATION file (#44)
; ^DIC(42) references - IA #10039, WARD LOCATION file
Q
;
; The following variables can not be newed or killed because they are used
; from upstream by scope (NOT as input parameters):
; HMPBATCH, HMPFADOM, HMPFLDON, HMPFZTSK, HMPMETA, HMPSTMP, LEX("LIST", and ZTQUEUED.
GET(HMP,FILTER) ; -- Return search results as JSON in @HMP@(n)
; RPC = HMP GET OPERATIONAL DATA
; where FILTER("domain") = name of desired data type (see $$TAG)
; FILTER("limit") = maximum number of items to return [opt]
; FILTER("start") = ien to start search from [opt]
; FILTER("id") = single item id to return [opt]
;
; HMPLAST - last record processed
N HMPSYS,TYPE,HMPMAX,HMPI,HMPID,HMPERR,HMPTN,HMPLAST,HMPCNT,HMPFINI
S HMP=$NA(^TMP("HMP",$J)),HMPI=0 K @HMP
S HMPSYS=$$SYS^HMPUTILS ;DE4463 - CK - 4/22/2016
;
; parse & validate input parameters
S TYPE=$P($G(FILTER("domain")),"#") ;,TYPE=$$LOW^XLFSTR(TYPE)
S HMPMAX=+$G(FILTER("limit")),HMPCNT=0
S HMPLAST=+$G(FILTER("start"))
S HMPID=$G(FILTER("id"))
;
K ^TMP($J,"HMP ERROR")
;
; extract data
I TYPE="" S HMPERR="Missing or invalid reference type" G GTQ
; *** convert code below to use $$HANDLE^XUSRB4 for zero node in ^XTMP, IA 4770***
I $D(ZTQUEUED) S HMP=$NA(^XTMP(HMPBATCH,HMPFZTSK,FILTER("domain"))) K @HMP
I TYPE="new",$L($T(EN^HMPEFX)) D EN^HMPEFX(HMPID,HMPMAX) Q
S HMPTN=$$TAG(TYPE) Q:'$L(HMPTN) ;D ERR(2) Q
D @HMPTN
;
GTQ ; add item count and terminating characters
N ERROR I $D(^TMP($J,"HMP ERROR"))>0 D BUILDERR(.ERROR) S ERROR(1)=ERROR(1)_"}"
I +$G(FILTER("noHead"))=1 D Q
.S @HMP@("total")=+$G(HMPI)
.S @HMP@("last")=HMPLAST
.S @HMP@("finished")=+$G(HMPFINI)
.I $L($G(ERROR(1)))>1 S @HMP@("error")=ERROR(1)
I '$D(@HMP)!'$G(HMPI) D Q
.I '$D(^TMP($J,"HMP ERROR")) S @HMP@(1)="""data"":{""totalItems"":0,""items"":[]}}" Q
.S @HMP@(1)="""data"":{""totalItems"":0,""items"":[]},"
.M @HMP@(2)=ERROR
;
I $D(@HMP),$G(HMPI) D
. S @HMP@(.5)="{""apiVersion"":""1.01"",""data"":{""updated"":"""_$$HL7NOW_""",""currentItemCount"":"_HMPI
. S:$G(HMPCNT) @HMP@(.5)=@HMP@(.5)_",""totalItems"":"_HMPCNT
. S:$G(HMPLAST) @HMP@(.5)=@HMP@(.5)_",""last"":"_HMPLAST
. S @HMP@(.5)=@HMP@(.5)_",""items"":["
. S HMPI=HMPI+1,@HMP@(HMPI)=$S($D(^TMP($J,"HMP ERROR"))>0:"]}",1:"]}}")
I $D(^TMP($J,"HMP ERROR"))>0 S HMPI=HMPI+1,@HMP@(HMPI,.3)="," M @HMP@(HMPI)=ERROR ;S HMPI=HMPI+1,@HMP@(HMPI)="}"
K ^TMP($J,"HMP ERROR")
Q
;
BUILDERR(RESULT) ; error array
N CNT,COUNT,DOM,DOMCNT,ERRMSG,ERROR,FIELD,MESSAGE,MSG,MSGCNT,T,TEMP
S COUNT=$G(^TMP($J,"HMP ERROR","# of Errors"))
S MESSAGE="A mumps error occurred when extracting data. A total of "_COUNT_" occurred.\n\r"
S CNT=1,ERROR("error","message","\",CNT)="A mumps error occurred when extracting patient data. A total of "_COUNT_" occurred.\n\r"
S MSGCNT=0 F S MSGCNT=$O(^TMP($J,"HMP ERROR","ERROR MESSAGE",MSGCNT)) Q:MSGCNT'>0 D
. S CNT=CNT+1,MESSAGE=MESSAGE_$G(^TMP($J,"HMP ERROR","ERROR MESSAGE",MSGCNT))_"\n\r"
S RESULT(1)="""error"":{""message"":"_""""_MESSAGE_""""_"}"
Q
;
TAG(X) ; -- linetag for reference domain X
N Y S Y="HMP",X=$G(X)
; default = HMP Object (various types)
I X="location" S Y="LOC"
I X="pt-select" S Y="PAT"
I X="person" S Y="NP"
I X="user" S Y="NP"
I X="labgroup" S Y="LABGRP"
I X="labpanel" S Y="LABPNL"
I X["orderable" S Y="OI"
I X["schedule" S Y="SCHEDULE"
I X["route" S Y="ROUTE"
I X["quick" S Y="QO"
I X="displayGroup" S Y="ODG"
I X["asu-" S Y="ASU"
I X["doc-" S Y="ASU"
I X="immunization" S Y="IMMTYPE"
I X="allergy-list" S Y="ALLTYPE"
;I X="problem-list" S Y="PROB"
I X="vital-type" S Y="VTYPE"
I X="vital-qualifier" S Y="VQUAL"
I X="vital-category" S Y="VCAT"
I X["clioterm" S Y="MDTERMS"
Q Y
;
ERR(X,VAL) ; return error message
N MSG S MSG="Error"
I X=2 S MSG="Domain type '"_$G(VAL)_"' not recognized"
I X=3 S MSG="UID '"_$G(VAL)_"' not found"
I X=99 S MSG="Unknown request"
Q MSG
;
ERRMSG(X,VAL) ; -- return error message
N Y S Y="A MUMPS error occurred while extracting "_X_" data"
S:$G(VAL) Y=Y_", ien "_VAL
Q Y
;
ERRQ ; -- Quit on error
Q
;
HL7NOW() ; -- Return current time in HL7 format
Q $$FMTHL7^HMPSTMP($$NOW^XLFDT) ; DE5016
;
ALL() ;
Q "location;patient;person;orderable;schedule;route;quick;displayGroup;asu-class;asu-rule;asu-role;doc-action;doc-status;clioterm;immunization;allergy-list;sign-symptom;vital-type;vital-qualifier;vital-category"
;
ADD(ITEM) ; -- add ITEM to @HMP@(HMPI)
N HMPY,HMPERR
I $G(HMPSTMP)]"" S @ITEM@("stampTime")=HMPSTMP ; US6734
E S @ITEM@("stampTime")=$$EN^HMPSTMP("NOW") ; DE2616 - must add stampTime to receive OPD freshness update from ADHOC^HMPUTIL1
D ENCODE^HMPJSON(ITEM,"HMPY","HMPERR")
I $D(HMPERR) D ;return ERRor instead of ITEM
. N HMPTMP,HMPTXT,HMPITM
. M HMPITM=@ITEM K HMPY
. S HMPTXT(1)="Problem encoding json output."
. D SETERROR^HMPUTILS(.HMPTMP,.HMPERR,.HMPTXT,.HMPITM)
. K HMPERR D ENCODE^HMPJSON("HMPTMP","HMPY","HMPERR")
I $D(HMPY) D
. Q:'$D(@ITEM@("uid"))
. I $G(HMPMETA) D ADD^HMPMETA($P(HMPFADOM,"#"),@ITEM@("uid"),HMPSTMP) Q:HMPMETA=1 ;US6734,US11019
. I HMPI D COMMA(HMPI)
. ;I HMPI,'$G(FILTER("noHead")) D COMMA(HMPI)
. S HMPI=HMPI+1 M @HMP@(HMPI)=HMPY
Q
;
COMMA(I) ; -- add comma between items
I $D(ZTQUEUED) Q
N J S J=+$O(@HMP@(I,"A"),-1) ;last sub-node for item I
S J=J+1,@HMP@(I,J)=","
Q
;
TOTAL(ROOT) ; -- Return total #items in @ROOT@(n)
Q $P($G(@ROOT@(0)),U,4)
;
TEST(TYPE,ID,IN) ; -- test GET, write results to screen
N OUT,IDX
S U="^"
S IN("domain")=$G(TYPE)
S:$D(ID) IN("id")=ID
D GET(.OUT,.IN)
;
S IDX=OUT
F S IDX=$Q(@IDX) Q:IDX'?1"^TMP(""HMP"","1.N.E Q:+$P(IDX,",",2)'=$J W !,@IDX
Q
;
; ** Reference file searches, using FILTER("parameter")
;
PAT ;Patients
N DFN,PAT,HMPPOPD
S HMPPOPD=1
S HMPCNT=$$TOTAL("^DPT")
I $G(HMPID) S DFN=+HMPID D LKUP^HMPDJ00 Q
N ERRMSG S ERRMSG="A mumps error occurred while extracting patients."
S DFN=+$G(HMPLAST) F S DFN=$O(^DPT(DFN)) Q:'(DFN>0) D I HMPMAX>0,HMPI'<HMPMAX Q ;DE4496 19 August 2016
. N $ES,$ET
. S $ET="D ERRHDLR^HMPDERRH"
. I $P($G(^DPT(DFN,0)),U)="" D LOGDPT^HMPLOG(DFN) Q ;DE4496 19 August 2016
. S ERRMSG=$$ERRMSG("Patient",DFN)
. K PAT D LKUP^HMPDJ00
. S HMPLAST=DFN
I '(DFN>0) S HMPFINI=1 ;DE4496 19 August 2016
Q
LOC ; Hospital Location (#44) and Ward Location (#42) /DE2818
D LOC^HMPEF1(.HMPFINI,.HMPFLDON,$G(HMPMETA))
Q
;
ACTWRD(IEN) ;Boolean TRUE if active WARD LOCATION
; IEN - IEN in file 42
S D0=IEN D WIN^DGPMDDCF Q 'X ; SRG: need DBIA
;
ACTLOC(LOC) ;Boolean TRUE if active hospital location
; ^SC - IA 10040
N D0,X I +$G(^SC(LOC,"OOS")) Q 0 ; screen out OOS entry
S D0=+$G(^SC(LOC,42)) I D0 D WIN^DGPMDDCF Q 'X ; chk out of svc wards
S X=$G(^SC(LOC,"I")) I +X=0 Q 1 ; no inactivate date
I DT>$P(X,U)&($P(X,U,2)=""!(DT<$P(X,U,2))) Q 0 ; chk reactivate date
Q 1 ; must still be active
;
NP ;New Persons
D NP^HMPEF1
Q
;
KEYS(IEN) ;user's keys
N HMPKEY,IENS,X,CNT
D GETS^DIQ(200,IEN_",","51*","IE","HMPKEY") S CNT=0
S IENS="" F S IENS=$O(HMPKEY(200.051,IENS)) Q:IENS="" D
. S X=$G(HMPKEY(200.051,IENS,.01,"E")),CNT=CNT+1
. S USER("vistaKeys",CNT,"name")=X
. S X=$G(HMPKEY(200.051,IENS,3,"I"))
. S:X USER("vistaKeys",CNT,"reviewDate")=$$JSONDT^HMPUTILS(X)
Q
;
ODG ;
D ADDODG^HMPCORD4
Q
;
OI ;
D OI^HMPCORD4("PS^RAP^LRT")
Q
;
PROB ;get problem list OPD store
D PROB^HMPEF1(.HMPFINI,LEX)
Q
;
QO ;
D QO^HMPCORD4
Q
;
SCHEDULE ;
N RESULT
D ADDSCH^HMPCORD4
Q
;
ROUTE ;
N RESULT
D ADDROUTE^HMPCORD4
Q
;
HMP ; HMP Objects
N IEN
S HMPCNT=$$TOTAL("^HMP(800000.11)")
I $L(HMPID) D Q
. I HMPID=+HMPID S IEN=HMPID
. E S IEN=+$O(^HMP(800000.11,"B",HMPID,0))
. S ERRMSG=$$ERRMSG("HMP Object",IEN)
. D:IEN HMP1^HMPDJ02(800000.11,IEN)
S IEN=+$G(HMPLAST) F S IEN=$O(^HMP(800000.11,"C",TYPE,IEN)) Q:IEN<1 D I HMPMAX>0,HMPI'<HMPMAX Q
. S ERRMSG=$$ERRMSG("HMP Object",IEN)
. D HMP1^HMPDJ02(800000.11,IEN) S HMPLAST=IEN
I IEN<1 S HMPFINI=1
Q
;
SOURCE(SRC) ;
N X S X=""
I SRC["SC(" S X="clinic"
I SRC["DPT(" S X="patient"
I SRC["DIC(42" S X="ward"
I SRC["SCTM" S X="pcmm"
I SRC["OR(100.21" S X="cprs"
I SRC["DIC(45.7" S X="specialty"
I SRC["VA(200" S X="provider"
I SRC["PXRM(810.4" S X="pxrm"
Q X
;
ASU ; ASU files
N X,RTN S X=$P($G(TYPE),"-",2)
S RTN=$$UP^XLFSTR(X)_"^HMPEASU"
I X'="",$L($T(@RTN)) D @RTN
Q
;
MDTERMS ; CP Terminology
D:$L($T(TERM^HMPMDUTL)) TERM^HMPMDUTL
Q
LABGRP ;
D SHWCUMR2^HMPELAB
Q
LABPNL ;
D SHWORPNL^HMPELAB
Q
;
;DE2818, changed reference to ^VA(201) to a FileMan call
ISPROXY(IEN) ; Boolean function, is NEW PERSON entry an APPLICATION PROXY?
N APP,HMPMSG,HMPUCLS,T,V
; APP - returned value
; HMPUCLS - user class array
; HMPMSG - FileMan message array
;
D GETS^DIQ(200,IEN_",","9.5*","E","HMPUCLS","HMPMSG") ; get external format
S APP=0,T="APPLICATION PROXY",V="HMPUCLS"
; search returned array for value equal to T
F S V=$Q(@V) Q:V=""!APP S:@V=T APP=1
Q APP
;
IMMTYPE ;immunization types
D IMMTYPE^HMPCORD5
Q
;
ALLTYPE ;allergy-list types
;BL;REMOVE FROM ODS
;D ALLTYPE^HMPCORD5
Q
;
VTYPE ;vital types
D VTYPE^HMPCORD5
Q
;
VQUAL ;vital qualifiers
D VQUAL^HMPCORD5
Q
;
VCAT ;vital categories
D VCAT^HMPCORD5
Q
;
FILENAME ; text of filenames for search treeview
;;VA Allergies File
;;VA Allergies File (Synonyms) SPACER ONLY - NOT DISPLAYED
;;National Drug File - Generic Drug Name
;;National Drug file - Trade Name
;;Local Drug File
;;Local Drug File (Synonyms) SPACER ONLY - NOT DISPLAYED
;;Drug Ingredients File
;;VA Drug Class File
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPEF 10585 printed Sep 23, 2025@19:29:53 Page 2
HMPEF ;SLC/MKB,ASMR/BL,RRB,JD,SRG,CK - Serve VistA operational data as JSON via RPC;Aug 29, 2016 20:06:27
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,2,3**;May 15, 2016;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; DE2818 - SQA findings. Newed L42 and L44 in LOC+1. RRB - 10/30/2015
+5 ;
+6 ; DE6652 - JD - 9/1/16: Removed code behind synching sign-symptom domain for operational data.
+7 ; SIGNS tag.
+8 ;
+9 ; ^SC references - IA 10040, HOSPITAL LOCATION file (#44)
+10 ; ^DIC(42) references - IA #10039, WARD LOCATION file
+11 QUIT
+12 ;
+13 ; The following variables can not be newed or killed because they are used
+14 ; from upstream by scope (NOT as input parameters):
+15 ; HMPBATCH, HMPFADOM, HMPFLDON, HMPFZTSK, HMPMETA, HMPSTMP, LEX("LIST", and ZTQUEUED.
GET(HMP,FILTER) ; -- Return search results as JSON in @HMP@(n)
+1 ; RPC = HMP GET OPERATIONAL DATA
+2 ; where FILTER("domain") = name of desired data type (see $$TAG)
+3 ; FILTER("limit") = maximum number of items to return [opt]
+4 ; FILTER("start") = ien to start search from [opt]
+5 ; FILTER("id") = single item id to return [opt]
+6 ;
+7 ; HMPLAST - last record processed
+8 NEW HMPSYS,TYPE,HMPMAX,HMPI,HMPID,HMPERR,HMPTN,HMPLAST,HMPCNT,HMPFINI
+9 SET HMP=$NAME(^TMP("HMP",$JOB))
SET HMPI=0
KILL @HMP
+10 ;DE4463 - CK - 4/22/2016
SET HMPSYS=$$SYS^HMPUTILS
+11 ;
+12 ; parse & validate input parameters
+13 ;,TYPE=$$LOW^XLFSTR(TYPE)
SET TYPE=$PIECE($GET(FILTER("domain")),"#")
+14 SET HMPMAX=+$GET(FILTER("limit"))
SET HMPCNT=0
+15 SET HMPLAST=+$GET(FILTER("start"))
+16 SET HMPID=$GET(FILTER("id"))
+17 ;
+18 KILL ^TMP($JOB,"HMP ERROR")
+19 ;
+20 ; extract data
+21 IF TYPE=""
SET HMPERR="Missing or invalid reference type"
GOTO GTQ
+22 ; *** convert code below to use $$HANDLE^XUSRB4 for zero node in ^XTMP, IA 4770***
+23 IF $DATA(ZTQUEUED)
SET HMP=$NAME(^XTMP(HMPBATCH,HMPFZTSK,FILTER("domain")))
KILL @HMP
+24 IF TYPE="new"
IF $LENGTH($TEXT(EN^HMPEFX))
DO EN^HMPEFX(HMPID,HMPMAX)
QUIT
+25 ;D ERR(2) Q
SET HMPTN=$$TAG(TYPE)
if '$LENGTH(HMPTN)
QUIT
+26 DO @HMPTN
+27 ;
GTQ ; add item count and terminating characters
+1 NEW ERROR
IF $DATA(^TMP($JOB,"HMP ERROR"))>0
DO BUILDERR(.ERROR)
SET ERROR(1)=ERROR(1)_"}"
+2 IF +$GET(FILTER("noHead"))=1
Begin DoDot:1
+3 SET @HMP@("total")=+$GET(HMPI)
+4 SET @HMP@("last")=HMPLAST
+5 SET @HMP@("finished")=+$GET(HMPFINI)
+6 IF $LENGTH($GET(ERROR(1)))>1
SET @HMP@("error")=ERROR(1)
End DoDot:1
QUIT
+7 IF '$DATA(@HMP)!'$GET(HMPI)
Begin DoDot:1
+8 IF '$DATA(^TMP($JOB,"HMP ERROR"))
SET @HMP@(1)="""data"":{""totalItems"":0,""items"":[]}}"
QUIT
+9 SET @HMP@(1)="""data"":{""totalItems"":0,""items"":[]},"
+10 MERGE @HMP@(2)=ERROR
End DoDot:1
QUIT
+11 ;
+12 IF $DATA(@HMP)
IF $GET(HMPI)
Begin DoDot:1
+13 SET @HMP@(.5)="{""apiVersion"":""1.01"",""data"":{""updated"":"""_$$HL7NOW_""",""currentItemCount"":"_HMPI
+14 if $GET(HMPCNT)
SET @HMP@(.5)=@HMP@(.5)_",""totalItems"":"_HMPCNT
+15 if $GET(HMPLAST)
SET @HMP@(.5)=@HMP@(.5)_",""last"":"_HMPLAST
+16 SET @HMP@(.5)=@HMP@(.5)_",""items"":["
+17 SET HMPI=HMPI+1
SET @HMP@(HMPI)=$SELECT($DATA(^TMP($JOB,"HMP ERROR"))>0:"]}",1:"]}}")
End DoDot:1
+18 ;S HMPI=HMPI+1,@HMP@(HMPI)="}"
IF $DATA(^TMP($JOB,"HMP ERROR"))>0
SET HMPI=HMPI+1
SET @HMP@(HMPI,.3)=","
MERGE @HMP@(HMPI)=ERROR
+19 KILL ^TMP($JOB,"HMP ERROR")
+20 QUIT
+21 ;
BUILDERR(RESULT) ; error array
+1 NEW CNT,COUNT,DOM,DOMCNT,ERRMSG,ERROR,FIELD,MESSAGE,MSG,MSGCNT,T,TEMP
+2 SET COUNT=$GET(^TMP($JOB,"HMP ERROR","# of Errors"))
+3 SET MESSAGE="A mumps error occurred when extracting data. A total of "_COUNT_" occurred.\n\r"
+4 SET CNT=1
SET ERROR("error","message","\",CNT)="A mumps error occurred when extracting patient data. A total of "_COUNT_" occurred.\n\r"
+5 SET MSGCNT=0
FOR
SET MSGCNT=$ORDER(^TMP($JOB,"HMP ERROR","ERROR MESSAGE",MSGCNT))
if MSGCNT'>0
QUIT
Begin DoDot:1
+6 SET CNT=CNT+1
SET MESSAGE=MESSAGE_$GET(^TMP($JOB,"HMP ERROR","ERROR MESSAGE",MSGCNT))_"\n\r"
End DoDot:1
+7 SET RESULT(1)="""error"":{""message"":"_""""_MESSAGE_""""_"}"
+8 QUIT
+9 ;
TAG(X) ; -- linetag for reference domain X
+1 NEW Y
SET Y="HMP"
SET X=$GET(X)
+2 ; default = HMP Object (various types)
+3 IF X="location"
SET Y="LOC"
+4 IF X="pt-select"
SET Y="PAT"
+5 IF X="person"
SET Y="NP"
+6 IF X="user"
SET Y="NP"
+7 IF X="labgroup"
SET Y="LABGRP"
+8 IF X="labpanel"
SET Y="LABPNL"
+9 IF X["orderable"
SET Y="OI"
+10 IF X["schedule"
SET Y="SCHEDULE"
+11 IF X["route"
SET Y="ROUTE"
+12 IF X["quick"
SET Y="QO"
+13 IF X="displayGroup"
SET Y="ODG"
+14 IF X["asu-"
SET Y="ASU"
+15 IF X["doc-"
SET Y="ASU"
+16 IF X="immunization"
SET Y="IMMTYPE"
+17 IF X="allergy-list"
SET Y="ALLTYPE"
+18 ;I X="problem-list" S Y="PROB"
+19 IF X="vital-type"
SET Y="VTYPE"
+20 IF X="vital-qualifier"
SET Y="VQUAL"
+21 IF X="vital-category"
SET Y="VCAT"
+22 IF X["clioterm"
SET Y="MDTERMS"
+23 QUIT Y
+24 ;
ERR(X,VAL) ; return error message
+1 NEW MSG
SET MSG="Error"
+2 IF X=2
SET MSG="Domain type '"_$GET(VAL)_"' not recognized"
+3 IF X=3
SET MSG="UID '"_$GET(VAL)_"' not found"
+4 IF X=99
SET MSG="Unknown request"
+5 QUIT MSG
+6 ;
ERRMSG(X,VAL) ; -- return error message
+1 NEW Y
SET Y="A MUMPS error occurred while extracting "_X_" data"
+2 if $GET(VAL)
SET Y=Y_", ien "_VAL
+3 QUIT Y
+4 ;
ERRQ ; -- Quit on error
+1 QUIT
+2 ;
HL7NOW() ; -- Return current time in HL7 format
+1 ; DE5016
QUIT $$FMTHL7^HMPSTMP($$NOW^XLFDT)
+2 ;
ALL() ;
+1 QUIT "location;patient;person;orderable;schedule;route;quick;displayGroup;asu-class;asu-rule;asu-role;doc-action;doc-status;clioterm;immunization;allergy-list;sign-symptom;vital-type;vital-qualifier;vital-category"
+2 ;
ADD(ITEM) ; -- add ITEM to @HMP@(HMPI)
+1 NEW HMPY,HMPERR
+2 ; US6734
IF $GET(HMPSTMP)]""
SET @ITEM@("stampTime")=HMPSTMP
+3 ; DE2616 - must add stampTime to receive OPD freshness update from ADHOC^HMPUTIL1
IF '$TEST
SET @ITEM@("stampTime")=$$EN^HMPSTMP("NOW")
+4 DO ENCODE^HMPJSON(ITEM,"HMPY","HMPERR")
+5 ;return ERRor instead of ITEM
IF $DATA(HMPERR)
Begin DoDot:1
+6 NEW HMPTMP,HMPTXT,HMPITM
+7 MERGE HMPITM=@ITEM
KILL HMPY
+8 SET HMPTXT(1)="Problem encoding json output."
+9 DO SETERROR^HMPUTILS(.HMPTMP,.HMPERR,.HMPTXT,.HMPITM)
+10 KILL HMPERR
DO ENCODE^HMPJSON("HMPTMP","HMPY","HMPERR")
End DoDot:1
+11 IF $DATA(HMPY)
Begin DoDot:1
+12 if '$DATA(@ITEM@("uid"))
QUIT
+13 ;US6734,US11019
IF $GET(HMPMETA)
DO ADD^HMPMETA($PIECE(HMPFADOM,"#"),@ITEM@("uid"),HMPSTMP)
if HMPMETA=1
QUIT
+14 IF HMPI
DO COMMA(HMPI)
+15 ;I HMPI,'$G(FILTER("noHead")) D COMMA(HMPI)
+16 SET HMPI=HMPI+1
MERGE @HMP@(HMPI)=HMPY
End DoDot:1
+17 QUIT
+18 ;
COMMA(I) ; -- add comma between items
+1 IF $DATA(ZTQUEUED)
QUIT
+2 ;last sub-node for item I
NEW J
SET J=+$ORDER(@HMP@(I,"A"),-1)
+3 SET J=J+1
SET @HMP@(I,J)=","
+4 QUIT
+5 ;
TOTAL(ROOT) ; -- Return total #items in @ROOT@(n)
+1 QUIT $PIECE($GET(@ROOT@(0)),U,4)
+2 ;
TEST(TYPE,ID,IN) ; -- test GET, write results to screen
+1 NEW OUT,IDX
+2 SET U="^"
+3 SET IN("domain")=$GET(TYPE)
+4 if $DATA(ID)
SET IN("id")=ID
+5 DO GET(.OUT,.IN)
+6 ;
+7 SET IDX=OUT
+8 FOR
SET IDX=$QUERY(@IDX)
if IDX'?1"^TMP(""HMP"","1.N.E
QUIT
if +$PIECE(IDX,",",2)'=$JOB
QUIT
WRITE !,@IDX
+9 QUIT
+10 ;
+11 ; ** Reference file searches, using FILTER("parameter")
+12 ;
PAT ;Patients
+1 NEW DFN,PAT,HMPPOPD
+2 SET HMPPOPD=1
+3 SET HMPCNT=$$TOTAL("^DPT")
+4 IF $GET(HMPID)
SET DFN=+HMPID
DO LKUP^HMPDJ00
QUIT
+5 NEW ERRMSG
SET ERRMSG="A mumps error occurred while extracting patients."
+6 ;DE4496 19 August 2016
SET DFN=+$GET(HMPLAST)
FOR
SET DFN=$ORDER(^DPT(DFN))
if '(DFN>0)
QUIT
Begin DoDot:1
+7 NEW $ESTACK,$ETRAP
+8 SET $ETRAP="D ERRHDLR^HMPDERRH"
+9 ;DE4496 19 August 2016
IF $PIECE($GET(^DPT(DFN,0)),U)=""
DO LOGDPT^HMPLOG(DFN)
QUIT
+10 SET ERRMSG=$$ERRMSG("Patient",DFN)
+11 KILL PAT
DO LKUP^HMPDJ00
+12 SET HMPLAST=DFN
End DoDot:1
IF HMPMAX>0
IF HMPI'<HMPMAX
QUIT
+13 ;DE4496 19 August 2016
IF '(DFN>0)
SET HMPFINI=1
+14 QUIT
LOC ; Hospital Location (#44) and Ward Location (#42) /DE2818
+1 DO LOC^HMPEF1(.HMPFINI,.HMPFLDON,$GET(HMPMETA))
+2 QUIT
+3 ;
ACTWRD(IEN) ;Boolean TRUE if active WARD LOCATION
+1 ; IEN - IEN in file 42
+2 ; SRG: need DBIA
SET D0=IEN
DO WIN^DGPMDDCF
QUIT 'X
+3 ;
ACTLOC(LOC) ;Boolean TRUE if active hospital location
+1 ; ^SC - IA 10040
+2 ; screen out OOS entry
NEW D0,X
IF +$GET(^SC(LOC,"OOS"))
QUIT 0
+3 ; chk out of svc wards
SET D0=+$GET(^SC(LOC,42))
IF D0
DO WIN^DGPMDDCF
QUIT 'X
+4 ; no inactivate date
SET X=$GET(^SC(LOC,"I"))
IF +X=0
QUIT 1
+5 ; chk reactivate date
IF DT>$PIECE(X,U)&($PIECE(X,U,2)=""!(DT<$PIECE(X,U,2)))
QUIT 0
+6 ; must still be active
QUIT 1
+7 ;
NP ;New Persons
+1 DO NP^HMPEF1
+2 QUIT
+3 ;
KEYS(IEN) ;user's keys
+1 NEW HMPKEY,IENS,X,CNT
+2 DO GETS^DIQ(200,IEN_",","51*","IE","HMPKEY")
SET CNT=0
+3 SET IENS=""
FOR
SET IENS=$ORDER(HMPKEY(200.051,IENS))
if IENS=""
QUIT
Begin DoDot:1
+4 SET X=$GET(HMPKEY(200.051,IENS,.01,"E"))
SET CNT=CNT+1
+5 SET USER("vistaKeys",CNT,"name")=X
+6 SET X=$GET(HMPKEY(200.051,IENS,3,"I"))
+7 if X
SET USER("vistaKeys",CNT,"reviewDate")=$$JSONDT^HMPUTILS(X)
End DoDot:1
+8 QUIT
+9 ;
ODG ;
+1 DO ADDODG^HMPCORD4
+2 QUIT
+3 ;
OI ;
+1 DO OI^HMPCORD4("PS^RAP^LRT")
+2 QUIT
+3 ;
PROB ;get problem list OPD store
+1 DO PROB^HMPEF1(.HMPFINI,LEX)
+2 QUIT
+3 ;
QO ;
+1 DO QO^HMPCORD4
+2 QUIT
+3 ;
SCHEDULE ;
+1 NEW RESULT
+2 DO ADDSCH^HMPCORD4
+3 QUIT
+4 ;
ROUTE ;
+1 NEW RESULT
+2 DO ADDROUTE^HMPCORD4
+3 QUIT
+4 ;
HMP ; HMP Objects
+1 NEW IEN
+2 SET HMPCNT=$$TOTAL("^HMP(800000.11)")
+3 IF $LENGTH(HMPID)
Begin DoDot:1
+4 IF HMPID=+HMPID
SET IEN=HMPID
+5 IF '$TEST
SET IEN=+$ORDER(^HMP(800000.11,"B",HMPID,0))
+6 SET ERRMSG=$$ERRMSG("HMP Object",IEN)
+7 if IEN
DO HMP1^HMPDJ02(800000.11,IEN)
End DoDot:1
QUIT
+8 SET IEN=+$GET(HMPLAST)
FOR
SET IEN=$ORDER(^HMP(800000.11,"C",TYPE,IEN))
if IEN<1
QUIT
Begin DoDot:1
+9 SET ERRMSG=$$ERRMSG("HMP Object",IEN)
+10 DO HMP1^HMPDJ02(800000.11,IEN)
SET HMPLAST=IEN
End DoDot:1
IF HMPMAX>0
IF HMPI'<HMPMAX
QUIT
+11 IF IEN<1
SET HMPFINI=1
+12 QUIT
+13 ;
SOURCE(SRC) ;
+1 NEW X
SET X=""
+2 IF SRC["SC("
SET X="clinic"
+3 IF SRC["DPT("
SET X="patient"
+4 IF SRC["DIC(42"
SET X="ward"
+5 IF SRC["SCTM"
SET X="pcmm"
+6 IF SRC["OR(100.21"
SET X="cprs"
+7 IF SRC["DIC(45.7"
SET X="specialty"
+8 IF SRC["VA(200"
SET X="provider"
+9 IF SRC["PXRM(810.4"
SET X="pxrm"
+10 QUIT X
+11 ;
ASU ; ASU files
+1 NEW X,RTN
SET X=$PIECE($GET(TYPE),"-",2)
+2 SET RTN=$$UP^XLFSTR(X)_"^HMPEASU"
+3 IF X'=""
IF $LENGTH($TEXT(@RTN))
DO @RTN
+4 QUIT
+5 ;
MDTERMS ; CP Terminology
+1 if $LENGTH($TEXT(TERM^HMPMDUTL))
DO TERM^HMPMDUTL
+2 QUIT
LABGRP ;
+1 DO SHWCUMR2^HMPELAB
+2 QUIT
LABPNL ;
+1 DO SHWORPNL^HMPELAB
+2 QUIT
+3 ;
+4 ;DE2818, changed reference to ^VA(201) to a FileMan call
ISPROXY(IEN) ; Boolean function, is NEW PERSON entry an APPLICATION PROXY?
+1 NEW APP,HMPMSG,HMPUCLS,T,V
+2 ; APP - returned value
+3 ; HMPUCLS - user class array
+4 ; HMPMSG - FileMan message array
+5 ;
+6 ; get external format
DO GETS^DIQ(200,IEN_",","9.5*","E","HMPUCLS","HMPMSG")
+7 SET APP=0
SET T="APPLICATION PROXY"
SET V="HMPUCLS"
+8 ; search returned array for value equal to T
+9 FOR
SET V=$QUERY(@V)
if V=""!APP
QUIT
if @V=T
SET APP=1
+10 QUIT APP
+11 ;
IMMTYPE ;immunization types
+1 DO IMMTYPE^HMPCORD5
+2 QUIT
+3 ;
ALLTYPE ;allergy-list types
+1 ;BL;REMOVE FROM ODS
+2 ;D ALLTYPE^HMPCORD5
+3 QUIT
+4 ;
VTYPE ;vital types
+1 DO VTYPE^HMPCORD5
+2 QUIT
+3 ;
VQUAL ;vital qualifiers
+1 DO VQUAL^HMPCORD5
+2 QUIT
+3 ;
VCAT ;vital categories
+1 DO VCAT^HMPCORD5
+2 QUIT
+3 ;
FILENAME ; text of filenames for search treeview
+1 ;;VA Allergies File
+2 ;;VA Allergies File (Synonyms) SPACER ONLY - NOT DISPLAYED
+3 ;;National Drug File - Generic Drug Name
+4 ;;National Drug file - Trade Name
+5 ;;Local Drug File
+6 ;;Local Drug File (Synonyms) SPACER ONLY - NOT DISPLAYED
+7 ;;Drug Ingredients File
+8 ;;VA Drug Class File
+9 ;;
