- 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 Feb 19, 2025@00:11:17 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