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

RAHLO1.m

Go to the documentation of this file. 
  1. 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
  1.  ; 12/15/2009 BAY/KAM RA*5*104 Rem Call 359702 On-line Verification issue
  1.  ; 11/15/2007 BAY/KAM RA*5*87 Rem Call 216332 Correct UNDEF on null dx code
  1.  ; 09/07/2005 108405 - KAM/BAY Allow Radiology to accept dx codes from Talk Technology
  1.  ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx
  1.  ;
  1.  ;Integration Agreements
  1.  ;----------------------
  1.  ;DIE(10018); ,FILE/UPDATE^DIE(2053); CREATE^WVRALINK(4793); $$NOW^XLFDT(10103)
  1.  ;EN^XUSHSHP(10045)
  1.  ;
  1. 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
  1.  ;the next available record number and then lock the record specific global by calling
  1.  ;$$NEWIEN^RAHLTCPU @ line tag NEW1 (lock is implicit; lock set within $$NEWIEN^RAHLTCPU)
  1.  ;
  1.  I RARPT>0 D LOCKR^RAHLTCPU(.RAERR) Q:$D(RAERR)#2
  1.  N RAFDA,RAIENS
  1.  ;
  1.  I '$D(ZTQUEUED) N ZTQUEUED S ZTQUEUED="1^dummy to suppress screen displays in UP2^RAUTL1 and elsewhere"
  1.  I '$D(RAQUIET) N RAQUIET S RAQUIET="1^dummy to suppress screen display in PTR^RARTE2"
  1.  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
  1.  N:'$D(RAPRTSET) RAPRTSET N:'$D(RAMEMARR) RAMEMARR
  1.  D EN2^RAUTL20(.RAMEMARR) ; 04/30/99 always recalculate RAPRTSET
  1.  ; If the report (stub/real) exists, unverify the existing report... Else create a new report
  1.  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
  1.  . ; must save off RARPT, RAVERF and other RA* variables because
  1.  . ; they are being killed off somewhere in the 'Unverify A Report'
  1.  . ; option. 'Unverify A Report' does lock the the report record in file 74!
  1.  . N RADFN,RADTI,RACNI,RARPTSTS,RASSN,RADATE,RALONGCN,RAVERF
  1.  . ; if report isn't a stub report, then consider it being edited
  1.  . S:'$$STUB^RAEDCN1(RARPT) RAEDIT=1 ;log report receipt event as an edit event
  1.  . I $D(RADENDUM)#2,($P(^RARPT(RARPT,0),U,5)="V") D  Q  ;back the report down from verified
  1.  .. L -^RARPT(RARPT) ;unlock the report; remember we locked it right after FILE^RAHLO1
  1.  .. D UNVER^RARTE1(RARPT) ;Why the unlock above? Because UNVER^RARTE1 will lock the report
  1.  .. S RARPT=RASAV  ;RTK 7/28 for RARPT killed in UNVER^RARTE1
  1.  .. D LOCKR^RAHLTCPU(.RAERR) ;re-lock the report after UNVER^RARTE1 releases its lock
  1.  .. Q
  1.  . K:'($D(RAERR)#2) ^RARPT(RARPT,"I"),^("R"),^("H")
  1.  . Q
  1.  ;
  1.  ; Create a new report record
  1. NEW1 N RARPT S RARPT=$$NEWIEN^RAHLTCPU()
  1.  ;
  1.  ;we have a new IEN and the record in locked. Now update that record using UPDATE^DIE
  1.  S RAIENS(1)=RARPT,RAFDA(74,"+1,",.01)=RALONGCN,RAFDA(74,"+1,",2)=RADFN
  1.  ;S RAFDA(74,"+1,",3)=(9999999.9999-RADTI),RAFDA(74,"+1,",4)=$P(RALONGCN,"-",2)
  1.  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
  1.  D UPDATE^DIE("","RAFDA","RAIENS","RAERR") K RAFDA,RAIENS
  1.  I $D(RAERR("DIERR"))#2 S RAERR="Error filing a new record in the RAD/NUC MED REPORTS file."  L -^RARPT(RARPT) Q
  1.  ;
  1. LOCK1 I $D(RAESIG) S X=RAESIG,X1=$G(RAVERF),X2=RARPT D EN^XUSHSHP S RAESIG=X
  1.  K RAFDA,RAIENS S RAIENS=RARPT_","
  1.  S RAFDA(74,RAIENS,5)=RARPTSTS ; rpt status
  1.  ;Verifier & Verified date will be set if RAVERF exists for new
  1.  ;reports, edits, and addendums.  Date rpt entered and reported date
  1.  ;will be set for new reports, and not reset for edits and addendums
  1.  I '($D(RAEDIT)#2),($D(RADATIME)#2) S RAFDA(74,RAIENS,6)=RADATIME ; date/time report entered
  1.  I $G(RAVERF)&(RARPTSTS="V") S RAFDA(74,RAIENS,7)=RADATIME ; v'fied date/time
  1.  I $D(RADATE)#2 S RAFDA(74,RAIENS,8)=RADATE ; reported date
  1.  I $G(RAVERF)&(RARPTSTS="V") S RAFDA(74,RAIENS,9)=RAVERF ; v'fying phys
  1.  S:$L($G(RATELENM)) RAFDA(74,RAIENS,9.1)=RATELENM ;Teleradiologist name - Patch 84
  1.  S:$L($G(RATELEPI)) RAFDA(74,RAIENS,9.2)=RATELEPI ;Teleradiologist NPI  - Patch 84
  1.  S RAFDA(74,RAIENS,10)=$S($D(RAESIG)&(RARPTSTS="V"):RAESIG,1:"") ;esig
  1.  S RAFDA(74,RAIENS,11)=$S($G(RATRANSC):RATRANSC,$G(RAVERF):RAVERF,1:"") ; transcriptionist
  1.  ;next: status changed to 'verified' by
  1.  I $G(RAVERF),(RARPTSTS="V") S RAFDA(74,RAIENS,17)=$G(^TMP("RARPT-REC",$J,RASUB,"RAWHOCHANGE"))
  1.  D FILE^DIE("","RAFDA","RAERR")
  1.  I $D(RAERR("DIERR"))#2 D  L -^RARPT(RARPT) Q  ;if error, unlock f74 and quit.
  1.  .S RAERR="Error filing report record data in the RAD/NUC MED REPORTS file."
  1.  .;KILL THE WHOLE RECORD???
  1.  .Q
  1.  ;--------------------------------------
  1.  ;
  1.  ;if case is member of a print set, then create sub-recs for file #74
  1.  I RAPRTSET D
  1.  .I '$D(RARPTN) N RARPTN S RARPTN=RALONGCN
  1.  .N RAXIT D PTR^RARTE2 ;create corresponding subrecs in ^RARPT()
  1.  .Q
  1.  ;--------------------------------------
  1.  ;
  1.  ;--- start FILE^DIE block for 70.03 ---
  1.  ;don't file a Pri. Dx code for teleradiology reports in the released status (P84v11 bus. rule)
  1.  S RARELTEL=$S(($D(RATELE)#2)&(RARPTSTS="R"):1,1:"")
  1.  ;
  1.  ;build the RADFA array to file Dx Code, resident/staff, and the report pointer
  1.  ;with a single call to FILE^DIE (silent DBS call)
  1.  K RAFDA,RAIENS S RAIENS=RACNI_","_RADTI_","_RADFN_","
  1.  ;
  1.  ; 02/08/2008 GJC replaced $G w/($D(RADX)#2) p84
  1.  ; 11/15/2007 BAY/KAM RA*5*87 Rem Call 216332 Changed next line to $G
  1.  ; 09/07/2005 108405 KAM/BAY Removed('$D(RADENDUM)#2) from next line
  1.  I ($D(RADX)#2),RARELTEL="" D
  1.  .S RAFDA(70.03,RAIENS,13)=RADX
  1.  .S:$P(^RA(78.3,+RADX,0),U,4)="y" RAAB=1
  1.  .Q
  1.  ;
  1.  K RARELTEL
  1.  S RAZRES=+$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT"))
  1.  S RAZSTF=+$G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF"))
  1.  ;
  1.  I '($D(RADENDUM)#2),(RAZRES!(RAZSTF)) D
  1.  .S:$D(^VA(200,"ARC","R",RAZRES)) RAFDA(70.03,RAIENS,12)=RAZRES
  1.  .S:$D(^VA(200,"ARC","S",RAZSTF)) RAFDA(70.03,RAIENS,15)=RAZSTF
  1.  .Q
  1.  ;
  1.  S RAZ7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) ;the following business rule needs review
  1.  S RAZPCE=$S($D(^VA(200,"ARC","S",+$G(RAVERF))):15,$D(^VA(200,"ARC","R",+$G(RAVERF))):12,1:"")
  1.  I '($D(RADENDUM)#2),(RAZPCE),($P(RAZ7003,U,RAZPCE)="") S RAFDA(70.03,RAIENS,RAZPCE)=$G(RAVERF)
  1.  ;
  1.  ;file the report pointer w/the exam record
  1.  S RAFDA(70.03,RAIENS,17)=RARPT
  1.  D FILE^DIE(,"RAFDA","RAERR")
  1.  I $D(RAERR("DIERR"))#2 D  L -^RARPT(RARPT) Q  ;if error, unlock f74 and quit.
  1.  .N RAFIELD S RAFIELD=$G(RAERR("DIERR",1,"PARAM","FIELD"))
  1.  .S RAERR="Error: IENs = "_RAIENS_"; file:70.03; field: "_RAFIELD_" value: "_$S(RAFIELD=13:RADX,RAFIELD=12:RAZRES,RAFIELD=15:RAZSTF,1:RARPT)
  1.  K RAFDA,RAIENS,RAZ7003,RAZPCE,RAZRES,RAZSTF
  1.  ;---- end FILE^DIE block for 70.03 ----
  1.  ;
  1.  ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx
  1.  I $D(RASECDX) D
  1.  . N RAX S RAX=0
  1.  . F  S RAX=$O(RASECDX(RAX)) Q:RAX'>0  D
  1.  .. S:$P(^RA(78.3,+RAX,0),U,4)="y" RAAB=1
  1.  ;
  1.  ; file impression text if present & not an addendum
  1.  I '$D(RADENDUM) D
  1.  . 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))
  1.  . S:J ^RARPT(RARPT,"I",0)="^^"_J_U_J_U_RADATE
  1.  . Q
  1.  ; file report text if present & not an addendum
  1.  I '$D(RADENDUM) D
  1.  . 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))
  1.  . S:J ^RARPT(RARPT,"R",0)="^^"_J_U_J_U_RADATE
  1.  . Q
  1.  ; if addendum, add addendum text to impression or report
  1.  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
  1.  ;
  1.  ; Check for History from Dictation
  1.  ; If history sent, check if previous history exists.  If previous
  1.  ; history then current history will follow adding 'Addendum:' before 
  1.  ; the text.
  1.  I $O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",0)) D
  1.  . S RACNT=+$O(^RARPT(RARPT,"H",9999999),-1),RAHSTNDE=RACNT+1
  1.  . S RANEW=$S(RACNT>0:0,1:1)
  1.  . S I=0 F  S I=$O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",I)) Q:I'>0  D
  1.  . . S RACNT=RACNT+1
  1.  . . S RALN=$G(^TMP("RARPT-REC",$J,RASUB,"RAHIST",I))
  1.  . . S:'RANEW&(I=$O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",0))) RALN="Addendum: "_RALN ; if the first line, append 'Addendum:'
  1.  . . I (RAHSTNDE=RACNT),(RACNT>1) S ^RARPT(RARPT,"H",RACNT,0)=" ",RACNT=RACNT+1
  1.  . . S ^RARPT(RARPT,"H",RACNT,0)=RALN
  1.  . . Q
  1.  . S ^RARPT(RARPT,"H",0)="^^"_RACNT_U_RACNT_U_RADATE
  1.  . Q
  1.  ;
  1.  I $P(^RARPT(RARPT,0),U,5)="V",$T(CREATE^WVRALINK)]"" D CREATE^WVRALINK(RADFN,RADTI,RACNI) ; women's health
  1.  G:'RAPRTSET UPACT ; the next section is for printsets only
  1.  ; copy DX (prim & sec), Prim Resid, Prim Staff
  1.  N RACNISAV,RA7
  1.  N RA13,RA12,RA15 ;prim dx, prim resid, prim staff, rpt pointer
  1.  S RACNISAV=RACNI,RA7=0
  1.  S RA13=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13),RA12=$P(^(0),U,12),RA15=$P(^(0),U,15)
  1.  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
  1.  S RACNI=RACNISAV
  1.  ;
  1. UPACT ;Update the Activity Log (74.01) w/DBS call
  1.  K RAIENS,RAFDA S RAIENS="+1,"_RARPT_","
  1.  S RAFDA(74.01,RAIENS,.01)=$E($$NOW^XLFDT(),1,12)
  1.  S RAFDA(74.01,RAIENS,2)=$S(RARPTSTS="V":"V",$D(RAEDIT):"E",1:"I")
  1.  S RAFDA(74.01,RAIENS,3)=$S($G(RAVERF):RAVERF,$G(RATRANSC):RATRANSC,1:"")
  1.  D UPDATE^DIE("","RAFDA","RAIENS","") K RAIENS,RAFDA,DIERR,^TMP("DIERR",$J)
  1.  ;
  1.  ; 12/15/2009 BAY/KAM RA*5*104 Changed next line to rebuild indexes
  1.  ;S RAQUEUED=1 ;to be checked in routines "jumped to" from RAHLO1
  1.  S DA=RARPT,DIK="^RARPT(",RAQUEUED=1 D IX^DIK K DA,DIK
  1.  ;
  1.  L -^RARPT(RARPT) ;unlock the report locked at FILE (existing rpt) or NEW1 (new rpt)
  1.  ;
  1.  ;If verified, update report & exam statuses; else, just update exam status
  1.  ;Note: be careful; exam locks are executed within UP1^RAUTL1!
  1.  I $D(RAMDV),RAMDV'="" D:RARPTSTS="V" UPSTAT^RAUTL0 D:RARPTSTS'="V" UP1^RAUTL1
  1.  D:'$D(RAERR)&($G(^TMP("RARPT-REC",$J,RASUB,"VENDOR"))'="KURZWEIL") GENACK^RAHLTCPB ; generate 'ACK' message
  1.  ;
  1. 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
  1.  ;the printer defined in the REPORT PRINTER NAME (#10) field via VOICE^RAHLO4.
  1.  I ($P(^RARPT(RARPT,0),U,5)="V")!($P(^(0),U,5)="R") D TASK^RAHLO4,VOICE^RAHLO4
  1.  ;
  1. KVAR K RAAB,RAEDIT,RAESIG,RAQUEUED,RAHIST
  1.  Q
  1.  ;