RARPTUT ;HISC/GJC - rad/nuc med report utilities ;04 Dec 2017 9:26 AM
;;5.0;Radiology/Nuclear Medicine;**106,114,144**;Mar 16, 1998;Build 1
;
;Integration Agreements
;----------------------
;$$FIND^DIC - 2051 (supported)
;FILE^DIE - 2053 (supported)
;UPDATE^DIE - 2053 (supported)
;WP^DIE - 2053 (supported)
;$$IENS^DILF - 2054 (supported)
;CLEAN^DILF - 2054 (supported)
;$$GET1^DIQ - 2056 (supported)
;
;Events that cause reports to be deleted or to revert back to a
;stub form need to make the appropriate case available to be read.
;
REL(RARPT,RAERR) ;NTP II - mark a report as 'X' (Deleted) or null
;(mimics 'images collected'). Called when an inbound report has a RESULT
;STATUS (OBR-25) value of 'VAQ'.
;
;Input : RARPT = the IEN of the rad/nuc med report record
;Output: RAERR = 0 if successful
; <0 error code^Message text^Error location^Type
;
; A positive value of RAERR will not trigger a negative acknowledgment
; to be broadcast.
;
S U="^",RAERR=0
N C,RAPARAMS,RATIMOUT,X,Y S RATIMOUT=300
;------------------------------------------------------------------------
;lock the report record in question. if unsuccessful quit w/error
S RAERR=$$LOCKFM^RALOCK(74,RARPT_",",,RATIMOUT) ;(+1)
S RAERR=$$LOCKERR^RAERR(RAERR,"Rad/Nuc Med Reports file")
;RAERR = -15^The Rad/Nuc Med Reports file is locked by other user/task. Please try later.
; ^LOCKERR+1~RAERR^W
I RAERR D QUIT
.N RATXT S RATXT(1)=$P(RAERR,U,2),RATXT(2)="IEN: "_$G(RARPT,-1)
.S RATXT(3)="Calling Routine: "_$P(RAERR,U,3)
.D MM(74,.RATXT)
.Q
;------------------------------------------------------------------------
;
;------------------------------------------------------------------------
CHKSTS ;In order to 'mark as deleted', NTP reports those reports must have a
;REPORT STATUS of 'R' (RELEASED/NOT VERIFIED). If the report status is
;not set to 'R' log the error, unlock the report & quit.
;RAERR="-19^Invalid value of field #5 in file #74, IENS='2317'.^^E"
S RARPT(0)=$G(^RARPT(RARPT,0))
I $P(RARPT(0),U,5)'="R" D Q
.S RAERR=$$ERROR^RAERR(-19,,74,RARPT,5)
.D UNLOCKFM^RALOCK(74,RARPT_",") ;(-1)
.N RATXT S RATXT(1)=$P($G(RAERR),U,2)
.S RATXT(2)=$P($G(RAERR),U,3) D MM(74,.RATXT)
.Q
;------------------------------------------------------------------------
;
;------------------------------------------------------------------------
IMG ;Can't 'mark as deleted' a report being held if images have been
;attached to that report record. Held reports w/images get moved to
;a null report status.
; RAIMAGES=1 if images are attached
; else RAIMAGES=0
N RAIMAGES S RAIMAGES=$S($O(^RARPT(RARPT,2005,0))>0:1,1:0)
;------------------------------------------------------------------------
;
;------------------------------------------------------------------------
REGEX ;lock at the REGISTERED EXAM (#70.02) record associated with this report
;piece 2: Patient DFN, piece 3: EXAM DATE/TIME, piece 4: CASE NUMBER
;>>> Note: RAIEN70 is the IEN string at the 70.02 level. <<<
N RACN,RACNI,RADFN,RADTI,RAIEN70,RAX
S (DA(1),RADFN)=$P(RARPT(0),U,2),(DA,RADTI)=9999999.9999-$P(RARPT(0),U,3)
S RACN=+$P(RARPT(0),U,4),RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0))
S RAIEN70=$$IENS^DILF(.DA) K DA
S RAERR=$$LOCKFM^RALOCK(70.02,RAIEN70,,RATIMOUT) ;(+2)
S RAERR=$$LOCKERR^RAERR(RAERR,"Registered Exams Sub-File #70.02")
;I the case at the REGISTERED EXAMS level is locked
I RAERR D QUIT
.D UNLOCKFM^RALOCK(74,RARPT_",") ;(-1)
.N RATXT S RATXT(1)=$P($G(RAERR),U,2),RATXT(2)="IEN(s): "_$G(RAIEN70,-1)
.S RATXT(3)="Calling Routine: "_$P($G(RAERR),U,3)
.D MM(74,.RATXT)
.Q
;------------------------------------------------------------------------
;
;------------------------------------------------------------------------
RPTXT ;delete the REPORT TEXT (70.03; #17) field value for a exam liked to
;a report that does not have attached images.
;>>> Note: RAIENS70 is the IEN string at the 70.03 level. <<<
I RAIMAGES=0 D
.;make sure you consider printsets
.S RADA=0 N RAIENS70
.F S RADA=$O(^RADPT(RADFN,"DT",RADTI,"P",RADA)) Q:'RADA D
..S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RADA,0)) Q:$P(RA7003,U,17)'=RARPT
..S DA=RADA,DA(1)=RADTI,DA(2)=RADFN
..S RAIENS70=$$IENS^DILF(.DA) K DA
..S RAFDA(70.03,RAIENS70,17)="@"
..Q
.I ($D(RAFDA(70.03))\10) D
..D FILE^DIE("","RAFDA") K RA7003,RADA,RAFDA
..I $D(DIERR)#2 D
...;RAERR="-9^FileMan DBS call error(s); File #70.03;
...;IENS: "1,6917999.9999,76,"^DBS+14~RAERR^E"
...S RAERR=$$DBS^RAERR("",-9,70.03,RAIENS70)
...D UNLOCKFM^RALOCK(70.02,RAIEN70) ;(-2)
...D UNLOCKFM^RALOCK(74,RARPT_",") ;(-1)
...N RATXT S RATXT(1)=$P($G(RAERR),U,2)
...S RATXT(2)="Calling Routine: "_$P($G(RAERR),U,3)
...S RATXT(3)="Calling subroutine: RPTXT"
...D MM(70.02,.RATXT)
...Q
..D CLEAN^DILF
..Q
.Q
Q:RAERR
;
PIS ;delete the PRIMARY INTERPRETING STAFF (70.03; #15) field value
;for a exam liked to a report regardless of whether that report has
;attached images.
;>>> Note: RAIENS70 is the IEN string at the 70.03 level. <<<
D
.;make sure you consider printsets
.S RADA=0 N RAIENS70
.F S RADA=$O(^RADPT(RADFN,"DT",RADTI,"P",RADA)) Q:'RADA D
..S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RADA,0))
..S DA=RADA,DA(1)=RADTI,DA(2)=RADFN
..S RAIENS70=$$IENS^DILF(.DA) K DA
..S RAFDA(70.03,RAIENS70,15)="@"
..Q
.I ($D(RAFDA(70.03))\10) D
..D FILE^DIE("","RAFDA") K RA7003,RADA,RAFDA
..I $D(DIERR)#2 D
...;RAERR="-9^FileMan DBS call error(s); File #70.03;
...;IENS: "1,6917999.9999,76,"^DBS+14~RAERR^E"
...S RAERR=$$DBS^RAERR("",-9,70.03,RAIENS70)
...D UNLOCKFM^RALOCK(70.02,RAIEN70) ;(-2)
...D UNLOCKFM^RALOCK(74,RARPT_",") ;(-1)
...N RATXT S RATXT(1)=$P($G(RAERR),U,2)
...S RATXT(2)="Calling Routine: "_$P($G(RAERR),U,3)
...S RATXT(3)="Calling subroutine: PIS"
...D MM(70.02,.RATXT)
...Q
..D CLEAN^DILF
..Q
.Q
Q:RAERR
;------------------------------------------------------------------------
;
;------------------------------------------------------------------------
BATCH ;if the report does not have associated images check the REPORT BATCHES
;(#74.2) file for references to the report in question. If there are
;references to this report those references (pointers) must be deleted.
;If there is an error within the RA742 function do not quit. The code
;within RA742 will trigger the correct emails. Continue on and update
;the REPORT STATUS field.
I RAIMAGES=0 D RA742(RARPT)
;------------------------------------------------------------------------
;
;------------------------------------------------------------------------
RSTATUS ;1) set the REPORT STATUS for reports absent of images to 'X'
; (Deleted)
; 2) set the REPORT STATUS for reports w/images present to null
; (mimics 'images collected')
K RAFDA S RAFDA(74,RARPT_",",5)=$S(RAIMAGES=1:"@",1:"X")
D FILE^DIE("","RAFDA") K RAFDA
I $D(DIERR)#2 D
.;RAERR="-9^FileMan DBS call error(s); File #74;
.;IENS: "2370,"^DBS+14~RAERR^E"
.S RAERR=$$DBS^RAERR("",-9,74,RARPT_",")
.D UNLOCKFM^RALOCK(70.02,RAIEN70) ;(-2)
.D UNLOCKFM^RALOCK(74,RARPT_",") ;(-1)
.N RATXT S RATXT(1)=$P($G(RAERR),U,2)
.S RATXT(2)="Calling Routine: "_$P($G(RAERR),U,3)
.D MM(74,.RATXT)
.Q
Q:RAERR
;
IMPRPTXT ;Delete the IMPRESSION TEXT (#300) and REPORT TEXT (#200)
;for a report record, w/images, being released back to the local
;facility for interpretation.
I RAIMAGES=1 D WP^DIE(74,RARPT_",",300,,"@"),WP^DIE(74,RARPT_",",200,,"@")
;------------------------------------------------------------------------
;
ACTIVLOG ;update the activity log. If an error occurs here inform the mail group
;and fall through to the code that unlocks the exam and report records.
;
;>>> Note: RAIEN is the record number for the newly created activity log sub-file
;record. <<<
;
S RAIEN=$$ACTLOG()
;
;if no error, and there are not images associated with this report build
;the RAFDA array for Dx Codes, sec. staff & sec. resident & file the data
;in the proper lower level sub-files.
I RAIEN>0,(RAIMAGES=0) S RAERR=$$ACTLOGX(RAIEN)
;
;------------------------------------------------------------------------
;unlock the records
D UNLOCKFM^RALOCK(70.02,RAIEN70) ;(-2)
D UNLOCKFM^RALOCK(74,RARPT_",") ;(-1)
;------------------------------------------------------------------------
;
;------------------------------------------------------------------------
MAIL ;Whether the event was a success of failure update the users in the RAD
;HL7 MESSAGES mail group about the change in REPORT STATUS.
S RARPTSTS=$$GET1^DIQ(74,RARPT_",",5)
S:RAERR RAX="NTP failed to release a study back to the local facility."
S:'RAERR RAX="NTP succeeded in releasing a study back to the local facility."
S RATXT(1)=RAX,RATXT(2)=""
S RATXT(3)="NTP released Rad/Nuc Med Report: "_$P(RARPT(0),U)_"."
S RATXT(4)="The REPORT STATUS of this report is: "_$S(RARPTSTS'="":RARPTSTS,1:"N/A")
D MM(74,.RATXT) K RARPTSTS,RATXT,RAX
;------------------------------------------------------------------------
;
D CLEAN^DILF K RAIEN QUIT ;end of main body...
;
;>>> subroutines follow <<<
;
RA742(RARPT) ;delete a report (without images) from the REPORT BATCHES (#74.2)
;REPORTS sub-file
;Input: RARPT = IEN of the RAD/NUC MED REPORT record
;;>>> Note: RAIEN742 is the IEN string at the 74.2 level. <<<
I ($D(^RABTCH(74.2,"D",RARPT))\10) D
.K DA,RA,RAFDA,RAIEN742,RAX N RAY1,RAY2 S RAY1=0,RA=74.2
.F S RAY1=$O(^RABTCH(74.2,"D",RARPT,RAY1)) Q:RAY1'>0 D
..S RAY2=0 F S RAY2=$O(^RABTCH(74.2,"D",RARPT,RAY1,RAY2)) Q:RAY2'>0 D
...S DA=RAY2,DA(1)=RAY1 S RAIEN742=$$IENS^DILF(.DA) K DA
...S RAERR=$$LOCKFM^RALOCK(74.21,RAIEN742,,RATIMOUT) ;(+3)
...S RAERR=$$LOCKERR^RAERR(RAERR,"Report Batches File #74.2")
...;
...;RAERR = -15^The Rad/Nuc Med Reports file is locked by other user/task. Please try later.
...; ^LOCKERR+1~RAERR^W
...I RAERR D QUIT
....N RATXT S RATXT(1)=$P($G(RAERR),U,2),RATXT(2)="IEN: "_$G(RARPT,-1)
....S RATXT(3)="Calling Routine: "_$P($G(RAERR),U,3)
....D MM(RA,.RATXT)
....Q
...;
...S RAFDA(74.21,RAIEN742,.01)="@"
...D FILE^DIE("","RAFDA") K RAFDA
...;
...I $D(DIERR)#2 D
....;RAERR="-9^FileMan DBS call error(s); File #74.21;
....;IENS: "1,113,"^DBS+14~RAERR^E"
....S RAERR=$$DBS^RAERR("",-9,74.21,RAIEN742)
....N RATXT S RATXT(1)=$P($G(RAERR),U,2)
....S RATXT(2)="Calling Routine: "_$P($G(RAERR),U,3)
....D MM(RA,.RATXT)
....Q
...D UNLOCKFM^RALOCK(74.21,RAIEN742) ;(-3)
...D CLEAN^DILF K RA,RAIEN742,RAX
...Q
..Q
.Q
Q
;
ACTLOG() ;update the Activity Log (#74.01) whenever a report is
;has a REPORT STATUS value of DELETED. Remember that printsets
;share primary/secondary staff, resident & Dx Codes across all
;studies.
;
;Given: RADFN, RADTI, RACNI, RARPT & RAIMAGE (indicates if DELETED)
;Note: the report record remains locked.
;>>> Note: RAIENS74 is the IEN string at the 74.01 level. <<<
;>>> RAIEN "finds" the next available IEN in the Activity Log sub-file <<<
N RAERR,RAFDA,RAIEN,RAIENS74,RAUSER,RAY3
S RAIEN=$O(^RARPT(RARPT,"L",$C(32)),-1),RAIEN=RAIEN+1
S RAUSER=$$FIND1^DIC(200,,"X","RADIOLOGY,OUTSIDE SERVICE")
S RAY3=$$GETEXM(),RAIENS74="+"_RAIEN_","_RARPT_","
S RAFDA(74.01,RAIENS74,.01)=$$NOW^XLFDT() ;to the second
S RAFDA(74.01,RAIENS74,2)="Q" ;QUIT released back to local VAMC
S RAFDA(74.01,RAIENS74,3)=$S(RAUSER>0:RAUSER,1:.5) ;a tipoff on a NTP action
S RAFDA(74.01,RAIENS74,4)="R" ;must be "R" (Released/not Verified)
;
;if there are no images linked to this report file primary & secondary
;Dx Code, resident, & staff into the Activity Log
I RAIMAGES=0 D
.S:$P(RAY3,U,2) RAFDA(74.01,RAIENS74,5)=$P(RAY3,U,2) ;dx
.S:$P(RAY3,U,3) RAFDA(74.01,RAIENS74,7)=$P(RAY3,U,3) ;stf
.S:$P(RAY3,U) RAFDA(74.01,RAIENS74,9)=$P(RAY3,U) ;res
.Q
;
D UPDATE^DIE("","RAFDA","RAIEN")
;if successful RAIEN(RAIEN) is the new record # for 74.01 sub-file
I $D(DIERR)#2 D
.S RAERR=$$DBS^RAERR("",-9,74.01,RAIENS74)
.N RATXT S RATXT(1)=$P($G(RAERR),U,2)
.S RATXT(2)="Calling Routine: "_$P($G(RAERR),U,3)
.D MM(RA,.RATXT)
.Q
Q $S(($D(RAERR)#2)<0:RAERR,1:RAIEN(RAIEN))
;
ACTLOGX(RAIEN) ;update the lower level sub-files...
;given: RARPT
;Input: RAIEN is the new record number created @ the 74.01 level
;>>> Note: RAIENS74 is the IEN string at the 74.01 level. <<<
N RA,RAERR,RAFDA,RAIENS74
S RAIENS74=","_RAIEN_","_RARPT_",",RA=74.01
;build the RAFDA array for Dx Codes, sec. staff & sec. resident
D SECDX,SECSTF,SECRES
;if there's data to be filed, file it. Note: the input transforms
;are "clean" so I stuff the internal value (equivalent of a four slash)
D:($D(RAFDA)\10) UPDATE^DIE("","RAFDA",,)
I $D(DIERR)#2 D
.S RAERR=$$DBS^RAERR("",-9,74.01,RAIENS74)
.N RATXT S RATXT(1)=$P($G(RAERR),U,2)
.S RATXT(2)="Calling Routine: "_$P($G(RAERR),U,3)
.D MM(RA,.RATXT)
.Q
Q $S(($D(RAERR)#2)<0:RAERR,1:0)
;
MM(RAY,RAX) ;call MailMan; let the members of the mail group know
;if a problem exists.
;Input: RAY = file #
; RAX = information passed to RAD HL7 MESSAGES members
;I $$GOTLOCAL^XMXAPIG("RAD HL7 MESSAGES") D
N DIERR,DUZ,RARY,X,XMDUN,XMDUZ,XMMG,XMZ S DUZ=.5,XMDUZ="POSTMASTER"
S XMSUB="NTP releases a case back to the local facility: #"_RAY
S XMTEXT="RAX(",XMY("G.RAD HL7 MESSAGES")="",XMY("POSTMASTER")=""
D ^XMD
Q
;
GETEXM() ;return primary Resident, primary Dx Code & primary Staff data (if any) #70.03
;given: RADFN, RADTI & RACNI
;return: primary Resident (piece 12)^Dx Code (piece 13)^primary Staff (piece 15)
N X S X=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
Q ($P(X,U,12)_U_$P(X,U,13)_U_$P(X,U,15))
;
SECRES ;return secondary Resident data (if any) #70.09 place in #74.19
;given: RADFN, RADTI & RACNI & RAIENS74 (global scope; defined in ACTLOGX)
N RAIEN,RAX,RAY,RAZ S RAX=500,RAY=0
F S RAY=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",RAY)) Q:'RAY D
.S RAZ=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",RAY,0))
.S RAIEN="+"_RAX,RAFDA(74.19,RAIEN_RAIENS74,.01)=$P(RAZ,U)
.S RAX=RAX+1
.Q
Q
;
SECDX ;return secondary Dx Code data (if any) #70.14 place in #74.16
;given: RADFN, RADTI & RACNI & RAIENS74 (global scope; defined in ACTLOGX)
N RAIEN,RAX,RAY,RAZ S RAX=100,RAY=0
F S RAY=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RAY)) Q:'RAY D
.S RAZ=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RAY,0))
.S RAIEN="+"_RAX,RAFDA(74.16,RAIEN_RAIENS74,.01)=$P(RAZ,U)
.S RAX=RAX+1
.Q
Q
;
SECSTF ;return secondary Staff data (if any) #70.11 place in #74.18
;given: RADFN, RADTI & RACNI & RAIENS74 (global scope; defined in ACTLOGX)
N RAIEN,RAX,RAY,RAZ S RAX=300,RAY=0
F S RAY=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",RAY)) Q:'RAY D
.S RAZ=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",RAY,0))
.S RAIEN="+"_RAX,RAFDA(74.18,RAIEN_RAIENS74,.01)=$P(RAZ,U)
.S RAX=RAX+1
.Q
Q
;
EN ;entry point called (from RAHLO) to trigger the logic that updates the
;REPORT STATUS field of a report w/o images to 'deleted'. If the report
;does associate with images the report is to be treated as an imaging
;stub report.
;
Q:RARPT'>0
D REL^RARPTUT(RARPT,.RAERR)
D RELEASE^RAHLRPC ;KLM/p144
Q:$G(RAERR)'=0
;
;RAERR will be defined so if RAERR=0 proceed to update the
;status of the exam. If RAERR'=0 do not update the status of
;the exam.
;
;Update the exam status. RAMDV (set in RAHLO) is a string that
;identifies division specific attributes. 11/NORPT^RASTREQ
;determine whether a report exists (an imaging stub is not
;a report).
;
;Note: exam records are locked within UP1^RAUTL1
I $D(RAMDV)#2,(RAMDV'="") D UP1^RAUTL1
;
;Note - the fact of the matter is this: upon returning to
;RAHLTCPB (which is done after the next 'Q'uit), GENACK is
;called only if an error has occurred. Because of this I
;call GENACK^RAHLTCPB below because there is no error.
K:$G(RAERR)=0 RAERR
D GENACK^RAHLTCPB ; generate 'ACK' message
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRARPTUT 16215 printed Oct 16, 2024@18:39:47 Page 2
RARPTUT ;HISC/GJC - rad/nuc med report utilities ;04 Dec 2017 9:26 AM
+1 ;;5.0;Radiology/Nuclear Medicine;**106,114,144**;Mar 16, 1998;Build 1
+2 ;
+3 ;Integration Agreements
+4 ;----------------------
+5 ;$$FIND^DIC - 2051 (supported)
+6 ;FILE^DIE - 2053 (supported)
+7 ;UPDATE^DIE - 2053 (supported)
+8 ;WP^DIE - 2053 (supported)
+9 ;$$IENS^DILF - 2054 (supported)
+10 ;CLEAN^DILF - 2054 (supported)
+11 ;$$GET1^DIQ - 2056 (supported)
+12 ;
+13 ;Events that cause reports to be deleted or to revert back to a
+14 ;stub form need to make the appropriate case available to be read.
+15 ;
REL(RARPT,RAERR) ;NTP II - mark a report as 'X' (Deleted) or null
+1 ;(mimics 'images collected'). Called when an inbound report has a RESULT
+2 ;STATUS (OBR-25) value of 'VAQ'.
+3 ;
+4 ;Input : RARPT = the IEN of the rad/nuc med report record
+5 ;Output: RAERR = 0 if successful
+6 ; <0 error code^Message text^Error location^Type
+7 ;
+8 ; A positive value of RAERR will not trigger a negative acknowledgment
+9 ; to be broadcast.
+10 ;
+11 SET U="^"
SET RAERR=0
+12 NEW C,RAPARAMS,RATIMOUT,X,Y
SET RATIMOUT=300
+13 ;------------------------------------------------------------------------
+14 ;lock the report record in question. if unsuccessful quit w/error
+15 ;(+1)
SET RAERR=$$LOCKFM^RALOCK(74,RARPT_",",,RATIMOUT)
+16 SET RAERR=$$LOCKERR^RAERR(RAERR,"Rad/Nuc Med Reports file")
+17 ;RAERR = -15^The Rad/Nuc Med Reports file is locked by other user/task. Please try later.
+18 ; ^LOCKERR+1~RAERR^W
+19 IF RAERR
Begin DoDot:1
+20 NEW RATXT
SET RATXT(1)=$PIECE(RAERR,U,2)
SET RATXT(2)="IEN: "_$GET(RARPT,-1)
+21 SET RATXT(3)="Calling Routine: "_$PIECE(RAERR,U,3)
+22 DO MM(74,.RATXT)
+23 QUIT
End DoDot:1
QUIT
+24 ;------------------------------------------------------------------------
+25 ;
+26 ;------------------------------------------------------------------------
CHKSTS ;In order to 'mark as deleted', NTP reports those reports must have a
+1 ;REPORT STATUS of 'R' (RELEASED/NOT VERIFIED). If the report status is
+2 ;not set to 'R' log the error, unlock the report & quit.
+3 ;RAERR="-19^Invalid value of field #5 in file #74, IENS='2317'.^^E"
+4 SET RARPT(0)=$GET(^RARPT(RARPT,0))
+5 IF $PIECE(RARPT(0),U,5)'="R"
Begin DoDot:1
+6 SET RAERR=$$ERROR^RAERR(-19,,74,RARPT,5)
+7 ;(-1)
DO UNLOCKFM^RALOCK(74,RARPT_",")
+8 NEW RATXT
SET RATXT(1)=$PIECE($GET(RAERR),U,2)
+9 SET RATXT(2)=$PIECE($GET(RAERR),U,3)
DO MM(74,.RATXT)
+10 QUIT
End DoDot:1
QUIT
+11 ;------------------------------------------------------------------------
+12 ;
+13 ;------------------------------------------------------------------------
IMG ;Can't 'mark as deleted' a report being held if images have been
+1 ;attached to that report record. Held reports w/images get moved to
+2 ;a null report status.
+3 ; RAIMAGES=1 if images are attached
+4 ; else RAIMAGES=0
+5 NEW RAIMAGES
SET RAIMAGES=$SELECT($ORDER(^RARPT(RARPT,2005,0))>0:1,1:0)
+6 ;------------------------------------------------------------------------
+7 ;
+8 ;------------------------------------------------------------------------
REGEX ;lock at the REGISTERED EXAM (#70.02) record associated with this report
+1 ;piece 2: Patient DFN, piece 3: EXAM DATE/TIME, piece 4: CASE NUMBER
+2 ;>>> Note: RAIEN70 is the IEN string at the 70.02 level. <<<
+3 NEW RACN,RACNI,RADFN,RADTI,RAIEN70,RAX
+4 SET (DA(1),RADFN)=$PIECE(RARPT(0),U,2)
SET (DA,RADTI)=9999999.9999-$PIECE(RARPT(0),U,3)
+5 SET RACN=+$PIECE(RARPT(0),U,4)
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0))
+6 SET RAIEN70=$$IENS^DILF(.DA)
KILL DA
+7 ;(+2)
SET RAERR=$$LOCKFM^RALOCK(70.02,RAIEN70,,RATIMOUT)
+8 SET RAERR=$$LOCKERR^RAERR(RAERR,"Registered Exams Sub-File #70.02")
+9 ;I the case at the REGISTERED EXAMS level is locked
+10 IF RAERR
Begin DoDot:1
+11 ;(-1)
DO UNLOCKFM^RALOCK(74,RARPT_",")
+12 NEW RATXT
SET RATXT(1)=$PIECE($GET(RAERR),U,2)
SET RATXT(2)="IEN(s): "_$GET(RAIEN70,-1)
+13 SET RATXT(3)="Calling Routine: "_$PIECE($GET(RAERR),U,3)
+14 DO MM(74,.RATXT)
+15 QUIT
End DoDot:1
QUIT
+16 ;------------------------------------------------------------------------
+17 ;
+18 ;------------------------------------------------------------------------
RPTXT ;delete the REPORT TEXT (70.03; #17) field value for a exam liked to
+1 ;a report that does not have attached images.
+2 ;>>> Note: RAIENS70 is the IEN string at the 70.03 level. <<<
+3 IF RAIMAGES=0
Begin DoDot:1
+4 ;make sure you consider printsets
+5 SET RADA=0
NEW RAIENS70
+6 FOR
SET RADA=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RADA))
if 'RADA
QUIT
Begin DoDot:2
+7 SET RA7003=$GET(^RADPT(RADFN,"DT",RADTI,"P",RADA,0))
if $PIECE(RA7003,U,17)'=RARPT
QUIT
+8 SET DA=RADA
SET DA(1)=RADTI
SET DA(2)=RADFN
+9 SET RAIENS70=$$IENS^DILF(.DA)
KILL DA
+10 SET RAFDA(70.03,RAIENS70,17)="@"
+11 QUIT
End DoDot:2
+12 IF ($DATA(RAFDA(70.03))\10)
Begin DoDot:2
+13 DO FILE^DIE("","RAFDA")
KILL RA7003,RADA,RAFDA
+14 IF $DATA(DIERR)#2
Begin DoDot:3
+15 ;RAERR="-9^FileMan DBS call error(s); File #70.03;
+16 ;IENS: "1,6917999.9999,76,"^DBS+14~RAERR^E"
+17 SET RAERR=$$DBS^RAERR("",-9,70.03,RAIENS70)
+18 ;(-2)
DO UNLOCKFM^RALOCK(70.02,RAIEN70)
+19 ;(-1)
DO UNLOCKFM^RALOCK(74,RARPT_",")
+20 NEW RATXT
SET RATXT(1)=$PIECE($GET(RAERR),U,2)
+21 SET RATXT(2)="Calling Routine: "_$PIECE($GET(RAERR),U,3)
+22 SET RATXT(3)="Calling subroutine: RPTXT"
+23 DO MM(70.02,.RATXT)
+24 QUIT
End DoDot:3
+25 DO CLEAN^DILF
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
+28 if RAERR
QUIT
+29 ;
PIS ;delete the PRIMARY INTERPRETING STAFF (70.03; #15) field value
+1 ;for a exam liked to a report regardless of whether that report has
+2 ;attached images.
+3 ;>>> Note: RAIENS70 is the IEN string at the 70.03 level. <<<
+4 Begin DoDot:1
+5 ;make sure you consider printsets
+6 SET RADA=0
NEW RAIENS70
+7 FOR
SET RADA=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RADA))
if 'RADA
QUIT
Begin DoDot:2
+8 SET RA7003=$GET(^RADPT(RADFN,"DT",RADTI,"P",RADA,0))
+9 SET DA=RADA
SET DA(1)=RADTI
SET DA(2)=RADFN
+10 SET RAIENS70=$$IENS^DILF(.DA)
KILL DA
+11 SET RAFDA(70.03,RAIENS70,15)="@"
+12 QUIT
End DoDot:2
+13 IF ($DATA(RAFDA(70.03))\10)
Begin DoDot:2
+14 DO FILE^DIE("","RAFDA")
KILL RA7003,RADA,RAFDA
+15 IF $DATA(DIERR)#2
Begin DoDot:3
+16 ;RAERR="-9^FileMan DBS call error(s); File #70.03;
+17 ;IENS: "1,6917999.9999,76,"^DBS+14~RAERR^E"
+18 SET RAERR=$$DBS^RAERR("",-9,70.03,RAIENS70)
+19 ;(-2)
DO UNLOCKFM^RALOCK(70.02,RAIEN70)
+20 ;(-1)
DO UNLOCKFM^RALOCK(74,RARPT_",")
+21 NEW RATXT
SET RATXT(1)=$PIECE($GET(RAERR),U,2)
+22 SET RATXT(2)="Calling Routine: "_$PIECE($GET(RAERR),U,3)
+23 SET RATXT(3)="Calling subroutine: PIS"
+24 DO MM(70.02,.RATXT)
+25 QUIT
End DoDot:3
+26 DO CLEAN^DILF
+27 QUIT
End DoDot:2
+28 QUIT
End DoDot:1
+29 if RAERR
QUIT
+30 ;------------------------------------------------------------------------
+31 ;
+32 ;------------------------------------------------------------------------
BATCH ;if the report does not have associated images check the REPORT BATCHES
+1 ;(#74.2) file for references to the report in question. If there are
+2 ;references to this report those references (pointers) must be deleted.
+3 ;If there is an error within the RA742 function do not quit. The code
+4 ;within RA742 will trigger the correct emails. Continue on and update
+5 ;the REPORT STATUS field.
+6 IF RAIMAGES=0
DO RA742(RARPT)
+7 ;------------------------------------------------------------------------
+8 ;
+9 ;------------------------------------------------------------------------
RSTATUS ;1) set the REPORT STATUS for reports absent of images to 'X'
+1 ; (Deleted)
+2 ; 2) set the REPORT STATUS for reports w/images present to null
+3 ; (mimics 'images collected')
+4 KILL RAFDA
SET RAFDA(74,RARPT_",",5)=$SELECT(RAIMAGES=1:"@",1:"X")
+5 DO FILE^DIE("","RAFDA")
KILL RAFDA
+6 IF $DATA(DIERR)#2
Begin DoDot:1
+7 ;RAERR="-9^FileMan DBS call error(s); File #74;
+8 ;IENS: "2370,"^DBS+14~RAERR^E"
+9 SET RAERR=$$DBS^RAERR("",-9,74,RARPT_",")
+10 ;(-2)
DO UNLOCKFM^RALOCK(70.02,RAIEN70)
+11 ;(-1)
DO UNLOCKFM^RALOCK(74,RARPT_",")
+12 NEW RATXT
SET RATXT(1)=$PIECE($GET(RAERR),U,2)
+13 SET RATXT(2)="Calling Routine: "_$PIECE($GET(RAERR),U,3)
+14 DO MM(74,.RATXT)
+15 QUIT
End DoDot:1
+16 if RAERR
QUIT
+17 ;
IMPRPTXT ;Delete the IMPRESSION TEXT (#300) and REPORT TEXT (#200)
+1 ;for a report record, w/images, being released back to the local
+2 ;facility for interpretation.
+3 IF RAIMAGES=1
DO WP^DIE(74,RARPT_",",300,,"@")
DO WP^DIE(74,RARPT_",",200,,"@")
+4 ;------------------------------------------------------------------------
+5 ;
ACTIVLOG ;update the activity log. If an error occurs here inform the mail group
+1 ;and fall through to the code that unlocks the exam and report records.
+2 ;
+3 ;>>> Note: RAIEN is the record number for the newly created activity log sub-file
+4 ;record. <<<
+5 ;
+6 SET RAIEN=$$ACTLOG()
+7 ;
+8 ;if no error, and there are not images associated with this report build
+9 ;the RAFDA array for Dx Codes, sec. staff & sec. resident & file the data
+10 ;in the proper lower level sub-files.
+11 IF RAIEN>0
IF (RAIMAGES=0)
SET RAERR=$$ACTLOGX(RAIEN)
+12 ;
+13 ;------------------------------------------------------------------------
+14 ;unlock the records
+15 ;(-2)
DO UNLOCKFM^RALOCK(70.02,RAIEN70)
+16 ;(-1)
DO UNLOCKFM^RALOCK(74,RARPT_",")
+17 ;------------------------------------------------------------------------
+18 ;
+19 ;------------------------------------------------------------------------
MAIL ;Whether the event was a success of failure update the users in the RAD
+1 ;HL7 MESSAGES mail group about the change in REPORT STATUS.
+2 SET RARPTSTS=$$GET1^DIQ(74,RARPT_",",5)
+3 if RAERR
SET RAX="NTP failed to release a study back to the local facility."
+4 if 'RAERR
SET RAX="NTP succeeded in releasing a study back to the local facility."
+5 SET RATXT(1)=RAX
SET RATXT(2)=""
+6 SET RATXT(3)="NTP released Rad/Nuc Med Report: "_$PIECE(RARPT(0),U)_"."
+7 SET RATXT(4)="The REPORT STATUS of this report is: "_$SELECT(RARPTSTS'="":RARPTSTS,1:"N/A")
+8 DO MM(74,.RATXT)
KILL RARPTSTS,RATXT,RAX
+9 ;------------------------------------------------------------------------
+10 ;
+11 ;end of main body...
DO CLEAN^DILF
KILL RAIEN
QUIT
+12 ;
+13 ;>>> subroutines follow <<<
+14 ;
RA742(RARPT) ;delete a report (without images) from the REPORT BATCHES (#74.2)
+1 ;REPORTS sub-file
+2 ;Input: RARPT = IEN of the RAD/NUC MED REPORT record
+3 ;;>>> Note: RAIEN742 is the IEN string at the 74.2 level. <<<
+4 IF ($DATA(^RABTCH(74.2,"D",RARPT))\10)
Begin DoDot:1
+5 KILL DA,RA,RAFDA,RAIEN742,RAX
NEW RAY1,RAY2
SET RAY1=0
SET RA=74.2
+6 FOR
SET RAY1=$ORDER(^RABTCH(74.2,"D",RARPT,RAY1))
if RAY1'>0
QUIT
Begin DoDot:2
+7 SET RAY2=0
FOR
SET RAY2=$ORDER(^RABTCH(74.2,"D",RARPT,RAY1,RAY2))
if RAY2'>0
QUIT
Begin DoDot:3
+8 SET DA=RAY2
SET DA(1)=RAY1
SET RAIEN742=$$IENS^DILF(.DA)
KILL DA
+9 ;(+3)
SET RAERR=$$LOCKFM^RALOCK(74.21,RAIEN742,,RATIMOUT)
+10 SET RAERR=$$LOCKERR^RAERR(RAERR,"Report Batches File #74.2")
+11 ;
+12 ;RAERR = -15^The Rad/Nuc Med Reports file is locked by other user/task. Please try later.
+13 ; ^LOCKERR+1~RAERR^W
+14 IF RAERR
Begin DoDot:4
+15 NEW RATXT
SET RATXT(1)=$PIECE($GET(RAERR),U,2)
SET RATXT(2)="IEN: "_$GET(RARPT,-1)
+16 SET RATXT(3)="Calling Routine: "_$PIECE($GET(RAERR),U,3)
+17 DO MM(RA,.RATXT)
+18 QUIT
End DoDot:4
QUIT
+19 ;
+20 SET RAFDA(74.21,RAIEN742,.01)="@"
+21 DO FILE^DIE("","RAFDA")
KILL RAFDA
+22 ;
+23 IF $DATA(DIERR)#2
Begin DoDot:4
+24 ;RAERR="-9^FileMan DBS call error(s); File #74.21;
+25 ;IENS: "1,113,"^DBS+14~RAERR^E"
+26 SET RAERR=$$DBS^RAERR("",-9,74.21,RAIEN742)
+27 NEW RATXT
SET RATXT(1)=$PIECE($GET(RAERR),U,2)
+28 SET RATXT(2)="Calling Routine: "_$PIECE($GET(RAERR),U,3)
+29 DO MM(RA,.RATXT)
+30 QUIT
End DoDot:4
+31 ;(-3)
DO UNLOCKFM^RALOCK(74.21,RAIEN742)
+32 DO CLEAN^DILF
KILL RA,RAIEN742,RAX
+33 QUIT
End DoDot:3
+34 QUIT
End DoDot:2
+35 QUIT
End DoDot:1
+36 QUIT
+37 ;
ACTLOG() ;update the Activity Log (#74.01) whenever a report is
+1 ;has a REPORT STATUS value of DELETED. Remember that printsets
+2 ;share primary/secondary staff, resident & Dx Codes across all
+3 ;studies.
+4 ;
+5 ;Given: RADFN, RADTI, RACNI, RARPT & RAIMAGE (indicates if DELETED)
+6 ;Note: the report record remains locked.
+7 ;>>> Note: RAIENS74 is the IEN string at the 74.01 level. <<<
+8 ;>>> RAIEN "finds" the next available IEN in the Activity Log sub-file <<<
+9 NEW RAERR,RAFDA,RAIEN,RAIENS74,RAUSER,RAY3
+10 SET RAIEN=$ORDER(^RARPT(RARPT,"L",$CHAR(32)),-1)
SET RAIEN=RAIEN+1
+11 SET RAUSER=$$FIND1^DIC(200,,"X","RADIOLOGY,OUTSIDE SERVICE")
+12 SET RAY3=$$GETEXM()
SET RAIENS74="+"_RAIEN_","_RARPT_","
+13 ;to the second
SET RAFDA(74.01,RAIENS74,.01)=$$NOW^XLFDT()
+14 ;QUIT released back to local VAMC
SET RAFDA(74.01,RAIENS74,2)="Q"
+15 ;a tipoff on a NTP action
SET RAFDA(74.01,RAIENS74,3)=$SELECT(RAUSER>0:RAUSER,1:.5)
+16 ;must be "R" (Released/not Verified)
SET RAFDA(74.01,RAIENS74,4)="R"
+17 ;
+18 ;if there are no images linked to this report file primary & secondary
+19 ;Dx Code, resident, & staff into the Activity Log
+20 IF RAIMAGES=0
Begin DoDot:1
+21 ;dx
if $PIECE(RAY3,U,2)
SET RAFDA(74.01,RAIENS74,5)=$PIECE(RAY3,U,2)
+22 ;stf
if $PIECE(RAY3,U,3)
SET RAFDA(74.01,RAIENS74,7)=$PIECE(RAY3,U,3)
+23 ;res
if $PIECE(RAY3,U)
SET RAFDA(74.01,RAIENS74,9)=$PIECE(RAY3,U)
+24 QUIT
End DoDot:1
+25 ;
+26 DO UPDATE^DIE("","RAFDA","RAIEN")
+27 ;if successful RAIEN(RAIEN) is the new record # for 74.01 sub-file
+28 IF $DATA(DIERR)#2
Begin DoDot:1
+29 SET RAERR=$$DBS^RAERR("",-9,74.01,RAIENS74)
+30 NEW RATXT
SET RATXT(1)=$PIECE($GET(RAERR),U,2)
+31 SET RATXT(2)="Calling Routine: "_$PIECE($GET(RAERR),U,3)
+32 DO MM(RA,.RATXT)
+33 QUIT
End DoDot:1
+34 QUIT $SELECT(($DATA(RAERR)#2)<0:RAERR,1:RAIEN(RAIEN))
+35 ;
ACTLOGX(RAIEN) ;update the lower level sub-files...
+1 ;given: RARPT
+2 ;Input: RAIEN is the new record number created @ the 74.01 level
+3 ;>>> Note: RAIENS74 is the IEN string at the 74.01 level. <<<
+4 NEW RA,RAERR,RAFDA,RAIENS74
+5 SET RAIENS74=","_RAIEN_","_RARPT_","
SET RA=74.01
+6 ;build the RAFDA array for Dx Codes, sec. staff & sec. resident
+7 DO SECDX
DO SECSTF
DO SECRES
+8 ;if there's data to be filed, file it. Note: the input transforms
+9 ;are "clean" so I stuff the internal value (equivalent of a four slash)
+10 if ($DATA(RAFDA)\10)
DO UPDATE^DIE("","RAFDA",,)
+11 IF $DATA(DIERR)#2
Begin DoDot:1
+12 SET RAERR=$$DBS^RAERR("",-9,74.01,RAIENS74)
+13 NEW RATXT
SET RATXT(1)=$PIECE($GET(RAERR),U,2)
+14 SET RATXT(2)="Calling Routine: "_$PIECE($GET(RAERR),U,3)
+15 DO MM(RA,.RATXT)
+16 QUIT
End DoDot:1
+17 QUIT $SELECT(($DATA(RAERR)#2)<0:RAERR,1:0)
+18 ;
MM(RAY,RAX) ;call MailMan; let the members of the mail group know
+1 ;if a problem exists.
+2 ;Input: RAY = file #
+3 ; RAX = information passed to RAD HL7 MESSAGES members
+4 ;I $$GOTLOCAL^XMXAPIG("RAD HL7 MESSAGES") D
+5 NEW DIERR,DUZ,RARY,X,XMDUN,XMDUZ,XMMG,XMZ
SET DUZ=.5
SET XMDUZ="POSTMASTER"
+6 SET XMSUB="NTP releases a case back to the local facility: #"_RAY
+7 SET XMTEXT="RAX("
SET XMY("G.RAD HL7 MESSAGES")=""
SET XMY("POSTMASTER")=""
+8 DO ^XMD
+9 QUIT
+10 ;
GETEXM() ;return primary Resident, primary Dx Code & primary Staff data (if any) #70.03
+1 ;given: RADFN, RADTI & RACNI
+2 ;return: primary Resident (piece 12)^Dx Code (piece 13)^primary Staff (piece 15)
+3 NEW X
SET X=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+4 QUIT ($PIECE(X,U,12)_U_$PIECE(X,U,13)_U_$PIECE(X,U,15))
+5 ;
SECRES ;return secondary Resident data (if any) #70.09 place in #74.19
+1 ;given: RADFN, RADTI & RACNI & RAIENS74 (global scope; defined in ACTLOGX)
+2 NEW RAIEN,RAX,RAY,RAZ
SET RAX=500
SET RAY=0
+3 FOR
SET RAY=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",RAY))
if 'RAY
QUIT
Begin DoDot:1
+4 SET RAZ=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",RAY,0))
+5 SET RAIEN="+"_RAX
SET RAFDA(74.19,RAIEN_RAIENS74,.01)=$PIECE(RAZ,U)
+6 SET RAX=RAX+1
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
SECDX ;return secondary Dx Code data (if any) #70.14 place in #74.16
+1 ;given: RADFN, RADTI & RACNI & RAIENS74 (global scope; defined in ACTLOGX)
+2 NEW RAIEN,RAX,RAY,RAZ
SET RAX=100
SET RAY=0
+3 FOR
SET RAY=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RAY))
if 'RAY
QUIT
Begin DoDot:1
+4 SET RAZ=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RAY,0))
+5 SET RAIEN="+"_RAX
SET RAFDA(74.16,RAIEN_RAIENS74,.01)=$PIECE(RAZ,U)
+6 SET RAX=RAX+1
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
SECSTF ;return secondary Staff data (if any) #70.11 place in #74.18
+1 ;given: RADFN, RADTI & RACNI & RAIENS74 (global scope; defined in ACTLOGX)
+2 NEW RAIEN,RAX,RAY,RAZ
SET RAX=300
SET RAY=0
+3 FOR
SET RAY=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",RAY))
if 'RAY
QUIT
Begin DoDot:1
+4 SET RAZ=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",RAY,0))
+5 SET RAIEN="+"_RAX
SET RAFDA(74.18,RAIEN_RAIENS74,.01)=$PIECE(RAZ,U)
+6 SET RAX=RAX+1
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
EN ;entry point called (from RAHLO) to trigger the logic that updates the
+1 ;REPORT STATUS field of a report w/o images to 'deleted'. If the report
+2 ;does associate with images the report is to be treated as an imaging
+3 ;stub report.
+4 ;
+5 if RARPT'>0
QUIT
+6 DO REL^RARPTUT(RARPT,.RAERR)
+7 ;KLM/p144
DO RELEASE^RAHLRPC
+8 if $GET(RAERR)'=0
QUIT
+9 ;
+10 ;RAERR will be defined so if RAERR=0 proceed to update the
+11 ;status of the exam. If RAERR'=0 do not update the status of
+12 ;the exam.
+13 ;
+14 ;Update the exam status. RAMDV (set in RAHLO) is a string that
+15 ;identifies division specific attributes. 11/NORPT^RASTREQ
+16 ;determine whether a report exists (an imaging stub is not
+17 ;a report).
+18 ;
+19 ;Note: exam records are locked within UP1^RAUTL1
+20 IF $DATA(RAMDV)#2
IF (RAMDV'="")
DO UP1^RAUTL1
+21 ;
+22 ;Note - the fact of the matter is this: upon returning to
+23 ;RAHLTCPB (which is done after the next 'Q'uit), GENACK is
+24 ;called only if an error has occurred. Because of this I
+25 ;call GENACK^RAHLTCPB below because there is no error.
+26 if $GET(RAERR)=0
KILL RAERR
+27 ; generate 'ACK' message
DO GENACK^RAHLTCPB
+28 QUIT
+29 ;
