- 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 Feb 19, 2025@00:05:38 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 ;;+--------------------------------------------------------+