VPRDMC ;SLC/MKB -- Clinical Procedures (Medicine) ;3/14/12 09:03
;;1.0;VIRTUAL PATIENT RECORD;**1,2,5**;Sep 01, 2011;Build 21
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^SC 10040
; ^VA(200 10060
; %DT 10003
; DILFD 2055
; DIQ 2056
; GMRCGUIB 2980
; ICPTCOD 1995
; MCARUTL2 3279
; MCARUTL3 3280
; MDPS1,^TMP("MDHSP"/"MDPTXT" 4230
; TIULQ 2693
; TIUSRVLO 2834
; XUAF4 2171
;
; ------------ Get procedures from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's procedures
N VPRITM,RES,VPRN,VPRX,RTN,DATE,CONS,TIUN,X0,DA,GBL,X,Y,%DT,VPRT,LOC
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
S DFN=+$G(DFN) Q:DFN<1
;
; get one procedure
I $G(ID) D ;reset dates for MDPS1
. N VPRMC,IEN,FILE
. S IEN=+ID,FILE=+$P(ID,"(",2) Q:FILE=702
. D MEDLKUP^MCARUTL3(.VPRMC,FILE,IEN)
. S X=$P(VPRMC,U,6) S:X (BEG,END)=X
;
; get all procedures
K ^TMP("MDHSP",$J) S RES=""
D EN1^MDPS1(RES,DFN,BEG,END,MAX,"",0)
S VPRN=0 F S VPRN=$O(^TMP("MDHSP",$J,VPRN)) Q:VPRN<1 S VPRX=$G(^(VPRN)) D
. I $G(ID),ID'=+$P(VPRX,U,2) Q ;update one procedure
. S RTN=$P(VPRX,U,3,4) Q:RTN="PRPRO^MDPS4" ;skip non-CP items
. S X=$P(VPRX,U,6),%DT="STX" D ^%DT S:Y>0 DATE=Y
. S GBL=+$P(VPRX,U,2)_";"_$S(RTN="PR702^MDPS1":"MDD(702,",1:$$ROOT(DFN,$P(VPRX,U,11),DATE))
. Q:'GBL I $G(ID),ID'=GBL Q ;unknown, or not requested
. ;
. S CONS=+$P(VPRX,U,13) D:CONS DOCLIST^GMRCGUIB(.VPRD,CONS) S X0=$G(VPRD(0)) ;=^GMR(123,ID,0)
. S TIUN=+$P(VPRX,U,14) S:TIUN TIUN=TIUN_U_$$RESOLVE^TIUSRVLO(TIUN)
A . ;
. K VPRITM S VPRITM("id")=GBL,VPRITM("name")=$P(VPRX,U)
. S VPRITM("dateTime")=DATE,VPRITM("category")="CP"
. S X=$P(VPRX,U,7) S:$L(X) VPRITM("interpretation")=X
. I CONS,X0 D
.. N VPRJ S VPRITM("consult")=CONS
.. S VPRITM("requested")=+X0,VPRITM("order")=+$P(X0,U,3)
.. S VPRITM("status")=$$EXTERNAL^DILFD(123,8,,$P(X0,U,12))
.. S VPRJ=0 F S VPRJ=$O(VPRD(50,VPRJ)) Q:VPRJ<1 S X=+$G(VPRD(50,VPRJ)) D
... N Y S Y=$$INFO^VPRDTIU(+X) Q:Y<1 ;draft or retracted
... S VPRITM("document",X)=Y ;ien^local^national title^VUID
... S:$G(VPRTEXT) VPRITM("document",X,"content")=$$TEXT^VPRDTIU(X)
... S:'TIUN TIUN=X ;get supporting fields
B . ;
. I TIUN D
.. S X=$P(TIUN,U,5) S:X VPRITM("provider")=+X_U_$P(X,";",3)_U_$$PROVSPC^VPRD(+X)
.. S:$P(TIUN,U,11) VPRITM("hasImages")=1
.. K VPRT D EXTRACT^TIULQ(+TIUN,"VPRT",,".03;.05;1211",,,"I")
.. S VPRITM("encounter")=+$G(VPRT(+TIUN,.03,"I"))
.. S LOC=+$G(VPRT(+TIUN,1211,"I")) I LOC S LOC=LOC_U_$P($G(^SC(LOC,0)),U)
.. E S X=$P(TIUN,U,6) S:$L(X) LOC=+$O(^SC("B",X,0))_U_X
.. S:LOC VPRITM("location")=LOC,VPRITM("facility")=$$FAC^VPRD(+LOC)
.. I '$D(VPRITM("status")) S X=+$G(VPRT(+TIUN,.05,"I")),VPRITM("status")=$S(X<6:"PARTIAL RESULTS",1:"COMPLETE")
.. I '$G(VPRITM("document",+TIUN)) D
... N Y S Y=$$INFO^VPRDTIU(+TIUN) Q:Y<1 ;draft or retracted
... S VPRITM("document",+TIUN)=Y ;ien^local^national title^VUID
... S:$G(VPRTEXT) VPRITM("document",+TIUN,"content")=$$TEXT^VPRDTIU(+TIUN)
C . ;
. ; if no consult or note/visit ...
. I TIUN<1 D
.. S VPRITM("document",1)=GBL_U_$P(VPRX,U)_"^PROCEDURE REPORT^4696566"
.. S:$G(VPRTEXT) VPRITM("document",1,"content")=$$TEXT(DFN,GBL,$P(VPRX,U,11))
. I '$D(VPRITM("facility")) S X=$P(X0,U,21),VPRITM("facility")=$S(X:$$STA^XUAF4(X)_U_$P($$NS^XUAF4(X),U),1:$$FAC^VPRD)
. I '$D(VPRITM("status")) S VPRITM("status")="COMPLETE"
. ;I DA D ;get CPT code from #697.2
. ;. K VPRT D GETS^DIQ(697.2,DA_",","1000*",,"VPRT")
. ;. N IENS S IENS=$O(VPRT(697.21,"")) Q:IENS=""
. ;. S X=VPRT(697.21,IENS,.01),VPRITM("type")=$$CPT(X)
. ;
. D XML(.VPRITM)
ENQ ;
K ^TMP("MDHSP",$J),^TMP("VPRTEXT",$J)
Q
;
ROOT(DFN,NAME,DATE) ; -- return vptr ID for procedure instance
N VPRMC,Y
D SUB^MCARUTL2(.VPRMC,DFN,NAME,DATE,DATE)
S Y=$S(+$G(VPRMC):$P($G(VPRMC(VPRMC)),U,4)_",",1:"")
Q Y
;
CPT(IEN) ; -- return code^description for CPT code, or "^" if error
N X0,VPRX,N,I,X,Y S IEN=+$G(IEN)
S X0=$$CPT^ICPTCOD(IEN) I X0<0 Q "^"
S Y=$P(X0,U,2,3) ;CPT Code^Short Name
S N=$$CPTD^ICPTCOD($P(Y,U),"VPRX") ;CPT Description
I N>0,$L($G(VPRX(1))) D
. S X=$G(VPRX(1)),I=1
. F S I=$O(VPRX(I)) Q:I<1 Q:VPRX(I)=" " S X=X_" "_VPRX(I)
. S $P(Y,U,2)=X
Q Y
;
; ------------ Get report(s) [via VPRDTIU] ------------
;
RPTS(DFN,BEG,END,MAX) ; -- find patient's medicine reports
N VPRITM,VPRN,VPRX,RTN,TIUN,CONS,VPRD,I,DA,X,Y,%DT,DATE,GBL,RES
S DFN=+$G(DFN) Q:$G(DFN)<1
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999),RES=""
K ^TMP("MDHSP",$J) D EN1^MDPS1(RES,DFN,BEG,END,MAX,"",0)
S VPRN=0 F S VPRN=$O(^TMP("MDHSP",$J,VPRN)) Q:VPRN<1 S VPRX=$G(^(VPRN)) D
. S RTN=$P(VPRX,U,3,4) ;Q:RTN="PRPRO^MDPS4" ;skip non-CP items
. S TIUN=+$P(VPRX,U,14) K VPRITM
. I TIUN,$$INFO^VPRDTIU(TIUN)>0 D EN1^VPRDTIU(TIUN,.VPRITM),XML^VPRDTIU(.VPRITM):$D(VPRITM)
. S CONS=+$P(VPRX,U,13) D:CONS DOCLIST^GMRCGUIB(.VPRD,CONS)
. S I=0 F S I=$O(VPRD(50,I)) Q:I<1 D
.. K VPRITM S DA=+VPRD(50,I) Q:DA=TIUN Q:$$INFO^VPRDTIU(DA)<1
.. D EN1^VPRDTIU(DA,.VPRITM),XML^VPRDTIU(.VPRITM):$D(VPRITM)
. Q:TIUN!$G(DA) ;done [got TIU note(s)]
. Q:RTN="PR702^MDPS1" ;CP, but no TIU note yet
. Q:RTN="PRPRO^MDPS4" ;non-CP procedure
. ; find ID for pre-TIU report
. S X=$P(VPRX,U,6),%DT="TX" D ^%DT S:Y>0 DATE=Y
. S GBL=+$P(VPRX,U,2)_";"_$$ROOT(DFN,$P(VPRX,U,11),DATE)
. I GBL D RPT1(DFN,GBL,.VPRITM),XML^VPRDTIU(.VPRITM):$D(VPRITM)
K ^TMP("MDHSP",$J),^TMP("VPRTEXT",$J)
Q
;
RPT1(DFN,ID,RPT) ; -- return report as a TIU document
S DFN=+$G(DFN),ID=$G(ID) Q:DFN<1 Q:'$L(ID)
N VPRY,VPRFN,X
S VPRFN=+$P(ID,"(",2)
D MEDLKUP^MCARUTL3(.VPRY,VPRFN,+ID)
S RPT("id")=ID,RPT("referenceDateTime")=$P(VPRY,U,6)
S RPT("localTitle")=$P(VPRY,U,9),RPT("category")="CP"
S RPT("documentClass")="CLINICAL PROCEDURES"
S RPT("nationalTitle")="4696566^PROCEDURE REPORT"
S RPT("nationalTitleService")="4696471^PROCEDURE"
S RPT("nationalTitleType")="4696123^REPORT"
S:$G(FILTER("loinc")) RPT("loinc")=$P(FILTER("loinc"),U)
S X=$$GET1^DIQ(VPRFN,+ID_",",1506)
S RPT("status")=$S($L(X):X,1:"COMPLETED")
S X=+$$GET1^DIQ(VPRFN,+ID_",",701,"I")
S:X RPT("clinician",1)=X_U_$P($G(^VA(200,X,0)),U)_"^A^^^"_$$PROVSPC^VPRD(X)
S X=+$$GET1^DIQ(VPRFN,+ID_",",1503,"I")
S:X RPT("clinician",2)=X_U_$P($G(^VA(200,X,0)),U)_"^S^"_$$GET1^DIQ(VPRFN,+ID_",",1505,"I")_U_$$SIG^VPRDTIU(X)_U_$$PROVSPC^VPRD(X)
; RPT("encounter")=$$GET1^DIQ(VPRFN,+ID_",",900,"I")
S RPT("facility")=$$FAC^VPRD
S:$G(VPRTEXT) RPT("content")=$$TEXT(DFN,ID,$P(VPRY,U,9))
Q
;
TEXT(DFN,ID,NAME) ; -- Get report text, return temp array name
N MCARGDA,MCPRO,MDALL,I,X,Y
S MCARGDA=+$G(ID),MCPRO=NAME,MDALL=1 D PR690^MDPS1
K ^TMP("VPRTEXT",$J,ID)
S I=0 F S I=$O(^TMP("MDPTXT",$J,MCARGDA,MCPRO,I)) Q:I<1 S X=$G(^(I,0)),^TMP("VPRTEXT",$J,ID,I)=X
S Y=$NA(^TMP("VPRTEXT",$J,ID))
K ^TMP("MDPTXT",$J)
Q Y
;
; ------------ Return data to middle tier ------------
;
XML(PROC) ; -- Return patient procedure as XML
; as <element code='123' displayName='ABC' />
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":"id^localTitle^nationalTitle^vuid",ATT="provider":"code^name^"_$$PROVTAGS^VPRD,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)),Y="<"_ATT_" "_$$LOOP
... 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[HVPRDMC 8729 printed Oct 16, 2024@18:45:25 Page 2
VPRDMC ;SLC/MKB -- Clinical Procedures (Medicine) ;3/14/12 09:03
+1 ;;1.0;VIRTUAL PATIENT RECORD;**1,2,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 ; ^SC 10040
+7 ; ^VA(200 10060
+8 ; %DT 10003
+9 ; DILFD 2055
+10 ; DIQ 2056
+11 ; GMRCGUIB 2980
+12 ; ICPTCOD 1995
+13 ; MCARUTL2 3279
+14 ; MCARUTL3 3280
+15 ; MDPS1,^TMP("MDHSP"/"MDPTXT" 4230
+16 ; TIULQ 2693
+17 ; TIUSRVLO 2834
+18 ; XUAF4 2171
+19 ;
+20 ; ------------ Get procedures from VistA ------------
+21 ;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's procedures
+1 NEW VPRITM,RES,VPRN,VPRX,RTN,DATE,CONS,TIUN,X0,DA,GBL,X,Y,%DT,VPRT,LOC
+2 SET BEG=$GET(BEG,1410101)
SET END=$GET(END,4141015)
SET MAX=$GET(MAX,9999)
+3 SET DFN=+$GET(DFN)
if DFN<1
QUIT
+4 ;
+5 ; get one procedure
+6 ;reset dates for MDPS1
IF $GET(ID)
Begin DoDot:1
+7 NEW VPRMC,IEN,FILE
+8 SET IEN=+ID
SET FILE=+$PIECE(ID,"(",2)
if FILE=702
QUIT
+9 DO MEDLKUP^MCARUTL3(.VPRMC,FILE,IEN)
+10 SET X=$PIECE(VPRMC,U,6)
if X
SET (BEG,END)=X
End DoDot:1
+11 ;
+12 ; get all procedures
+13 KILL ^TMP("MDHSP",$JOB)
SET RES=""
+14 DO EN1^MDPS1(RES,DFN,BEG,END,MAX,"",0)
+15 SET VPRN=0
FOR
SET VPRN=$ORDER(^TMP("MDHSP",$JOB,VPRN))
if VPRN<1
QUIT
SET VPRX=$GET(^(VPRN))
Begin DoDot:1
+16 ;update one procedure
IF $GET(ID)
IF ID'=+$PIECE(VPRX,U,2)
QUIT
+17 ;skip non-CP items
SET RTN=$PIECE(VPRX,U,3,4)
if RTN="PRPRO^MDPS4"
QUIT
+18 SET X=$PIECE(VPRX,U,6)
SET %DT="STX"
DO ^%DT
if Y>0
SET DATE=Y
+19 SET GBL=+$PIECE(VPRX,U,2)_";"_$SELECT(RTN="PR702^MDPS1":"MDD(702,",1:$$ROOT(DFN,$PIECE(VPRX,U,11),DATE))
+20 ;unknown, or not requested
if 'GBL
QUIT
IF $GET(ID)
IF ID'=GBL
QUIT
+21 ;
+22 ;=^GMR(123,ID,0)
SET CONS=+$PIECE(VPRX,U,13)
if CONS
DO DOCLIST^GMRCGUIB(.VPRD,CONS)
SET X0=$GET(VPRD(0))
+23 SET TIUN=+$PIECE(VPRX,U,14)
if TIUN
SET TIUN=TIUN_U_$$RESOLVE^TIUSRVLO(TIUN)
A ;
+1 KILL VPRITM
SET VPRITM("id")=GBL
SET VPRITM("name")=$PIECE(VPRX,U)
+2 SET VPRITM("dateTime")=DATE
SET VPRITM("category")="CP"
+3 SET X=$PIECE(VPRX,U,7)
if $LENGTH(X)
SET VPRITM("interpretation")=X
+4 IF CONS
IF X0
Begin DoDot:2
+5 NEW VPRJ
SET VPRITM("consult")=CONS
+6 SET VPRITM("requested")=+X0
SET VPRITM("order")=+$PIECE(X0,U,3)
+7 SET VPRITM("status")=$$EXTERNAL^DILFD(123,8,,$PIECE(X0,U,12))
+8 SET VPRJ=0
FOR
SET VPRJ=$ORDER(VPRD(50,VPRJ))
if VPRJ<1
QUIT
SET X=+$GET(VPRD(50,VPRJ))
Begin DoDot:3
+9 ;draft or retracted
NEW Y
SET Y=$$INFO^VPRDTIU(+X)
if Y<1
QUIT
+10 ;ien^local^national title^VUID
SET VPRITM("document",X)=Y
+11 if $GET(VPRTEXT)
SET VPRITM("document",X,"content")=$$TEXT^VPRDTIU(X)
+12 ;get supporting fields
if 'TIUN
SET TIUN=X
End DoDot:3
End DoDot:2
B ;
+1 IF TIUN
Begin DoDot:2
+2 SET X=$PIECE(TIUN,U,5)
if X
SET VPRITM("provider")=+X_U_$PIECE(X,";",3)_U_$$PROVSPC^VPRD(+X)
+3 if $PIECE(TIUN,U,11)
SET VPRITM("hasImages")=1
+4 KILL VPRT
DO EXTRACT^TIULQ(+TIUN,"VPRT",,".03;.05;1211",,,"I")
+5 SET VPRITM("encounter")=+$GET(VPRT(+TIUN,.03,"I"))
+6 SET LOC=+$GET(VPRT(+TIUN,1211,"I"))
IF LOC
SET LOC=LOC_U_$PIECE($GET(^SC(LOC,0)),U)
+7 IF '$TEST
SET X=$PIECE(TIUN,U,6)
if $LENGTH(X)
SET LOC=+$ORDER(^SC("B",X,0))_U_X
+8 if LOC
SET VPRITM("location")=LOC
SET VPRITM("facility")=$$FAC^VPRD(+LOC)
+9 IF '$DATA(VPRITM("status"))
SET X=+$GET(VPRT(+TIUN,.05,"I"))
SET VPRITM("status")=$SELECT(X<6:"PARTIAL RESULTS",1:"COMPLETE")
+10 IF '$GET(VPRITM("document",+TIUN))
Begin DoDot:3
+11 ;draft or retracted
NEW Y
SET Y=$$INFO^VPRDTIU(+TIUN)
if Y<1
QUIT
+12 ;ien^local^national title^VUID
SET VPRITM("document",+TIUN)=Y
+13 if $GET(VPRTEXT)
SET VPRITM("document",+TIUN,"content")=$$TEXT^VPRDTIU(+TIUN)
End DoDot:3
End DoDot:2
C ;
+1 ; if no consult or note/visit ...
+2 IF TIUN<1
Begin DoDot:2
+3 SET VPRITM("document",1)=GBL_U_$PIECE(VPRX,U)_"^PROCEDURE REPORT^4696566"
+4 if $GET(VPRTEXT)
SET VPRITM("document",1,"content")=$$TEXT(DFN,GBL,$PIECE(VPRX,U,11))
End DoDot:2
+5 IF '$DATA(VPRITM("facility"))
SET X=$PIECE(X0,U,21)
SET VPRITM("facility")=$SELECT(X:$$STA^XUAF4(X)_U_$PIECE($$NS^XUAF4(X),U),1:$$FAC^VPRD)
+6 IF '$DATA(VPRITM("status"))
SET VPRITM("status")="COMPLETE"
+7 ;I DA D ;get CPT code from #697.2
+8 ;. K VPRT D GETS^DIQ(697.2,DA_",","1000*",,"VPRT")
+9 ;. N IENS S IENS=$O(VPRT(697.21,"")) Q:IENS=""
+10 ;. S X=VPRT(697.21,IENS,.01),VPRITM("type")=$$CPT(X)
+11 ;
+12 DO XML(.VPRITM)
End DoDot:1
ENQ ;
+1 KILL ^TMP("MDHSP",$JOB),^TMP("VPRTEXT",$JOB)
+2 QUIT
+3 ;
ROOT(DFN,NAME,DATE) ; -- return vptr ID for procedure instance
+1 NEW VPRMC,Y
+2 DO SUB^MCARUTL2(.VPRMC,DFN,NAME,DATE,DATE)
+3 SET Y=$SELECT(+$GET(VPRMC):$PIECE($GET(VPRMC(VPRMC)),U,4)_",",1:"")
+4 QUIT Y
+5 ;
CPT(IEN) ; -- return code^description for CPT code, or "^" if error
+1 NEW X0,VPRX,N,I,X,Y
SET IEN=+$GET(IEN)
+2 SET X0=$$CPT^ICPTCOD(IEN)
IF X0<0
QUIT "^"
+3 ;CPT Code^Short Name
SET Y=$PIECE(X0,U,2,3)
+4 ;CPT Description
SET N=$$CPTD^ICPTCOD($PIECE(Y,U),"VPRX")
+5 IF N>0
IF $LENGTH($GET(VPRX(1)))
Begin DoDot:1
+6 SET X=$GET(VPRX(1))
SET I=1
+7 FOR
SET I=$ORDER(VPRX(I))
if I<1
QUIT
if VPRX(I)=" "
QUIT
SET X=X_" "_VPRX(I)
+8 SET $PIECE(Y,U,2)=X
End DoDot:1
+9 QUIT Y
+10 ;
+11 ; ------------ Get report(s) [via VPRDTIU] ------------
+12 ;
RPTS(DFN,BEG,END,MAX) ; -- find patient's medicine reports
+1 NEW VPRITM,VPRN,VPRX,RTN,TIUN,CONS,VPRD,I,DA,X,Y,%DT,DATE,GBL,RES
+2 SET DFN=+$GET(DFN)
if $GET(DFN)<1
QUIT
+3 SET BEG=$GET(BEG,1410101)
SET END=$GET(END,4141015)
SET MAX=$GET(MAX,9999)
SET RES=""
+4 KILL ^TMP("MDHSP",$JOB)
DO EN1^MDPS1(RES,DFN,BEG,END,MAX,"",0)
+5 SET VPRN=0
FOR
SET VPRN=$ORDER(^TMP("MDHSP",$JOB,VPRN))
if VPRN<1
QUIT
SET VPRX=$GET(^(VPRN))
Begin DoDot:1
+6 ;Q:RTN="PRPRO^MDPS4" ;skip non-CP items
SET RTN=$PIECE(VPRX,U,3,4)
+7 SET TIUN=+$PIECE(VPRX,U,14)
KILL VPRITM
+8 IF TIUN
IF $$INFO^VPRDTIU(TIUN)>0
DO EN1^VPRDTIU(TIUN,.VPRITM)
if $DATA(VPRITM)
DO XML^VPRDTIU(.VPRITM)
+9 SET CONS=+$PIECE(VPRX,U,13)
if CONS
DO DOCLIST^GMRCGUIB(.VPRD,CONS)
+10 SET I=0
FOR
SET I=$ORDER(VPRD(50,I))
if I<1
QUIT
Begin DoDot:2
+11 KILL VPRITM
SET DA=+VPRD(50,I)
if DA=TIUN
QUIT
if $$INFO^VPRDTIU(DA)<1
QUIT
+12 DO EN1^VPRDTIU(DA,.VPRITM)
if $DATA(VPRITM)
DO XML^VPRDTIU(.VPRITM)
End DoDot:2
+13 ;done [got TIU note(s)]
if TIUN!$GET(DA)
QUIT
+14 ;CP, but no TIU note yet
if RTN="PR702^MDPS1"
QUIT
+15 ;non-CP procedure
if RTN="PRPRO^MDPS4"
QUIT
+16 ; find ID for pre-TIU report
+17 SET X=$PIECE(VPRX,U,6)
SET %DT="TX"
DO ^%DT
if Y>0
SET DATE=Y
+18 SET GBL=+$PIECE(VPRX,U,2)_";"_$$ROOT(DFN,$PIECE(VPRX,U,11),DATE)
+19 IF GBL
DO RPT1(DFN,GBL,.VPRITM)
if $DATA(VPRITM)
DO XML^VPRDTIU(.VPRITM)
End DoDot:1
+20 KILL ^TMP("MDHSP",$JOB),^TMP("VPRTEXT",$JOB)
+21 QUIT
+22 ;
RPT1(DFN,ID,RPT) ; -- return report as a TIU document
+1 SET DFN=+$GET(DFN)
SET ID=$GET(ID)
if DFN<1
QUIT
if '$LENGTH(ID)
QUIT
+2 NEW VPRY,VPRFN,X
+3 SET VPRFN=+$PIECE(ID,"(",2)
+4 DO MEDLKUP^MCARUTL3(.VPRY,VPRFN,+ID)
+5 SET RPT("id")=ID
SET RPT("referenceDateTime")=$PIECE(VPRY,U,6)
+6 SET RPT("localTitle")=$PIECE(VPRY,U,9)
SET RPT("category")="CP"
+7 SET RPT("documentClass")="CLINICAL PROCEDURES"
+8 SET RPT("nationalTitle")="4696566^PROCEDURE REPORT"
+9 SET RPT("nationalTitleService")="4696471^PROCEDURE"
+10 SET RPT("nationalTitleType")="4696123^REPORT"
+11 if $GET(FILTER("loinc"))
SET RPT("loinc")=$PIECE(FILTER("loinc"),U)
+12 SET X=$$GET1^DIQ(VPRFN,+ID_",",1506)
+13 SET RPT("status")=$SELECT($LENGTH(X):X,1:"COMPLETED")
+14 SET X=+$$GET1^DIQ(VPRFN,+ID_",",701,"I")
+15 if X
SET RPT("clinician",1)=X_U_$PIECE($GET(^VA(200,X,0)),U)_"^A^^^"_$$PROVSPC^VPRD(X)
+16 SET X=+$$GET1^DIQ(VPRFN,+ID_",",1503,"I")
+17 if X
SET RPT("clinician",2)=X_U_$PIECE($GET(^VA(200,X,0)),U)_"^S^"_$$GET1^DIQ(VPRFN,+ID_",",1505,"I")_U_$$SIG^VPRDTIU(X)_U_$$PROVSPC^VPRD(X)
+18 ; RPT("encounter")=$$GET1^DIQ(VPRFN,+ID_",",900,"I")
+19 SET RPT("facility")=$$FAC^VPRD
+20 if $GET(VPRTEXT)
SET RPT("content")=$$TEXT(DFN,ID,$PIECE(VPRY,U,9))
+21 QUIT
+22 ;
TEXT(DFN,ID,NAME) ; -- Get report text, return temp array name
+1 NEW MCARGDA,MCPRO,MDALL,I,X,Y
+2 SET MCARGDA=+$GET(ID)
SET MCPRO=NAME
SET MDALL=1
DO PR690^MDPS1
+3 KILL ^TMP("VPRTEXT",$JOB,ID)
+4 SET I=0
FOR
SET I=$ORDER(^TMP("MDPTXT",$JOB,MCARGDA,MCPRO,I))
if I<1
QUIT
SET X=$GET(^(I,0))
SET ^TMP("VPRTEXT",$JOB,ID,I)=X
+5 SET Y=$NAME(^TMP("VPRTEXT",$JOB,ID))
+6 KILL ^TMP("MDPTXT",$JOB)
+7 QUIT Y
+8 ;
+9 ; ------------ Return data to middle tier ------------
+10 ;
XML(PROC) ; -- Return patient procedure as XML
+1 ; as <element code='123' displayName='ABC' />
+2 NEW ATT,X,Y,I,J,NAMES
+3 DO ADD("<procedure>")
SET VPRTOTL=$GET(VPRTOTL)+1
+4 SET ATT=""
FOR
SET ATT=$ORDER(PROC(ATT))
if ATT=""
QUIT
Begin DoDot:1
+5 SET NAMES=$SELECT(ATT="document":"id^localTitle^nationalTitle^vuid",ATT="provider":"code^name^"_$$PROVTAGS^VPRD,1:"code^name")_"^Z"
+6 ;multiples
IF $ORDER(PROC(ATT,0))
Begin DoDot:2
+7 DO ADD("<"_ATT_"s>")
+8 SET I=0
FOR
SET I=$ORDER(PROC(ATT,I))
if I<1
QUIT
Begin DoDot:3
+9 SET X=$GET(PROC(ATT,I))
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
