NHINV ;SLC/MKB - Serve VistA data as XML via RPC
;;1.0;NHIN;**1**;Oct 25, 2010;Build 11
;
; External References DBIA#
; ------------------- -----
; ^DPT 10035
; ^SC 10040
; DIQ 2056
; MPIF001 2701
; VASITE 10112
; XLFDT 10103
; XLFSTR 10104
; XUAF4 2171
;
GET(NHIN,DFN,TYPE,START,STOP,MAX,ID) ; -- Return search results as XML in @NHIN@(n)
; RPC = NHIN GET VISTA DATA
N ICN,NHINI,NHINTOTL
S NHIN=$NA(^TMP("NHINV",$J)) K @NHIN
;
; parse & validate input parameters
S ICN=+$P(DFN,";",2),DFN=+$G(DFN)
I 'DFN S DFN=+$$GETDFN^MPIF001(ICN)
I DFN<1!'$D(^DPT(DFN)) D ERR(1,DFN) G GTQ
S TYPE=$G(TYPE) I TYPE="" S TYPE=$$ALL
S:'$G(START) START=1410101 S:'$G(STOP) STOP=9999998 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"
S ID=$G(ID)
;
; extract data
N NHINTYPE,NHINP,RTN
S NHINTYPE=TYPE D ADD("<results>")
F NHINP=1:1:$L(NHINTYPE,";") S TYPE=$P(NHINTYPE,";",NHINP) I $L(TYPE) D
. S RTN="EN^"_$$RTN(TYPE) Q:'$L($T(@RTN)) ;D ERR(2) Q
. D @(RTN_"(DFN,START,STOP,MAX,ID)")
D ADD("</results>")
;
I $G(NHINTOTL),$G(@NHIN@(1))="<results>" S @NHIN@(1)="<results total='"_NHINTOTL_"' >"
;
GTQ ; end
Q
;
RTN(X) ; -- Return name of NHINVxxx routine for clinical domain X
S X=$$UP^XLFSTR(X),Y="NHINV"
I X="ACCESSION" S Y="NHINVLRA"
I X="ALLERGY" S Y="NHINVART"
I X="APPOINTMENT" S Y="NHINVAPT"
; X="CONSULT" S Y="NHINVCON"
I X="DOCUMENT" S Y="NHINVTIU"
I X="IMMUNIZATION" S Y="NHINVIMM"
I X="LAB" S Y="NHINVLR"
I X="PANEL" S Y="NHINVLRO"
I X="MED" S Y="NHINVPS"
I X="RX" S Y="NHINVPSO"
; X="ORDER" S Y="NHINVOR"
I X="PATIENT" S Y="NHINVPT"
I X="PROBLEM" S Y="NHINVPL"
I X="PROCEDURE" S Y="NHINVPRC"
I X="SURGERY" S Y="NHINVSR"
I X="VISIT" S Y="NHINVSIT"
I X="VITAL" S Y="NHINVIT"
I X="RADIOLOGY" S Y="NHINVRA"
I X="NEW" S Y="NHINVPR"
Q Y
;
ALL() ; -- return string for all types of data
Q "patient;allergy;problem;vital;lab;med;immunization;visit;appointment;document;procedure"
;
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 @NHIN@(n)=X
S NHINI=$G(NHINI)+1
S @NHIN@(NHINI)=X
Q
;
STRING(ARRAY) ; -- Return text in ARRAY(n) or ARRAY(n,0) as a string
N I,X,Y S Y=""
S I=+$O(ARRAY("")) I I=0 S I=+$O(ARRAY(0))
S Y=$S($D(ARRAY(I,0)):ARRAY(I,0),1:$G(ARRAY(I)))
F S I=$O(ARRAY(I)) Q:I<1 D
. S X=$S($D(ARRAY(I,0)):ARRAY(I,0),1:ARRAY(I))
. I $E(X)=" " S Y=Y_$C(13,10)_X Q
. 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) ;Institution ien
; Get P:4 via Med Ctr Div, if not directly linked
I 'FAC,$P(HLOC,U,15) S FAC=$$GET1^DIQ(40.8,+$P(HLOC,U,15)_",",.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)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNHINV 4096 printed Jun 11, 2024@22:02:53 Page 2
NHINV ;SLC/MKB - Serve VistA data as XML via RPC
+1 ;;1.0;NHIN;**1**;Oct 25, 2010;Build 11
+2 ;
+3 ; External References DBIA#
+4 ; ------------------- -----
+5 ; ^DPT 10035
+6 ; ^SC 10040
+7 ; DIQ 2056
+8 ; MPIF001 2701
+9 ; VASITE 10112
+10 ; XLFDT 10103
+11 ; XLFSTR 10104
+12 ; XUAF4 2171
+13 ;
GET(NHIN,DFN,TYPE,START,STOP,MAX,ID) ; -- Return search results as XML in @NHIN@(n)
+1 ; RPC = NHIN GET VISTA DATA
+2 NEW ICN,NHINI,NHINTOTL
+3 SET NHIN=$NAME(^TMP("NHINV",$JOB))
KILL @NHIN
+4 ;
+5 ; parse & validate input parameters
+6 SET ICN=+$PIECE(DFN,";",2)
SET DFN=+$GET(DFN)
+7 IF 'DFN
SET DFN=+$$GETDFN^MPIF001(ICN)
+8 IF DFN<1!'$DATA(^DPT(DFN))
DO ERR(1,DFN)
GOTO GTQ
+9 SET TYPE=$GET(TYPE)
IF TYPE=""
SET TYPE=$$ALL
+10 if '$GET(START)
SET START=1410101
if '$GET(STOP)
SET STOP=9999998
if '$GET(MAX)
SET MAX=9999
+11 ;switch
IF START
IF STOP
IF STOP<START
NEW X
SET X=START
SET START=STOP
SET STOP=X
+12 IF STOP
IF $LENGTH(STOP,".")<2
SET STOP=STOP_".24"
+13 SET ID=$GET(ID)
+14 ;
+15 ; extract data
+16 NEW NHINTYPE,NHINP,RTN
+17 SET NHINTYPE=TYPE
DO ADD("<results>")
+18 FOR NHINP=1:1:$LENGTH(NHINTYPE,";")
SET TYPE=$PIECE(NHINTYPE,";",NHINP)
IF $LENGTH(TYPE)
Begin DoDot:1
+19 ;D ERR(2) Q
SET RTN="EN^"_$$RTN(TYPE)
if '$LENGTH($TEXT(@RTN))
QUIT
+20 DO @(RTN_"(DFN,START,STOP,MAX,ID)")
End DoDot:1
+21 DO ADD("</results>")
+22 ;
+23 IF $GET(NHINTOTL)
IF $GET(@NHIN@(1))="<results>"
SET @NHIN@(1)="<results total='"_NHINTOTL_"' >"
+24 ;
GTQ ; end
+1 QUIT
+2 ;
RTN(X) ; -- Return name of NHINVxxx routine for clinical domain X
+1 SET X=$$UP^XLFSTR(X)
SET Y="NHINV"
+2 IF X="ACCESSION"
SET Y="NHINVLRA"
+3 IF X="ALLERGY"
SET Y="NHINVART"
+4 IF X="APPOINTMENT"
SET Y="NHINVAPT"
+5 ; X="CONSULT" S Y="NHINVCON"
+6 IF X="DOCUMENT"
SET Y="NHINVTIU"
+7 IF X="IMMUNIZATION"
SET Y="NHINVIMM"
+8 IF X="LAB"
SET Y="NHINVLR"
+9 IF X="PANEL"
SET Y="NHINVLRO"
+10 IF X="MED"
SET Y="NHINVPS"
+11 IF X="RX"
SET Y="NHINVPSO"
+12 ; X="ORDER" S Y="NHINVOR"
+13 IF X="PATIENT"
SET Y="NHINVPT"
+14 IF X="PROBLEM"
SET Y="NHINVPL"
+15 IF X="PROCEDURE"
SET Y="NHINVPRC"
+16 IF X="SURGERY"
SET Y="NHINVSR"
+17 IF X="VISIT"
SET Y="NHINVSIT"
+18 IF X="VITAL"
SET Y="NHINVIT"
+19 IF X="RADIOLOGY"
SET Y="NHINVRA"
+20 IF X="NEW"
SET Y="NHINVPR"
+21 QUIT Y
+22 ;
ALL() ; -- return string for all types of data
+1 QUIT "patient;allergy;problem;vital;lab;med;immunization;visit;appointment;document;procedure"
+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 @NHIN@(n)=X
+1 SET NHINI=$GET(NHINI)+1
+2 SET @NHIN@(NHINI)=X
+3 QUIT
+4 ;
STRING(ARRAY) ; -- Return text in ARRAY(n) or ARRAY(n,0) as a string
+1 NEW I,X,Y
SET Y=""
+2 SET I=+$ORDER(ARRAY(""))
IF I=0
SET I=+$ORDER(ARRAY(0))
+3 SET Y=$SELECT($DATA(ARRAY(I,0)):ARRAY(I,0),1:$GET(ARRAY(I)))
+4 FOR
SET I=$ORDER(ARRAY(I))
if I<1
QUIT
Begin DoDot:1
+5 SET X=$SELECT($DATA(ARRAY(I,0)):ARRAY(I,0),1:ARRAY(I))
+6 IF $EXTRACT(X)=" "
SET Y=Y_$CHAR(13,10)_X
QUIT
+7 SET Y=Y_$SELECT($EXTRACT(Y,$LENGTH(Y))=" ":"",1:" ")_X
End DoDot:1
+8 QUIT Y
+9 ;
FAC(X) ; -- return Institution file station# for location X
+1 NEW HLOC,FAC,Y0,Y
SET Y=""
+2 ;Institution ien
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(40.8,+$PIECE(HLOC,U,15)_",",.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)
