- VPRDPROC ;SLC/MKB -- Procedure extract ;8/2/11 15:29
- ;;1.0;VIRTUAL PATIENT RECORD;**1,5**;Sep 01, 2011;Build 21
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ; External References DBIA#
- ; ------------------- -----
- ; RAO7PC1 2043
- ; SROESTV 3533
- ;
- ; ------------ Get procedure(s) from VistA ------------
- ;
- EN(DFN,BEG,END,MAX,ID) ; -- find patient's procedures
- S DFN=+$G(DFN) Q:DFN<1
- S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
- ;
- N VPRN,VPRCNT,VPRITM,VPRY,VPRCATG
- S VPRCATG=$G(FILTER("category"),"SR;RA") ;NwHIN default
- ;
- ; get one procedure
- I $G(ID),ID'[";" D D:$D(VPRITM) XML(.VPRITM) Q
- . I ID'["-" D EN1^VPRDSR(ID,.VPRITM) Q ;Surgery
- . S (BEG,END)=9999999.9999=+ID D EN1^RAO7PC1(DFN,BEG,END,"1P")
- . D EN1^VPRDRA(ID,.VPRITM) ;Radiology
- . K ^TMP($J,"RAE1")
- I $G(ID),ID[";" D EN^VPRDMC(DFN,,,,ID) Q ;CP/Medicine
- ;
- SR ; get all surgeries
- I VPRCATG'["SR" G RA
- N SHOWADD S SHOWADD=1 ;to omit leading '+' with note titles
- D LIST^SROESTV(.VPRY,DFN,BEG,END,MAX,1)
- S VPRN=0 F S VPRN=$O(@VPRY@(VPRN)) Q:VPRN<1 D
- . K VPRITM D ONE^VPRDSR(VPRN,.VPRITM) Q:'$D(VPRITM)
- . ;Q:$G(VPRITM("status"))'?1"COMP".E
- . D XML(.VPRITM)
- K @VPRY
- ;
- RA ; get all radiology exams
- I VPRCATG'["RA" G CP
- K ^TMP($J,"RAE1") D EN1^RAO7PC1(DFN,BEG,END,MAX)
- S VPRCNT=+$G(VPRTOTL),VPRN=""
- 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
- . K VPRITM D EN1^VPRDRA(VPRN,.VPRITM) Q:'$D(VPRITM)
- . D XML(.VPRITM) S VPRCNT=VPRCNT+1
- K ^TMP($J,"RAE1")
- ;
- CP ; get CP procedures
- D:VPRCATG["CP" EN^VPRDMC(DFN,BEG,END,MAX)
- ;
- ; V-CPT
- ;
- Q
- ;
- ; ------------ Return data to middle tier ------------
- ;
- XML(PROC) ; -- Return procedures as XML
- N ATT,X,Y,I,J,NAMES
- D ADD("<procedure>") S VPRTOTL=$G(VPRTOTL)+1
- S ATT="" F S ATT=$O(PROC(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
- . S NAMES=$S(ATT="document"!(ATT="opReport"):"id^localTitle^nationalTitle^vuid^status^Z",1:"code^name^Z")
- . I $O(PROC(ATT,0)) D S Y="" Q ;multiples
- .. D ADD("<"_ATT_"s>")
- .. S I=0 F S I=$O(PROC(ATT,I)) Q:I<1 D
- ... S X=$G(PROC(ATT,I))
- ... S Y="<"_ATT_" "_$$LOOP ;_"/>" D ADD(Y)
- ... S X=$G(PROC(ATT,I,"content")) I '$L(X) S Y=Y_"/>" D ADD(Y) Q
- ... S Y=Y_">" D ADD(Y)
- ... S Y="<content xml:space='preserve'>" D ADD(Y)
- ... S J=0 F S J=$O(@X@(J)) Q:J<1 S Y=$$ESC^VPRD(@X@(J)) D ADD(Y)
- ... D ADD("</content>"),ADD("</"_ATT_">")
- .. D ADD("</"_ATT_"s>")
- . S X=$G(PROC(ATT)),Y="" Q:'$L(X)
- . I X'["^" S Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />" Q
- . I $L(X)>1 S Y="<"_ATT_" "_$$LOOP_"/>"
- D ADD("</procedure>")
- Q
- ;
- LOOP() ; -- build sub-items string from NAMES and X
- N STR,P,TAG S STR=""
- 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))_"' "
- Q STR
- ;
- ADD(X) ; -- Add a line @VPR@(n)=X
- S VPRI=$G(VPRI)+1
- S @VPR@(VPRI)=X
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDPROC 3014 printed Feb 19, 2025@00:11:19 Page 2
- VPRDPROC ;SLC/MKB -- Procedure extract ;8/2/11 15:29
- +1 ;;1.0;VIRTUAL PATIENT RECORD;**1,5**;Sep 01, 2011;Build 21
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ; External References DBIA#
- +5 ; ------------------- -----
- +6 ; RAO7PC1 2043
- +7 ; SROESTV 3533
- +8 ;
- +9 ; ------------ Get procedure(s) from VistA ------------
- +10 ;
- EN(DFN,BEG,END,MAX,ID) ; -- find patient's procedures
- +1 SET DFN=+$GET(DFN)
- if DFN<1
- QUIT
- +2 SET BEG=$GET(BEG,1410101)
- SET END=$GET(END,4141015)
- SET MAX=$GET(MAX,9999)
- +3 ;
- +4 NEW VPRN,VPRCNT,VPRITM,VPRY,VPRCATG
- +5 ;NwHIN default
- SET VPRCATG=$GET(FILTER("category"),"SR;RA")
- +6 ;
- +7 ; get one procedure
- +8 IF $GET(ID)
- IF ID'[";"
- Begin DoDot:1
- +9 ;Surgery
- IF ID'["-"
- DO EN1^VPRDSR(ID,.VPRITM)
- QUIT
- +10 SET (BEG,END)=9999999.9999=+ID
- DO EN1^RAO7PC1(DFN,BEG,END,"1P")
- +11 ;Radiology
- DO EN1^VPRDRA(ID,.VPRITM)
- +12 KILL ^TMP($JOB,"RAE1")
- End DoDot:1
- if $DATA(VPRITM)
- DO XML(.VPRITM)
- QUIT
- +13 ;CP/Medicine
- IF $GET(ID)
- IF ID[";"
- DO EN^VPRDMC(DFN,,,,ID)
- QUIT
- +14 ;
- SR ; get all surgeries
- +1 IF VPRCATG'["SR"
- GOTO RA
- +2 ;to omit leading '+' with note titles
- NEW SHOWADD
- SET SHOWADD=1
- +3 DO LIST^SROESTV(.VPRY,DFN,BEG,END,MAX,1)
- +4 SET VPRN=0
- FOR
- SET VPRN=$ORDER(@VPRY@(VPRN))
- if VPRN<1
- QUIT
- Begin DoDot:1
- +5 KILL VPRITM
- DO ONE^VPRDSR(VPRN,.VPRITM)
- if '$DATA(VPRITM)
- QUIT
- +6 ;Q:$G(VPRITM("status"))'?1"COMP".E
- +7 DO XML(.VPRITM)
- End DoDot:1
- +8 KILL @VPRY
- +9 ;
- RA ; get all radiology exams
- +1 IF VPRCATG'["RA"
- GOTO CP
- +2 KILL ^TMP($JOB,"RAE1")
- DO EN1^RAO7PC1(DFN,BEG,END,MAX)
- +3 SET VPRCNT=+$GET(VPRTOTL)
- SET VPRN=""
- +4 ;I $P($P($G(^(VPRN)),U,6),"~",2)?1"COMP".E
- FOR
- SET VPRN=$ORDER(^TMP($JOB,"RAE1",DFN,VPRN))
- if VPRN=""
- QUIT
- Begin DoDot:1
- +5 KILL VPRITM
- DO EN1^VPRDRA(VPRN,.VPRITM)
- if '$DATA(VPRITM)
- QUIT
- +6 DO XML(.VPRITM)
- SET VPRCNT=VPRCNT+1
- End DoDot:1
- if VPRCNT'<MAX
- QUIT
- +7 KILL ^TMP($JOB,"RAE1")
- +8 ;
- CP ; get CP procedures
- +1 if VPRCATG["CP"
- DO EN^VPRDMC(DFN,BEG,END,MAX)
- +2 ;
- +3 ; V-CPT
- +4 ;
- +5 QUIT
- +6 ;
- +7 ; ------------ Return data to middle tier ------------
- +8 ;
- XML(PROC) ; -- Return procedures as XML
- +1 NEW ATT,X,Y,I,J,NAMES
- +2 DO ADD("<procedure>")
- SET VPRTOTL=$GET(VPRTOTL)+1
- +3 SET ATT=""
- FOR
- SET ATT=$ORDER(PROC(ATT))
- if ATT=""
- QUIT
- Begin DoDot:1
- +4 SET NAMES=$SELECT(ATT="document"!(ATT="opReport"):"id^localTitle^nationalTitle^vuid^status^Z",1:"code^name^Z")
- +5 ;multiples
- IF $ORDER(PROC(ATT,0))
- Begin DoDot:2
- +6 DO ADD("<"_ATT_"s>")
- +7 SET I=0
- FOR
- SET I=$ORDER(PROC(ATT,I))
- if I<1
- QUIT
- Begin DoDot:3
- +8 SET X=$GET(PROC(ATT,I))
- +9 ;_"/>" D ADD(Y)
- SET Y="<"_ATT_" "_$$LOOP
- +10 SET X=$GET(PROC(ATT,I,"content"))
- IF '$LENGTH(X)
- SET Y=Y_"/>"
- DO ADD(Y)
- QUIT
- +11 SET Y=Y_">"
- DO ADD(Y)
- +12 SET Y="<content xml:space='preserve'>"
- DO ADD(Y)
- +13 SET J=0
- FOR
- SET J=$ORDER(@X@(J))
- if J<1
- QUIT
- SET Y=$$ESC^VPRD(@X@(J))
- DO ADD(Y)
- +14 DO ADD("</content>")
- DO ADD("</"_ATT_">")
- End DoDot:3
- +15 DO ADD("</"_ATT_"s>")
- End DoDot:2
- SET Y=""
- QUIT
- +16 SET X=$GET(PROC(ATT))
- SET Y=""
- if '$LENGTH(X)
- QUIT
- +17 IF X'["^"
- SET Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />"
- QUIT
- +18 IF $LENGTH(X)>1
- SET Y="<"_ATT_" "_$$LOOP_"/>"
- End DoDot:1
- if $LENGTH(Y)
- DO ADD(Y)
- +19 DO ADD("</procedure>")
- +20 QUIT
- +21 ;
- LOOP() ; -- build sub-items string from NAMES and X
- +1 NEW STR,P,TAG
- SET STR=""
- +2 FOR P=1:1
- SET TAG=$PIECE(NAMES,U,P)
- if TAG="Z"
- QUIT
- IF $LENGTH($PIECE(X,U,P))
- SET STR=STR_TAG_"='"_$$ESC^VPRD($PIECE(X,U,P))_"' "
- +3 QUIT STR
- +4 ;
- ADD(X) ; -- Add a line @VPR@(n)=X
- +1 SET VPRI=$GET(VPRI)+1
- +2 SET @VPR@(VPRI)=X
- +3 QUIT