RAHLO1 ;HIRMFO/GJC/BNT-File rpt (data from bridge program) ;6/25/04 11:49
;;5.0;Radiology/Nuclear Medicine;**4,5,12,17,21,27,48,55,66,87,84,94,104,47**;Mar 16, 1998;Build 21
; 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 = "^")
;Lock an existing report record; quit if unsuccessful. If there is not existing record find
;the next available record number and then lock the record specific global by calling
;$$NEWIEN^RAHLTCPU @ line tag NEW1 (lock is implicit; lock set within $$NEWIEN^RAHLTCPU)
;
I RARPT>0 D LOCKR^RAHLTCPU(.RAERR) Q:$D(RAERR)#2
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) ;unlock the report; remember we locked it right after FILE^RAHLO1
.. D UNVER^RARTE1(RARPT) ;Why the unlock above? Because UNVER^RARTE1 will lock the report
.. S RARPT=RASAV ;RTK 7/28 for RARPT killed in UNVER^RARTE1
.. D LOCKR^RAHLTCPU(.RAERR) ;re-lock the report after UNVER^RARTE1 releases its lock
.. Q
. K:'($D(RAERR)#2) ^RARPT(RARPT,"I"),^("R"),^("H")
. Q
;
; Create a new report record
NEW1 N RARPT S RARPT=$$NEWIEN^RAHLTCPU()
;
;we have a new IEN and the record in locked. Now update that record using UPDATE^DIE
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." L -^RARPT(RARPT) Q
;
LOCK1 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 L -^RARPT(RARPT) Q ;if error, unlock f74 and quit.
.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 needs review
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),($P(RAZ7003,U,RAZPCE)="") S RAFDA(70.03,RAIENS,RAZPCE)=$G(RAVERF)
;
;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 L -^RARPT(RARPT) Q ;if error, unlock f74 and quit.
.N RAFIELD S RAFIELD=$G(RAERR("DIERR",1,"PARAM","FIELD"))
.S RAERR="Error: IENs = "_RAIENS_"; file:70.03; field: "_RAFIELD_" value: "_$S(RAFIELD=13:RADX,RAFIELD=12:RAZRES,RAFIELD=15:RAZSTF,1:RARPT)
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)
F S RA7=$O(RAMEMARR(RA7)) Q:RA7="" I RACNISAV'=RA7 S RACNI=RA7 D UPMEM^RAHLO4 I $D(RASECDX),('$D(RADENDUM)#2) 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
;
L -^RARPT(RARPT) ;unlock the report locked at FILE (existing rpt) or NEW1 (new rpt)
;
;If verified, update report & exam statuses; else, just update exam status
;Note: be careful; exam locks are executed within UP1^RAUTL1!
I $D(RAMDV),RAMDV'="" D:RARPTSTS="V" UPSTAT^RAUTL0 D:RARPTSTS'="V" UP1^RAUTL1
D:'$D(RAERR)&($G(^TMP("RARPT-REC",$J,RASUB,"VENDOR"))'="KURZWEIL") GENACK^RAHLTCPB ; generate 'ACK' message
;
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
;
RAHLO1 ;HIRMFO/GJC/BNT-File rpt (data from bridge program) ;6/25/04 11:49
+1 ;;5.0;Radiology/Nuclear Medicine;**4,5,12,17,21,27,48,55,66,87,84,94,104,47**;Mar 16, 1998;Build 21
+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 ;Lock an existing report record; quit if unsuccessful. If there is not existing record find
+2 ;the next available record number and then lock the record specific global by calling
+3 ;$$NEWIEN^RAHLTCPU @ line tag NEW1 (lock is implicit; lock set within $$NEWIEN^RAHLTCPU)
+4 ;
+5 IF RARPT>0
DO LOCKR^RAHLTCPU(.RAERR)
IF $DATA(RAERR)#2
QUIT
+6 NEW RAFDA,RAIENS
+7 ;
+8 IF '$DATA(ZTQUEUED)
NEW ZTQUEUED
SET ZTQUEUED="1^dummy to suppress screen displays in UP2^RAUTL1 and elsewhere"
+9 IF '$DATA(RAQUIET)
NEW RAQUIET
SET RAQUIET="1^dummy to suppress screen display in PTR^RARTE2"
+10 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
+11 IF '$DATA(RAPRTSET)
NEW RAPRTSET
IF '$DATA(RAMEMARR)
NEW RAMEMARR
+12 ; 04/30/99 always recalculate RAPRTSET
DO EN2^RAUTL20(.RAMEMARR)
+13 ; If the report (stub/real) exists, unverify the existing report... Else create a new report
+14 IF RARPT
IF $DATA(^RARPT(RARPT,0))
SET RASAV=RARPT
Begin DoDot:1
+15 ; must save off RARPT, RAVERF and other RA* variables because
+16 ; they are being killed off somewhere in the 'Unverify A Report'
+17 ; option. 'Unverify A Report' does lock the the report record in file 74!
+18 NEW RADFN,RADTI,RACNI,RARPTSTS,RASSN,RADATE,RALONGCN,RAVERF
+19 ; if report isn't a stub report, then consider it being edited
+20 ;log report receipt event as an edit event
IF '$$STUB^RAEDCN1(RARPT)
SET RAEDIT=1
+21 ;back the report down from verified
IF $DATA(RADENDUM)#2
IF ($PIECE(^RARPT(RARPT,0),U,5)="V")
Begin DoDot:2
+22 ;unlock the report; remember we locked it right after FILE^RAHLO1
LOCK -^RARPT(RARPT)
+23 ;Why the unlock above? Because UNVER^RARTE1 will lock the report
DO UNVER^RARTE1(RARPT)
+24 ;RTK 7/28 for RARPT killed in UNVER^RARTE1
SET RARPT=RASAV
+25 ;re-lock the report after UNVER^RARTE1 releases its lock
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 ;
+30 ; Create a new report record
NEW1 NEW RARPT
SET RARPT=$$NEWIEN^RAHLTCPU()
+1 ;
+2 ;we have a new IEN and the record in locked. Now update that record using UPDATE^DIE
+3 SET RAIENS(1)=RARPT
SET RAFDA(74,"+1,",.01)=RALONGCN
SET RAFDA(74,"+1,",2)=RADFN
+4 ;S RAFDA(74,"+1,",3)=(9999999.9999-RADTI),RAFDA(74,"+1,",4)=$P(RALONGCN,"-",2)
+5 ;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,"-"))
+6 DO UPDATE^DIE("","RAFDA","RAIENS","RAERR")
KILL RAFDA,RAIENS
+7 IF $DATA(RAERR("DIERR"))#2
SET RAERR="Error filing a new record in the RAD/NUC MED REPORTS file."
LOCK -^RARPT(RARPT)
QUIT
+8 ;
LOCK1 IF $DATA(RAESIG)
SET X=RAESIG
SET X1=$GET(RAVERF)
SET X2=RARPT
DO EN^XUSHSHP
SET RAESIG=X
+1 KILL RAFDA,RAIENS
SET RAIENS=RARPT_","
+2 ; rpt status
SET RAFDA(74,RAIENS,5)=RARPTSTS
+3 ;Verifier & Verified date will be set if RAVERF exists for new
+4 ;reports, edits, and addendums. Date rpt entered and reported date
+5 ;will be set for new reports, and not reset for edits and addendums
+6 ; date/time report entered
IF '($DATA(RAEDIT)#2)
IF ($DATA(RADATIME)#2)
SET RAFDA(74,RAIENS,6)=RADATIME
+7 ; v'fied date/time
IF $GET(RAVERF)&(RARPTSTS="V")
SET RAFDA(74,RAIENS,7)=RADATIME
+8 ; reported date
IF $DATA(RADATE)#2
SET RAFDA(74,RAIENS,8)=RADATE
+9 ; v'fying phys
IF $GET(RAVERF)&(RARPTSTS="V")
SET RAFDA(74,RAIENS,9)=RAVERF
+10 ;Teleradiologist name - Patch 84
IF $LENGTH($GET(RATELENM))
SET RAFDA(74,RAIENS,9.1)=RATELENM
+11 ;Teleradiologist NPI - Patch 84
IF $LENGTH($GET(RATELEPI))
SET RAFDA(74,RAIENS,9.2)=RATELEPI
+12 ;esig
SET RAFDA(74,RAIENS,10)=$SELECT($DATA(RAESIG)&(RARPTSTS="V"):RAESIG,1:"")
+13 ; transcriptionist
SET RAFDA(74,RAIENS,11)=$SELECT($GET(RATRANSC):RATRANSC,$GET(RAVERF):RAVERF,1:"")
+14 ;next: status changed to 'verified' by
+15 IF $GET(RAVERF)
IF (RARPTSTS="V")
SET RAFDA(74,RAIENS,17)=$GET(^TMP("RARPT-REC",$JOB,RASUB,"RAWHOCHANGE"))
+16 DO FILE^DIE("","RAFDA","RAERR")
+17 ;if error, unlock f74 and quit.
IF $DATA(RAERR("DIERR"))#2
Begin DoDot:1
+18 SET RAERR="Error filing report record data in the RAD/NUC MED REPORTS file."
+19 ;KILL THE WHOLE RECORD???
+20 QUIT
End DoDot:1
LOCK -^RARPT(RARPT)
QUIT
+21 ;--------------------------------------
+22 ;
+23 ;if case is member of a print set, then create sub-recs for file #74
+24 IF RAPRTSET
Begin DoDot:1
+25 IF '$DATA(RARPTN)
NEW RARPTN
SET RARPTN=RALONGCN
+26 ;create corresponding subrecs in ^RARPT()
NEW RAXIT
DO PTR^RARTE2
+27 QUIT
End DoDot:1
+28 ;--------------------------------------
+29 ;
+30 ;--- start FILE^DIE block for 70.03 ---
+31 ;don't file a Pri. Dx code for teleradiology reports in the released status (P84v11 bus. rule)
+32 SET RARELTEL=$SELECT(($DATA(RATELE)#2)&(RARPTSTS="R"):1,1:"")
+33 ;
+34 ;build the RADFA array to file Dx Code, resident/staff, and the report pointer
+35 ;with a single call to FILE^DIE (silent DBS call)
+36 KILL RAFDA,RAIENS
SET RAIENS=RACNI_","_RADTI_","_RADFN_","
+37 ;
+38 ; 02/08/2008 GJC replaced $G w/($D(RADX)#2) p84
+39 ; 11/15/2007 BAY/KAM RA*5*87 Rem Call 216332 Changed next line to $G
+40 ; 09/07/2005 108405 KAM/BAY Removed('$D(RADENDUM)#2) from next line
+41 IF ($DATA(RADX)#2)
IF RARELTEL=""
Begin DoDot:1
+42 SET RAFDA(70.03,RAIENS,13)=RADX
+43 IF $PIECE(^RA(78.3,+RADX,0),U,4)="y"
SET RAAB=1
+44 QUIT
End DoDot:1
+45 ;
+46 KILL RARELTEL
+47 SET RAZRES=+$GET(^TMP("RARPT-REC",$JOB,RASUB,"RARESIDENT"))
+48 SET RAZSTF=+$GET(^TMP("RARPT-REC",$JOB,RASUB,"RASTAFF"))
+49 ;
+50 IF '($DATA(RADENDUM)#2)
IF (RAZRES!(RAZSTF))
Begin DoDot:1
+51 IF $DATA(^VA(200,"ARC","R",RAZRES))
SET RAFDA(70.03,RAIENS,12)=RAZRES
+52 IF $DATA(^VA(200,"ARC","S",RAZSTF))
SET RAFDA(70.03,RAIENS,15)=RAZSTF
+53 QUIT
End DoDot:1
+54 ;
+55 ;the following business rule needs review
SET RAZ7003=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+56 SET RAZPCE=$SELECT($DATA(^VA(200,"ARC","S",+$GET(RAVERF))):15,$DATA(^VA(200,"ARC","R",+$GET(RAVERF))):12,1:"")
+57 IF '($DATA(RADENDUM)#2)
IF (RAZPCE)
IF ($PIECE(RAZ7003,U,RAZPCE)="")
SET RAFDA(70.03,RAIENS,RAZPCE)=$GET(RAVERF)
+58 ;
+59 ;file the report pointer w/the exam record
+60 SET RAFDA(70.03,RAIENS,17)=RARPT
+61 DO FILE^DIE(,"RAFDA","RAERR")
+62 ;if error, unlock f74 and quit.
IF $DATA(RAERR("DIERR"))#2
Begin DoDot:1
+63 NEW RAFIELD
SET RAFIELD=$GET(RAERR("DIERR",1,"PARAM","FIELD"))
+64 SET RAERR="Error: IENs = "_RAIENS_"; file:70.03; field: "_RAFIELD_" value: "_$SELECT(RAFIELD=13:RADX,RAFIELD=12:RAZRES,RAFIELD=15:RAZSTF,1:RARPT)
End DoDot:1
LOCK -^RARPT(RARPT)
QUIT
+65 KILL RAFDA,RAIENS,RAZ7003,RAZPCE,RAZRES,RAZSTF
+66 ;---- end FILE^DIE block for 70.03 ----
+67 ;
+68 ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx
+69 IF $DATA(RASECDX)
Begin DoDot:1
+70 NEW RAX
SET RAX=0
+71 FOR
SET RAX=$ORDER(RASECDX(RAX))
IF RAX'>0
QUIT
Begin DoDot:2
+72 IF $PIECE(^RA(78.3,+RAX,0),U,4)="y"
SET RAAB=1
End DoDot:2
End DoDot:1
+73 ;
+74 ; file impression text if present & not an addendum
+75 IF '$DATA(RADENDUM)
Begin DoDot:1
+76 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))
+77 IF J
SET ^RARPT(RARPT,"I",0)="^^"_J_U_J_U_RADATE
+78 QUIT
End DoDot:1
+79 ; file report text if present & not an addendum
+80 IF '$DATA(RADENDUM)
Begin DoDot:1
+81 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))
+82 IF J
SET ^RARPT(RARPT,"R",0)="^^"_J_U_J_U_RADATE
+83 QUIT
End DoDot:1
+84 ; if addendum, add addendum text to impression or report
+85 ; 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
+86 ;
+87 ; Check for History from Dictation
+88 ; If history sent, check if previous history exists. If previous
+89 ; history then current history will follow adding 'Addendum:' before
+90 ; the text.
+91 IF $ORDER(^TMP("RARPT-REC",$JOB,RASUB,"RAHIST",0))
Begin DoDot:1
+92 SET RACNT=+$ORDER(^RARPT(RARPT,"H",9999999),-1)
SET RAHSTNDE=RACNT+1
+93 SET RANEW=$SELECT(RACNT>0:0,1:1)
+94 SET I=0
FOR
SET I=$ORDER(^TMP("RARPT-REC",$JOB,RASUB,"RAHIST",I))
IF I'>0
QUIT
Begin DoDot:2
+95 SET RACNT=RACNT+1
+96 SET RALN=$GET(^TMP("RARPT-REC",$JOB,RASUB,"RAHIST",I))
+97 ; if the first line, append 'Addendum:'
IF 'RANEW&(I=$ORDER(^TMP("RARPT-REC",$JOB,RASUB,"RAHIST",0)))
SET RALN="Addendum: "_RALN
+98 IF (RAHSTNDE=RACNT)
IF (RACNT>1)
SET ^RARPT(RARPT,"H",RACNT,0)=" "
SET RACNT=RACNT+1
+99 SET ^RARPT(RARPT,"H",RACNT,0)=RALN
+100 QUIT
End DoDot:2
+101 SET ^RARPT(RARPT,"H",0)="^^"_RACNT_U_RACNT_U_RADATE
+102 QUIT
End DoDot:1
+103 ;
+104 ; women's health
IF $PIECE(^RARPT(RARPT,0),U,5)="V"
IF $TEXT(CREATE^WVRALINK)]""
DO CREATE^WVRALINK(RADFN,RADTI,RACNI)
+105 ; the next section is for printsets only
IF 'RAPRTSET
GOTO UPACT
+106 ; copy DX (prim & sec), Prim Resid, Prim Staff
+107 NEW RACNISAV,RA7
+108 ;prim dx, prim resid, prim staff, rpt pointer
NEW RA13,RA12,RA15
+109 SET RACNISAV=RACNI
SET RA7=0
+110 SET RA13=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13)
SET RA12=$PIECE(^(0),U,12)
SET RA15=$PIECE(^(0),U,15)
+111 FOR
SET RA7=$ORDER(RAMEMARR(RA7))
IF RA7=""
QUIT
IF RACNISAV'=RA7
SET RACNI=RA7
DO UPMEM^RAHLO4
IF $DATA(RASECDX)
IF ('$DATA(RADENDUM)#2)
DO SECDX^RAHLO2
+112 SET RACNI=RACNISAV
+113 ;
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 ;unlock the report locked at FILE (existing rpt) or NEW1 (new rpt)
LOCK -^RARPT(RARPT)
+12 ;
+13 ;If verified, update report & exam statuses; else, just update exam status
+14 ;Note: be careful; exam locks are executed within UP1^RAUTL1!
+15 IF $DATA(RAMDV)
IF RAMDV'=""
IF RARPTSTS="V"
DO UPSTAT^RAUTL0
IF RARPTSTS'="V"
DO UP1^RAUTL1
+16 ; generate 'ACK' message
IF '$DATA(RAERR)&($GET(^TMP("RARPT-REC",$JOB,RASUB,"VENDOR"))'="KURZWEIL")
DO GENACK^RAHLTCPB
+17 ;
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 ;
