VPRSDAR ;SLC/MKB -- SDA Radiology utilities ;8/6/18 12:21
;;1.0;VIRTUAL PATIENT RECORD;**8,10,30**;Sep 01, 2011;Build 9
;;Per VHA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^OR(100 5771
; ^RADPT 2480,2588
; ^RARPT 5605
; DIQ 2056
; RAO7PC1 2043,2265
; RAO7PC3 2877
;
PRE ; -- PreProcessing for VPR RAD ORDER
; Expects DFN, DSTRT, DSTOP, DMAX from EN^DDEGET
N BEG,END,MAX,RAORD
S BEG=$G(DSTRT),END=$G(DSTOP),MAX=$G(DMAX)_"P"
I $G(ID) D ;reset for one order
. S RAORD=+$G(^OR(100,+ID,4)) S:'DFN DFN=+$P($G(^(0)),U,2)
. S IDT=$O(^RADPT("AO",RAORD,DFN,0))
. S:IDT (BEG,END)=9999999.9999-IDT
K ^TMP($J,"RAE1") D EN1^RAO7PC1(DFN,BEG,END,MAX)
Q
;
POST ; -- PostProcessing for VPR RAD ORDER
K ^TMP($J,"RAE1",DFN),^TMP($J,"RAE2",DFN)
K VPRAE1,VPRAE2,RARPT,RAPROC,ORPK
Q
;
ONE(RAID) ; -- ID Processing for each VPR RAD RESULT (RAID = #75.1 ien)
; Returns VPRAE1 = ^TMP($J,"RAE1",DFN,Exam ID)
; VPRAE2 = $NA(^TMP($J,"RAE2",DFN,caseIEN,procedureName))
; RARPT = Report #74 IEN
; RAPROC = Procedure name
; RAID = #70.03 IEN string
;
N IDT,CASE,EXAM,TYPE
S IDT=+$O(^RADPT("AO",+$G(RAID),DFN,0)),CASE=+$O(^(IDT,0))
I CASE<1 S DDEOUT=1 Q
S EXAM=IDT_"-"_CASE K RARPT
; get [1st] exam node
S VPRAE1=$G(^TMP($J,"RAE1",DFN,EXAM)),STS=$P(VPRAE1,U,3)
I STS="No Report"!(STS="Deleted")!(STS["Draft")!(STS["Released/Not") S DDEOUT=1 Q
S RARPT=+$P(VPRAE1,U,5) I RARPT<1 S DDEOUT=1 Q
; get report details for [1st] exam/case, save array name for reference
K ^TMP($J,"RAE2") D EN30^RAO7PC1(RAID)
I '$D(^TMP($J,"RAE2",DFN,CASE)) S DDEOUT=1 Q
S VPRAE2=$Q(^TMP($J,"RAE2",DFN)),RAID=CASE_","_IDT_","_DFN
; get procedure for DocumentName, list of report iens if examset
S TYPE=$G(^TMP($J,"RAE1",DFN,EXAM,"CPRS"))
I +TYPE=0 S RAPROC=$P(VPRAE1,U) ;1 case/report
I +TYPE=2 S RAPROC=$P(TYPE,U,2) ;1 report (print set)
I +TYPE=1 S RAPROC=$P(TYPE,U,2) D ;exam set
. N RAE1,RPT S RARPT(CASE)=RARPT_";RA"
. F S CASE=$O(^TMP($J,"RAE2",DFN,CASE)) Q:CASE<1 D
.. S EXAM=IDT_"-"_CASE
.. S RAE1=$G(^TMP($J,"RAE1",DFN,EXAM)),STS=$P(RAE1,U,3)
.. Q:STS="No Report"!(STS="Deleted")!(STS["Draft")!(STS["Released/Not")
.. S RPT=+$P(RAE1,U,5) S:RPT RARPT(CASE)=RPT_";RA"
Q
;
ABN() ; -- return "A" if any report for exam(s) is abnormal, else null
N X,Y,CASE S Y=""
I $D(RARPT)<9 D Q Y
. S Y=$S($P(VPRAE1,U,4)="Y":"A",1:"") ;,$P(VPRAE1,U,9)="Y":"A"
S CASE=0 F S CASE=$O(^TMP($J,"RAE2",DFN,CASE)) Q:CASE<1 D Q:$L(Y)
. S X=$Q(^TMP($J,"RAE2",DFN,CASE))
. S:$P(@X,U,2)="Y" Y="A"
Q Y
;
; -- for Documents container:
;
RPTS ; -- find patient's radiology reports
N VPRN,VPRXID,STS,RARPT
S DFN=+$G(DFN) Q:DFN<1
K ^TMP($J,"RAE1") D EN1^RAO7PC1(DFN,DSTRT,DSTOP,DMAX_"P")
S VPRN=0 ; VPRXID = invdate.time-caseIEN
S VPRXID="" F S VPRXID=$O(^TMP($J,"RAE1",DFN,VPRXID)) Q:VPRXID="" D
. S STS=$P($G(^TMP($J,"RAE1",DFN,VPRXID)),U,3),RARPT=+$P($G(^(VPRXID)),U,5)
. Q:STS="No Report"!(STS="Deleted")!(STS["Draft")!(STS["Released/Not")
. Q:RARPT<1 Q:$D(RARPT(RARPT)) ;already have report, for sets
. S VPRN=+$G(VPRN)+1,DLIST(VPRN)=RARPT_"~"_VPRXID
. S RARPT(+RARPT)=""
K ^TMP($J,"RAE1")
Q
;
RPT1 ; -- ID Processing for each VPR RAD REPORT
; Returns VPRXID = Exam-Case ID
; VPRAE2 = $NA(^TMP($J,"RAE2",DFN,caseIEN,procedureName))
; VPRAE3 = $NA(^TMP($J,"RAE3",DFN,caseIEN,procedureName))
; RAPROC = Procedure name
;
N RA0,X
S VPRXID=$P(DIEN,"~",2),DIEN=+$P(DIEN,"~")
S RA0=$G(^RARPT(DIEN,0)) S:DFN<1 DFN=+$P(RA0,U,2)
I 'VPRXID D
. N I S VPRXID=9999999.9999-$P(RA0,U,3),I=0
. F S I=$O(^RADPT(DFN,"DT",VPRXID,"P",I)) Q:I<1 I $P($G(^(I,0)),U,17)=DIEN S VPRXID=VPRXID_"-"_I Q
I $L(VPRXID,"-")<2 S DDEOUT=1 Q
S X=DFN_U_$TR(VPRXID,"-","^") D
. N DFN,RACNT,RAMDIV,RAWHOVER,RAPRTSET
. K ^TMP($J,"RAE2"),^TMP($J,"RAE3")
. D EN3^RAO7PC1(X),EN3^RAO7PC3(X)
S VPRAE2=$Q(^TMP($J,"RAE2",DFN)),VPRAE3=$Q(^TMP($J,"RAE3",DFN))
; get [ordered] procedure for document name
I $D(^TMP($J,"RAE3",DFN,"PRINT_SET")) S RAPROC=$G(^("ORD"))
E S RAPROC=$QS(VPRAE3,5)
Q
;
VNUM(DFN,EXAMID) ; -- return Visit# for patient, examID
N I,IDT,IENS,Y
S I=+$P(EXAMID,"-",2),IDT=$P(EXAMID,"-"),IENS=I_","_IDT_","_DFN_","
S Y=$$GET1^DIQ(70.03,IENS,27,"I")
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDAR 4571 printed Sep 02, 2024@19:31:13 Page 2
VPRSDAR ;SLC/MKB -- SDA Radiology utilities ;8/6/18 12:21
+1 ;;1.0;VIRTUAL PATIENT RECORD;**8,10,30**;Sep 01, 2011;Build 9
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^OR(100 5771
+7 ; ^RADPT 2480,2588
+8 ; ^RARPT 5605
+9 ; DIQ 2056
+10 ; RAO7PC1 2043,2265
+11 ; RAO7PC3 2877
+12 ;
PRE ; -- PreProcessing for VPR RAD ORDER
+1 ; Expects DFN, DSTRT, DSTOP, DMAX from EN^DDEGET
+2 NEW BEG,END,MAX,RAORD
+3 SET BEG=$GET(DSTRT)
SET END=$GET(DSTOP)
SET MAX=$GET(DMAX)_"P"
+4 ;reset for one order
IF $GET(ID)
Begin DoDot:1
+5 SET RAORD=+$GET(^OR(100,+ID,4))
if 'DFN
SET DFN=+$PIECE($GET(^(0)),U,2)
+6 SET IDT=$ORDER(^RADPT("AO",RAORD,DFN,0))
+7 if IDT
SET (BEG,END)=9999999.9999-IDT
End DoDot:1
+8 KILL ^TMP($JOB,"RAE1")
DO EN1^RAO7PC1(DFN,BEG,END,MAX)
+9 QUIT
+10 ;
POST ; -- PostProcessing for VPR RAD ORDER
+1 KILL ^TMP($JOB,"RAE1",DFN),^TMP($JOB,"RAE2",DFN)
+2 KILL VPRAE1,VPRAE2,RARPT,RAPROC,ORPK
+3 QUIT
+4 ;
ONE(RAID) ; -- ID Processing for each VPR RAD RESULT (RAID = #75.1 ien)
+1 ; Returns VPRAE1 = ^TMP($J,"RAE1",DFN,Exam ID)
+2 ; VPRAE2 = $NA(^TMP($J,"RAE2",DFN,caseIEN,procedureName))
+3 ; RARPT = Report #74 IEN
+4 ; RAPROC = Procedure name
+5 ; RAID = #70.03 IEN string
+6 ;
+7 NEW IDT,CASE,EXAM,TYPE
+8 SET IDT=+$ORDER(^RADPT("AO",+$GET(RAID),DFN,0))
SET CASE=+$ORDER(^(IDT,0))
+9 IF CASE<1
SET DDEOUT=1
QUIT
+10 SET EXAM=IDT_"-"_CASE
KILL RARPT
+11 ; get [1st] exam node
+12 SET VPRAE1=$GET(^TMP($JOB,"RAE1",DFN,EXAM))
SET STS=$PIECE(VPRAE1,U,3)
+13 IF STS="No Report"!(STS="Deleted")!(STS["Draft")!(STS["Released/Not")
SET DDEOUT=1
QUIT
+14 SET RARPT=+$PIECE(VPRAE1,U,5)
IF RARPT<1
SET DDEOUT=1
QUIT
+15 ; get report details for [1st] exam/case, save array name for reference
+16 KILL ^TMP($JOB,"RAE2")
DO EN30^RAO7PC1(RAID)
+17 IF '$DATA(^TMP($JOB,"RAE2",DFN,CASE))
SET DDEOUT=1
QUIT
+18 SET VPRAE2=$QUERY(^TMP($JOB,"RAE2",DFN))
SET RAID=CASE_","_IDT_","_DFN
+19 ; get procedure for DocumentName, list of report iens if examset
+20 SET TYPE=$GET(^TMP($JOB,"RAE1",DFN,EXAM,"CPRS"))
+21 ;1 case/report
IF +TYPE=0
SET RAPROC=$PIECE(VPRAE1,U)
+22 ;1 report (print set)
IF +TYPE=2
SET RAPROC=$PIECE(TYPE,U,2)
+23 ;exam set
IF +TYPE=1
SET RAPROC=$PIECE(TYPE,U,2)
Begin DoDot:1
+24 NEW RAE1,RPT
SET RARPT(CASE)=RARPT_";RA"
+25 FOR
SET CASE=$ORDER(^TMP($JOB,"RAE2",DFN,CASE))
if CASE<1
QUIT
Begin DoDot:2
+26 SET EXAM=IDT_"-"_CASE
+27 SET RAE1=$GET(^TMP($JOB,"RAE1",DFN,EXAM))
SET STS=$PIECE(RAE1,U,3)
+28 if STS="No Report"!(STS="Deleted")!(STS["Draft")!(STS["Released/Not")
QUIT
+29 SET RPT=+$PIECE(RAE1,U,5)
if RPT
SET RARPT(CASE)=RPT_";RA"
End DoDot:2
End DoDot:1
+30 QUIT
+31 ;
ABN() ; -- return "A" if any report for exam(s) is abnormal, else null
+1 NEW X,Y,CASE
SET Y=""
+2 IF $DATA(RARPT)<9
Begin DoDot:1
+3 ;,$P(VPRAE1,U,9)="Y":"A"
SET Y=$SELECT($PIECE(VPRAE1,U,4)="Y":"A",1:"")
End DoDot:1
QUIT Y
+4 SET CASE=0
FOR
SET CASE=$ORDER(^TMP($JOB,"RAE2",DFN,CASE))
if CASE<1
QUIT
Begin DoDot:1
+5 SET X=$QUERY(^TMP($JOB,"RAE2",DFN,CASE))
+6 if $PIECE(@X,U,2)="Y"
SET Y="A"
End DoDot:1
if $LENGTH(Y)
QUIT
+7 QUIT Y
+8 ;
+9 ; -- for Documents container:
+10 ;
RPTS ; -- find patient's radiology reports
+1 NEW VPRN,VPRXID,STS,RARPT
+2 SET DFN=+$GET(DFN)
if DFN<1
QUIT
+3 KILL ^TMP($JOB,"RAE1")
DO EN1^RAO7PC1(DFN,DSTRT,DSTOP,DMAX_"P")
+4 ; VPRXID = invdate.time-caseIEN
SET VPRN=0
+5 SET VPRXID=""
FOR
SET VPRXID=$ORDER(^TMP($JOB,"RAE1",DFN,VPRXID))
if VPRXID=""
QUIT
Begin DoDot:1
+6 SET STS=$PIECE($GET(^TMP($JOB,"RAE1",DFN,VPRXID)),U,3)
SET RARPT=+$PIECE($GET(^(VPRXID)),U,5)
+7 if STS="No Report"!(STS="Deleted")!(STS["Draft")!(STS["Released/Not")
QUIT
+8 ;already have report, for sets
if RARPT<1
QUIT
if $DATA(RARPT(RARPT))
QUIT
+9 SET VPRN=+$GET(VPRN)+1
SET DLIST(VPRN)=RARPT_"~"_VPRXID
+10 SET RARPT(+RARPT)=""
End DoDot:1
+11 KILL ^TMP($JOB,"RAE1")
+12 QUIT
+13 ;
RPT1 ; -- ID Processing for each VPR RAD REPORT
+1 ; Returns VPRXID = Exam-Case ID
+2 ; VPRAE2 = $NA(^TMP($J,"RAE2",DFN,caseIEN,procedureName))
+3 ; VPRAE3 = $NA(^TMP($J,"RAE3",DFN,caseIEN,procedureName))
+4 ; RAPROC = Procedure name
+5 ;
+6 NEW RA0,X
+7 SET VPRXID=$PIECE(DIEN,"~",2)
SET DIEN=+$PIECE(DIEN,"~")
+8 SET RA0=$GET(^RARPT(DIEN,0))
if DFN<1
SET DFN=+$PIECE(RA0,U,2)
+9 IF 'VPRXID
Begin DoDot:1
+10 NEW I
SET VPRXID=9999999.9999-$PIECE(RA0,U,3)
SET I=0
+11 FOR
SET I=$ORDER(^RADPT(DFN,"DT",VPRXID,"P",I))
if I<1
QUIT
IF $PIECE($GET(^(I,0)),U,17)=DIEN
SET VPRXID=VPRXID_"-"_I
QUIT
End DoDot:1
+12 IF $LENGTH(VPRXID,"-")<2
SET DDEOUT=1
QUIT
+13 SET X=DFN_U_$TRANSLATE(VPRXID,"-","^")
Begin DoDot:1
+14 NEW DFN,RACNT,RAMDIV,RAWHOVER,RAPRTSET
+15 KILL ^TMP($JOB,"RAE2"),^TMP($JOB,"RAE3")
+16 DO EN3^RAO7PC1(X)
DO EN3^RAO7PC3(X)
End DoDot:1
+17 SET VPRAE2=$QUERY(^TMP($JOB,"RAE2",DFN))
SET VPRAE3=$QUERY(^TMP($JOB,"RAE3",DFN))
+18 ; get [ordered] procedure for document name
+19 IF $DATA(^TMP($JOB,"RAE3",DFN,"PRINT_SET"))
SET RAPROC=$GET(^("ORD"))
+20 IF '$TEST
SET RAPROC=$QSUBSCRIPT(VPRAE3,5)
+21 QUIT
+22 ;
VNUM(DFN,EXAMID) ; -- return Visit# for patient, examID
+1 NEW I,IDT,IENS,Y
+2 SET I=+$PIECE(EXAMID,"-",2)
SET IDT=$PIECE(EXAMID,"-")
SET IENS=I_","_IDT_","_DFN_","
+3 SET Y=$$GET1^DIQ(70.03,IENS,27,"I")
+4 QUIT Y
