NHINVTIU ;SLC/MKB -- TIU extract
;;1.0;NHIN;**1**;Oct 25, 2010;Build 11
;
; External References DBIA#
; ------------------- -----
; ^SC( 10040
; ^VA(200 10060
; DIQ 2056
; TIUSRVLO 2834,2865
; TIUSRVR1 2944
;
; ------------ Get documents from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's documents
N NHITM,NHI,NHX,NHY,NHDAD
S DFN=+$G(DFN) Q:$G(DFN)<1
S BEG=$G(BEG,1410101),END=$G(END,9999998),MAX=$G(MAX,999999)
;
; get one document
I $L($G(ID)),ID[";" D RPT^NHINVLRA(DFN,ID,.NHITM),XML(.NHITM) Q ;Lab
I $G(ID),ID["-" D RPT^NHINVRA(DFN,ID,.NHITM),XML(.NHITM) Q ;Radiology
I $G(ID) D Q
. N SHOWADD S SHOWADD=1
. S NHX=ID_U_$$RESOLVE^TIUSRVLO(ID)
. D EN1(ID,.NHITM),XML(.NHITM)
;
; get all documents via
D CONTEXT^TIUSRVLO(.NHY,3,1,DFN,BEG,END,,MAX,,1)
S NHI=0 F S NHI=$O(@NHY@(NHI)) Q:NHI<1 D
. S NHX=$G(@NHY@(NHI)),IFN=+NHX
. K NHITM D EN1(IFN,.NHITM)
. D:$D(NHITM) XML(.NHITM)
Q
;
EN1(IEN,DOC) ; -- return a document in DOC("attribute")=value
; Expects DFN, NHX=IEN ^ $$RESOLVE^TIUSRVLO(IEN)
N X,NAME,NHINX,ES,I K DOC
S IEN=+$G(IEN) Q:IEN<1 ;invalid ien
Q:"UNKNOWN"[$P($G(NHX),U,2) ;null or invalid
S DOC("id")=IEN,NAME=$P(NHX,U,2),DOC("localTitle")=NAME
I $P(NHX,U,14),$P(NAME," ")="Addendum" D Q
. N DATE,PARENT K DOC
. S DATE=$P(NHX,U,3),PARENT=$P(NHX,U,14)
. I DATE,PARENT>1 S NHDAD(PARENT,DATE)=NHX
S X=$$GET1^DIQ(8925,IEN_",",".01:1501") S:$L(X) DOC("nationalTitle")=X
S X=$$GET1^DIQ(8925,IEN_",",".01:1501:99.99") S:$L(X) DOC("nationalTitleCode")=X
S X=$$GET1^DIQ(8925,IEN_",",.04) S:$L(X) DOC("documentClass")=X
S DOC("referenceDateTime")=$P(NHX,U,3)
S X=$P(NHX,U,6) D ;S:$L(X) DOC("location")=X
. N LOC S LOC=$S($L(X):+$O(^SC("B",X,0)),1:0)
. S DOC("facility")=$$FAC^NHINV(LOC)
S X=$P(NHX,U,7) S:$L(X) DOC("status")=X
S:$L($P(NHX,U,12)) DOC("subject")=$P(NHX,U,12)
; X=$S($P(NHX,U,13)[">":"C",$P(NHX,U,13)["<":"I",1:"") ;componentType
S DOC("encounter")=$$GET1^DIQ(8925,IEN_",",.03,"I") ;$$VSTR(IEN)
S DOC("content")=$$TEXT(IEN)
; providers &/or signatures
S X=$P(NHX,U,5),I=0 S:X I=I+1,DOC("clinician",I)=+X_U_$P(X,";",3)_"^A" ;author
D GETS^DIQ(8925,IEN_",","1501;1502;1507;1508","IE","NHINX")
M ES=NHINX(8925,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
;
VSTR(DA) ; -- get visit string for document DA
; Expects DFN, NHX = IEN ^ $$RESOLVE^TIUSRVLO(IEN)
N VDT,VTYP,VLOC,Y
S VDT=$P($P(NHX,U,8),";",2)
S VTYP=$$GET1^DIQ(8925,DA_",",.13)
S VLOC=$$GET1^DIQ(8925,DA_",",1211,"I")
S Y=VLOC_";"_VDT_";"_VTYP
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(NHY,IFN) ; -- Return text of document in @NHY@(n)
D TGET^TIUSRVR1(.NHY,IFN)
Q
;
TEXT(IFN) ; -- Return document IFN as a text string
N I,Y,NHY S IFN=+$G(IFN),Y=""
I IFN D
. D TGET^TIUSRVR1(.NHY,IFN)
. S I=0 F S I=$O(@NHY@(I)) Q:I<1 S Y=Y_$S($L(Y):$C(13,10),1:"")_@NHY@(I)
Q Y
;
; ------------ Return data to middle tier ------------
;
XML(DOC) ; -- Return patient documents as XML
N ATT,X,Y,NAMES,TYPE
D ADD("<document>") S NHINTOTL=$G(NHINTOTL)+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" S Y="<"_ATT_" xml:space='preserve'>"_$$ESC^NHINV(X)_"</"_ATT_">" Q
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^NHINV(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^NHINV($P(X,U,P))_"' "
Q STR
;
ADD(X) ; Add a line @NHIN@(n)=X
S NHINI=$G(NHINI)+1
S @NHIN@(NHINI)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNHINVTIU 4444 printed Apr 09, 2024@21:20:23 Page 2
NHINVTIU ;SLC/MKB -- TIU extract
+1 ;;1.0;NHIN;**1**;Oct 25, 2010;Build 11
+2 ;
+3 ; External References DBIA#
+4 ; ------------------- -----
+5 ; ^SC( 10040
+6 ; ^VA(200 10060
+7 ; DIQ 2056
+8 ; TIUSRVLO 2834,2865
+9 ; TIUSRVR1 2944
+10 ;
+11 ; ------------ Get documents from VistA ------------
+12 ;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's documents
+1 NEW NHITM,NHI,NHX,NHY,NHDAD
+2 SET DFN=+$GET(DFN)
if $GET(DFN)<1
QUIT
+3 SET BEG=$GET(BEG,1410101)
SET END=$GET(END,9999998)
SET MAX=$GET(MAX,999999)
+4 ;
+5 ; get one document
+6 ;Lab
IF $LENGTH($GET(ID))
IF ID[";"
DO RPT^NHINVLRA(DFN,ID,.NHITM)
DO XML(.NHITM)
QUIT
+7 ;Radiology
IF $GET(ID)
IF ID["-"
DO RPT^NHINVRA(DFN,ID,.NHITM)
DO XML(.NHITM)
QUIT
+8 IF $GET(ID)
Begin DoDot:1
+9 NEW SHOWADD
SET SHOWADD=1
+10 SET NHX=ID_U_$$RESOLVE^TIUSRVLO(ID)
+11 DO EN1(ID,.NHITM)
DO XML(.NHITM)
End DoDot:1
QUIT
+12 ;
+13 ; get all documents via
+14 DO CONTEXT^TIUSRVLO(.NHY,3,1,DFN,BEG,END,,MAX,,1)
+15 SET NHI=0
FOR
SET NHI=$ORDER(@NHY@(NHI))
if NHI<1
QUIT
Begin DoDot:1
+16 SET NHX=$GET(@NHY@(NHI))
SET IFN=+NHX
+17 KILL NHITM
DO EN1(IFN,.NHITM)
+18 if $DATA(NHITM)
DO XML(.NHITM)
End DoDot:1
+19 QUIT
+20 ;
EN1(IEN,DOC) ; -- return a document in DOC("attribute")=value
+1 ; Expects DFN, NHX=IEN ^ $$RESOLVE^TIUSRVLO(IEN)
+2 NEW X,NAME,NHINX,ES,I
KILL DOC
+3 ;invalid ien
SET IEN=+$GET(IEN)
if IEN<1
QUIT
+4 ;null or invalid
if "UNKNOWN"[$PIECE($GET(NHX),U,2)
QUIT
+5 SET DOC("id")=IEN
SET NAME=$PIECE(NHX,U,2)
SET DOC("localTitle")=NAME
+6 IF $PIECE(NHX,U,14)
IF $PIECE(NAME," ")="Addendum"
Begin DoDot:1
+7 NEW DATE,PARENT
KILL DOC
+8 SET DATE=$PIECE(NHX,U,3)
SET PARENT=$PIECE(NHX,U,14)
+9 IF DATE
IF PARENT>1
SET NHDAD(PARENT,DATE)=NHX
End DoDot:1
QUIT
+10 SET X=$$GET1^DIQ(8925,IEN_",",".01:1501")
if $LENGTH(X)
SET DOC("nationalTitle")=X
+11 SET X=$$GET1^DIQ(8925,IEN_",",".01:1501:99.99")
if $LENGTH(X)
SET DOC("nationalTitleCode")=X
+12 SET X=$$GET1^DIQ(8925,IEN_",",.04)
if $LENGTH(X)
SET DOC("documentClass")=X
+13 SET DOC("referenceDateTime")=$PIECE(NHX,U,3)
+14 ;S:$L(X) DOC("location")=X
SET X=$PIECE(NHX,U,6)
Begin DoDot:1
+15 NEW LOC
SET LOC=$SELECT($LENGTH(X):+$ORDER(^SC("B",X,0)),1:0)
+16 SET DOC("facility")=$$FAC^NHINV(LOC)
End DoDot:1
+17 SET X=$PIECE(NHX,U,7)
if $LENGTH(X)
SET DOC("status")=X
+18 if $LENGTH($PIECE(NHX,U,12))
SET DOC("subject")=$PIECE(NHX,U,12)
+19 ; X=$S($P(NHX,U,13)[">":"C",$P(NHX,U,13)["<":"I",1:"") ;componentType
+20 ;$$VSTR(IEN)
SET DOC("encounter")=$$GET1^DIQ(8925,IEN_",",.03,"I")
+21 SET DOC("content")=$$TEXT(IEN)
+22 ; providers &/or signatures
+23 ;author
SET X=$PIECE(NHX,U,5)
SET I=0
if X
SET I=I+1
SET DOC("clinician",I)=+X_U_$PIECE(X,";",3)_"^A"
+24 DO GETS^DIQ(8925,IEN_",","1501;1502;1507;1508","IE","NHINX")
+25 MERGE ES=NHINX(8925,IEN_",")
IF ES(1501,"I")
Begin DoDot:1
+26 SET I=I+1
+27 SET DOC("clinician",I)=ES(1502,"I")_U_ES(1502,"E")_"^S^"_ES(1501,"I")_U_$$SIG(ES(1502,"I"))
End DoDot:1
+28 ; cosigner
IF ES(1507,"I")
Begin DoDot:1
+29 SET I=I+1
+30 SET DOC("clinician",I)=ES(1508,"I")_U_ES(1508,"E")_"^C^"_ES(1507,"I")_U_$$SIG(ES(1508,"I"))
End DoDot:1
+31 QUIT
+32 ;
VSTR(DA) ; -- get visit string for document DA
+1 ; Expects DFN, NHX = IEN ^ $$RESOLVE^TIUSRVLO(IEN)
+2 NEW VDT,VTYP,VLOC,Y
+3 SET VDT=$PIECE($PIECE(NHX,U,8),";",2)
+4 SET VTYP=$$GET1^DIQ(8925,DA_",",.13)
+5 SET VLOC=$$GET1^DIQ(8925,DA_",",1211,"I")
+6 SET Y=VLOC_";"_VDT_";"_VTYP
+7 QUIT Y
+8 ;
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(NHY,IFN) ; -- Return text of document in @NHY@(n)
+1 DO TGET^TIUSRVR1(.NHY,IFN)
+2 QUIT
+3 ;
TEXT(IFN) ; -- Return document IFN as a text string
+1 NEW I,Y,NHY
SET IFN=+$GET(IFN)
SET Y=""
+2 IF IFN
Begin DoDot:1
+3 DO TGET^TIUSRVR1(.NHY,IFN)
+4 SET I=0
FOR
SET I=$ORDER(@NHY@(I))
if I<1
QUIT
SET Y=Y_$SELECT($LENGTH(Y):$CHAR(13,10),1:"")_@NHY@(I)
End DoDot:1
+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
+2 DO ADD("<document>")
SET NHINTOTL=$GET(NHINTOTL)+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 IF ATT="content"
SET Y="<"_ATT_" xml:space='preserve'>"_$$ESC^NHINV(X)_"</"_ATT_">"
QUIT
+13 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^NHINV(X)_"' />"
QUIT
+14 IF $LENGTH(X)>1
SET NAMES="code^name^Z"
SET Y="<"_ATT_" "_$$LOOP_"/>"
End DoDot:1
if $LENGTH(Y)
DO ADD(Y)
+15 DO ADD("</document>")
+16 QUIT
+17 ;
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^NHINV($PIECE(X,U,P))_"' "
+3 QUIT STR
+4 ;
ADD(X) ; Add a line @NHIN@(n)=X
+1 SET NHINI=$GET(NHINI)+1
+2 SET @NHIN@(NHINI)=X
+3 QUIT
