RARTE7 ;HISC/SM continuation - Delete a Report, Outside Rpt misc;10/10/08 16:05
;;5.0;Radiology/Nuclear Medicine;**56,95,97,103**;Mar 16, 1998;Build 2
;Supported IA #2053 NOW^XLFDT, FILE^DIE, UPDATE^DIE
;Supported IA #2052 GET1^DID
;Supported IA #2055 ROOT^DILFD
;
;04/06/2010 BP/KAM RA*5*103 Remedy Ticket 324541 Outside Reports does
; not generate Imaging Results CPRS Alert
Q
MARKDEL ; set field 5 to "X" to mark rpt as deleted
; also update activity log, send report deletion bulletin, store then delete
; associated DX, Staff, Resident data
N DA,DIK,RA1,RA2,RAA,RAFDA,RAIEN2,RAIENDX,RAIENL,RACLOAK
N RAMEMARR,RAMSG,RAOUT,RAPRTSET,RASAVE,RAX,RA7003
N RAF1,RAF2,RAF3,RAIENS
;
;PART 1 - mark report as deleted
;
S RASAVE=$P(^RARPT(RAIEN,0),U,5) ;save current rpt status
S RAFDA(74,RAIEN_",",5)="X" ;change rpt status
D FILE^DIE("","RAFDA")
K RAFDA
;
;PART 2 - add new entry to ACTIVITY LOG and store primary data
;
S RA7003=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
S RAIENL="+1,"_RAIEN_","
S RAFDA(74.01,RAIENL,.01)=+$E($$NOW^XLFDT(),1,12)
S RAFDA(74.01,RAIENL,2)="X"
S RAFDA(74.01,RAIENL,3)=$G(DUZ)
S RAFDA(74.01,RAIENL,4)=RASAVE ;store before-delete rpt status
S RAFDA(74.01,RAIENL,5)=$P(RA7003,U,13) ; store Prim DX code
S RAFDA(74.01,RAIENL,7)=$P(RA7003,U,15) ; store Prim Staff
S RAFDA(74.01,RAIENL,9)=$P(RA7003,U,12) ; store Prim Resident
D UPDATE^DIE(,"RAFDA","RAOUT","RAMSG")
W:$D(RAMSG("DIERR")) !!,"Could not update deleted Report's Activity Log."
K RAFDA
;
; store Secondary DXs/Staff/Residents under this ACTIVITY LOG
; if printset, no need to store each case's sec DX, they should be same
Q:'RAOUT(1) ;no record set in 74.01
S RAIEN2=RAOUT(1)
;
;PART 3 - send report deletion bulletin
;
D CLOAK^RABUL3 ; requires RAIEN and RAIEN2
;
;PART 4 - store secondary DX, Staff, Resident data
;
;don't need separate logic for printset for storing identical data
F RAFLD=5,7,9 D SET7401(RAFLD)
;
;PART 5 - remove Prim. and Sec. DX, Staff, Resident from case record
;
D EN2^RAUTL20(.RAMEMARR) ; is case part of a printset?
G:RAPRTSET PSET
;
; single case
;
; delete primaries
S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",13)="@" ;Prim. DX
S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",15)="@" ;Prim. Staff
S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",12)="@" ;Prim. Resident
D FILE^DIE("","RAFDA")
K RAFDA
;
; delete secondaries
F RASUB=70.14,70.11,70.09 D KILSEC(RASUB,RACNI)
Q
;
; cases from printset
;
PSET ;delete primary and secondary data
S RA1=0
F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" D
.; delete primary from 70.03
.S RAFDA(70.03,RA1_","_RADTI_","_RADFN_",",13)="@" ;Prim. DX
.S RAFDA(70.03,RA1_","_RADTI_","_RADFN_",",15)="@" ;Prim. Staff
.S RAFDA(70.03,RA1_","_RADTI_","_RADFN_",",12)="@" ;Prim. Resident
.D FILE^DIE("","RAFDA")
.K RAFDA
.F RASUB=70.14,70.11,70.09 D KILSEC(RASUB,RA1)
Q
KILSEC(RAF2,RAC1) ;kill secondary data
;RAF2 subfile number from file 70's secondaries
;RAC1 ien for subfile 70.03
N RAA,RAROOT
K DA,DIK
S RAIENS=1_","_RAC1_","_RADTI_","_RADFN_","
S RAROOT=$$ROOT^DILFD(RAF2,RAIENS,1) ; closed root
M RAA=@RAROOT
Q:$O(RAA(0))'>0 ;no secondaries
D DA^DILF(RAIENS,.DA) ;get the DA array
S DIK=$$ROOT^DILFD(RAF2,RAIENS)
S RA2=0
F S RA2=$O(RAA(RA2)) Q:'RA2 S DA=RA2 D ^DIK
K DIK
Q
SET7401(X) ; use this for DX, Staff, Resident secondaries
; set activity log's subfiles to store any secondaries
K RAFDA,RAMSG,RAA
; X is the Field number from subfile 74.01:
; 5 = BEFORE DELETION PRIM. DX CODE
; 7 = BEFORE DELETION PRIM. STAFF
; 9 = BEFORE DELETION PRIM. RESIDENT
;
; RAF1 = subfile number from file 74's activity log
; RAF2 = subfile number from file 70's secondaries
; RAF3 = subfile number pointed to from file 70's secondaries
;
S RAF1=$S(X=5:74.16,X=7:74.18,X=9:74.19,1:"") Q:RAF1=""
S RAF2=$S(X=5:70.14,X=7:70.11,X=9:70.09,1:"") Q:RAF2=""
S RAIENS=1_","_RACNI_","_RADTI_","_RADFN_","
S RAROOT=$$ROOT^DILFD(RAF2,RAIENS,1) ; closed root, file 70's secondaries
M RAA=@RAROOT
Q:$O(RAA(0))'>0 ; no secondaries
;
S RAF3=$$GET1^DID(RAF2,.01,"","POINTER")
; extract file number from RAF3
S RAF3=$TR(RAF3,$TR(RAF3,"0123456789."))
;
; store Secondary DXs
S RA1=0
S RAIENDX="+2,"_RAIEN2_","_RAIEN_","
F S RA1=$O(RAA(RA1)) Q:'RA1 S RAX=$G(RAA(RA1,0)) D:RAX
.S RAFDA(RAF1,RAIENDX,.01)=RAX
.D UPDATE^DIE(,"RAFDA",,"RAMSG")
.W:$D(RAMSG("DIERR")) !!,"Could not store ",$$GET1^DID(RAF2,.01,"","LABEL"),"'s value: ",$$GET1^DIQ(RAF3,RAX,.01)
.K RAFDA,RAMSG
.Q
Q
ANYDX(ARRAY) ; called from RARTE5
; input ARRAY name to store all DXs for this case
; output:
; =1 if one or more diag codes
; =0 if no diag code
; ARRAY() stores diag codes as merged from case
Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))
K ARRAY
M ARRAY=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX") ;Sec Diags
S ARRAY(9999,0)=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13) ;Prim Diag
I $O(ARRAY(0)) Q 1
Q 0
;
ALERT ; for Outside Report, ck if new/changed diags require alert
; this is called from RARTE5 each time an outside report is edited
Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))
N RASAVE,RAY3,X
; set RASAVE() for OENOTE^RAUTL00
S RASAVE("RADFN")=RADFN,RASAVE("RADTI")=RADTI,RASAVE("RACNI")=RACNI
;
N I
Q:(RANY1=0)&(RANY2=0) ;no diags before and after edit
S I=0
; loop RAA2
F S I=$O(RAA2(I)) Q:'I K:RAA2(I,0)=$G(RAA1(I,0)) RAA2(I,0)
;04/06/2010 BP/KAM RA*5*103 Rem Tkt 324541 Commented out next line
;Q:'$O(RAA2(0))
K RAAB
S I=0 F S I=$O(RAA2(I)) Q:'I D
.I $D(^RA(78.3,+RAA2(I,0),0)),($P(^(0),U,4)="y") S RAAB=1
.Q
; invoke notification for either condition:
; (1) new EF report is made --> non-critical imaging alert
; (2) old/new EF report w abnormal DX --> abnormal alert
; either of the above alert may be from an amended report or not
I $G(RAAB)!RAFIRST D
.S RAY3=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
.S X=RAY3 ; X is input to OENOTE
.D OENOTE^RAUTL00
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRARTE7 6101 printed Sep 23, 2025@20:15:29 Page 2
RARTE7 ;HISC/SM continuation - Delete a Report, Outside Rpt misc;10/10/08 16:05
+1 ;;5.0;Radiology/Nuclear Medicine;**56,95,97,103**;Mar 16, 1998;Build 2
+2 ;Supported IA #2053 NOW^XLFDT, FILE^DIE, UPDATE^DIE
+3 ;Supported IA #2052 GET1^DID
+4 ;Supported IA #2055 ROOT^DILFD
+5 ;
+6 ;04/06/2010 BP/KAM RA*5*103 Remedy Ticket 324541 Outside Reports does
+7 ; not generate Imaging Results CPRS Alert
+8 QUIT
MARKDEL ; set field 5 to "X" to mark rpt as deleted
+1 ; also update activity log, send report deletion bulletin, store then delete
+2 ; associated DX, Staff, Resident data
+3 NEW DA,DIK,RA1,RA2,RAA,RAFDA,RAIEN2,RAIENDX,RAIENL,RACLOAK
+4 NEW RAMEMARR,RAMSG,RAOUT,RAPRTSET,RASAVE,RAX,RA7003
+5 NEW RAF1,RAF2,RAF3,RAIENS
+6 ;
+7 ;PART 1 - mark report as deleted
+8 ;
+9 ;save current rpt status
SET RASAVE=$PIECE(^RARPT(RAIEN,0),U,5)
+10 ;change rpt status
SET RAFDA(74,RAIEN_",",5)="X"
+11 DO FILE^DIE("","RAFDA")
+12 KILL RAFDA
+13 ;
+14 ;PART 2 - add new entry to ACTIVITY LOG and store primary data
+15 ;
+16 SET RA7003=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
+17 SET RAIENL="+1,"_RAIEN_","
+18 SET RAFDA(74.01,RAIENL,.01)=+$EXTRACT($$NOW^XLFDT(),1,12)
+19 SET RAFDA(74.01,RAIENL,2)="X"
+20 SET RAFDA(74.01,RAIENL,3)=$GET(DUZ)
+21 ;store before-delete rpt status
SET RAFDA(74.01,RAIENL,4)=RASAVE
+22 ; store Prim DX code
SET RAFDA(74.01,RAIENL,5)=$PIECE(RA7003,U,13)
+23 ; store Prim Staff
SET RAFDA(74.01,RAIENL,7)=$PIECE(RA7003,U,15)
+24 ; store Prim Resident
SET RAFDA(74.01,RAIENL,9)=$PIECE(RA7003,U,12)
+25 DO UPDATE^DIE(,"RAFDA","RAOUT","RAMSG")
+26 if $DATA(RAMSG("DIERR"))
WRITE !!,"Could not update deleted Report's Activity Log."
+27 KILL RAFDA
+28 ;
+29 ; store Secondary DXs/Staff/Residents under this ACTIVITY LOG
+30 ; if printset, no need to store each case's sec DX, they should be same
+31 ;no record set in 74.01
if 'RAOUT(1)
QUIT
+32 SET RAIEN2=RAOUT(1)
+33 ;
+34 ;PART 3 - send report deletion bulletin
+35 ;
+36 ; requires RAIEN and RAIEN2
DO CLOAK^RABUL3
+37 ;
+38 ;PART 4 - store secondary DX, Staff, Resident data
+39 ;
+40 ;don't need separate logic for printset for storing identical data
+41 FOR RAFLD=5,7,9
DO SET7401(RAFLD)
+42 ;
+43 ;PART 5 - remove Prim. and Sec. DX, Staff, Resident from case record
+44 ;
+45 ; is case part of a printset?
DO EN2^RAUTL20(.RAMEMARR)
+46 if RAPRTSET
GOTO PSET
+47 ;
+48 ; single case
+49 ;
+50 ; delete primaries
+51 ;Prim. DX
SET RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",13)="@"
+52 ;Prim. Staff
SET RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",15)="@"
+53 ;Prim. Resident
SET RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",12)="@"
+54 DO FILE^DIE("","RAFDA")
+55 KILL RAFDA
+56 ;
+57 ; delete secondaries
+58 FOR RASUB=70.14,70.11,70.09
DO KILSEC(RASUB,RACNI)
+59 QUIT
+60 ;
+61 ; cases from printset
+62 ;
PSET ;delete primary and secondary data
+1 SET RA1=0
+2 FOR
SET RA1=$ORDER(RAMEMARR(RA1))
if RA1=""
QUIT
Begin DoDot:1
+3 ; delete primary from 70.03
+4 ;Prim. DX
SET RAFDA(70.03,RA1_","_RADTI_","_RADFN_",",13)="@"
+5 ;Prim. Staff
SET RAFDA(70.03,RA1_","_RADTI_","_RADFN_",",15)="@"
+6 ;Prim. Resident
SET RAFDA(70.03,RA1_","_RADTI_","_RADFN_",",12)="@"
+7 DO FILE^DIE("","RAFDA")
+8 KILL RAFDA
+9 FOR RASUB=70.14,70.11,70.09
DO KILSEC(RASUB,RA1)
End DoDot:1
+10 QUIT
KILSEC(RAF2,RAC1) ;kill secondary data
+1 ;RAF2 subfile number from file 70's secondaries
+2 ;RAC1 ien for subfile 70.03
+3 NEW RAA,RAROOT
+4 KILL DA,DIK
+5 SET RAIENS=1_","_RAC1_","_RADTI_","_RADFN_","
+6 ; closed root
SET RAROOT=$$ROOT^DILFD(RAF2,RAIENS,1)
+7 MERGE RAA=@RAROOT
+8 ;no secondaries
if $ORDER(RAA(0))'>0
QUIT
+9 ;get the DA array
DO DA^DILF(RAIENS,.DA)
+10 SET DIK=$$ROOT^DILFD(RAF2,RAIENS)
+11 SET RA2=0
+12 FOR
SET RA2=$ORDER(RAA(RA2))
if 'RA2
QUIT
SET DA=RA2
DO ^DIK
+13 KILL DIK
+14 QUIT
SET7401(X) ; use this for DX, Staff, Resident secondaries
+1 ; set activity log's subfiles to store any secondaries
+2 KILL RAFDA,RAMSG,RAA
+3 ; X is the Field number from subfile 74.01:
+4 ; 5 = BEFORE DELETION PRIM. DX CODE
+5 ; 7 = BEFORE DELETION PRIM. STAFF
+6 ; 9 = BEFORE DELETION PRIM. RESIDENT
+7 ;
+8 ; RAF1 = subfile number from file 74's activity log
+9 ; RAF2 = subfile number from file 70's secondaries
+10 ; RAF3 = subfile number pointed to from file 70's secondaries
+11 ;
+12 SET RAF1=$SELECT(X=5:74.16,X=7:74.18,X=9:74.19,1:"")
if RAF1=""
QUIT
+13 SET RAF2=$SELECT(X=5:70.14,X=7:70.11,X=9:70.09,1:"")
if RAF2=""
QUIT
+14 SET RAIENS=1_","_RACNI_","_RADTI_","_RADFN_","
+15 ; closed root, file 70's secondaries
SET RAROOT=$$ROOT^DILFD(RAF2,RAIENS,1)
+16 MERGE RAA=@RAROOT
+17 ; no secondaries
if $ORDER(RAA(0))'>0
QUIT
+18 ;
+19 SET RAF3=$$GET1^DID(RAF2,.01,"","POINTER")
+20 ; extract file number from RAF3
+21 SET RAF3=$TRANSLATE(RAF3,$TRANSLATE(RAF3,"0123456789."))
+22 ;
+23 ; store Secondary DXs
+24 SET RA1=0
+25 SET RAIENDX="+2,"_RAIEN2_","_RAIEN_","
+26 FOR
SET RA1=$ORDER(RAA(RA1))
if 'RA1
QUIT
SET RAX=$GET(RAA(RA1,0))
if RAX
Begin DoDot:1
+27 SET RAFDA(RAF1,RAIENDX,.01)=RAX
+28 DO UPDATE^DIE(,"RAFDA",,"RAMSG")
+29 if $DATA(RAMSG("DIERR"))
WRITE !!,"Could not store ",$$GET1^DID(RAF2,.01,"","LABEL"),"'s value: ",$$GET1^DIQ(RAF3,RAX,.01)
+30 KILL RAFDA,RAMSG
+31 QUIT
End DoDot:1
+32 QUIT
ANYDX(ARRAY) ; called from RARTE5
+1 ; input ARRAY name to store all DXs for this case
+2 ; output:
+3 ; =1 if one or more diag codes
+4 ; =0 if no diag code
+5 ; ARRAY() stores diag codes as merged from case
+6 if '$DATA(RADFN)!('$DATA(RADTI))!('$DATA(RACNI))
QUIT
+7 KILL ARRAY
+8 ;Sec Diags
MERGE ARRAY=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX")
+9 ;Prim Diag
SET ARRAY(9999,0)=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13)
+10 IF $ORDER(ARRAY(0))
QUIT 1
+11 QUIT 0
+12 ;
ALERT ; for Outside Report, ck if new/changed diags require alert
+1 ; this is called from RARTE5 each time an outside report is edited
+2 if '$DATA(RADFN)!('$DATA(RADTI))!('$DATA(RACNI))
QUIT
+3 NEW RASAVE,RAY3,X
+4 ; set RASAVE() for OENOTE^RAUTL00
+5 SET RASAVE("RADFN")=RADFN
SET RASAVE("RADTI")=RADTI
SET RASAVE("RACNI")=RACNI
+6 ;
+7 NEW I
+8 ;no diags before and after edit
if (RANY1=0)&(RANY2=0)
QUIT
+9 SET I=0
+10 ; loop RAA2
+11 FOR
SET I=$ORDER(RAA2(I))
if 'I
QUIT
if RAA2(I,0)=$GET(RAA1(I,0))
KILL RAA2(I,0)
+12 ;04/06/2010 BP/KAM RA*5*103 Rem Tkt 324541 Commented out next line
+13 ;Q:'$O(RAA2(0))
+14 KILL RAAB
+15 SET I=0
FOR
SET I=$ORDER(RAA2(I))
if 'I
QUIT
Begin DoDot:1
+16 IF $DATA(^RA(78.3,+RAA2(I,0),0))
IF ($PIECE(^(0),U,4)="y")
SET RAAB=1
+17 QUIT
End DoDot:1
+18 ; invoke notification for either condition:
+19 ; (1) new EF report is made --> non-critical imaging alert
+20 ; (2) old/new EF report w abnormal DX --> abnormal alert
+21 ; either of the above alert may be from an amended report or not
+22 IF $GET(RAAB)!RAFIRST
Begin DoDot:1
+23 SET RAY3=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+24 ; X is input to OENOTE
SET X=RAY3
+25 DO OENOTE^RAUTL00
End DoDot:1
+26 QUIT
