NHINVRA ;SLC/MKB -- Radiology extract
;;1.0;NHIN;**1**;Oct 25, 2010;Build 11
;
; External References DBIA#
; ------------------- -----
; ^SC( 10040
; ^VA(200 10060
; DIQ 2056
; ICPTCOD 1995
; RAO7PC1 2043
; RAO7PC3 2877
;
; ------------ Get exam(s) from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's radiology exams
N NHITM,NHICNT,NHXID
S DFN=+$G(DFN) Q:DFN<1
S BEG=$G(BEG,1410101),END=$G(END,9999998),MAX=$G(MAX,999999)
K ^TMP($J,"RAE1") D EN1^RAO7PC1(DFN,BEG,END,MAX)
;
; get exam(s)
I $G(ID) D EN1(ID,.NHITM),XML(.NHITM) Q
;
; get all exams
S NHICNT=0,NHXID=""
F S NHXID=$O(^TMP($J,"RAE1",DFN,NHXID)) Q:NHXID="" D Q:NHICNT'<MAX
. K NHITM D EN1(NHXID,.NHITM) Q:'$D(NHITM)
. D XML(.NHITM) S NHICNT=NHICNT+1
K ^TMP($J,"RAE1")
Q
;
EN1(ID,EXM) ; -- return an exam in EXM("attribute")=value
; Expects ^TMP($J,"RAE1",DFN,ID) from EN1^RAO7PC1
N VPRN,VPR,X0,DATE,LOC,X,Y,IENS,NHMOD K EXM
S X0=$G(^TMP($J,"RAE1",DFN,ID))
S EXM("id")=ID,EXM("name")=$P(X0,U),EXM("case")=$P(X0,U,2)
S DATE=9999999.9999-+ID,EXM("dateTime")=DATE
I $P(X0,U,5) S EXM("document",1)=ID_U_$P(X0,U)_"^^"_$P(X0,U,3) ;id^localTitle^^status, if rpt exists
S:$L($P(X0,U,6)) EXM("status")=$P($P(X0,U,6),"~",2)
S X=$P(X0,U,7),LOC="" I $L(X) D
. S LOC=+$O(^SC("B",X,0)),EXM("location")=LOC_U_X
S EXM("facility")=$$FAC^NHINV(LOC)
I $L($P(X0,U,8)) S X=$TR($P(X0,U,8),"~","^"),EXM("imagingType")=X
S IENS=$P(ID,"-",2)_","_+ID_","_DFN_","
S X=$P(X0,U,10) I X D
. S EXM("type")=$$CPT(X)
. I $D(^TMP($J,"RAE1",DFN,ID,"CMOD")) M EXM("modifier")=^("CMOD")
S EXM("hasImages")=$S($P(X0,U,12)="Y":1,1:0)
I $P(X0,U,4)="Y"!($P(X0,U,9)="Y") S EXM("interpretation")="ABNORMAL"
S EXM("encounter")=$$GET1^DIQ(70.03,IENS,27,"I")
S X=$$GET1^DIQ(70.03,IENS,15,"I") ;S:'X X=$$GET1^DIQ(70.03,IENS,12,"I")
I X S EXM("provider")=X_U_$P($G(^VA(200,X,0)),U)
S EXM("category")="RA"
Q
;
CPT(IEN) ; -- return code^description for CPT code, or "^" if error
N X0,NHX,N,I,X,Y S IEN=+$G(IEN)
S X0=$$CPT^ICPTCOD(IEN) I X0<0 Q "^"
S Y=$P(X0,U,2,3) ;CPT Code^Short Name
S N=$$CPTD^ICPTCOD($P(Y,U),"NHX") ;CPT Description
I N>0,$L($G(NHX(1))) D
. S X=$G(NHX(1)),I=1
. F S I=$O(NHX(I)) Q:I<1 Q:NHX(I)=" " S X=X_" "_NHX(I)
. S $P(Y,U,2)=X
Q Y
;
RPT(DFN,ID,RPT) ; -- return report as a TIU document
S DFN=+$G(DFN),ID=$G(ID) Q:DFN<1 Q:ID<1
N EXAM,CASE,PROC,X0,I,X,Y,IENS
S EXAM=DFN_U_$TR(ID,"-","^") D
. N DFN D EN3^RAO7PC3(EXAM)
S CASE=$O(^TMP($J,"RAE3",DFN,0)),PROC=$O(^(CASE,"")),X0=$G(^(PROC))
S I=$O(^TMP($J,"RAE3",DFN,CASE,PROC,0)),Y=$G(^(I))
F S I=$O(^TMP($J,"RAE3",DFN,CASE,PROC,I)) Q:I<1 S X=^(I),Y=Y_$C(13,10)_X
S RPT("id")=ID,RPT("content")=Y
S X=9999999.9999-(+ID),RPT("referenceDateTime")=X
S RPT("localTitle")=PROC,RPT("status")=$P(X0,U)
S IENS=+ID_","_DFN_",",X=$$GET1^DIQ(70.02,IENS,4,"I")
S RPT("facility")=$$FAC^NHINV(X)
S IENS=$P(ID,"-",2)_","_IENS
S RPT("encounter")=$$GET1^DIQ(70.03,IENS,27,"I")
S X=$$GET1^DIQ(70.03,IENS,15,"I") S:'X X=$$GET1^DIQ(70.03,IENS,12,"I")
I X S RPT("clinician",1)=X_U_$P($G(^VA(200,X,0)),U)
K ^TMP($J,"RAE3",DFN)
Q
;
; ------------ Return data to middle tier ------------
;
XML(EXM) ; -- Return exams as XML
N ATT,X,Y,NAMES
D ADD("<radiology>") S NHINTOTL=$G(NHINTOTL)+1
S ATT="" F S ATT=$O(EXM(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
. S NAMES=$S(ATT="document":"id^localTitle^nationalTitle^status^Z",1:"code^name^Z")
. I $O(EXM(ATT,0)) D S Y="" Q ;multiples
.. D ADD("<"_ATT_"s>")
.. S I=0 F S I=$O(EXM(ATT,I)) Q:I<1 D
... S X=$G(EXM(ATT,I))
... S Y="<"_ATT_" "_$$LOOP_"/>" D ADD(Y)
.. D ADD("</"_ATT_"s>")
. S X=$G(EXM(ATT)),Y="" Q:'$L(X)
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^NHINV(X)_"' />" Q
. I $L(X)>1 S Y="<"_ATT_" "_$$LOOP_"/>"
D ADD("</radiology>")
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[HNHINVRA 4311 printed Sep 23, 2025@19:53:49 Page 2
NHINVRA ;SLC/MKB -- Radiology 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 ; ICPTCOD 1995
+9 ; RAO7PC1 2043
+10 ; RAO7PC3 2877
+11 ;
+12 ; ------------ Get exam(s) from VistA ------------
+13 ;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's radiology exams
+1 NEW NHITM,NHICNT,NHXID
+2 SET DFN=+$GET(DFN)
if DFN<1
QUIT
+3 SET BEG=$GET(BEG,1410101)
SET END=$GET(END,9999998)
SET MAX=$GET(MAX,999999)
+4 KILL ^TMP($JOB,"RAE1")
DO EN1^RAO7PC1(DFN,BEG,END,MAX)
+5 ;
+6 ; get exam(s)
+7 IF $GET(ID)
DO EN1(ID,.NHITM)
DO XML(.NHITM)
QUIT
+8 ;
+9 ; get all exams
+10 SET NHICNT=0
SET NHXID=""
+11 FOR
SET NHXID=$ORDER(^TMP($JOB,"RAE1",DFN,NHXID))
if NHXID=""
QUIT
Begin DoDot:1
+12 KILL NHITM
DO EN1(NHXID,.NHITM)
if '$DATA(NHITM)
QUIT
+13 DO XML(.NHITM)
SET NHICNT=NHICNT+1
End DoDot:1
if NHICNT'<MAX
QUIT
+14 KILL ^TMP($JOB,"RAE1")
+15 QUIT
+16 ;
EN1(ID,EXM) ; -- return an exam in EXM("attribute")=value
+1 ; Expects ^TMP($J,"RAE1",DFN,ID) from EN1^RAO7PC1
+2 NEW VPRN,VPR,X0,DATE,LOC,X,Y,IENS,NHMOD
KILL EXM
+3 SET X0=$GET(^TMP($JOB,"RAE1",DFN,ID))
+4 SET EXM("id")=ID
SET EXM("name")=$PIECE(X0,U)
SET EXM("case")=$PIECE(X0,U,2)
+5 SET DATE=9999999.9999-+ID
SET EXM("dateTime")=DATE
+6 ;id^localTitle^^status, if rpt exists
IF $PIECE(X0,U,5)
SET EXM("document",1)=ID_U_$PIECE(X0,U)_"^^"_$PIECE(X0,U,3)
+7 if $LENGTH($PIECE(X0,U,6))
SET EXM("status")=$PIECE($PIECE(X0,U,6),"~",2)
+8 SET X=$PIECE(X0,U,7)
SET LOC=""
IF $LENGTH(X)
Begin DoDot:1
+9 SET LOC=+$ORDER(^SC("B",X,0))
SET EXM("location")=LOC_U_X
End DoDot:1
+10 SET EXM("facility")=$$FAC^NHINV(LOC)
+11 IF $LENGTH($PIECE(X0,U,8))
SET X=$TRANSLATE($PIECE(X0,U,8),"~","^")
SET EXM("imagingType")=X
+12 SET IENS=$PIECE(ID,"-",2)_","_+ID_","_DFN_","
+13 SET X=$PIECE(X0,U,10)
IF X
Begin DoDot:1
+14 SET EXM("type")=$$CPT(X)
+15 IF $DATA(^TMP($JOB,"RAE1",DFN,ID,"CMOD"))
MERGE EXM("modifier")=^("CMOD")
End DoDot:1
+16 SET EXM("hasImages")=$SELECT($PIECE(X0,U,12)="Y":1,1:0)
+17 IF $PIECE(X0,U,4)="Y"!($PIECE(X0,U,9)="Y")
SET EXM("interpretation")="ABNORMAL"
+18 SET EXM("encounter")=$$GET1^DIQ(70.03,IENS,27,"I")
+19 ;S:'X X=$$GET1^DIQ(70.03,IENS,12,"I")
SET X=$$GET1^DIQ(70.03,IENS,15,"I")
+20 IF X
SET EXM("provider")=X_U_$PIECE($GET(^VA(200,X,0)),U)
+21 SET EXM("category")="RA"
+22 QUIT
+23 ;
CPT(IEN) ; -- return code^description for CPT code, or "^" if error
+1 NEW X0,NHX,N,I,X,Y
SET IEN=+$GET(IEN)
+2 SET X0=$$CPT^ICPTCOD(IEN)
IF X0<0
QUIT "^"
+3 ;CPT Code^Short Name
SET Y=$PIECE(X0,U,2,3)
+4 ;CPT Description
SET N=$$CPTD^ICPTCOD($PIECE(Y,U),"NHX")
+5 IF N>0
IF $LENGTH($GET(NHX(1)))
Begin DoDot:1
+6 SET X=$GET(NHX(1))
SET I=1
+7 FOR
SET I=$ORDER(NHX(I))
if I<1
QUIT
if NHX(I)=" "
QUIT
SET X=X_" "_NHX(I)
+8 SET $PIECE(Y,U,2)=X
End DoDot:1
+9 QUIT Y
+10 ;
RPT(DFN,ID,RPT) ; -- return report as a TIU document
+1 SET DFN=+$GET(DFN)
SET ID=$GET(ID)
if DFN<1
QUIT
if ID<1
QUIT
+2 NEW EXAM,CASE,PROC,X0,I,X,Y,IENS
+3 SET EXAM=DFN_U_$TRANSLATE(ID,"-","^")
Begin DoDot:1
+4 NEW DFN
DO EN3^RAO7PC3(EXAM)
End DoDot:1
+5 SET CASE=$ORDER(^TMP($JOB,"RAE3",DFN,0))
SET PROC=$ORDER(^(CASE,""))
SET X0=$GET(^(PROC))
+6 SET I=$ORDER(^TMP($JOB,"RAE3",DFN,CASE,PROC,0))
SET Y=$GET(^(I))
+7 FOR
SET I=$ORDER(^TMP($JOB,"RAE3",DFN,CASE,PROC,I))
if I<1
QUIT
SET X=^(I)
SET Y=Y_$CHAR(13,10)_X
+8 SET RPT("id")=ID
SET RPT("content")=Y
+9 SET X=9999999.9999-(+ID)
SET RPT("referenceDateTime")=X
+10 SET RPT("localTitle")=PROC
SET RPT("status")=$PIECE(X0,U)
+11 SET IENS=+ID_","_DFN_","
SET X=$$GET1^DIQ(70.02,IENS,4,"I")
+12 SET RPT("facility")=$$FAC^NHINV(X)
+13 SET IENS=$PIECE(ID,"-",2)_","_IENS
+14 SET RPT("encounter")=$$GET1^DIQ(70.03,IENS,27,"I")
+15 SET X=$$GET1^DIQ(70.03,IENS,15,"I")
if 'X
SET X=$$GET1^DIQ(70.03,IENS,12,"I")
+16 IF X
SET RPT("clinician",1)=X_U_$PIECE($GET(^VA(200,X,0)),U)
+17 KILL ^TMP($JOB,"RAE3",DFN)
+18 QUIT
+19 ;
+20 ; ------------ Return data to middle tier ------------
+21 ;
XML(EXM) ; -- Return exams as XML
+1 NEW ATT,X,Y,NAMES
+2 DO ADD("<radiology>")
SET NHINTOTL=$GET(NHINTOTL)+1
+3 SET ATT=""
FOR
SET ATT=$ORDER(EXM(ATT))
if ATT=""
QUIT
Begin DoDot:1
+4 SET NAMES=$SELECT(ATT="document":"id^localTitle^nationalTitle^status^Z",1:"code^name^Z")
+5 ;multiples
IF $ORDER(EXM(ATT,0))
Begin DoDot:2
+6 DO ADD("<"_ATT_"s>")
+7 SET I=0
FOR
SET I=$ORDER(EXM(ATT,I))
if I<1
QUIT
Begin DoDot:3
+8 SET X=$GET(EXM(ATT,I))
+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(EXM(ATT))
SET Y=""
if '$LENGTH(X)
QUIT
+12 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^NHINV(X)_"' />"
QUIT
+13 IF $LENGTH(X)>1
SET Y="<"_ATT_" "_$$LOOP_"/>"
End DoDot:1
if $LENGTH(Y)
DO ADD(Y)
+14 DO ADD("</radiology>")
+15 QUIT
+16 ;
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
