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

HMPDMC.m

Go to the documentation of this file. 
  1. 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
  1.  ;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ; DE2818, ^SC and ^VA(200) references supprted
  1.  ; External Reference ~ DBIA#
  1.  ; ^SC ~ 10040
  1.  ; ^TIU(8925.1 ~ 5677
  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.  Q
  1.  ; ------------ Get procedures from VistA ------------
  1.  ;
  1. EN(DFN,BEG,END,MAX,ID) ; -- find patient's procedures
  1.  N HMPITM,RES,HMPN,HMPX,RTN,DATE,CONS,TIUN,X0,DA,GBL,X,Y,%DT,HMPT,LT,NT,LOC
  1.  S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
  1.  S DFN=+$G(DFN) I '(DFN>0) D LOGDPT^HMPLOG(DFN) Q  ;DE4496 19 August 2016
  1.  ;
  1.  ; get one procedure
  1.  I $G(ID) D  ;reset dates for MDPS1
  1.  . N HMPMC,IEN,FILE
  1.  . S IEN=+ID,FILE=+$P(ID,"(",2) Q:FILE=702
  1.  . D MEDLKUP^MCARUTL3(.HMPMC,FILE,IEN)
  1.  . S X=$P(HMPMC,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 HMPN=0 F  S HMPN=$O(^TMP("MDHSP",$J,HMPN)) Q:HMPN<1  S HMPX=$G(^(HMPN)) D
  1.  . I $G(ID),ID'=+$P(HMPX,U,2) Q              ;update one procedure
  1.  . S RTN=$P(HMPX,U,3,4) Q:RTN="PRPRO^MDPS4"  ;skip non-CP items
  1.  . S X=$P(HMPX,U,6),%DT="TX" D ^%DT S:Y>0 DATE=Y
  1.  . S GBL=+$P(HMPX,U,2)_";"_$S(RTN="PR702^MDPS1":"MDD(702,",1:$$ROOT(DFN,$P(HMPX,U,11),DATE))
  1.  . Q:'GBL  I $G(ID),ID'=GBL Q                ;unknown, or not requested
  1.  . ;
  1.  . S CONS=+$P(HMPX,U,13) D:CONS DOCLIST^GMRCGUIB(.HMPD,CONS) S X0=$G(HMPD(0)) ;=^GMR(123,ID,0)
  1.  . S TIUN=+$P(HMPX,U,14) S:TIUN TIUN=TIUN_U_$$RESOLVE^TIUSRVLO(TIUN)
  1. A . ;
  1.  . K HMPITM S HMPITM("id")=GBL,HMPITM("name")=$P(HMPX,U)
  1.  . S HMPITM("dateTime")=DATE,HMPITM("category")="CP"
  1.  . S X=$P(HMPX,U,7) S:$L(X) HMPITM("interpretation")=X
  1.  . I CONS,X0 D
  1.  .. N HMPJ S HMPITM("consult")=CONS
  1.  .. S HMPITM("requested")=+X0,HMPITM("order")=+$P(X0,U,3)
  1.  .. S HMPITM("status")=$$EXTERNAL^DILFD(123,8,,$P(X0,U,12))
  1.  .. S HMPJ=0 F  S HMPJ=$O(HMPD(50,HMPJ)) Q:HMPJ<1  S X=+$G(HMPD(50,HMPJ)) D
  1.  ... K HMPT D EXTRACT^TIULQ(X,"HMPT",,.01) S LT=$G(HMPT(X,.01,"E"))
  1.  ... S NT=$$GET1^DIQ(8925.1,+$G(HMPT(X,.01,"I"))_",",1501)
  1.  ... S HMPITM("document",X)=X_U_LT_U_NT  ;ien^local^national title
  1.  ... S:$G(HMPTEXT) HMPITM("document",X,"content")=$$TEXT^HMPDTIU(X)
  1.  ... S:'TIUN TIUN=X ;get supporting fields
  1. B . ;
  1.  . I TIUN D
  1.  .. S X=$P(TIUN,U,5) S:X HMPITM("provider")=+X_U_$P(X,";",3)
  1.  .. S:$P(TIUN,U,11) HMPITM("hasImages")=1
  1.  .. K HMPT D EXTRACT^TIULQ(+TIUN,"HMPT",,".03;.05;1211",,,"I")
  1.  .. S HMPITM("encounter")=+$G(HMPT(+TIUN,.03,"I"))
  1.  .. S LOC=+$G(HMPT(+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 HMPITM("location")=LOC,HMPITM("facility")=$$FAC^HMPD(+LOC)
  1.  .. I '$D(HMPITM("status")) S X=+$G(HMPT(+TIUN,.05,"I")),HMPITM("status")=$S(X<6:"PARTIAL RESULTS",1:"COMPLETE")
  1.  .. I '$G(HMPITM("document",+TIUN)) D
  1.  ... K HMPT D EXTRACT^TIULQ(+TIUN,"HMPT",,.01,,,"I")
  1.  ... S NT=$$GET1^DIQ(8925.1,+$G(HMPT(+TIUN,.01,"I"))_",",1501)
  1.  ... S HMPITM("document",+TIUN)=$P(TIUN,U,1,2)_U_NT  ;ien^local^national title
  1.  ... S:$G(HMPTEXT) HMPITM("document",+TIUN,"content")=$$TEXT^HMPDTIU(+TIUN)
  1. C . ;
  1.  . ; if no consult or note/visit ...
  1.  . 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)
  1.  . I '$D(HMPITM("status")) S HMPITM("status")="COMPLETE"
  1.  . ;I DA D  ;get CPT code from #697.2
  1.  . ;. K HMPT D GETS^DIQ(697.2,DA_",","1000*",,"HMPT")
  1.  . ;. N IENS S IENS=$O(HMPT(697.21,"")) Q:IENS=""
  1.  . ;. S X=HMPT(697.21,IENS,.01),HMPITM("type")=$$CPT(X)
  1.  . ;
  1.  . D XML(.HMPITM)
  1. ENQ ;
  1.  K ^TMP("MDHSP",$J),^TMP("HMPTEXT",$J)
  1.  Q
  1.  ;
  1. ROOT(DFN,NAME,DATE) ; -- return vptr ID for procedure instance
  1.  N HMPMC,Y
  1.  D SUB^MCARUTL2(.HMPMC,DFN,NAME,DATE,DATE)
  1.  S Y=$S(+$G(HMPMC):$P($G(HMPMC(HMPMC)),U,4)_",",1:"")
  1.  Q Y
  1.  ;
  1. CPT(IEN) ; -- return code^description for CPT code, or "^" if error
  1.  N X0,HMPX,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),"HMPX") ;CPT Description
  1.  I N>0,$L($G(HMPX(1))) D
  1.  . S X=$G(HMPX(1)),I=1
  1.  . F  S I=$O(HMPX(I)) Q:I<1  Q:HMPX(I)=" "  S X=X_" "_HMPX(I)
  1.  . S $P(Y,U,2)=X
  1.  Q Y
  1.  ;
  1.  ; ------------ Get report(s) [via HMPDTIU] ------------
  1.  ;
  1. RPTS(DFN,BEG,END,MAX) ; -- find patient's medicine reports
  1.  N HMPITM,HMPN,HMPX,RTN,TIUN,CONS,HMPD,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 HMPN=0 F  S HMPN=$O(^TMP("MDHSP",$J,HMPN)) Q:HMPN<1  S HMPX=$G(^(HMPN)) D
  1.  . S RTN=$P(HMPX,U,3,4) ;Q:RTN="PRPRO^MDPS4"  ;skip non-CP items
  1.  . S TIUN=+$P(HMPX,U,14) K HMPITM
  1.  . I TIUN D EN1^HMPDTIU(TIUN,.HMPITM),XML^HMPDTIU(.HMPITM):$D(HMPITM)
  1.  . S CONS=+$P(HMPX,U,13) D:CONS DOCLIST^GMRCGUIB(.HMPD,CONS)
  1.  . S I=0 F  S I=$O(HMPD(50,I)) Q:I<1  D
  1.  .. K HMPITM S DA=+HMPD(50,I) Q:DA=TIUN
  1.  .. D EN1^HMPDTIU(DA,.HMPITM),XML^HMPDTIU(.HMPITM):$D(HMPITM)
  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(HMPX,U,6),%DT="TX" D ^%DT S:Y>0 DATE=Y
  1.  . S GBL=+$P(HMPX,U,2)_";"_$$ROOT(DFN,$P(HMPX,U,11),DATE)
  1.  . I GBL D RPT1(DFN,GBL,.HMPITM),XML^HMPDTIU(.HMPITM):$D(HMPITM)
  1.  K ^TMP("MDHSP",$J),^TMP("HMPTEXT",$J)
  1.  Q
  1.  ;
  1. RPT1(DFN,ID,RPT) ; -- return report as a TIU document
  1.  S DFN=+$G(DFN),ID=$G(ID) I '(DFN>0) D LOGDPT^HMPLOG(DFN) Q  ;DE4496 19 August 2016
  1.  Q:'$L(ID)
  1.  N HMPY,HMPFN,X
  1.  S HMPFN=+$P(ID,"(",2)
  1.  D MEDLKUP^MCARUTL3(.HMPY,HMPFN,+ID)
  1.  S RPT("id")=ID,RPT("referenceDateTime")=$P(HMPY,U,6)
  1.  S RPT("localTitle")=$P(HMPY,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(HMPFN,+ID_",",1506)
  1.  S RPT("status")=$S($L(X):X,1:"COMPLETED")
  1.  S X=+$$GET1^DIQ(HMPFN,+ID_",",701,"I")
  1.  S:X RPT("clinician",1)=X_U_$P($G(^VA(200,X,0)),U)_"^A"
  1.  S X=+$$GET1^DIQ(HMPFN,+ID_",",1503,"I")
  1.  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)
  1.  ; RPT("encounter")=$$GET1^DIQ(HMPFN,+ID_",",900,"I")
  1.  S RPT("facility")=$$FAC^HMPD
  1.  S:$G(HMPTEXT) RPT("content")=$$TEXT(DFN,ID,$P(HMPY,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 ;de3944
  1.  S MCARGDA=+$G(ID),MCPRO=NAME,MDALL=1 D PR690^MDPS1
  1.  K ^TMP("HMPTEXT",$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("HMPTEXT",$J,ID,I)=X
  1.  S Y=$NA(^TMP("HMPTEXT",$J,ID))
  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 HMPTOTL=$G(HMPTOTL)+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^Z",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^HMPD(@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^HMPD(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^HMPD($P(X,U,P))_"' "
  1.  Q STR
  1.  ;
  1. ADD(X) ; Add a line @HMP@(n)=X
  1.  S HMPI=$G(HMPI)+1
  1.  S @HMP@(HMPI)=X
  1.  Q