HMPDTIU ;SLC/MKB,ASMR/RRB - TIU extract;Nov 23, 2015 18:02:20
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**;Sep 01, 2011;Build 63
;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^SC( 10040
; ^TIU(8925.1 2321,5677
; ^TIU(8926.1 5678
; ^VA(200 10060
; DIQ 2056
; RAO7PC1 2043
; TIUCNSLT 5546
; TIUCP 3568
; TIULQ 2693
; TIULX 3058
; TIUSROI 5676
; TIUSRVLO 2834,2865
; TIUSRVR1 2944
; XLFSTR 10104
Q
; ------------ Get documents from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's documents
N HMPITM,HMPN,HMPX,HMPY,HMPCNT
S DFN=+$G(DFN) Q:$G(DFN)<1
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
;
; get one document
I $L($G(ID)),ID[";" D G ENQ
. I ID D RPT1^HMPDMC(DFN,ID,.HMPITM),XML(.HMPITM) Q ;CP
. D RPT1^HMPDLRA(DFN,ID,.HMPITM),XML(.HMPITM) Q ;Lab
I $G(ID),ID["-" D G ENQ ;Radiology
. S (BEG,END)=9999999.9999-+ID D EN1^RAO7PC1(DFN,BEG,END,"99P")
. D RPT1^HMPDRA(DFN,ID,.HMPITM),XML(.HMPITM)
. K ^TMP($J,"RAE1")
I $G(ID) D EN1(ID,.HMPITM),XML(.HMPITM):$D(HMPITM) G ENQ
;
; get all documents
N CLASS,SUBCLASS,TITLE,SERVICE,SUBJECT,NOTSUBJ,STATUS,HMPC,CLS,HMPS,CTXT
D SETUP S HMPCNT=0 ;define search criteria
I CLASS="CP" D RPTS^HMPDMC(DFN,BEG,END,MAX) Q
I CLASS="RA" D RPTS^HMPDRA(DFN,BEG,END,MAX) Q
I CLASS="LR" D RPTS^HMPDLRA(DFN,BEG,END,MAX) Q
F HMPC=1:1:$L(CLASS,U) S CLS=$P(CLASS,U,HMPC) D Q:HMPCNT'<MAX
. F HMPS=1:1:$L(STATUS,U) S CTXT=$P(STATUS,U,HMPS) D Q:HMPCNT'<MAX
.. D CONTEXT^TIUSRVLO(.HMPY,CLS,CTXT,DFN,BEG,END,,MAX,,1)
.. S HMPN=0 F S HMPN=$O(@HMPY@(HMPN)) Q:HMPN<1 D Q:HMPCNT'<MAX
... S HMPX=$G(@HMPY@(HMPN)) Q:'$$MATCH(HMPX,$G(SUBCLASS),$G(SERVICE),$G(SUBJECT),$G(NOTSUBJ))
... Q:$D(^TMP("HMPD",$J,+HMPX)) ;already included
... K HMPITM D EN1(HMPX,.HMPITM) Q:'$D(HMPITM)
... D XML(.HMPITM) S HMPCNT=HMPCNT+1
.. K @HMPY
ENQ ; end
K ^TMP("HMPTEXT",$J)
Q
;
EN1(HMPX,DOC) ; -- return a document in DOC("attribute")=value
; Expects DFN, HMPX=IEN^$$RESOLVE^TIUSRVLO(IEN)
N IEN,X,NAME,HMPTIU,ES,I,HMPY
K DOC,^TMP("HMPTEXT",$J)
S IEN=+$G(HMPX) Q:IEN<1 ;invalid ien
I +HMPX=HMPX D ;get data string, if needed
. N SHOWADD,DA S SHOWADD=1,DA=+HMPX
. S HMPX=DA_U_$$RESOLVE^TIUSRVLO(DA)
Q:"UNKNOWN"[$P($G(HMPX),U,2) ;null or invalid
S NAME=$P(HMPX,U,2) ;I $P(HMPX,U,14),$P(NAME," ")="Addendum" Q
S DOC("id")=IEN,DOC("localTitle")=NAME
D EXTRACT^TIULQ(IEN,"HMPTIU",,".01:.04;1501:1508")
S X=$$GET1^DIQ(8925,IEN_",",".01:1501","I") I X D
. N IENS,TIU,Y,FNUM
. S IENS=X_"," D GETS^DIQ(8926.1,IENS,"*","IE","TIU")
. S DOC("nationalTitle")=$G(TIU(8926.1,IENS,99.99,"E"))_U_$G(TIU(8926.1,IENS,.01,"E"))
. F I=".04^Subject^2",".05^Role^3",".06^Setting^4",".07^Service^5",".08^Type^6" D
.. S Y=+$G(TIU(8926.1,IENS,+I,"I")) Q:Y'>0
.. S FNUM="8926."_+$P(I,U,3)
.. S DOC("nationalTitle"_$P(I,U,2))=$$VUID^HMPD(Y,FNUM)_U_$G(TIU(8926.1,IENS,+I,"E"))
S:$G(FILTER("loinc")) DOC("loinc")=$P(FILTER("loinc"),U)
S X=+$G(HMPTIU(IEN,.01,"I")),X=$$CATG(X),(DOC("type"),DOC("category"))=X
S DOC("documentClass")=$S(X="LR":"LR LABORATORY REPORTS",X="SR":"SURGICAL REPORTS",X="CP":"CLINICAL PROCEDURES",X="DS":"DISCHARGE SUMMARY",1:"PROGRESS NOTES")
S DOC("referenceDateTime")=$P(HMPX,U,3)
S X=$P(HMPX,U,6) D ;S:$L(X) DOC("location")=X
. ; DE2818, ICR 10040 for ^SC, this doesn't handle duplicate entries and should be corrected
. N LOC S LOC=$S($L(X):+$O(^SC("B",X,0)),1:0)
. S DOC("facility")=$$FAC^HMPD(LOC)
S X=$P(HMPX,U,7) S:$L(X) DOC("status")=X
S:$P(HMPX,U,11) DOC("images")=+$P(HMPX,U,11)
S:$L($P(HMPX,U,12)) DOC("subject")=$P(HMPX,U,12)
; X=$S($P(HMPX,U,13)[">":"C",$P(HMPX,U,13)["<":"I",1:"") ;componentType
I $P(HMPX,U,14)>5 S DOC("parent")=$P(HMPX,U,14) ;ID notes
S DOC("encounter")=$G(HMPTIU(IEN,.03,"I"))
S:$G(HMPTEXT) DOC("content")=$$TEXT(IEN)
; providers &/or signatures
S X=$P(HMPX,U,5),I=0 S:X I=I+1,DOC("clinician",I)=+X_U_$P(X,";",3)_"^A" ;author
M ES=HMPTIU(IEN) I ES(1501,"I") D
. S I=I+1
. S DOC("clinician",I)=ES(1502,"I")_U_ES(1502,"E")_"^S^"_ES(1501,"I")_U_$$SIG(ES(1502,"I"))
I ES(1507,"I") D ; cosigner
. S I=I+1
. S DOC("clinician",I)=ES(1508,"I")_U_ES(1508,"E")_"^C^"_ES(1507,"I")_U_$$SIG(ES(1508,"I"))
Q
;
CATG(DA) ; -- Return a code for document type #8925.1 DA
N X
D ISCNSLT^TIUCNSLT(.X,DA) I X Q "CR" ;consult result
I $$ISA^TIULX(DA,25) Q "A" ;CWAD note/Allergy
I $$ISA^TIULX(DA,27) Q "D" ;CWAD note/Advance Directive
I $$ISA^TIULX(DA,30) Q "C" ;CWAD note/Crisis Note
I $$ISA^TIULX(DA,31) Q "W" ;CWAD note/Clinical Warning
I $$ISA^TIULX(DA,3) Q "PN" ;progress note
;
I $$ISA^TIULX(DA,244) Q "DS" ;discharge summary
D ISCP^TIUCP(.X,DA) I X Q "CP" ;clinical procedure
D ISSURG^TIUSROI(.X,DA) I X Q "SR" ;surgery
I $$ISA^TIULX(DA,$$LR) Q "LR" ;laboratory
Q ""
;
LR() ; -- Return ien of Lab class
N Y S Y=+$O(^TIU(8925.1,"B","LR LABORATORY REPORTS",0)) ;DE2818, ICRs 2700 and 5677
I Y>0,$S($P($G(^TIU(8925.1,Y,0)),U,4)="CL":0,$P($G(^(0)),U,4)="DC":0,1:1) S Y=0
Q Y
;
SIG(X) ; -- Return Signature Block Name_Title
N X20,Y S X20=$G(^VA(200,+$G(X),20))
S Y=$P(X20,U,2)_" "_$P(X20,U,3)
Q Y
;
RPT(HMPY,IFN) ; -- Return text of document in @HMPY@(n)
N I,J ;protect for calling loops
D TGET^TIUSRVR1(.HMPY,IFN)
Q
;
TEXT(IFN) ; -- Get document IFN text, return temp array name
N HMPY,Y,I,J ;protect I&J for calling loops
S IFN=+$G(IFN) D TGET^TIUSRVR1(.HMPY,IFN)
M ^TMP("HMPTEXT",$J,IFN)=@HMPY K @HMPY
S Y=$NA(^TMP("HMPTEXT",$J,IFN))
Q Y
;
; ------------ Return data to middle tier ------------
;
XML(DOC) ; -- Return patient documents as XML
N ATT,X,Y,NAMES,TYPE,I
D ADD("<document>") S HMPTOTL=$G(HMPTOTL)+1
S ATT="" F S ATT=$O(DOC(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
. I $O(DOC(ATT,0)) D S Y="" Q ;multiples
.. D ADD("<"_ATT_"s>")
.. S I=0 F S I=$O(DOC(ATT,I)) Q:I<1 D
... S X=$G(DOC(ATT,I)),NAMES=""
... I ATT="clinician" S NAMES="code^name^role^dateTime^signature^Z"
... S Y="<"_ATT_" "_$$LOOP_"/>" D ADD(Y)
.. D ADD("</"_ATT_"s>")
. S X=$G(DOC(ATT)),Y="" Q:'$L(X)
. I ATT="content" D S Y="" Q ;text
.. S Y="<content xml:space='preserve'>" D ADD(Y)
.. S I=0 F S I=$O(@X@(I)) Q:I<1 S Y=$$ESC^HMPD(@X@(I)) D ADD(Y)
.. D ADD("</content>")
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^HMPD(X)_"' />" Q
. I $L(X)>1 S NAMES="code^name^Z",Y="<"_ATT_" "_$$LOOP_"/>"
D ADD("</document>")
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^HMPD($P(X,U,P))_"' "
Q STR
;
ADD(X) ; Add a line @HMP@(n)=X
S HMPI=$G(HMPI)+1
S @HMP@(HMPI)=X
Q
;
; ------------ Get/apply search criteria ------------
;
SETUP ; -- convert FILTER("attribute") = value to TIU criteria
; Expects: FILTER("category") = code (see $$CATG)
; FILTER("loinc") = LOINC
; FILTER("status") = 'all','completed','unsigned'
; Returns CLASS,[SUBCLASS,TITLE,SERVICE,SUBJECT,STATUS]
;
N LOINC,TYPE,STS,CP
S LOINC=+$G(FILTER("loinc")),TYPE=$$UP^XLFSTR($G(FILTER("category")))
S CLASS="3^244",(SUBCLASS,TITLE,SERVICE,SUBJECT,NOTSUBJ,STATUS)=""
;
; status [default='complete']
S STS=$$LOW^XLFSTR($G(FILTER("status")))
S STATUS=$S(STS?1"unsig".E:2,STS="all":"5^2",1:5) ;TIUSRVLO statuses
;
; progress notes
I TYPE="PN" S CLASS=3 Q
I TYPE="CR"!(LOINC=11488) S CLASS=3,SUBCLASS=+$$CLASS^TIUCNSLT Q
; LOINC=26442 S CLASS=3,SUBJECT="^114^" Q ;OB/GYN
I LOINC=34117 S CLASS=3,SERVICE="^88^" Q ;H&P
I TYPE="CWAD" S CLASS=3,SUBCLASS="25^27^30^31" Q ;CWAD
I TYPE="C" S CLASS=3,SUBCLASS=30 Q ;Crisis Note
I TYPE="W" S CLASS=3,SUBCLASS=31 Q ;Clinical Warning
I TYPE="A" S CLASS=3,SUBCLASS=25 Q ;Allergy Note
I TYPE="D"!(LOINC=42348) S CLASS=3,SUBCLASS=27 Q ;Advance Directive
;
; discharge summaries
I TYPE="DS"!(LOINC=18842) S CLASS=244 Q
;
; procedures
I TYPE="SR"!(LOINC=29752) S CLASS=+$$CLASS^TIUSROI("SURGICAL REPORTS") Q
D CPCLASS^TIUCP(.CP)
I TYPE="CP" S CLASS=$S(STATUS=2:CP,1:"CP") Q ;CLINICAL PROCEDURES
I LOINC=26441 D Q ;CARDIOLOGY
. S CLASS=CP_"^3"
. S SUBJECT="^18^142^174^",SERVICE="^75^76^115^"
I LOINC=27896 D Q ;PULMONARY
. S CLASS=CP_"^3"
. S SUBJECT="^23^142^",SERVICE="^75^76^115^"
I LOINC=27895 D Q ;GASTROENTEROLOGY
. S CLASS=CP_"^3"
. S SUBJECT="^20^",SERVICE="^75^76^115^"
I LOINC=27897 D Q ;NEUROLOGY
. S CLASS=CP_"^3"
. S SUBJECT="^44^45^52^111^112^143^146^",SERVICE="^75^76^115^"
I LOINC=28619 D Q ;OPHTH/OPTOMETRY
. S CLASS=CP_"^3"
. S SUBJECT="^13^14^103^",SERVICE="^75^76^115^"
I LOINC=28634 D Q ;MISC/ALL OTHERS
. S CLASS=CP_"^3",SERVICE="^75^76^115^"
. S NOTSUBJ="^18^142^174^23^142^20^44^45^52^111^112^143^146^13^14^103^"
I LOINC=28570 D Q ;UNSPECIFIED/ALL
. S CLASS=CP_"^3"
. S SERVICE="^75^76^115^"
;
; pathology/lab
I TYPE="LR"!(LOINC=27898) S CLASS=$S(STATUS=2:$$LR,1:"LR") Q
;
; radiology
I TYPE="RA"!(LOINC=18726) S CLASS="RA" Q
;
; unknown
I $L(TYPE)!LOINC S CLASS=0
Q
;
;DE2818 begin, changed function below to use FileMan for ^TIU(8926.1) references, ICR 5678
MATCH(DOC,SBCLSS,SRVC,SBJCT,NTSBJ) ; Boolean function, Return 1 or 0, if document matches search criteria
; DOC - IEN in TIU DOCUMENT file (#8925)
; SBCLSS - subclass
; SRVC - service
; two pointers to TIU LOINC SUBJECT MATTER DOMAIN (#8926.2):
; SBJCT - subject to include, NTSUBJ - subject to exclude
N DA,HMSBJMD,LOCAL,NATL,OK,Y
; Y is the return value
S Y=0,DA=+$G(DOC) G:DA<1 MQ
; include addenda if pulling only unsigned items
I $P(DOC,U,2)?1"Addendum ".E,STATUS'=2 G MQ
; TIU unsigned list can include completed parent notes
I CTXT=2,$P(DOC,U,7)'="unsigned" G MQ
S LOCAL=$$GET1^DIQ(8925,DA_",",.01,"I") ;local Title 8925.1 ien
I $L(SBCLSS) D G:'OK MQ
. N I,X S OK=0
. F I=1:1:$L(SBCLSS,U) S X=$P(SBCLSS,U,I) I $$ISA^TIULX(LOCAL,X) S OK=1 Q
S NATL=+$$GET1^DIQ(8925.1,LOCAL_",",1501,"I") ;Natl Title 8926.1 ien
I $L(TITLE) G:TITLE'[(U_+NATL_U) MQ
;S X0=$G(^TIU(8926.1,NATL,0))
I $L(SRVC) G:SRVC'[(U_$$GET1^DIQ(8926.1,NATL_",",.07,"I")_U) MQ ;(#.07) SERVICE
S HMSBJMD=+$$GET1^DIQ(8926.1,NATL_",",.07,"I") ;(#.04) SUBJECT MATTER DOMAIN
I $L(SBJCT) G:SBJCT'[(U_HMSBJMD_U) MQ
I $L(NTSBJ) G:NTSBJ[(U_HMSBJMD_U) MQ
S Y=1
MQ Q Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDTIU 11182 printed Apr 09, 2024@20:59:41 Page 2
HMPDTIU ;SLC/MKB,ASMR/RRB - TIU extract;Nov 23, 2015 18:02:20
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**;Sep 01, 2011;Build 63
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^SC( 10040
+7 ; ^TIU(8925.1 2321,5677
+8 ; ^TIU(8926.1 5678
+9 ; ^VA(200 10060
+10 ; DIQ 2056
+11 ; RAO7PC1 2043
+12 ; TIUCNSLT 5546
+13 ; TIUCP 3568
+14 ; TIULQ 2693
+15 ; TIULX 3058
+16 ; TIUSROI 5676
+17 ; TIUSRVLO 2834,2865
+18 ; TIUSRVR1 2944
+19 ; XLFSTR 10104
+20 QUIT
+21 ; ------------ Get documents from VistA ------------
+22 ;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's documents
+1 NEW HMPITM,HMPN,HMPX,HMPY,HMPCNT
+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)
+4 ;
+5 ; get one document
+6 IF $LENGTH($GET(ID))
IF ID[";"
Begin DoDot:1
+7 ;CP
IF ID
DO RPT1^HMPDMC(DFN,ID,.HMPITM)
DO XML(.HMPITM)
QUIT
+8 ;Lab
DO RPT1^HMPDLRA(DFN,ID,.HMPITM)
DO XML(.HMPITM)
QUIT
End DoDot:1
GOTO ENQ
+9 ;Radiology
IF $GET(ID)
IF ID["-"
Begin DoDot:1
+10 SET (BEG,END)=9999999.9999-+ID
DO EN1^RAO7PC1(DFN,BEG,END,"99P")
+11 DO RPT1^HMPDRA(DFN,ID,.HMPITM)
DO XML(.HMPITM)
+12 KILL ^TMP($JOB,"RAE1")
End DoDot:1
GOTO ENQ
+13 IF $GET(ID)
DO EN1(ID,.HMPITM)
if $DATA(HMPITM)
DO XML(.HMPITM)
GOTO ENQ
+14 ;
+15 ; get all documents
+16 NEW CLASS,SUBCLASS,TITLE,SERVICE,SUBJECT,NOTSUBJ,STATUS,HMPC,CLS,HMPS,CTXT
+17 ;define search criteria
DO SETUP
SET HMPCNT=0
+18 IF CLASS="CP"
DO RPTS^HMPDMC(DFN,BEG,END,MAX)
QUIT
+19 IF CLASS="RA"
DO RPTS^HMPDRA(DFN,BEG,END,MAX)
QUIT
+20 IF CLASS="LR"
DO RPTS^HMPDLRA(DFN,BEG,END,MAX)
QUIT
+21 FOR HMPC=1:1:$LENGTH(CLASS,U)
SET CLS=$PIECE(CLASS,U,HMPC)
Begin DoDot:1
+22 FOR HMPS=1:1:$LENGTH(STATUS,U)
SET CTXT=$PIECE(STATUS,U,HMPS)
Begin DoDot:2
+23 DO CONTEXT^TIUSRVLO(.HMPY,CLS,CTXT,DFN,BEG,END,,MAX,,1)
+24 SET HMPN=0
FOR
SET HMPN=$ORDER(@HMPY@(HMPN))
if HMPN<1
QUIT
Begin DoDot:3
+25 SET HMPX=$GET(@HMPY@(HMPN))
if '$$MATCH(HMPX,$GET(SUBCLASS),$GET(SERVICE),$GET(SUBJECT),$GET(NOTSUBJ))
QUIT
+26 ;already included
if $DATA(^TMP("HMPD",$JOB,+HMPX))
QUIT
+27 KILL HMPITM
DO EN1(HMPX,.HMPITM)
if '$DATA(HMPITM)
QUIT
+28 DO XML(.HMPITM)
SET HMPCNT=HMPCNT+1
End DoDot:3
if HMPCNT'<MAX
QUIT
+29 KILL @HMPY
End DoDot:2
if HMPCNT'<MAX
QUIT
End DoDot:1
if HMPCNT'<MAX
QUIT
ENQ ; end
+1 KILL ^TMP("HMPTEXT",$JOB)
+2 QUIT
+3 ;
EN1(HMPX,DOC) ; -- return a document in DOC("attribute")=value
+1 ; Expects DFN, HMPX=IEN^$$RESOLVE^TIUSRVLO(IEN)
+2 NEW IEN,X,NAME,HMPTIU,ES,I,HMPY
+3 KILL DOC,^TMP("HMPTEXT",$JOB)
+4 ;invalid ien
SET IEN=+$GET(HMPX)
if IEN<1
QUIT
+5 ;get data string, if needed
IF +HMPX=HMPX
Begin DoDot:1
+6 NEW SHOWADD,DA
SET SHOWADD=1
SET DA=+HMPX
+7 SET HMPX=DA_U_$$RESOLVE^TIUSRVLO(DA)
End DoDot:1
+8 ;null or invalid
if "UNKNOWN"[$PIECE($GET(HMPX),U,2)
QUIT
+9 ;I $P(HMPX,U,14),$P(NAME," ")="Addendum" Q
SET NAME=$PIECE(HMPX,U,2)
+10 SET DOC("id")=IEN
SET DOC("localTitle")=NAME
+11 DO EXTRACT^TIULQ(IEN,"HMPTIU",,".01:.04;1501:1508")
+12 SET X=$$GET1^DIQ(8925,IEN_",",".01:1501","I")
IF X
Begin DoDot:1
+13 NEW IENS,TIU,Y,FNUM
+14 SET IENS=X_","
DO GETS^DIQ(8926.1,IENS,"*","IE","TIU")
+15 SET DOC("nationalTitle")=$GET(TIU(8926.1,IENS,99.99,"E"))_U_$GET(TIU(8926.1,IENS,.01,"E"))
+16 FOR I=".04^Subject^2",".05^Role^3",".06^Setting^4",".07^Service^5",".08^Type^6"
Begin DoDot:2
+17 SET Y=+$GET(TIU(8926.1,IENS,+I,"I"))
if Y'>0
QUIT
+18 SET FNUM="8926."_+$PIECE(I,U,3)
+19 SET DOC("nationalTitle"_$PIECE(I,U,2))=$$VUID^HMPD(Y,FNUM)_U_$GET(TIU(8926.1,IENS,+I,"E"))
End DoDot:2
End DoDot:1
+20 if $GET(FILTER("loinc"))
SET DOC("loinc")=$PIECE(FILTER("loinc"),U)
+21 SET X=+$GET(HMPTIU(IEN,.01,"I"))
SET X=$$CATG(X)
SET (DOC("type"),DOC("category"))=X
+22 SET DOC("documentClass")=$SELECT(X="LR":"LR LABORATORY REPORTS",X="SR":"SURGICAL REPORTS",X="CP":"CLINICAL PROCEDURES",X="DS":"DISCHARGE SUMMARY",1:"PROGRESS NOTES")
+23 SET DOC("referenceDateTime")=$PIECE(HMPX,U,3)
+24 ;S:$L(X) DOC("location")=X
SET X=$PIECE(HMPX,U,6)
Begin DoDot:1
+25 ; DE2818, ICR 10040 for ^SC, this doesn't handle duplicate entries and should be corrected
+26 NEW LOC
SET LOC=$SELECT($LENGTH(X):+$ORDER(^SC("B",X,0)),1:0)
+27 SET DOC("facility")=$$FAC^HMPD(LOC)
End DoDot:1
+28 SET X=$PIECE(HMPX,U,7)
if $LENGTH(X)
SET DOC("status")=X
+29 if $PIECE(HMPX,U,11)
SET DOC("images")=+$PIECE(HMPX,U,11)
+30 if $LENGTH($PIECE(HMPX,U,12))
SET DOC("subject")=$PIECE(HMPX,U,12)
+31 ; X=$S($P(HMPX,U,13)[">":"C",$P(HMPX,U,13)["<":"I",1:"") ;componentType
+32 ;ID notes
IF $PIECE(HMPX,U,14)>5
SET DOC("parent")=$PIECE(HMPX,U,14)
+33 SET DOC("encounter")=$GET(HMPTIU(IEN,.03,"I"))
+34 if $GET(HMPTEXT)
SET DOC("content")=$$TEXT(IEN)
+35 ; providers &/or signatures
+36 ;author
SET X=$PIECE(HMPX,U,5)
SET I=0
if X
SET I=I+1
SET DOC("clinician",I)=+X_U_$PIECE(X,";",3)_"^A"
+37 MERGE ES=HMPTIU(IEN)
IF ES(1501,"I")
Begin DoDot:1
+38 SET I=I+1
+39 SET DOC("clinician",I)=ES(1502,"I")_U_ES(1502,"E")_"^S^"_ES(1501,"I")_U_$$SIG(ES(1502,"I"))
End DoDot:1
+40 ; cosigner
IF ES(1507,"I")
Begin DoDot:1
+41 SET I=I+1
+42 SET DOC("clinician",I)=ES(1508,"I")_U_ES(1508,"E")_"^C^"_ES(1507,"I")_U_$$SIG(ES(1508,"I"))
End DoDot:1
+43 QUIT
+44 ;
CATG(DA) ; -- Return a code for document type #8925.1 DA
+1 NEW X
+2 ;consult result
DO ISCNSLT^TIUCNSLT(.X,DA)
IF X
QUIT "CR"
+3 ;CWAD note/Allergy
IF $$ISA^TIULX(DA,25)
QUIT "A"
+4 ;CWAD note/Advance Directive
IF $$ISA^TIULX(DA,27)
QUIT "D"
+5 ;CWAD note/Crisis Note
IF $$ISA^TIULX(DA,30)
QUIT "C"
+6 ;CWAD note/Clinical Warning
IF $$ISA^TIULX(DA,31)
QUIT "W"
+7 ;progress note
IF $$ISA^TIULX(DA,3)
QUIT "PN"
+8 ;
+9 ;discharge summary
IF $$ISA^TIULX(DA,244)
QUIT "DS"
+10 ;clinical procedure
DO ISCP^TIUCP(.X,DA)
IF X
QUIT "CP"
+11 ;surgery
DO ISSURG^TIUSROI(.X,DA)
IF X
QUIT "SR"
+12 ;laboratory
IF $$ISA^TIULX(DA,$$LR)
QUIT "LR"
+13 QUIT ""
+14 ;
LR() ; -- Return ien of Lab class
+1 ;DE2818, ICRs 2700 and 5677
NEW Y
SET Y=+$ORDER(^TIU(8925.1,"B","LR LABORATORY REPORTS",0))
+2 IF Y>0
IF $SELECT($PIECE($GET(^TIU(8925.1,Y,0)),U,4)="CL":0,$PIECE($GET(^(0)),U,4)="DC":0,1:1)
SET Y=0
+3 QUIT Y
+4 ;
SIG(X) ; -- Return Signature Block Name_Title
+1 NEW X20,Y
SET X20=$GET(^VA(200,+$GET(X),20))
+2 SET Y=$PIECE(X20,U,2)_" "_$PIECE(X20,U,3)
+3 QUIT Y
+4 ;
RPT(HMPY,IFN) ; -- Return text of document in @HMPY@(n)
+1 ;protect for calling loops
NEW I,J
+2 DO TGET^TIUSRVR1(.HMPY,IFN)
+3 QUIT
+4 ;
TEXT(IFN) ; -- Get document IFN text, return temp array name
+1 ;protect I&J for calling loops
NEW HMPY,Y,I,J
+2 SET IFN=+$GET(IFN)
DO TGET^TIUSRVR1(.HMPY,IFN)
+3 MERGE ^TMP("HMPTEXT",$JOB,IFN)=@HMPY
KILL @HMPY
+4 SET Y=$NAME(^TMP("HMPTEXT",$JOB,IFN))
+5 QUIT Y
+6 ;
+7 ; ------------ Return data to middle tier ------------
+8 ;
XML(DOC) ; -- Return patient documents as XML
+1 NEW ATT,X,Y,NAMES,TYPE,I
+2 DO ADD("<document>")
SET HMPTOTL=$GET(HMPTOTL)+1
+3 SET ATT=""
FOR
SET ATT=$ORDER(DOC(ATT))
if ATT=""
QUIT
Begin DoDot:1
+4 ;multiples
IF $ORDER(DOC(ATT,0))
Begin DoDot:2
+5 DO ADD("<"_ATT_"s>")
+6 SET I=0
FOR
SET I=$ORDER(DOC(ATT,I))
if I<1
QUIT
Begin DoDot:3
+7 SET X=$GET(DOC(ATT,I))
SET NAMES=""
+8 IF ATT="clinician"
SET NAMES="code^name^role^dateTime^signature^Z"
+9 SET Y="<"_ATT_" "_$$LOOP_"/>"
DO ADD(Y)
End DoDot:3
+10 DO ADD("</"_ATT_"s>")
End DoDot:2
SET Y=""
QUIT
+11 SET X=$GET(DOC(ATT))
SET Y=""
if '$LENGTH(X)
QUIT
+12 ;text
IF ATT="content"
Begin DoDot:2
+13 SET Y="<content xml:space='preserve'>"
DO ADD(Y)
+14 SET I=0
FOR
SET I=$ORDER(@X@(I))
if I<1
QUIT
SET Y=$$ESC^HMPD(@X@(I))
DO ADD(Y)
+15 DO ADD("</content>")
End DoDot:2
SET Y=""
QUIT
+16 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^HMPD(X)_"' />"
QUIT
+17 IF $LENGTH(X)>1
SET NAMES="code^name^Z"
SET Y="<"_ATT_" "_$$LOOP_"/>"
End DoDot:1
if $LENGTH(Y)
DO ADD(Y)
+18 DO ADD("</document>")
+19 QUIT
+20 ;
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^HMPD($PIECE(X,U,P))_"' "
+3 QUIT STR
+4 ;
ADD(X) ; Add a line @HMP@(n)=X
+1 SET HMPI=$GET(HMPI)+1
+2 SET @HMP@(HMPI)=X
+3 QUIT
+4 ;
+5 ; ------------ Get/apply search criteria ------------
+6 ;
SETUP ; -- convert FILTER("attribute") = value to TIU criteria
+1 ; Expects: FILTER("category") = code (see $$CATG)
+2 ; FILTER("loinc") = LOINC
+3 ; FILTER("status") = 'all','completed','unsigned'
+4 ; Returns CLASS,[SUBCLASS,TITLE,SERVICE,SUBJECT,STATUS]
+5 ;
+6 NEW LOINC,TYPE,STS,CP
+7 SET LOINC=+$GET(FILTER("loinc"))
SET TYPE=$$UP^XLFSTR($GET(FILTER("category")))
+8 SET CLASS="3^244"
SET (SUBCLASS,TITLE,SERVICE,SUBJECT,NOTSUBJ,STATUS)=""
+9 ;
+10 ; status [default='complete']
+11 SET STS=$$LOW^XLFSTR($GET(FILTER("status")))
+12 ;TIUSRVLO statuses
SET STATUS=$SELECT(STS?1"unsig".E:2,STS="all":"5^2",1:5)
+13 ;
+14 ; progress notes
+15 IF TYPE="PN"
SET CLASS=3
QUIT
+16 IF TYPE="CR"!(LOINC=11488)
SET CLASS=3
SET SUBCLASS=+$$CLASS^TIUCNSLT
QUIT
+17 ; LOINC=26442 S CLASS=3,SUBJECT="^114^" Q ;OB/GYN
+18 ;H&P
IF LOINC=34117
SET CLASS=3
SET SERVICE="^88^"
QUIT
+19 ;CWAD
IF TYPE="CWAD"
SET CLASS=3
SET SUBCLASS="25^27^30^31"
QUIT
+20 ;Crisis Note
IF TYPE="C"
SET CLASS=3
SET SUBCLASS=30
QUIT
+21 ;Clinical Warning
IF TYPE="W"
SET CLASS=3
SET SUBCLASS=31
QUIT
+22 ;Allergy Note
IF TYPE="A"
SET CLASS=3
SET SUBCLASS=25
QUIT
+23 ;Advance Directive
IF TYPE="D"!(LOINC=42348)
SET CLASS=3
SET SUBCLASS=27
QUIT
+24 ;
+25 ; discharge summaries
+26 IF TYPE="DS"!(LOINC=18842)
SET CLASS=244
QUIT
+27 ;
+28 ; procedures
+29 IF TYPE="SR"!(LOINC=29752)
SET CLASS=+$$CLASS^TIUSROI("SURGICAL REPORTS")
QUIT
+30 DO CPCLASS^TIUCP(.CP)
+31 ;CLINICAL PROCEDURES
IF TYPE="CP"
SET CLASS=$SELECT(STATUS=2:CP,1:"CP")
QUIT
+32 ;CARDIOLOGY
IF LOINC=26441
Begin DoDot:1
+33 SET CLASS=CP_"^3"
+34 SET SUBJECT="^18^142^174^"
SET SERVICE="^75^76^115^"
End DoDot:1
QUIT
+35 ;PULMONARY
IF LOINC=27896
Begin DoDot:1
+36 SET CLASS=CP_"^3"
+37 SET SUBJECT="^23^142^"
SET SERVICE="^75^76^115^"
End DoDot:1
QUIT
+38 ;GASTROENTEROLOGY
IF LOINC=27895
Begin DoDot:1
+39 SET CLASS=CP_"^3"
+40 SET SUBJECT="^20^"
SET SERVICE="^75^76^115^"
End DoDot:1
QUIT
+41 ;NEUROLOGY
IF LOINC=27897
Begin DoDot:1
+42 SET CLASS=CP_"^3"
+43 SET SUBJECT="^44^45^52^111^112^143^146^"
SET SERVICE="^75^76^115^"
End DoDot:1
QUIT
+44 ;OPHTH/OPTOMETRY
IF LOINC=28619
Begin DoDot:1
+45 SET CLASS=CP_"^3"
+46 SET SUBJECT="^13^14^103^"
SET SERVICE="^75^76^115^"
End DoDot:1
QUIT
+47 ;MISC/ALL OTHERS
IF LOINC=28634
Begin DoDot:1
+48 SET CLASS=CP_"^3"
SET SERVICE="^75^76^115^"
+49 SET NOTSUBJ="^18^142^174^23^142^20^44^45^52^111^112^143^146^13^14^103^"
End DoDot:1
QUIT
+50 ;UNSPECIFIED/ALL
IF LOINC=28570
Begin DoDot:1
+51 SET CLASS=CP_"^3"
+52 SET SERVICE="^75^76^115^"
End DoDot:1
QUIT
+53 ;
+54 ; pathology/lab
+55 IF TYPE="LR"!(LOINC=27898)
SET CLASS=$SELECT(STATUS=2:$$LR,1:"LR")
QUIT
+56 ;
+57 ; radiology
+58 IF TYPE="RA"!(LOINC=18726)
SET CLASS="RA"
QUIT
+59 ;
+60 ; unknown
+61 IF $LENGTH(TYPE)!LOINC
SET CLASS=0
+62 QUIT
+63 ;
+64 ;DE2818 begin, changed function below to use FileMan for ^TIU(8926.1) references, ICR 5678
MATCH(DOC,SBCLSS,SRVC,SBJCT,NTSBJ) ; Boolean function, Return 1 or 0, if document matches search criteria
+1 ; DOC - IEN in TIU DOCUMENT file (#8925)
+2 ; SBCLSS - subclass
+3 ; SRVC - service
+4 ; two pointers to TIU LOINC SUBJECT MATTER DOMAIN (#8926.2):
+5 ; SBJCT - subject to include, NTSUBJ - subject to exclude
+6 NEW DA,HMSBJMD,LOCAL,NATL,OK,Y
+7 ; Y is the return value
+8 SET Y=0
SET DA=+$GET(DOC)
if DA<1
GOTO MQ
+9 ; include addenda if pulling only unsigned items
+10 IF $PIECE(DOC,U,2)?1"Addendum ".E
IF STATUS'=2
GOTO MQ
+11 ; TIU unsigned list can include completed parent notes
+12 IF CTXT=2
IF $PIECE(DOC,U,7)'="unsigned"
GOTO MQ
+13 ;local Title 8925.1 ien
SET LOCAL=$$GET1^DIQ(8925,DA_",",.01,"I")
+14 IF $LENGTH(SBCLSS)
Begin DoDot:1
+15 NEW I,X
SET OK=0
+16 FOR I=1:1:$LENGTH(SBCLSS,U)
SET X=$PIECE(SBCLSS,U,I)
IF $$ISA^TIULX(LOCAL,X)
SET OK=1
QUIT
End DoDot:1
if 'OK
GOTO MQ
+17 ;Natl Title 8926.1 ien
SET NATL=+$$GET1^DIQ(8925.1,LOCAL_",",1501,"I")
+18 IF $LENGTH(TITLE)
if TITLE'[(U_+NATL_U)
GOTO MQ
+19 ;S X0=$G(^TIU(8926.1,NATL,0))
+20 ;(#.07) SERVICE
IF $LENGTH(SRVC)
if SRVC'[(U_$$GET1^DIQ(8926.1,NATL_",",.07,"I")_U)
GOTO MQ
+21 ;(#.04) SUBJECT MATTER DOMAIN
SET HMSBJMD=+$$GET1^DIQ(8926.1,NATL_",",.07,"I")
+22 IF $LENGTH(SBJCT)
if SBJCT'[(U_HMSBJMD_U)
GOTO MQ
+23 IF $LENGTH(NTSBJ)
if NTSBJ[(U_HMSBJMD_U)
GOTO MQ
+24 SET Y=1
MQ QUIT Y
+1 ;
