RAEDCN1 ;HISC/GJC-Utility routine for RAEDCN ; 20 Apr 2011 7:26 PM
;;5.0;Radiology/Nuclear Medicine;**18,45,93,1003**;Nov 01, 2010;Build 3
; last modif by SS for P18
; 07/15/2008 BAY/KAM rem call 249750 RA*5*93 Correct DIK Calls
UNDEF ; Message for undefined imaging types
I '+$G(RAMLC) D Q
. W !?5,"Imaging Location data is not defined, "
. W "contact IRM.",$C(7)
. Q
W !?5,"An Imaging Type was not defined for the following Imaging"
W !?5,"Location: "_$P(^SC($P($G(^RA(79.1,+RAMLC,0)),U),0),U)_"."
Q
STUB(RARPT) ; Determine if this is an imaging stub report.
; Input: RARPT-ien of the report record
; Output: 1 if an imaging stub rpt, else 0
N RA0 S RA0=$O(^RARPT(RARPT,"L",""),-1) ; most recent activity on rpt
I RA0>0,$P($G(^RARPT(RARPT,"L",RA0,0)),U,2)="C",$P(^RARPT(RARPT,0),U,5)="",$O(^RARPT(RARPT,2005,0)),'$D(^RARPT(RARPT,"I")),'$D(^("P")),'$D(^("R")) Q 1 ; rpt is an image stub
Q 0 ; (non-stub rpt record)
;
PSET(RADFN,RADTI,RACNI) ; Determine if this exam is part of a printset.
; Input: RADFN-patient dfn <-> RADTI-exam timestamp <-> RACNI-exam ien
; Output: 1 if part of a printset, else 0
Q $S($P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",25)=2:1,1:0)
;
CKREASON(X) ;check file 75.2 ; P18 moved it from RAEDCN because the routine's length exceeded limit
; 0=OKAY, 1=BAD
; don't check for var RAOREA, because it's not set this early
I X="C",$O(^RA(75.2,"B","EXAM CANCELLED",0)) Q 0
I X="D",$O(^RA(75.2,"B","EXAM DELETED",0)) Q 0
W !!?5,$S(X="C":"Cancellation",1:"Deletion")," cannot be done, because your file #75.2,"
W !?5,"RAD/NUC MED REASON, does not have ""EXAM ",$S(X="C":"CANCELLED",1:"DELETED"),"""","."
W !!?5,"Please notify your ADPAC.",!
K DIR S DIR(0)="E",DIR("A")="Press RETURN for menu options" D ^DIR K DIR,DIROUT,DIRUT,DTOUT,DUOUT
Q 1
;
DEL ; 'Exam Deletion' option (RA DELETEXAM)
D SETVARS^RAEDCN Q:'($D(RACCESS(DUZ))\10)!('$D(RAIMGTY))
S RAXIT=$$CKREASON^RAEDCN1("D") I RAXIT K RAXIT Q ;P18
DEL1 D ^RACNLU G Q^RAEDCN:X="^"
I RARPT W !?3,$C(7),"A report has been filed for this case. Therefore deletion is not allowed!" G DEL1
ASKDEL R !!,"Do you wish to delete this exam? NO// ",X:DTIME S:'$T!(X="")!(X["^") X="N" G DEL1:"Nn"[$E(X) I "Yy"'[$E(X) W:X'["?" $C(7) W !!,"Enter 'YES' to delete this exam, or 'NO' not to." G ASKDEL
L +^RADPT(RADFN,"DT",RADTI):1 I '$T W !,$C(7),"Someone else is editing an exam for this patient on the date/time",!,"you selected. Please try Later" G DEL1
S RADELFLG="" D ^RAORDC
; trigger RA CANCEL protocol on xam delete if xam not already cancelled
S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),X=+$P(RA7003,"^",3)
; no rpt filed, xam status exists & not cancelled -OR- xam status
; non-existent.
I $P($G(^RA(72,X,0)),U,3)'=0 D
. K RAIENS,RAERR S RAIENS=""_RACNI_","_RADTI_","_RADFN_","_"",RAFDA(70.03,RAIENS,3)="CANCELLED" D FILE^DIE("KSE","RAFDA","RAERR") K RAIENS,RAERR,RAFDA D CANCEL^RAHLRPC
. Q
;IHS/BJI/DAY - Patch 1003 - Add hang to let HL7 messages get created
W !,"Beginning deletion - please wait " H 24
;End Patch
K RA7003 S RABULL="",DA(2)=RADFN,DA(1)=RADTI,DA=RACNI
;S DIK="^RADPT(DA(2),""DT"",DA(1),""P""," D ^DIK
S DIK="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," D ^DIK
W !?10,"...deletion of exam complete."
K %,D,D0,D1,D2,DA,DIC,DIK,RADELFLG,RABULL,RAPRTZ,RAAFTER,RABEFORE
; Check if one exam or multiple exams exists below "DT" node.
; If no exams are present, delete "DT" node.
I '+$O(^RADPT(RADFN,"DT",RADTI,"P",0)) D
. K DA,DIK S DA(1)=RADFN,DA=RADTI
. ; S DIK="^RADPT(DA(1),""DT""," D ^DIK
. S DIK="^RADPT("_DA(1)_",""DT""," D ^DIK
. K DA,DIK Q
L -^RADPT(RADFN,"DT",RADTI)
G DEL1
;
VIEW ; 'View Exam by Case No.' option (RA VIEWCN)
D SETVARS^RAEDCN Q:'($D(RACCESS(DUZ))\10)!('$D(RAIMGTY))
S RAVW="" D ^RACNLU G Q^RAEDCN:X="^" K RAFL D ^RAPROD D Q^RAEDCN G VIEW
;
RAEDCN1 ;HISC/GJC-Utility routine for RAEDCN ; 20 Apr 2011 7:26 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**18,45,93,1003**;Nov 01, 2010;Build 3
+2 ; last modif by SS for P18
+3 ; 07/15/2008 BAY/KAM rem call 249750 RA*5*93 Correct DIK Calls
UNDEF ; Message for undefined imaging types
+1 IF '+$GET(RAMLC)
Begin DoDot:1
+2 WRITE !?5,"Imaging Location data is not defined, "
+3 WRITE "contact IRM.",$CHAR(7)
+4 QUIT
End DoDot:1
QUIT
+5 WRITE !?5,"An Imaging Type was not defined for the following Imaging"
+6 WRITE !?5,"Location: "_$PIECE(^SC($PIECE($GET(^RA(79.1,+RAMLC,0)),U),0),U)_"."
+7 QUIT
STUB(RARPT) ; Determine if this is an imaging stub report.
+1 ; Input: RARPT-ien of the report record
+2 ; Output: 1 if an imaging stub rpt, else 0
+3 ; most recent activity on rpt
NEW RA0
SET RA0=$ORDER(^RARPT(RARPT,"L",""),-1)
+4 ; rpt is an image stub
IF RA0>0
IF $PIECE($GET(^RARPT(RARPT,"L",RA0,0)),U,2)="C"
IF $PIECE(^RARPT(RARPT,0),U,5)=""
IF $ORDER(^RARPT(RARPT,2005,0))
IF '$DATA(^RARPT(RARPT,"I"))
IF '$DATA(^("P"))
IF '$DATA(^("R"))
QUIT 1
+5 ; (non-stub rpt record)
QUIT 0
+6 ;
PSET(RADFN,RADTI,RACNI) ; Determine if this exam is part of a printset.
+1 ; Input: RADFN-patient dfn <-> RADTI-exam timestamp <-> RACNI-exam ien
+2 ; Output: 1 if part of a printset, else 0
+3 QUIT $SELECT($PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",25)=2:1,1:0)
+4 ;
CKREASON(X) ;check file 75.2 ; P18 moved it from RAEDCN because the routine's length exceeded limit
+1 ; 0=OKAY, 1=BAD
+2 ; don't check for var RAOREA, because it's not set this early
+3 IF X="C"
IF $ORDER(^RA(75.2,"B","EXAM CANCELLED",0))
QUIT 0
+4 IF X="D"
IF $ORDER(^RA(75.2,"B","EXAM DELETED",0))
QUIT 0
+5 WRITE !!?5,$SELECT(X="C":"Cancellation",1:"Deletion")," cannot be done, because your file #75.2,"
+6 WRITE !?5,"RAD/NUC MED REASON, does not have ""EXAM ",$SELECT(X="C":"CANCELLED",1:"DELETED"),"""","."
+7 WRITE !!?5,"Please notify your ADPAC.",!
+8 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press RETURN for menu options"
DO ^DIR
KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+9 QUIT 1
+10 ;
DEL ; 'Exam Deletion' option (RA DELETEXAM)
+1 DO SETVARS^RAEDCN
IF '($DATA(RACCESS(DUZ))\10)!('$DATA(RAIMGTY))
QUIT
+2 ;P18
SET RAXIT=$$CKREASON^RAEDCN1("D")
IF RAXIT
KILL RAXIT
QUIT
DEL1 DO ^RACNLU
IF X="^"
GOTO Q^RAEDCN
+1 IF RARPT
WRITE !?3,$CHAR(7),"A report has been filed for this case. Therefore deletion is not allowed!"
GOTO DEL1
ASKDEL READ !!,"Do you wish to delete this exam? NO// ",X:DTIME
IF '$TEST!(X="")!(X["^")
SET X="N"
IF "Nn"[$EXTRACT(X)
GOTO DEL1
IF "Yy"'[$EXTRACT(X)
IF X'["?"
WRITE $CHAR(7)
WRITE !!,"Enter 'YES' to delete this exam, or 'NO' not to."
GOTO ASKDEL
+1 LOCK +^RADPT(RADFN,"DT",RADTI):1
IF '$TEST
WRITE !,$CHAR(7),"Someone else is editing an exam for this patient on the date/time",!,"you selected. Please try Later"
GOTO DEL1
+2 SET RADELFLG=""
DO ^RAORDC
+3 ; trigger RA CANCEL protocol on xam delete if xam not already cancelled
+4 SET RA7003=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
SET X=+$PIECE(RA7003,"^",3)
+5 ; no rpt filed, xam status exists & not cancelled -OR- xam status
+6 ; non-existent.
+7 IF $PIECE($GET(^RA(72,X,0)),U,3)'=0
Begin DoDot:1
+8 KILL RAIENS,RAERR
SET RAIENS=""_RACNI_","_RADTI_","_RADFN_","_""
SET RAFDA(70.03,RAIENS,3)="CANCELLED"
DO FILE^DIE("KSE","RAFDA","RAERR")
KILL RAIENS,RAERR,RAFDA
DO CANCEL^RAHLRPC
+9 QUIT
End DoDot:1
+10 ;IHS/BJI/DAY - Patch 1003 - Add hang to let HL7 messages get created
+11 WRITE !,"Beginning deletion - please wait "
HANG 24
+12 ;End Patch
+13 KILL RA7003
SET RABULL=""
SET DA(2)=RADFN
SET DA(1)=RADTI
SET DA=RACNI
+14 ;S DIK="^RADPT(DA(2),""DT"",DA(1),""P""," D ^DIK
+15 SET DIK="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
DO ^DIK
+16 WRITE !?10,"...deletion of exam complete."
+17 KILL %,D,D0,D1,D2,DA,DIC,DIK,RADELFLG,RABULL,RAPRTZ,RAAFTER,RABEFORE
+18 ; Check if one exam or multiple exams exists below "DT" node.
+19 ; If no exams are present, delete "DT" node.
+20 IF '+$ORDER(^RADPT(RADFN,"DT",RADTI,"P",0))
Begin DoDot:1
+21 KILL DA,DIK
SET DA(1)=RADFN
SET DA=RADTI
+22 ; S DIK="^RADPT(DA(1),""DT""," D ^DIK
+23 SET DIK="^RADPT("_DA(1)_",""DT"","
DO ^DIK
+24 KILL DA,DIK
QUIT
End DoDot:1
+25 LOCK -^RADPT(RADFN,"DT",RADTI)
+26 GOTO DEL1
+27 ;
VIEW ; 'View Exam by Case No.' option (RA VIEWCN)
+1 DO SETVARS^RAEDCN
IF '($DATA(RACCESS(DUZ))\10)!('$DATA(RAIMGTY))
QUIT
+2 SET RAVW=""
DO ^RACNLU
IF X="^"
GOTO Q^RAEDCN
KILL RAFL
DO ^RAPROD
DO Q^RAEDCN
GOTO VIEW
+3 ;
