- 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 Jan 18, 2025@02:54:22 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