HMPD ;SLC/MKB,ASMR/RRB,CK - Serve VistA data as XML via RPC ;Aug 29, 2016 20:06:27
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**3**;Sep 01, 2011;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DPT 10035
; ^SC 10040
; DIQ 2056
; MPIF001 2701
; VASITE 10112
; XLFDT 10103
; XLFSTR 10104
; XUAF4 2171
;
Q
;
GET(HMP,DFN,TYPE,START,STOP,MAX,ID,FILTER) ; -- Return search results as XML in @HMP@(n)
; RPC = HMP GET PATIENT DATA
N ICN,HMPI,HMPTOTL,HMPTEXT
S HMP=$NA(^TMP("HMP",$J)) K @HMP
S HMPTEXT=+$G(FILTER("text")) ;include report/document text?
;
; parse & validate input parameters
S ICN=+$P($G(DFN),";",2),DFN=+$G(DFN),ID=$G(ID)
I DFN<1,ICN S DFN=+$$GETDFN^MPIF001(ICN)
S TYPE=$$LOW^XLFSTR($G(TYPE)) I TYPE="" S TYPE=$$ALL
;next line, ICR 10035 ASF 11/2/15 DE2818, DE4496 19 August 2016
I TYPE'="new",DFN<1!'$D(^DPT(DFN)) D LOGDPT^HMPLOG(DFN),ERR(1,DFN) G GTQ
S:'$G(START) START=1410102 S:'$G(STOP) STOP=4141015 S:'$G(MAX) MAX=9999
I START,STOP,STOP<START N X S X=START,START=STOP,STOP=X ;switch
I STOP,$L(STOP,".")<2 S STOP=STOP_".24"
I ID="",$D(FILTER("id")) S ID=FILTER("id")
;
; extract data
N HMPTYPE,HMPP,HMPHDR,HMPTAG,HMPTN
S HMPTYPE=TYPE D ADD("<results version='1.1' timeZone='"_$$TZ^XLFDT_"' >")
F HMPP=1:1:$L(HMPTYPE,";") S HMPTAG=$P(HMPTYPE,";",HMPP) I $L(HMPTAG) D
. S HMPTN="EN^"_$$RTN(.HMPTAG) Q:'$L($T(@HMPTN)) ;D ERR(2) Q
. D ADD("<"_HMPTAG) S HMPHDR=HMPI,HMPTOTL=0
. D @(HMPTN_"(DFN,START,STOP,MAX,ID)")
. S @HMP@(HMPHDR)=@HMP@(HMPHDR)_" total='"_+$G(HMPTOTL)_"' >" D ADD("</"_HMPTAG_">")
D ADD("</results>")
;
GTQ ; end
Q
;
RTN(X) ; -- Return name of HMPDxxxx routine for clinical domain X
; X is also enforced as expected group tag name, if passed by ref
N Y S Y="HMPD",X=$G(X) I X="" Q Y
I X["accession" S Y="HMPDLRA",X="accessions"
I X["allerg" S Y="HMPDGMRA",X="reactions"
I X["appointment" S Y="HMPDSDAM",X="appointments"
I X["clinicalProc" S Y="HMPDMC",X="clinicalProcedures"
I X["consult" S Y="HMPDGMRC",X="consults"
I X["demograph" S Y="HMPDPT",X="demographics"
I X["document" S Y="HMPDTIU",X="documents"
I X["factor" S Y="HMPDPXHF",X="healthFactors"
I X["flag" S Y="HMPDGPF",X="flags"
I X["immunization" S Y="HMPDPXIM",X="immunizations"
I X["skin" S Y="HMPDPXSK",X="skinTests"
I X?1"exam".E S Y="HMPDPXAM",X="exams"
I X["educat" S Y="HMPDPXED",X="educationTopics"
I X["insur" S Y="HMPDIB",X="insurancePolicies"
I X["polic" S Y="HMPDIB",X="insurancePolicies"
I X["lab" S Y="HMPDLR",X="labs"
I X["panel" S Y="HMPDLRO",X="panels"
I X["med" S Y="HMPDPS",X="meds"
I X["pharm" S Y="HMPDPSOR",X="meds"
I X["observ" S Y="HMPDMDC",X="observations"
I X["order" S Y="HMPDOR",X="orders"
I X["patient" S Y="HMPDPT",X="demographics"
I X["problem" S Y="HMPDGMPL",X="problems"
I X["procedure" S Y="HMPDPROC",X="procedures"
I X["reaction" S Y="HMPDGMRA",X="reactions"
I X["surg" S Y="HMPDSR",X="surgeries"
I X["visit" S Y="HMPDVSIT",X="visits"
I X["vital" S Y="HMPDGMV",X="vitals"
I X["rad" S Y="HMPDRA",X="radiologyExams"
I X["xray" S Y="HMPDRA",X="radiologyExams"
I X["new" S Y="HMPDX",X="patients"
Q Y
;
TAG(X) ; -- return plural name for group tags
N Y S:X'?1.L X=$$LOW^XLFSTR(X)
I $E(X,$L(X))="s" S Y=X
I $E(X,$L(X))="y" S Y=$E(X,1,$L(X)-1)_"ies"
E S Y=X_"s"
Q Y
;
ALL() ; -- return string for all types of data
Q "demographics;reactions;problems;vitals;labs;meds;immunizations;observation;visits;appointments;documents;procedures;consults;flags;factors;skinTests;exams;education;insurance"
;
ERR(X,VAL) ; -- return error message
N MSG S MSG="Error"
I X=1 S MSG="Patient with dfn '"_$G(VAL)_"' not found"
I X=2 S MSG="Requested domain type '"_$G(VAL)_"' not recognized"
I X=99 S MSG="Unknown request"
;
D ADD("<error>")
D ADD("<message>"_MSG_"</message>")
D ADD("</error>")
Q
;
ESC(X) ; -- escape outgoing XML
; Q $ZCONVERT(X,"O","HTML") ; uncomment for fastest performance on Cache
;
N I,Y,QOT S QOT=""""
S Y=$P(X,"&") F I=2:1:$L(X,"&") S Y=Y_"&"_$P(X,"&",I)
S X=Y,Y=$P(X,"<") F I=2:1:$L(X,"<") S Y=Y_"<"_$P(X,"<",I)
S X=Y,Y=$P(X,">") F I=2:1:$L(X,">") S Y=Y_">"_$P(X,">",I)
S X=Y,Y=$P(X,"'") F I=2:1:$L(X,"'") S Y=Y_"'"_$P(X,"'",I)
S X=Y,Y=$P(X,QOT) F I=2:1:$L(X,QOT) S Y=Y_"""_$P(X,QOT,I)
Q Y
;
ADD(X) ; Add a line @HMP@(n)=X
S HMPI=$G(HMPI)+1
S @HMP@(HMPI)=X
Q
;
STRING(ARY) ; -- Return text in ARY(n) or ARY(n,0) as a string, ARY passed by ref.
;DE3409 8/11/2106 CK - to prevent a MAXSTRING error, allow 30,000 characters
N I,MXSTRNG,X,Y
S MXSTRNG=30000
S I=+$O(ARY("")) I I=0 S I=+$O(ARY(0))
S Y=$S($D(ARY(I,0)):ARY(I,0),1:$G(ARY(I)))
F S I=$O(ARY(I)) Q:I<1 D
. S X=$S($D(ARY(I,0)):ARY(I,0),1:ARY(I))
. I ($L(Y)+$L(X))>MXSTRNG S Y=Y_$E(X,1,(MXSTRNG-$L(Y))) Q
. I $E(X)=" " S Y=Y_$C(13,10)_X Q
. ; add a space to separate each line of text
. S Y=Y_$S($E(Y,$L(Y))=" ":"",1:" ")_X
Q Y
;
FAC(X) ; -- return Institution file station# for location X
N HLOC,FAC,Y0,Y S Y=""
S HLOC=$G(^SC(+$G(X),0)),FAC=$P(HLOC,U,4) ;ICR 10040 DE2818 ASF 11/5/15
; Get P:4 via Med Ctr Div, if not directly linked
I 'FAC,$P(HLOC,U,15) S FAC=$$GET1^DIQ(44,+$G(X)_",","3.5:.07","I")
S Y0=$S(FAC:$$NS^XUAF4(FAC),1:$P($$SITE^VASITE,U,2,3)) ;name^stn#
S:$L(Y0) Y=$P(Y0,U,2)_U_$P(Y0,U) ;switch to stn#^name
I $L(Y),'Y S $P(Y,U)=FAC
Q Y
;
VUID(IEN,FILE) ; -- Return VUID for item
Q $$GET1^DIQ(FILE,IEN_",",99.99)
;
VERSION(RET) ; -- Return current version of data extracts
S RET="1.01"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPD 6066 printed Oct 16, 2024@17:53:48 Page 2
HMPD ;SLC/MKB,ASMR/RRB,CK - Serve VistA data as XML via RPC ;Aug 29, 2016 20:06:27
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**3**;Sep 01, 2011;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DPT 10035
+7 ; ^SC 10040
+8 ; DIQ 2056
+9 ; MPIF001 2701
+10 ; VASITE 10112
+11 ; XLFDT 10103
+12 ; XLFSTR 10104
+13 ; XUAF4 2171
+14 ;
+15 QUIT
+16 ;
GET(HMP,DFN,TYPE,START,STOP,MAX,ID,FILTER) ; -- Return search results as XML in @HMP@(n)
+1 ; RPC = HMP GET PATIENT DATA
+2 NEW ICN,HMPI,HMPTOTL,HMPTEXT
+3 SET HMP=$NAME(^TMP("HMP",$JOB))
KILL @HMP
+4 ;include report/document text?
SET HMPTEXT=+$GET(FILTER("text"))
+5 ;
+6 ; parse & validate input parameters
+7 SET ICN=+$PIECE($GET(DFN),";",2)
SET DFN=+$GET(DFN)
SET ID=$GET(ID)
+8 IF DFN<1
IF ICN
SET DFN=+$$GETDFN^MPIF001(ICN)
+9 SET TYPE=$$LOW^XLFSTR($GET(TYPE))
IF TYPE=""
SET TYPE=$$ALL
+10 ;next line, ICR 10035 ASF 11/2/15 DE2818, DE4496 19 August 2016
+11 IF TYPE'="new"
IF DFN<1!'$DATA(^DPT(DFN))
DO LOGDPT^HMPLOG(DFN)
DO ERR(1,DFN)
GOTO GTQ
+12 if '$GET(START)
SET START=1410102
if '$GET(STOP)
SET STOP=4141015
if '$GET(MAX)
SET MAX=9999
+13 ;switch
IF START
IF STOP
IF STOP<START
NEW X
SET X=START
SET START=STOP
SET STOP=X
+14 IF STOP
IF $LENGTH(STOP,".")<2
SET STOP=STOP_".24"
+15 IF ID=""
IF $DATA(FILTER("id"))
SET ID=FILTER("id")
+16 ;
+17 ; extract data
+18 NEW HMPTYPE,HMPP,HMPHDR,HMPTAG,HMPTN
+19 SET HMPTYPE=TYPE
DO ADD("<results version='1.1' timeZone='"_$$TZ^XLFDT_"' >")
+20 FOR HMPP=1:1:$LENGTH(HMPTYPE,";")
SET HMPTAG=$PIECE(HMPTYPE,";",HMPP)
IF $LENGTH(HMPTAG)
Begin DoDot:1
+21 ;D ERR(2) Q
SET HMPTN="EN^"_$$RTN(.HMPTAG)
if '$LENGTH($TEXT(@HMPTN))
QUIT
+22 DO ADD("<"_HMPTAG)
SET HMPHDR=HMPI
SET HMPTOTL=0
+23 DO @(HMPTN_"(DFN,START,STOP,MAX,ID)")
+24 SET @HMP@(HMPHDR)=@HMP@(HMPHDR)_" total='"_+$GET(HMPTOTL)_"' >"
DO ADD("</"_HMPTAG_">")
End DoDot:1
+25 DO ADD("</results>")
+26 ;
GTQ ; end
+1 QUIT
+2 ;
RTN(X) ; -- Return name of HMPDxxxx routine for clinical domain X
+1 ; X is also enforced as expected group tag name, if passed by ref
+2 NEW Y
SET Y="HMPD"
SET X=$GET(X)
IF X=""
QUIT Y
+3 IF X["accession"
SET Y="HMPDLRA"
SET X="accessions"
+4 IF X["allerg"
SET Y="HMPDGMRA"
SET X="reactions"
+5 IF X["appointment"
SET Y="HMPDSDAM"
SET X="appointments"
+6 IF X["clinicalProc"
SET Y="HMPDMC"
SET X="clinicalProcedures"
+7 IF X["consult"
SET Y="HMPDGMRC"
SET X="consults"
+8 IF X["demograph"
SET Y="HMPDPT"
SET X="demographics"
+9 IF X["document"
SET Y="HMPDTIU"
SET X="documents"
+10 IF X["factor"
SET Y="HMPDPXHF"
SET X="healthFactors"
+11 IF X["flag"
SET Y="HMPDGPF"
SET X="flags"
+12 IF X["immunization"
SET Y="HMPDPXIM"
SET X="immunizations"
+13 IF X["skin"
SET Y="HMPDPXSK"
SET X="skinTests"
+14 IF X?1"exam".E
SET Y="HMPDPXAM"
SET X="exams"
+15 IF X["educat"
SET Y="HMPDPXED"
SET X="educationTopics"
+16 IF X["insur"
SET Y="HMPDIB"
SET X="insurancePolicies"
+17 IF X["polic"
SET Y="HMPDIB"
SET X="insurancePolicies"
+18 IF X["lab"
SET Y="HMPDLR"
SET X="labs"
+19 IF X["panel"
SET Y="HMPDLRO"
SET X="panels"
+20 IF X["med"
SET Y="HMPDPS"
SET X="meds"
+21 IF X["pharm"
SET Y="HMPDPSOR"
SET X="meds"
+22 IF X["observ"
SET Y="HMPDMDC"
SET X="observations"
+23 IF X["order"
SET Y="HMPDOR"
SET X="orders"
+24 IF X["patient"
SET Y="HMPDPT"
SET X="demographics"
+25 IF X["problem"
SET Y="HMPDGMPL"
SET X="problems"
+26 IF X["procedure"
SET Y="HMPDPROC"
SET X="procedures"
+27 IF X["reaction"
SET Y="HMPDGMRA"
SET X="reactions"
+28 IF X["surg"
SET Y="HMPDSR"
SET X="surgeries"
+29 IF X["visit"
SET Y="HMPDVSIT"
SET X="visits"
+30 IF X["vital"
SET Y="HMPDGMV"
SET X="vitals"
+31 IF X["rad"
SET Y="HMPDRA"
SET X="radiologyExams"
+32 IF X["xray"
SET Y="HMPDRA"
SET X="radiologyExams"
+33 IF X["new"
SET Y="HMPDX"
SET X="patients"
+34 QUIT Y
+35 ;
TAG(X) ; -- return plural name for group tags
+1 NEW Y
if X'?1.L
SET X=$$LOW^XLFSTR(X)
+2 IF $EXTRACT(X,$LENGTH(X))="s"
SET Y=X
+3 IF $EXTRACT(X,$LENGTH(X))="y"
SET Y=$EXTRACT(X,1,$LENGTH(X)-1)_"ies"
+4 IF '$TEST
SET Y=X_"s"
+5 QUIT Y
+6 ;
ALL() ; -- return string for all types of data
+1 QUIT "demographics;reactions;problems;vitals;labs;meds;immunizations;observation;visits;appointments;documents;procedures;consults;flags;factors;skinTests;exams;education;insurance"
+2 ;
ERR(X,VAL) ; -- return error message
+1 NEW MSG
SET MSG="Error"
+2 IF X=1
SET MSG="Patient with dfn '"_$GET(VAL)_"' not found"
+3 IF X=2
SET MSG="Requested domain type '"_$GET(VAL)_"' not recognized"
+4 IF X=99
SET MSG="Unknown request"
+5 ;
+6 DO ADD("<error>")
+7 DO ADD("<message>"_MSG_"</message>")
+8 DO ADD("</error>")
+9 QUIT
+10 ;
ESC(X) ; -- escape outgoing XML
+1 ; Q $ZCONVERT(X,"O","HTML") ; uncomment for fastest performance on Cache
+2 ;
+3 NEW I,Y,QOT
SET QOT=""""
+4 SET Y=$PIECE(X,"&")
FOR I=2:1:$LENGTH(X,"&")
SET Y=Y_"&"_$PIECE(X,"&",I)
+5 SET X=Y
SET Y=$PIECE(X,"<")
FOR I=2:1:$LENGTH(X,"<")
SET Y=Y_"<"_$PIECE(X,"<",I)
+6 SET X=Y
SET Y=$PIECE(X,">")
FOR I=2:1:$LENGTH(X,">")
SET Y=Y_">"_$PIECE(X,">",I)
+7 SET X=Y
SET Y=$PIECE(X,"'")
FOR I=2:1:$LENGTH(X,"'")
SET Y=Y_"'"_$PIECE(X,"'",I)
+8 SET X=Y
SET Y=$PIECE(X,QOT)
FOR I=2:1:$LENGTH(X,QOT)
SET Y=Y_"""_$PIECE(X,QOT,I)
+9 QUIT Y
+10 ;
ADD(X) ; Add a line @HMP@(n)=X
+1 SET HMPI=$GET(HMPI)+1
+2 SET @HMP@(HMPI)=X
+3 QUIT
+4 ;
STRING(ARY) ; -- Return text in ARY(n) or ARY(n,0) as a string, ARY passed by ref.
+1 ;DE3409 8/11/2106 CK - to prevent a MAXSTRING error, allow 30,000 characters
+2 NEW I,MXSTRNG,X,Y
+3 SET MXSTRNG=30000
+4 SET I=+$ORDER(ARY(""))
IF I=0
SET I=+$ORDER(ARY(0))
+5 SET Y=$SELECT($DATA(ARY(I,0)):ARY(I,0),1:$GET(ARY(I)))
+6 FOR
SET I=$ORDER(ARY(I))
if I<1
QUIT
Begin DoDot:1
+7 SET X=$SELECT($DATA(ARY(I,0)):ARY(I,0),1:ARY(I))
+8 IF ($LENGTH(Y)+$LENGTH(X))>MXSTRNG
SET Y=Y_$EXTRACT(X,1,(MXSTRNG-$LENGTH(Y)))
QUIT
+9 IF $EXTRACT(X)=" "
SET Y=Y_$CHAR(13,10)_X
QUIT
+10 ; add a space to separate each line of text
+11 SET Y=Y_$SELECT($EXTRACT(Y,$LENGTH(Y))=" ":"",1:" ")_X
End DoDot:1
+12 QUIT Y
+13 ;
FAC(X) ; -- return Institution file station# for location X
+1 NEW HLOC,FAC,Y0,Y
SET Y=""
+2 ;ICR 10040 DE2818 ASF 11/5/15
SET HLOC=$GET(^SC(+$GET(X),0))
SET FAC=$PIECE(HLOC,U,4)
+3 ; Get P:4 via Med Ctr Div, if not directly linked
+4 IF 'FAC
IF $PIECE(HLOC,U,15)
SET FAC=$$GET1^DIQ(44,+$GET(X)_",","3.5:.07","I")
+5 ;name^stn#
SET Y0=$SELECT(FAC:$$NS^XUAF4(FAC),1:$PIECE($$SITE^VASITE,U,2,3))
+6 ;switch to stn#^name
if $LENGTH(Y0)
SET Y=$PIECE(Y0,U,2)_U_$PIECE(Y0,U)
+7 IF $LENGTH(Y)
IF 'Y
SET $PIECE(Y,U)=FAC
+8 QUIT Y
+9 ;
VUID(IEN,FILE) ; -- Return VUID for item
+1 QUIT $$GET1^DIQ(FILE,IEN_",",99.99)
+2 ;
VERSION(RET) ; -- Return current version of data extracts
+1 SET RET="1.01"
+2 QUIT
