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

VPRD.m

Go to the documentation of this file.
  1. VPRD ;SLC/MKB -- Serve VistA data as XML via RPC ;8/2/11 15:29
  1. ;;1.0;VIRTUAL PATIENT RECORD;**1,2,4,5,6,32**;Sep 01, 2011;Build 6
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ; External References DBIA#
  1. ; ------------------- -----
  1. ; ^DPT 10035
  1. ; ^SC 10040
  1. ; ^USC(8932.1) 4984
  1. ; ^VA(200 10060
  1. ; DIQ 2056
  1. ; MPIF001 2701
  1. ; VASITE 10112
  1. ; XLFDT 10103
  1. ; XLFSTR 10104
  1. ; XPAR 2263
  1. ; XUAF4 2171
  1. ; XUSTAX 4911
  1. ;
  1. GET(VPR,DFN,TYPE,START,STOP,MAX,ID,FILTER) ; -- Return search results as XML in @VPR@(n)
  1. ; RPC = VPR GET PATIENT DATA
  1. N ICN,VPRI,VPRTOTL,VPRTEXT
  1. S VPR=$NA(^TMP("VPR",$J)) K @VPR
  1. S VPRTEXT=+$G(FILTER("text")) ;include report/document text?
  1. ;
  1. ; parse & validate input parameters
  1. S ICN=+$P($G(DFN),";",2),DFN=+$G(DFN),ID=$G(ID)
  1. I DFN<1,ICN S DFN=+$$GETDFN^MPIF001(ICN)
  1. I DFN<1!'$D(^DPT(DFN)) D ERR(1,DFN) G GTQ
  1. S TYPE=$$LOW^XLFSTR($G(TYPE)) I TYPE="" S TYPE=$$ALL
  1. S:'$G(START) START=1410102 S:'$G(STOP) STOP=4141015 S:'$G(MAX) MAX=9999
  1. I START,STOP,STOP<START N X S X=START,START=STOP,STOP=X ;switch
  1. I STOP,$L(STOP,".")<2 S STOP=STOP_".24"
  1. I ID="",$D(FILTER("id")) S ID=FILTER("id")
  1. ;
  1. ; extract data
  1. N VPRTYPE,VPRP,VPRHDR,VPRTAG,VPRTN
  1. D ADD("<results version='"_$$GET^XPAR("ALL","VPR VERSION")_"' timeZone='"_$$TZ^XLFDT_"' >")
  1. S VPRTYPE=TYPE
  1. F VPRP=1:1:$L(VPRTYPE,";") S VPRTAG=$P(VPRTYPE,";",VPRP) I $L(VPRTAG) D
  1. . S VPRTN="EN^"_$$RTN(.VPRTAG) Q:'$L($T(@VPRTN)) ;D ERR(2) Q
  1. . D ADD("<"_VPRTAG) S VPRHDR=VPRI,VPRTOTL=0
  1. . D @(VPRTN_"(DFN,START,STOP,MAX,ID)")
  1. . S @VPR@(VPRHDR)=@VPR@(VPRHDR)_" total='"_+$G(VPRTOTL)_"' >" D ADD("</"_VPRTAG_">")
  1. D ADD("</results>")
  1. ;
  1. GTQ ; end
  1. K ^TMP("VPRD",$J)
  1. Q
  1. ;
  1. RTN(X) ; -- Return name of VPRDxxxx routine for clinical domain X
  1. ; X is also enforced as expected group tag name, if passed by ref
  1. N Y S Y="VPRD",X=$G(X) I X="" Q Y
  1. I X["accession" S Y="VPRDLRA",X="accessions"
  1. I X["allerg" S Y="VPRDGMRA",X="reactions"
  1. I X["appointment" S Y="VPRDSDAM",X="appointments"
  1. I X["clinicalproc" S Y="VPRDMC",X="clinicalProcedures"
  1. I X["consult" S Y="VPRDGMRC",X="consults"
  1. I X["demograph" S Y="VPRDPT",X="demographics"
  1. I X["document" S Y="VPRDTIU",X="documents"
  1. I X["factor" S Y="VPRDPXHF",X="healthFactors"
  1. I X["flag" S Y="VPRDGPF",X="flags"
  1. I X["function" S Y="VPRDRMIM",X="functionalMeasurements"
  1. I X="fim" S Y="VPRDRMIM",X="functionalMeasurements"
  1. I X["immunization" S Y="VPRDPXIM",X="immunizations"
  1. I X["skin" S Y="VPRDPXSK",X="skinTests"
  1. I X?1"exam".E S Y="VPRDPXAM",X="exams"
  1. I X["educat" S Y="VPRDPXED",X="educationTopics"
  1. I X["insur" S Y="VPRDIB",X="insurancePolicies"
  1. I X["polic" S Y="VPRDIB",X="insurancePolicies"
  1. I X["lab" S Y="VPRDLR",X="labs"
  1. I X["panel" S Y="VPRDLRO",X="panels"
  1. I X["med" S Y="VPRDPS",X="meds"
  1. I X["pharm" S Y="VPRDPSOR",X="meds"
  1. I X["observ" S Y="VPRDMDC",X="observations"
  1. I X["order" S Y="VPRDOR",X="orders"
  1. I X["patient" S Y="VPRDPT",X="demographics"
  1. I X["problem" S Y="VPRDGMPL",X="problems"
  1. I X?1"procedure".E S Y="VPRDPROC",X="procedures"
  1. I X["reaction" S Y="VPRDGMRA",X="reactions"
  1. I X["reminder" S Y="VPRDPXRM",X="reminders"
  1. I X["surg" S Y="VPRDSR",X="surgeries"
  1. I X["visit" S Y="VPRDVSIT",X="visits"
  1. I X["vital" S Y="VPRDGMV",X="vitals"
  1. I X["rad" S Y="VPRDRA",X="radiologyExams"
  1. I X["xray" S Y="VPRDRA",X="radiologyExams"
  1. Q Y
  1. ;
  1. TAG(X) ; -- return plural name for group tags
  1. N Y S:X'?1.L X=$$LOW^XLFSTR(X)
  1. I $E(X,$L(X))="s" S Y=X
  1. I $E(X,$L(X))="y" S Y=$E(X,1,$L(X)-1)_"ies"
  1. E S Y=X_"s"
  1. Q Y
  1. ;
  1. ALL() ; -- return string for all types of data
  1. Q "demographics;reactions;problems;vitals;labs;meds;immunizations;observations;visits;appointments;documents;procedures;consults;flags;factors;skinTests;exams;education;insurance;reminders"
  1. ;
  1. ERR(X,VAL) ; -- return error message
  1. N MSG S MSG="Error"
  1. I X=1 S MSG="Patient with DFN '"_$G(VAL)_"' not found"
  1. I X=2 S MSG="Requested domain type '"_$G(VAL)_"' not recognized"
  1. I X=99 S MSG="Unknown request"
  1. ;
  1. D ADD("<error>")
  1. D ADD("<message>"_MSG_"</message>")
  1. D ADD("</error>")
  1. Q
  1. ;
  1. ESC(X) ; -- escape outgoing XML
  1. ; Q $ZCONVERT(X,"O","HTML") ; uncomment for fastest performance on Cache
  1. ;
  1. N I,Y,QOT S QOT=""""
  1. F I=1:1:8,11,12,14:1:31 S X=$TR(X,$C(I))
  1. S Y=$P(X,"&") F I=2:1:$L(X,"&") S Y=Y_"&"_$P(X,"&",I)
  1. S X=Y,Y=$P(X,"<") F I=2:1:$L(X,"<") S Y=Y_"<"_$P(X,"<",I)
  1. S X=Y,Y=$P(X,">") F I=2:1:$L(X,">") S Y=Y_">"_$P(X,">",I)
  1. S X=Y,Y=$P(X,"'") F I=2:1:$L(X,"'") S Y=Y_"'"_$P(X,"'",I)
  1. S X=Y,Y=$P(X,QOT) F I=2:1:$L(X,QOT) S Y=Y_"""_$P(X,QOT,I)
  1. Q Y
  1. ;
  1. ADD(X) ; Add a line @VPR@(n)=X
  1. S VPRI=$G(VPRI)+1
  1. S @VPR@(VPRI)=X
  1. Q
  1. ;
  1. STRING(ARRAY) ; -- Return text in ARRAY(n) or ARRAY(n,0) as a string
  1. N I,X,Y S Y=""
  1. N CRLF S CRLF=+$G(FILTER("nowrap")) ;1=insert CRLF between lines
  1. S I=+$O(ARRAY("")) I I=0 S I=+$O(ARRAY(0))
  1. S Y=$S($D(ARRAY(I,0)):ARRAY(I,0),1:$G(ARRAY(I)))
  1. F S I=$O(ARRAY(I)) Q:I<1 D
  1. . S X=$S($D(ARRAY(I,0)):ARRAY(I,0),1:ARRAY(I))
  1. . I $E(X)=" " S Y=Y_$C(13,10)_X Q
  1. . I CRLF S Y=Y_$C(13,10)_X Q
  1. . S Y=Y_$S($E(Y,$L(Y))=" ":"",1:" ")_X
  1. Q Y
  1. ;
  1. FAC(X) ; -- return Institution file station# for location X
  1. N HLOC,FAC,Y0,Y S Y=""
  1. S HLOC=$G(^SC(+$G(X),0)),FAC=$P(HLOC,U,4)
  1. ; Get P:4 via Med Ctr Div, if not directly linked
  1. I 'FAC,$P(HLOC,U,15) S FAC=$$GET1^DIQ(44,+$G(X)_",","3.5:.07","I")
  1. S Y0=$S(FAC:$$NS^XUAF4(FAC),1:$P($$SITE^VASITE,U,2,3)) ;name^stn#
  1. S:$L(Y0) Y=$P(Y0,U,2)_U_$P(Y0,U) ;switch to stn#^name
  1. I $L(Y),'Y S $P(Y,U)=FAC
  1. Q Y
  1. ;
  1. PROVTAGS() ; -- Return attribute tags for provider info as built below
  1. Q "officePhone^analogPager^fax^email^taxonomyCode^providerType^classification^specialization^service"
  1. ;
  1. PROVSPC(NP) ; -- Return contact & specialty info for provider NP
  1. ; save strings in ^TMP("VPRD",$J,NP) for efficiency
  1. N X,Y,I,CLS,RES,X13,X15 S NP=+$G(NP) ;protect I for calling routine
  1. S RES=$G(^TMP("VPRD",$J,NP)) I $L(RES) Q RES
  1. S X13=$G(^VA(200,NP,.13)),X15=$G(^(.15))
  1. S RES=$P(X13,U,2)_U_$P(X13,U,7)_U_$P(X13,U,6)_U_$P(X15,U)_U
  1. S X=$$TAXIND^XUSTAX(NP) I $P(X,U,2) D ;= X12 code ^ #8932.1 ien
  1. . S CLS=$G(^USC(8932.1,$P(X,U,2),0)) Q:CLS=""
  1. . S RES=RES_$P(X,U)_U_$P(CLS,U,1,3) ;X12^type^class^specialization
  1. S $P(RES,U,9)=$$GET1^DIQ(200,NP_",",29)
  1. S ^TMP("VPRD",$J,NP)=RES
  1. Q RES
  1. ;
  1. VUID(IEN,FILE) ; -- Return VUID for item
  1. Q $$GET1^DIQ(FILE,IEN_",",99.99)
  1. ;
  1. VERSION(RET) ; -- Return current version of data extracts
  1. S RET=$$GET^XPAR("ALL","VPR VERSION")
  1. Q
  1. ;
  1. TEST(DFN,TYPE,ID,START,STOP,MAX,TEXT,IN) ; -- test GET, write results to screen
  1. N OUT,IDX S U="^"
  1. S DFN=+$G(DFN) Q:DFN<1
  1. S TYPE=$G(TYPE) Q:TYPE=""
  1. D GET(.OUT,DFN,TYPE,$G(START),$G(STOP),$G(MAX),$G(ID),.IN)
  1. ;
  1. S IDX=OUT
  1. F S IDX=$Q(@IDX) Q:IDX'?1"^TMP(""VPR"","1.N.E Q:+$P(IDX,",",2)'=$J W !,@IDX
  1. Q