- RARTE1 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Edit/Delete a Report ; Aug 25, 2020@15:11:03
- ;;5.0;Radiology/Nuclear Medicine;**2,15,17,23,31,68,56,47,124,163,162,173**;Mar 16, 1998;Build 1
- ;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 RAORDIFN,RAPRG74,RASN,RASTI,Y ;KLM/163 - removed RADUZ from kill
- 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)
- ;p173/KLM lookup on IEN should not be ambiguous.
- 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)
- ;
- ;this check is to see if a report from the outside is to be amended $G(RAXRPT)>0
- I RAXIT S:$G(RAXRPT)>0 RAERR="^RARPT("_RARPT_", could not be locked for addendum." D Q QUIT
- ;if called from RAHLO1 and the lock fails we need to set RAERR
- ;RAERR is needed back in RAHLO1 p162
- ;
- 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 ;KLM/163 - removed RADUZ from kill
- 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
- ;pre p124: "^V^EF" post p124 "^V^EF^"
- 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
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRARTE1 10120 printed Feb 19, 2025@00:05:34 Page 2
- RARTE1 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Edit/Delete a Report ; Aug 25, 2020@15:11:03
- +1 ;;5.0;Radiology/Nuclear Medicine;**2,15,17,23,31,68,56,47,124,163,162,173**;Mar 16, 1998;Build 1
- +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 ;KLM/163 - removed RADUZ from kill
- KILL 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 ;p173/KLM lookup on IEN should not be ambiguous.
- +8 IF RAXRPT
- NEW X
- SET X="`"_RAXRPT
- +9 SET RAXIT=0
- SET DIC="^RARPT("
- SET DIC("S")="I $P(^(0),U,5)=""V"""
- +10 SET DIC(0)=$SELECT('RAXRPT:"AEMQZ",1:"NZ")
- +11 DO DICW
- DO ^DIC
- KILL DIC
- IF Y<0
- DO Q
- QUIT
- +12 SET RA74B4=$GET(Y(0))
- +13 SET (RARPT,DA)=+Y
- SET RADFN=$PIECE(Y(0),U,2)
- +14 SET RADTI=9999999.9999-$PIECE(Y(0),"^",3)
- SET RACN=$PIECE(Y(0),"^",4)
- +15 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"
- +16 if RAXRPT
- SET DR="5////^S X=""D"";9///@;17///@;100///NOW"
- +17 ;11/07/2005 KAM/BAY 110020 Modified next line to look for voice recognition
- +18 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)
- +19 SET RAXIT=$$LOCK^RAUTL12("^RARPT(",RARPT)
- +20 ;
- +21 ;this check is to see if a report from the outside is to be amended $G(RAXRPT)>0
- +22 IF RAXIT
- if $GET(RAXRPT)>0
- SET RAERR="^RARPT("_RARPT_", could not be locked for addendum."
- DO Q
- QUIT
- +23 ;if called from RAHLO1 and the lock fails we need to set RAERR
- +24 ;RAERR is needed back in RAHLO1 p162
- +25 ;
- +26 DO ^DIE
- KILL DE,DQ,DIE,DR
- DO UNLOCK^RAUTL12("^RARPT(",RARPT)
- +27 NEW RA1,RA2,RA3,RA4
- SET RA1=RADFN
- SET RA2=RADTI
- SET RA3=RACN
- SET RA4=RARPT
- +28 SET RA(0)=$GET(^RARPT(RARPT,0))
- SET RA(5)=$PIECE(^RARPT(RARPT,0),"^",5)
- +29 SET RA(7)=$PIECE(^RARPT(RARPT,0),"^",7)
- SET RA(10)=$PIECE(^RARPT(RARPT,0),"^",10)
- +30 IF RA(5)'="V"
- Begin DoDot:1
- +31 IF RA(7)]""
- DO ENKILL^RAXREF(74,7,RA(7),RARPT)
- SET $PIECE(^RARPT(RARPT,0),"^",7)=""
- +32 IF RA(10)]""
- DO ENKILL^RAXREF(74,10,RA(10),RARPT)
- SET $PIECE(^RARPT(RARPT,0),"^",10)=""
- +33 NEW RADDEN,RAUTOE
- SET (RADDEN,RAUTOE)=""
- DO ^RARTR
- DO EN1^RARTE3(RA4)
- +34 QUIT
- End DoDot:1
- +35 SET RADFN=RA1
- SET RADTI=RA2
- SET RACN=RA3
- SET RARPT=RA4
- +36 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
- +37 SET DA=0
- FOR
- SET DA=$ORDER(^RABTCH(74.4,"B",RARPT,DA))
- if 'DA
- QUIT
- Begin DoDot:2
- +38 SET DIK="^RABTCH(74.4,"
- DO ^DIK
- +39 QUIT
- End DoDot:2
- +40 QUIT
- End DoDot:1
- +41 ; women's health
- IF "^V^EF^"'[("^"_$PIECE($GET(^RARPT(RARPT,0)),"^",5)_"^")
- IF $TEXT(DELETE^WVRALINK)]""
- DO DELETE^WVRALINK(RADFN,RADTI,RACNI)
- +42 ;
- 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 ;KLM/163 - removed RADUZ from kill
- KILL RASTI,RAXIT,X,XQUIT,Y,RA74B4,DDH,DIPGM,DISYS,I
- +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 ;pre p124: "^V^EF" post p124 "^V^EF^"
- +2 ; women's health
- IF "^V^EF^"[("^"_$PIECE(^RARPT(RARPT,0),U,5)_"^")
- IF $TEXT(CREATE^WVRALINK)]""
- DO CREATE^WVRALINK(RADFN,RADTI,RACNI)
- +3 QUIT
- +4 ;
- 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 ;