HMPDMC ;SLC/MKB,ASMR/RRB,BL,CPC - Clinical Procedures (Medicine);Aug 29, 2016 20:06:27
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2,3**;Sep 01, 2011;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
; DE2818, ^SC and ^VA(200) references supprted
; External Reference ~ DBIA#
; ^SC ~ 10040
; ^TIU(8925.1 ~ 5677
; ^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
Q
; ------------ Get procedures from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's procedures
N HMPITM,RES,HMPN,HMPX,RTN,DATE,CONS,TIUN,X0,DA,GBL,X,Y,%DT,HMPT,LT,NT,LOC
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
S DFN=+$G(DFN) I '(DFN>0) D LOGDPT^HMPLOG(DFN) Q ;DE4496 19 August 2016
;
; get one procedure
I $G(ID) D ;reset dates for MDPS1
. N HMPMC,IEN,FILE
. S IEN=+ID,FILE=+$P(ID,"(",2) Q:FILE=702
. D MEDLKUP^MCARUTL3(.HMPMC,FILE,IEN)
. S X=$P(HMPMC,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 HMPN=0 F S HMPN=$O(^TMP("MDHSP",$J,HMPN)) Q:HMPN<1 S HMPX=$G(^(HMPN)) D
. I $G(ID),ID'=+$P(HMPX,U,2) Q ;update one procedure
. S RTN=$P(HMPX,U,3,4) Q:RTN="PRPRO^MDPS4" ;skip non-CP items
. S X=$P(HMPX,U,6),%DT="TX" D ^%DT S:Y>0 DATE=Y
. S GBL=+$P(HMPX,U,2)_";"_$S(RTN="PR702^MDPS1":"MDD(702,",1:$$ROOT(DFN,$P(HMPX,U,11),DATE))
. Q:'GBL I $G(ID),ID'=GBL Q ;unknown, or not requested
. ;
. S CONS=+$P(HMPX,U,13) D:CONS DOCLIST^GMRCGUIB(.HMPD,CONS) S X0=$G(HMPD(0)) ;=^GMR(123,ID,0)
. S TIUN=+$P(HMPX,U,14) S:TIUN TIUN=TIUN_U_$$RESOLVE^TIUSRVLO(TIUN)
A . ;
. K HMPITM S HMPITM("id")=GBL,HMPITM("name")=$P(HMPX,U)
. S HMPITM("dateTime")=DATE,HMPITM("category")="CP"
. S X=$P(HMPX,U,7) S:$L(X) HMPITM("interpretation")=X
. I CONS,X0 D
.. N HMPJ S HMPITM("consult")=CONS
.. S HMPITM("requested")=+X0,HMPITM("order")=+$P(X0,U,3)
.. S HMPITM("status")=$$EXTERNAL^DILFD(123,8,,$P(X0,U,12))
.. S HMPJ=0 F S HMPJ=$O(HMPD(50,HMPJ)) Q:HMPJ<1 S X=+$G(HMPD(50,HMPJ)) D
... K HMPT D EXTRACT^TIULQ(X,"HMPT",,.01) S LT=$G(HMPT(X,.01,"E"))
... S NT=$$GET1^DIQ(8925.1,+$G(HMPT(X,.01,"I"))_",",1501)
... S HMPITM("document",X)=X_U_LT_U_NT ;ien^local^national title
... S:$G(HMPTEXT) HMPITM("document",X,"content")=$$TEXT^HMPDTIU(X)
... S:'TIUN TIUN=X ;get supporting fields
B . ;
. I TIUN D
.. S X=$P(TIUN,U,5) S:X HMPITM("provider")=+X_U_$P(X,";",3)
.. S:$P(TIUN,U,11) HMPITM("hasImages")=1
.. K HMPT D EXTRACT^TIULQ(+TIUN,"HMPT",,".03;.05;1211",,,"I")
.. S HMPITM("encounter")=+$G(HMPT(+TIUN,.03,"I"))
.. S LOC=+$G(HMPT(+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 HMPITM("location")=LOC,HMPITM("facility")=$$FAC^HMPD(+LOC)
.. I '$D(HMPITM("status")) S X=+$G(HMPT(+TIUN,.05,"I")),HMPITM("status")=$S(X<6:"PARTIAL RESULTS",1:"COMPLETE")
.. I '$G(HMPITM("document",+TIUN)) D
... K HMPT D EXTRACT^TIULQ(+TIUN,"HMPT",,.01,,,"I")
... S NT=$$GET1^DIQ(8925.1,+$G(HMPT(+TIUN,.01,"I"))_",",1501)
... S HMPITM("document",+TIUN)=$P(TIUN,U,1,2)_U_NT ;ien^local^national title
... S:$G(HMPTEXT) HMPITM("document",+TIUN,"content")=$$TEXT^HMPDTIU(+TIUN)
C . ;
. ; if no consult or note/visit ...
. I '$D(HMPITM("facility")) S X=$P(X0,U,21),HMPITM("facility")=$S(X:$$STA^XUAF4(X)_U_$P($$NS^XUAF4(X),U),1:$$FAC^HMPD)
. I '$D(HMPITM("status")) S HMPITM("status")="COMPLETE"
. ;I DA D ;get CPT code from #697.2
. ;. K HMPT D GETS^DIQ(697.2,DA_",","1000*",,"HMPT")
. ;. N IENS S IENS=$O(HMPT(697.21,"")) Q:IENS=""
. ;. S X=HMPT(697.21,IENS,.01),HMPITM("type")=$$CPT(X)
. ;
. D XML(.HMPITM)
ENQ ;
K ^TMP("MDHSP",$J),^TMP("HMPTEXT",$J)
Q
;
ROOT(DFN,NAME,DATE) ; -- return vptr ID for procedure instance
N HMPMC,Y
D SUB^MCARUTL2(.HMPMC,DFN,NAME,DATE,DATE)
S Y=$S(+$G(HMPMC):$P($G(HMPMC(HMPMC)),U,4)_",",1:"")
Q Y
;
CPT(IEN) ; -- return code^description for CPT code, or "^" if error
N X0,HMPX,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),"HMPX") ;CPT Description
I N>0,$L($G(HMPX(1))) D
. S X=$G(HMPX(1)),I=1
. F S I=$O(HMPX(I)) Q:I<1 Q:HMPX(I)=" " S X=X_" "_HMPX(I)
. S $P(Y,U,2)=X
Q Y
;
; ------------ Get report(s) [via HMPDTIU] ------------
;
RPTS(DFN,BEG,END,MAX) ; -- find patient's medicine reports
N HMPITM,HMPN,HMPX,RTN,TIUN,CONS,HMPD,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 HMPN=0 F S HMPN=$O(^TMP("MDHSP",$J,HMPN)) Q:HMPN<1 S HMPX=$G(^(HMPN)) D
. S RTN=$P(HMPX,U,3,4) ;Q:RTN="PRPRO^MDPS4" ;skip non-CP items
. S TIUN=+$P(HMPX,U,14) K HMPITM
. I TIUN D EN1^HMPDTIU(TIUN,.HMPITM),XML^HMPDTIU(.HMPITM):$D(HMPITM)
. S CONS=+$P(HMPX,U,13) D:CONS DOCLIST^GMRCGUIB(.HMPD,CONS)
. S I=0 F S I=$O(HMPD(50,I)) Q:I<1 D
.. K HMPITM S DA=+HMPD(50,I) Q:DA=TIUN
.. D EN1^HMPDTIU(DA,.HMPITM),XML^HMPDTIU(.HMPITM):$D(HMPITM)
. 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(HMPX,U,6),%DT="TX" D ^%DT S:Y>0 DATE=Y
. S GBL=+$P(HMPX,U,2)_";"_$$ROOT(DFN,$P(HMPX,U,11),DATE)
. I GBL D RPT1(DFN,GBL,.HMPITM),XML^HMPDTIU(.HMPITM):$D(HMPITM)
K ^TMP("MDHSP",$J),^TMP("HMPTEXT",$J)
Q
;
RPT1(DFN,ID,RPT) ; -- return report as a TIU document
S DFN=+$G(DFN),ID=$G(ID) I '(DFN>0) D LOGDPT^HMPLOG(DFN) Q ;DE4496 19 August 2016
Q:'$L(ID)
N HMPY,HMPFN,X
S HMPFN=+$P(ID,"(",2)
D MEDLKUP^MCARUTL3(.HMPY,HMPFN,+ID)
S RPT("id")=ID,RPT("referenceDateTime")=$P(HMPY,U,6)
S RPT("localTitle")=$P(HMPY,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(HMPFN,+ID_",",1506)
S RPT("status")=$S($L(X):X,1:"COMPLETED")
S X=+$$GET1^DIQ(HMPFN,+ID_",",701,"I")
S:X RPT("clinician",1)=X_U_$P($G(^VA(200,X,0)),U)_"^A"
S X=+$$GET1^DIQ(HMPFN,+ID_",",1503,"I")
S:X RPT("clinician",2)=X_U_$P($G(^VA(200,X,0)),U)_"^S^"_$$GET1^DIQ(HMPFN,+ID_",",1505,"I")_U_$$SIG^HMPDTIU(X)
; RPT("encounter")=$$GET1^DIQ(HMPFN,+ID_",",900,"I")
S RPT("facility")=$$FAC^HMPD
S:$G(HMPTEXT) RPT("content")=$$TEXT(DFN,ID,$P(HMPY,U,9))
Q
;
TEXT(DFN,ID,NAME) ; -- Get report text, return temp array name
N MCARGDA,MCPRO,MDALL,I,X,Y ;de3944
S MCARGDA=+$G(ID),MCPRO=NAME,MDALL=1 D PR690^MDPS1
K ^TMP("HMPTEXT",$J,ID)
S I=0 F S I=$O(^TMP("MDPTXT",$J,MCARGDA,MCPRO,I)) Q:I<1 S X=$G(^(I,0)),^TMP("HMPTEXT",$J,ID,I)=X
S Y=$NA(^TMP("HMPTEXT",$J,ID))
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 HMPTOTL=$G(HMPTOTL)+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^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)),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^HMPD(@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^HMPD(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^HMPD($P(X,U,P))_"' "
Q STR
;
ADD(X) ; Add a line @HMP@(n)=X
S HMPI=$G(HMPI)+1
S @HMP@(HMPI)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDMC 8438 printed Apr 09, 2024@20:58:38 Page 2
HMPDMC ;SLC/MKB,ASMR/RRB,BL,CPC - Clinical Procedures (Medicine);Aug 29, 2016 20:06:27
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2,3**;Sep 01, 2011;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; DE2818, ^SC and ^VA(200) references supprted
+5 ; External Reference ~ DBIA#
+6 ; ^SC ~ 10040
+7 ; ^TIU(8925.1 ~ 5677
+8 ; ^VA(200 ~ 10060
+9 ; %DT ~ 10003
+10 ; DILFD ~ 2055
+11 ; DIQ ~ 2056
+12 ; GMRCGUIB ~ 2980
+13 ; ICPTCOD ~ 1995
+14 ; MCARUTL2 ~ 3279
+15 ; MCARUTL3 ~ 3280
+16 ; MDPS1,^TMP("MDHSP"/"MDPTXT" ~ 4230
+17 ; TIULQ ~ 2693
+18 ; TIUSRVLO ~ 2834
+19 ; XUAF4 ~ 2171
+20 QUIT
+21 ; ------------ Get procedures from VistA ------------
+22 ;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's procedures
+1 NEW HMPITM,RES,HMPN,HMPX,RTN,DATE,CONS,TIUN,X0,DA,GBL,X,Y,%DT,HMPT,LT,NT,LOC
+2 SET BEG=$GET(BEG,1410101)
SET END=$GET(END,4141015)
SET MAX=$GET(MAX,9999)
+3 ;DE4496 19 August 2016
SET DFN=+$GET(DFN)
IF '(DFN>0)
DO LOGDPT^HMPLOG(DFN)
QUIT
+4 ;
+5 ; get one procedure
+6 ;reset dates for MDPS1
IF $GET(ID)
Begin DoDot:1
+7 NEW HMPMC,IEN,FILE
+8 SET IEN=+ID
SET FILE=+$PIECE(ID,"(",2)
if FILE=702
QUIT
+9 DO MEDLKUP^MCARUTL3(.HMPMC,FILE,IEN)
+10 SET X=$PIECE(HMPMC,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 HMPN=0
FOR
SET HMPN=$ORDER(^TMP("MDHSP",$JOB,HMPN))
if HMPN<1
QUIT
SET HMPX=$GET(^(HMPN))
Begin DoDot:1
+16 ;update one procedure
IF $GET(ID)
IF ID'=+$PIECE(HMPX,U,2)
QUIT
+17 ;skip non-CP items
SET RTN=$PIECE(HMPX,U,3,4)
if RTN="PRPRO^MDPS4"
QUIT
+18 SET X=$PIECE(HMPX,U,6)
SET %DT="TX"
DO ^%DT
if Y>0
SET DATE=Y
+19 SET GBL=+$PIECE(HMPX,U,2)_";"_$SELECT(RTN="PR702^MDPS1":"MDD(702,",1:$$ROOT(DFN,$PIECE(HMPX,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(HMPX,U,13)
if CONS
DO DOCLIST^GMRCGUIB(.HMPD,CONS)
SET X0=$GET(HMPD(0))
+23 SET TIUN=+$PIECE(HMPX,U,14)
if TIUN
SET TIUN=TIUN_U_$$RESOLVE^TIUSRVLO(TIUN)
A ;
+1 KILL HMPITM
SET HMPITM("id")=GBL
SET HMPITM("name")=$PIECE(HMPX,U)
+2 SET HMPITM("dateTime")=DATE
SET HMPITM("category")="CP"
+3 SET X=$PIECE(HMPX,U,7)
if $LENGTH(X)
SET HMPITM("interpretation")=X
+4 IF CONS
IF X0
Begin DoDot:2
+5 NEW HMPJ
SET HMPITM("consult")=CONS
+6 SET HMPITM("requested")=+X0
SET HMPITM("order")=+$PIECE(X0,U,3)
+7 SET HMPITM("status")=$$EXTERNAL^DILFD(123,8,,$PIECE(X0,U,12))
+8 SET HMPJ=0
FOR
SET HMPJ=$ORDER(HMPD(50,HMPJ))
if HMPJ<1
QUIT
SET X=+$GET(HMPD(50,HMPJ))
Begin DoDot:3
+9 KILL HMPT
DO EXTRACT^TIULQ(X,"HMPT",,.01)
SET LT=$GET(HMPT(X,.01,"E"))
+10 SET NT=$$GET1^DIQ(8925.1,+$GET(HMPT(X,.01,"I"))_",",1501)
+11 ;ien^local^national title
SET HMPITM("document",X)=X_U_LT_U_NT
+12 if $GET(HMPTEXT)
SET HMPITM("document",X,"content")=$$TEXT^HMPDTIU(X)
+13 ;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 HMPITM("provider")=+X_U_$PIECE(X,";",3)
+3 if $PIECE(TIUN,U,11)
SET HMPITM("hasImages")=1
+4 KILL HMPT
DO EXTRACT^TIULQ(+TIUN,"HMPT",,".03;.05;1211",,,"I")
+5 SET HMPITM("encounter")=+$GET(HMPT(+TIUN,.03,"I"))
+6 SET LOC=+$GET(HMPT(+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 HMPITM("location")=LOC
SET HMPITM("facility")=$$FAC^HMPD(+LOC)
+9 IF '$DATA(HMPITM("status"))
SET X=+$GET(HMPT(+TIUN,.05,"I"))
SET HMPITM("status")=$SELECT(X<6:"PARTIAL RESULTS",1:"COMPLETE")
+10 IF '$GET(HMPITM("document",+TIUN))
Begin DoDot:3
+11 KILL HMPT
DO EXTRACT^TIULQ(+TIUN,"HMPT",,.01,,,"I")
+12 SET NT=$$GET1^DIQ(8925.1,+$GET(HMPT(+TIUN,.01,"I"))_",",1501)
+13 ;ien^local^national title
SET HMPITM("document",+TIUN)=$PIECE(TIUN,U,1,2)_U_NT
+14 if $GET(HMPTEXT)
SET HMPITM("document",+TIUN,"content")=$$TEXT^HMPDTIU(+TIUN)
End DoDot:3
End DoDot:2
C ;
+1 ; if no consult or note/visit ...
+2 IF '$DATA(HMPITM("facility"))
SET X=$PIECE(X0,U,21)
SET HMPITM("facility")=$SELECT(X:$$STA^XUAF4(X)_U_$PIECE($$NS^XUAF4(X),U),1:$$FAC^HMPD)
+3 IF '$DATA(HMPITM("status"))
SET HMPITM("status")="COMPLETE"
+4 ;I DA D ;get CPT code from #697.2
+5 ;. K HMPT D GETS^DIQ(697.2,DA_",","1000*",,"HMPT")
+6 ;. N IENS S IENS=$O(HMPT(697.21,"")) Q:IENS=""
+7 ;. S X=HMPT(697.21,IENS,.01),HMPITM("type")=$$CPT(X)
+8 ;
+9 DO XML(.HMPITM)
End DoDot:1
ENQ ;
+1 KILL ^TMP("MDHSP",$JOB),^TMP("HMPTEXT",$JOB)
+2 QUIT
+3 ;
ROOT(DFN,NAME,DATE) ; -- return vptr ID for procedure instance
+1 NEW HMPMC,Y
+2 DO SUB^MCARUTL2(.HMPMC,DFN,NAME,DATE,DATE)
+3 SET Y=$SELECT(+$GET(HMPMC):$PIECE($GET(HMPMC(HMPMC)),U,4)_",",1:"")
+4 QUIT Y
+5 ;
CPT(IEN) ; -- return code^description for CPT code, or "^" if error
+1 NEW X0,HMPX,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),"HMPX")
+5 IF N>0
IF $LENGTH($GET(HMPX(1)))
Begin DoDot:1
+6 SET X=$GET(HMPX(1))
SET I=1
+7 FOR
SET I=$ORDER(HMPX(I))
if I<1
QUIT
if HMPX(I)=" "
QUIT
SET X=X_" "_HMPX(I)
+8 SET $PIECE(Y,U,2)=X
End DoDot:1
+9 QUIT Y
+10 ;
+11 ; ------------ Get report(s) [via HMPDTIU] ------------
+12 ;
RPTS(DFN,BEG,END,MAX) ; -- find patient's medicine reports
+1 NEW HMPITM,HMPN,HMPX,RTN,TIUN,CONS,HMPD,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 HMPN=0
FOR
SET HMPN=$ORDER(^TMP("MDHSP",$JOB,HMPN))
if HMPN<1
QUIT
SET HMPX=$GET(^(HMPN))
Begin DoDot:1
+6 ;Q:RTN="PRPRO^MDPS4" ;skip non-CP items
SET RTN=$PIECE(HMPX,U,3,4)
+7 SET TIUN=+$PIECE(HMPX,U,14)
KILL HMPITM
+8 IF TIUN
DO EN1^HMPDTIU(TIUN,.HMPITM)
if $DATA(HMPITM)
DO XML^HMPDTIU(.HMPITM)
+9 SET CONS=+$PIECE(HMPX,U,13)
if CONS
DO DOCLIST^GMRCGUIB(.HMPD,CONS)
+10 SET I=0
FOR
SET I=$ORDER(HMPD(50,I))
if I<1
QUIT
Begin DoDot:2
+11 KILL HMPITM
SET DA=+HMPD(50,I)
if DA=TIUN
QUIT
+12 DO EN1^HMPDTIU(DA,.HMPITM)
if $DATA(HMPITM)
DO XML^HMPDTIU(.HMPITM)
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(HMPX,U,6)
SET %DT="TX"
DO ^%DT
if Y>0
SET DATE=Y
+18 SET GBL=+$PIECE(HMPX,U,2)_";"_$$ROOT(DFN,$PIECE(HMPX,U,11),DATE)
+19 IF GBL
DO RPT1(DFN,GBL,.HMPITM)
if $DATA(HMPITM)
DO XML^HMPDTIU(.HMPITM)
End DoDot:1
+20 KILL ^TMP("MDHSP",$JOB),^TMP("HMPTEXT",$JOB)
+21 QUIT
+22 ;
RPT1(DFN,ID,RPT) ; -- return report as a TIU document
+1 ;DE4496 19 August 2016
SET DFN=+$GET(DFN)
SET ID=$GET(ID)
IF '(DFN>0)
DO LOGDPT^HMPLOG(DFN)
QUIT
+2 if '$LENGTH(ID)
QUIT
+3 NEW HMPY,HMPFN,X
+4 SET HMPFN=+$PIECE(ID,"(",2)
+5 DO MEDLKUP^MCARUTL3(.HMPY,HMPFN,+ID)
+6 SET RPT("id")=ID
SET RPT("referenceDateTime")=$PIECE(HMPY,U,6)
+7 SET RPT("localTitle")=$PIECE(HMPY,U,9)
SET RPT("category")="CP"
+8 SET RPT("documentClass")="CLINICAL PROCEDURES"
+9 SET RPT("nationalTitle")="4696566^PROCEDURE REPORT"
+10 SET RPT("nationalTitleService")="4696471^PROCEDURE"
+11 SET RPT("nationalTitleType")="4696123^REPORT"
+12 if $GET(FILTER("loinc"))
SET RPT("loinc")=$PIECE(FILTER("loinc"),U)
+13 SET X=$$GET1^DIQ(HMPFN,+ID_",",1506)
+14 SET RPT("status")=$SELECT($LENGTH(X):X,1:"COMPLETED")
+15 SET X=+$$GET1^DIQ(HMPFN,+ID_",",701,"I")
+16 if X
SET RPT("clinician",1)=X_U_$PIECE($GET(^VA(200,X,0)),U)_"^A"
+17 SET X=+$$GET1^DIQ(HMPFN,+ID_",",1503,"I")
+18 if X
SET RPT("clinician",2)=X_U_$PIECE($GET(^VA(200,X,0)),U)_"^S^"_$$GET1^DIQ(HMPFN,+ID_",",1505,"I")_U_$$SIG^HMPDTIU(X)
+19 ; RPT("encounter")=$$GET1^DIQ(HMPFN,+ID_",",900,"I")
+20 SET RPT("facility")=$$FAC^HMPD
+21 if $GET(HMPTEXT)
SET RPT("content")=$$TEXT(DFN,ID,$PIECE(HMPY,U,9))
+22 QUIT
+23 ;
TEXT(DFN,ID,NAME) ; -- Get report text, return temp array name
+1 ;de3944
NEW MCARGDA,MCPRO,MDALL,I,X,Y
+2 SET MCARGDA=+$GET(ID)
SET MCPRO=NAME
SET MDALL=1
DO PR690^MDPS1
+3 KILL ^TMP("HMPTEXT",$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("HMPTEXT",$JOB,ID,I)=X
+5 SET Y=$NAME(^TMP("HMPTEXT",$JOB,ID))
+6 QUIT Y
+7 ;
+8 ; ------------ Return data to middle tier ------------
+9 ;
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 HMPTOTL=$GET(HMPTOTL)+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^Z",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^HMPD(@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^HMPD(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^HMPD($PIECE(X,U,P))_"' "
+3 QUIT STR
+4 ;
ADD(X) ; Add a line @HMP@(n)=X
+1 SET HMPI=$GET(HMPI)+1
+2 SET @HMP@(HMPI)=X
+3 QUIT
