RARTE6 ;HISC/SM - Restore deleted report ; Nov 29, 2023@09:14:58
;;5.0;Radiology/Nuclear Medicine;**56,95,99,47,163,182,209**;Mar 16, 1998;Build 3
;Supported IA #10060 ^VA(200
;Supported IA #2053 FILE^DIE, UPDATE^DIE
;Supported IA #2052 GET1^DID
;Supported IA #2056 GET1^DIQ
;Supported IA #10103 NOW^XLFDT
;Supported IA #2055 ROOT^DILFD
;Supported IA #10060 GETS^DIQ
;P99, added pregnancy screen and pregnancy screen comment
Q
RSTR ;restore deleted report
F I=1:1:5 W !?4,$P($T(INTRO+I),";;",2)
W !
S RAXIT=0 ; =0 exit normally, =1 exit early
;p182/KLM - update RA MGR to RA RPTMGR
I '$D(^XUSEC("RA RPTMGR",DUZ)) W !!,"Report Manager key RA RPTMGR is needed for this option." Q
S DIC("S")="I $P(^(0),""^"",5)=""X""" ;only select deleted reports
S DIC("A")="Select Deleted Report to restore: "
S DIC="^RARPT(",DIC(0)="AEMQZ"
D DICW^RARTST1,^DIC K DIC I Y<0 G FINISH
S RARPT=+Y
W !
D CHECK G:RAXIT NOTDONE ;check if case has rpt & DX codes
D ASK1 G:RAXIT NOTDONE ;ask if want restore deleted report
D ASSOC G:RAXIT NOTDONE ;display associated case(s) & ask user again if want continue
D RESTORE ;restore rpt status, link rpt to case(s)
D FINISH
Q
CHECK ; check if associated case(s) has rpt and DX codes
S RA74=^RARPT(RARPT,0)
S RADFN=+$P(RA74,U,2),RADTI=9999999.9999-$P(RA74,U,3),RACN=+$P($P(RA74,U,1),"-",$L($P(RA74,U,1),"-"))
S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0))
S RA70=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
I 'RADFN!('RADTI)!('RACNI)!(RA70="") D ERR0 Q
S RANME=$$GET1^DIQ(2,RADFN,.01),RAST=+$P(RA70,U,3)
S RAPRC=$S($D(^RAMIS(71,+$P(RA70,U,2),0)):$P(^(0),U),1:"Unknown")
S RASSN=$$SSN^RAUTL,RASUBY0=RA70
S RANODE=$G(^RADPT(RADFN,"DT",RADTI,0))
; check if case(s) already have a report
D EN2^RAUTL20(.RAMEMARR)
I RAPRTSET D
.S RA1=0
.F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" D
..I $P(^RADPT(RADFN,"DT",RADTI,"P",RA1,0),U,17)'="" D ERR3($P(RAMEMARR(RA1),"^"))
..Q
.Q
E I $P(RA70,U,17) D ERR3($P(RA74,U,1)) Q
; check if case(s) already have DX codes, staff, resident
; don't use IF ELSE here due to outside calls
;
; Printset cases
I RAPRTSET D Q
.S RA1=0
.F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" D
..; check primary
..F RA2=13,15,12 I $P(^RADPT(RADFN,"DT",RADTI,"P",RA1,0),U,RA2)'="" D ERR2($P(RAMEMARR(RA1),"^"),70.03,RA2)
..; check secondary
..S RAIENS=1_","_RA1_","_RADTI_","_RADFN_","
..F RA2=70.14,70.11,70.09 S RAROOT=$$ROOT^DILFD(RA2,RAIENS) I $O(@(RAROOT_"0)")) D ERR2($P(RAMEMARR(RA1),"^"),RA2,.01)
..Q
.Q
; single case
F RA2=13,15,12 I $P(RA70,U,RA2) D ERR2($P(RA74,U,1),70.03,RA2)
S RAIENS=1_","_RACNI_","_RADTI_","_RADFN_","
F RA2=70.14,70.11,70.09 S RAROOT=$$ROOT^DILFD(RA2,RAIENS) I $O(@(RAROOT_"0)")) D ERR2($P(RA74,U,1),RA2,.01)
Q
ASK1 ; ask if want to restore report
; RAPRVIEN last Activity Log rec in subfile 74.01
; RAPRVST previous report status logged in latest activity log rec
; RALAST last activity log record
S RAPRVIEN=$O(^RARPT(RARPT,"L",""),-1)
I 'RAPRVIEN D ERR1 Q
S RALAST=$G(^RARPT(RARPT,"L",+RAPRVIEN,0))
I RALAST="" D ERR1 Q
S RAPRVST=$P(RALAST,U,4) ;previous rpt status
K DIR
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Do you want to restore this deleted report"
S DIR("?")="Answer ""Y"" to assign the previous report status, "_$$GET1^DIQ(74.01,RAPRVIEN_","_RARPT_",",4)_", to this report."
D ^DIR K DIR
S:$D(DIRUT) RAXIT=1
S:'Y RAXIT=1
Q
ASSOC ;
; list case(s) for this report
S (Y,RADTE)=+$P(RANODE,U)
D D^RAUTL S RADATE=Y
D DISPLAY
W !
K DIR
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Are you sure you want to link this report back to the case"_$S(RAPRTSET:"s",1:"")
S DIR("?")="Answer ""Y"" to link this report back to the case(s) shown above."
D ^DIR K DIR
S:$D(DIRUT) RAXIT=1
S:'Y RAXIT=1
Q
RESTORE ; set Report Status to "before delete" value, link to case(s)
D SETFF(74,5,RARPT,RAPRVST)
W !!?3,"... Restored ",$P(RA74,U,1),"'s report status to: ",$$GET1^DIQ(74,+RARPT,5),"."
;
; set activity log record
S RAIENL="+1,"_RARPT_","
D SETALOG(RAIENL,"R","")
;
; link report to single case or all cases of a printset
I RAPRTSET D
.S RA1=""
.F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" S $P(^RADPT(RADFN,"DT",RADTI,"P",RA1,0),U,17)=RARPT D MSG1($P(RAMEMARR(RA1),"^"))
.Q
E S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,17)=RARPT D MSG1($P(RA74,U,1))
;
;Restore Primary and Secondary DX codes, Staff and Residents
;
F RAFLD=5,7,9 S RAPREV=$P(RALAST,U,RAFLD) D:RAPREV SET70(RAFLD)
W !!!?3,"** You need to edit the case"_$S(RAPRTSET:"s",1:"")_" to update the exam status. **"
Q
SET70(X) ; put back previous DX codes, Staff, Residents into case record
; assumes if no primary then no secondaries
K RAFDA,RAA
N RA1
S RAIENS=1_","_RAPRVIEN_","_RARPT_","
;
; 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
; RAPIECE = piece in 70.03's 0 node
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 RAF3=$$GET1^DID(RAF2,.01,"","POINTER")
; extract file number from RAF3
S RAF3=$TR(RAF3,$TR(RAF3,"0123456789."))
;piece number for Primary DX/Staff/Resident in 70.03
S RAPIECE=$S(X=5:13,X=7:15,X=9:12,1:"") Q:RAPIECE=""
S RAROOT=$$ROOT^DILFD(RAF1,RAIENS,1) ;closed root under file 74's Activity Log
;copy secondaries into RAA()
M RAA=@RAROOT
;
G:RAPRTSET PSET
;
; single case
;
; copy Primary into single case
S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",RAPIECE)=RAPREV
D FILE^DIE("","RAFDA","RAMSG")
I $D(RAMSG("DIERR")) D ERR4($P(RA74,U,1),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01))
E D MSG2($P(RA74,U,1),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01))
K RAFDA,RAMSG
;
Q:$O(RAA(0))'>0 ; no secondaries
;
;copy secondary items into single case
S RA1=0
F S RA1=$O(RAA(RA1)) Q:'RA1 S RAX=$G(RAA(RA1,0)) D:RAX
.S RAFDA(RAF2,"+2,"_RACNI_","_RADTI_","_RADFN_",",.01)=RAX
.D UPDATE^DIE(,"RAFDA",,"RAMSG")
.I $D(RAMSG("DIERR")) D ERR4($P(RA74,U,1),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01))
.E D MSG2($P(RA74,U,1),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01))
.K RAFDA,RAMSG
.Q
Q
;
; cases from printset
;
PSET ; copy Primary into cases of a printset
S RA1=0
F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" D
.S RAFDA(70.03,RA1_","_RADTI_","_RADFN_",",RAPIECE)=RAPREV
.D FILE^DIE("","RAFDA","RAMSG")
.I $D(RAMSG("DIERR")) D ERR4($P(RAMEMARR(RA1),"^"),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01))
.;E D MSG2(+RAMEMARR(RA1),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01))
.E D MSG2($P(RAMEMARR(RA1),"^"),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01))
.K RAFDA,RAMSG
.Q:$O(RAA(0))'>0 ; no secondary DXs
.; copy secondaries into cases of a printset
.S RA2=0
.F S RA2=$O(RAA(RA2)) Q:'RA2 S RAX=$G(RAA(RA2,0)) D:RAX
..S RAFDA(RAF2,"+2,"_RA1_","_RADTI_","_RADFN_",",.01)=RAX
..D UPDATE^DIE(,"RAFDA",,"RAMSG")
..I $D(RAMSG("DIERR")) D ERR4($P(RAMEMARR(RA1),"^"),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01))
..;E D MSG2(+RAMEMARR(RA1),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01))
..E D MSG2($P(RAMEMARR(RA1),"^"),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01))
..K RAFDA,RAMSG
..Q
.Q
Q
SETFF(RA1,RA2,RA3,RA4,RA5) ;reset file's field value
;RA1 file number
;RA2 field number
;RA3 IEN in file
;RA4 field value to set in record IEN
;RA5 (optional), set to "E" for external
N RAFDA
S RAFDA(RA1,RA3_",",RA2)=RA4
I $G(RA5)="E" D FILE^DIE("E","RAFDA")
E D FILE^DIE("","RAFDA")
Q
SETALOG(RA1,RA2,RA3) ;set new record in Activity log 74.01
;RA1 ien string, eg., "+1,"_RARPT_","
;RA2 type of action
;RA3 current report status code
;
N RAFDA
S RAFDA(74.01,RA1,.01)=+$E($$NOW^XLFDT(),1,12)
S RAFDA(74.01,RA1,2)=RA2
S RAFDA(74.01,RA1,3)=$G(DUZ)
S:$G(RA3)]"" RAFDA(74.01,RA1,4)=RA3 ;only del rpt would have data here
D UPDATE^DIE(,"RAFDA")
Q
MSG1(X) ;
W !?3,"... Linked restored report to case no. ",X
Q
MSG2(X,Y,Z) ;
W !?3,"... Restored case ",X,"'s ",Y," to: ",Z
Q
ERR0 ;
W !,"Unable to determine case previously associated with this report."
S RAXIT=1
Q
ERR1 W !!,"Cannot determine previous report status.",!
S RAXIT=1
Q
ERR2(X,Y,Z) ;X=External short case No, Y=File no., Z=Field no.
W !,"Case #",X," already has ",$$GET1^DID(Y,Z,"","LABEL")
S RAXIT=1
Q
ERR3(X) ;
W !,"Case #",X," is already associated with a report!"
S RAXIT=1
Q
ERR4(X,Y,Z) ;
W !!?3,"Cannot restore case ",X,"'s ",Y," to: ",Z
Q
NOTDONE ;
W !!?3,"Restoration was not done."
; continue to clean up
FINISH ; clean up and exit
R !!!,"Press RETURN to exit. ",X:DTIME
K DIRUT,I
K RA1,RA2,RA3,RA4,RA5,RA18EX,RA70,RA74,RAA,RACMDATA
K RACN,RACNI,RADATE,RADFN,RADTE,RADTI,RADUZ,RAFDA,RAF1,RAF2,RAF3
K RAI,RAIENL,RAIENS,RAIENSUB,RALAST,RALCKFLG,RAMEMARR,RANME,RANODE
K RAOUT,RAPIECE,RAPRC,RAPRTSET,RAPRVIEN,RAPREV,RAPRVST,RAROOT,RARPT
K RASSN,RAST,RASUB70,RASUBY0,RAX,RAXIT,X,XY,Y,Z
Q
DISPLAY ; Display exam specific info, edit/enter the report
; adapted from routine RARTE
;p206/KLM - INC29784322: New RAOUT
N RASSAN,RACNDSP,RAOUT S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN)
S RA18EX=0 ;P18 for quit if uparrow inside PUTTCOM
I '($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))#2) D D Q1^RARTE5 QUIT
. I $$USESSAN^RAHLRU1() W !!?2,"Case #: ",RACNDSP," for ",RANME S RAXIT=1
. I '$$USESSAN^RAHLRU1() W !!?2,"Case #: ",RACN," for ",RANME S RAXIT=1
. W !?2,"Procedure: '",$E(RAPRC,1,45),"' has been deleted"
. W !?2,"by another user!",$C(7)
. Q
;
S RAI="",$P(RAI,"-",80)="" W !,RAI
W !?1,"Name : ",$E(RANME,1,25),?40,"Pt ID : ",RASSN
I $$USESSAN^RAHLRU1() W !?1,"Case No. : ",RACNDSP,?40,"Exm. St : ",$E($P($G(^RA(72,+RAST,0)),"^"),1,22),!?1,"Procedure: ",$E(RAPRC,1,45)
I '$$USESSAN^RAHLRU1() W !?1,"Case No. : ",RACN,?18,"Exm. St: ",$E($P($G(^RA(72,+RAST,0)),"^"),1,12),?40,"Procedure : ",$E(RAPRC,1,25)
;check for contrast media; display if CM data exists (patch 45)
S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI)
D:$L(RACMDATA) CMEDIA^RARTE(RACMDATA)
K RACMDATA
S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,RACN," Tech.Comment: ",15,70,-1,0) ;P18
I RA18EX=-1 Q ;P18
;
K RAMEMARR D EN2^RAUTL20(.RAMEMARR) ;recalculate RAPRTSET
; if printset, display cases and continue on to display Exam Date
I RAPRTSET D
. S RA1=""
. F S RA1=$O(RAMEMARR(RA1)) Q:RA1=""!(RA18EX=-1) I RA1'=RACNI D
.. I $$USESSAN^RAHLRU1() W !,?1,"Case No. : ",$P(RAMEMARR(RA1),U)
.. I '$$USESSAN^RAHLRU1() W !,?1,"Case No. : ",+RAMEMARR(RA1)
.. I $$USESSAN^RAHLRU1() W:$P(RAMEMARR(RA1),"^",4)]"" ?40,"Exm. St : ",$E($P($G(^RA(72,$P(RAMEMARR(RA1),"^",4),0)),"^"),1,22) W !?1,"Procedure: ",$E($P($G(^RAMIS(71,+$P(RAMEMARR(RA1),"^",2),0)),"^"),1,45)
.. I '$$USESSAN^RAHLRU1() W:$P(RAMEMARR(RA1),"^",4)]"" ?18,"Exm. St: ",$E($P($G(^RA(72,$P(RAMEMARR(RA1),"^",4),0)),"^"),1,12) W ?40,"Procedure : ",$E($P($G(^RAMIS(71,+$P(RAMEMARR(RA1),"^",2),0)),"^"),1,26)
.. ;check printset for contrast media; display if CM data exists
.. S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RA1)
.. D:$L(RACMDATA) CMEDIA^RARTE(RACMDATA)
.. K RACMDATA
.. I $P(RAMEMARR(RA1),"^")["-" S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,$P($P(RAMEMARR(RA1),"^"),"-",3)," Tech.Comment: ",15,70,-1,0) Q:RA18EX=-1
.. I $P(RAMEMARR(RA1),"^")'["-" S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,+RAMEMARR(RA1)," Tech.Comment: ",15,70,-1,0) Q:RA18EX=-1 ;P18
.. Q
. Q
;continue display
I RA18EX=-1 Q ;P18
S Y(0)=RASUBY0
S RAIENS=RACNI_","_RADTI_","_RADFN_","
D GETS^DIQ(70.03,RAIENS,"14;175*","E","RAOUT")
W !?1,"Exam Date: ",RADATE,?40,"Technologist: "
S RAIENSUB=$O(RAOUT(70.12,0))
W:RAIENSUB]"" $E($G(RAOUT(70.12,RAIENSUB,.01,"E")),1,25)
;p99 begins
W !?1,"Req Phys : ",$E($G(RAOUT(70.03,RAIENS,14,"E")),1,25)
I $$PTSEX^RAUTL8(RADFN)="F" D
.D GETS^DIQ(70.03,RAIENS,"32;80","I","RAOUT")
.N RA3 S RA3=$G(RAOUT(70.03,RAIENS,32,"I"))
.W:RA3'="" !?1,"Pregnancy Screen: ",$S(RA3="y":"Patient answered yes",RA3="n":"Patient answered no",RA3="u":"Patient is unable to answer or is unsure",1:"")
.W:(RA3'="n")&($G(RAOUT(70.03,RAIENS,80,"I"))'="") !?1,"Pregnancy Screen Comment: ",$G(RAOUT(70.03,RAIENS,80,"I"))
;p99 ends
W !,RAI
Q
LOCK(X,Y) ; Lock the data global
; uses var DILOCKTM, code taken from rtn RAUTL12
; 'X' is the global root
; 'Y' is the record number
; KLM/163 - remove setting of RADUZ and ^TMP("RAD LOCKS"
N RALCKFLG,XY
;S RADUZ=+$G(DUZ),RALCKFLG=0,
S RALCKFLG=0,XY=X_Y
L +@(XY_")"):DILOCKTM
I '$T S RALCKFLG=1 D
. W !?5,"This record is being edited by another user."
. W !?5,"Try again later!",$C(7)
. Q
;E D
;. S ^TMP("RAD LOCKS",$J,RADUZ,X,Y)=""
;. Q
Q RALCKFLG
INTRO ;
;; +--------------------------------------------------------+
;; | |
;; | This option is for restoring a deleted report. |
;; | |
;; +--------------------------------------------------------+
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRARTE6 13557 printed Apr 09, 2024@21:37:11 Page 2
RARTE6 ;HISC/SM - Restore deleted report ; Nov 29, 2023@09:14:58
+1 ;;5.0;Radiology/Nuclear Medicine;**56,95,99,47,163,182,209**;Mar 16, 1998;Build 3
+2 ;Supported IA #10060 ^VA(200
+3 ;Supported IA #2053 FILE^DIE, UPDATE^DIE
+4 ;Supported IA #2052 GET1^DID
+5 ;Supported IA #2056 GET1^DIQ
+6 ;Supported IA #10103 NOW^XLFDT
+7 ;Supported IA #2055 ROOT^DILFD
+8 ;Supported IA #10060 GETS^DIQ
+9 ;P99, added pregnancy screen and pregnancy screen comment
+10 QUIT
RSTR ;restore deleted report
+1 FOR I=1:1:5
WRITE !?4,$PIECE($TEXT(INTRO+I),";;",2)
+2 WRITE !
+3 ; =0 exit normally, =1 exit early
SET RAXIT=0
+4 ;p182/KLM - update RA MGR to RA RPTMGR
+5 IF '$DATA(^XUSEC("RA RPTMGR",DUZ))
WRITE !!,"Report Manager key RA RPTMGR is needed for this option."
QUIT
+6 ;only select deleted reports
SET DIC("S")="I $P(^(0),""^"",5)=""X"""
+7 SET DIC("A")="Select Deleted Report to restore: "
+8 SET DIC="^RARPT("
SET DIC(0)="AEMQZ"
+9 DO DICW^RARTST1
DO ^DIC
KILL DIC
IF Y<0
GOTO FINISH
+10 SET RARPT=+Y
+11 WRITE !
+12 ;check if case has rpt & DX codes
DO CHECK
if RAXIT
GOTO NOTDONE
+13 ;ask if want restore deleted report
DO ASK1
if RAXIT
GOTO NOTDONE
+14 ;display associated case(s) & ask user again if want continue
DO ASSOC
if RAXIT
GOTO NOTDONE
+15 ;restore rpt status, link rpt to case(s)
DO RESTORE
+16 DO FINISH
+17 QUIT
CHECK ; check if associated case(s) has rpt and DX codes
+1 SET RA74=^RARPT(RARPT,0)
+2 SET RADFN=+$PIECE(RA74,U,2)
SET RADTI=9999999.9999-$PIECE(RA74,U,3)
SET RACN=+$PIECE($PIECE(RA74,U,1),"-",$LENGTH($PIECE(RA74,U,1),"-"))
+3 SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0))
+4 SET RA70=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+5 IF 'RADFN!('RADTI)!('RACNI)!(RA70="")
DO ERR0
QUIT
+6 SET RANME=$$GET1^DIQ(2,RADFN,.01)
SET RAST=+$PIECE(RA70,U,3)
+7 SET RAPRC=$SELECT($DATA(^RAMIS(71,+$PIECE(RA70,U,2),0)):$PIECE(^(0),U),1:"Unknown")
+8 SET RASSN=$$SSN^RAUTL
SET RASUBY0=RA70
+9 SET RANODE=$GET(^RADPT(RADFN,"DT",RADTI,0))
+10 ; check if case(s) already have a report
+11 DO EN2^RAUTL20(.RAMEMARR)
+12 IF RAPRTSET
Begin DoDot:1
+13 SET RA1=0
+14 FOR
SET RA1=$ORDER(RAMEMARR(RA1))
if RA1=""
QUIT
Begin DoDot:2
+15 IF $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RA1,0),U,17)'=""
DO ERR3($PIECE(RAMEMARR(RA1),"^"))
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 IF '$TEST
IF $PIECE(RA70,U,17)
DO ERR3($PIECE(RA74,U,1))
QUIT
+19 ; check if case(s) already have DX codes, staff, resident
+20 ; don't use IF ELSE here due to outside calls
+21 ;
+22 ; Printset cases
+23 IF RAPRTSET
Begin DoDot:1
+24 SET RA1=0
+25 FOR
SET RA1=$ORDER(RAMEMARR(RA1))
if RA1=""
QUIT
Begin DoDot:2
+26 ; check primary
+27 FOR RA2=13,15,12
IF $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RA1,0),U,RA2)'=""
DO ERR2($PIECE(RAMEMARR(RA1),"^"),70.03,RA2)
+28 ; check secondary
+29 SET RAIENS=1_","_RA1_","_RADTI_","_RADFN_","
+30 FOR RA2=70.14,70.11,70.09
SET RAROOT=$$ROOT^DILFD(RA2,RAIENS)
IF $ORDER(@(RAROOT_"0)"))
DO ERR2($PIECE(RAMEMARR(RA1),"^"),RA2,.01)
+31 QUIT
End DoDot:2
+32 QUIT
End DoDot:1
QUIT
+33 ; single case
+34 FOR RA2=13,15,12
IF $PIECE(RA70,U,RA2)
DO ERR2($PIECE(RA74,U,1),70.03,RA2)
+35 SET RAIENS=1_","_RACNI_","_RADTI_","_RADFN_","
+36 FOR RA2=70.14,70.11,70.09
SET RAROOT=$$ROOT^DILFD(RA2,RAIENS)
IF $ORDER(@(RAROOT_"0)"))
DO ERR2($PIECE(RA74,U,1),RA2,.01)
+37 QUIT
ASK1 ; ask if want to restore report
+1 ; RAPRVIEN last Activity Log rec in subfile 74.01
+2 ; RAPRVST previous report status logged in latest activity log rec
+3 ; RALAST last activity log record
+4 SET RAPRVIEN=$ORDER(^RARPT(RARPT,"L",""),-1)
+5 IF 'RAPRVIEN
DO ERR1
QUIT
+6 SET RALAST=$GET(^RARPT(RARPT,"L",+RAPRVIEN,0))
+7 IF RALAST=""
DO ERR1
QUIT
+8 ;previous rpt status
SET RAPRVST=$PIECE(RALAST,U,4)
+9 KILL DIR
+10 SET DIR(0)="Y"
SET DIR("B")="NO"
+11 SET DIR("A")="Do you want to restore this deleted report"
+12 SET DIR("?")="Answer ""Y"" to assign the previous report status, "_$$GET1^DIQ(74.01,RAPRVIEN_","_RARPT_",",4)_", to this report."
+13 DO ^DIR
KILL DIR
+14 if $DATA(DIRUT)
SET RAXIT=1
+15 if 'Y
SET RAXIT=1
+16 QUIT
ASSOC ;
+1 ; list case(s) for this report
+2 SET (Y,RADTE)=+$PIECE(RANODE,U)
+3 DO D^RAUTL
SET RADATE=Y
+4 DO DISPLAY
+5 WRITE !
+6 KILL DIR
+7 SET DIR(0)="Y"
SET DIR("B")="NO"
+8 SET DIR("A")="Are you sure you want to link this report back to the case"_$SELECT(RAPRTSET:"s",1:"")
+9 SET DIR("?")="Answer ""Y"" to link this report back to the case(s) shown above."
+10 DO ^DIR
KILL DIR
+11 if $DATA(DIRUT)
SET RAXIT=1
+12 if 'Y
SET RAXIT=1
+13 QUIT
RESTORE ; set Report Status to "before delete" value, link to case(s)
+1 DO SETFF(74,5,RARPT,RAPRVST)
+2 WRITE !!?3,"... Restored ",$PIECE(RA74,U,1),"'s report status to: ",$$GET1^DIQ(74,+RARPT,5),"."
+3 ;
+4 ; set activity log record
+5 SET RAIENL="+1,"_RARPT_","
+6 DO SETALOG(RAIENL,"R","")
+7 ;
+8 ; link report to single case or all cases of a printset
+9 IF RAPRTSET
Begin DoDot:1
+10 SET RA1=""
+11 FOR
SET RA1=$ORDER(RAMEMARR(RA1))
if RA1=""
QUIT
SET $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RA1,0),U,17)=RARPT
DO MSG1($PIECE(RAMEMARR(RA1),"^"))
+12 QUIT
End DoDot:1
+13 IF '$TEST
SET $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,17)=RARPT
DO MSG1($PIECE(RA74,U,1))
+14 ;
+15 ;Restore Primary and Secondary DX codes, Staff and Residents
+16 ;
+17 FOR RAFLD=5,7,9
SET RAPREV=$PIECE(RALAST,U,RAFLD)
if RAPREV
DO SET70(RAFLD)
+18 WRITE !!!?3,"** You need to edit the case"_$SELECT(RAPRTSET:"s",1:"")_" to update the exam status. **"
+19 QUIT
SET70(X) ; put back previous DX codes, Staff, Residents into case record
+1 ; assumes if no primary then no secondaries
+2 KILL RAFDA,RAA
+3 NEW RA1
+4 SET RAIENS=1_","_RAPRVIEN_","_RARPT_","
+5 ;
+6 ; X is the field number from subfile 74.01:
+7 ; 5 = BEFORE DELETION PRIM. DX CODE
+8 ; 7 = BEFORE DELETION PRIM. STAFF
+9 ; 9 = BEFORE DELETION PRIM. RESIDENT
+10 ;
+11 ; RAF1 = subfile number from file 74's activity log
+12 ; RAF2 = subfile number from file 70's secondaries
+13 ; RAF3 = subfile number pointed to from file 70's secondaries
+14 ; RAPIECE = piece in 70.03's 0 node
+15 SET RAF1=$SELECT(X=5:74.16,X=7:74.18,X=9:74.19,1:"")
if RAF1=""
QUIT
+16 SET RAF2=$SELECT(X=5:70.14,X=7:70.11,X=9:70.09,1:"")
if RAF2=""
QUIT
+17 SET RAF3=$$GET1^DID(RAF2,.01,"","POINTER")
+18 ; extract file number from RAF3
+19 SET RAF3=$TRANSLATE(RAF3,$TRANSLATE(RAF3,"0123456789."))
+20 ;piece number for Primary DX/Staff/Resident in 70.03
+21 SET RAPIECE=$SELECT(X=5:13,X=7:15,X=9:12,1:"")
if RAPIECE=""
QUIT
+22 ;closed root under file 74's Activity Log
SET RAROOT=$$ROOT^DILFD(RAF1,RAIENS,1)
+23 ;copy secondaries into RAA()
+24 MERGE RAA=@RAROOT
+25 ;
+26 if RAPRTSET
GOTO PSET
+27 ;
+28 ; single case
+29 ;
+30 ; copy Primary into single case
+31 SET RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",RAPIECE)=RAPREV
+32 DO FILE^DIE("","RAFDA","RAMSG")
+33 IF $DATA(RAMSG("DIERR"))
DO ERR4($PIECE(RA74,U,1),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01))
+34 IF '$TEST
DO MSG2($PIECE(RA74,U,1),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01))
+35 KILL RAFDA,RAMSG
+36 ;
+37 ; no secondaries
if $ORDER(RAA(0))'>0
QUIT
+38 ;
+39 ;copy secondary items into single case
+40 SET RA1=0
+41 FOR
SET RA1=$ORDER(RAA(RA1))
if 'RA1
QUIT
SET RAX=$GET(RAA(RA1,0))
if RAX
Begin DoDot:1
+42 SET RAFDA(RAF2,"+2,"_RACNI_","_RADTI_","_RADFN_",",.01)=RAX
+43 DO UPDATE^DIE(,"RAFDA",,"RAMSG")
+44 IF $DATA(RAMSG("DIERR"))
DO ERR4($PIECE(RA74,U,1),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01))
+45 IF '$TEST
DO MSG2($PIECE(RA74,U,1),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01))
+46 KILL RAFDA,RAMSG
+47 QUIT
End DoDot:1
+48 QUIT
+49 ;
+50 ; cases from printset
+51 ;
PSET ; copy Primary into cases of a printset
+1 SET RA1=0
+2 FOR
SET RA1=$ORDER(RAMEMARR(RA1))
if RA1=""
QUIT
Begin DoDot:1
+3 SET RAFDA(70.03,RA1_","_RADTI_","_RADFN_",",RAPIECE)=RAPREV
+4 DO FILE^DIE("","RAFDA","RAMSG")
+5 IF $DATA(RAMSG("DIERR"))
DO ERR4($PIECE(RAMEMARR(RA1),"^"),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01))
+6 ;E D MSG2(+RAMEMARR(RA1),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01))
+7 IF '$TEST
DO MSG2($PIECE(RAMEMARR(RA1),"^"),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01))
+8 KILL RAFDA,RAMSG
+9 ; no secondary DXs
if $ORDER(RAA(0))'>0
QUIT
+10 ; copy secondaries into cases of a printset
+11 SET RA2=0
+12 FOR
SET RA2=$ORDER(RAA(RA2))
if 'RA2
QUIT
SET RAX=$GET(RAA(RA2,0))
if RAX
Begin DoDot:2
+13 SET RAFDA(RAF2,"+2,"_RA1_","_RADTI_","_RADFN_",",.01)=RAX
+14 DO UPDATE^DIE(,"RAFDA",,"RAMSG")
+15 IF $DATA(RAMSG("DIERR"))
DO ERR4($PIECE(RAMEMARR(RA1),"^"),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01))
+16 ;E D MSG2(+RAMEMARR(RA1),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01))
+17 IF '$TEST
DO MSG2($PIECE(RAMEMARR(RA1),"^"),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01))
+18 KILL RAFDA,RAMSG
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 QUIT
SETFF(RA1,RA2,RA3,RA4,RA5) ;reset file's field value
+1 ;RA1 file number
+2 ;RA2 field number
+3 ;RA3 IEN in file
+4 ;RA4 field value to set in record IEN
+5 ;RA5 (optional), set to "E" for external
+6 NEW RAFDA
+7 SET RAFDA(RA1,RA3_",",RA2)=RA4
+8 IF $GET(RA5)="E"
DO FILE^DIE("E","RAFDA")
+9 IF '$TEST
DO FILE^DIE("","RAFDA")
+10 QUIT
SETALOG(RA1,RA2,RA3) ;set new record in Activity log 74.01
+1 ;RA1 ien string, eg., "+1,"_RARPT_","
+2 ;RA2 type of action
+3 ;RA3 current report status code
+4 ;
+5 NEW RAFDA
+6 SET RAFDA(74.01,RA1,.01)=+$EXTRACT($$NOW^XLFDT(),1,12)
+7 SET RAFDA(74.01,RA1,2)=RA2
+8 SET RAFDA(74.01,RA1,3)=$GET(DUZ)
+9 ;only del rpt would have data here
if $GET(RA3)]""
SET RAFDA(74.01,RA1,4)=RA3
+10 DO UPDATE^DIE(,"RAFDA")
+11 QUIT
MSG1(X) ;
+1 WRITE !?3,"... Linked restored report to case no. ",X
+2 QUIT
MSG2(X,Y,Z) ;
+1 WRITE !?3,"... Restored case ",X,"'s ",Y," to: ",Z
+2 QUIT
ERR0 ;
+1 WRITE !,"Unable to determine case previously associated with this report."
+2 SET RAXIT=1
+3 QUIT
ERR1 WRITE !!,"Cannot determine previous report status.",!
+1 SET RAXIT=1
+2 QUIT
ERR2(X,Y,Z) ;X=External short case No, Y=File no., Z=Field no.
+1 WRITE !,"Case #",X," already has ",$$GET1^DID(Y,Z,"","LABEL")
+2 SET RAXIT=1
+3 QUIT
ERR3(X) ;
+1 WRITE !,"Case #",X," is already associated with a report!"
+2 SET RAXIT=1
+3 QUIT
ERR4(X,Y,Z) ;
+1 WRITE !!?3,"Cannot restore case ",X,"'s ",Y," to: ",Z
+2 QUIT
NOTDONE ;
+1 WRITE !!?3,"Restoration was not done."
+2 ; continue to clean up
FINISH ; clean up and exit
+1 READ !!!,"Press RETURN to exit. ",X:DTIME
+2 KILL DIRUT,I
+3 KILL RA1,RA2,RA3,RA4,RA5,RA18EX,RA70,RA74,RAA,RACMDATA
+4 KILL RACN,RACNI,RADATE,RADFN,RADTE,RADTI,RADUZ,RAFDA,RAF1,RAF2,RAF3
+5 KILL RAI,RAIENL,RAIENS,RAIENSUB,RALAST,RALCKFLG,RAMEMARR,RANME,RANODE
+6 KILL RAOUT,RAPIECE,RAPRC,RAPRTSET,RAPRVIEN,RAPREV,RAPRVST,RAROOT,RARPT
+7 KILL RASSN,RAST,RASUB70,RASUBY0,RAX,RAXIT,X,XY,Y,Z
+8 QUIT
DISPLAY ; Display exam specific info, edit/enter the report
+1 ; adapted from routine RARTE
+2 ;p206/KLM - INC29784322: New RAOUT
+3 NEW RASSAN,RACNDSP,RAOUT
SET RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
+4 SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:RACN)
+5 ;P18 for quit if uparrow inside PUTTCOM
SET RA18EX=0
+6 IF '($DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))#2)
Begin DoDot:1
+7 IF $$USESSAN^RAHLRU1()
WRITE !!?2,"Case #: ",RACNDSP," for ",RANME
SET RAXIT=1
+8 IF '$$USESSAN^RAHLRU1()
WRITE !!?2,"Case #: ",RACN," for ",RANME
SET RAXIT=1
+9 WRITE !?2,"Procedure: '",$EXTRACT(RAPRC,1,45),"' has been deleted"
+10 WRITE !?2,"by another user!",$CHAR(7)
+11 QUIT
End DoDot:1
DO Q1^RARTE5
QUIT
+12 ;
+13 SET RAI=""
SET $PIECE(RAI,"-",80)=""
WRITE !,RAI
+14 WRITE !?1,"Name : ",$EXTRACT(RANME,1,25),?40,"Pt ID : ",RASSN
+15 IF $$USESSAN^RAHLRU1()
WRITE !?1,"Case No. : ",RACNDSP,?40,"Exm. St : ",$EXTRACT($PIECE($GET(^RA(72,+RAST,0)),"^"),1,22),!?1,"Procedure: ",$EXTRACT(RAPRC,1,45)
+16 IF '$$USESSAN^RAHLRU1()
WRITE !?1,"Case No. : ",RACN,?18,"Exm. St: ",$EXTRACT($PIECE($GET(^RA(72,+RAST,0)),"^"),1,12),?40,"Procedure : ",$EXTRACT(RAPRC,1,25)
+17 ;check for contrast media; display if CM data exists (patch 45)
+18 SET RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI)
+19 if $LENGTH(RACMDATA)
DO CMEDIA^RARTE(RACMDATA)
+20 KILL RACMDATA
+21 ;P18
SET RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,RACN," Tech.Comment: ",15,70,-1,0)
+22 ;P18
IF RA18EX=-1
QUIT
+23 ;
+24 ;recalculate RAPRTSET
KILL RAMEMARR
DO EN2^RAUTL20(.RAMEMARR)
+25 ; if printset, display cases and continue on to display Exam Date
+26 IF RAPRTSET
Begin DoDot:1
+27 SET RA1=""
+28 FOR
SET RA1=$ORDER(RAMEMARR(RA1))
if RA1=""!(RA18EX=-1)
QUIT
IF RA1'=RACNI
Begin DoDot:2
+29 IF $$USESSAN^RAHLRU1()
WRITE !,?1,"Case No. : ",$PIECE(RAMEMARR(RA1),U)
+30 IF '$$USESSAN^RAHLRU1()
WRITE !,?1,"Case No. : ",+RAMEMARR(RA1)
+31 IF $$USESSAN^RAHLRU1()
if $PIECE(RAMEMARR(RA1),"^",4)]""
WRITE ?40,"Exm. St : ",$EXTRACT($PIECE($GET(^RA(72,$PIECE(RAMEMARR(RA1),"^",4),0)),"^"),1,22)
WRITE !?1,"Procedure: ",$EXTRACT($PIECE($GET(^RAMIS(71,+$PIECE(RAMEMARR(RA1),"^",2),0)),"^"),1,45)
+32 IF '$$USESSAN^RAHLRU1()
if $PIECE(RAMEMARR(RA1),"^",4)]""
WRITE ?18,"Exm. St: ",$EXTRACT($PIECE($GET(^RA(72,$PIECE(RAMEMARR(RA1),"^",4),0)),"^"),1,12)
WRITE ?40,"Procedure : ",$EXTRACT($PIECE($GET(^RAMIS(71,+$PIECE(RAMEMARR(RA1),"^",2),0)),"^"),1,26)
+33 ;check printset for contrast media; display if CM data exists
+34 SET RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RA1)
+35 if $LENGTH(RACMDATA)
DO CMEDIA^RARTE(RACMDATA)
+36 KILL RACMDATA
+37 IF $PIECE(RAMEMARR(RA1),"^")["-"
SET RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,$PIECE($PIECE(RAMEMARR(RA1),"^"),"-",3)," Tech.Comment: ",15,70,-1,0)
if RA18EX=-1
QUIT
+38 ;P18
IF $PIECE(RAMEMARR(RA1),"^")'["-"
SET RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,+RAMEMARR(RA1)," Tech.Comment: ",15,70,-1,0)
if RA18EX=-1
QUIT
+39 QUIT
End DoDot:2
+40 QUIT
End DoDot:1
+41 ;continue display
+42 ;P18
IF RA18EX=-1
QUIT
+43 SET Y(0)=RASUBY0
+44 SET RAIENS=RACNI_","_RADTI_","_RADFN_","
+45 DO GETS^DIQ(70.03,RAIENS,"14;175*","E","RAOUT")
+46 WRITE !?1,"Exam Date: ",RADATE,?40,"Technologist: "
+47 SET RAIENSUB=$ORDER(RAOUT(70.12,0))
+48 if RAIENSUB]""
WRITE $EXTRACT($GET(RAOUT(70.12,RAIENSUB,.01,"E")),1,25)
+49 ;p99 begins
+50 WRITE !?1,"Req Phys : ",$EXTRACT($GET(RAOUT(70.03,RAIENS,14,"E")),1,25)
+51 IF $$PTSEX^RAUTL8(RADFN)="F"
Begin DoDot:1
+52 DO GETS^DIQ(70.03,RAIENS,"32;80","I","RAOUT")
+53 NEW RA3
SET RA3=$GET(RAOUT(70.03,RAIENS,32,"I"))
+54 if RA3'=""
WRITE !?1,"Pregnancy Screen: ",$SELECT(RA3="y":"Patient answered yes",RA3="n":"Patient answered no",RA3="u":"Patient is unable to answer or is unsure",1:"")
+55 if (RA3'="n")&($GET(RAOUT(70.03,RAIENS,80,"I"))'="")
WRITE !?1,"Pregnancy Screen Comment: ",$GET(RAOUT(70.03,RAIENS,80,"I"))
End DoDot:1
+56 ;p99 ends
+57 WRITE !,RAI
+58 QUIT
LOCK(X,Y) ; Lock the data global
+1 ; uses var DILOCKTM, code taken from rtn RAUTL12
+2 ; 'X' is the global root
+3 ; 'Y' is the record number
+4 ; KLM/163 - remove setting of RADUZ and ^TMP("RAD LOCKS"
+5 NEW RALCKFLG,XY
+6 ;S RADUZ=+$G(DUZ),RALCKFLG=0,
+7 SET RALCKFLG=0
SET XY=X_Y
+8 LOCK +@(XY_")"):DILOCKTM
+9 IF '$TEST
SET RALCKFLG=1
Begin DoDot:1
+10 WRITE !?5,"This record is being edited by another user."
+11 WRITE !?5,"Try again later!",$CHAR(7)
+12 QUIT
End DoDot:1
+13 ;E D
+14 ;. S ^TMP("RAD LOCKS",$J,RADUZ,X,Y)=""
+15 ;. Q
+16 QUIT RALCKFLG
INTRO ;
+1 ;; +--------------------------------------------------------+
+2 ;; | |
+3 ;; | This option is for restoring a deleted report. |
+4 ;; | |
+5 ;; +--------------------------------------------------------+
