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

VPRDPROC.m

Go to the documentation of this file.
  1. VPRDPROC ;SLC/MKB -- Procedure extract ;8/2/11 15:29
  1. ;;1.0;VIRTUAL PATIENT RECORD;**1,5**;Sep 01, 2011;Build 21
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ; External References DBIA#
  1. ; ------------------- -----
  1. ; RAO7PC1 2043
  1. ; SROESTV 3533
  1. ;
  1. ; ------------ Get procedure(s) from VistA ------------
  1. ;
  1. EN(DFN,BEG,END,MAX,ID) ; -- find patient's procedures
  1. S DFN=+$G(DFN) Q:DFN<1
  1. S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
  1. ;
  1. N VPRN,VPRCNT,VPRITM,VPRY,VPRCATG
  1. S VPRCATG=$G(FILTER("category"),"SR;RA") ;NwHIN default
  1. ;
  1. ; get one procedure
  1. I $G(ID),ID'[";" D D:$D(VPRITM) XML(.VPRITM) Q
  1. . I ID'["-" D EN1^VPRDSR(ID,.VPRITM) Q ;Surgery
  1. . S (BEG,END)=9999999.9999=+ID D EN1^RAO7PC1(DFN,BEG,END,"1P")
  1. . D EN1^VPRDRA(ID,.VPRITM) ;Radiology
  1. . K ^TMP($J,"RAE1")
  1. I $G(ID),ID[";" D EN^VPRDMC(DFN,,,,ID) Q ;CP/Medicine
  1. ;
  1. SR ; get all surgeries
  1. I VPRCATG'["SR" G RA
  1. N SHOWADD S SHOWADD=1 ;to omit leading '+' with note titles
  1. D LIST^SROESTV(.VPRY,DFN,BEG,END,MAX,1)
  1. S VPRN=0 F S VPRN=$O(@VPRY@(VPRN)) Q:VPRN<1 D
  1. . K VPRITM D ONE^VPRDSR(VPRN,.VPRITM) Q:'$D(VPRITM)
  1. . ;Q:$G(VPRITM("status"))'?1"COMP".E
  1. . D XML(.VPRITM)
  1. K @VPRY
  1. ;
  1. RA ; get all radiology exams
  1. I VPRCATG'["RA" G CP
  1. K ^TMP($J,"RAE1") D EN1^RAO7PC1(DFN,BEG,END,MAX)
  1. S VPRCNT=+$G(VPRTOTL),VPRN=""
  1. F S VPRN=$O(^TMP($J,"RAE1",DFN,VPRN)) Q:VPRN="" D Q:VPRCNT'<MAX ;I $P($P($G(^(VPRN)),U,6),"~",2)?1"COMP".E
  1. . K VPRITM D EN1^VPRDRA(VPRN,.VPRITM) Q:'$D(VPRITM)
  1. . D XML(.VPRITM) S VPRCNT=VPRCNT+1
  1. K ^TMP($J,"RAE1")
  1. ;
  1. CP ; get CP procedures
  1. D:VPRCATG["CP" EN^VPRDMC(DFN,BEG,END,MAX)
  1. ;
  1. ; V-CPT
  1. ;
  1. Q
  1. ;
  1. ; ------------ Return data to middle tier ------------
  1. ;
  1. XML(PROC) ; -- Return procedures as XML
  1. N ATT,X,Y,I,J,NAMES
  1. D ADD("<procedure>") S VPRTOTL=$G(VPRTOTL)+1
  1. S ATT="" F S ATT=$O(PROC(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
  1. . S NAMES=$S(ATT="document"!(ATT="opReport"):"id^localTitle^nationalTitle^vuid^status^Z",1:"code^name^Z")
  1. . I $O(PROC(ATT,0)) D S Y="" Q ;multiples
  1. .. D ADD("<"_ATT_"s>")
  1. .. S I=0 F S I=$O(PROC(ATT,I)) Q:I<1 D
  1. ... S X=$G(PROC(ATT,I))
  1. ... S Y="<"_ATT_" "_$$LOOP ;_"/>" D ADD(Y)
  1. ... S X=$G(PROC(ATT,I,"content")) I '$L(X) S Y=Y_"/>" D ADD(Y) Q
  1. ... S Y=Y_">" D ADD(Y)
  1. ... S Y="<content xml:space='preserve'>" D ADD(Y)
  1. ... S J=0 F S J=$O(@X@(J)) Q:J<1 S Y=$$ESC^VPRD(@X@(J)) D ADD(Y)
  1. ... D ADD("</content>"),ADD("</"_ATT_">")
  1. .. D ADD("</"_ATT_"s>")
  1. . S X=$G(PROC(ATT)),Y="" Q:'$L(X)
  1. . I X'["^" S Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />" Q
  1. . I $L(X)>1 S Y="<"_ATT_" "_$$LOOP_"/>"
  1. D ADD("</procedure>")
  1. Q
  1. ;
  1. LOOP() ; -- build sub-items string from NAMES and X
  1. N STR,P,TAG S STR=""
  1. F P=1:1 S TAG=$P(NAMES,U,P) Q:TAG="Z" I $L($P(X,U,P)) S STR=STR_TAG_"='"_$$ESC^VPRD($P(X,U,P))_"' "
  1. Q STR
  1. ;
  1. ADD(X) ; -- Add a line @VPR@(n)=X
  1. S VPRI=$G(VPRI)+1
  1. S @VPR@(VPRI)=X
  1. Q