Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RARTE5

RARTE5.m

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