RAO7PC2 ;HISC/GJC-Part two for Return Narrative (EN3^RAO7PC1) ; Sep 11, 2023@14:32:30
;;5.0;Radiology/Nuclear Medicine;**1,11,14,16,22,27,45,75,56,95,97,143,206**;Mar 16, 1998;Build 8
;Per VHA Directive 2004-038, this routine should not be modified.
;Supported IA #1571 ^LEX(757.01
;Supported IA #10104 UP^XLFSTR
;Supported IA #2055 EXTERNAL^DILFD
;Supported IA #10060 ^VA(200
CASE(Y) ; Retrieve exam data for specified inverse exam date range.
; 'Y'-> Exam node IEN
N RABNOR,RACNT,RAEXAM,RAI,RAIMPRES,RAINCLUD,RAOPRC,RAORD,RAPDIAG
N RAPIST,RAPIRE,RAPROC,RARDE,RADTI,RACNI,RADUPHX,RAREASDY
N RARPT,RARPTST,RARPTXT,RASBN,RASDIAG,RAVER,RAERRFLG,Z,Z1,Z2,RATMP
S RACNT=1
S RAEXAM(0)=$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,0)) Q:RAEXAM(0)']""
S:$P(RAEXAM(0),"^",25)=2 RAPSET=1
S:RAPSET=1 ^TMP($J,"RAE2",RADFN,"PRINT_SET")="" ; xam set with same rpt
S RAPROC(0)=$G(^RAMIS(71,+$P(RAEXAM(0),"^",2),0))
S RAPROC=$S($P(RAPROC(0),"^")]"":$P(RAPROC(0),"^"),1:"Unknown")
S RAORD(0)=$G(^RAO(75.1,+$P(RAEXAM(0),"^",11),0))
S RAORD(7)=$P(RAORD(0),"^",7) ; CPRS order ien
S RAREASDY=$P($G(^RAO(75.1,+$P(RAEXAM(0),"^",11),.1)),"^") ;REASON FOR STUDY
S RAOPRC(0)=$G(^RAMIS(71,+$P(RAORD(0),"^",2),0))
S RAOPRC=$S($P(RAOPRC(0),"^")]"":$P(RAOPRC(0),"^"),1:"Unknown")
S RAPDIAG(0)=$G(^RA(78.3,+$P(RAEXAM(0),"^",13),0))
;p206/KLM - EXPRESSION field (#6) deprecated. Use DISPLAY TEXT field (#100)
;S RATMP=$$GET1^DIQ(757.01,$P($G(^RA(78.3,+$P(RAEXAM(0),U,13),0)),U,6),.01)
S RATMP=$P($G(^RA(78.3,+$P(RAEXAM(0),U,13),1)),U)
;p206 end
S RAPDIAG=$P(RAPDIAG(0),"^")_$S(RATMP="":"",1:" ("_RATMP_")")
S RARPT=+$P(RAEXAM(0),"^",17)
; RARPTST="NO REPORT" if no ^RARPT(ien) OR no data for Report Status
S RARPT(0)=$G(^RARPT(RARPT,0)),RARPTST=$$UL^RAO7PC1A($$RSTAT^RAO7PC1A())
; set the following flag variable: RAINCLUD
; RAINCLUD=1 includes V, R, EF <-- patch 95
S RAINCLUD=$S("RVE"[$E(RARPTST):1,1:0)
I $E(RARPTST)="V",(RAPSET'<0) D
. S RAVER=$P(RARPT(0),"^",9),RASBN=$P($G(^VA(200,+RAVER,20)),"^",2)
. S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"V")=RAVER_"^"_RASBN
. Q
S RABNOR=$$UP^XLFSTR($P(RAPDIAG(0),"^",4)) S:RABNOR'="Y" RABNOR=""
I RAPDIAG]"",(RAINCLUD),(RAPSET'<0) D ; if diag & verif'd or released/unverif'd & first pass if part of xam set (many xams - one rpt)
. S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"D",RACNT)=RAPDIAG
. Q
S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"RFS")=RAREASDY ;REASON FOR STUDY
; 1st, get clnhist from file70. 2nd, get addl clnhist form file74
; 1st:
I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"H",0)) D
. N RAI S (RAI,Z)=0
. F S Z=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"H",Z)) Q:Z'>0 D
.. S RAI=RAI+1
.. S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"H",RAI)=$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"H",Z,0))
.. Q
. Q
;2nd:
S RADTI=RAINVXDT,RACNI=Y D CHKDUPHX^RART1 ;chk if file74 clnhist is dupl
I 'RADUPHX,$O(^RARPT(RARPT,"H",0)) S Z="H" D RPTXT(RARPT,Z)
;
I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"M",0)) D ; save modifiers
. N RAI S (RAI,Z)=0
. F S Z=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"M",Z)) Q:Z'>0 D
.. S RAI=RAI+1
.. S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"M",RAI)=$P($G(^RAMIS(71.2,+$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"M",Z,0)),0)),"^")
.. Q
. Q
I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"DX",0)),(RAPSET'<0) D
. S Z=0 F S Z=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"DX",Z)) Q:Z'>0 D
.. S RASDIAG=+$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"DX",Z,0))
.. S RASDIAG(0)=$G(^RA(78.3,RASDIAG,0))
.. ;p206 - EXPRESSION field (#6) deprecated. Use DISPLAY TEXT field (#100)
.. ;S RATMP=$$GET1^DIQ(757.01,$P($G(^RA(78.3,+RASDIAG,0)),U,6),.01)
.. S RATMP=$P($G(^RA(78.3,+RASDIAG,1)),U)
.. S RASDIAG(1)=$P(RASDIAG(0),"^")_$S(RATMP="":"",1:" ("_RATMP_")")
.. I RASDIAG(1)]"",(RAINCLUD) D
... S RACNT=RACNT+1,^TMP($J,"RAE2",RADFN,Y,RAPROC,"D",RACNT)=RASDIAG(1)
... I RABNOR'="Y" D
.... S RABNOR=$$UP^XLFSTR($P(RASDIAG(0),"^",4)) S:RABNOR'="Y" RABNOR=""
.... Q
... Q
.. Q
. Q
I RAINCLUD,(RAPSET'<0) D
. I +$O(^RARPT(RARPT,"I",0)) S Z="I" D RPTXT(RARPT,Z)
. I +$O(^RARPT(RARPT,"R",0)) S Z="R" D RPTXT(RARPT,Z)
. Q
I $P(RAEXAM(0),"^",25) S ^TMP($J,"RAE2",RADFN,"ORD")=RAOPRC
I '$P(RAEXAM(0),"^",25) S ^TMP($J,"RAE2",RADFN,"ORD",Y)=RAOPRC
;
; Check to see if amended report
I RAPSET'<0,+$O(^RARPT(RARPT,"ERR",0)) S RAERRFLG="A"
;
S:RAPSET'<0 ^TMP($J,"RAE2",RADFN,Y,RAPROC)=RARPTST_"^"_$G(RABNOR)_"^"_$G(RAORD(7))_"^"_$G(RAERRFLG)
S:RAPSET<0 ^TMP($J,"RAE2",RADFN,Y,RAPROC)=""
S:RAPSET=1 RAPSET=-1
; Patch RA*5.0*143 Add datetime subscript for use in RAORD61
S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"DTI",RAINVXDT)=""
;
I RARPTST'="No Report" D
.; Add Prim Int Staff, Prim Int Resident & Reported Date
.S RAPIST=$P(RAEXAM(0),"^",15)
.S RAPIRE=$P(RAEXAM(0),"^",12)
.S RARDE=$P(RARPT(0),"^",8)
.S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"P")=RAPIST_"^"_RAPIRE_"^"_RARDE
;If contrast media was involved in the exam pass that information.
I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"CM",0)) S (RACNT,RAI)=0 D
.F S RAI=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"CM",RAI)) Q:'RAI D
..S RACNT=RACNT+1
..S RAI(0)=$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"CM",RAI,0))
..S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"CM",RACNT)=$P(RAI(0),U)_"^"_$$EXTERNAL^DILFD(70.3225,.01,"",$P(RAI(0),U))
..Q
Q
;
RPTXT(RARPT,Z) ; Retrieve report text & store in ^TMP
; 'RARPT' -> Report IEN
; 'Z' -> "I":Impression Text <> "R":Report Text
S (Z1,Z2)=0
;file 74's "H" nodes are now additional clinical history
I Z="H" S Z2=$O(^TMP($J,"RAE2",RADFN,Y,RAPROC,Z,""),-1) I $O(^RARPT(RARPT,Z,Z1)) S Z2=Z2+1,^TMP($J,"RAE2",RADFN,Y,RAPROC,Z,Z2)="Additional Clinical History:"
F S Z1=$O(^RARPT(RARPT,Z,Z1)) Q:Z1'>0 D
. S Z1(0)=$G(^RARPT(RARPT,Z,Z1,0)),Z2=Z2+1
. S ^TMP($J,"RAE2",RADFN,Y,RAPROC,Z,Z2)=Z1(0)
. Q
Q
;
CLIN(DFN,PROCLIST) ;Radiology and Clinical Reminders API
;
; Created by Cameron Taylor March 1999
;
; This API recieves a patient and a list of procedures. For each
; Procedure, the details of the last 'complete' procedure and/or the
; last 'cancelled' & 'in progress' procedure details and returns them
; in ^TMP($J,"RADPROC"
N XX,PROC,DATE,STATUS,PROVIDER,EXAM,X,Y,EXAMIEN,RADPTIEN,ORDER,SUCCESS
;
S DFN=$G(DFN) ; Patient Name
S PROCLIST=$G(PROCLIST) ; List of Procedures (separated by '^')
K ^TMP($J,"RADPROC")
;
S RADPTIEN=$O(^RADPT("B",DFN,""))
I (RADPTIEN="")!(RADPTIEN=0) D Q
.S ^TMP($J,"RADPROC")="Invalid/Unknown Radiology Patient"
;
F XX=1:1 S PROC=$P(PROCLIST,U,XX) Q:PROC="" D
.S SUCCESS=0 ; Quit searching if SUCCESS=3 (comp, canc & in prog)
.S DATE=0 F S DATE=$O(^RADPT(RADPTIEN,"DT",DATE)) Q:DATE'?7N1".".N!(SUCCESS=3) D
..S EXAMIEN=0 F S EXAMIEN=$O(^RADPT(RADPTIEN,"DT",DATE,"P",EXAMIEN)) Q:'EXAMIEN!(SUCCESS=3) D
...S EXAM=$G(^RADPT(RADPTIEN,"DT",DATE,"P",EXAMIEN,0))
...Q:$P(EXAM,U,2)'=PROC
...;
...; Continue, get STATUS and ORDER
...; (0 is cancelled, 1-8 in progress & 9 is COMPLETE)
...; (ignore if null)
...;
...S STATUS=$P(EXAM,U,3)
...I STATUS'="" D
....S ORDER=$P(^RA(72,STATUS,0),U,3)
....S STATUS=$P(^RA(72,STATUS,0),U) ; description
...;
...; Only one of each type (ORDER)
...;
...Q:ORDER=""
...I ORDER=0 Q:$D(^TMP($J,"RADPROC",RADPTIEN,PROC,"CANCELLED")) S ORDER="CANCELLED"
...I ORDER=9 Q:$D(^TMP($J,"RADPROC",RADPTIEN,PROC,"COMPLETE")) S ORDER="COMPLETE"
...I ORDER<9,ORDER>0 Q:$D(^TMP($J,"RADPROC",RADPTIEN,PROC,"IN PROGRESS")) S ORDER="IN PROGRESS"
...;
...; Now for the PROVIDER. Check PRIMARY INTERPRETING STAFF
...; if none, then default to PRIMARY INTERPRETING RESIDENT.
...;
...S PROVIDER=$P(EXAM,U,15)
...S:PROVIDER="" PROVIDER=$P(EXAM,U,12)
...S:PROVIDER'="" PROVIDER=$P($G(^VA(200,PROVIDER,0)),U,1) ; description
...;
...; Create return info. on ^TMP (1st manipulate DATE)
...;
...S Y=9999999.9999-DATE
...S ^TMP($J,"RADPROC",RADPTIEN,PROC,ORDER)=Y_U_STATUS_U_PROVIDER
...S SUCCESS=SUCCESS+1
.;
.; Finished searching Patient file. Any Procedures with no activity?
.;
.I '$D(^TMP($J,"RADPROC",RADPTIEN,PROC)) S ^TMP($J,"RADPROC",RADPTIEN,PROC,"NONE")=""
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAO7PC2 8144 printed Dec 13, 2024@02:37:47 Page 2
RAO7PC2 ;HISC/GJC-Part two for Return Narrative (EN3^RAO7PC1) ; Sep 11, 2023@14:32:30
+1 ;;5.0;Radiology/Nuclear Medicine;**1,11,14,16,22,27,45,75,56,95,97,143,206**;Mar 16, 1998;Build 8
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;Supported IA #1571 ^LEX(757.01
+4 ;Supported IA #10104 UP^XLFSTR
+5 ;Supported IA #2055 EXTERNAL^DILFD
+6 ;Supported IA #10060 ^VA(200
CASE(Y) ; Retrieve exam data for specified inverse exam date range.
+1 ; 'Y'-> Exam node IEN
+2 NEW RABNOR,RACNT,RAEXAM,RAI,RAIMPRES,RAINCLUD,RAOPRC,RAORD,RAPDIAG
+3 NEW RAPIST,RAPIRE,RAPROC,RARDE,RADTI,RACNI,RADUPHX,RAREASDY
+4 NEW RARPT,RARPTST,RARPTXT,RASBN,RASDIAG,RAVER,RAERRFLG,Z,Z1,Z2,RATMP
+5 SET RACNT=1
+6 SET RAEXAM(0)=$GET(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,0))
if RAEXAM(0)']""
QUIT
+7 if $PIECE(RAEXAM(0),"^",25)=2
SET RAPSET=1
+8 ; xam set with same rpt
if RAPSET=1
SET ^TMP($JOB,"RAE2",RADFN,"PRINT_SET")=""
+9 SET RAPROC(0)=$GET(^RAMIS(71,+$PIECE(RAEXAM(0),"^",2),0))
+10 SET RAPROC=$SELECT($PIECE(RAPROC(0),"^")]"":$PIECE(RAPROC(0),"^"),1:"Unknown")
+11 SET RAORD(0)=$GET(^RAO(75.1,+$PIECE(RAEXAM(0),"^",11),0))
+12 ; CPRS order ien
SET RAORD(7)=$PIECE(RAORD(0),"^",7)
+13 ;REASON FOR STUDY
SET RAREASDY=$PIECE($GET(^RAO(75.1,+$PIECE(RAEXAM(0),"^",11),.1)),"^")
+14 SET RAOPRC(0)=$GET(^RAMIS(71,+$PIECE(RAORD(0),"^",2),0))
+15 SET RAOPRC=$SELECT($PIECE(RAOPRC(0),"^")]"":$PIECE(RAOPRC(0),"^"),1:"Unknown")
+16 SET RAPDIAG(0)=$GET(^RA(78.3,+$PIECE(RAEXAM(0),"^",13),0))
+17 ;p206/KLM - EXPRESSION field (#6) deprecated. Use DISPLAY TEXT field (#100)
+18 ;S RATMP=$$GET1^DIQ(757.01,$P($G(^RA(78.3,+$P(RAEXAM(0),U,13),0)),U,6),.01)
+19 SET RATMP=$PIECE($GET(^RA(78.3,+$PIECE(RAEXAM(0),U,13),1)),U)
+20 ;p206 end
+21 SET RAPDIAG=$PIECE(RAPDIAG(0),"^")_$SELECT(RATMP="":"",1:" ("_RATMP_")")
+22 SET RARPT=+$PIECE(RAEXAM(0),"^",17)
+23 ; RARPTST="NO REPORT" if no ^RARPT(ien) OR no data for Report Status
+24 SET RARPT(0)=$GET(^RARPT(RARPT,0))
SET RARPTST=$$UL^RAO7PC1A($$RSTAT^RAO7PC1A())
+25 ; set the following flag variable: RAINCLUD
+26 ; RAINCLUD=1 includes V, R, EF <-- patch 95
+27 SET RAINCLUD=$SELECT("RVE"[$EXTRACT(RARPTST):1,1:0)
+28 IF $EXTRACT(RARPTST)="V"
IF (RAPSET'<0)
Begin DoDot:1
+29 SET RAVER=$PIECE(RARPT(0),"^",9)
SET RASBN=$PIECE($GET(^VA(200,+RAVER,20)),"^",2)
+30 SET ^TMP($JOB,"RAE2",RADFN,Y,RAPROC,"V")=RAVER_"^"_RASBN
+31 QUIT
End DoDot:1
+32 SET RABNOR=$$UP^XLFSTR($PIECE(RAPDIAG(0),"^",4))
if RABNOR'="Y"
SET RABNOR=""
+33 ; if diag & verif'd or released/unverif'd & first pass if part of xam set (many xams - one rpt)
IF RAPDIAG]""
IF (RAINCLUD)
IF (RAPSET'<0)
Begin DoDot:1
+34 SET ^TMP($JOB,"RAE2",RADFN,Y,RAPROC,"D",RACNT)=RAPDIAG
+35 QUIT
End DoDot:1
+36 ;REASON FOR STUDY
SET ^TMP($JOB,"RAE2",RADFN,Y,RAPROC,"RFS")=RAREASDY
+37 ; 1st, get clnhist from file70. 2nd, get addl clnhist form file74
+38 ; 1st:
+39 IF +$ORDER(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"H",0))
Begin DoDot:1
+40 NEW RAI
SET (RAI,Z)=0
+41 FOR
SET Z=$ORDER(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"H",Z))
if Z'>0
QUIT
Begin DoDot:2
+42 SET RAI=RAI+1
+43 SET ^TMP($JOB,"RAE2",RADFN,Y,RAPROC,"H",RAI)=$GET(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"H",Z,0))
+44 QUIT
End DoDot:2
+45 QUIT
End DoDot:1
+46 ;2nd:
+47 ;chk if file74 clnhist is dupl
SET RADTI=RAINVXDT
SET RACNI=Y
DO CHKDUPHX^RART1
+48 IF 'RADUPHX
IF $ORDER(^RARPT(RARPT,"H",0))
SET Z="H"
DO RPTXT(RARPT,Z)
+49 ;
+50 ; save modifiers
IF +$ORDER(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"M",0))
Begin DoDot:1
+51 NEW RAI
SET (RAI,Z)=0
+52 FOR
SET Z=$ORDER(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"M",Z))
if Z'>0
QUIT
Begin DoDot:2
+53 SET RAI=RAI+1
+54 SET ^TMP($JOB,"RAE2",RADFN,Y,RAPROC,"M",RAI)=$PIECE($GET(^RAMIS(71.2,+$GET(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"M",Z,0)),0)),"^")
+55 QUIT
End DoDot:2
+56 QUIT
End DoDot:1
+57 IF +$ORDER(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"DX",0))
IF (RAPSET'<0)
Begin DoDot:1
+58 SET Z=0
FOR
SET Z=$ORDER(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"DX",Z))
if Z'>0
QUIT
Begin DoDot:2
+59 SET RASDIAG=+$GET(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"DX",Z,0))
+60 SET RASDIAG(0)=$GET(^RA(78.3,RASDIAG,0))
+61 ;p206 - EXPRESSION field (#6) deprecated. Use DISPLAY TEXT field (#100)
+62 ;S RATMP=$$GET1^DIQ(757.01,$P($G(^RA(78.3,+RASDIAG,0)),U,6),.01)
+63 SET RATMP=$PIECE($GET(^RA(78.3,+RASDIAG,1)),U)
+64 SET RASDIAG(1)=$PIECE(RASDIAG(0),"^")_$SELECT(RATMP="":"",1:" ("_RATMP_")")
+65 IF RASDIAG(1)]""
IF (RAINCLUD)
Begin DoDot:3
+66 SET RACNT=RACNT+1
SET ^TMP($JOB,"RAE2",RADFN,Y,RAPROC,"D",RACNT)=RASDIAG(1)
+67 IF RABNOR'="Y"
Begin DoDot:4
+68 SET RABNOR=$$UP^XLFSTR($PIECE(RASDIAG(0),"^",4))
if RABNOR'="Y"
SET RABNOR=""
+69 QUIT
End DoDot:4
+70 QUIT
End DoDot:3
+71 QUIT
End DoDot:2
+72 QUIT
End DoDot:1
+73 IF RAINCLUD
IF (RAPSET'<0)
Begin DoDot:1
+74 IF +$ORDER(^RARPT(RARPT,"I",0))
SET Z="I"
DO RPTXT(RARPT,Z)
+75 IF +$ORDER(^RARPT(RARPT,"R",0))
SET Z="R"
DO RPTXT(RARPT,Z)
+76 QUIT
End DoDot:1
+77 IF $PIECE(RAEXAM(0),"^",25)
SET ^TMP($JOB,"RAE2",RADFN,"ORD")=RAOPRC
+78 IF '$PIECE(RAEXAM(0),"^",25)
SET ^TMP($JOB,"RAE2",RADFN,"ORD",Y)=RAOPRC
+79 ;
+80 ; Check to see if amended report
+81 IF RAPSET'<0
IF +$ORDER(^RARPT(RARPT,"ERR",0))
SET RAERRFLG="A"
+82 ;
+83 if RAPSET'<0
SET ^TMP($JOB,"RAE2",RADFN,Y,RAPROC)=RARPTST_"^"_$GET(RABNOR)_"^"_$GET(RAORD(7))_"^"_$GET(RAERRFLG)
+84 if RAPSET<0
SET ^TMP($JOB,"RAE2",RADFN,Y,RAPROC)=""
+85 if RAPSET=1
SET RAPSET=-1
+86 ; Patch RA*5.0*143 Add datetime subscript for use in RAORD61
+87 SET ^TMP($JOB,"RAE2",RADFN,Y,RAPROC,"DTI",RAINVXDT)=""
+88 ;
+89 IF RARPTST'="No Report"
Begin DoDot:1
+90 ; Add Prim Int Staff, Prim Int Resident & Reported Date
+91 SET RAPIST=$PIECE(RAEXAM(0),"^",15)
+92 SET RAPIRE=$PIECE(RAEXAM(0),"^",12)
+93 SET RARDE=$PIECE(RARPT(0),"^",8)
+94 SET ^TMP($JOB,"RAE2",RADFN,Y,RAPROC,"P")=RAPIST_"^"_RAPIRE_"^"_RARDE
End DoDot:1
+95 ;If contrast media was involved in the exam pass that information.
+96 IF +$ORDER(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"CM",0))
SET (RACNT,RAI)=0
Begin DoDot:1
+97 FOR
SET RAI=$ORDER(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"CM",RAI))
if 'RAI
QUIT
Begin DoDot:2
+98 SET RACNT=RACNT+1
+99 SET RAI(0)=$GET(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"CM",RAI,0))
+100 SET ^TMP($JOB,"RAE2",RADFN,Y,RAPROC,"CM",RACNT)=$PIECE(RAI(0),U)_"^"_$$EXTERNAL^DILFD(70.3225,.01,"",$PIECE(RAI(0),U))
+101 QUIT
End DoDot:2
End DoDot:1
+102 QUIT
+103 ;
RPTXT(RARPT,Z) ; Retrieve report text & store in ^TMP
+1 ; 'RARPT' -> Report IEN
+2 ; 'Z' -> "I":Impression Text <> "R":Report Text
+3 SET (Z1,Z2)=0
+4 ;file 74's "H" nodes are now additional clinical history
+5 IF Z="H"
SET Z2=$ORDER(^TMP($JOB,"RAE2",RADFN,Y,RAPROC,Z,""),-1)
IF $ORDER(^RARPT(RARPT,Z,Z1))
SET Z2=Z2+1
SET ^TMP($JOB,"RAE2",RADFN,Y,RAPROC,Z,Z2)="Additional Clinical History:"
+6 FOR
SET Z1=$ORDER(^RARPT(RARPT,Z,Z1))
if Z1'>0
QUIT
Begin DoDot:1
+7 SET Z1(0)=$GET(^RARPT(RARPT,Z,Z1,0))
SET Z2=Z2+1
+8 SET ^TMP($JOB,"RAE2",RADFN,Y,RAPROC,Z,Z2)=Z1(0)
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
CLIN(DFN,PROCLIST) ;Radiology and Clinical Reminders API
+1 ;
+2 ; Created by Cameron Taylor March 1999
+3 ;
+4 ; This API recieves a patient and a list of procedures. For each
+5 ; Procedure, the details of the last 'complete' procedure and/or the
+6 ; last 'cancelled' & 'in progress' procedure details and returns them
+7 ; in ^TMP($J,"RADPROC"
+8 NEW XX,PROC,DATE,STATUS,PROVIDER,EXAM,X,Y,EXAMIEN,RADPTIEN,ORDER,SUCCESS
+9 ;
+10 ; Patient Name
SET DFN=$GET(DFN)
+11 ; List of Procedures (separated by '^')
SET PROCLIST=$GET(PROCLIST)
+12 KILL ^TMP($JOB,"RADPROC")
+13 ;
+14 SET RADPTIEN=$ORDER(^RADPT("B",DFN,""))
+15 IF (RADPTIEN="")!(RADPTIEN=0)
Begin DoDot:1
+16 SET ^TMP($JOB,"RADPROC")="Invalid/Unknown Radiology Patient"
End DoDot:1
QUIT
+17 ;
+18 FOR XX=1:1
SET PROC=$PIECE(PROCLIST,U,XX)
if PROC=""
QUIT
Begin DoDot:1
+19 ; Quit searching if SUCCESS=3 (comp, canc & in prog)
SET SUCCESS=0
+20 SET DATE=0
FOR
SET DATE=$ORDER(^RADPT(RADPTIEN,"DT",DATE))
if DATE'?7N1".".N!(SUCCESS=3)
QUIT
Begin DoDot:2
+21 SET EXAMIEN=0
FOR
SET EXAMIEN=$ORDER(^RADPT(RADPTIEN,"DT",DATE,"P",EXAMIEN))
if 'EXAMIEN!(SUCCESS=3)
QUIT
Begin DoDot:3
+22 SET EXAM=$GET(^RADPT(RADPTIEN,"DT",DATE,"P",EXAMIEN,0))
+23 if $PIECE(EXAM,U,2)'=PROC
QUIT
+24 ;
+25 ; Continue, get STATUS and ORDER
+26 ; (0 is cancelled, 1-8 in progress & 9 is COMPLETE)
+27 ; (ignore if null)
+28 ;
+29 SET STATUS=$PIECE(EXAM,U,3)
+30 IF STATUS'=""
Begin DoDot:4
+31 SET ORDER=$PIECE(^RA(72,STATUS,0),U,3)
+32 ; description
SET STATUS=$PIECE(^RA(72,STATUS,0),U)
End DoDot:4
+33 ;
+34 ; Only one of each type (ORDER)
+35 ;
+36 if ORDER=""
QUIT
+37 IF ORDER=0
if $DATA(^TMP($JOB,"RADPROC",RADPTIEN,PROC,"CANCELLED"))
QUIT
SET ORDER="CANCELLED"
+38 IF ORDER=9
if $DATA(^TMP($JOB,"RADPROC",RADPTIEN,PROC,"COMPLETE"))
QUIT
SET ORDER="COMPLETE"
+39 IF ORDER<9
IF ORDER>0
if $DATA(^TMP($JOB,"RADPROC",RADPTIEN,PROC,"IN PROGRESS"))
QUIT
SET ORDER="IN PROGRESS"
+40 ;
+41 ; Now for the PROVIDER. Check PRIMARY INTERPRETING STAFF
+42 ; if none, then default to PRIMARY INTERPRETING RESIDENT.
+43 ;
+44 SET PROVIDER=$PIECE(EXAM,U,15)
+45 if PROVIDER=""
SET PROVIDER=$PIECE(EXAM,U,12)
+46 ; description
if PROVIDER'=""
SET PROVIDER=$PIECE($GET(^VA(200,PROVIDER,0)),U,1)
+47 ;
+48 ; Create return info. on ^TMP (1st manipulate DATE)
+49 ;
+50 SET Y=9999999.9999-DATE
+51 SET ^TMP($JOB,"RADPROC",RADPTIEN,PROC,ORDER)=Y_U_STATUS_U_PROVIDER
+52 SET SUCCESS=SUCCESS+1
End DoDot:3
End DoDot:2
+53 ;
+54 ; Finished searching Patient file. Any Procedures with no activity?
+55 ;
+56 IF '$DATA(^TMP($JOB,"RADPROC",RADPTIEN,PROC))
SET ^TMP($JOB,"RADPROC",RADPTIEN,PROC,"NONE")=""
End DoDot:1
+57 QUIT
+58 ;
