RAHLO1 ;HIRMFO/GJC/BNT-File rpt (data from bridge program) ; Jan 06, 2020@15:12:27
;;5.0;Radiology/Nuclear Medicine;**4,5,12,17,21,27,48,55,66,87,84,94,104,47,157,162**;Mar 16, 1998;Build 2
; 12/15/2009 BAY/KAM RA*5*104 Rem Call 359702 On-line Verification issue
; 11/15/2007 BAY/KAM RA*5*87 Rem Call 216332 Correct UNDEF on null dx code
; 09/07/2005 108405 - KAM/BAY Allow Radiology to accept dx codes from Talk Technology
; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx
;
;Integration Agreements
;----------------------
;DIE(10018); ,FILE/UPDATE^DIE(2053); CREATE^WVRALINK(4793); $$NOW^XLFDT(10103)
;EN^XUSHSHP(10045)
;
FILE ;Create entry in file 74 & file data (remember: U = "^")
;An existing report record was locked in RAHLO. If no report, find the next available
;report record number, create the report record and lock it. the software
;locks the new report record by calling $$NEWIEN^RAHLTCPU @ tag NEW1
;
N RAFDA,RAIENS
;
I '$D(ZTQUEUED) N ZTQUEUED S ZTQUEUED="1^dummy to suppress screen displays in UP2^RAUTL1 and elsewhere"
I '$D(RAQUIET) N RAQUIET S RAQUIET="1^dummy to suppress screen display in PTR^RARTE2"
N RADATIME S RADATIME=$$NOW^XLFDT() I $L($P(RADATIME,".",2))>4 S RADATIME=$P(RADATIME,".",1)_"."_$E($P(RADATIME,".",2),1,4) S RADATIME=+RADATIME
N:'$D(RAPRTSET) RAPRTSET N:'$D(RAMEMARR) RAMEMARR
D EN2^RAUTL20(.RAMEMARR) ; 04/30/99 always recalculate RAPRTSET
; If the report (stub/real) exists, unverify the existing report... Else create a new report
I RARPT,$D(^RARPT(RARPT,0)) S RASAV=RARPT D S RARPT=RASAV K RASAV L:$D(RAERR) -^RARPT(RARPT) Q:$D(RAERR) G LOCK1
. ; must save off RARPT, RAVERF and other RA* variables because
. ; they are being killed off somewhere in the 'Unverify A Report'
. ; option. 'Unverify A Report' does lock the the report record in file 74!
. N RADFN,RADTI,RACNI,RARPTSTS,RASSN,RADATE,RALONGCN,RAVERF
. ; if report isn't a stub report, then consider it being edited
. S:'$$STUB^RAEDCN1(RARPT) RAEDIT=1 ;log report receipt event as an edit event
. I $D(RADENDUM)#2,($P(^RARPT(RARPT,0),U,5)="V") D Q ;back the report down from verified
.. L -^RARPT(RARPT) ;*** -LR1 unlock the report b/c UNVER^RARTE1 also locks the report ***
.. D UNVER^RARTE1(RARPT)
.. S RARPT=RASAV ;RTK 7/28 for RARPT killed in UNVER^RARTE1
.. S RADUZ=$G(^TMP("RARPT-REC",$J,RASUB,"RAVERF")) ;reset RADUZ for P162
.. D LOCKR^RAHLTCPU(.RAERR) ;*** +LR1 re-lock the report post UNVER^RARTE1 ***
.. Q
. K:'($D(RAERR)#2) ^RARPT(RARPT,"I"),^("R"),^("H")
. Q
;
NEW1 ; The variable RARPT is set to zero in RAHLO. NEWIEN^RAHLTCPU() will
; return a record number in RARPT to used for filing a new report. Use
; UPDATE^DIE to create a report with the record number returned in RARPT.
S RARPT=$$NEWIEN^RAHLTCPU()
;
;*** + LR2 $$NEWIEN^RAHLTCPU() locked the new report record *** P162
S RAIENS(1)=RARPT,RAFDA(74,"+1,",.01)=RALONGCN,RAFDA(74,"+1,",2)=RADFN
;S RAFDA(74,"+1,",3)=(9999999.9999-RADTI),RAFDA(74,"+1,",4)=$P(RALONGCN,"-",2)
S RAFDA(74,"+1,",3)=(9999999.9999-RADTI),RAFDA(74,"+1,",4)=$P(RALONGCN,"-",$L(RALONGCN,"-")) ;format of RALONGCN after P47 could be SSS-DDDDDD-CASE# so get LAST "-" piece instead of 2nd piece
D UPDATE^DIE("","RAFDA","RAIENS","RAERR") K RAFDA,RAIENS
I $D(RAERR("DIERR"))#2 S RAERR="Error filing a new record in the RAD/NUC MED REPORTS file." Q ;report is unlocked upon return to RAHLO p162
;
LOCK1 ;jump here if we intend to amend an existing report
I $D(RAESIG) S X=RAESIG,X1=$G(RAVERF),X2=RARPT D EN^XUSHSHP S RAESIG=X
K RAFDA,RAIENS S RAIENS=RARPT_","
S RAFDA(74,RAIENS,5)=RARPTSTS ; rpt status
;Verifier & Verified date will be set if RAVERF exists for new
;reports, edits, and addendums. Date rpt entered and reported date
;will be set for new reports, and not reset for edits and addendums
I '($D(RAEDIT)#2),($D(RADATIME)#2) S RAFDA(74,RAIENS,6)=RADATIME ; date/time report entered
I $G(RAVERF)&(RARPTSTS="V") S RAFDA(74,RAIENS,7)=RADATIME ; v'fied date/time
I $D(RADATE)#2 S RAFDA(74,RAIENS,8)=RADATE ; reported date
I $G(RAVERF)&(RARPTSTS="V") S RAFDA(74,RAIENS,9)=RAVERF ; v'fying phys
S:$L($G(RATELENM)) RAFDA(74,RAIENS,9.1)=RATELENM ;Teleradiologist name - Patch 84
S:$L($G(RATELEPI)) RAFDA(74,RAIENS,9.2)=RATELEPI ;Teleradiologist NPI - Patch 84
S RAFDA(74,RAIENS,10)=$S($D(RAESIG)&(RARPTSTS="V"):RAESIG,1:"") ;esig
S RAFDA(74,RAIENS,11)=$S($G(RATRANSC):RATRANSC,$G(RAVERF):RAVERF,1:"") ; transcriptionist
;next: status changed to 'verified' by
I $G(RAVERF),(RARPTSTS="V") S RAFDA(74,RAIENS,17)=$G(^TMP("RARPT-REC",$J,RASUB,"RAWHOCHANGE"))
D FILE^DIE("","RAFDA","RAERR")
I $D(RAERR("DIERR"))#2 D Q ;report is unlocked upon return to RAHLO p162
.S RAERR="Error filing report record data in the RAD/NUC MED REPORTS file."
.;KILL THE WHOLE RECORD???
.Q
;--------------------------------------
;
;if case is member of a print set, then create sub-recs for file #74
I RAPRTSET D
.I '$D(RARPTN) N RARPTN S RARPTN=RALONGCN
.N RAXIT D PTR^RARTE2 ;create corresponding subrecs in ^RARPT()
.Q
;--------------------------------------
;
;--- start FILE^DIE block for 70.03 ---
;don't file a Pri. Dx code for teleradiology reports in the released status (P84v11 bus. rule)
S RARELTEL=$S(($D(RATELE)#2)&(RARPTSTS="R"):1,1:"")
;
;build the RADFA array to file Dx Code, resident/staff, and the report pointer
;with a single call to FILE^DIE (silent DBS call)
K RAFDA,RAIENS S RAIENS=RACNI_","_RADTI_","_RADFN_","
;
; 02/08/2008 GJC replaced $G w/($D(RADX)#2) p84
; 11/15/2007 BAY/KAM RA*5*87 Rem Call 216332 Changed next line to $G
; 09/07/2005 108405 KAM/BAY Removed('$D(RADENDUM)#2) from next line
I ($D(RADX)#2),RARELTEL="" D
.S RAFDA(70.03,RAIENS,13)=RADX
.S:$P(^RA(78.3,+RADX,0),U,4)="y" RAAB=1
.Q
;
K RARELTEL
S RAZRES=+$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT"))
S RAZSTF=+$G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF"))
;
I '($D(RADENDUM)#2),(RAZRES!(RAZSTF)) D
.S:$D(^VA(200,"ARC","R",RAZRES)) RAFDA(70.03,RAIENS,12)=RAZRES
.S:$D(^VA(200,"ARC","S",RAZSTF)) RAFDA(70.03,RAIENS,15)=RAZSTF
.Q
;
S RAZ7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) ;the following business rule WAS reviewed
S RAZPCE=$S($D(^VA(200,"ARC","S",+$G(RAVERF))):15,$D(^VA(200,"ARC","R",+$G(RAVERF))):12,1:"")
I '($D(RADENDUM)#2),(RAZPCE) S RAFDA(70.03,RAIENS,RAZPCE)=$G(RAVERF) ;P162
;
;file the report pointer w/the exam record
S RAFDA(70.03,RAIENS,17)=RARPT
D FILE^DIE(,"RAFDA","RAERR")
I $D(RAERR("DIERR"))#2 D Q ;report is unlocked upon return to RAHLO p162
.N RAFIELD S RAFIELD=$G(RAERR("DIERR",1,"PARAM","FIELD"))
.S RAERR="Error filing report pointer value: "_$G(RARPT,"unknown")
K RAFDA,RAIENS,RAZ7003,RAZPCE,RAZRES,RAZSTF
;---- end FILE^DIE block for 70.03 ----
;
; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx
I $D(RASECDX) D
. N RAX S RAX=0
. F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D
.. S:$P(^RA(78.3,+RAX,0),U,4)="y" RAAB=1
;
; file impression text if present & not an addendum
I '$D(RADENDUM) D
. S J=0 I $O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0)) S I=0 F J=0:1 S I=$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",I)) Q:I'>0 I $D(^(I)) S ^RARPT(RARPT,"I",(J+1),0)=$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",I))
. S:J ^RARPT(RARPT,"I",0)="^^"_J_U_J_U_RADATE
. Q
; file report text if present & not an addendum
I '$D(RADENDUM) D
. S J=0 I $O(^TMP("RARPT-REC",$J,RASUB,"RATXT",0)) S I=0 F J=0:1 S I=$O(^TMP("RARPT-REC",$J,RASUB,"RATXT",I)) Q:I'>0 I $D(^(I)) S ^RARPT(RARPT,"R",(J+1),0)=$G(^TMP("RARPT-REC",$J,RASUB,"RATXT",I))
. S:J ^RARPT(RARPT,"R",0)="^^"_J_U_J_U_RADATE
. Q
; if addendum, add addendum text to impression or report
I $D(RADENDUM),($O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0))!$O(^TMP("RARPT-REC",$J,RASUB,"RATXT",0))) D ADENDUM^RAHLO2 ; store new lines at the end of existing text
;
; Check for History from Dictation
; If history sent, check if previous history exists. If previous
; history then current history will follow adding 'Addendum:' before
; the text.
I $O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",0)) D
. S RACNT=+$O(^RARPT(RARPT,"H",9999999),-1),RAHSTNDE=RACNT+1
. S RANEW=$S(RACNT>0:0,1:1)
. S I=0 F S I=$O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",I)) Q:I'>0 D
. . S RACNT=RACNT+1
. . S RALN=$G(^TMP("RARPT-REC",$J,RASUB,"RAHIST",I))
. . S:'RANEW&(I=$O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",0))) RALN="Addendum: "_RALN ; if the first line, append 'Addendum:'
. . I (RAHSTNDE=RACNT),(RACNT>1) S ^RARPT(RARPT,"H",RACNT,0)=" ",RACNT=RACNT+1
. . S ^RARPT(RARPT,"H",RACNT,0)=RALN
. . Q
. S ^RARPT(RARPT,"H",0)="^^"_RACNT_U_RACNT_U_RADATE
. Q
;
I $P(^RARPT(RARPT,0),U,5)="V",$T(CREATE^WVRALINK)]"" D CREATE^WVRALINK(RADFN,RADTI,RACNI) ; women's health
G:'RAPRTSET UPACT ; the next section is for printsets only
; copy DX (prim & sec), Prim Resid, Prim Staff
N RACNISAV,RA7
N RA13,RA12,RA15 ;prim dx, prim resid, prim staff, rpt pointer
S RACNISAV=RACNI,RA7=0
S RA13=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13),RA12=$P(^(0),U,12),RA15=$P(^(0),U,15)
;KLM/p157 - Remove Addendum check next line (need secondary DX codes updated on all descendants)
F S RA7=$O(RAMEMARR(RA7)) Q:RA7="" I RACNISAV'=RA7 S RACNI=RA7 D UPMEM^RAHLO4 I $D(RASECDX) D SECDX^RAHLO2
S RACNI=RACNISAV
;
UPACT ;Update the Activity Log (74.01) w/DBS call
K RAIENS,RAFDA S RAIENS="+1,"_RARPT_","
S RAFDA(74.01,RAIENS,.01)=$E($$NOW^XLFDT(),1,12)
S RAFDA(74.01,RAIENS,2)=$S(RARPTSTS="V":"V",$D(RAEDIT):"E",1:"I")
S RAFDA(74.01,RAIENS,3)=$S($G(RAVERF):RAVERF,$G(RATRANSC):RATRANSC,1:"")
D UPDATE^DIE("","RAFDA","RAIENS","") K RAIENS,RAFDA,DIERR,^TMP("DIERR",$J)
;
; 12/15/2009 BAY/KAM RA*5*104 Changed next line to rebuild indexes
;S RAQUEUED=1 ;to be checked in routines "jumped to" from RAHLO1
S DA=RARPT,DIK="^RARPT(",RAQUEUED=1 D IX^DIK K DA,DIK
;
;If verified, update report & exam statuses; else, just update exam status
;Be careful; exam locks are executed within both:
;- UPSTAT^RAUTL0
;- UP1^RAUTL1
;
I $D(RAMDV),RAMDV'="" D
.;*** unlock the study & report based on called tag^routines below p162 ***
.L -^RARPT(RARPT) L -^RADPT(RADFN,"DT",RADTI)
.D:RARPTSTS="V" UPSTAT^RAUTL0
.D:RARPTSTS'="V" UP1^RAUTL1
.Q
;
;p162 dropped the check for 'Kurzweil'
D:'$D(RAERR) GENACK^RAHLTCPB
;
PACS ;If there are subscribers to RA RPT xxx events broadcast ORU mesages to those subscribers
;via TASK^RAHLO4. If VOICE DICTATION AUTO-PRINT (#26) field is set to 'Y' print the report to
;the printer defined in the REPORT PRINTER NAME (#10) field via VOICE^RAHLO4.
I ($P(^RARPT(RARPT,0),U,5)="V")!($P(^(0),U,5)="R") D TASK^RAHLO4,VOICE^RAHLO4
;
KVAR K RAAB,RAEDIT,RAESIG,RAQUEUED,RAHIST
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAHLO1 10820 printed Apr 09, 2024@21:41:42 Page 2
RAHLO1 ;HIRMFO/GJC/BNT-File rpt (data from bridge program) ; Jan 06, 2020@15:12:27
+1 ;;5.0;Radiology/Nuclear Medicine;**4,5,12,17,21,27,48,55,66,87,84,94,104,47,157,162**;Mar 16, 1998;Build 2
+2 ; 12/15/2009 BAY/KAM RA*5*104 Rem Call 359702 On-line Verification issue
+3 ; 11/15/2007 BAY/KAM RA*5*87 Rem Call 216332 Correct UNDEF on null dx code
+4 ; 09/07/2005 108405 - KAM/BAY Allow Radiology to accept dx codes from Talk Technology
+5 ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx
+6 ;
+7 ;Integration Agreements
+8 ;----------------------
+9 ;DIE(10018); ,FILE/UPDATE^DIE(2053); CREATE^WVRALINK(4793); $$NOW^XLFDT(10103)
+10 ;EN^XUSHSHP(10045)
+11 ;
FILE ;Create entry in file 74 & file data (remember: U = "^")
+1 ;An existing report record was locked in RAHLO. If no report, find the next available
+2 ;report record number, create the report record and lock it. the software
+3 ;locks the new report record by calling $$NEWIEN^RAHLTCPU @ tag NEW1
+4 ;
+5 NEW RAFDA,RAIENS
+6 ;
+7 IF '$DATA(ZTQUEUED)
NEW ZTQUEUED
SET ZTQUEUED="1^dummy to suppress screen displays in UP2^RAUTL1 and elsewhere"
+8 IF '$DATA(RAQUIET)
NEW RAQUIET
SET RAQUIET="1^dummy to suppress screen display in PTR^RARTE2"
+9 NEW RADATIME
SET RADATIME=$$NOW^XLFDT()
IF $LENGTH($PIECE(RADATIME,".",2))>4
SET RADATIME=$PIECE(RADATIME,".",1)_"."_$EXTRACT($PIECE(RADATIME,".",2),1,4)
SET RADATIME=+RADATIME
+10 if '$DATA(RAPRTSET)
NEW RAPRTSET
if '$DATA(RAMEMARR)
NEW RAMEMARR
+11 ; 04/30/99 always recalculate RAPRTSET
DO EN2^RAUTL20(.RAMEMARR)
+12 ; If the report (stub/real) exists, unverify the existing report... Else create a new report
+13 IF RARPT
IF $DATA(^RARPT(RARPT,0))
SET RASAV=RARPT
Begin DoDot:1
+14 ; must save off RARPT, RAVERF and other RA* variables because
+15 ; they are being killed off somewhere in the 'Unverify A Report'
+16 ; option. 'Unverify A Report' does lock the the report record in file 74!
+17 NEW RADFN,RADTI,RACNI,RARPTSTS,RASSN,RADATE,RALONGCN,RAVERF
+18 ; if report isn't a stub report, then consider it being edited
+19 ;log report receipt event as an edit event
if '$$STUB^RAEDCN1(RARPT)
SET RAEDIT=1
+20 ;back the report down from verified
IF $DATA(RADENDUM)#2
IF ($PIECE(^RARPT(RARPT,0),U,5)="V")
Begin DoDot:2
+21 ;*** -LR1 unlock the report b/c UNVER^RARTE1 also locks the report ***
LOCK -^RARPT(RARPT)
+22 DO UNVER^RARTE1(RARPT)
+23 ;RTK 7/28 for RARPT killed in UNVER^RARTE1
SET RARPT=RASAV
+24 ;reset RADUZ for P162
SET RADUZ=$GET(^TMP("RARPT-REC",$JOB,RASUB,"RAVERF"))
+25 ;*** +LR1 re-lock the report post UNVER^RARTE1 ***
DO LOCKR^RAHLTCPU(.RAERR)
+26 QUIT
End DoDot:2
QUIT
+27 if '($DATA(RAERR)#2)
KILL ^RARPT(RARPT,"I"),^("R"),^("H")
+28 QUIT
End DoDot:1
SET RARPT=RASAV
KILL RASAV
if $DATA(RAERR)
LOCK -^RARPT(RARPT)
if $DATA(RAERR)
QUIT
GOTO LOCK1
+29 ;
NEW1 ; The variable RARPT is set to zero in RAHLO. NEWIEN^RAHLTCPU() will
+1 ; return a record number in RARPT to used for filing a new report. Use
+2 ; UPDATE^DIE to create a report with the record number returned in RARPT.
+3 SET RARPT=$$NEWIEN^RAHLTCPU()
+4 ;
+5 ;*** + LR2 $$NEWIEN^RAHLTCPU() locked the new report record *** P162
+6 SET RAIENS(1)=RARPT
SET RAFDA(74,"+1,",.01)=RALONGCN
SET RAFDA(74,"+1,",2)=RADFN
+7 ;S RAFDA(74,"+1,",3)=(9999999.9999-RADTI),RAFDA(74,"+1,",4)=$P(RALONGCN,"-",2)
+8 ;format of RALONGCN after P47 could be SSS-DDDDDD-CASE# so get LAST "-" piece instead of 2nd piece
SET RAFDA(74,"+1,",3)=(9999999.9999-RADTI)
SET RAFDA(74,"+1,",4)=$PIECE(RALONGCN,"-",$LENGTH(RALONGCN,"-"))
+9 DO UPDATE^DIE("","RAFDA","RAIENS","RAERR")
KILL RAFDA,RAIENS
+10 ;report is unlocked upon return to RAHLO p162
IF $DATA(RAERR("DIERR"))#2
SET RAERR="Error filing a new record in the RAD/NUC MED REPORTS file."
QUIT
+11 ;
LOCK1 ;jump here if we intend to amend an existing report
+1 IF $DATA(RAESIG)
SET X=RAESIG
SET X1=$GET(RAVERF)
SET X2=RARPT
DO EN^XUSHSHP
SET RAESIG=X
+2 KILL RAFDA,RAIENS
SET RAIENS=RARPT_","
+3 ; rpt status
SET RAFDA(74,RAIENS,5)=RARPTSTS
+4 ;Verifier & Verified date will be set if RAVERF exists for new
+5 ;reports, edits, and addendums. Date rpt entered and reported date
+6 ;will be set for new reports, and not reset for edits and addendums
+7 ; date/time report entered
IF '($DATA(RAEDIT)#2)
IF ($DATA(RADATIME)#2)
SET RAFDA(74,RAIENS,6)=RADATIME
+8 ; v'fied date/time
IF $GET(RAVERF)&(RARPTSTS="V")
SET RAFDA(74,RAIENS,7)=RADATIME
+9 ; reported date
IF $DATA(RADATE)#2
SET RAFDA(74,RAIENS,8)=RADATE
+10 ; v'fying phys
IF $GET(RAVERF)&(RARPTSTS="V")
SET RAFDA(74,RAIENS,9)=RAVERF
+11 ;Teleradiologist name - Patch 84
if $LENGTH($GET(RATELENM))
SET RAFDA(74,RAIENS,9.1)=RATELENM
+12 ;Teleradiologist NPI - Patch 84
if $LENGTH($GET(RATELEPI))
SET RAFDA(74,RAIENS,9.2)=RATELEPI
+13 ;esig
SET RAFDA(74,RAIENS,10)=$SELECT($DATA(RAESIG)&(RARPTSTS="V"):RAESIG,1:"")
+14 ; transcriptionist
SET RAFDA(74,RAIENS,11)=$SELECT($GET(RATRANSC):RATRANSC,$GET(RAVERF):RAVERF,1:"")
+15 ;next: status changed to 'verified' by
+16 IF $GET(RAVERF)
IF (RARPTSTS="V")
SET RAFDA(74,RAIENS,17)=$GET(^TMP("RARPT-REC",$JOB,RASUB,"RAWHOCHANGE"))
+17 DO FILE^DIE("","RAFDA","RAERR")
+18 ;report is unlocked upon return to RAHLO p162
IF $DATA(RAERR("DIERR"))#2
Begin DoDot:1
+19 SET RAERR="Error filing report record data in the RAD/NUC MED REPORTS file."
+20 ;KILL THE WHOLE RECORD???
+21 QUIT
End DoDot:1
QUIT
+22 ;--------------------------------------
+23 ;
+24 ;if case is member of a print set, then create sub-recs for file #74
+25 IF RAPRTSET
Begin DoDot:1
+26 IF '$DATA(RARPTN)
NEW RARPTN
SET RARPTN=RALONGCN
+27 ;create corresponding subrecs in ^RARPT()
NEW RAXIT
DO PTR^RARTE2
+28 QUIT
End DoDot:1
+29 ;--------------------------------------
+30 ;
+31 ;--- start FILE^DIE block for 70.03 ---
+32 ;don't file a Pri. Dx code for teleradiology reports in the released status (P84v11 bus. rule)
+33 SET RARELTEL=$SELECT(($DATA(RATELE)#2)&(RARPTSTS="R"):1,1:"")
+34 ;
+35 ;build the RADFA array to file Dx Code, resident/staff, and the report pointer
+36 ;with a single call to FILE^DIE (silent DBS call)
+37 KILL RAFDA,RAIENS
SET RAIENS=RACNI_","_RADTI_","_RADFN_","
+38 ;
+39 ; 02/08/2008 GJC replaced $G w/($D(RADX)#2) p84
+40 ; 11/15/2007 BAY/KAM RA*5*87 Rem Call 216332 Changed next line to $G
+41 ; 09/07/2005 108405 KAM/BAY Removed('$D(RADENDUM)#2) from next line
+42 IF ($DATA(RADX)#2)
IF RARELTEL=""
Begin DoDot:1
+43 SET RAFDA(70.03,RAIENS,13)=RADX
+44 if $PIECE(^RA(78.3,+RADX,0),U,4)="y"
SET RAAB=1
+45 QUIT
End DoDot:1
+46 ;
+47 KILL RARELTEL
+48 SET RAZRES=+$GET(^TMP("RARPT-REC",$JOB,RASUB,"RARESIDENT"))
+49 SET RAZSTF=+$GET(^TMP("RARPT-REC",$JOB,RASUB,"RASTAFF"))
+50 ;
+51 IF '($DATA(RADENDUM)#2)
IF (RAZRES!(RAZSTF))
Begin DoDot:1
+52 if $DATA(^VA(200,"ARC","R",RAZRES))
SET RAFDA(70.03,RAIENS,12)=RAZRES
+53 if $DATA(^VA(200,"ARC","S",RAZSTF))
SET RAFDA(70.03,RAIENS,15)=RAZSTF
+54 QUIT
End DoDot:1
+55 ;
+56 ;the following business rule WAS reviewed
SET RAZ7003=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+57 SET RAZPCE=$SELECT($DATA(^VA(200,"ARC","S",+$GET(RAVERF))):15,$DATA(^VA(200,"ARC","R",+$GET(RAVERF))):12,1:"")
+58 ;P162
IF '($DATA(RADENDUM)#2)
IF (RAZPCE)
SET RAFDA(70.03,RAIENS,RAZPCE)=$GET(RAVERF)
+59 ;
+60 ;file the report pointer w/the exam record
+61 SET RAFDA(70.03,RAIENS,17)=RARPT
+62 DO FILE^DIE(,"RAFDA","RAERR")
+63 ;report is unlocked upon return to RAHLO p162
IF $DATA(RAERR("DIERR"))#2
Begin DoDot:1
+64 NEW RAFIELD
SET RAFIELD=$GET(RAERR("DIERR",1,"PARAM","FIELD"))
+65 SET RAERR="Error filing report pointer value: "_$GET(RARPT,"unknown")
End DoDot:1
QUIT
+66 KILL RAFDA,RAIENS,RAZ7003,RAZPCE,RAZRES,RAZSTF
+67 ;---- end FILE^DIE block for 70.03 ----
+68 ;
+69 ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx
+70 IF $DATA(RASECDX)
Begin DoDot:1
+71 NEW RAX
SET RAX=0
+72 FOR
SET RAX=$ORDER(RASECDX(RAX))
if RAX'>0
QUIT
Begin DoDot:2
+73 if $PIECE(^RA(78.3,+RAX,0),U,4)="y"
SET RAAB=1
End DoDot:2
End DoDot:1
+74 ;
+75 ; file impression text if present & not an addendum
+76 IF '$DATA(RADENDUM)
Begin DoDot:1
+77 SET J=0
IF $ORDER(^TMP("RARPT-REC",$JOB,RASUB,"RAIMP",0))
SET I=0
FOR J=0:1
SET I=$ORDER(^TMP("RARPT-REC",$JOB,RASUB,"RAIMP",I))
if I'>0
QUIT
IF $DATA(^(I))
SET ^RARPT(RARPT,"I",(J+1),0)=$GET(^TMP("RARPT-REC",$JOB,RASUB,"RAIMP",I))
+78 if J
SET ^RARPT(RARPT,"I",0)="^^"_J_U_J_U_RADATE
+79 QUIT
End DoDot:1
+80 ; file report text if present & not an addendum
+81 IF '$DATA(RADENDUM)
Begin DoDot:1
+82 SET J=0
IF $ORDER(^TMP("RARPT-REC",$JOB,RASUB,"RATXT",0))
SET I=0
FOR J=0:1
SET I=$ORDER(^TMP("RARPT-REC",$JOB,RASUB,"RATXT",I))
if I'>0
QUIT
IF $DATA(^(I))
SET ^RARPT(RARPT,"R",(J+1),0)=$GET(^TMP("RARPT-REC",$JOB,RASUB,"RATXT",I))
+83 if J
SET ^RARPT(RARPT,"R",0)="^^"_J_U_J_U_RADATE
+84 QUIT
End DoDot:1
+85 ; if addendum, add addendum text to impression or report
+86 ; store new lines at the end of existing text
IF $DATA(RADENDUM)
IF ($ORDER(^TMP("RARPT-REC",$JOB,RASUB,"RAIMP",0))!$ORDER(^TMP("RARPT-REC",$JOB,RASUB,"RATXT",0)))
DO ADENDUM^RAHLO2
+87 ;
+88 ; Check for History from Dictation
+89 ; If history sent, check if previous history exists. If previous
+90 ; history then current history will follow adding 'Addendum:' before
+91 ; the text.
+92 IF $ORDER(^TMP("RARPT-REC",$JOB,RASUB,"RAHIST",0))
Begin DoDot:1
+93 SET RACNT=+$ORDER(^RARPT(RARPT,"H",9999999),-1)
SET RAHSTNDE=RACNT+1
+94 SET RANEW=$SELECT(RACNT>0:0,1:1)
+95 SET I=0
FOR
SET I=$ORDER(^TMP("RARPT-REC",$JOB,RASUB,"RAHIST",I))
if I'>0
QUIT
Begin DoDot:2
+96 SET RACNT=RACNT+1
+97 SET RALN=$GET(^TMP("RARPT-REC",$JOB,RASUB,"RAHIST",I))
+98 ; if the first line, append 'Addendum:'
if 'RANEW&(I=$ORDER(^TMP("RARPT-REC",$JOB,RASUB,"RAHIST",0)))
SET RALN="Addendum: "_RALN
+99 IF (RAHSTNDE=RACNT)
IF (RACNT>1)
SET ^RARPT(RARPT,"H",RACNT,0)=" "
SET RACNT=RACNT+1
+100 SET ^RARPT(RARPT,"H",RACNT,0)=RALN
+101 QUIT
End DoDot:2
+102 SET ^RARPT(RARPT,"H",0)="^^"_RACNT_U_RACNT_U_RADATE
+103 QUIT
End DoDot:1
+104 ;
+105 ; women's health
IF $PIECE(^RARPT(RARPT,0),U,5)="V"
IF $TEXT(CREATE^WVRALINK)]""
DO CREATE^WVRALINK(RADFN,RADTI,RACNI)
+106 ; the next section is for printsets only
if 'RAPRTSET
GOTO UPACT
+107 ; copy DX (prim & sec), Prim Resid, Prim Staff
+108 NEW RACNISAV,RA7
+109 ;prim dx, prim resid, prim staff, rpt pointer
NEW RA13,RA12,RA15
+110 SET RACNISAV=RACNI
SET RA7=0
+111 SET RA13=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13)
SET RA12=$PIECE(^(0),U,12)
SET RA15=$PIECE(^(0),U,15)
+112 ;KLM/p157 - Remove Addendum check next line (need secondary DX codes updated on all descendants)
+113 FOR
SET RA7=$ORDER(RAMEMARR(RA7))
if RA7=""
QUIT
IF RACNISAV'=RA7
SET RACNI=RA7
DO UPMEM^RAHLO4
IF $DATA(RASECDX)
DO SECDX^RAHLO2
+114 SET RACNI=RACNISAV
+115 ;
UPACT ;Update the Activity Log (74.01) w/DBS call
+1 KILL RAIENS,RAFDA
SET RAIENS="+1,"_RARPT_","
+2 SET RAFDA(74.01,RAIENS,.01)=$EXTRACT($$NOW^XLFDT(),1,12)
+3 SET RAFDA(74.01,RAIENS,2)=$SELECT(RARPTSTS="V":"V",$DATA(RAEDIT):"E",1:"I")
+4 SET RAFDA(74.01,RAIENS,3)=$SELECT($GET(RAVERF):RAVERF,$GET(RATRANSC):RATRANSC,1:"")
+5 DO UPDATE^DIE("","RAFDA","RAIENS","")
KILL RAIENS,RAFDA,DIERR,^TMP("DIERR",$JOB)
+6 ;
+7 ; 12/15/2009 BAY/KAM RA*5*104 Changed next line to rebuild indexes
+8 ;S RAQUEUED=1 ;to be checked in routines "jumped to" from RAHLO1
+9 SET DA=RARPT
SET DIK="^RARPT("
SET RAQUEUED=1
DO IX^DIK
KILL DA,DIK
+10 ;
+11 ;If verified, update report & exam statuses; else, just update exam status
+12 ;Be careful; exam locks are executed within both:
+13 ;- UPSTAT^RAUTL0
+14 ;- UP1^RAUTL1
+15 ;
+16 IF $DATA(RAMDV)
IF RAMDV'=""
Begin DoDot:1
+17 ;*** unlock the study & report based on called tag^routines below p162 ***
+18 LOCK -^RARPT(RARPT)
LOCK -^RADPT(RADFN,"DT",RADTI)
+19 if RARPTSTS="V"
DO UPSTAT^RAUTL0
+20 if RARPTSTS'="V"
DO UP1^RAUTL1
+21 QUIT
End DoDot:1
+22 ;
+23 ;p162 dropped the check for 'Kurzweil'
+24 if '$DATA(RAERR)
DO GENACK^RAHLTCPB
+25 ;
PACS ;If there are subscribers to RA RPT xxx events broadcast ORU mesages to those subscribers
+1 ;via TASK^RAHLO4. If VOICE DICTATION AUTO-PRINT (#26) field is set to 'Y' print the report to
+2 ;the printer defined in the REPORT PRINTER NAME (#10) field via VOICE^RAHLO4.
+3 IF ($PIECE(^RARPT(RARPT,0),U,5)="V")!($PIECE(^(0),U,5)="R")
DO TASK^RAHLO4
DO VOICE^RAHLO4
+4 ;
KVAR KILL RAAB,RAEDIT,RAESIG,RAQUEUED,RAHIST
+1 QUIT
+2 ;
