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

VPRDMC.m

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