HMPDGMPL ;SLC/MKB,ASMR/RRB,BL - Problem extract;Aug 29, 2016 20:06:27
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**3**;Sep 01, 2011;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^AUPNPROB 5703
; ^DPT 10035
; ^VA(200 10060
; ^WV(790.05 5772
; %DT 10003
; DIQ 2056
; GMPLUTL2 2741
; SDUTL3 1252
; XLFDT 10103
; XUAF4 2171
Q
; ------------ Get problems from VistA ------------
;
EN(DFN,BEG,END,MAX,IFN) ; -- find patient's problems
N HMPSTS,HMPPROB,HMPN,HMPITM,HMPCNT,X
;
; get one problem
I $G(IFN)="WV" D WV(.HMPITM,1),XML(.HMPITM):$D(HMPITM) Q
I $G(IFN) D EN1(IFN,.HMPITM),XML(.HMPITM) Q
;
; get all patient problems
S DFN=+$G(DFN) I '(DFN>0) D LOGDPT^HMPLOG(DFN) Q ;DE4496, 19 August 2016
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999),HMPCNT=0
S HMPSTS=$G(FILTER("status")) ;default = all problems
D LIST^GMPLUTL2(.HMPPROB,DFN,HMPSTS)
S HMPN=0 F S HMPN=$O(HMPPROB(HMPN)) Q:(HMPN<1)!(HMPCNT'<MAX) D
. S X=$P(HMPPROB(HMPN),U,5) I X,(X<BEG)!(X>END) Q ;onset
. S X=+HMPPROB(HMPN) K HMPITM ;ien
. D EN1(X,.HMPITM),XML(.HMPITM)
. S HMPCNT=HMPCNT+1
I $P($G(^DPT(DFN,0)),U,2)="F" D WV(.HMPITM),XML(.HMPITM):$D(HMPITM) ;ICR 10035 DE2818 ASF 11/2/15
Q
;
EN1(ID,PROB) ; -- return a problem in PROB("attribute")=value
N HMPL,X,I,J K PROB
S ID=+$G(ID) Q:ID<1 ;invalid ien
D DETAIL^GMPLUTL2(ID,.HMPL) Q:'$D(HMPL) ;doesn't exist
S PROB("id")=ID ;,PROB("lexiconID")=+X1 ;SNOMED?
S PROB("name")=$G(HMPL("NARRATIVE"))
S X=$G(HMPL("MODIFIED")) S:$L(X) PROB("updated")=$$DATE(X)
S PROB("icd")=$G(HMPL("DIAGNOSIS"))
S X=$G(HMPL("STATUS")) S:$L(X) PROB("status")=$E(X)_U_X
S X=$G(HMPL("HISTORY")) S:$L(X) PROB("history")=$E(X)_U_X
S X=$G(HMPL("PRIORITY")) S:$L(X) PROB("acuity")=$E(X)_U_X
S X=$G(HMPL("ONSET")) S:$L(X) PROB("onset")=$$DATE(X)
S X=$$GET1^DIQ(9000011,ID_",",1.07,"I") S:X PROB("resolved")=X
S X=$P($G(HMPL("ENTERED")),U) S:$L(X) PROB("entered")=$$DATE(X)
S X=$$GET1^DIQ(9000011,ID_",",1.02,"I")
S:X="P" PROB("unverified")=0,PROB("removed")=0
S:X="T" PROB("unverified")=1,PROB("removed")=0
S:X="H" PROB("unverified")=0,PROB("removed")=1
S X=$G(HMPL("SC")),X=$S(X="YES":1,X="NO":0,1:"")
S:$L(X) PROB("sc")=X I $G(HMPL("EXPOSURE")) D ;ao^rad^pgulf^hnc^mst^cv
. S I=0 F S I=$O(HMPL("EXPOSURE",I)) Q:I<1 D
.. S X=$G(HMPL("EXPOSURE",I))
.. S PROB("exposure",I)=$$EXP(X)
S X=$G(HMPL("PROVIDER")) S:$L(X) PROB("provider")=$$GET1^DIQ(9000011,ID_",",1.05,"I")_U_X
S X=$$GET1^DIQ(9000011,ID_",",1.06) S:$L(X) PROB("service")=X
S X=$G(HMPL("CLINIC")) S:$L(X) PROB("location")=X
S X=+$$GET1^DIQ(9000011,ID_",",.06,"I")
S:X PROB("facility")=$$STA^XUAF4(X)_U_$P($$NS^XUAF4(X),U)
I 'X S PROB("facility")=$$FAC^HMPD ;local stn#^name
CMT ; comments
Q:'$G(HMPL("COMMENT"))
S I=0 F S I=$O(HMPL("COMMENT",I)) Q:I<1 D
. S X=$G(HMPL("COMMENT",I))
. S PROB("comment",I)=$$DATE($P(X,U))_U_$P(X,U,2,3)
. ; = date ^ name of author ^ text
Q
;
WV(PROB,UPD) ; -- return a pregnancy log entry in PROB("attribute")=value
N I,X0,Y K PROB
S I=$O(^WV(790.05,"C",DFN,""),-1) Q:'I ;last entry ICR 5772 DE2818 ASF 11/23/15
S X0=$G(^WV(790.05,I,0)),Y=0
; status=YES, future due date (allow past 14 days)
I $P(X0,U,3),$P(X0,U,4)'<$$FMADD^XLFDT(DT,-14) S Y=1
I 'Y,'$G(UPD) Q
; continue if pregnant, or update requested
S PROB("id")="WV",PROB("entered")=+X0
S PROB("name")="Pregnancy",PROB("icd")="V22.2"
; PROB("problemType")=64572001 ;HITSP/Condition
S PROB("status")=$S(Y:"A^ACTIVE",1:"I^INACTIVE")
S PROB("resolved")=$P(X0,U,4) ;due date
S PROB("provider")=$$OUTPTPR^SDUTL3(DFN) ;primary care
S PROB("facility")=$$FAC^HMPD
Q
;
DATE(X) ; -- Return internal form of date X
N %DT,Y
S %DT="" D ^%DT S:Y<1 Y=X
Q Y
;
VA200(X) ; -- Return ien of New Person X
N Y S Y=$S($L($G(X)):+$O(^VA(200,"B",X,0)),1:"") ;ICR 10060 DE2818 ASF 11/23/15
Q Y
;
EXP(X) ; -- Return code for exposure name X
N Y S Y="",X=$E($G(X))
I X="A" S Y="AO" ;agent orange
I X="R" S Y="IR" ;ionizing radiation
I X="E" S Y="PG" ;persian gulf
I X="H" S Y="HNC" ;head/neck cancer
I X="M" S Y="MST" ;military sexual trauma
I X="C" S Y="CV" ;combat vet
I X="S" S Y="SHAD"
Q Y
;
; ------------ Return data to middle tier ------------
;
XML(PROB) ; -- Return patient problem as XML in @HMP@(I)
N ATT,I,X,Y,P,TAG
D ADD("<problem>") S HMPTOTL=$G(HMPTOTL)+1
S ATT="" F S ATT=$O(PROB(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
. I ATT="exposure" D S Y="" Q
.. S Y="<exposures>" D ADD(Y)
.. S I=0 F S I=$O(PROB(ATT,I)) Q:I<1 S X=$G(PROB(ATT,I)) S:$L(X) Y="<exposure value='"_X_"' />" D ADD(Y)
.. D ADD("</exposures>")
. I ATT="comment" D S Y="" Q
.. D ADD("<comments>")
.. S I=0 F S I=$O(PROB(ATT,I)) Q:I<1 S X=$G(PROB(ATT,I)) D
... S Y="<comment id='"_I
... S:$L($P(X,U,1)) Y=Y_"' entered='"_$P(X,U)
... S:$L($P(X,U,2)) Y=Y_"' enteredBy='"_$$ESC^HMPD($P(X,U,2))
... S:$L($P(X,U,3)) Y=Y_"' commentText='"_$$ESC^HMPD($P(X,U,3))
... S Y=Y_"' />" D ADD(Y)
.. D ADD("</comments>")
. S X=$G(PROB(ATT)),Y="" Q:'$L(X)
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^HMPD(X)_"' />" Q
. I $L(X)>1 D S Y=""
.. S Y="<"_ATT_" "
.. F P=1:1 S TAG=$P("code^name^Z",U,P) Q:TAG="Z" I $L($P(X,U,P)) S Y=Y_TAG_"='"_$$ESC^HMPD($P(X,U,P))_"' "
.. S Y=Y_"/>" D ADD(Y)
D ADD("</problem>")
Q
;
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[HHMPDGMPL 5803 printed Oct 16, 2024@17:53:50 Page 2
HMPDGMPL ;SLC/MKB,ASMR/RRB,BL - Problem extract;Aug 29, 2016 20:06:27
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**3**;Sep 01, 2011;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^AUPNPROB 5703
+7 ; ^DPT 10035
+8 ; ^VA(200 10060
+9 ; ^WV(790.05 5772
+10 ; %DT 10003
+11 ; DIQ 2056
+12 ; GMPLUTL2 2741
+13 ; SDUTL3 1252
+14 ; XLFDT 10103
+15 ; XUAF4 2171
+16 QUIT
+17 ; ------------ Get problems from VistA ------------
+18 ;
EN(DFN,BEG,END,MAX,IFN) ; -- find patient's problems
+1 NEW HMPSTS,HMPPROB,HMPN,HMPITM,HMPCNT,X
+2 ;
+3 ; get one problem
+4 IF $GET(IFN)="WV"
DO WV(.HMPITM,1)
if $DATA(HMPITM)
DO XML(.HMPITM)
QUIT
+5 IF $GET(IFN)
DO EN1(IFN,.HMPITM)
DO XML(.HMPITM)
QUIT
+6 ;
+7 ; get all patient problems
+8 ;DE4496, 19 August 2016
SET DFN=+$GET(DFN)
IF '(DFN>0)
DO LOGDPT^HMPLOG(DFN)
QUIT
+9 SET BEG=$GET(BEG,1410101)
SET END=$GET(END,4141015)
SET MAX=$GET(MAX,9999)
SET HMPCNT=0
+10 ;default = all problems
SET HMPSTS=$GET(FILTER("status"))
+11 DO LIST^GMPLUTL2(.HMPPROB,DFN,HMPSTS)
+12 SET HMPN=0
FOR
SET HMPN=$ORDER(HMPPROB(HMPN))
if (HMPN<1)!(HMPCNT'<MAX)
QUIT
Begin DoDot:1
+13 ;onset
SET X=$PIECE(HMPPROB(HMPN),U,5)
IF X
IF (X<BEG)!(X>END)
QUIT
+14 ;ien
SET X=+HMPPROB(HMPN)
KILL HMPITM
+15 DO EN1(X,.HMPITM)
DO XML(.HMPITM)
+16 SET HMPCNT=HMPCNT+1
End DoDot:1
+17 ;ICR 10035 DE2818 ASF 11/2/15
IF $PIECE($GET(^DPT(DFN,0)),U,2)="F"
DO WV(.HMPITM)
if $DATA(HMPITM)
DO XML(.HMPITM)
+18 QUIT
+19 ;
EN1(ID,PROB) ; -- return a problem in PROB("attribute")=value
+1 NEW HMPL,X,I,J
KILL PROB
+2 ;invalid ien
SET ID=+$GET(ID)
if ID<1
QUIT
+3 ;doesn't exist
DO DETAIL^GMPLUTL2(ID,.HMPL)
if '$DATA(HMPL)
QUIT
+4 ;,PROB("lexiconID")=+X1 ;SNOMED?
SET PROB("id")=ID
+5 SET PROB("name")=$GET(HMPL("NARRATIVE"))
+6 SET X=$GET(HMPL("MODIFIED"))
if $LENGTH(X)
SET PROB("updated")=$$DATE(X)
+7 SET PROB("icd")=$GET(HMPL("DIAGNOSIS"))
+8 SET X=$GET(HMPL("STATUS"))
if $LENGTH(X)
SET PROB("status")=$EXTRACT(X)_U_X
+9 SET X=$GET(HMPL("HISTORY"))
if $LENGTH(X)
SET PROB("history")=$EXTRACT(X)_U_X
+10 SET X=$GET(HMPL("PRIORITY"))
if $LENGTH(X)
SET PROB("acuity")=$EXTRACT(X)_U_X
+11 SET X=$GET(HMPL("ONSET"))
if $LENGTH(X)
SET PROB("onset")=$$DATE(X)
+12 SET X=$$GET1^DIQ(9000011,ID_",",1.07,"I")
if X
SET PROB("resolved")=X
+13 SET X=$PIECE($GET(HMPL("ENTERED")),U)
if $LENGTH(X)
SET PROB("entered")=$$DATE(X)
+14 SET X=$$GET1^DIQ(9000011,ID_",",1.02,"I")
+15 if X="P"
SET PROB("unverified")=0
SET PROB("removed")=0
+16 if X="T"
SET PROB("unverified")=1
SET PROB("removed")=0
+17 if X="H"
SET PROB("unverified")=0
SET PROB("removed")=1
+18 SET X=$GET(HMPL("SC"))
SET X=$SELECT(X="YES":1,X="NO":0,1:"")
+19 ;ao^rad^pgulf^hnc^mst^cv
if $LENGTH(X)
SET PROB("sc")=X
IF $GET(HMPL("EXPOSURE"))
Begin DoDot:1
+20 SET I=0
FOR
SET I=$ORDER(HMPL("EXPOSURE",I))
if I<1
QUIT
Begin DoDot:2
+21 SET X=$GET(HMPL("EXPOSURE",I))
+22 SET PROB("exposure",I)=$$EXP(X)
End DoDot:2
End DoDot:1
+23 SET X=$GET(HMPL("PROVIDER"))
if $LENGTH(X)
SET PROB("provider")=$$GET1^DIQ(9000011,ID_",",1.05,"I")_U_X
+24 SET X=$$GET1^DIQ(9000011,ID_",",1.06)
if $LENGTH(X)
SET PROB("service")=X
+25 SET X=$GET(HMPL("CLINIC"))
if $LENGTH(X)
SET PROB("location")=X
+26 SET X=+$$GET1^DIQ(9000011,ID_",",.06,"I")
+27 if X
SET PROB("facility")=$$STA^XUAF4(X)_U_$PIECE($$NS^XUAF4(X),U)
+28 ;local stn#^name
IF 'X
SET PROB("facility")=$$FAC^HMPD
CMT ; comments
+1 if '$GET(HMPL("COMMENT"))
QUIT
+2 SET I=0
FOR
SET I=$ORDER(HMPL("COMMENT",I))
if I<1
QUIT
Begin DoDot:1
+3 SET X=$GET(HMPL("COMMENT",I))
+4 SET PROB("comment",I)=$$DATE($PIECE(X,U))_U_$PIECE(X,U,2,3)
+5 ; = date ^ name of author ^ text
End DoDot:1
+6 QUIT
+7 ;
WV(PROB,UPD) ; -- return a pregnancy log entry in PROB("attribute")=value
+1 NEW I,X0,Y
KILL PROB
+2 ;last entry ICR 5772 DE2818 ASF 11/23/15
SET I=$ORDER(^WV(790.05,"C",DFN,""),-1)
if 'I
QUIT
+3 SET X0=$GET(^WV(790.05,I,0))
SET Y=0
+4 ; status=YES, future due date (allow past 14 days)
+5 IF $PIECE(X0,U,3)
IF $PIECE(X0,U,4)'<$$FMADD^XLFDT(DT,-14)
SET Y=1
+6 IF 'Y
IF '$GET(UPD)
QUIT
+7 ; continue if pregnant, or update requested
+8 SET PROB("id")="WV"
SET PROB("entered")=+X0
+9 SET PROB("name")="Pregnancy"
SET PROB("icd")="V22.2"
+10 ; PROB("problemType")=64572001 ;HITSP/Condition
+11 SET PROB("status")=$SELECT(Y:"A^ACTIVE",1:"I^INACTIVE")
+12 ;due date
SET PROB("resolved")=$PIECE(X0,U,4)
+13 ;primary care
SET PROB("provider")=$$OUTPTPR^SDUTL3(DFN)
+14 SET PROB("facility")=$$FAC^HMPD
+15 QUIT
+16 ;
DATE(X) ; -- Return internal form of date X
+1 NEW %DT,Y
+2 SET %DT=""
DO ^%DT
if Y<1
SET Y=X
+3 QUIT Y
+4 ;
VA200(X) ; -- Return ien of New Person X
+1 ;ICR 10060 DE2818 ASF 11/23/15
NEW Y
SET Y=$SELECT($LENGTH($GET(X)):+$ORDER(^VA(200,"B",X,0)),1:"")
+2 QUIT Y
+3 ;
EXP(X) ; -- Return code for exposure name X
+1 NEW Y
SET Y=""
SET X=$EXTRACT($GET(X))
+2 ;agent orange
IF X="A"
SET Y="AO"
+3 ;ionizing radiation
IF X="R"
SET Y="IR"
+4 ;persian gulf
IF X="E"
SET Y="PG"
+5 ;head/neck cancer
IF X="H"
SET Y="HNC"
+6 ;military sexual trauma
IF X="M"
SET Y="MST"
+7 ;combat vet
IF X="C"
SET Y="CV"
+8 IF X="S"
SET Y="SHAD"
+9 QUIT Y
+10 ;
+11 ; ------------ Return data to middle tier ------------
+12 ;
XML(PROB) ; -- Return patient problem as XML in @HMP@(I)
+1 NEW ATT,I,X,Y,P,TAG
+2 DO ADD("<problem>")
SET HMPTOTL=$GET(HMPTOTL)+1
+3 SET ATT=""
FOR
SET ATT=$ORDER(PROB(ATT))
if ATT=""
QUIT
Begin DoDot:1
+4 IF ATT="exposure"
Begin DoDot:2
+5 SET Y="<exposures>"
DO ADD(Y)
+6 SET I=0
FOR
SET I=$ORDER(PROB(ATT,I))
if I<1
QUIT
SET X=$GET(PROB(ATT,I))
if $LENGTH(X)
SET Y="<exposure value='"_X_"' />"
DO ADD(Y)
+7 DO ADD("</exposures>")
End DoDot:2
SET Y=""
QUIT
+8 IF ATT="comment"
Begin DoDot:2
+9 DO ADD("<comments>")
+10 SET I=0
FOR
SET I=$ORDER(PROB(ATT,I))
if I<1
QUIT
SET X=$GET(PROB(ATT,I))
Begin DoDot:3
+11 SET Y="<comment id='"_I
+12 if $LENGTH($PIECE(X,U,1))
SET Y=Y_"' entered='"_$PIECE(X,U)
+13 if $LENGTH($PIECE(X,U,2))
SET Y=Y_"' enteredBy='"_$$ESC^HMPD($PIECE(X,U,2))
+14 if $LENGTH($PIECE(X,U,3))
SET Y=Y_"' commentText='"_$$ESC^HMPD($PIECE(X,U,3))
+15 SET Y=Y_"' />"
DO ADD(Y)
End DoDot:3
+16 DO ADD("</comments>")
End DoDot:2
SET Y=""
QUIT
+17 SET X=$GET(PROB(ATT))
SET Y=""
if '$LENGTH(X)
QUIT
+18 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^HMPD(X)_"' />"
QUIT
+19 IF $LENGTH(X)>1
Begin DoDot:2
+20 SET Y="<"_ATT_" "
+21 FOR P=1:1
SET TAG=$PIECE("code^name^Z",U,P)
if TAG="Z"
QUIT
IF $LENGTH($PIECE(X,U,P))
SET Y=Y_TAG_"='"_$$ESC^HMPD($PIECE(X,U,P))_"' "
+22 SET Y=Y_"/>"
DO ADD(Y)
End DoDot:2
SET Y=""
End DoDot:1
if $LENGTH(Y)
DO ADD(Y)
+23 DO ADD("</problem>")
+24 QUIT
+25 ;
ADD(X) ; Add a line @HMP@(n)=X
+1 SET HMPI=$GET(HMPI)+1
+2 SET @HMP@(HMPI)=X
+3 QUIT
