RARTE1 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Edit/Delete a Report ;6/10/98 16:08
;;5.0;Radiology/Nuclear Medicine;**2,15,17,23,31,68,56,47**;Mar 16, 1998;Build 21
;Private IA #4793 DELETE^WVRALINK, CREATE^WVRALINK
;Supported IA #10035
;Supported IA #10007
;11/07/2005 KAM/BAY 110020 - Correct DUZ ID from Talk Technology
; During the Unverify process
DEL D SET^RAPSET1 I $D(XQUIT) K XQUIT Q
S (RAPRG74,RAXIT)=0
S DIC("A")="Select Report Day-Case#: "
S DIC("W")="S RA0=^(0) W "" "",$S($D(^DPT(+$P(RA0,""^"",2),0)):$P(^(0),""^""),1:""Unknown"") K RA0 W "" "",$$FLD^RARTFLDS(+Y,""PROC"")"
S DIC("S")="I $P(^(0),U,5)'=""X""" ;select only non-deleted reports
S DIC="^RARPT(",DIC(0)="AEMQZ" D ^DIC K DIC G END:Y<0
S RA0=Y(0),(DA,RAIEN)=+Y
I $O(^RARPT(RAIEN,2005,0)) D D END Q
. W !!?5,"Cannot delete a report that is associated with an image."
. W !?5,"Contact your Imaging Coordinator for further assistance.",!
. S DIR(0)="E",DIR("A")="Press RETURN to continue"
. D ^DIR K DIR,DIRUT,DUOUT
. Q ;08/23/00
D CHK17^RARTE3 ;see this subroutine for values of RAOK
G:RAOK=1 END ;can't del rpt w/o RACN or RACNI so avoid err at UP1^RAUTL1
S RAXIT=$$LOCK^RAUTL12("^RARPT(",RAIEN)
I RAXIT K RAXIT D END Q ; record locked by another
ASKDEL ; ask if deletion is appropriate
R !!,"Do you wish to delete this report? NO// ",X:DTIME
S:'$T!(X="")!(X["^") X="N"
I "Nn"[$E(X) D UNLOCK^RAUTL12("^RARPT(",RAIEN) G DEL
I "Yy"'[$E(X) D G ASKDEL
. W:X'["?" $C(7)
. W !!?3,"Enter 'YES' to delete this report, or 'NO' not to."
. Q
; comment out next line, these 3 vars are already set by CHK17^RARTE3
;S RADFN=+$P(RA0,"^",2),RADTI=9999999.9999-$P(RA0,"^",3),RACN=$P(RA0,"^",4)
G:RAOK=2 AD2 ;don't remove piece 17 if rpt doesn't match exm's rpt ptr
; del other member's REPORT TEXT xrefs, and set pointer to #74 as null
D DEL17^RARTE2(RAIEN) ;del ptrs to file 74 excluding lead case of prtset
S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0))
G:'$D(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0))#2 AD2
; kill any xrefs for file #70's REPORT TEXT
S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI D ENKILL^RAXREF(70.03,17,RAIEN,.DA)
; set REPORT TEXT to null
S $P(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0),"^",17)=""
AD2 K RAXIT S RAPRG74=1 ;RAPRG74 used in kill logic file 74 fld .01
D MARKDEL^RARTE7 ; mark report deleted, save DXs, remov DXs fm case(s)
W !?10,"...report deletion complete."
D:RAOK'=2 UP1^RAUTL1 ;skip update status if report doesn't belong to exm
D UPDTPNT^RAUTL9(RAIEN) ; Update pointers in 74.2, and 74.4!
D UNLOCK^RAUTL12("^RARPT(",RAIEN) ; unlock report
I RAOK'=2,$T(DELETE^WVRALINK)]"" D DELETE^WVRALINK(RADFN,RADTI,RACNI) ; women's health, skip if report doesn't belong to exm
END K %,%Y,D0,DA,DIC,DIE,RAJ1,DIK,RADFN,RADTI,RACN,RACNI,RA0,RAIEN,RAOR
K RADUZ,RAORDIFN,RAPRG74,RASN,RASTI,Y
K RADATE,RADTE,X
K RA791,RACANC,RACN0,RACPT,RACPTNDE,RAI,RAN,RAOBR4,RAPKG,RAPRCNDE,RAPROC,RAPROCIT,RAPRV,RASULT,RAXIT
K C,D,D1,DDER,DDH,DFN,DI,DISYS,DIWF,DIWL,DIWR,DQ,DR,GMRAL,HLN,HLRESLT,HLSAN,I,VA,VADM,VAERR,X0
Q
;
UNVER(RAXRPT) ; unverify a report
; Input: if RAXRPT>0 then we know the report we wish to delete
; this requires no user interaction.
; RAXRPT=0 user is prompted for the report they wish to
; delete (interactive)
;
I 'RAXRPT D SET^RAPSET1 G Q:$D(XQUIT)
I RAXRPT N X S X=RAXRPT
S RAXIT=0,DIC="^RARPT(",DIC("S")="I $P(^(0),U,5)=""V"""
S DIC(0)=$S('RAXRPT:"AEMQZ",1:"NZ")
D DICW,^DIC K DIC I Y<0 D Q Q
S RA74B4=$G(Y(0))
S (RARPT,DA)=+Y,RADFN=$P(Y(0),U,2)
S RADTI=9999999.9999-$P(Y(0),"^",3),RACN=$P(Y(0),"^",4)
I 'RAXRPT S DR="D EN1^RAUTL9 I $D(DIRUT) S Y=""@99"";S:RASTATX'=""PD"" Y=""@10"";25;@10;5////^S X=RASTATX;S:X=""V"" Y=""@99"";9///@;17///@;100///NOW;@99"
S:RAXRPT DR="5////^S X=""D"";9///@;17///@;100///NOW"
;11/07/2005 KAM/BAY 110020 Modified next line to look for voice recognition
S DIE="^RARPT(",DR(2,74.01)="2////U;3////"_$S(($D(RAQUIET)#2)&($D(RASUB)#2):$G(^TMP("RARPT-REC",$J,RASUB,"RAVERF")),1:DUZ)
S RAXIT=$$LOCK^RAUTL12("^RARPT(",RARPT)
I RAXIT D Q QUIT
D ^DIE K DE,DQ,DIE,DR D UNLOCK^RAUTL12("^RARPT(",RARPT)
N RA1,RA2,RA3,RA4 S RA1=RADFN,RA2=RADTI,RA3=RACN,RA4=RARPT
S RA(0)=$G(^RARPT(RARPT,0)),RA(5)=$P(^RARPT(RARPT,0),"^",5)
S RA(7)=$P(^RARPT(RARPT,0),"^",7),RA(10)=$P(^RARPT(RARPT,0),"^",10)
I RA(5)'="V" D
. I RA(7)]"" D ENKILL^RAXREF(74,7,RA(7),RARPT) S $P(^RARPT(RARPT,0),"^",7)=""
. I RA(10)]"" D ENKILL^RAXREF(74,10,RA(10),RARPT) S $P(^RARPT(RARPT,0),"^",10)=""
. N RADDEN,RAUTOE S (RADDEN,RAUTOE)="" D ^RARTR,EN1^RARTE3(RA4)
. Q
S RADFN=RA1,RADTI=RA2,RACN=RA3,RARPT=RA4
S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) I $D(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0)) D UP1^RAUTL1 I $D(^RABTCH(74.4,"B",RARPT)) D
.S DA=0 F S DA=$O(^RABTCH(74.4,"B",RARPT,DA)) Q:'DA D
..S DIK="^RABTCH(74.4," D ^DIK
..Q
.Q
I "^V^EF^"'[("^"_$P($G(^RARPT(RARPT,0)),"^",5)_"^"),$T(DELETE^WVRALINK)]"" D DELETE^WVRALINK(RADFN,RADTI,RACNI) ; women's health
;
Q ; Kill and quit
K DFN,DI,DIW,DIWF,DIWI,DIWL,DIWT,DIWTC,DIWX,RAACNT,RANUM,RAST,RAWHOVER
K %,%DT,%W,%Y,%Y1,C,D,D0,D1,DA,DIC,DIE,DIK,DR,RA,RACN,RACNI,RADATE
K RADFN,RADIV,RADTE,RADTI,RAJ,RAOR,RAORDIFN,RARPT,RASET,RASN,RASTATX
K RASTI,RAXIT,X,XQUIT,Y,RA74B4,DDH,DIPGM,DISYS,I,RADUZ
Q
;
STD S (RALR,RALI)=1
STD1 S DIC="^RA(74.1,",DIC("A")="Select 'Standard' Report to Copy: ",DIC(0)="AEMQ" D ^DIC K DIC("A") Q:Y<0
ASKSEL W:$$IMPRPT(RARPT) !!,"Report already exists. This will over-write it."
W !,"Are you sure you want the '",$P(Y,"^",2),"' standard report? No// " R X:DTIME G STD1:'$T!(X="")!(X["^")!("Nn"[$E(X))
I "Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to select the '",$P(Y,"^",2),"' standard report, or 'NO' not to." G ASKSEL
I RALR=1,RALI=1 K ^RARPT(RARPT,"R"),^("I")
F I=1:1 Q:'$D(^RA(74.1,+Y,"R",I,0)) S ^RARPT(RARPT,"R",RALR,0)=^(0),RALR=RALR+1
F I=1:1 Q:'$D(^RA(74.1,+Y,"I",I,0)) S ^RARPT(RARPT,"I",RALI,0)=^(0),RALI=RALI+1
ASKADD R !!,"Do you want to add another standard to this report? No// ",X:DTIME Q:'$T!(X="")!(X["^")!("Nn"[$E(X)) I "Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to add another standard to this report, or 'NO' not to." G ASKADD
S (^RARPT(RARPT,"R",RALR,0),^RARPT(RARPT,"I",RALI,0))="",RALR=RALR+1,RALI=RALI+1 W ! G STD1
;
EDTRPT ; Called from 'RARTE4' and 'RARTVER'.
N RAXIT S RACT=$S('+$G(^RARPT(RARPT,"T")):"I",1:"E")
S:'$D(^RARPT(RARPT,"T")) ^("T")=""
S DA=RARPT,DR="[RA REPORT EDIT]",DIE="^RARPT(" D ^DIE K DE,DQ ;,RAFLAGK
I $D(Y),RACT="V",'$P(^RARPT(RARPT,0),"^",9) W !,$C(7),"You must enter a verifying Interpreting Physician to 'VERIFY' a report.",!?3,"...report status will now be changed to 'DRAFT'." S DA=RARPT,DR="5///D" D ^DIE K DE,DQ ;Q
Q:$D(RAONLINE)&($G(RARDX)="E")
; move PACS line to its own subroutine
;I $D(RAFLAGK) K RAFLAGK Q
G:$D(Y) PACS
;Since report editing is not necessarily screened by sign-on imaging
;type, use the imaging type on the exam record ;ch
S RAIMGTYI=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2),RAIMGTYJ=$P($G(^RA(79.2,+RAIMGTYI,0)),U)
S X=+$O(^RA(72,"AA",RAIMGTYJ,9,0)),DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," K RAIMGTYI,RAIMGTYJ
S DR=13_$S(RACT'="V":"",'$D(^RA(72,X,.1)):"",$P(^(.1),"^",5)'="Y":"",1:"R")_";I $D(^RA(78.3,+X,0)),$P(^(0),""^"",4)=""y"" S RAAB=1"
;
;lock the correct sub-file (pset?)
D DXLOC
;
I RACT="V",$P($G(^RA(72,X,.1)),"^",5)="Y" S DIE("NO^")="BACK"
I 'RAXIT D ^DIE K DA,DE,DQ,DIE,DR
I RAXIT!($P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13)="")!($D(Y)) D DXULOC G PACS
S DR="50///"_RACN
S DR(2,70.03)=13.1
S DR(3,70.14)=.01_";I $D(^RA(78.3,+X,0)),$P(^(0),""^"",4)=""y"" S RAAB=1"
S DA(1)=RADFN,DA=RADTI,DIE="^RADPT("_DA(1)_",""DT"","
;
I 'RAXIT D ^DIE K DA,DE,DQ,DIE,DR
;
COPYDX ;if we have a printset copy over the Dx code data (both primary & secondary)
;to all our descendents before building our HL7 ORU messsages.
I RAPRTSET S RADRS=1,RAXIT=0 D COPY^RARTE2 ;P47
;unlock the correct sub-file (pset?)
D DXULOC
;
PACS I ($P(^RARPT(RARPT,0),U,5)="V")!($P(^(0),U,5)="R") D RPT^RAHLRPC
I "^V^EF"[("^"_$P(^RARPT(RARPT,0),U,5)_"^"),$T(CREATE^WVRALINK)]"" D CREATE^WVRALINK(RADFN,RADTI,RACNI) ; women's health
Q
;
ASKBTCH R !!,"Do you want to batch print reports? Yes// ",X:DTIME S:'$T X="^" S:X="" X="Y" Q:X["^" I "Nn"'[$E(X),"Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to batch print reports, or 'NO' not to." G ASKBTCH
Q
;
ASKPRT R !!,"Do you want to print batch now? No// ",X:DTIME S:'$T!(X="")!(X["^") X="N" I "Nn"'[$E(X),"Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to print this batch, or 'NO' not to." G ASKPRT
Q
DICW ; Build DIC("W") string
N DO D DO^DIC1
S DIC("W")=$S($G(DIC("W"))]"":DIC("W")_" ",1:"")_"W "" "",$$FLD^RARTFLDS(+Y,""PROC"")"
Q
IMPRPT(Y) ; Does the report we are currently editing have either Report
; or Impression Text?
; Input : 'Y' - the ien of the report being edited
; Output: '1' - either impression or report text exists, '0' - neither
; report or impression text exists.
Q $S(+$O(^RARPT(Y,"I",0)):1,+$O(^RARPT(Y,"R",0)):1,1:0)
;
DXLOC ;lock the correct RAD/NUC MED PATIENT sub-file
S:'RAPRTSET RAXIT=$$LOCK^RAUTL12("^RADPT("_RADFN_",""DT"","_RADTI_",""P"",",RACNI)
S:RAPRTSET RAXIT=$$LOCK^RAUTL12("^RADPT("_RADFN_",""DT"",",RADTI)
Q
;
DXULOC ;unlock the correct RAD/NUC MED PATIENT sub-file
D:'RAPRTSET UNLOCK^RAUTL12("^RADPT("_RADFN_",""DT"","_RADTI_",""P"",",RACNI)
D:RAPRTSET UNLOCK^RAUTL12("^RADPT("_RADFN_",""DT"",",RADTI)
Q
;
RARTE1 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Edit/Delete a Report ;6/10/98 16:08
+1 ;;5.0;Radiology/Nuclear Medicine;**2,15,17,23,31,68,56,47**;Mar 16, 1998;Build 21
+2 ;Private IA #4793 DELETE^WVRALINK, CREATE^WVRALINK
+3 ;Supported IA #10035
+4 ;Supported IA #10007
+5 ;11/07/2005 KAM/BAY 110020 - Correct DUZ ID from Talk Technology
+6 ; During the Unverify process
DEL DO SET^RAPSET1
IF $DATA(XQUIT)
KILL XQUIT
QUIT
+1 SET (RAPRG74,RAXIT)=0
+2 SET DIC("A")="Select Report Day-Case#: "
+3 SET DIC("W")="S RA0=^(0) W "" "",$S($D(^DPT(+$P(RA0,""^"",2),0)):$P(^(0),""^""),1:""Unknown"") K RA0 W "" "",$$FLD^RARTFLDS(+Y,""PROC"")"
+4 ;select only non-deleted reports
SET DIC("S")="I $P(^(0),U,5)'=""X"""
+5 SET DIC="^RARPT("
SET DIC(0)="AEMQZ"
DO ^DIC
KILL DIC
IF Y<0
GOTO END
+6 SET RA0=Y(0)
SET (DA,RAIEN)=+Y
+7 IF $ORDER(^RARPT(RAIEN,2005,0))
Begin DoDot:1
+8 WRITE !!?5,"Cannot delete a report that is associated with an image."
+9 WRITE !?5,"Contact your Imaging Coordinator for further assistance.",!
+10 SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
+11 DO ^DIR
KILL DIR,DIRUT,DUOUT
+12 ;08/23/00
QUIT
End DoDot:1
DO END
QUIT
+13 ;see this subroutine for values of RAOK
DO CHK17^RARTE3
+14 ;can't del rpt w/o RACN or RACNI so avoid err at UP1^RAUTL1
IF RAOK=1
GOTO END
+15 SET RAXIT=$$LOCK^RAUTL12("^RARPT(",RAIEN)
+16 ; record locked by another
IF RAXIT
KILL RAXIT
DO END
QUIT
ASKDEL ; ask if deletion is appropriate
+1 READ !!,"Do you wish to delete this report? NO// ",X:DTIME
+2 IF '$TEST!(X="")!(X["^")
SET X="N"
+3 IF "Nn"[$EXTRACT(X)
DO UNLOCK^RAUTL12("^RARPT(",RAIEN)
GOTO DEL
+4 IF "Yy"'[$EXTRACT(X)
Begin DoDot:1
+5 IF X'["?"
WRITE $CHAR(7)
+6 WRITE !!?3,"Enter 'YES' to delete this report, or 'NO' not to."
+7 QUIT
End DoDot:1
GOTO ASKDEL
+8 ; comment out next line, these 3 vars are already set by CHK17^RARTE3
+9 ;S RADFN=+$P(RA0,"^",2),RADTI=9999999.9999-$P(RA0,"^",3),RACN=$P(RA0,"^",4)
+10 ;don't remove piece 17 if rpt doesn't match exm's rpt ptr
IF RAOK=2
GOTO AD2
+11 ; del other member's REPORT TEXT xrefs, and set pointer to #74 as null
+12 ;del ptrs to file 74 excluding lead case of prtset
DO DEL17^RARTE2(RAIEN)
+13 SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0))
+14 IF '$DATA(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0))#2
GOTO AD2
+15 ; kill any xrefs for file #70's REPORT TEXT
+16 SET DA(2)=RADFN
SET DA(1)=RADTI
SET DA=RACNI
DO ENKILL^RAXREF(70.03,17,RAIEN,.DA)
+17 ; set REPORT TEXT to null
+18 SET $PIECE(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0),"^",17)=""
AD2 ;RAPRG74 used in kill logic file 74 fld .01
KILL RAXIT
SET RAPRG74=1
+1 ; mark report deleted, save DXs, remov DXs fm case(s)
DO MARKDEL^RARTE7
+2 WRITE !?10,"...report deletion complete."
+3 ;skip update status if report doesn't belong to exm
IF RAOK'=2
DO UP1^RAUTL1
+4 ; Update pointers in 74.2, and 74.4!
DO UPDTPNT^RAUTL9(RAIEN)
+5 ; unlock report
DO UNLOCK^RAUTL12("^RARPT(",RAIEN)
+6 ; women's health, skip if report doesn't belong to exm
IF RAOK'=2
IF $TEXT(DELETE^WVRALINK)]""
DO DELETE^WVRALINK(RADFN,RADTI,RACNI)
END KILL %,%Y,D0,DA,DIC,DIE,RAJ1,DIK,RADFN,RADTI,RACN,RACNI,RA0,RAIEN,RAOR
+1 KILL RADUZ,RAORDIFN,RAPRG74,RASN,RASTI,Y
+2 KILL RADATE,RADTE,X
+3 KILL RA791,RACANC,RACN0,RACPT,RACPTNDE,RAI,RAN,RAOBR4,RAPKG,RAPRCNDE,RAPROC,RAPROCIT,RAPRV,RASULT,RAXIT
+4 KILL C,D,D1,DDER,DDH,DFN,DI,DISYS,DIWF,DIWL,DIWR,DQ,DR,GMRAL,HLN,HLRESLT,HLSAN,I,VA,VADM,VAERR,X0
+5 QUIT
+6 ;
UNVER(RAXRPT) ; unverify a report
+1 ; Input: if RAXRPT>0 then we know the report we wish to delete
+2 ; this requires no user interaction.
+3 ; RAXRPT=0 user is prompted for the report they wish to
+4 ; delete (interactive)
+5 ;
+6 IF 'RAXRPT
DO SET^RAPSET1
IF $DATA(XQUIT)
GOTO Q
+7 IF RAXRPT
NEW X
SET X=RAXRPT
+8 SET RAXIT=0
SET DIC="^RARPT("
SET DIC("S")="I $P(^(0),U,5)=""V"""
+9 SET DIC(0)=$SELECT('RAXRPT:"AEMQZ",1:"NZ")
+10 DO DICW
DO ^DIC
KILL DIC
IF Y<0
DO Q
QUIT
+11 SET RA74B4=$GET(Y(0))
+12 SET (RARPT,DA)=+Y
SET RADFN=$PIECE(Y(0),U,2)
+13 SET RADTI=9999999.9999-$PIECE(Y(0),"^",3)
SET RACN=$PIECE(Y(0),"^",4)
+14 IF 'RAXRPT
SET DR="D EN1^RAUTL9 I $D(DIRUT) S Y=""@99"";S:RASTATX'=""PD"" Y=""@10"";25;@10;5////^S X=RASTATX;S:X=""V"" Y=""@99"";9///@;17///@;100///NOW;@99"
+15 IF RAXRPT
SET DR="5////^S X=""D"";9///@;17///@;100///NOW"
+16 ;11/07/2005 KAM/BAY 110020 Modified next line to look for voice recognition
+17 SET DIE="^RARPT("
SET DR(2,74.01)="2////U;3////"_$SELECT(($DATA(RAQUIET)#2)&($DATA(RASUB)#2):$GET(^TMP("RARPT-REC",$JOB,RASUB,"RAVERF")),1:DUZ)
+18 SET RAXIT=$$LOCK^RAUTL12("^RARPT(",RARPT)
+19 IF RAXIT
DO Q
QUIT
+20 DO ^DIE
KILL DE,DQ,DIE,DR
DO UNLOCK^RAUTL12("^RARPT(",RARPT)
+21 NEW RA1,RA2,RA3,RA4
SET RA1=RADFN
SET RA2=RADTI
SET RA3=RACN
SET RA4=RARPT
+22 SET RA(0)=$GET(^RARPT(RARPT,0))
SET RA(5)=$PIECE(^RARPT(RARPT,0),"^",5)
+23 SET RA(7)=$PIECE(^RARPT(RARPT,0),"^",7)
SET RA(10)=$PIECE(^RARPT(RARPT,0),"^",10)
+24 IF RA(5)'="V"
Begin DoDot:1
+25 IF RA(7)]""
DO ENKILL^RAXREF(74,7,RA(7),RARPT)
SET $PIECE(^RARPT(RARPT,0),"^",7)=""
+26 IF RA(10)]""
DO ENKILL^RAXREF(74,10,RA(10),RARPT)
SET $PIECE(^RARPT(RARPT,0),"^",10)=""
+27 NEW RADDEN,RAUTOE
SET (RADDEN,RAUTOE)=""
DO ^RARTR
DO EN1^RARTE3(RA4)
+28 QUIT
End DoDot:1
+29 SET RADFN=RA1
SET RADTI=RA2
SET RACN=RA3
SET RARPT=RA4
+30 SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0))
IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0))
DO UP1^RAUTL1
IF $DATA(^RABTCH(74.4,"B",RARPT))
Begin DoDot:1
+31 SET DA=0
FOR
SET DA=$ORDER(^RABTCH(74.4,"B",RARPT,DA))
IF 'DA
QUIT
Begin DoDot:2
+32 SET DIK="^RABTCH(74.4,"
DO ^DIK
+33 QUIT
End DoDot:2
+34 QUIT
End DoDot:1
+35 ; women's health
IF "^V^EF^"'[("^"_$PIECE($GET(^RARPT(RARPT,0)),"^",5)_"^")
IF $TEXT(DELETE^WVRALINK)]""
DO DELETE^WVRALINK(RADFN,RADTI,RACNI)
+36 ;
Q ; Kill and quit
+1 KILL DFN,DI,DIW,DIWF,DIWI,DIWL,DIWT,DIWTC,DIWX,RAACNT,RANUM,RAST,RAWHOVER
+2 KILL %,%DT,%W,%Y,%Y1,C,D,D0,D1,DA,DIC,DIE,DIK,DR,RA,RACN,RACNI,RADATE
+3 KILL RADFN,RADIV,RADTE,RADTI,RAJ,RAOR,RAORDIFN,RARPT,RASET,RASN,RASTATX
+4 KILL RASTI,RAXIT,X,XQUIT,Y,RA74B4,DDH,DIPGM,DISYS,I,RADUZ
+5 QUIT
+6 ;
STD SET (RALR,RALI)=1
STD1 SET DIC="^RA(74.1,"
SET DIC("A")="Select 'Standard' Report to Copy: "
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC("A")
IF Y<0
QUIT
ASKSEL IF $$IMPRPT(RARPT)
WRITE !!,"Report already exists. This will over-write it."
+1 WRITE !,"Are you sure you want the '",$PIECE(Y,"^",2),"' standard report? No// "
READ X:DTIME
IF '$TEST!(X="")!(X["^")!("Nn"[$EXTRACT(X))
GOTO STD1
+2 IF "Yy"'[$EXTRACT(X)
IF X'["?"
WRITE $CHAR(7)
WRITE !!?3,"Enter 'YES' to select the '",$PIECE(Y,"^",2),"' standard report, or 'NO' not to."
GOTO ASKSEL
+3 IF RALR=1
IF RALI=1
KILL ^RARPT(RARPT,"R"),^("I")
+4 FOR I=1:1
IF '$DATA(^RA(74.1,+Y,"R",I,0))
QUIT
SET ^RARPT(RARPT,"R",RALR,0)=^(0)
SET RALR=RALR+1
+5 FOR I=1:1
IF '$DATA(^RA(74.1,+Y,"I",I,0))
QUIT
SET ^RARPT(RARPT,"I",RALI,0)=^(0)
SET RALI=RALI+1
ASKADD READ !!,"Do you want to add another standard to this report? No// ",X:DTIME
IF '$TEST!(X="")!(X["^")!("Nn"[$EXTRACT(X))
QUIT
IF "Yy"'[$EXTRACT(X)
IF X'["?"
WRITE $CHAR(7)
WRITE !!?3,"Enter 'YES' to add another standard to this report, or 'NO' not to."
GOTO ASKADD
+1 SET (^RARPT(RARPT,"R",RALR,0),^RARPT(RARPT,"I",RALI,0))=""
SET RALR=RALR+1
SET RALI=RALI+1
WRITE !
GOTO STD1
+2 ;
EDTRPT ; Called from 'RARTE4' and 'RARTVER'.
+1 NEW RAXIT
SET RACT=$SELECT('+$GET(^RARPT(RARPT,"T")):"I",1:"E")
+2 IF '$DATA(^RARPT(RARPT,"T"))
SET ^("T")=""
+3 ;,RAFLAGK
SET DA=RARPT
SET DR="[RA REPORT EDIT]"
SET DIE="^RARPT("
DO ^DIE
KILL DE,DQ
+4 ;Q
IF $DATA(Y)
IF RACT="V"
IF '$PIECE(^RARPT(RARPT,0),"^",9)
WRITE !,$CHAR(7),"You must enter a verifying Interpreting Physician to 'VERIFY' a report.",!?3,"...report status will now be changed to 'DRAFT'."
SET DA=RARPT
SET DR="5///D"
DO ^DIE
KILL DE,DQ
+5 IF $DATA(RAONLINE)&($GET(RARDX)="E")
QUIT
+6 ; move PACS line to its own subroutine
+7 ;I $D(RAFLAGK) K RAFLAGK Q
+8 IF $DATA(Y)
GOTO PACS
+9 ;Since report editing is not necessarily screened by sign-on imaging
+10 ;type, use the imaging type on the exam record ;ch
+11 SET RAIMGTYI=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,0)),U,2)
SET RAIMGTYJ=$PIECE($GET(^RA(79.2,+RAIMGTYI,0)),U)
+12 SET X=+$ORDER(^RA(72,"AA",RAIMGTYJ,9,0))
SET DA(2)=RADFN
SET DA(1)=RADTI
SET DA=RACNI
SET DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
KILL RAIMGTYI,RAIMGTYJ
+13 SET DR=13_$SELECT(RACT'="V":"",'$DATA(^RA(72,X,.1)):"",$PIECE(^(.1),"^",5)'="Y":"",1:"R")_";I $D(^RA(78.3,+X,0)),$P(^(0),""^"",4)=""y"" S RAAB=1"
+14 ;
+15 ;lock the correct sub-file (pset?)
+16 DO DXLOC
+17 ;
+18 IF RACT="V"
IF $PIECE($GET(^RA(72,X,.1)),"^",5)="Y"
SET DIE("NO^")="BACK"
+19 IF 'RAXIT
DO ^DIE
KILL DA,DE,DQ,DIE,DR
+20 IF RAXIT!($PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13)="")!($DATA(Y))
DO DXULOC
GOTO PACS
+21 SET DR="50///"_RACN
+22 SET DR(2,70.03)=13.1
+23 SET DR(3,70.14)=.01_";I $D(^RA(78.3,+X,0)),$P(^(0),""^"",4)=""y"" S RAAB=1"
+24 SET DA(1)=RADFN
SET DA=RADTI
SET DIE="^RADPT("_DA(1)_",""DT"","
+25 ;
+26 IF 'RAXIT
DO ^DIE
KILL DA,DE,DQ,DIE,DR
+27 ;
COPYDX ;if we have a printset copy over the Dx code data (both primary & secondary)
+1 ;to all our descendents before building our HL7 ORU messsages.
+2 ;P47
IF RAPRTSET
SET RADRS=1
SET RAXIT=0
DO COPY^RARTE2
+3 ;unlock the correct sub-file (pset?)
+4 DO DXULOC
+5 ;
PACS IF ($PIECE(^RARPT(RARPT,0),U,5)="V")!($PIECE(^(0),U,5)="R")
DO RPT^RAHLRPC
+1 ; women's health
IF "^V^EF"[("^"_$PIECE(^RARPT(RARPT,0),U,5)_"^")
IF $TEXT(CREATE^WVRALINK)]""
DO CREATE^WVRALINK(RADFN,RADTI,RACNI)
+2 QUIT
+3 ;
ASKBTCH READ !!,"Do you want to batch print reports? Yes// ",X:DTIME
IF '$TEST
SET X="^"
IF X=""
SET X="Y"
IF X["^"
QUIT
IF "Nn"'[$EXTRACT(X)
IF "Yy"'[$EXTRACT(X)
IF X'["?"
WRITE $CHAR(7)
WRITE !!?3,"Enter 'YES' to batch print reports, or 'NO' not to."
GOTO ASKBTCH
+1 QUIT
+2 ;
ASKPRT READ !!,"Do you want to print batch now? No// ",X:DTIME
IF '$TEST!(X="")!(X["^")
SET X="N"
IF "Nn"'[$EXTRACT(X)
IF "Yy"'[$EXTRACT(X)
IF X'["?"
WRITE $CHAR(7)
WRITE !!?3,"Enter 'YES' to print this batch, or 'NO' not to."
GOTO ASKPRT
+1 QUIT
DICW ; Build DIC("W") string
+1 NEW DO
DO DO^DIC1
+2 SET DIC("W")=$SELECT($GET(DIC("W"))]"":DIC("W")_" ",1:"")_"W "" "",$$FLD^RARTFLDS(+Y,""PROC"")"
+3 QUIT
IMPRPT(Y) ; Does the report we are currently editing have either Report
+1 ; or Impression Text?
+2 ; Input : 'Y' - the ien of the report being edited
+3 ; Output: '1' - either impression or report text exists, '0' - neither
+4 ; report or impression text exists.
+5 QUIT $SELECT(+$ORDER(^RARPT(Y,"I",0)):1,+$ORDER(^RARPT(Y,"R",0)):1,1:0)
+6 ;
DXLOC ;lock the correct RAD/NUC MED PATIENT sub-file
+1 IF 'RAPRTSET
SET RAXIT=$$LOCK^RAUTL12("^RADPT("_RADFN_",""DT"","_RADTI_",""P"",",RACNI)
+2 IF RAPRTSET
SET RAXIT=$$LOCK^RAUTL12("^RADPT("_RADFN_",""DT"",",RADTI)
+3 QUIT
+4 ;
DXULOC ;unlock the correct RAD/NUC MED PATIENT sub-file
+1 IF 'RAPRTSET
DO UNLOCK^RAUTL12("^RADPT("_RADFN_",""DT"","_RADTI_",""P"",",RACNI)
+2 IF RAPRTSET
DO UNLOCK^RAUTL12("^RADPT("_RADFN_",""DT"",",RADTI)
+3 QUIT
+4 ;
