RARTE5 ;HISC/SWM AISC/MJK,RMO - Enter/Edit Outside Reports ; Mar 01, 2023@12:04:48
;;5.0;Radiology/Nuclear Medicine;**56,95,97,47,141,124,184,186,200**;Mar 16, 1998;Build 2
;
; 3-p200 3/01/2023 KLM RA*5*200 INC26245936 - Undefined RABIREQ variable
;
;Private IA #4793 CREATE^WVRALINK
;Controlled IA #3544 ^VA(200
;Supported IA #2056 GET1^DIQ
;Supported IA #10013 IX1^DIK
;Supported IA #10141 MES^XPDUTL
; adapted from RARTE, RARTE1, RARTE4
F I=1:1:10 W !?3,$P($T(INTRO+I),";;",2)
W ! D SET^RAPSET1 I $D(XQUIT) K XQUIT Q
N RAXIT,RASUBY0,RA18EX,RAPRTSET,RAMEMARR,RA1,RA7003
S RAXIT=0
K RASSS,RASSSX ;clear HL7 exclusion vars
I $D(RANOSCRN) S X=$$DIVLOC^RAUTL7() I X D Q1 QUIT
;
; only require any Radiology Classification in New Person file
S X=0 F I="C","R","S","T" S:$D(^VA(200,"ARC",I,DUZ)) X=1
I 'X W !,"Your user account is missing a Radiology classification.",! D INCRPT Q
;
START S RAFIRST=0 ;=1 for 1st time rpt given "EF" rpt status
K RAVER,RAX S (RAVW,RAX)="",RAREPORT=1 D ^RACNLU G Q1:"^"[X
; RACNLU defines RADFN, RADTI, RACNI, RARPT
S RASUBY0=Y(0) ; save value of Y(0)
;// begin RA*5.0*186 mods //
;Note: Y(0) = zero node of the case from the EXAMINATIONS (#70.03) multiple
I +$P(Y(0),U,2)=0 D GOTO START
.NEW ACCESSION S ACCESSION=$P(Y(0),U,31)
.S:ACCESSION="" ACCESSION=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_+Y(0)
.W !!,"Warning: This case: '"_ACCESSION_"' is missing a procedure.",!
.Q
I $$BROAD($P(Y(0),U,2))=1 D GOTO START
.W !!,"Broad procedures are not allowed with Outside Reports.",!
.Q
;// end RA*5.0*186 mods //
N RASSAN,RACNDSP S RASSAN=$P(RASUBY0,U,31)
S RACNDSP=$S((RASSAN'=""):RASSAN,1:$P(RASUBY0,U,1))
G:$P(^RA(72,+RAST,0),"^",3)>0 CONTIN
I $D(^XUSEC("RA MGR",DUZ)) G CONTIN
G:$P(RAMDV,"^",22)=1 CONTIN
W $C(7),!!,"The STATUS for this case is CANCELLED. You may not enter a report.",!! D INCRPT G START
;
CONTIN ; continue
S RAXIT=0 D DISPLAY^RARTE6
I RA18EX=-1 D INCRPT G START
;RA184/KLM - Add warning for anything other than NO CREDIT registered exam (NSR20210806)
I $$REGCR() W !!,$C(7),"** WARNING, this case is not registered in an OUTSIDE imaging location. **",! K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you want to continue" D ^DIR I Y=0 D INCRPT G START
; raprtset is defined in display^rarte6
S RAPNODE="^RADPT("_RADFN_",""DT"","_RADTI_",""P"","
S RA7003=@(RAPNODE_RACNI_",0)")
S RAXIT=$$LOCK^RARTE6(RAPNODE,RACNI) I RAXIT D INCRPT G START
;
; Real rpt must have fld 5="EF" & fld 18 w/ data. Stub rpt allowed
I $D(^RARPT(+RARPT,0)),(($P(^(0),"^",5)'="EF")!($P(^(0),"^",18)="")),'$$STUB^RAEDCN1(+RARPT) W !?3,$C(7),"Only Electronically Filed reports can be selected!",! D UNLOCK^RAUTL12(RAPNODE,RACNI) D INCRPT G START
;Create new rpt, or skip to IN to edit existing report
G IN:$D(^RARPT(+RARPT,0))
;
G:'RAPRTSET NEW G:$P(^RA(72,+RAST,0),"^",3)>0 NEW
; case is part of a print set, AND is cancelled
N RA2 S (RA1,RA2)=""
F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" S:$P(RAMEMARR(RA1),"^",3)]"" RA2=$P(RAMEMARR(RA1),"^",3)
G:RA2="" NEW
W !!,$C(7),"Other cases of this cancelled case ",RACN,"'s print set are entered in a report already",!!,"You may NOT create a new report for this cancelled case,",!,"but you may include this cancelled case in the existing report."
W !!,"Do you want to include this cancelled case in the same report",!,"as the others in the print set ?"
S %=2 D YN^DICN
W:%>0 "...",$S(%=1:"Include",1:"Skip")," this case"
P124 ;fix for RA5P124
I %=1 S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)=RA2,RARPT=RA2,RARPTN=$P(^RARPT(RARPT,0),"^"),RA1=RACN D
.N RACCSTR S RACCSTR=$P(RARPTN,"-",1,($L(RARPTN,"-"))-1)_"-"_RACN
.D:($D(^RARPT("B",RACCSTR,RARPT))=0) INSERT^RARTE2
.Q
;end fix RA5P124
D UNLOCK^RAUTL12(RAPNODE,RACNI) D INCRPT G START
NEW G:'RAPRTSET NEW1
L +^RADPT(RADFN,"DT",RADTI):DILOCKTM G:$T NEW1
W !!?10,$C(7),"** This case belongs to a printset, and someone else is",?68,"**",!?10,"** editing another case from this printset, or entering",?68,"**"
W !?10,"** a report for this printset, so you may not enter a",?68,"**",!?10,"** new report.",?68,"**"
H 2 D UNLOCK^RAUTL12(RAPNODE,RACNI) D INCRPT G START
;
NEW1 ;
I $L(RACNDSP,"-")>1 S RARPTN=RACNDSP
I $L(RACNDSP,"-")<2 S RARPTN=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN
W !?3,"...report not entered for this exam...",!?10,"...will now initialize report entry..."
S I=+$P(^RARPT(0),"^",3)
;
LOCK ;Try to lock next avail IEN, if locked - fail, if used - increment again
S I=I+1 S RAXIT=$$LOCK^RARTE6("^RARPT(",I) I RAXIT D UNLOCK2^RARTE4 D INCRPT G START
;don't check ^RARPT("B",RARPTN) due cloaked deleted reports
I $D(^RARPT(I)) D UNLOCK^RAUTL12("^RARPT(",I) G LOCK
S ^RARPT(I,0)=RARPTN,RARPT=I,^(0)=$P(^RARPT(0),"^",1,2)_"^"_I_"^"_($P(^(0),"^",4)+1),^DISV($S($D(DUZ)#2:DUZ,1:0),"^RARPT(")=I S:'$D(^RARPT(RARPT,"T")) ^("T")=""
S ^RARPT(RARPT,0)=RARPTN_"^"_RADFN_"^"_RADTE_"^"_RACN_"^EF",DIK="^RARPT(",DA=RARPT D IX1^DIK
K %,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI
S DIE="^RADPT("_RADFN_",""DT"","_RADTI_",""P"","
S DR="17////"_RARPT D ^DIE
K %,D,D0,DA,DI,DIC,DIE,DQ,DR,RAY1,X,Y
;if printset -- set pc 17 in subfile 70.03 and subrec in subfile 74.05
I RAPRTSET D PTR^RARTE2
I RAXIT D UNLOCK2^RARTE4,UNLOCK^RAUTL12("^RARPT(",RARPT) G Q1
W !,RAI
G IN0
IN ;edit existing rpt, so lock rpt fr the 1st time
S RAXIT=$$LOCK^RARTE6("^RARPT(",RARPT) I RAXIT D UNLOCK2^RARTE4 G Q1
IN0 ;skip to here if rpt created in this session and already locked
; Flag first time EF report is made if piece 18 has no data yet
I $P(^RARPT(RARPT,0),U,18)="" S RAFIRST=1
; save DXs before edit
S RANY1=$$ANYDX^RARTE7(.RAA1) ;1=has DXs, 0=no DXs, RAA1() stores DXs
; Ask if copy standard report
I $P(RAMDV,"^",12) D STD^RARTE1 I X="^" S RAXIT=1,RAX=X G UNCASE
; Ask Report Date
S DR="8",DA=RARPT,DIE="^RARPT(" D ^DIE K DE,DQ
; y is defined if user "^" out
I $D(Y) K Y G UNCASE
; Display Clinical History
D CHPRINT^RAUTL9
; report status before editing
S RACT=$P(^RARPT(RARPT,0),U,5)
; Edit Report Text and enter Diagnostic code(s)
D ERPT
; Resident and Staff not asked and not copied to other cases of printset
; continue to check sufficient data even if RAXIT=1 at this point
UNCASE ;
D UNLOCK^RAUTL12(RAPNODE,RACNI) ;unlock case
; copy diags to other cases of printset
; and unlock case "DT" level after copying is done
I RAPRTSET S RADRS=1 D COPY^RARTE2 L -^RADPT(RADFN,"DT",RADTI)
; first time EF rpt made -- del rpt & xrefs if no rpt txt & impression
I RAFIRST S RAXIT=$$CCAN(RARPT)
I RAX="^" S RAXIT=1
D UNLOCK^RAUTL12("^RARPT(",RARPT) ;unlock report
G:RAXIT PRT
;
; "EF" was stuffed in LOCK+5 for new rpts but not stub rpt yet
I $P(^RARPT(RARPT,0),U,5)'="EF" D SETFF^RARTE6(74,5,RARPT,"EF")
W !!?5,"Report status is stored as ""Electronically Filed""."
; Stuff in initial entry date only once
I RAFIRST D SETFF^RARTE6(74,18,RARPT,"NOW","E")
; Stuff in Activity Log subfile at all times
D SETALOG^RARTE6("+1,"_RARPT_",","F","")
;
; transmit to women's health each time this point is reached
; COPY^WVRALINK will stop if the same case number is already in 790.1
;
I $P(^RARPT(RARPT,0),U,5)="EF",$T(CREATE^WVRALINK)]"" D CREATE^WVRALINK(RADFN,RADTI,RACNI) ; women's health
;
PRT I RAXIT S RAXIT=0 D UNLOCK2^RARTE4 D INCRPT G START
;
; report status after editing
S RACT=$P(^RARPT(RARPT,0),U,5)
; ---
; set RAHLTCPB to prevent broadcast ORM messages
N RAHLTCPB S RAHLTCPB=1
;
; update case's exam status only if exam status isn't COMPLETE
; and isn't CANCEL
; and ((birads not required) or (birads required and entered))
S RA2=$$GET1^DIQ(72,+$P(RA7003,U,3)_",",3)
I RA2'=9,(RA2'=0) D
.I '$D(RABIREQ) D CKREQ^RABIRAD ;3-p200 - call to check birad requirement again
.I '$G(RABIREQ) D UP1^RAUTL1 Q ;3-p200 added $G for good measure
.I RABIDAT D UP1^RAUTL1 Q
.E W !!?5,"Exam status not recalculated due to missing BI-RADS code."
.Q
S RANY2=$$ANYDX^RARTE7(.RAA2) ;RAA2() store DXs after edit
; check if new/changed diagnostic codes, send alert if nec.
D ALERT^RARTE7
K RAAB
; broadcast if EF rpt made first time, or any DX changed/added/del'd
I $O(RAA2(0))!(RAFIRST) D
.D HLXMSG ;find VR subscribers to exclude
.D RPT^RAHLRPC
.Q
PRT1 R !!,"Do you wish to print this report? No// ",X:DTIME S:'$T!(X["^") X="N" S:X="" X="N" ;030497
I "Nn"[$E(X) D INCRPT G START
I "Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to print this report, or 'NO' not to." G PRT1
S ION=$P(RAMLC,"^",10),IOP=$S(ION]"":"Q;"_ION,1:"Q")
S RAMES="W !!?3,""Report has been queued for printing on device "",ION,""."""
D Q^RARTR D INCRPT G START ; queue rpt, cleanup, startover
;
Q1 K %,%DT,%W,%Y,%Y1,C,D0,D1,DA,DIC,DIE,DR,OREND,RABTCH,RABTCHN,RACN,RACNI,RACOPY,RACS,RACT,RADATE,RADFN,RADTE,RADTI,RADUZ,RAELESIG,RAFIN,RAHEAD,RAI,RAJ1
K RALI,RALR,RANME,RANUM,RAOR,RAORDIFN,RAPNODE,RAPRC,RAPRIT,RAQUIT,RAREPORT,RARES,RARPDT,RARPT,RARPTN,RARPTZ,RARTPN,RASET,RASI,RASIG,RASN,RASSN,RAST,RAST1,RASTI,RASTFF,RAVW,XQUIT,W,X,Y
K D,D2,DDER,DI,DIPGM,DLAYGO,J,RAEND,RAF5,RAFL,RAFST,RAIX,RAPOP,RAY1
K ^TMP($J,"RAEX")
K POP,DUOUT,RAFDA,RATEXT,RADIR0,RAXIT,RAX
D INCRPT
Q
INCRPT ; Kill extraneous variables to avoid collisions.
; Incomplete report information, select another case #.
K DA,DIE,DR,RATXT
K %,%DT,D,D0,D1,D2,DI,DIC,DIWT,DN,I,J,RAA1,RAA2
K RABIENS,RABIDAT,RABIREQ,RACN,RACNI,RACT
K RADATE,RADRS,RADTE,RADTI,RAFIN,RAFIRST,RAI,RALI,RALR,RANME,RAPRC,RARPT
K RARPTN,RASSN,RAST,RAVW,RASSS,RASSSX,X,Y
Q
CCAN(IEN74) ;Check canned report for Outside Reporting
; adapted from EN3^RAUTL15
; outputs: 0 if report is kept
; 1 if report is deleted due to no canned text entered
;
N RAPRG74,RATXT
; keep report if it is linked to images
I $O(^RARPT(IEN74,2005,0))>0 Q 0
;
;del canned report if missing both REPORT TEXT and IMPRESSION TEXT
I '$O(^RARPT(IEN74,"I",0)),'$O(^RARPT(IEN74,"R",0)) D Q 1
.; un-link rpt from other cases of printset
.D DEL17^RARTE2(IEN74)
.; exec field's xrefs' KILL logic
.S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI
.D ENKILL^RAXREF(70.03,17,IEN74,.DA)
.;
.;del piece 17 from case record
.S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)="" K DA,X
.;
.; Del report ptr from batch and distribution files
.D UPDTPNT^RAUTL9(IEN74)
.;
.; Del entry from Report file
.S DA=IEN74,DIK="^RARPT(" D ^DIK
.S RATXT(1)=" "
.S RATXT(2)=" Outside canned report not complete. Must Delete......deletion complete!"
.S RATXT(3)=$C(7) D MES^XPDUTL(.RATXT)
.; also delete any diagnostic codes from case record
.I RAPRTSET D DELDXPRT ;del DXs from printset cases
.I 'RAPRTSET D DELDX ;del DXs from standalone case
.Q
Q 0
ERPT ; Edit report text, impression, and enter/edit diagnostic codes
;remove lock case commands here since case is still locked
S $P(RATXT,"+",52)=""
W !!?5,RATXT,!?8,"Required: REPORT TEXT and/or IMPRESSION TEXT",!?5,RATXT
S RAXIT=0 ; here, =1 means user "^" out
S DA=RARPT,DIE="^RARPT("
S DR="200;I X=""^"" S Y=""@8"";300;I X'=""^"" S Y=""@9"";@8;S RAXIT=1;@9"
D ^DIE
; subseq edit -- Report Text and Impression Text cannot both be empty
I 'RAFIRST,'$O(^RARPT(RARPT,"I",0)),'$O(^RARPT(RARPT,"R",0)) G ERPT
; dont quit on "^" if mammography study
D CKREQ^RABIRAD ;check if BIRADS diag is required
I RAXIT=1,'RABIREQ Q
DIAG ; Diagnostic codes
; (code taken from routine RARTE1)
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
; ask Prim. Diag, required if site require diag, don't ck abnormal here
S DR=13_$S('$D(^RA(72,X,.1)):"",$P(^(.1),"^",5)'="Y":"",1:"R")
; allow user to "^" exit
D ^DIE K DA,DE,DQ,DIE,DR
I ($P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13)="")!($D(Y)) S RAXIT=0 G PACS
S DR="50///"_RACN
S DR(2,70.03)=13.1
S DR(3,70.14)=.01 ; don't ck abnormal here
S DA(1)=RADFN,DA=RADTI,DIE="^RADPT("_DA(1)_",""DT"","
D ^DIE K DA,DE,DQ,DIE,DR
I $D(Y) K Y S RAXIT=1 ;$D(Y) means user "^" out
PACS ; do not broadcast ORU message at this point
;
; if BIRADS required, ck if BIRADS entered, if not, go back to ask diag
I RABIREQ D CKDATA^RABIRAD I 'RABIDAT I $$ASK^RABIRAD G DIAG
; move WV outside of this in case rpt is deleted due insufficient data
Q
;
HLXMSG ; set up RASSSX() of VR subscribers to exclude from ORM msg broadcast
N RA,XX
; q if there are no HL applications that use the 4 RA HL7 protocols
Q:'$$GETAP^RAHLRS1(.XX)
S RA=$NA(XX)
F S RA=$Q(@RA) Q:RA="" I RA'["RA-TALK",(RA'["RA-PSCRIBE"),(RA'["RA-SCIMAGE"),(RA'["RA-RADWHERE") S RASSS(@RA)=""
; RASSS(ien #771)
; RASSSX(ien #101 driver, ien #101 subscriber)=".01 value of driver"
D:$D(RASSS)>1 GETSUB^RAHLRS1(.RASSS,.RASSSX)
Q
DELDX ; del any Prim. and Sec. DXs from standalone case
S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",13)="@" ;Prim DX
D FILE^DIE("","RAFDA")
K RAFDA
D KILSEC^RARTE7(70.14,RACNI)
Q
DELDXPRT ;del any Prim. and Sec. DXs from all cases in printset
S RA1=0
F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" D
.S RAFDA(70.03,RA1_","_RADTI_","_RADFN_",",13)="@" ;Prim DX
.D FILE^DIE("","RAFDA")
.K RAFDA
.D KILSEC^RARTE7(70.14,RA1)
.Q
Q
REGCR() ;RA184/KLM - Check credit method of exam's registered location
N RAIL S RAIL=$P(^RADPT(RADFN,"DT",RADTI,0),U,4)
I $P(^RA(79.1,RAIL,0),U,21)'=2 Q 1
Q 0
;
BROAD(RAY) ;A strict check if the procedure associated with this report
;is a 'BROAD' procedure.
;input: 'RAY' = IEN of the procedure (filel #71)
;returns: one if 'BROAD'; else zero
Q $S($P($G(^RAMIS(71,RAY,0)),U,6)="B":1,1:0)
;
INTRO ;
;;+--------------------------------------------------------+
;;| |
;;| This option is for entering canned text for |
;;| outside work: interpreted report done outside, |
;;| and images made outside this facility. |
;;| |
;;| For a printset, the canned text must apply to all |
;;| cases within the printset. |
;;| |
;;+--------------------------------------------------------+
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRARTE5 14494 printed Apr 09, 2024@21:39:19 Page 2
RARTE5 ;HISC/SWM AISC/MJK,RMO - Enter/Edit Outside Reports ; Mar 01, 2023@12:04:48
+1 ;;5.0;Radiology/Nuclear Medicine;**56,95,97,47,141,124,184,186,200**;Mar 16, 1998;Build 2
+2 ;
+3 ; 3-p200 3/01/2023 KLM RA*5*200 INC26245936 - Undefined RABIREQ variable
+4 ;
+5 ;Private IA #4793 CREATE^WVRALINK
+6 ;Controlled IA #3544 ^VA(200
+7 ;Supported IA #2056 GET1^DIQ
+8 ;Supported IA #10013 IX1^DIK
+9 ;Supported IA #10141 MES^XPDUTL
+10 ; adapted from RARTE, RARTE1, RARTE4
+11 FOR I=1:1:10
WRITE !?3,$PIECE($TEXT(INTRO+I),";;",2)
+12 WRITE !
DO SET^RAPSET1
IF $DATA(XQUIT)
KILL XQUIT
QUIT
+13 NEW RAXIT,RASUBY0,RA18EX,RAPRTSET,RAMEMARR,RA1,RA7003
+14 SET RAXIT=0
+15 ;clear HL7 exclusion vars
KILL RASSS,RASSSX
+16 IF $DATA(RANOSCRN)
SET X=$$DIVLOC^RAUTL7()
IF X
DO Q1
QUIT
+17 ;
+18 ; only require any Radiology Classification in New Person file
+19 SET X=0
FOR I="C","R","S","T"
if $DATA(^VA(200,"ARC",I,DUZ))
SET X=1
+20 IF 'X
WRITE !,"Your user account is missing a Radiology classification.",!
DO INCRPT
QUIT
+21 ;
START ;=1 for 1st time rpt given "EF" rpt status
SET RAFIRST=0
+1 KILL RAVER,RAX
SET (RAVW,RAX)=""
SET RAREPORT=1
DO ^RACNLU
if "^"[X
GOTO Q1
+2 ; RACNLU defines RADFN, RADTI, RACNI, RARPT
+3 ; save value of Y(0)
SET RASUBY0=Y(0)
+4 ;// begin RA*5.0*186 mods //
+5 ;Note: Y(0) = zero node of the case from the EXAMINATIONS (#70.03) multiple
+6 IF +$PIECE(Y(0),U,2)=0
Begin DoDot:1
+7 NEW ACCESSION
SET ACCESSION=$PIECE(Y(0),U,31)
+8 if ACCESSION=""
SET ACCESSION=$EXTRACT(RADTE,4,7)_$EXTRACT(RADTE,2,3)_"-"_+Y(0)
+9 WRITE !!,"Warning: This case: '"_ACCESSION_"' is missing a procedure.",!
+10 QUIT
End DoDot:1
GOTO START
+11 IF $$BROAD($PIECE(Y(0),U,2))=1
Begin DoDot:1
+12 WRITE !!,"Broad procedures are not allowed with Outside Reports.",!
+13 QUIT
End DoDot:1
GOTO START
+14 ;// end RA*5.0*186 mods //
+15 NEW RASSAN,RACNDSP
SET RASSAN=$PIECE(RASUBY0,U,31)
+16 SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:$PIECE(RASUBY0,U,1))
+17 if $PIECE(^RA(72,+RAST,0),"^",3)>0
GOTO CONTIN
+18 IF $DATA(^XUSEC("RA MGR",DUZ))
GOTO CONTIN
+19 if $PIECE(RAMDV,"^",22)=1
GOTO CONTIN
+20 WRITE $CHAR(7),!!,"The STATUS for this case is CANCELLED. You may not enter a report.",!!
DO INCRPT
GOTO START
+21 ;
CONTIN ; continue
+1 SET RAXIT=0
DO DISPLAY^RARTE6
+2 IF RA18EX=-1
DO INCRPT
GOTO START
+3 ;RA184/KLM - Add warning for anything other than NO CREDIT registered exam (NSR20210806)
+4 IF $$REGCR()
WRITE !!,$CHAR(7),"** WARNING, this case is not registered in an OUTSIDE imaging location. **",!
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Do you want to continue"
DO ^DIR
IF Y=0
DO INCRPT
GOTO START
+5 ; raprtset is defined in display^rarte6
+6 SET RAPNODE="^RADPT("_RADFN_",""DT"","_RADTI_",""P"","
+7 SET RA7003=@(RAPNODE_RACNI_",0)")
+8 SET RAXIT=$$LOCK^RARTE6(RAPNODE,RACNI)
IF RAXIT
DO INCRPT
GOTO START
+9 ;
+10 ; Real rpt must have fld 5="EF" & fld 18 w/ data. Stub rpt allowed
+11 IF $DATA(^RARPT(+RARPT,0))
IF (($PIECE(^(0),"^",5)'="EF")!($PIECE(^(0),"^",18)=""))
IF '$$STUB^RAEDCN1(+RARPT)
WRITE !?3,$CHAR(7),"Only Electronically Filed reports can be selected!",!
DO UNLOCK^RAUTL12(RAPNODE,RACNI)
DO INCRPT
GOTO START
+12 ;Create new rpt, or skip to IN to edit existing report
+13 if $DATA(^RARPT(+RARPT,0))
GOTO IN
+14 ;
+15 if 'RAPRTSET
GOTO NEW
if $PIECE(^RA(72,+RAST,0),"^",3)>0
GOTO NEW
+16 ; case is part of a print set, AND is cancelled
+17 NEW RA2
SET (RA1,RA2)=""
+18 FOR
SET RA1=$ORDER(RAMEMARR(RA1))
if RA1=""
QUIT
if $PIECE(RAMEMARR(RA1),"^",3)]""
SET RA2=$PIECE(RAMEMARR(RA1),"^",3)
+19 if RA2=""
GOTO NEW
+20 WRITE !!,$CHAR(7),"Other cases of this cancelled case ",RACN,"'s print set are entered in a report already",!!,"You may NOT create a new report for this cancelled case,",!,"but you may include this cancelled case in the existing report."
+21 WRITE !!,"Do you want to include this cancelled case in the same report",!,"as the others in the print set ?"
+22 SET %=2
DO YN^DICN
+23 if %>0
WRITE "...",$SELECT(%=1:"Include",1:"Skip")," this case"
P124 ;fix for RA5P124
+1 IF %=1
SET $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)=RA2
SET RARPT=RA2
SET RARPTN=$PIECE(^RARPT(RARPT,0),"^")
SET RA1=RACN
Begin DoDot:1
+2 NEW RACCSTR
SET RACCSTR=$PIECE(RARPTN,"-",1,($LENGTH(RARPTN,"-"))-1)_"-"_RACN
+3 if ($DATA(^RARPT("B",RACCSTR,RARPT))=0)
DO INSERT^RARTE2
+4 QUIT
End DoDot:1
+5 ;end fix RA5P124
+6 DO UNLOCK^RAUTL12(RAPNODE,RACNI)
DO INCRPT
GOTO START
NEW if 'RAPRTSET
GOTO NEW1
+1 LOCK +^RADPT(RADFN,"DT",RADTI):DILOCKTM
if $TEST
GOTO NEW1
+2 WRITE !!?10,$CHAR(7),"** This case belongs to a printset, and someone else is",?68,"**",!?10,"** editing another case from this printset, or entering",?68,"**"
+3 WRITE !?10,"** a report for this printset, so you may not enter a",?68,"**",!?10,"** new report.",?68,"**"
+4 HANG 2
DO UNLOCK^RAUTL12(RAPNODE,RACNI)
DO INCRPT
GOTO START
+5 ;
NEW1 ;
+1 IF $LENGTH(RACNDSP,"-")>1
SET RARPTN=RACNDSP
+2 IF $LENGTH(RACNDSP,"-")<2
SET RARPTN=$EXTRACT(RADTE,4,7)_$EXTRACT(RADTE,2,3)_"-"_RACN
+3 WRITE !?3,"...report not entered for this exam...",!?10,"...will now initialize report entry..."
+4 SET I=+$PIECE(^RARPT(0),"^",3)
+5 ;
LOCK ;Try to lock next avail IEN, if locked - fail, if used - increment again
+1 SET I=I+1
SET RAXIT=$$LOCK^RARTE6("^RARPT(",I)
IF RAXIT
DO UNLOCK2^RARTE4
DO INCRPT
GOTO START
+2 ;don't check ^RARPT("B",RARPTN) due cloaked deleted reports
+3 IF $DATA(^RARPT(I))
DO UNLOCK^RAUTL12("^RARPT(",I)
GOTO LOCK
+4 SET ^RARPT(I,0)=RARPTN
SET RARPT=I
SET ^(0)=$PIECE(^RARPT(0),"^",1,2)_"^"_I_"^"_($PIECE(^(0),"^",4)+1)
SET ^DISV($SELECT($DATA(DUZ)#2:DUZ,1:0),"^RARPT(")=I
if '$DATA(^RARPT(RARPT,"T"))
SET ^("T")=""
+5 SET ^RARPT(RARPT,0)=RARPTN_"^"_RADFN_"^"_RADTE_"^"_RACN_"^EF"
SET DIK="^RARPT("
SET DA=RARPT
DO IX1^DIK
+6 KILL %,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
+7 SET DA(2)=RADFN
SET DA(1)=RADTI
SET DA=RACNI
+8 SET DIE="^RADPT("_RADFN_",""DT"","_RADTI_",""P"","
+9 SET DR="17////"_RARPT
DO ^DIE
+10 KILL %,D,D0,DA,DI,DIC,DIE,DQ,DR,RAY1,X,Y
+11 ;if printset -- set pc 17 in subfile 70.03 and subrec in subfile 74.05
+12 IF RAPRTSET
DO PTR^RARTE2
+13 IF RAXIT
DO UNLOCK2^RARTE4
DO UNLOCK^RAUTL12("^RARPT(",RARPT)
GOTO Q1
+14 WRITE !,RAI
+15 GOTO IN0
IN ;edit existing rpt, so lock rpt fr the 1st time
+1 SET RAXIT=$$LOCK^RARTE6("^RARPT(",RARPT)
IF RAXIT
DO UNLOCK2^RARTE4
GOTO Q1
IN0 ;skip to here if rpt created in this session and already locked
+1 ; Flag first time EF report is made if piece 18 has no data yet
+2 IF $PIECE(^RARPT(RARPT,0),U,18)=""
SET RAFIRST=1
+3 ; save DXs before edit
+4 ;1=has DXs, 0=no DXs, RAA1() stores DXs
SET RANY1=$$ANYDX^RARTE7(.RAA1)
+5 ; Ask if copy standard report
+6 IF $PIECE(RAMDV,"^",12)
DO STD^RARTE1
IF X="^"
SET RAXIT=1
SET RAX=X
GOTO UNCASE
+7 ; Ask Report Date
+8 SET DR="8"
SET DA=RARPT
SET DIE="^RARPT("
DO ^DIE
KILL DE,DQ
+9 ; y is defined if user "^" out
+10 IF $DATA(Y)
KILL Y
GOTO UNCASE
+11 ; Display Clinical History
+12 DO CHPRINT^RAUTL9
+13 ; report status before editing
+14 SET RACT=$PIECE(^RARPT(RARPT,0),U,5)
+15 ; Edit Report Text and enter Diagnostic code(s)
+16 DO ERPT
+17 ; Resident and Staff not asked and not copied to other cases of printset
+18 ; continue to check sufficient data even if RAXIT=1 at this point
UNCASE ;
+1 ;unlock case
DO UNLOCK^RAUTL12(RAPNODE,RACNI)
+2 ; copy diags to other cases of printset
+3 ; and unlock case "DT" level after copying is done
+4 IF RAPRTSET
SET RADRS=1
DO COPY^RARTE2
LOCK -^RADPT(RADFN,"DT",RADTI)
+5 ; first time EF rpt made -- del rpt & xrefs if no rpt txt & impression
+6 IF RAFIRST
SET RAXIT=$$CCAN(RARPT)
+7 IF RAX="^"
SET RAXIT=1
+8 ;unlock report
DO UNLOCK^RAUTL12("^RARPT(",RARPT)
+9 if RAXIT
GOTO PRT
+10 ;
+11 ; "EF" was stuffed in LOCK+5 for new rpts but not stub rpt yet
+12 IF $PIECE(^RARPT(RARPT,0),U,5)'="EF"
DO SETFF^RARTE6(74,5,RARPT,"EF")
+13 WRITE !!?5,"Report status is stored as ""Electronically Filed""."
+14 ; Stuff in initial entry date only once
+15 IF RAFIRST
DO SETFF^RARTE6(74,18,RARPT,"NOW","E")
+16 ; Stuff in Activity Log subfile at all times
+17 DO SETALOG^RARTE6("+1,"_RARPT_",","F","")
+18 ;
+19 ; transmit to women's health each time this point is reached
+20 ; COPY^WVRALINK will stop if the same case number is already in 790.1
+21 ;
+22 ; women's health
IF $PIECE(^RARPT(RARPT,0),U,5)="EF"
IF $TEXT(CREATE^WVRALINK)]""
DO CREATE^WVRALINK(RADFN,RADTI,RACNI)
+23 ;
PRT IF RAXIT
SET RAXIT=0
DO UNLOCK2^RARTE4
DO INCRPT
GOTO START
+1 ;
+2 ; report status after editing
+3 SET RACT=$PIECE(^RARPT(RARPT,0),U,5)
+4 ; ---
+5 ; set RAHLTCPB to prevent broadcast ORM messages
+6 NEW RAHLTCPB
SET RAHLTCPB=1
+7 ;
+8 ; update case's exam status only if exam status isn't COMPLETE
+9 ; and isn't CANCEL
+10 ; and ((birads not required) or (birads required and entered))
+11 SET RA2=$$GET1^DIQ(72,+$PIECE(RA7003,U,3)_",",3)
+12 IF RA2'=9
IF (RA2'=0)
Begin DoDot:1
+13 ;3-p200 - call to check birad requirement again
IF '$DATA(RABIREQ)
DO CKREQ^RABIRAD
+14 ;3-p200 added $G for good measure
IF '$GET(RABIREQ)
DO UP1^RAUTL1
QUIT
+15 IF RABIDAT
DO UP1^RAUTL1
QUIT
+16 IF '$TEST
WRITE !!?5,"Exam status not recalculated due to missing BI-RADS code."
+17 QUIT
End DoDot:1
+18 ;RAA2() store DXs after edit
SET RANY2=$$ANYDX^RARTE7(.RAA2)
+19 ; check if new/changed diagnostic codes, send alert if nec.
+20 DO ALERT^RARTE7
+21 KILL RAAB
+22 ; broadcast if EF rpt made first time, or any DX changed/added/del'd
+23 IF $ORDER(RAA2(0))!(RAFIRST)
Begin DoDot:1
+24 ;find VR subscribers to exclude
DO HLXMSG
+25 DO RPT^RAHLRPC
+26 QUIT
End DoDot:1
PRT1 ;030497
READ !!,"Do you wish to print this report? No// ",X:DTIME
if '$TEST!(X["^")
SET X="N"
if X=""
SET X="N"
+1 IF "Nn"[$EXTRACT(X)
DO INCRPT
GOTO START
+2 IF "Yy"'[$EXTRACT(X)
if X'["?"
WRITE $CHAR(7)
WRITE !!?3,"Enter 'YES' to print this report, or 'NO' not to."
GOTO PRT1
+3 SET ION=$PIECE(RAMLC,"^",10)
SET IOP=$SELECT(ION]"":"Q;"_ION,1:"Q")
+4 SET RAMES="W !!?3,""Report has been queued for printing on device "",ION,""."""
+5 ; queue rpt, cleanup, startover
DO Q^RARTR
DO INCRPT
GOTO START
+6 ;
Q1 KILL %,%DT,%W,%Y,%Y1,C,D0,D1,DA,DIC,DIE,DR,OREND,RABTCH,RABTCHN,RACN,RACNI,RACOPY,RACS,RACT,RADATE,RADFN,RADTE,RADTI,RADUZ,RAELESIG,RAFIN,RAHEAD,RAI,RAJ1
+1 KILL RALI,RALR,RANME,RANUM,RAOR,RAORDIFN,RAPNODE,RAPRC,RAPRIT,RAQUIT,RAREPORT,RARES,RARPDT,RARPT,RARPTN,RARPTZ,RARTPN,RASET,RASI,RASIG,RASN,RASSN,RAST,RAST1,RASTI,RASTFF,RAVW,XQUIT,W,X,Y
+2 KILL D,D2,DDER,DI,DIPGM,DLAYGO,J,RAEND,RAF5,RAFL,RAFST,RAIX,RAPOP,RAY1
+3 KILL ^TMP($JOB,"RAEX")
+4 KILL POP,DUOUT,RAFDA,RATEXT,RADIR0,RAXIT,RAX
+5 DO INCRPT
+6 QUIT
INCRPT ; Kill extraneous variables to avoid collisions.
+1 ; Incomplete report information, select another case #.
+2 KILL DA,DIE,DR,RATXT
+3 KILL %,%DT,D,D0,D1,D2,DI,DIC,DIWT,DN,I,J,RAA1,RAA2
+4 KILL RABIENS,RABIDAT,RABIREQ,RACN,RACNI,RACT
+5 KILL RADATE,RADRS,RADTE,RADTI,RAFIN,RAFIRST,RAI,RALI,RALR,RANME,RAPRC,RARPT
+6 KILL RARPTN,RASSN,RAST,RAVW,RASSS,RASSSX,X,Y
+7 QUIT
CCAN(IEN74) ;Check canned report for Outside Reporting
+1 ; adapted from EN3^RAUTL15
+2 ; outputs: 0 if report is kept
+3 ; 1 if report is deleted due to no canned text entered
+4 ;
+5 NEW RAPRG74,RATXT
+6 ; keep report if it is linked to images
+7 IF $ORDER(^RARPT(IEN74,2005,0))>0
QUIT 0
+8 ;
+9 ;del canned report if missing both REPORT TEXT and IMPRESSION TEXT
+10 IF '$ORDER(^RARPT(IEN74,"I",0))
IF '$ORDER(^RARPT(IEN74,"R",0))
Begin DoDot:1
+11 ; un-link rpt from other cases of printset
+12 DO DEL17^RARTE2(IEN74)
+13 ; exec field's xrefs' KILL logic
+14 SET DA(2)=RADFN
SET DA(1)=RADTI
SET DA=RACNI
+15 DO ENKILL^RAXREF(70.03,17,IEN74,.DA)
+16 ;
+17 ;del piece 17 from case record
+18 SET $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)=""
KILL DA,X
+19 ;
+20 ; Del report ptr from batch and distribution files
+21 DO UPDTPNT^RAUTL9(IEN74)
+22 ;
+23 ; Del entry from Report file
+24 SET DA=IEN74
SET DIK="^RARPT("
DO ^DIK
+25 SET RATXT(1)=" "
+26 SET RATXT(2)=" Outside canned report not complete. Must Delete......deletion complete!"
+27 SET RATXT(3)=$CHAR(7)
DO MES^XPDUTL(.RATXT)
+28 ; also delete any diagnostic codes from case record
+29 ;del DXs from printset cases
IF RAPRTSET
DO DELDXPRT
+30 ;del DXs from standalone case
IF 'RAPRTSET
DO DELDX
+31 QUIT
End DoDot:1
QUIT 1
+32 QUIT 0
ERPT ; Edit report text, impression, and enter/edit diagnostic codes
+1 ;remove lock case commands here since case is still locked
+2 SET $PIECE(RATXT,"+",52)=""
+3 WRITE !!?5,RATXT,!?8,"Required: REPORT TEXT and/or IMPRESSION TEXT",!?5,RATXT
+4 ; here, =1 means user "^" out
SET RAXIT=0
+5 SET DA=RARPT
SET DIE="^RARPT("
+6 SET DR="200;I X=""^"" S Y=""@8"";300;I X'=""^"" S Y=""@9"";@8;S RAXIT=1;@9"
+7 DO ^DIE
+8 ; subseq edit -- Report Text and Impression Text cannot both be empty
+9 IF 'RAFIRST
IF '$ORDER(^RARPT(RARPT,"I",0))
IF '$ORDER(^RARPT(RARPT,"R",0))
GOTO ERPT
+10 ; dont quit on "^" if mammography study
+11 ;check if BIRADS diag is required
DO CKREQ^RABIRAD
+12 IF RAXIT=1
IF 'RABIREQ
QUIT
DIAG ; Diagnostic codes
+1 ; (code taken from routine RARTE1)
+2 SET RAIMGTYI=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,0)),U,2)
SET RAIMGTYJ=$PIECE($GET(^RA(79.2,+RAIMGTYI,0)),U)
+3 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
+4 ; ask Prim. Diag, required if site require diag, don't ck abnormal here
+5 SET DR=13_$SELECT('$DATA(^RA(72,X,.1)):"",$PIECE(^(.1),"^",5)'="Y":"",1:"R")
+6 ; allow user to "^" exit
+7 DO ^DIE
KILL DA,DE,DQ,DIE,DR
+8 IF ($PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13)="")!($DATA(Y))
SET RAXIT=0
GOTO PACS
+9 SET DR="50///"_RACN
+10 SET DR(2,70.03)=13.1
+11 ; don't ck abnormal here
SET DR(3,70.14)=.01
+12 SET DA(1)=RADFN
SET DA=RADTI
SET DIE="^RADPT("_DA(1)_",""DT"","
+13 DO ^DIE
KILL DA,DE,DQ,DIE,DR
+14 ;$D(Y) means user "^" out
IF $DATA(Y)
KILL Y
SET RAXIT=1
PACS ; do not broadcast ORU message at this point
+1 ;
+2 ; if BIRADS required, ck if BIRADS entered, if not, go back to ask diag
+3 IF RABIREQ
DO CKDATA^RABIRAD
IF 'RABIDAT
IF $$ASK^RABIRAD
GOTO DIAG
+4 ; move WV outside of this in case rpt is deleted due insufficient data
+5 QUIT
+6 ;
HLXMSG ; set up RASSSX() of VR subscribers to exclude from ORM msg broadcast
+1 NEW RA,XX
+2 ; q if there are no HL applications that use the 4 RA HL7 protocols
+3 if '$$GETAP^RAHLRS1(.XX)
QUIT
+4 SET RA=$NAME(XX)
+5 FOR
SET RA=$QUERY(@RA)
if RA=""
QUIT
IF RA'["RA-TALK"
IF (RA'["RA-PSCRIBE")
IF (RA'["RA-SCIMAGE")
IF (RA'["RA-RADWHERE")
SET RASSS(@RA)=""
+6 ; RASSS(ien #771)
+7 ; RASSSX(ien #101 driver, ien #101 subscriber)=".01 value of driver"
+8 if $DATA(RASSS)>1
DO GETSUB^RAHLRS1(.RASSS,.RASSSX)
+9 QUIT
DELDX ; del any Prim. and Sec. DXs from standalone case
+1 ;Prim DX
SET RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",13)="@"
+2 DO FILE^DIE("","RAFDA")
+3 KILL RAFDA
+4 DO KILSEC^RARTE7(70.14,RACNI)
+5 QUIT
DELDXPRT ;del any Prim. and Sec. DXs from all cases in printset
+1 SET RA1=0
+2 FOR
SET RA1=$ORDER(RAMEMARR(RA1))
if RA1=""
QUIT
Begin DoDot:1
+3 ;Prim DX
SET RAFDA(70.03,RA1_","_RADTI_","_RADFN_",",13)="@"
+4 DO FILE^DIE("","RAFDA")
+5 KILL RAFDA
+6 DO KILSEC^RARTE7(70.14,RA1)
+7 QUIT
End DoDot:1
+8 QUIT
REGCR() ;RA184/KLM - Check credit method of exam's registered location
+1 NEW RAIL
SET RAIL=$PIECE(^RADPT(RADFN,"DT",RADTI,0),U,4)
+2 IF $PIECE(^RA(79.1,RAIL,0),U,21)'=2
QUIT 1
+3 QUIT 0
+4 ;
BROAD(RAY) ;A strict check if the procedure associated with this report
+1 ;is a 'BROAD' procedure.
+2 ;input: 'RAY' = IEN of the procedure (filel #71)
+3 ;returns: one if 'BROAD'; else zero
+4 QUIT $SELECT($PIECE($GET(^RAMIS(71,RAY,0)),U,6)="B":1,1:0)
+5 ;
INTRO ;
+1 ;;+--------------------------------------------------------+
+2 ;;| |
+3 ;;| This option is for entering canned text for |
+4 ;;| outside work: interpreted report done outside, |
+5 ;;| and images made outside this facility. |
+6 ;;| |
+7 ;;| For a printset, the canned text must apply to all |
+8 ;;| cases within the printset. |
+9 ;;| |
+10 ;;+--------------------------------------------------------+
